Mercurial > hg > xemacs-beta
view lisp/gtk-marshal.el @ 2881:0e0af7cbfd1b
[xemacs-hg @ 2005-08-01 16:28:18 by darrylo]
On some (64-bit) systems, sizeof(int) != sizeof(long), and this can
cause crashes because in-use lisp objects can get prematurely gc'd (and
0xdeadbeef'd). This occurs because the memory_description for the
Gap_Array structure incorrectly describes some members as XD_INT's
(32-bit objects), when they should actually be XD_ELEMCOUNT's and
XD_BYTECOUNT's (both 64-bit objects), as that is how they are declared
in the structure.
author | darrylo |
---|---|
date | Mon, 01 Aug 2005 16:28:21 +0000 |
parents | f981d2fdd880 |
children | db7068430402 |
line wrap: on
line source
;; ;; To regenerate ../src/emacs-marshals.c just load this file. ;; (defconst name-to-return-type '(("INT" . "gint") ("CALLBACK" . "GtkCallback") ("OBJECT" . "GtkObject *") ("POINTER" . "void *") ("STRING" . "gchar *") ("BOOL" . "gboolean") ("DOUBLE" . "gdouble") ("FLOAT" . "gfloat") ("LIST" . "void *") ("NONE" . nil))) (defvar defined-marshallers nil) (defun get-marshaller-name (rval args) (concat "emacs_gtk_marshal_" rval "__" (mapconcat 'identity (or args '("NONE")) "_"))) (defun define-marshaller (rval &rest args) (let ((name nil) (internal-rval (assoc rval name-to-return-type)) (ctr 0) (func-proto (format "__%s_fn" rval))) (if (not internal-rval) (error "Do not know return type of `%s'" rval)) (setq name (get-marshaller-name rval args)) (if (member name defined-marshallers) (error "Attempt to define the same marshaller more than once! %s" name)) (set-buffer (get-buffer-create "emacs-marshals.c")) (goto-char (point-max)) (if (or (member "FLOAT" args) (member "DOUBLE" args)) ;; We need to special case anything with FLOAT in the argument ;; list or the parameters get screwed up royally. (progn (setq func-proto (concat (format "__%s__" rval) (mapconcat 'identity args "_") "_fn")) (insert "typedef " (or (cdr internal-rval) "void") " (*" func-proto ")(" (mapconcat (lambda (x) (cdr (assoc x name-to-return-type))) args ", ") ");\n"))) (insert "\n" "static void\n" name " (ffi_actual_function func, GtkArg *args)\n" "{\n" (format " %s rfunc = (%s) func;\n" func-proto func-proto)) (if (string= "LIST" rval) (setq rval "POINTER")) (if (cdr internal-rval) ;; It has a return type to worry about (insert " " (cdr internal-rval) " *return_val;\n\n" (format " return_val = GTK_RETLOC_%s (args[%d]);\n" rval (length args)) " *return_val = ") (insert " ")) (insert "(*rfunc) (") (while args (if (/= ctr 0) (insert ", ")) (insert (format "GTK_VALUE_%s (args[%d])" (car args) ctr)) (setq args (cdr args) ctr (1+ ctr))) (insert ");\n") (insert "}\n"))) (save-excursion (find-file "../src/emacs-marshals.c") (erase-buffer) (setq defined-marshallers nil) (insert "/* This file was automatically generated by ../lisp/gtk-marshal.el */\n" "/* DO NOT EDIT BY HAND!!! */\n") (insert "#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x)\n\n") (insert "#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x)\n\n") (let ((todo '( ("BOOL" "OBJECT" "INT") ("BOOL" "OBJECT" "OBJECT" "OBJECT") ("BOOL" "OBJECT" "OBJECT") ("BOOL" "OBJECT" "POINTER") ("BOOL" "OBJECT" "STRING") ("BOOL" "OBJECT") ("BOOL" "POINTER" "BOOL") ("BOOL" "POINTER") ("BOOL") ("FLOAT" "OBJECT" "FLOAT") ("FLOAT" "OBJECT") ("INT" "BOOL") ("INT" "OBJECT" "ARRAY") ("INT" "OBJECT" "INT" "ARRAY") ("INT" "OBJECT" "INT" "INT") ("INT" "OBJECT" "INT" "STRING") ("INT" "OBJECT" "INT") ("INT" "OBJECT" "OBJECT") ("INT" "OBJECT" "POINTER" "INT" "INT") ("INT" "OBJECT" "POINTER" "INT") ("INT" "OBJECT" "POINTER") ("INT" "OBJECT" "STRING") ("INT" "OBJECT") ("INT" "POINTER" "INT") ("INT" "POINTER" "STRING" "INT") ("INT" "POINTER" "STRING" "STRING") ("INT" "POINTER" "STRING") ("INT" "POINTER") ("INT" "STRING" "STRING" "INT" "ARRAY") ("INT" "STRING") ("INT") ("LIST" "OBJECT") ("LIST") ("NONE" "BOOL") ("NONE" "INT" "INT" "INT" "INT") ("NONE" "INT" "INT") ("NONE" "INT") ("NONE" "OBJECT" "BOOL" "INT") ("NONE" "OBJECT" "BOOL") ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "BOOL") ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT") ("NONE" "OBJECT" "FLOAT" "FLOAT") ("NONE" "OBJECT" "FLOAT") ("NONE" "OBJECT" "INT" "BOOL") ("NONE" "OBJECT" "INT" "FLOAT" "BOOL") ("NONE" "OBJECT" "INT" "FLOAT") ("NONE" "OBJECT" "INT" "INT" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY") ("NONE" "OBJECT" "INT" "INT" "ARRAY") ("NONE" "OBJECT" "INT" "INT" "FLOAT" "FLOAT") ("NONE" "OBJECT" "INT" "INT" "INT" "INT") ("NONE" "OBJECT" "INT" "INT" "INT") ("NONE" "OBJECT" "INT" "INT" "POINTER" "POINTER") ("NONE" "OBJECT" "INT" "INT" "POINTER") ("NONE" "OBJECT" "INT" "INT" "STRING" "INT" "POINTER" "POINTER") ("NONE" "OBJECT" "INT" "INT" "STRING") ("NONE" "OBJECT" "INT" "INT") ("NONE" "OBJECT" "INT" "OBJECT") ("NONE" "OBJECT" "INT" "POINTER") ("NONE" "OBJECT" "INT" "STRING") ("NONE" "OBJECT" "INT") ("NONE" "OBJECT" "LIST" "INT") ("NONE" "OBJECT" "LIST") ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT") ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL") ("NONE" "OBJECT" "OBJECT" "FLOAT" "INT") ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT" "INT" "INT" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "INT") ("NONE" "OBJECT" "OBJECT" "OBJECT" "INT") ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT" "INT") ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT") ("NONE" "OBJECT" "OBJECT" "OBJECT" "POINTER" "POINTER" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "OBJECT") ("NONE" "OBJECT" "OBJECT" "POINTER") ("NONE" "OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") ("NONE" "OBJECT" "OBJECT" "STRING" "STRING" "INT") ("NONE" "OBJECT" "OBJECT" "STRING" "STRING") ("NONE" "OBJECT" "OBJECT" "STRING") ("NONE" "OBJECT" "OBJECT") ("NONE" "OBJECT" "POINTER" "BOOL") ("NONE" "OBJECT" "POINTER" "INT" "FLOAT" "FLOAT") ("NONE" "OBJECT" "POINTER" "INT" "INT" "INT") ("NONE" "OBJECT" "POINTER" "INT" "INT") ("NONE" "OBJECT" "POINTER" "INT" "POINTER" "POINTER") ("NONE" "OBJECT" "POINTER" "INT" "POINTER") ("NONE" "OBJECT" "POINTER" "INT" "STRING" "INT" "POINTER" "POINTER") ("NONE" "OBJECT" "POINTER" "INT" "STRING") ("NONE" "OBJECT" "POINTER" "INT") ("NONE" "OBJECT" "POINTER" "POINTER" "INT" "INT" "INT" "INT" "INT" "INT") ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER" "STRING" "INT") ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER") ("NONE" "OBJECT" "POINTER" "POINTER") ("NONE" "OBJECT" "POINTER" "STRING" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") ("NONE" "OBJECT" "POINTER") ("NONE" "OBJECT" "STRING" "BOOL") ("NONE" "OBJECT" "STRING" "INT" "INT" "INT") ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT" "INT") ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT") ("NONE" "OBJECT" "STRING" "STRING") ("NONE" "OBJECT" "STRING") ("NONE" "OBJECT") ("NONE" "POINTER" "INT" "INT") ("NONE" "POINTER" "INT") ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT" "INT" "INT") ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT") ("NONE" "POINTER" "POINTER" "INT" "INT" "INT" "INT") ("NONE" "POINTER" "POINTER" "INT" "INT") ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING" "INT") ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING") ("NONE" "POINTER" "POINTER" "POINTER" "POINTER") ("NONE" "POINTER" "POINTER") ("NONE" "POINTER" "STRING" "STRING") ("NONE" "POINTER" "STRING") ("NONE" "POINTER") ("NONE") ("OBJECT" "BOOL" "BOOL" "INT") ("OBJECT" "BOOL" "INT") ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") ("OBJECT" "INT" "ARRAY") ("OBJECT" "INT" "BOOL" "BOOL") ("OBJECT" "INT" "INT" "ARRAY") ("OBJECT" "INT" "INT" "BOOL") ("OBJECT" "INT" "INT" "STRING") ("OBJECT" "INT" "INT") ("OBJECT" "INT") ("OBJECT" "OBJECT" "FLOAT" "INT") ("OBJECT" "OBJECT" "INT") ("OBJECT" "OBJECT" "OBJECT") ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT") ("OBJECT" "OBJECT" "STRING" "INT" "INT") ("OBJECT" "OBJECT" "STRING") ("OBJECT" "OBJECT") ("OBJECT" "POINTER" "POINTER") ("OBJECT" "POINTER" "STRING") ("OBJECT" "POINTER") ("OBJECT" "STRING" "FLOAT" "FLOAT" "FLOAT" "BOOL") ("OBJECT" "STRING" "INT" "STRING" "STRING") ("OBJECT" "STRING" "OBJECT") ("OBJECT" "STRING" "STRING" "STRING" "ARRAY" "STRING" "STRING") ("OBJECT" "STRING" "STRING") ("OBJECT" "STRING") ("OBJECT") ("POINTER" "INT" "INT") ("POINTER" "INT") ("POINTER" "OBJECT" "INT" "INT") ("POINTER" "OBJECT" "INT") ("POINTER" "OBJECT" "POINTER" "INT") ("POINTER" "OBJECT" "POINTER" "POINTER" "ARRAY" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") ("POINTER" "OBJECT" "POINTER") ("POINTER" "OBJECT") ("POINTER" "POINTER") ("POINTER" "STRING" "INT") ("POINTER") ("STRING" "INT" "INT" "INT") ("STRING" "INT") ("STRING" "OBJECT" "BOOL") ("STRING" "OBJECT" "FLOAT") ("STRING" "OBJECT" "INT" "INT") ("STRING" "OBJECT" "INT") ("STRING" "OBJECT") ("STRING" "POINTER" "STRING") ("STRING" "POINTER") ("STRING") ) ) ) (mapc (lambda (x) (apply 'define-marshaller x)) todo) (insert "\n #include \"hash.h\" static struct hash_table *marshaller_hashtable; static void initialize_marshaller_storage (void) { if (!marshaller_hashtable) { marshaller_hashtable = make_string_hash_table (100); ") (mapc (lambda (x) (let ((name (get-marshaller-name (car x) (cdr x)))) (insert (format "\t\tputhash (\"%s\", (void *) %s, marshaller_hashtable);\n" name name)))) todo) (insert "\t};\n" "}\n" " static void *find_marshaller (const char *func_name) { void *fn = NULL; initialize_marshaller_storage (); if (gethash (func_name, marshaller_hashtable, (const void **)&fn)) { return (fn); } return (NULL); } ")) (save-buffer) (kill-buffer "emacs-marshals.c"))