Mercurial > hg > xemacs-beta

comparison lisp/gtk-marshal.el @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-46
author cvs
date Mon, 13 Aug 2007 11:44:37 +0200
parents
children ec73ae6e772b
comparison
equal deleted inserted replaced
461:120ed4009e51 462:0784d089fdc9
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
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"))