--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/gtk-marshal.el	Mon Aug 13 11:44:37 2007 +0200
@@ -0,0 +1,289 @@
+(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
+#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"))