--- /dev/null
+(defconst name-to-return-type
+ '(("INT" . "guint")
+ ("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 "Attempe 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 "#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")
+ ("NONE" "POINTER" "INT" "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" "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\f
+#include \"hash.h\"
+static c_hashtable marshaller_hashtable;
+
+static void initialize_marshaller_storage (void)
+{
+ if (!marshaller_hashtable)
+ {
+ marshaller_hashtable = make_strings_hashtable (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"))
projects / chise / xemacs-chise.git- / blobdiff