1 | ;;;; build-gtk.jl -- translate guile-gtk .defs file to rep C code |
---|
2 | ;;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk> |
---|
3 | ;;; $Id: build-gtk.jl,v 1.1.1.1 2000-11-12 06:16:28 ghudson Exp $ |
---|
4 | ;;; |
---|
5 | ;;; This program is free software; you can redistribute it and/or modify |
---|
6 | ;;; it under the terms of the GNU General Public License as published by |
---|
7 | ;;; the Free Software Foundation; either version 2, or (at your option) |
---|
8 | ;;; any later version. |
---|
9 | ;;; |
---|
10 | ;;; This program is distributed in the hope that it will be useful, |
---|
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
13 | ;;; GNU General Public License for more details. |
---|
14 | ;;; |
---|
15 | ;;; You should have received a copy of the GNU General Public License |
---|
16 | ;;; along with this software; see the file COPYING. If not, write to |
---|
17 | ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
---|
18 | |
---|
19 | (provide 'build-gtk) |
---|
20 | |
---|
21 | ;; Notes: |
---|
22 | |
---|
23 | ;; This assumes that the `sed-fix-defs' sed script has been run over all |
---|
24 | ;; input files (to convert schemey things to their lispy equivalents) |
---|
25 | |
---|
26 | ;; Todo: |
---|
27 | ;; * doesn't check for `listable' type-property |
---|
28 | ;; * guile-gtk `struct' and `ptype' types |
---|
29 | ;; * not possible to wrap functions returning vector types |
---|
30 | |
---|
31 | ;; WARNING: This makes some pretty gruesome assumptions. [where?] |
---|
32 | |
---|
33 | |
---|
34 | ;; Configuration |
---|
35 | |
---|
36 | ;; Alist of (TYPE ["C-TYPE" | DECL-FUNC] ["REP2GTK" | FROM-REP-FUNC] |
---|
37 | ;; ["GTK2REP" | TO-REP-FUNC] ["PRED-NAME" | PRED-FUNC] |
---|
38 | ;; . OPTION-ALIST) |
---|
39 | |
---|
40 | ;; The required functions are called as: |
---|
41 | |
---|
42 | ;; (DECL-FUNC TYPE TYPE-INFO) |
---|
43 | ;; (FROM-REP-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS) |
---|
44 | ;; (TO-REP-FUNC OUTPUT-STREAM TYPE "GTK-VAR" TYPE-INFO OPTIONS) |
---|
45 | ;; (PRED-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS) |
---|
46 | |
---|
47 | ;; The options in the OPTION-ALIST may be: |
---|
48 | |
---|
49 | ;; (c2args . EMIT-ARG-FUNC) |
---|
50 | ;; (finish . FINISH-ARG-FUNC) |
---|
51 | ;; (listable . BOOLEAN) |
---|
52 | |
---|
53 | ;; with: |
---|
54 | |
---|
55 | ;; (EMIT-ARG-FUNC OUTPUT TYPE "GTK-VAR" OPTIONS) |
---|
56 | ;; (FINISH-ARG-FUNC OUTPUT TYPE "GTK-VAR" "REP-VAR" OPTIONS) |
---|
57 | |
---|
58 | (defvar gtk-type-alist nil) |
---|
59 | |
---|
60 | (defun define-type (type c-type rep-to-gtk gtk-to-rep type-pred &rest options) |
---|
61 | (setq gtk-type-alist (cons (list* type c-type rep-to-gtk |
---|
62 | gtk-to-rep type-pred options) |
---|
63 | gtk-type-alist))) |
---|
64 | |
---|
65 | |
---|
66 | ;; Work variables |
---|
67 | |
---|
68 | (defvar gtk-enums nil |
---|
69 | "List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs") |
---|
70 | |
---|
71 | (defvar gtk-string-enums nil |
---|
72 | "List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs") |
---|
73 | |
---|
74 | (defvar gtk-flags nil |
---|
75 | "List of (ENUM-NAME . ENUM-DEF) for all parsed flags defs") |
---|
76 | |
---|
77 | (defvar gtk-boxed nil |
---|
78 | "List of (BOXED-NAME . BOXED-DEF)") |
---|
79 | |
---|
80 | (defvar gtk-objects nil |
---|
81 | "List of (OBJECT-NAME . OBJECT-DEF)") |
---|
82 | |
---|
83 | (defvar gtk-functions nil |
---|
84 | "List of (FUNCTION-NAME . FUNCTION-DEF)") |
---|
85 | |
---|
86 | (defvar gtk-options nil |
---|
87 | "List of (OPTION VALUE)") |
---|
88 | |
---|
89 | (defvar gtk-subrs nil |
---|
90 | "List of C-NAME.") |
---|
91 | |
---|
92 | ;; similar for imported files |
---|
93 | (defvar gtk-imported-enums nil) |
---|
94 | (defvar gtk-imported-string-enums nil) |
---|
95 | (defvar gtk-imported-flags nil) |
---|
96 | (defvar gtk-imported-boxed nil) |
---|
97 | (defvar gtk-imported-objects nil) |
---|
98 | |
---|
99 | ;; t when importing secondary definitions |
---|
100 | (defvar gtk-importing nil) |
---|
101 | |
---|
102 | (defmacro gtk-get-options (name options) |
---|
103 | `(cdr (assq ,name ,options))) |
---|
104 | |
---|
105 | (defmacro gtk-get-option (name options) |
---|
106 | `(car (gtk-get-options ,name ,options))) |
---|
107 | |
---|
108 | (defvar gtk-hyphen-map |
---|
109 | (let |
---|
110 | ((map (make-string (1+ ?_))) |
---|
111 | (i 0)) |
---|
112 | (while (< i ?_) |
---|
113 | (aset map i i) |
---|
114 | (setq i (1+ i))) |
---|
115 | (aset map i ?-) |
---|
116 | map)) |
---|
117 | |
---|
118 | (defvar gtk-unhyphen-map |
---|
119 | (let |
---|
120 | ((map (make-string (1+ ?-))) |
---|
121 | (i 0)) |
---|
122 | (while (< i ?-) |
---|
123 | (aset map i i) |
---|
124 | (setq i (1+ i))) |
---|
125 | (aset map i ?_) |
---|
126 | map)) |
---|
127 | |
---|
128 | (defvar gtk-emitted-composite-helpers nil) |
---|
129 | |
---|
130 | |
---|
131 | ;; Entry point |
---|
132 | |
---|
133 | (defun build-gtk (defs-file-name output-file-name) |
---|
134 | (let |
---|
135 | ((gtk-enums nil) |
---|
136 | (gtk-string-enums nil) |
---|
137 | (gtk-flags nil) |
---|
138 | (gtk-boxed nil) |
---|
139 | (gtk-objects nil) |
---|
140 | (gtk-functions nil) |
---|
141 | (gtk-options nil) |
---|
142 | (gtk-subrs nil) |
---|
143 | (gtk-imported-enums nil) |
---|
144 | (gtk-imported-string-enums nil) |
---|
145 | (gtk-imported-flags nil) |
---|
146 | (gtk-imported-boxed nil) |
---|
147 | (gtk-imported-objects nil) |
---|
148 | (gtk-importing nil) |
---|
149 | (gtk-emitted-composite-helpers nil)) |
---|
150 | (let |
---|
151 | ((defs-file (open-file defs-file-name 'read))) |
---|
152 | (or defs-file (error "Can't open input file: %s" defs-file-name)) |
---|
153 | (unwind-protect |
---|
154 | (parse-gtk defs-file) |
---|
155 | (close-file defs-file))) |
---|
156 | (setq gtk-enums (nreverse gtk-enums)) |
---|
157 | (setq gtk-string-enums (nreverse gtk-string-enums)) |
---|
158 | (setq gtk-flags (nreverse gtk-flags)) |
---|
159 | (setq gtk-boxed (nreverse gtk-boxed)) |
---|
160 | (setq gtk-objects (nreverse gtk-objects)) |
---|
161 | (setq gtk-functions (nreverse gtk-functions)) |
---|
162 | (let |
---|
163 | ((output-file (open-file output-file-name 'write))) |
---|
164 | (or output-file (error "Can't open output file: %s" output-file-name)) |
---|
165 | (unwind-protect |
---|
166 | (let |
---|
167 | ((standard-output output-file)) |
---|
168 | (output-gtk output-file)) |
---|
169 | (close-file output-file))))) |
---|
170 | |
---|
171 | (defun build-gtk-batch () |
---|
172 | (or (= (length command-line-args) 2) (error "usage: INPUT OUTPUT")) |
---|
173 | (let |
---|
174 | ((in (car command-line-args)) |
---|
175 | (out (nth 1 command-line-args))) |
---|
176 | (setq command-line-args (nthcdr 2 command-line-args)) |
---|
177 | (build-gtk in out))) |
---|
178 | |
---|
179 | |
---|
180 | ;; Parsing |
---|
181 | |
---|
182 | (defun parse-gtk (input) |
---|
183 | (condition-case nil |
---|
184 | (while t |
---|
185 | (let |
---|
186 | ((def (read input))) |
---|
187 | ;;(format standard-error "read: %S\n" def) |
---|
188 | (when def |
---|
189 | (or (consp def) (error "Definition isn't a list")) |
---|
190 | (cond |
---|
191 | ((memq (car def) '(include import)) |
---|
192 | (let |
---|
193 | ((file (open-file (expand-file-name (nth 1 def) |
---|
194 | (file-name-directory |
---|
195 | (file-binding input))) |
---|
196 | 'read))) |
---|
197 | (or file (error "Can't open input file: %s" (nth 1 def))) |
---|
198 | (unwind-protect |
---|
199 | (if (eq (car def) 'import) |
---|
200 | (let |
---|
201 | ((gtk-importing t)) |
---|
202 | (parse-gtk file)) |
---|
203 | (parse-gtk file)) |
---|
204 | (close-file file)))) |
---|
205 | ((eq (car def) 'define-enum) |
---|
206 | (let* |
---|
207 | ((name (nth 1 def)) |
---|
208 | (body (nthcdr 2 def)) |
---|
209 | (cell (or (assq name gtk-enums) |
---|
210 | (assq name gtk-imported-enums)))) |
---|
211 | (if cell |
---|
212 | (rplacd cell body) |
---|
213 | (if (not gtk-importing) |
---|
214 | (setq gtk-enums (cons (cons name body) gtk-enums)) |
---|
215 | (setq gtk-imported-enums |
---|
216 | (cons (cons name body) gtk-imported-enums)))))) |
---|
217 | ((eq (car def) 'define-string-enum) |
---|
218 | (let* |
---|
219 | ((name (nth 1 def)) |
---|
220 | (body (nthcdr 2 def)) |
---|
221 | (cell (or (assq name gtk-string-enums) |
---|
222 | (assq name gtk-imported-string-enums)))) |
---|
223 | (if cell |
---|
224 | (rplacd cell body) |
---|
225 | (if (not gtk-importing) |
---|
226 | (setq gtk-string-enums (cons (cons name body) |
---|
227 | gtk-string-enums)) |
---|
228 | (setq gtk-imported-string-enums |
---|
229 | (cons (cons name body) |
---|
230 | gtk-imported-string-enums)))))) |
---|
231 | ((eq (car def) 'define-flags) |
---|
232 | (let* |
---|
233 | ((name (nth 1 def)) |
---|
234 | (body (nthcdr 2 def)) |
---|
235 | (cell (or (assq name gtk-flags) |
---|
236 | (assq name gtk-imported-flags)))) |
---|
237 | (if cell |
---|
238 | (rplacd cell body) |
---|
239 | (if (not gtk-importing) |
---|
240 | (setq gtk-flags (cons (cons name body) gtk-flags)) |
---|
241 | (setq gtk-imported-flags |
---|
242 | (cons (cons name body) gtk-imported-flags)))))) |
---|
243 | ((eq (car def) 'define-boxed) |
---|
244 | (let |
---|
245 | ((cell (or (assq (nth 1 def) gtk-boxed) |
---|
246 | (assq (nth 1 def) gtk-imported-boxed)))) |
---|
247 | (if cell |
---|
248 | (rplacd cell (nthcdr 2 def)) |
---|
249 | (if (not gtk-importing) |
---|
250 | (setq gtk-boxed (cons (cdr def) gtk-boxed)) |
---|
251 | (setq gtk-imported-boxed |
---|
252 | (cons (cdr def) gtk-imported-boxed)))))) |
---|
253 | ((eq (car def) 'define-object) |
---|
254 | (let* |
---|
255 | ((name (nth 1 def)) |
---|
256 | (super (nth 2 def)) |
---|
257 | (attrs (nthcdr 3 def)) |
---|
258 | (cell (or (assq name gtk-objects) |
---|
259 | (assq name gtk-imported-objects)))) |
---|
260 | (when (car super) |
---|
261 | (setq attrs (cons (cons 'super (car super)) attrs))) |
---|
262 | (if cell |
---|
263 | (rplacd cell attrs) |
---|
264 | (if (not gtk-importing) |
---|
265 | (setq gtk-objects |
---|
266 | (cons (cons name attrs) gtk-objects)) |
---|
267 | (setq gtk-imported-objects |
---|
268 | (cons (cons name attrs) gtk-imported-objects)))))) |
---|
269 | ((eq (car def) 'define-func) |
---|
270 | (unless gtk-importing |
---|
271 | (let |
---|
272 | ((cell (assq (nth 1 def) gtk-functions))) |
---|
273 | (if cell |
---|
274 | (rplacd cell (nthcdr 2 def)) |
---|
275 | (setq gtk-functions (cons (cdr def) gtk-functions)))))) |
---|
276 | ((eq (car def) 'define-type) |
---|
277 | (eval def)) |
---|
278 | ((eq (car def) 'options) |
---|
279 | (unless gtk-importing |
---|
280 | (mapc (lambda (cell) |
---|
281 | (let |
---|
282 | ((value (assq (car cell) gtk-options))) |
---|
283 | (if value |
---|
284 | (rplacd value (nconc (cdr value) |
---|
285 | (list (nth 1 cell)))) |
---|
286 | (setq gtk-options (cons cell gtk-options))))) |
---|
287 | (cdr def)))) |
---|
288 | ((eq (car def) 'add-options) |
---|
289 | (unless gtk-importing |
---|
290 | (let |
---|
291 | ((value (assq (nth 1 def) gtk-options))) |
---|
292 | (if value |
---|
293 | (rplacd value (nconc (cdr value) (nthcdr 2 def))) |
---|
294 | (setq gtk-options (cons (cdr def) gtk-options)))))) |
---|
295 | (t |
---|
296 | (gtk-warning "Ignoring `%S'" def)))))) |
---|
297 | (end-of-stream))) |
---|
298 | |
---|
299 | |
---|
300 | ;; Code generation |
---|
301 | |
---|
302 | (defmacro @ (&rest args) |
---|
303 | (list* 'format 'output args)) |
---|
304 | |
---|
305 | (defun output-header (output) |
---|
306 | (@ "/* Automatically generated by build-gtk, DO NOT EDIT! */\n\n") |
---|
307 | (when (gtk-get-options 'includes gtk-options) |
---|
308 | (mapc (lambda (opt) |
---|
309 | (@ "%s\n" opt)) |
---|
310 | (gtk-get-options 'includes gtk-options))) |
---|
311 | (@ "#include <rep.h>\n") |
---|
312 | (@ "#include \"rep-gtk.h\"\n\n")) |
---|
313 | |
---|
314 | (defun output-footer (output) |
---|
315 | (let* |
---|
316 | ((feature (gtk-get-option 'provide gtk-options)) |
---|
317 | (c-feature (and feature (gtk-unhyphenate-name (symbol-name feature)))) |
---|
318 | (aliases (gtk-get-options 'alias gtk-options)) |
---|
319 | (init (gtk-get-option 'init-func gtk-options))) |
---|
320 | (when feature |
---|
321 | (@ "\nrepv\nrep_dl_init \(void\)\n{\n") |
---|
322 | (@ " repv s = rep_push_structure \(\"%s\"\);\n" feature) |
---|
323 | (mapc (lambda (a) |
---|
324 | (@ " /* ::alias:%s %s:: */\n" a feature) |
---|
325 | (@ " rep_alias_structure \(\"%s\"\);\n" a)) aliases) |
---|
326 | (when init |
---|
327 | (@ "\n %s \(\);\n\n" init)) |
---|
328 | (@ " return rep_pop_structure \(s\);\n") |
---|
329 | (@ "}\n")))) |
---|
330 | |
---|
331 | (defun output-imported-enums (output) |
---|
332 | (when gtk-imported-enums |
---|
333 | (@ "\f\n/* Imported enums */\n\n") |
---|
334 | (mapc (lambda (enum) |
---|
335 | (let* |
---|
336 | ((cname (gtk-canonical-name (symbol-name (car enum))))) |
---|
337 | (@ "extern sgtk_enum_info sgtk_%s_info;\n" cname))) |
---|
338 | gtk-imported-enums) |
---|
339 | (@ "\n"))) |
---|
340 | |
---|
341 | (defun output-enums (output) |
---|
342 | (when gtk-enums |
---|
343 | (@ "\f\n/* Enums definitions */\n\n") |
---|
344 | (mapc (lambda (enum) |
---|
345 | (let* |
---|
346 | ((name (car enum)) |
---|
347 | (cname (gtk-canonical-name (symbol-name name))) |
---|
348 | (values (cdr enum))) |
---|
349 | ;; write literal names |
---|
350 | (@ "static sgtk_enum_literal _%s_literals[%d] = {\n" |
---|
351 | cname (length values)) |
---|
352 | (mapc (lambda (cell) |
---|
353 | (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) |
---|
354 | values) |
---|
355 | (@ "};\n") |
---|
356 | ;; write type info struct |
---|
357 | (@ "sgtk_enum_info sgtk_%s_info = {\n" cname) |
---|
358 | (@ " { \"%s\", GTK_TYPE_ENUM }, %d, _%s_literals,\n" |
---|
359 | name (length values) cname) |
---|
360 | (@ "};\n\n"))) |
---|
361 | gtk-enums))) |
---|
362 | |
---|
363 | (defun output-imported-string-enums (output) |
---|
364 | (when gtk-imported-string-enums |
---|
365 | (@ "\f\n/* Imported string enums */\n\n") |
---|
366 | (mapc (lambda (enum) |
---|
367 | (let* |
---|
368 | ((cname (gtk-canonical-name (symbol-name (car enum))))) |
---|
369 | (@ "extern sgtk_string_enum_info sgtk_%s_info;\n" cname))) |
---|
370 | gtk-imported-string-enums) |
---|
371 | (@ "\n"))) |
---|
372 | |
---|
373 | (defun output-string-enums (output) |
---|
374 | (when gtk-string-enums |
---|
375 | (@ "\f\n/* String enums definitions */\n\n") |
---|
376 | (mapc (lambda (enum) |
---|
377 | (let* |
---|
378 | ((name (car enum)) |
---|
379 | (cname (gtk-canonical-name (symbol-name name))) |
---|
380 | (values (cdr enum))) |
---|
381 | ;; write literal names |
---|
382 | (@ "static sgtk_senum_literal _%s_literals[%d] = {\n" |
---|
383 | cname (length values)) |
---|
384 | (mapc (lambda (cell) |
---|
385 | (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) |
---|
386 | values) |
---|
387 | (@ "};\n") |
---|
388 | ;; write type info struct |
---|
389 | (@ "sgtk_senum_info sgtk_%s_info = {\n" cname) |
---|
390 | (@ " { \"%s\", GTK_TYPE_INVALID }, %d, _%s_literals,\n" |
---|
391 | name (length values) cname) |
---|
392 | (@ "};\n\n"))) |
---|
393 | gtk-string-enums))) |
---|
394 | |
---|
395 | (defun output-imported-flags (output) |
---|
396 | (when gtk-imported-flags |
---|
397 | (@ "\f\n/* Imported flags */\n\n") |
---|
398 | (mapc (lambda (flag) |
---|
399 | (let* |
---|
400 | ((cname (gtk-canonical-name (symbol-name (car flag))))) |
---|
401 | (@ "extern sgtk_enum_info sgtk_%s_info;\n" cname))) |
---|
402 | gtk-imported-flags) |
---|
403 | (@ "\n"))) |
---|
404 | |
---|
405 | (defun output-flags (output) |
---|
406 | (when gtk-flags |
---|
407 | (@ "\f\n/* Flags definitions */\n\n") |
---|
408 | (mapc (lambda (flag) |
---|
409 | (let* |
---|
410 | ((name (car flag)) |
---|
411 | (cname (gtk-canonical-name (symbol-name name))) |
---|
412 | (values (cdr flag))) |
---|
413 | ;; write literal names |
---|
414 | (@ "static sgtk_enum_literal _%s_literals[%d] = {\n" |
---|
415 | cname (length values)) |
---|
416 | (mapc (lambda (cell) |
---|
417 | (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) |
---|
418 | values) |
---|
419 | (@ "};\n") |
---|
420 | ;; write type info struct |
---|
421 | (@ "sgtk_enum_info sgtk_%s_info = {\n" cname) |
---|
422 | (@ " { \"%s\", GTK_TYPE_FLAGS }, %d, _%s_literals,\n" |
---|
423 | name (length values) cname) |
---|
424 | (@ "};\n\n"))) |
---|
425 | gtk-flags))) |
---|
426 | |
---|
427 | (defun output-imported-boxed (output) |
---|
428 | (when gtk-imported-boxed |
---|
429 | (@ "\f\n/* Imported boxed structures */\n\n") |
---|
430 | (mapc (lambda (boxed) |
---|
431 | (let* |
---|
432 | ((cname (gtk-canonical-name (symbol-name (car boxed))))) |
---|
433 | (@ "extern sgtk_boxed_info sgtk_%s_info;\n" cname))) |
---|
434 | gtk-imported-boxed) |
---|
435 | (@ "\n"))) |
---|
436 | |
---|
437 | (defun output-boxed (output) |
---|
438 | (when gtk-boxed |
---|
439 | (@ "\f\n/* Boxed structure definitions */\n\n") |
---|
440 | (mapc (lambda (boxed) |
---|
441 | (let* |
---|
442 | ((name (car boxed)) |
---|
443 | (cname (gtk-canonical-name (symbol-name name))) |
---|
444 | (attrs (cdr boxed)) |
---|
445 | (conv (car (cdr (assq 'conversion attrs))))) |
---|
446 | (when conv |
---|
447 | (@ "repv %s (repv);\n" conv)) |
---|
448 | (@ "sgtk_boxed_info sgtk_%s_info = {\n" cname) |
---|
449 | (@ " { \"%s\", GTK_TYPE_BOXED, %s },\n" name (or conv "NULL")) |
---|
450 | (@ " (void *(*)(void*))%s,\n" |
---|
451 | (or (car (cdr (assq 'copy attrs))) "NULL")) |
---|
452 | (@ " (void (*)(void*))%s,\n" |
---|
453 | (or (car (cdr (assq 'free attrs))) "NULL")) |
---|
454 | (@ " %s\n" |
---|
455 | (or (car (cdr (assq 'size attrs))) 0)) |
---|
456 | (@ "};\n\n"))) |
---|
457 | gtk-boxed))) |
---|
458 | |
---|
459 | (defun output-imported-objects (output) |
---|
460 | (when gtk-imported-objects |
---|
461 | (@ "\f\n/* Imported GTK objects */\n\n") |
---|
462 | (mapc (lambda (obj) |
---|
463 | (let* |
---|
464 | ((cname (gtk-canonical-name (symbol-name (car obj))))) |
---|
465 | (@ "extern sgtk_object_info sgtk_%s_info;\n" cname))) |
---|
466 | gtk-imported-objects) |
---|
467 | (@ "\n"))) |
---|
468 | |
---|
469 | (defun output-objects (output) |
---|
470 | (when gtk-objects |
---|
471 | (@ "\f\n/* GTK object definitions */\n\n") |
---|
472 | (mapc (lambda (obj) |
---|
473 | (let* |
---|
474 | ((name (car obj)) |
---|
475 | (cname (gtk-canonical-name (symbol-name name)))) |
---|
476 | (@ "sgtk_object_info sgtk_%s_info = {\n" cname) |
---|
477 | (@ " { \"%s\", GTK_TYPE_OBJECT }, %s_get_type\n" name cname) |
---|
478 | (@ "};\n\n"))) gtk-objects))) |
---|
479 | |
---|
480 | (defun output-type-info (output) |
---|
481 | (when (or gtk-enums gtk-flags gtk-boxed gtk-objects) |
---|
482 | (@ "\f\n/* Vector of all type information */\n\n") |
---|
483 | (@ "static sgtk_type_info *_type_infos[] = {\n") |
---|
484 | (mapc (lambda (lst) |
---|
485 | (mapc (lambda (type) |
---|
486 | (@ " (sgtk_type_info*)&sgtk_%s_info,\n" |
---|
487 | (gtk-canonical-name (symbol-name (car type))))) |
---|
488 | lst)) |
---|
489 | (list gtk-enums gtk-string-enums gtk-flags gtk-boxed gtk-objects)) |
---|
490 | (@ " NULL\n};\n\n"))) |
---|
491 | |
---|
492 | (defun output-functions (output) |
---|
493 | (@ "\f\n/* Defuns */\n\n") |
---|
494 | (mapc (lambda (fun) |
---|
495 | (let |
---|
496 | ;; send output to a temporary buffer to allow helper |
---|
497 | ;; functions to be emitted asynchronously |
---|
498 | ((temporary-stream (make-string-output-stream))) |
---|
499 | (output-function fun temporary-stream) |
---|
500 | (write output (get-output-stream-string temporary-stream)))) |
---|
501 | gtk-functions) |
---|
502 | (@ "\n\n")) |
---|
503 | |
---|
504 | (defun output-subrs (output) |
---|
505 | (@ "\f\n/* Initialisation */\n\n") |
---|
506 | (let |
---|
507 | ((init-func (gtk-get-option 'init-func gtk-options)) |
---|
508 | (other-inits (gtk-get-options 'other-inits gtk-options)) |
---|
509 | (extra-init (gtk-get-options 'extra-init-code gtk-options)) |
---|
510 | (system-init (gtk-get-options 'system-init-code gtk-options))) |
---|
511 | (when init-func |
---|
512 | (@ "void\n%s (void)\n{\n" init-func) |
---|
513 | (@ " static int done;\n if (!done)\n {\n") |
---|
514 | (@ " done = 1;\n") |
---|
515 | (mapc (lambda (func) |
---|
516 | (@ " %s ();\n" func)) other-inits) |
---|
517 | (when (or gtk-enums gtk-string-enums gtk-flags gtk-boxed gtk-objects) |
---|
518 | (@ " sgtk_register_type_infos (_type_infos);\n")) |
---|
519 | (mapc (lambda (cname) |
---|
520 | (@ " rep_ADD_SUBR(S%s);\n" cname)) (nreverse gtk-subrs)) |
---|
521 | (mapc (lambda (code) |
---|
522 | (@ " %s\n")) extra-init) |
---|
523 | (when system-init |
---|
524 | (@ " {\n") |
---|
525 | (@ " char *tem = getenv (\"REP_GTK_DONT_INITIALIZE\");\n") |
---|
526 | (@ " if (tem == 0 || atoi (tem) == 0) {\n") |
---|
527 | (mapc (lambda (code) |
---|
528 | (@ " %s\n" code)) system-init) |
---|
529 | (@ " }\n") |
---|
530 | (@ " }\n")) |
---|
531 | (@ " \}\n\}\n")))) |
---|
532 | |
---|
533 | (defun output-gtk (output) |
---|
534 | (output-header output) |
---|
535 | (output-imported-enums output) |
---|
536 | (output-imported-string-enums output) |
---|
537 | (output-imported-flags output) |
---|
538 | (output-imported-boxed output) |
---|
539 | (output-imported-objects output) |
---|
540 | (output-enums output) |
---|
541 | (output-string-enums output) |
---|
542 | (output-flags output) |
---|
543 | (output-boxed output) |
---|
544 | (output-objects output) |
---|
545 | (output-functions output) |
---|
546 | (output-field-functions gtk-boxed output) |
---|
547 | (output-field-functions gtk-objects output) |
---|
548 | (output-type-info output) |
---|
549 | (output-subrs output) |
---|
550 | (output-footer output)) |
---|
551 | |
---|
552 | |
---|
553 | ;; Type management |
---|
554 | |
---|
555 | (defun gtk-outer-type (type) |
---|
556 | (while (consp type) |
---|
557 | (setq type (car type))) |
---|
558 | type) |
---|
559 | |
---|
560 | (defun gtk-inner-type (type) |
---|
561 | (while (consp (car type)) |
---|
562 | (setq type (car type))) |
---|
563 | (nth 1 type)) |
---|
564 | |
---|
565 | (defun gtk-composite-type-mode (type) |
---|
566 | (while (consp (car type)) |
---|
567 | (setq type (car type))) |
---|
568 | (case (car type) |
---|
569 | ((ret) 'out) |
---|
570 | ((fvec) (or (nth 3 type) 'in)) |
---|
571 | (t (or (nth 2 type) 'in)))) |
---|
572 | |
---|
573 | (defun gtk-composite-type-len (type) |
---|
574 | (while (consp (car type)) |
---|
575 | (setq type (car type))) |
---|
576 | (case (car type) |
---|
577 | ((ret) 1) |
---|
578 | ((fvec) (nth 2 type)) |
---|
579 | (t nil))) |
---|
580 | |
---|
581 | (defun gtk-type-info (type) |
---|
582 | (let* |
---|
583 | ((actual-type (gtk-outer-type type)) |
---|
584 | (typage (cond ((or (assq actual-type gtk-enums) |
---|
585 | (assq actual-type gtk-imported-enums)) |
---|
586 | (assq 'enum gtk-type-alist)) |
---|
587 | ((or (assq actual-type gtk-string-enums) |
---|
588 | (assq actual-type gtk-imported-string-enums)) |
---|
589 | (assq 'senum gtk-type-alist)) |
---|
590 | ((or (assq actual-type gtk-flags) |
---|
591 | (assq actual-type gtk-imported-flags)) |
---|
592 | (assq 'flags gtk-type-alist)) |
---|
593 | ((or (assq actual-type gtk-boxed) |
---|
594 | (assq actual-type gtk-imported-boxed)) |
---|
595 | (assq 'boxed gtk-type-alist)) |
---|
596 | ((or (assq actual-type gtk-objects) |
---|
597 | (assq actual-type gtk-imported-objects)) |
---|
598 | (assq 'object gtk-type-alist)) |
---|
599 | (t |
---|
600 | (assq actual-type gtk-type-alist))))) |
---|
601 | (or typage (error "Unknown type: %s" type)))) |
---|
602 | |
---|
603 | (defmacro gtk-typage-prop (typage prop) |
---|
604 | `(cdr (assq ,prop (nthcdr 5 ,typage)))) |
---|
605 | |
---|
606 | (defun gtk-type-decl (type typage) |
---|
607 | (let |
---|
608 | ((decl (nth 1 typage))) |
---|
609 | (if (functionp decl) |
---|
610 | (funcall decl type typage) |
---|
611 | decl))) |
---|
612 | |
---|
613 | (defmacro gtk-type-fromrep (typage) |
---|
614 | `(nth 2 ,typage)) |
---|
615 | |
---|
616 | (defmacro gtk-type-torep (typage) |
---|
617 | `(nth 3 ,typage)) |
---|
618 | |
---|
619 | (defmacro gtk-type-pred (typage) |
---|
620 | `(nth 4 typage)) |
---|
621 | |
---|
622 | (defun gtk-type-prop (type prop) |
---|
623 | (gtk-typage-prop (gtk-type-info type) prop)) |
---|
624 | |
---|
625 | |
---|
626 | ;; Function arg helpers |
---|
627 | |
---|
628 | (defmacro gtk-get-arg-options (option arg) |
---|
629 | `(assq ,option (nthcdr 2 ,arg))) |
---|
630 | |
---|
631 | (defun gtk-arg-optional-p (arg) |
---|
632 | (nth 1 (gtk-get-arg-options '= arg))) |
---|
633 | |
---|
634 | (defmacro gtk-arg-type (arg) |
---|
635 | `(car ,arg)) |
---|
636 | |
---|
637 | (defmacro gtk-arg-name (arg) |
---|
638 | `(symbol-name (nth 1 ,arg))) |
---|
639 | |
---|
640 | |
---|
641 | ;; Type output functions |
---|
642 | |
---|
643 | (defun output-complex-type (type typage) |
---|
644 | (setq type (gtk-outer-type type)) |
---|
645 | (if (or (assq type gtk-enums) (assq type gtk-imported-enums) |
---|
646 | (assq type gtk-flags) (assq type gtk-imported-flags)) |
---|
647 | (symbol-name type) |
---|
648 | (format nil "%s*" type))) |
---|
649 | |
---|
650 | (define (output-rep-to-static x) |
---|
651 | (lambda (output type rep-var typage) |
---|
652 | (setq type (gtk-outer-type type)) |
---|
653 | (let ((name (gtk-canonical-name (symbol-name type)))) |
---|
654 | (@ "\(%s\) sgtk_rep_to_%s \(%s, &sgtk_%s_info\)" |
---|
655 | (gtk-type-decl type typage) x rep-var name)))) |
---|
656 | |
---|
657 | (define (output-static-to-rep x) |
---|
658 | (lambda (output type gtk-var typage) |
---|
659 | (setq type (gtk-outer-type type)) |
---|
660 | (let ((name (gtk-canonical-name (symbol-name type)))) |
---|
661 | (@ "sgtk_%s_to_rep \(%s, &sgtk_%s_info\)" x gtk-var name)))) |
---|
662 | |
---|
663 | (define (output-static-pred x) |
---|
664 | (lambda (output type rep-var typage) |
---|
665 | (@ "sgtk_valid_%s \(%s, &sgtk_%s_info\)" |
---|
666 | x rep-var (gtk-canonical-name (symbol-name type))))) |
---|
667 | |
---|
668 | (define output-rep-to-enum (output-rep-to-static 'enum)) |
---|
669 | (define output-enum-to-rep (output-static-to-rep 'enum)) |
---|
670 | (define output-enum-pred (output-static-pred 'enum)) |
---|
671 | |
---|
672 | (define output-rep-to-senum (output-rep-to-static 'senum)) |
---|
673 | (define output-senum-to-rep (output-static-to-rep 'senum)) |
---|
674 | (define output-senum-pred (output-static-pred 'senum)) |
---|
675 | |
---|
676 | (define output-rep-to-flags (output-rep-to-static 'flags)) |
---|
677 | (define output-flags-to-rep (output-static-to-rep 'flags)) |
---|
678 | (define output-flags-pred (output-static-pred 'flags)) |
---|
679 | |
---|
680 | (defun output-rep-to-boxed (output type rep-var typage) |
---|
681 | (setq type (gtk-outer-type type)) |
---|
682 | (@ "\(%s*\) sgtk_rep_to_boxed \(%s\)" type rep-var)) |
---|
683 | |
---|
684 | (defun output-boxed-to-rep (output type gtk-var typage) |
---|
685 | (let* |
---|
686 | ((base-type (gtk-outer-type type)) |
---|
687 | (name (gtk-canonical-name (symbol-name base-type))) |
---|
688 | (copy (if (assq 'copy (cdr type)) |
---|
689 | (gtk-get-option 'copy (cdr type)) |
---|
690 | t))) |
---|
691 | (@ "sgtk_boxed_to_rep \(%s, &sgtk_%s_info, %d\)" |
---|
692 | gtk-var name (if copy 1 0)))) |
---|
693 | |
---|
694 | (defun output-boxed-pred (output type rep-var typage) |
---|
695 | (@ "sgtk_valid_boxed \(%s, &sgtk_%s_info\)" |
---|
696 | rep-var (gtk-canonical-name (symbol-name type)))) |
---|
697 | |
---|
698 | (defun output-rep-to-object (output type rep-var typage) |
---|
699 | (setq type (gtk-outer-type type)) |
---|
700 | (@ "\(%s*\) sgtk_get_gtkobj \(%s\)" type rep-var)) |
---|
701 | |
---|
702 | (defun output-object-to-rep (output type gtk-var typage) |
---|
703 | (setq type (gtk-outer-type type)) |
---|
704 | (@ "sgtk_wrap_gtkobj \(\(GtkObject*\) %s\)" gtk-var)) |
---|
705 | |
---|
706 | (defun output-object-pred (output type rep-var typage) |
---|
707 | (@ "sgtk_is_a_gtkobj \(%s_get_type \(\), %s\)" |
---|
708 | (gtk-canonical-name (symbol-name type)) rep-var)) |
---|
709 | |
---|
710 | (defun output-rep-to-full-callback (output type rep-var typage options) |
---|
711 | (let |
---|
712 | ((protect (gtk-get-option 'protection options))) |
---|
713 | (cond ((eq protect '*result*) |
---|
714 | (@ "sgtk_new_protect \(%s\)" rep-var)) |
---|
715 | ((and (not (eq protect t)) |
---|
716 | (not (eq protect nil))) |
---|
717 | (@ "sgtk_protect \(p_%s, %s\)" protect rep-var)) |
---|
718 | (t |
---|
719 | (@ "sgtk_protect \(Qt, %s\)" rep-var))))) |
---|
720 | |
---|
721 | (defun output-full-callback-args (output type var options) |
---|
722 | (@ "0, sgtk_callback_marshal, (gpointer)%s, sgtk_callback_destroy" var)) |
---|
723 | |
---|
724 | (defun output-full-callback-finish (output type g-var r-var options) |
---|
725 | (let |
---|
726 | ((protect (gtk-get-option 'protection options))) |
---|
727 | (when (eq protect '*result*) |
---|
728 | (@ " sgtk_set_protect \(pr_ret, %s\);\n" g-var)))) |
---|
729 | |
---|
730 | (defun output-rep-to-cvec (output type rep-var typage) |
---|
731 | (let* |
---|
732 | ((outer-type (gtk-outer-type type)) |
---|
733 | (inner-type (gtk-inner-type type)) |
---|
734 | (inner-typage (gtk-type-info inner-type)) |
---|
735 | (decl (gtk-type-decl inner-type inner-typage)) |
---|
736 | (mode (gtk-composite-type-mode type))) |
---|
737 | (output-helper inner-type standard-output) |
---|
738 | (@ "sgtk_rep_to_cvec \(%s, %s, sizeof \(%s\)\)" |
---|
739 | rep-var |
---|
740 | (if (eq mode 'out) |
---|
741 | "0" |
---|
742 | (format nil "_sgtk_helper_fromrep_%s" inner-type)) |
---|
743 | decl))) |
---|
744 | |
---|
745 | (defun output-cvec-to-rep (output type gtk-var typage) |
---|
746 | (let* |
---|
747 | ((outer-type (gtk-outer-type type)) |
---|
748 | (inner-type (gtk-inner-type type)) |
---|
749 | (inner-typage (gtk-type-info inner-type)) |
---|
750 | (decl (gtk-type-decl inner-type inner-typage))) |
---|
751 | (output-helper inner-type standard-output) |
---|
752 | (@ "sgtk_cvec_to_rep \(&%s, _sgtk_helper_torep_copy_%s, sizeof \(%s\)\)" |
---|
753 | gtk-var inner-type decl))) |
---|
754 | |
---|
755 | (defun output-cvec-pred (output type rep-var typage) |
---|
756 | (let* |
---|
757 | ((outer-type (gtk-outer-type type)) |
---|
758 | (inner-type (gtk-inner-type type)) |
---|
759 | (inner-typage (gtk-type-info inner-type)) |
---|
760 | (mode (gtk-composite-type-mode type)) |
---|
761 | (len (gtk-composite-type-len type))) |
---|
762 | (output-helper inner-type standard-output) |
---|
763 | (if len |
---|
764 | (@ "sgtk_valid_complen \(%s, %s, %s\)" |
---|
765 | rep-var |
---|
766 | (if (eq mode 'out) |
---|
767 | ;; `out', so don't check inner validity |
---|
768 | "NULL" |
---|
769 | (concat "_sgtk_helper_valid_" (symbol-name inner-type))) |
---|
770 | len) |
---|
771 | (@ "sgtk_valid_composite \(%s, _sgtk_helper_valid_%s\)" |
---|
772 | rep-var inner-type)))) |
---|
773 | |
---|
774 | (defun output-cvec-args (output type var options) |
---|
775 | (let* |
---|
776 | ((outer-type (gtk-outer-type type)) |
---|
777 | (inner-type (gtk-inner-type type)) |
---|
778 | (inner-typage (gtk-type-info inner-type)) |
---|
779 | (decl (gtk-type-decl inner-type inner-typage))) |
---|
780 | (cond ((eq outer-type 'cvec) |
---|
781 | (@ "%s.count, \(%s*\) %s.vec" var decl var)) |
---|
782 | ((eq outer-type 'cvecr) |
---|
783 | (@ "\(%s*\) %s.vec, %s.count" decl var var)) |
---|
784 | ((memq outer-type '(fvec ret tvec)) |
---|
785 | (@ "\(%s*\) %s.vec" decl var)) |
---|
786 | (t |
---|
787 | (gtk-warning "Don't know how to pass type %s" type))))) |
---|
788 | |
---|
789 | (defun output-cvec-finish (output type gtk-var rep-var options) |
---|
790 | (let* |
---|
791 | ((outer-type (gtk-outer-type type)) |
---|
792 | (inner-type (gtk-inner-type type)) |
---|
793 | (inner-typage (gtk-type-info inner-type)) |
---|
794 | (decl (gtk-type-decl inner-type inner-typage)) |
---|
795 | (mode (gtk-composite-type-mode type))) |
---|
796 | (@ " sgtk_cvec_finish \(&%s, %s, %s, sizeof \(%s\)\);\n" |
---|
797 | gtk-var rep-var |
---|
798 | (if (eq mode 'in) |
---|
799 | "0" |
---|
800 | (format nil "_sgtk_helper_torep_nocopy_%s" inner-type)) |
---|
801 | decl))) |
---|
802 | |
---|
803 | (defun output-rep-to-list (output type rep-var typage) |
---|
804 | (let |
---|
805 | ((outer-type (gtk-outer-type type)) |
---|
806 | (inner-type (gtk-inner-type type))) |
---|
807 | (output-helper inner-type standard-output) |
---|
808 | (@ "sgtk_rep_to_%s \(%s, _sgtk_helper_fromrep_%s\)" |
---|
809 | outer-type rep-var inner-type))) |
---|
810 | |
---|
811 | (defun output-list-to-rep (output type gtk-var typage) |
---|
812 | (let |
---|
813 | ((outer-type (gtk-outer-type type)) |
---|
814 | (inner-type (gtk-inner-type type))) |
---|
815 | (output-helper inner-type standard-output) |
---|
816 | (@ "sgtk_%s_to_rep \(%s, _sgtk_helper_torep_copy_%s\)" |
---|
817 | outer-type gtk-var inner-type))) |
---|
818 | |
---|
819 | (defun output-list-finish (output type gtk-var rep-var options) |
---|
820 | (let |
---|
821 | ((outer-type (gtk-outer-type type)) |
---|
822 | (inner-type (gtk-inner-type type)) |
---|
823 | (mode (gtk-composite-type-mode type))) |
---|
824 | (@ " sgtk_%s_finish \(%s, %s, %s\);\n" |
---|
825 | outer-type gtk-var rep-var |
---|
826 | (if (eq mode 'in) |
---|
827 | "0" |
---|
828 | (format nil "_sgtk_helper_torep_nocopy_%s" inner-type))))) |
---|
829 | |
---|
830 | |
---|
831 | ;; Function generation |
---|
832 | |
---|
833 | (defun output-function (def output &optional function-callback) |
---|
834 | (let* |
---|
835 | ((ret (nth 1 def)) |
---|
836 | (args (nth 2 def)) |
---|
837 | (options (nthcdr 3 def)) |
---|
838 | (fname (symbol-name (car def))) |
---|
839 | (rname (or (gtk-get-option 'scm-name options) |
---|
840 | (gtk-hyphenate-name fname))) |
---|
841 | (cname (gtk-unhyphenate-name rname)) |
---|
842 | (subrtype (if (or (> (length args) 5) |
---|
843 | (gtk-get-option 'rest-arg options)) |
---|
844 | 'n |
---|
845 | (length args)))) |
---|
846 | (setq gtk-subrs (cons cname gtk-subrs)) |
---|
847 | |
---|
848 | ;; output header |
---|
849 | (@ "DEFUN\(\"%s\", F%s, S%s, \(" rname cname cname) |
---|
850 | (if (eq subrtype 'n) |
---|
851 | (@ "repv args") |
---|
852 | (if (zerop subrtype) |
---|
853 | (@ "void") |
---|
854 | (let |
---|
855 | ((tem args)) |
---|
856 | (while tem |
---|
857 | (@ "repv p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " "")) |
---|
858 | (setq tem (cdr tem)))))) |
---|
859 | (@ "\), rep_Subr%s\)\n{\n" (if (numberp subrtype) subrtype "N")) |
---|
860 | (unless (eq ret 'none) |
---|
861 | (@ " repv pr_ret;\n")) |
---|
862 | (when (eq subrtype 'n) |
---|
863 | (@ " repv ") |
---|
864 | (let |
---|
865 | ((tem args)) |
---|
866 | (while tem |
---|
867 | (@ "p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " ";\n\n")) |
---|
868 | (setq tem (cdr tem))))) |
---|
869 | |
---|
870 | ;; output any gc roots required |
---|
871 | (mapc (lambda (arg) |
---|
872 | (when (or (gtk-get-arg-options 'protect-during arg) |
---|
873 | (gtk-type-prop (gtk-arg-type arg) 'finish)) |
---|
874 | (@ " rep_GC_root gc_%s;\n" (gtk-arg-name arg)))) args) |
---|
875 | |
---|
876 | ;; output arg/ret decls |
---|
877 | (mapc (lambda (arg) |
---|
878 | (let* |
---|
879 | ((type (gtk-arg-type arg)) |
---|
880 | (typage (gtk-type-info type)) |
---|
881 | (decl (gtk-type-decl type typage))) |
---|
882 | (if (stringp decl) |
---|
883 | (@ " %s c_%s;\n" decl (gtk-arg-name arg)) |
---|
884 | (gtk-warning |
---|
885 | "Don't know how to declare type: %s" type)))) args) |
---|
886 | (unless (eq ret 'none) |
---|
887 | (let* |
---|
888 | ((typage (gtk-type-info ret)) |
---|
889 | (decl (gtk-type-decl ret typage))) |
---|
890 | (cond |
---|
891 | ((stringp decl) |
---|
892 | (@ " %s cr_ret;\n" decl)) |
---|
893 | ((functionp decl) |
---|
894 | (funcall decl output ret "cr_ret" typage options)) |
---|
895 | (t |
---|
896 | (gtk-warning |
---|
897 | "Don't know how to declare type: %s" ret))))) |
---|
898 | (unless (and (null args) (eq ret 'none)) |
---|
899 | (@ "\n")) |
---|
900 | |
---|
901 | ;; break out the list of parameters |
---|
902 | (when (eq subrtype 'n) |
---|
903 | (let |
---|
904 | ((tem args) |
---|
905 | (i 1)) |
---|
906 | (while tem |
---|
907 | (@ " if \(!rep_CONSP\(args\)\)\n") |
---|
908 | (@ " p_%s = Qnil; \n" (gtk-arg-name (car tem))) |
---|
909 | (@ " else {\n") |
---|
910 | (@ (if (and (null (cdr tem)) (gtk-get-option 'rest-arg options)) |
---|
911 | " p_%s = args; args = Qnil;\n" |
---|
912 | " p_%s = rep_CAR(args); args = rep_CDR(args);\n") |
---|
913 | (gtk-arg-name (car tem))) |
---|
914 | (@ " }\n") |
---|
915 | (setq tem (cdr tem)) |
---|
916 | (setq i (1+ i))) |
---|
917 | (@ "\n"))) |
---|
918 | |
---|
919 | ;; output arg checks and conversions |
---|
920 | (let |
---|
921 | ((tem args) |
---|
922 | (i 1)) |
---|
923 | (while tem |
---|
924 | (let* |
---|
925 | ((type (gtk-arg-type (car tem))) |
---|
926 | (typage (gtk-type-info type)) |
---|
927 | (pred (gtk-type-pred typage)) |
---|
928 | (optional (gtk-arg-optional-p (car tem))) |
---|
929 | (type-options (gtk-get-options type gtk-options))) |
---|
930 | (when (gtk-get-option 'conversion type-options) |
---|
931 | (@ " p_%s = %s \(p_%s\);\n" |
---|
932 | (gtk-arg-name (car tem)) |
---|
933 | (gtk-get-option 'conversion type-options) |
---|
934 | (gtk-arg-name (car tem)))) |
---|
935 | (unless (or optional (null pred)) |
---|
936 | (when (gtk-get-arg-options 'null-ok (car tem)) |
---|
937 | (@ " if (p_%s != Qnil)\n " (gtk-arg-name (car tem)))) |
---|
938 | (@ " rep_DECLARE \(%d, p_%s, " i (gtk-arg-name (car tem))) |
---|
939 | (cond ((stringp pred) |
---|
940 | (@ "%s \(p_%s\)" pred (gtk-arg-name (car tem)))) |
---|
941 | ((functionp pred) |
---|
942 | (funcall pred output type |
---|
943 | (concat "p_" (gtk-arg-name (car tem))) |
---|
944 | typage options)) |
---|
945 | (t |
---|
946 | (gtk-warning "Don't know type predicate: %s" type))) |
---|
947 | (@ "\);\n")) |
---|
948 | (setq tem (cdr tem)) |
---|
949 | (setq i (1+ i))))) |
---|
950 | (when args |
---|
951 | (@ "\n")) |
---|
952 | |
---|
953 | ;; initialise gc roots |
---|
954 | (mapc (lambda (arg) |
---|
955 | (when (or (gtk-get-arg-options 'protect-during arg) |
---|
956 | (gtk-type-prop (gtk-arg-type arg) 'finish)) |
---|
957 | (@ " rep_PUSHGC \(gc_%s, p_%s\);\n" |
---|
958 | (gtk-arg-name arg) (gtk-arg-name arg)))) args) |
---|
959 | |
---|
960 | ;; output arg initialisations |
---|
961 | (mapc (lambda (arg) |
---|
962 | (let* |
---|
963 | ((type (gtk-arg-type arg)) |
---|
964 | (typage (gtk-type-info type)) |
---|
965 | (from (gtk-type-fromrep typage)) |
---|
966 | (optional (gtk-arg-optional-p arg))) |
---|
967 | (when (gtk-get-arg-options 'null-ok arg) |
---|
968 | (@ " if (p_%s == Qnil)\n c_%s = 0; \n else\n " |
---|
969 | (gtk-arg-name arg) (gtk-arg-name arg))) |
---|
970 | (when optional |
---|
971 | (@ " if \(p_%s == Qnil\)\n c_%s = %s;\n else\n " |
---|
972 | (gtk-arg-name arg) (gtk-arg-name arg) optional)) |
---|
973 | (@ " c_%s = " (gtk-arg-name arg)) |
---|
974 | (cond ((stringp from) |
---|
975 | (@ "%s \(p_%s\)" from (gtk-arg-name arg))) |
---|
976 | ((functionp from) |
---|
977 | (funcall from output type |
---|
978 | (concat "p_" (gtk-arg-name arg)) |
---|
979 | typage options)) |
---|
980 | (t |
---|
981 | (gtk-warning |
---|
982 | "Don't know how to convert repv to %s" type))) |
---|
983 | (@ ";\n"))) args) |
---|
984 | (when args |
---|
985 | (@ "\n")) |
---|
986 | |
---|
987 | (if function-callback |
---|
988 | (funcall function-callback output) |
---|
989 | ;; output call |
---|
990 | (@ " ") |
---|
991 | (unless (eq ret 'none) |
---|
992 | (@ "cr_ret = ")) |
---|
993 | (@ "%s \(" fname) |
---|
994 | (let |
---|
995 | ((tem args)) |
---|
996 | (while tem |
---|
997 | (let |
---|
998 | ((opt (gtk-type-prop (gtk-arg-type (car tem)) 'c2args))) |
---|
999 | (if opt |
---|
1000 | (if (functionp opt) |
---|
1001 | (funcall opt output (gtk-arg-type (car tem)) |
---|
1002 | (concat "c_" (gtk-arg-name (car tem))) |
---|
1003 | options) |
---|
1004 | (gtk-warning "c2args function %s undefined" opt)) |
---|
1005 | (@ "c_%s" (gtk-arg-name (car tem))))) |
---|
1006 | (@ (if (cdr tem) ", " "")) |
---|
1007 | (setq tem (cdr tem)))) |
---|
1008 | (@ "\);\n\n")) |
---|
1009 | |
---|
1010 | ;; output ret conversion |
---|
1011 | (unless (eq ret 'none) |
---|
1012 | (let* |
---|
1013 | ((typage (gtk-type-info ret)) |
---|
1014 | (to (gtk-type-torep typage))) |
---|
1015 | (@ " pr_ret = ") |
---|
1016 | (cond ((stringp to) |
---|
1017 | (@ "%s \(cr_ret\)" to)) |
---|
1018 | ((functionp to) |
---|
1019 | (funcall to output ret "cr_ret" typage options)) |
---|
1020 | (t |
---|
1021 | (gtk-warning |
---|
1022 | "Don't know how to convert %s to repv" ret))) |
---|
1023 | (@ ";\n"))) |
---|
1024 | |
---|
1025 | ;; output `finish' options |
---|
1026 | (mapc (lambda (arg) |
---|
1027 | (let |
---|
1028 | ((opt (gtk-type-prop (gtk-arg-type arg) 'finish))) |
---|
1029 | (when opt |
---|
1030 | (if (functionp opt) |
---|
1031 | (funcall opt output (gtk-arg-type arg) |
---|
1032 | (concat "c_" (gtk-arg-name arg)) |
---|
1033 | (concat "p_" (gtk-arg-name arg)) |
---|
1034 | options) |
---|
1035 | (gtk-warning "finish function %s undefined" opt))))) args) |
---|
1036 | |
---|
1037 | ;; pop gc roots |
---|
1038 | (mapc (lambda (arg) |
---|
1039 | (when (or (gtk-get-arg-options 'protect-during arg) |
---|
1040 | (gtk-type-prop (gtk-arg-type arg) 'finish)) |
---|
1041 | (@ " rep_POPGC;\n" |
---|
1042 | (gtk-arg-name arg) (gtk-arg-name arg)))) args) |
---|
1043 | |
---|
1044 | ;; output return statement |
---|
1045 | (if (eq ret 'none) |
---|
1046 | (@ " return Qnil;\n") |
---|
1047 | (@ " return pr_ret;\n")) |
---|
1048 | |
---|
1049 | ;; footer |
---|
1050 | (@ "}\n\n"))) |
---|
1051 | |
---|
1052 | |
---|
1053 | ;; Field access functions |
---|
1054 | |
---|
1055 | (defun output-field-functions (type-list output) |
---|
1056 | (mapc (lambda (def) |
---|
1057 | (let |
---|
1058 | ((fields (cdr (assq 'fields (cdr def))))) |
---|
1059 | (when fields |
---|
1060 | (mapc #'(lambda (field) |
---|
1061 | (output-field-accessors |
---|
1062 | (car def) field output |
---|
1063 | (car (cdr (assq 'setter (nthcdr 2 field)))) |
---|
1064 | (car (cdr (assq 'getter (nthcdr 2 field)))))) |
---|
1065 | fields)) |
---|
1066 | (output-type-predicate (car def) output))) |
---|
1067 | type-list)) |
---|
1068 | |
---|
1069 | (defun output-field-accessors (datatype field output &optional settable getter) |
---|
1070 | (let* |
---|
1071 | ((type (car field)) |
---|
1072 | (cdatatype (gtk-canonical-name (symbol-name datatype))) |
---|
1073 | (cfieldname (symbol-name (nth 1 field)))) |
---|
1074 | (output-function (list (intern (format nil "%s_%s" cdatatype cfieldname)) |
---|
1075 | type (list (list datatype 'obj))) |
---|
1076 | output |
---|
1077 | (lambda (output) |
---|
1078 | (if getter |
---|
1079 | (@ " cr_ret = %s (c_obj);\n" getter) |
---|
1080 | (@ " cr_ret = c_obj->%s;\n" cfieldname)))) |
---|
1081 | (when settable |
---|
1082 | (output-function (list (intern (format nil "%s_%s_set" |
---|
1083 | cdatatype cfieldname)) |
---|
1084 | 'none (list (list datatype 'obj) |
---|
1085 | (list type 'data))) |
---|
1086 | output |
---|
1087 | (lambda (output) |
---|
1088 | (@ " c_obj->%s = c_data;\n" cfieldname)))))) |
---|
1089 | |
---|
1090 | (defun output-type-predicate (type output) |
---|
1091 | (let* |
---|
1092 | ((typage (gtk-type-info type)) |
---|
1093 | (ctype (gtk-canonical-name (symbol-name type))) |
---|
1094 | (rtype (gtk-hyphenate-name ctype)) |
---|
1095 | (pred (gtk-type-pred typage))) |
---|
1096 | (cond ((stringp pred) |
---|
1097 | (setq pred (format nil "%s \(p_obj\)" pred))) |
---|
1098 | ((functionp pred) |
---|
1099 | (let |
---|
1100 | ((temporary-output (make-string-output-stream))) |
---|
1101 | (funcall pred temporary-output type "p_obj" typage nil) |
---|
1102 | (setq pred (get-output-stream-string temporary-output)))) |
---|
1103 | ((null pred) |
---|
1104 | (setq pred "1"))) |
---|
1105 | (@ "DEFUN\(\"%s-p\", F%s_p, S%s_p, \(repv p_obj\), rep_Subr1\)\n{\n" |
---|
1106 | rtype ctype ctype) |
---|
1107 | (@ " return \(%s\) ? Qt : Qnil;\n}\n\n" pred) |
---|
1108 | (setq gtk-subrs (cons (intern (format nil "%s_p" ctype)) gtk-subrs)))) |
---|
1109 | |
---|
1110 | |
---|
1111 | ;; Composite type helper functions |
---|
1112 | |
---|
1113 | (defun output-helper (type output) |
---|
1114 | (unless (memq type gtk-emitted-composite-helpers) |
---|
1115 | (setq gtk-emitted-composite-helpers |
---|
1116 | (cons type gtk-emitted-composite-helpers)) |
---|
1117 | (let* |
---|
1118 | ((typage (gtk-type-info type)) |
---|
1119 | (pred (gtk-type-pred typage)) |
---|
1120 | (decl (gtk-type-decl type typage)) |
---|
1121 | (from (gtk-type-fromrep typage)) |
---|
1122 | (to (gtk-type-torep typage))) |
---|
1123 | |
---|
1124 | ;; use some hackery to get from, to, and pred functions as strings |
---|
1125 | (cond ((stringp from) |
---|
1126 | (setq from (concat from " \(obj\)"))) |
---|
1127 | ((functionp from) |
---|
1128 | (let |
---|
1129 | ((temporary-output (make-string-output-stream))) |
---|
1130 | (funcall from temporary-output type "obj" typage nil) |
---|
1131 | (setq from (get-output-stream-string temporary-output))))) |
---|
1132 | (cond ((stringp to) |
---|
1133 | (setq to (format nil "%s \(*\(%s*\)mem\)" to decl))) |
---|
1134 | ((functionp to) |
---|
1135 | (let |
---|
1136 | ((temporary-output (make-string-output-stream))) |
---|
1137 | (funcall to temporary-output type |
---|
1138 | (format nil "\(*\(%s*\)mem\)" decl) typage nil) |
---|
1139 | (setq to (get-output-stream-string temporary-output))))) |
---|
1140 | (cond ((stringp pred) |
---|
1141 | (setq pred (format nil "%s \(obj\)" pred))) |
---|
1142 | ((functionp pred) |
---|
1143 | (let |
---|
1144 | ((temporary-output (make-string-output-stream))) |
---|
1145 | (funcall pred temporary-output type "obj" typage nil) |
---|
1146 | (setq pred (get-output-stream-string temporary-output)))) |
---|
1147 | ((null pred) |
---|
1148 | (setq pred "1"))) |
---|
1149 | |
---|
1150 | (unless (and (stringp decl) (stringp pred) (stringp from) (stringp to)) |
---|
1151 | (error "Can't create composite helper for %s" type)) |
---|
1152 | (@ "/* helpers for %s */\n" type) |
---|
1153 | (@ "static int\n_sgtk_helper_valid_%s \(repv obj\)\n" type) |
---|
1154 | (@ "\{\n return obj == Qnil || \(%s\);\n\}\n" pred) |
---|
1155 | (@ "static void\n_sgtk_helper_fromrep_%s \(repv obj, void *mem\)\n" type) |
---|
1156 | (@ "\{\n *\(%s*\)mem = %s;\n\}\n" decl from) |
---|
1157 | (@ "static repv\n_sgtk_helper_torep_copy_%s \(void *mem\)\n" type) |
---|
1158 | (@ "\{\n return %s;\n\}\n" to) |
---|
1159 | ;; XXX presumably there should be a difference between the |
---|
1160 | ;; XXX copy and no_copy variants!? |
---|
1161 | (@ "static repv\n_sgtk_helper_torep_nocopy_%s \(void *mem\)\n" type) |
---|
1162 | (@ "\{\n return %s;\n\}\n\n" to)))) |
---|
1163 | |
---|
1164 | |
---|
1165 | ;; Sundries |
---|
1166 | |
---|
1167 | (defun gtk-canonical-name (name) |
---|
1168 | (let |
---|
1169 | ((out nil) |
---|
1170 | (point 0)) |
---|
1171 | (while (string-match "[A-Z]+" name point) |
---|
1172 | (setq out (cons (substring name point (match-start)) out)) |
---|
1173 | (unless (zerop point) |
---|
1174 | (setq out (cons ?_ out))) |
---|
1175 | (setq out (cons (translate-string (substring |
---|
1176 | name (match-start) (match-end)) |
---|
1177 | downcase-table) out)) |
---|
1178 | (setq point (match-end))) |
---|
1179 | (if out |
---|
1180 | (progn |
---|
1181 | (setq out (cons (substring name point) out)) |
---|
1182 | (apply concat (nreverse out))) |
---|
1183 | name))) |
---|
1184 | |
---|
1185 | (defun gtk-hyphenate-name (name) |
---|
1186 | (if (string-match "_" name) |
---|
1187 | (translate-string (copy-sequence name) gtk-hyphen-map) |
---|
1188 | name)) |
---|
1189 | |
---|
1190 | (defun gtk-unhyphenate-name (name) |
---|
1191 | (if (string-match "-" name) |
---|
1192 | (translate-string (copy-sequence name) gtk-unhyphen-map) |
---|
1193 | name)) |
---|
1194 | |
---|
1195 | (defun gtk-warning (fmt &rest args) |
---|
1196 | (apply format standard-error fmt args) |
---|
1197 | (write standard-error ?\n)) |
---|
1198 | |
---|
1199 | |
---|
1200 | ;; initialisation |
---|
1201 | |
---|
1202 | (define-type 'type "GtkType" "sgtk_rep_to_type" |
---|
1203 | "sgtk_type_to_rep" "sgtk_valid_type") |
---|
1204 | |
---|
1205 | (define-type 'char "gchar" "sgtk_rep_to_char" |
---|
1206 | "sgtk_char_to_rep" "sgtk_valid_char") |
---|
1207 | |
---|
1208 | (define-type 'bool "int" "sgtk_rep_to_bool" "sgtk_bool_to_rep" nil) |
---|
1209 | |
---|
1210 | (define-type 'int "gint" "sgtk_rep_to_int" "sgtk_int_to_rep" |
---|
1211 | "sgtk_valid_int" '(listable . t)) |
---|
1212 | |
---|
1213 | (define-type 'uint "guint" "sgtk_rep_to_uint" "sgtk_uint_to_rep" |
---|
1214 | "sgtk_valid_uint" '(listable . t)) |
---|
1215 | |
---|
1216 | (define-type 'long "glong" "sgtk_rep_to_long" |
---|
1217 | "sgtk_long_to_rep" "sgtk_valid_long") |
---|
1218 | |
---|
1219 | (define-type 'ulong "gulong" "sgtk_rep_to_ulong" |
---|
1220 | "sgtk_ulong_to_rep" "sgtk_valid_ulong") |
---|
1221 | |
---|
1222 | (define-type 'float "gfloat" "sgtk_rep_to_float" |
---|
1223 | "sgtk_float_to_rep" "sgtk_valid_float") |
---|
1224 | |
---|
1225 | (define-type 'string "char*" "sgtk_rep_to_string" |
---|
1226 | "sgtk_string_to_rep" "sgtk_valid_string" '(listable . t)) |
---|
1227 | |
---|
1228 | (define-type 'enum output-complex-type output-rep-to-enum |
---|
1229 | output-enum-to-rep output-enum-pred) |
---|
1230 | |
---|
1231 | (define-type 'senum "char*" output-rep-to-senum |
---|
1232 | output-senum-to-rep output-senum-pred) |
---|
1233 | |
---|
1234 | (define-type 'flags output-complex-type output-rep-to-flags |
---|
1235 | output-flags-to-rep output-flags-pred) |
---|
1236 | |
---|
1237 | (define-type 'boxed output-complex-type output-rep-to-boxed |
---|
1238 | output-boxed-to-rep output-boxed-pred '(listable . t)) |
---|
1239 | |
---|
1240 | (define-type 'pointer "gpointer" "sgtk_rep_to_pointer" |
---|
1241 | "sgtk_pointer_to_rep" "sgtk_valid_pointer") |
---|
1242 | |
---|
1243 | (define-type 'object output-complex-type output-rep-to-object |
---|
1244 | output-object-to-rep output-object-pred '(listable . t)) |
---|
1245 | |
---|
1246 | (define-type 'static_string "const char*" nil |
---|
1247 | "sgtk_static_string_to_rep" nil '(listable . t)) |
---|
1248 | |
---|
1249 | (define-type 'full-callback "sgtk_protshell*" output-rep-to-full-callback nil |
---|
1250 | "sgtk_valid_function" (cons 'c2args output-full-callback-args) |
---|
1251 | (cons 'finish output-full-callback-finish)) |
---|
1252 | |
---|
1253 | (define-type 'file-descriptor "int" "sgtk_rep_to_fd" |
---|
1254 | "sgtk_fd_to_rep" "sgtk_valid_fd") |
---|
1255 | |
---|
1256 | (define-type 'list "GList*" output-rep-to-list output-list-to-rep |
---|
1257 | output-cvec-pred (cons 'finish output-list-finish)) |
---|
1258 | |
---|
1259 | (define-type 'slist "GSList*" output-rep-to-list output-list-to-rep |
---|
1260 | output-cvec-pred (cons 'finish output-list-finish)) |
---|
1261 | |
---|
1262 | (define-type 'cvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep |
---|
1263 | output-cvec-pred (cons 'finish output-cvec-finish) |
---|
1264 | (cons 'c2args output-cvec-args)) |
---|
1265 | |
---|
1266 | (define-type 'cvecr "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep |
---|
1267 | output-cvec-pred (cons 'finish output-cvec-finish) |
---|
1268 | (cons 'c2args output-cvec-args)) |
---|
1269 | |
---|
1270 | (define-type 'fvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep |
---|
1271 | output-cvec-pred (cons 'finish output-cvec-finish) |
---|
1272 | (cons 'c2args output-cvec-args)) |
---|
1273 | |
---|
1274 | (define-type 'tvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep |
---|
1275 | output-cvec-pred (cons 'finish output-cvec-finish) |
---|
1276 | (cons 'c2args output-cvec-args)) |
---|
1277 | |
---|
1278 | (define-type 'ret "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep |
---|
1279 | output-cvec-pred (cons 'finish output-cvec-finish) |
---|
1280 | (cons 'c2args output-cvec-args)) |
---|
1281 | |
---|
1282 | (define-type 'double "gdouble" "sgtk_rep_to_double" |
---|
1283 | "sgtk_double_to_rep" "sgtk_valid_double") |
---|
1284 | |
---|
1285 | (define-type 'point "GdkPoint" "sgtk_rep_to_point" |
---|
1286 | "sgtk_point_to_rep" "sgtk_valid_point") |
---|
1287 | |
---|
1288 | (define-type 'rect "GdkRectangle" "sgtk_rep_to_rect" |
---|
1289 | "sgtk_rect_to_rep" "sgtk_valid_rect") |
---|
1290 | |
---|
1291 | (define-type 'SCM "repv" "" "" nil) |
---|