source: trunk/third/rep-gtk/build-gtk.jl @ 15286

Revision 15286, 40.1 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r15285, which included commits to RCS files with non-trunk default branches.
Line 
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)
Note: See TracBrowser for help on using the repository browser.