(U-000216B4): Copied from Ideograph-R038-Woman.el.
[chise/xemacs-chise.git.1] / lisp / gtk-marshal.el
1 (defconst name-to-return-type
2   '(("INT" . "guint")
3     ("CALLBACK" . "GtkCallback")
4     ("OBJECT" . "GtkObject *")
5     ("POINTER" . "void *")
6     ("STRING" . "gchar *")
7     ("BOOL" . "gboolean")
8     ("DOUBLE" . "gdouble")
9     ("FLOAT" . "gfloat")
10     ("LIST"  . "void *")
11     ("NONE" . nil)))
12
13 (defvar defined-marshallers nil)
14
15 (defun get-marshaller-name (rval args)
16   (concat "emacs_gtk_marshal_" rval "__"
17           (mapconcat 'identity (or args '("NONE")) "_")))
18
19 (defun define-marshaller (rval &rest args)
20   (let ((name nil)
21         (internal-rval (assoc rval  name-to-return-type))
22         (ctr 0)
23         (func-proto (format "__%s_fn" rval)))
24     (if (not internal-rval)
25         (error "Do not know return type of `%s'" rval))
26     (setq name (get-marshaller-name rval args))
27
28     (if (member name defined-marshallers)
29         (error "Attempe to define the same marshaller more than once! %s" name))
30
31     (set-buffer (get-buffer-create "emacs-marshals.c"))
32     (goto-char (point-max))
33
34     (if (or (member "FLOAT" args) (member "DOUBLE" args))
35         ;; We need to special case anything with FLOAT in the argument
36         ;; list or the parameters get screwed up royally.
37         (progn
38           (setq func-proto (concat (format "__%s__" rval)
39                                    (mapconcat 'identity args "_")
40                                    "_fn"))
41           (insert "typedef "
42                   (or (cdr internal-rval) "void")
43                   " (*"
44                   func-proto ")("
45                   (mapconcat (lambda (x)
46                                (cdr (assoc x name-to-return-type))) args ", ")
47                   ");\n")))
48
49     (insert "\n"
50             "static void\n"
51             name " (ffi_actual_function func, GtkArg *args)\n"
52             "{\n"
53             (format "  %s rfunc = (%s) func;\n" func-proto func-proto))
54
55     (if (string= "LIST" rval) (setq rval "POINTER"))
56
57     (if (cdr internal-rval)
58         ;; It has a return type to worry about
59         (insert "  " (cdr internal-rval) " *return_val;\n\n"
60                 (format "  return_val = GTK_RETLOC_%s (args[%d]);\n" rval (length args))
61                 "  *return_val = ")
62       (insert "  "))
63     (insert "(*rfunc) (")
64     (while args
65       (if (/= ctr 0)
66           (insert ", "))
67       (insert (format "GTK_VALUE_%s (args[%d])" (car args) ctr))
68       (setq args (cdr args)
69             ctr (1+ ctr)))
70     (insert ");\n")
71     (insert "}\n")))
72
73 (save-excursion
74   (find-file "../../src/emacs-marshals.c")
75   (erase-buffer)
76   (setq defined-marshallers nil)
77
78   (insert "#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x)\n\n")
79   (insert "#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x)\n\n")
80
81   (let ((todo '(
82                 ("BOOL" "OBJECT" "INT")
83                 ("BOOL" "OBJECT" "OBJECT" "OBJECT")
84                 ("BOOL" "OBJECT" "OBJECT")
85                 ("BOOL" "OBJECT" "POINTER")
86                 ("BOOL" "OBJECT" "STRING")
87                 ("BOOL" "OBJECT")
88                 ("BOOL" "POINTER" "BOOL")
89                 ("BOOL" "POINTER")
90                 ("BOOL")
91                 ("FLOAT" "OBJECT" "FLOAT")
92                 ("FLOAT" "OBJECT")
93                 ("INT" "BOOL")
94                 ("INT" "OBJECT" "ARRAY")
95                 ("INT" "OBJECT" "INT" "ARRAY")
96                 ("INT" "OBJECT" "INT" "INT")
97                 ("INT" "OBJECT" "INT" "STRING")
98                 ("INT" "OBJECT" "INT")
99                 ("INT" "OBJECT" "OBJECT")
100                 ("INT" "OBJECT" "POINTER" "INT" "INT")
101                 ("INT" "OBJECT" "POINTER" "INT")
102                 ("INT" "OBJECT" "POINTER")
103                 ("INT" "OBJECT" "STRING")
104                 ("INT" "OBJECT")
105                 ("INT" "POINTER" "INT")
106                 ("INT" "POINTER" "STRING" "INT")
107                 ("INT" "POINTER" "STRING" "STRING")
108                 ("INT" "POINTER" "STRING")
109                 ("INT" "POINTER")
110                 ("INT" "STRING" "STRING" "INT" "ARRAY")
111                 ("INT" "STRING")
112                 ("INT")
113                 ("LIST" "OBJECT")
114                 ("LIST")
115                 ("NONE" "BOOL")
116                 ("NONE" "INT" "INT" "INT" "INT")
117                 ("NONE" "INT" "INT")
118                 ("NONE" "INT")
119                 ("NONE" "OBJECT" "BOOL" "INT")
120                 ("NONE" "OBJECT" "BOOL")
121                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "BOOL")
122                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
123                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT")
124                 ("NONE" "OBJECT" "FLOAT" "FLOAT")
125                 ("NONE" "OBJECT" "FLOAT")
126                 ("NONE" "OBJECT" "INT" "BOOL")
127                 ("NONE" "OBJECT" "INT" "FLOAT" "BOOL")
128                 ("NONE" "OBJECT" "INT" "FLOAT")
129                 ("NONE" "OBJECT" "INT" "INT" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY")
130                 ("NONE" "OBJECT" "INT" "INT" "ARRAY")
131                 ("NONE" "OBJECT" "INT" "INT" "FLOAT" "FLOAT")
132                 ("NONE" "OBJECT" "INT" "INT" "INT" "INT")
133                 ("NONE" "OBJECT" "INT" "INT" "INT")
134                 ("NONE" "OBJECT" "INT" "INT" "POINTER" "POINTER")
135                 ("NONE" "OBJECT" "INT" "INT" "POINTER")
136                 ("NONE" "OBJECT" "INT" "INT" "STRING" "INT" "POINTER" "POINTER")
137                 ("NONE" "OBJECT" "INT" "INT" "STRING")
138                 ("NONE" "OBJECT" "INT" "INT")
139                 ("NONE" "OBJECT" "INT" "OBJECT")
140                 ("NONE" "OBJECT" "INT" "POINTER")
141                 ("NONE" "OBJECT" "INT" "STRING")
142                 ("NONE" "OBJECT" "INT")
143                 ("NONE" "OBJECT" "LIST" "INT")
144                 ("NONE" "OBJECT" "LIST")
145                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT" "INT")
146                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT")
147                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL")
148                 ("NONE" "OBJECT" "OBJECT" "FLOAT" "INT")
149                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT" "INT" "INT" "INT" "INT")
150                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT")
151                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT")
152                 ("NONE" "OBJECT" "OBJECT" "INT" "INT")
153                 ("NONE" "OBJECT" "OBJECT" "INT")
154                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "INT")
155                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT" "INT")
156                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT")
157                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "POINTER" "POINTER" "INT" "INT")
158                 ("NONE" "OBJECT" "OBJECT" "OBJECT")
159                 ("NONE" "OBJECT" "OBJECT" "POINTER")
160                 ("NONE" "OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT")
161                 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING" "INT")
162                 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING")
163                 ("NONE" "OBJECT" "OBJECT" "STRING")
164                 ("NONE" "OBJECT" "OBJECT")
165                 ("NONE" "OBJECT" "POINTER" "BOOL")
166                 ("NONE" "OBJECT" "POINTER" "INT" "FLOAT" "FLOAT")
167                 ("NONE" "OBJECT" "POINTER" "INT" "INT" "INT")
168                 ("NONE" "OBJECT" "POINTER" "INT" "INT")
169                 ("NONE" "OBJECT" "POINTER" "INT" "POINTER" "POINTER")
170                 ("NONE" "OBJECT" "POINTER" "INT" "POINTER")
171                 ("NONE" "OBJECT" "POINTER" "INT" "STRING" "INT" "POINTER" "POINTER")
172                 ("NONE" "OBJECT" "POINTER" "INT" "STRING")
173                 ("NONE" "OBJECT" "POINTER" "INT")
174                 ("NONE" "OBJECT" "POINTER" "POINTER" "INT" "INT" "INT" "INT" "INT" "INT")
175                 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER" "STRING" "INT")
176                 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER")
177                 ("NONE" "OBJECT" "POINTER" "POINTER")
178                 ("NONE" "OBJECT" "POINTER" "STRING" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL")
179                 ("NONE" "OBJECT" "POINTER")
180                 ("NONE" "OBJECT" "STRING" "BOOL")
181                 ("NONE" "OBJECT" "STRING" "INT" "INT" "INT")
182                 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT" "INT")
183                 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT")
184                 ("NONE" "OBJECT" "STRING" "STRING")
185                 ("NONE" "OBJECT" "STRING")
186                 ("NONE" "OBJECT")
187                 ("NONE" "POINTER" "INT")
188                 ("NONE" "POINTER" "INT" "INT")
189                 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT" "INT" "INT")
190                 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT")
191                 ("NONE" "POINTER" "POINTER" "INT" "INT" "INT" "INT")
192                 ("NONE" "POINTER" "POINTER" "INT" "INT")
193                 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING" "INT")
194                 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING")
195                 ("NONE" "POINTER" "POINTER" "POINTER" "POINTER")
196                 ("NONE" "POINTER" "POINTER")
197                 ("NONE" "POINTER" "STRING" "STRING")
198                 ("NONE" "POINTER" "STRING")
199                 ("NONE" "POINTER")
200                 ("NONE")
201                 ("OBJECT" "BOOL" "BOOL" "INT")
202                 ("OBJECT" "BOOL" "INT")
203                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
204                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
205                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
206                 ("OBJECT" "INT" "ARRAY")
207                 ("OBJECT" "INT" "BOOL" "BOOL")
208                 ("OBJECT" "INT" "INT" "ARRAY")
209                 ("OBJECT" "INT" "INT" "BOOL")
210                 ("OBJECT" "INT" "INT" "STRING")
211                 ("OBJECT" "INT" "INT")
212                 ("OBJECT" "INT")
213                 ("OBJECT" "OBJECT" "FLOAT" "INT")
214                 ("OBJECT" "OBJECT" "INT")
215                 ("OBJECT" "OBJECT" "OBJECT")
216                 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT")
217                 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT")
218                 ("OBJECT" "OBJECT" "STRING" "INT" "INT")
219                 ("OBJECT" "OBJECT" "STRING")
220                 ("OBJECT" "OBJECT")
221                 ("OBJECT" "POINTER" "POINTER")
222                 ("OBJECT" "POINTER" "STRING")
223                 ("OBJECT" "POINTER")
224                 ("OBJECT" "STRING" "FLOAT" "FLOAT" "FLOAT" "BOOL")
225                 ("OBJECT" "STRING" "INT" "STRING" "STRING")
226                 ("OBJECT" "STRING" "OBJECT")
227                 ("OBJECT" "STRING" "STRING" "STRING" "ARRAY" "STRING" "STRING")
228                 ("OBJECT" "STRING" "STRING")
229                 ("OBJECT" "STRING")
230                 ("OBJECT")
231                 ("POINTER" "INT" "INT")
232                 ("POINTER" "INT")
233                 ("POINTER" "OBJECT" "INT" "INT")
234                 ("POINTER" "OBJECT" "INT")
235                 ("POINTER" "OBJECT" "POINTER" "INT")
236                 ("POINTER" "OBJECT" "POINTER" "POINTER" "ARRAY" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL")
237                 ("POINTER" "OBJECT" "POINTER")
238                 ("POINTER" "OBJECT")
239                 ("POINTER" "POINTER")
240                 ("POINTER")
241                 ("STRING" "INT" "INT" "INT")
242                 ("STRING" "INT")
243                 ("STRING" "OBJECT" "BOOL")
244                 ("STRING" "OBJECT" "FLOAT")
245                 ("STRING" "OBJECT" "INT" "INT")
246                 ("STRING" "OBJECT" "INT")
247                 ("STRING" "OBJECT")
248                 ("STRING" "POINTER" "STRING")
249                 ("STRING" "POINTER")
250                 ("STRING")
251                 )
252               )
253         )
254     (mapc (lambda (x) (apply 'define-marshaller x)) todo)
255
256     (insert "\n\f
257 #include \"hash.h\"
258 static c_hashtable marshaller_hashtable;
259
260 static void initialize_marshaller_storage (void)
261 {
262         if (!marshaller_hashtable)
263         {
264                 marshaller_hashtable = make_strings_hashtable (100);
265 ")
266     
267     (mapc (lambda (x)
268             (let ((name (get-marshaller-name (car x) (cdr x))))
269               (insert (format "\t\tputhash (\"%s\", (void *) %s, marshaller_hashtable);\n" name name))))
270           todo)
271     (insert "\t};\n"
272             "}\n"
273             "
274 static void *find_marshaller (const char *func_name)
275 {
276         void *fn = NULL;
277         initialize_marshaller_storage ();
278
279         if (gethash (func_name, marshaller_hashtable, (CONST void **)&fn))
280         {
281                 return (fn);
282         }
283
284         return (NULL);
285 }
286 "))
287
288   (save-buffer)
289   (kill-buffer "emacs-marshals.c"))