Context Navigation

build-gtk.jl @ 18404

Visit:

Revision 18404, 41.5 KB checked in by ghudson, 22 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r18403, 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.2 2003-01-05 00:30:07 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	(setq debug-on-error '(bad-arg invalid-function missing-arg))
22
23	;; Notes:
24
25	;; This assumes that the `sed-fix-defs' sed script has been run over all
26	;; input files (to convert schemey things to their lispy equivalents)
27
28	;; Todo:
29	;; * doesn't check for `listable' type-property
30	;; * guile-gtk `struct' and `ptype' types
31	;; * not possible to wrap functions returning vector types
32
33	;; WARNING: This makes some pretty gruesome assumptions. [where?]
34
35
36	;; Configuration
37
38	;; Alist of (TYPE ["C-TYPE" \| DECL-FUNC] ["REP2GTK" \| FROM-REP-FUNC]
39	;; ["GTK2REP" \| TO-REP-FUNC] ["PRED-NAME" \| PRED-FUNC]
40	;; . OPTION-ALIST)
41
42	;; The required functions are called as:
43
44	;; (DECL-FUNC TYPE TYPE-INFO)
45	;; (FROM-REP-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS)
46	;; (TO-REP-FUNC OUTPUT-STREAM TYPE "GTK-VAR" TYPE-INFO OPTIONS)
47	;; (PRED-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS)
48
49	;; The options in the OPTION-ALIST may be:
50
51	;; (c2args . EMIT-ARG-FUNC)
52	;; (finish . FINISH-ARG-FUNC)
53	;; (listable . BOOLEAN)
54
55	;; with:
56
57	;; (EMIT-ARG-FUNC OUTPUT TYPE "GTK-VAR" OPTIONS)
58	;; (FINISH-ARG-FUNC OUTPUT TYPE "GTK-VAR" "REP-VAR" OPTIONS)
59
60	(defvar gtk-type-alist nil)
61
62	(defun define-type (type c-type rep-to-gtk gtk-to-rep type-pred . options)
63	(setq gtk-type-alist (cons (list* type c-type rep-to-gtk
64	gtk-to-rep type-pred options)
65	gtk-type-alist)))
66
67
68	;; Work variables
69
70	(defvar gtk-enums nil
71	"List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs")
72
73	(defvar gtk-string-enums nil
74	"List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs")
75
76	(defvar gtk-flags nil
77	"List of (ENUM-NAME . ENUM-DEF) for all parsed flags defs")
78
79	(defvar gtk-boxed nil
80	"List of (BOXED-NAME . BOXED-DEF)")
81
82	(defvar gtk-objects nil
83	"List of (OBJECT-NAME . OBJECT-DEF)")
84
85	(defvar gtk-functions nil
86	"List of (FUNCTION-NAME . FUNCTION-DEF)")
87
88	(defvar gtk-options nil
89	"List of (OPTION VALUE)")
90
91	(defvar gtk-subrs nil
92	"List of C-NAME.")
93
94	;; similar for imported files
95	(defvar gtk-imported-enums nil)
96	(defvar gtk-imported-string-enums nil)
97	(defvar gtk-imported-flags nil)
98	(defvar gtk-imported-boxed nil)
99	(defvar gtk-imported-objects nil)
100
101	;; t when importing secondary definitions
102	(defvar gtk-importing nil)
103
104	(defmacro gtk-get-options (name options)
105	`(cdr (assq ,name ,options)))
106
107	(defmacro gtk-get-option (name options)
108	`(car (gtk-get-options ,name ,options)))
109
110	(defvar gtk-hyphen-map
111	(let
112	((map (make-string (1+ ?_)))
113	(i 0))
114	(while (< i ?_)
115	(aset map i i)
116	(setq i (1+ i)))
117	(aset map i ?-)
118	map))
119
120	(defvar gtk-unhyphen-map
121	(let
122	((map (make-string (1+ ?-)))
123	(i 0))
124	(while (< i ?-)
125	(aset map i i)
126	(setq i (1+ i)))
127	(aset map i ?_)
128	map))
129
130	(defvar gtk-emitted-composite-helpers nil)
131
132
133	;; Entry point
134
135	(defun build-gtk (defs-file-name output-file-name)
136	(let
137	((gtk-enums nil)
138	(gtk-string-enums nil)
139	(gtk-flags nil)
140	(gtk-boxed nil)
141	(gtk-objects nil)
142	(gtk-functions nil)
143	(gtk-options nil)
144	(gtk-subrs nil)
145	(gtk-imported-enums nil)
146	(gtk-imported-string-enums nil)
147	(gtk-imported-flags nil)
148	(gtk-imported-boxed nil)
149	(gtk-imported-objects nil)
150	(gtk-importing nil)
151	(gtk-emitted-composite-helpers nil))
152	(let
153	((defs-file (open-file defs-file-name 'read)))
154	(or defs-file (error "Can't open input file: %s" defs-file-name))
155	(unwind-protect
156	(parse-gtk defs-file)
157	(close-file defs-file)))
158	(setq gtk-enums (nreverse gtk-enums))
159	(setq gtk-string-enums (nreverse gtk-string-enums))
160	(setq gtk-flags (nreverse gtk-flags))
161	(setq gtk-boxed (nreverse gtk-boxed))
162	(setq gtk-objects (nreverse gtk-objects))
163	(setq gtk-functions (nreverse gtk-functions))
164	(let
165	((output-file (open-file output-file-name 'write)))
166	(or output-file (error "Can't open output file: %s" output-file-name))
167	(unwind-protect
168	(let
169	((standard-output output-file))
170	(output-gtk output-file))
171	(close-file output-file)))))
172
173	(defun build-gtk-batch ()
174	(or (= (length command-line-args) 2) (error "usage: INPUT OUTPUT"))
175	(let
176	((in (car command-line-args))
177	(out (nth 1 command-line-args)))
178	(setq command-line-args (nthcdr 2 command-line-args))
179	(build-gtk in out)))
180
181
182	;; Parsing
183
184	(defun parse-gtk (input)
185	(condition-case nil
186	(while t
187	(let
188	((def (read input)))
189	;;(format standard-error "read: %S\n" def)
190	(when def
191	(or (consp def) (error "Definition isn't a list"))
192	(cond
193	((memq (car def) '(include import))
194	(let
195	((file (open-file (expand-file-name (nth 1 def)
196	(file-name-directory
197	(file-binding input)))
198	'read)))
199	(or file (error "Can't open input file: %s" (nth 1 def)))
200	(unwind-protect
201	(let ((gtk-importing (if (eq (car def) 'import)
202	t
203	gtk-importing)))
204	(parse-gtk file))
205	(close-file file))))
206	((eq (car def) 'define-enum)
207	(let*
208	((name (nth 1 def))
209	(body (nthcdr 2 def))
210	(cell (or (assq name gtk-enums)
211	(assq name gtk-imported-enums))))
212	(if cell
213	(rplacd cell body)
214	(if (not gtk-importing)
215	(setq gtk-enums (cons (cons name body) gtk-enums))
216	(setq gtk-imported-enums
217	(cons (cons name body) gtk-imported-enums))))))
218	((eq (car def) 'define-string-enum)
219	(let*
220	((name (nth 1 def))
221	(body (nthcdr 2 def))
222	(cell (or (assq name gtk-string-enums)
223	(assq name gtk-imported-string-enums))))
224	(if cell
225	(rplacd cell body)
226	(if (not gtk-importing)
227	(setq gtk-string-enums (cons (cons name body)
228	gtk-string-enums))
229	(setq gtk-imported-string-enums
230	(cons (cons name body)
231	gtk-imported-string-enums))))))
232	((eq (car def) 'define-flags)
233	(let*
234	((name (nth 1 def))
235	(body (nthcdr 2 def))
236	(cell (or (assq name gtk-flags)
237	(assq name gtk-imported-flags))))
238	(if cell
239	(rplacd cell body)
240	(if (not gtk-importing)
241	(setq gtk-flags (cons (cons name body) gtk-flags))
242	(setq gtk-imported-flags
243	(cons (cons name body) gtk-imported-flags))))))
244	((eq (car def) 'define-boxed)
245	(let
246	((cell (or (assq (nth 1 def) gtk-boxed)
247	(assq (nth 1 def) gtk-imported-boxed))))
248	(if cell
249	(rplacd cell (nthcdr 2 def))
250	(if (not gtk-importing)
251	(setq gtk-boxed (cons (cdr def) gtk-boxed))
252	(setq gtk-imported-boxed
253	(cons (cdr def) gtk-imported-boxed))))))
254	((eq (car def) 'define-object)
255	(let*
256	((name (nth 1 def))
257	(super (nth 2 def))
258	(attrs (nthcdr 3 def))
259	(cell (or (assq name gtk-objects)
260	(assq name gtk-imported-objects))))
261	(when (car super)
262	(setq attrs (cons (cons 'super (car super)) attrs)))
263	(if cell
264	(rplacd cell attrs)
265	(if (not gtk-importing)
266	(setq gtk-objects
267	(cons (cons name attrs) gtk-objects))
268	(setq gtk-imported-objects
269	(cons (cons name attrs) gtk-imported-objects))))))
270	((eq (car def) 'define-func)
271	(unless gtk-importing
272	(let
273	((cell (assq (nth 1 def) gtk-functions)))
274	(if cell
275	(rplacd cell (nthcdr 2 def))
276	(setq gtk-functions (cons (cdr def) gtk-functions))))))
277	((eq (car def) 'define-type)
278	(eval def))
279	((eq (car def) 'options)
280	(unless gtk-importing
281	(mapc (lambda (cell)
282	(let
283	((value (assq (car cell) gtk-options)))
284	(if value
285	(rplacd value (nconc (cdr value)
286	(list (nth 1 cell))))
287	(setq gtk-options (cons cell gtk-options)))))
288	(cdr def))))
289	((eq (car def) 'add-options)
290	(unless gtk-importing
291	(let
292	((value (assq (nth 1 def) gtk-options)))
293	(if value
294	(rplacd value (nconc (cdr value) (nthcdr 2 def)))
295	(setq gtk-options (cons (cdr def) gtk-options))))))
296	(t
297	(gtk-warning "Ignoring `%S'" def))))))
298	(end-of-stream)))
299
300
301	;; Code generation
302
303	(defmacro @ args
304	(list* 'format 'output args))
305
306	(defun output-header (output)
307	(@ "/* Automatically generated by build-gtk, DO NOT EDIT! */\n\n")
308	(when (gtk-get-options 'includes gtk-options)
309	(mapc (lambda (opt)
310	(@ "%s\n" opt))
311	(gtk-get-options 'includes gtk-options)))
312	(@ "#include <rep.h>\n")
313	(@ "#include \"rep-gtk.h\"\n\n"))
314
315	(defun output-footer (output)
316	(let*
317	((feature (gtk-get-option 'provide gtk-options))
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\", G_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\", G_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\", G_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\", G_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\", G_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	(declare (unused code))
523	(@ " %s\n")) extra-init)
524	(when system-init
525	(@ " {\n")
526	(@ " char *tem = getenv (\"REP_GTK_DONT_INITIALIZE\");\n")
527	(@ " if (tem == 0 \|\| atoi (tem) == 0) {\n")
528	(mapc (lambda (code)
529	(@ " %s\n" code)) system-init)
530	(@ " }\n")
531	(@ " }\n"))
532	(@ " \}\n\}\n"))))
533
534	(defun output-gtk (output)
535	(output-header output)
536	(output-imported-enums output)
537	(output-imported-string-enums output)
538	(output-imported-flags output)
539	(output-imported-boxed output)
540	(output-imported-objects output)
541	(output-enums output)
542	(output-string-enums output)
543	(output-flags output)
544	(output-boxed output)
545	(output-objects output)
546	(output-functions output)
547	(output-field-functions gtk-boxed output)
548	(output-field-functions gtk-objects output)
549	(output-type-info output)
550	(output-subrs output)
551	(output-footer output))
552
553
554	;; Type management
555
556	(defun gtk-outer-type (type)
557	(while (consp type)
558	(setq type (car type)))
559	type)
560
561	(defun gtk-inner-type (type)
562	(while (consp (car type))
563	(setq type (car type)))
564	(nth 1 type))
565
566	(defun gtk-composite-type-mode (type)
567	(while (consp (car type))
568	(setq type (car type)))
569	(case (car type)
570	((ret) 'out)
571	((fvec) (or (nth 3 type) 'in))
572	(t (or (nth 2 type) 'in))))
573
574	(defun gtk-composite-type-len (type)
575	(while (consp (car type))
576	(setq type (car type)))
577	(case (car type)
578	((ret) 1)
579	((fvec) (nth 2 type))
580	(t nil)))
581
582	(defun gtk-type-info (type)
583	(let*
584	((actual-type (gtk-outer-type type))
585	(typage (cond ((or (assq actual-type gtk-enums)
586	(assq actual-type gtk-imported-enums))
587	(assq 'enum gtk-type-alist))
588	((or (assq actual-type gtk-string-enums)
589	(assq actual-type gtk-imported-string-enums))
590	(assq 'senum gtk-type-alist))
591	((or (assq actual-type gtk-flags)
592	(assq actual-type gtk-imported-flags))
593	(assq 'flags gtk-type-alist))
594	((or (assq actual-type gtk-boxed)
595	(assq actual-type gtk-imported-boxed))
596	(assq 'boxed gtk-type-alist))
597	((or (assq actual-type gtk-objects)
598	(assq actual-type gtk-imported-objects))
599	(assq 'object gtk-type-alist))
600	(t
601	(assq actual-type gtk-type-alist)))))
602	(or typage (error "Unknown type: %s" type))))
603
604	(defmacro gtk-typage-prop (typage prop)
605	`(cdr (assq ,prop (nthcdr 5 ,typage))))
606
607	(defun gtk-type-decl (type typage)
608	(let
609	((decl (nth 1 typage)))
610	(if (functionp decl)
611	(funcall decl type typage)
612	decl)))
613
614	(defmacro gtk-type-fromrep (typage)
615	`(nth 2 ,typage))
616
617	(defmacro gtk-type-torep (typage)
618	`(nth 3 ,typage))
619
620	(defmacro gtk-type-pred (typage)
621	`(nth 4 ,typage))
622
623	(defun gtk-type-prop (type prop)
624	(gtk-typage-prop (gtk-type-info type) prop))
625
626
627	;; Function arg helpers
628
629	(defmacro gtk-get-arg-options (option arg)
630	`(assq ,option (nthcdr 2 ,arg)))
631
632	(defun gtk-arg-optional-p (arg)
633	(nth 1 (gtk-get-arg-options '= arg)))
634
635	(defmacro gtk-arg-type (arg)
636	`(car ,arg))
637
638	(defmacro gtk-arg-name (arg)
639	`(symbol-name (nth 1 ,arg)))
640
641
642	;; Type output functions
643
644	(defun output-complex-type (type typage)
645	(declare (unused typage))
646	(setq type (gtk-outer-type type))
647	(if (or (assq type gtk-enums) (assq type gtk-imported-enums)
648	(assq type gtk-flags) (assq type gtk-imported-flags))
649	(symbol-name type)
650	(format nil "%s*" type)))
651
652	(define (output-rep-to-static x)
653	(lambda (output type rep-var typage)
654	(setq type (gtk-outer-type type))
655	(let ((name (gtk-canonical-name (symbol-name type))))
656	(@ "$%s$ sgtk_rep_to_%s $%s, &sgtk_%s_info$"
657	(gtk-type-decl type typage) x rep-var name))))
658
659	(define (output-static-to-rep x)
660	(lambda (output type gtk-var typage)
661	(declare (unused typage))
662	(setq type (gtk-outer-type type))
663	(let ((name (gtk-canonical-name (symbol-name type))))
664	(@ "sgtk_%s_to_rep $%s, &sgtk_%s_info$" x gtk-var name))))
665
666	(define (output-static-pred x)
667	(lambda (output type rep-var typage)
668	(declare (unused typage))
669	(@ "sgtk_valid_%s $%s, &sgtk_%s_info$"
670	x rep-var (gtk-canonical-name (symbol-name type)))))
671
672	(define output-rep-to-enum (output-rep-to-static 'enum))
673	(define output-enum-to-rep (output-static-to-rep 'enum))
674	(define output-enum-pred (output-static-pred 'enum))
675
676	(define output-rep-to-senum (output-rep-to-static 'senum))
677	(define output-senum-to-rep (output-static-to-rep 'senum))
678	(define output-senum-pred (output-static-pred 'senum))
679
680	(define output-rep-to-flags (output-rep-to-static 'flags))
681	(define output-flags-to-rep (output-static-to-rep 'flags))
682	(define output-flags-pred (output-static-pred 'flags))
683
684	(defun output-rep-to-boxed (output type rep-var typage)
685	(declare (unused typage))
686	(setq type (gtk-outer-type type))
687	(@ "$%s*$ sgtk_rep_to_boxed $%s$" type rep-var))
688
689	(defun output-boxed-to-rep (output type gtk-var typage)
690	(declare (unused typage))
691	(let*
692	((base-type (gtk-outer-type type))
693	(name (gtk-canonical-name (symbol-name base-type)))
694	(copy (if (assq 'copy (cdr type))
695	(gtk-get-option 'copy (cdr type))
696	t)))
697	(@ "sgtk_boxed_to_rep $%s, &sgtk_%s_info, %d$"
698	gtk-var name (if copy 1 0))))
699
700	(defun output-boxed-pred (output type rep-var typage)
701	(declare (unused typage))
702	(@ "sgtk_valid_boxed $%s, &sgtk_%s_info$"
703	rep-var (gtk-canonical-name (symbol-name type))))
704
705	(defun output-rep-to-object (output type rep-var typage)
706	(declare (unused typage))
707	(setq type (gtk-outer-type type))
708	(@ "$%s*$ sgtk_get_gobj $%s$" type rep-var))
709
710	(defun output-object-to-rep (output type gtk-var typage)
711	(declare (unused typage))
712	(setq type (gtk-outer-type type))
713	(@ "sgtk_wrap_gobj $\(GObject*$ %s\)" gtk-var))
714
715	(defun output-object-pred (output type rep-var typage)
716	(declare (unused typage))
717	(@ "sgtk_is_a_gobj $%s_get_type \($, %s\)"
718	(gtk-canonical-name (symbol-name type)) rep-var))
719
720	(defun output-rep-to-full-callback (output type rep-var typage options)
721	(declare (unused typage type))
722	(let
723	((protect (gtk-get-option 'protection options)))
724	(cond ((eq protect 'result)
725	(@ "sgtk_new_protect $%s$" rep-var))
726	((and (not (eq protect t))
727	(not (eq protect nil)))
728	(@ "sgtk_protect $p_%s, %s$" protect rep-var))
729	(t
730	(@ "sgtk_protect $Qt, %s$" rep-var)))))
731
732	(defun output-full-callback-args (output type var options)
733	(declare (unused typage type options))
734	(@ "0, sgtk_callback_marshal, (gpointer)%s, sgtk_callback_destroy" var))
735
736	(defun output-full-callback-finish (output type g-var r-var options)
737	(declare (unused typage type r-var))
738	(let
739	((protect (gtk-get-option 'protection options)))
740	(when (eq protect 'result)
741	(@ " sgtk_set_protect $pr_ret, %s$;\n" g-var))))
742
743	(defun output-rep-to-gclosure (output type rep-var typage options)
744	(declare (unused typage type))
745	(let
746	((protect (gtk-get-option 'protection options)))
747	(cond ((eq protect 'result)
748	(@ "sgtk_new_gclosure $%s$" rep-var))
749	((and (not (eq protect t))
750	(not (eq protect nil)))
751	(@ "sgtk_gclosure $p_%s, %s$" protect rep-var))
752	(t
753	(@ "sgtk_gclosure $Qt, %s$" rep-var)))))
754
755	(defun output-gclosure-finish (output type g-var r-var options)
756	(declare (unused typage type r-var))
757	(let
758	((protect (gtk-get-option 'protection options)))
759	(when (eq protect 'result)
760	(@ " sgtk_set_gclosure $pr_ret, %s$;\n" g-var))))
761
762	(defun output-rep-to-cvec (output type rep-var typage)
763	(declare (unused typage))
764	(let*
765	((inner-type (gtk-inner-type type))
766	(inner-typage (gtk-type-info inner-type))
767	(decl (gtk-type-decl inner-type inner-typage))
768	(mode (gtk-composite-type-mode type)))
769	(output-helper inner-type standard-output)
770	(@ "sgtk_rep_to_cvec $%s, %s, sizeof \(%s$\)"
771	rep-var
772	(if (eq mode 'out)
773	"0"
774	(format nil "_sgtk_helper_fromrep_%s" inner-type))
775	decl)))
776
777	(defun output-cvec-to-rep (output type gtk-var typage)
778	(declare (unused typage))
779	(let*
780	((inner-type (gtk-inner-type type))
781	(inner-typage (gtk-type-info inner-type))
782	(decl (gtk-type-decl inner-type inner-typage)))
783	(output-helper inner-type standard-output)
784	(@ "sgtk_cvec_to_rep $&%s, _sgtk_helper_torep_copy_%s, sizeof \(%s$\)"
785	gtk-var inner-type decl)))
786
787	(defun output-cvec-pred (output type rep-var typage)
788	(declare (unused typage))
789	(let*
790	((inner-type (gtk-inner-type type))
791	(mode (gtk-composite-type-mode type))
792	(len (gtk-composite-type-len type)))
793	(output-helper inner-type standard-output)
794	(if len
795	(@ "sgtk_valid_complen $%s, %s, %s$"
796	rep-var
797	(if (eq mode 'out)
798	;; `out', so don't check inner validity
799	"NULL"
800	(concat "_sgtk_helper_valid_" (symbol-name inner-type)))
801	len)
802	(@ "sgtk_valid_composite $%s, _sgtk_helper_valid_%s$"
803	rep-var inner-type))))
804
805	(defun output-cvec-args (output type var options)
806	(declare (unused typage options))
807	(let*
808	((outer-type (gtk-outer-type type))
809	(inner-type (gtk-inner-type type))
810	(inner-typage (gtk-type-info inner-type))
811	(decl (gtk-type-decl inner-type inner-typage)))
812	(cond ((eq outer-type 'cvec)
813	(@ "%s.count, $%s*$ %s.vec" var decl var))
814	((eq outer-type 'cvecr)
815	(@ "$%s*$ %s.vec, %s.count" decl var var))
816	((memq outer-type '(fvec ret tvec))
817	(@ "$%s*$ %s.vec" decl var))
818	(t
819	(gtk-warning "Don't know how to pass type %s" type)))))
820
821	(defun output-cvec-finish (output type gtk-var rep-var options)
822	(declare (unused typage options))
823	(let*
824	((inner-type (gtk-inner-type type))
825	(inner-typage (gtk-type-info inner-type))
826	(decl (gtk-type-decl inner-type inner-typage))
827	(mode (gtk-composite-type-mode type)))
828	(@ " sgtk_cvec_finish $&%s, %s, %s, sizeof \(%s$\);\n"
829	gtk-var rep-var
830	(if (eq mode 'in)
831	"0"
832	(format nil "_sgtk_helper_torep_nocopy_%s" inner-type))
833	decl)))
834
835	(defun output-rep-to-list (output type rep-var typage)
836	(declare (unused typage))
837	(let
838	((outer-type (gtk-outer-type type))
839	(inner-type (gtk-inner-type type)))
840	(output-helper inner-type standard-output)
841	(@ "sgtk_rep_to_%s $%s, _sgtk_helper_fromrep_%s$"
842	outer-type rep-var inner-type)))
843
844	(defun output-list-to-rep (output type gtk-var typage)
845	(declare (unused typage))
846	(let
847	((outer-type (gtk-outer-type type))
848	(inner-type (gtk-inner-type type)))
849	(output-helper inner-type standard-output)
850	(@ "sgtk_%s_to_rep $%s, _sgtk_helper_torep_copy_%s$"
851	outer-type gtk-var inner-type)))
852
853	(defun output-list-finish (output type gtk-var rep-var options)
854	(declare (unused typage options))
855	(let
856	((outer-type (gtk-outer-type type))
857	(inner-type (gtk-inner-type type))
858	(mode (gtk-composite-type-mode type)))
859	(@ " sgtk_%s_finish $%s, %s, %s$;\n"
860	outer-type gtk-var rep-var
861	(if (eq mode 'in)
862	"0"
863	(format nil "_sgtk_helper_torep_nocopy_%s" inner-type)))))
864
865
866	;; Function generation
867
868	(defun output-function (def output #!optional function-callback)
869	(let*
870	((ret (nth 1 def))
871	(args (nth 2 def))
872	(options (nthcdr 3 def))
873	(fname (symbol-name (car def)))
874	(rname (or (gtk-get-option 'scm-name options)
875	(gtk-hyphenate-name fname)))
876	(cname (gtk-unhyphenate-name rname))
877	(subrtype (if (or (> (length args) 5)
878	(gtk-get-option 'rest-arg options))
879	'n
880	(length args))))
881	(setq gtk-subrs (cons cname gtk-subrs))
882
883	;; output header
884	(@ "DEFUN\(\"%s\", F%s, S%s, \(" rname cname cname)
885	(if (eq subrtype 'n)
886	(@ "repv args")
887	(if (zerop subrtype)
888	(@ "void")
889	(let
890	((tem args))
891	(while tem
892	(@ "repv p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " ""))
893	(setq tem (cdr tem))))))
894	(@ "\), rep_Subr%s\)\n{\n" (if (numberp subrtype) subrtype "N"))
895	(unless (eq ret 'none)
896	(@ " repv pr_ret;\n"))
897	(when (eq subrtype 'n)
898	(@ " repv ")
899	(let
900	((tem args))
901	(while tem
902	(@ "p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " ";\n\n"))
903	(setq tem (cdr tem)))))
904
905	;; output any gc roots required
906	(mapc (lambda (arg)
907	(when (or (gtk-get-arg-options 'protect-during arg)
908	(gtk-type-prop (gtk-arg-type arg) 'finish))
909	(@ " rep_GC_root gc_%s;\n" (gtk-arg-name arg)))) args)
910
911	;; output arg/ret decls
912	(mapc (lambda (arg)
913	(let*
914	((type (gtk-arg-type arg))
915	(typage (gtk-type-info type))
916	(decl (gtk-type-decl type typage)))
917	(if (stringp decl)
918	(@ " %s c_%s;\n" decl (gtk-arg-name arg))
919	(gtk-warning
920	"Don't know how to declare type: %s" type)))) args)
921	(unless (eq ret 'none)
922	(let*
923	((typage (gtk-type-info ret))
924	(decl (gtk-type-decl ret typage)))
925	(cond
926	((stringp decl)
927	(@ " %s cr_ret;\n" decl))
928	((functionp decl)
929	(funcall decl output ret "cr_ret" typage options))
930	(t
931	(gtk-warning
932	"Don't know how to declare type: %s" ret)))))
933	(unless (and (null args) (eq ret 'none))
934	(@ "\n"))
935
936	;; break out the list of parameters
937	(when (eq subrtype 'n)
938	(let
939	((tem args)
940	(i 1))
941	(while tem
942	(@ " if $!rep_CONSP\(args$\)\n")
943	(@ " p_%s = Qnil; \n" (gtk-arg-name (car tem)))
944	(@ " else {\n")
945	(@ (if (and (null (cdr tem)) (gtk-get-option 'rest-arg options))
946	" p_%s = args; args = Qnil;\n"
947	" p_%s = rep_CAR(args); args = rep_CDR(args);\n")
948	(gtk-arg-name (car tem)))
949	(@ " }\n")
950	(setq tem (cdr tem))
951	(setq i (1+ i)))
952	(@ "\n")))
953
954	;; output arg checks and conversions
955	(let
956	((tem args)
957	(i 1))
958	(while tem
959	(let*
960	((type (gtk-arg-type (car tem)))
961	(typage (gtk-type-info type))
962	(pred (gtk-type-pred typage))
963	(optional (gtk-arg-optional-p (car tem)))
964	(type-options (gtk-get-options type gtk-options)))
965	(when (gtk-get-option 'conversion type-options)
966	(@ " p_%s = %s $p_%s$;\n"
967	(gtk-arg-name (car tem))
968	(gtk-get-option 'conversion type-options)
969	(gtk-arg-name (car tem))))
970	(unless (or optional (null pred))
971	(when (gtk-get-arg-options 'null-ok (car tem))
972	(@ " if (p_%s != Qnil)\n " (gtk-arg-name (car tem))))
973	(@ " rep_DECLARE \(%d, p_%s, " i (gtk-arg-name (car tem)))
974	(cond ((stringp pred)
975	(@ "%s $p_%s$" pred (gtk-arg-name (car tem))))
976	((functionp pred)
977	(funcall pred output type
978	(concat "p_" (gtk-arg-name (car tem)))
979	typage options))
980	(t
981	(gtk-warning "Don't know type predicate: %s" type)))
982	(@ "\);\n"))
983	(setq tem (cdr tem))
984	(setq i (1+ i)))))
985	(when args
986	(@ "\n"))
987
988	;; initialise gc roots
989	(mapc (lambda (arg)
990	(when (or (gtk-get-arg-options 'protect-during arg)
991	(gtk-type-prop (gtk-arg-type arg) 'finish))
992	(@ " rep_PUSHGC $gc_%s, p_%s$;\n"
993	(gtk-arg-name arg) (gtk-arg-name arg)))) args)
994
995	;; output arg initialisations
996	(mapc (lambda (arg)
997	(let*
998	((type (gtk-arg-type arg))
999	(typage (gtk-type-info type))
1000	(from (gtk-type-fromrep typage))
1001	(optional (gtk-arg-optional-p arg)))
1002	(when (gtk-get-arg-options 'null-ok arg)
1003	(@ " if (p_%s == Qnil)\n c_%s = 0; \n else\n "
1004	(gtk-arg-name arg) (gtk-arg-name arg)))
1005	(when optional
1006	(@ " if $p_%s == Qnil$\n c_%s = %s;\n else\n "
1007	(gtk-arg-name arg) (gtk-arg-name arg) optional))
1008	(@ " c_%s = " (gtk-arg-name arg))
1009	(cond ((stringp from)
1010	(@ "%s $p_%s$" from (gtk-arg-name arg)))
1011	((functionp from)
1012	(funcall from output type
1013	(concat "p_" (gtk-arg-name arg))
1014	typage options))
1015	(t
1016	(gtk-warning
1017	"Don't know how to convert repv to %s" type)))
1018	(@ ";\n"))) args)
1019	(when args
1020	(@ "\n"))
1021
1022	(if function-callback
1023	(funcall function-callback output)
1024	;; output call
1025	(@ " ")
1026	(unless (eq ret 'none)
1027	(@ "cr_ret = "))
1028	(@ "%s \(" fname)
1029	(let
1030	((tem args))
1031	(while tem
1032	(let
1033	((opt (gtk-type-prop (gtk-arg-type (car tem)) 'c2args)))
1034	(if opt
1035	(if (functionp opt)
1036	(funcall opt output (gtk-arg-type (car tem))
1037	(concat "c_" (gtk-arg-name (car tem)))
1038	options)
1039	(gtk-warning "c2args function %s undefined" opt))
1040	(@ "c_%s" (gtk-arg-name (car tem)))))
1041	(@ (if (cdr tem) ", " ""))
1042	(setq tem (cdr tem))))
1043	(@ "\);\n\n"))
1044
1045	;; output ret conversion
1046	(unless (eq ret 'none)
1047	(let*
1048	((typage (gtk-type-info ret))
1049	(to (gtk-type-torep typage)))
1050	(@ " pr_ret = ")
1051	(cond ((stringp to)
1052	(@ "%s $cr_ret$" to))
1053	((functionp to)
1054	(funcall to output ret "cr_ret" typage options))
1055	(t
1056	(gtk-warning
1057	"Don't know how to convert %s to repv" ret)))
1058	(@ ";\n")))
1059
1060	;; output `finish' options
1061	(mapc (lambda (arg)
1062	(let
1063	((opt (gtk-type-prop (gtk-arg-type arg) 'finish)))
1064	(when opt
1065	(if (functionp opt)
1066	(funcall opt output (gtk-arg-type arg)
1067	(concat "c_" (gtk-arg-name arg))
1068	(concat "p_" (gtk-arg-name arg))
1069	options)
1070	(gtk-warning "finish function %s undefined" opt))))) args)
1071
1072	;; pop gc roots
1073	(mapc (lambda (arg)
1074	(when (or (gtk-get-arg-options 'protect-during arg)
1075	(gtk-type-prop (gtk-arg-type arg) 'finish))
1076	(@ " rep_POPGC;\n"
1077	(gtk-arg-name arg) (gtk-arg-name arg)))) args)
1078
1079	;; output return statement
1080	(if (eq ret 'none)
1081	(@ " return Qnil;\n")
1082	(@ " return pr_ret;\n"))
1083
1084	;; footer
1085	(@ "}\n\n")))
1086
1087
1088	;; Field access functions
1089
1090	(defun output-field-functions (type-list output)
1091	(mapc (lambda (def)
1092	(let
1093	((fields (cdr (assq 'fields (cdr def)))))
1094	(when fields
1095	(mapc #'(lambda (field)
1096	(output-field-accessors
1097	(car def) field output
1098	(car (cdr (assq 'setter (nthcdr 2 field))))
1099	(car (cdr (assq 'getter (nthcdr 2 field))))))
1100	fields))
1101	(output-type-predicate (car def) output)))
1102	type-list))
1103
1104	(defun output-field-accessors (datatype field output #!optional settable getter)
1105	(let*
1106	((type (car field))
1107	(cdatatype (gtk-canonical-name (symbol-name datatype)))
1108	(cfieldname (symbol-name (nth 1 field))))
1109	(output-function (list (intern (format nil "%s_%s" cdatatype cfieldname))
1110	type (list (list datatype 'obj)))
1111	output
1112	(lambda (output)
1113	(if getter
1114	(@ " cr_ret = %s (c_obj);\n" getter)
1115	(@ " cr_ret = c_obj->%s;\n" cfieldname))))
1116	(when settable
1117	(output-function (list (intern (format nil "%s_%s_set"
1118	cdatatype cfieldname))
1119	'none (list (list datatype 'obj)
1120	(list type 'data)))
1121	output
1122	(lambda (output)
1123	(@ " c_obj->%s = c_data;\n" cfieldname))))))
1124
1125	(defun output-type-predicate (type output)
1126	(let*
1127	((typage (gtk-type-info type))
1128	(ctype (gtk-canonical-name (symbol-name type)))
1129	(rtype (gtk-hyphenate-name ctype))
1130	(pred (gtk-type-pred typage)))
1131	(cond ((stringp pred)
1132	(setq pred (format nil "%s $p_obj$" pred)))
1133	((functionp pred)
1134	(let
1135	((temporary-output (make-string-output-stream)))
1136	(funcall pred temporary-output type "p_obj" typage nil)
1137	(setq pred (get-output-stream-string temporary-output))))
1138	((null pred)
1139	(setq pred "1")))
1140	(@ "DEFUN$\"%s-p\", F%s_p, S%s_p, \(repv p_obj$, rep_Subr1\)\n{\n"
1141	rtype ctype ctype)
1142	(@ " return $%s$ ? Qt : Qnil;\n}\n\n" pred)
1143	(setq gtk-subrs (cons (intern (format nil "%s_p" ctype)) gtk-subrs))))
1144
1145
1146	;; Composite type helper functions
1147
1148	(defun output-helper (type output)
1149	(unless (memq type gtk-emitted-composite-helpers)
1150	(setq gtk-emitted-composite-helpers
1151	(cons type gtk-emitted-composite-helpers))
1152	(let*
1153	((typage (gtk-type-info type))
1154	(pred (gtk-type-pred typage))
1155	(decl (gtk-type-decl type typage))
1156	(from (gtk-type-fromrep typage))
1157	(to (gtk-type-torep typage)))
1158
1159	;; use some hackery to get from, to, and pred functions as strings
1160	(cond ((stringp from)
1161	(setq from (concat from " $obj$")))
1162	((functionp from)
1163	(let
1164	((temporary-output (make-string-output-stream)))
1165	(funcall from temporary-output type "obj" typage nil)
1166	(setq from (get-output-stream-string temporary-output)))))
1167	(cond ((stringp to)
1168	(setq to (format nil "%s $\(%s$mem\)" to decl)))
1169	((functionp to)
1170	(let
1171	((temporary-output (make-string-output-stream)))
1172	(funcall to temporary-output type
1173	(format nil "$\(%s$mem\)" decl) typage nil)
1174	(setq to (get-output-stream-string temporary-output)))))
1175	(cond ((stringp pred)
1176	(setq pred (format nil "%s $obj$" pred)))
1177	((functionp pred)
1178	(let
1179	((temporary-output (make-string-output-stream)))
1180	(funcall pred temporary-output type "obj" typage nil)
1181	(setq pred (get-output-stream-string temporary-output))))
1182	((null pred)
1183	(setq pred "1")))
1184
1185	(unless (and (stringp decl) (stringp pred) (stringp from) (stringp to))
1186	(error "Can't create composite helper for %s" type))
1187	(@ "/* helpers for %s */\n" type)
1188	(@ "static int\n_sgtk_helper_valid_%s $repv obj$\n" type)
1189	(@ "\{\n return obj == Qnil \|\| $%s$;\n\}\n" pred)
1190	(@ "static void\n_sgtk_helper_fromrep_%s $repv obj, void *mem$\n" type)
1191	(@ "\{\n $%s$mem = %s;\n\}\n" decl from)
1192	(@ "static repv\n_sgtk_helper_torep_copy_%s $void *mem$\n" type)
1193	(@ "\{\n return %s;\n\}\n" to)
1194	;; XXX presumably there should be a difference between the
1195	;; XXX copy and no_copy variants!?
1196	(@ "static repv\n_sgtk_helper_torep_nocopy_%s $void *mem$\n" type)
1197	(@ "\{\n return %s;\n\}\n\n" to))))
1198
1199
1200	;; Sundries
1201
1202	(defun gtk-canonical-name (name)
1203	(let
1204	((out nil)
1205	(point 0))
1206	(while (string-match "[A-Z]+" name point)
1207	(setq out (cons (substring name point (match-start)) out))
1208	(unless (zerop point)
1209	(setq out (cons ?_ out)))
1210	(setq out (cons (translate-string (substring
1211	name (match-start) (match-end))
1212	downcase-table) out))
1213	(setq point (match-end)))
1214	(if out
1215	(progn
1216	(setq out (cons (substring name point) out))
1217	(apply concat (nreverse out)))
1218	name)))
1219
1220	(defun gtk-hyphenate-name (name)
1221	(if (string-match "_" name)
1222	(translate-string (copy-sequence name) gtk-hyphen-map)
1223	name))
1224
1225	(defun gtk-unhyphenate-name (name)
1226	(if (string-match "-" name)
1227	(translate-string (copy-sequence name) gtk-unhyphen-map)
1228	name))
1229
1230	(defun gtk-warning (fmt . args)
1231	(apply format standard-error fmt args)
1232	(write standard-error ?\n))
1233
1234
1235	;; initialisation
1236
1237	(define-type 'type "GtkType" "sgtk_rep_to_type"
1238	"sgtk_type_to_rep" "sgtk_valid_type")
1239
1240	(define-type 'char "gchar" "sgtk_rep_to_char"
1241	"sgtk_char_to_rep" "sgtk_valid_char")
1242
1243	(define-type 'bool "int" "sgtk_rep_to_bool" "sgtk_bool_to_rep" nil)
1244
1245	;; XXX fix the validation functions
1246	(define-type 'short "short" "sgtk_rep_to_int" "sgtk_int_to_rep"
1247	"sgtk_valid_int" '(listable . t))
1248	(define-type 'ushort "gushort" "sgtk_rep_to_uint" "sgtk_uint_to_rep"
1249	"sgtk_valid_uint" '(listable . t))
1250
1251	(define-type 'int "gint" "sgtk_rep_to_int" "sgtk_int_to_rep"
1252	"sgtk_valid_int" '(listable . t))
1253
1254	(define-type 'uint "guint" "sgtk_rep_to_uint" "sgtk_uint_to_rep"
1255	"sgtk_valid_uint" '(listable . t))
1256
1257	(define-type 'long "glong" "sgtk_rep_to_long"
1258	"sgtk_long_to_rep" "sgtk_valid_long")
1259
1260	(define-type 'ulong "gulong" "sgtk_rep_to_ulong"
1261	"sgtk_ulong_to_rep" "sgtk_valid_ulong")
1262
1263	(define-type 'float "gfloat" "sgtk_rep_to_float"
1264	"sgtk_float_to_rep" "sgtk_valid_float")
1265
1266	(define-type 'string "char*" "sgtk_rep_to_string"
1267	"sgtk_string_to_rep" "sgtk_valid_string" '(listable . t))
1268
1269	(define-type 'enum output-complex-type output-rep-to-enum
1270	output-enum-to-rep output-enum-pred)
1271
1272	(define-type 'senum "char*" output-rep-to-senum
1273	output-senum-to-rep output-senum-pred)
1274
1275	(define-type 'flags output-complex-type output-rep-to-flags
1276	output-flags-to-rep output-flags-pred)
1277
1278	(define-type 'boxed output-complex-type output-rep-to-boxed
1279	output-boxed-to-rep output-boxed-pred '(listable . t))
1280
1281	(define-type 'pointer "gpointer" "sgtk_rep_to_pointer"
1282	"sgtk_pointer_to_rep" "sgtk_valid_pointer")
1283
1284	(define-type 'object output-complex-type output-rep-to-object
1285	output-object-to-rep output-object-pred '(listable . t))
1286
1287	(define-type 'static_string "const char*" nil
1288	"sgtk_static_string_to_rep" nil '(listable . t))
1289
1290	(define-type 'full-callback "sgtk_protshell*" output-rep-to-full-callback nil
1291	"sgtk_valid_function" (cons 'c2args output-full-callback-args)
1292	(cons 'finish output-full-callback-finish))
1293
1294	(define-type 'gclosure "GClosure*" output-rep-to-gclosure nil
1295	"sgtk_valid_function" (cons 'finish output-full-callback-finish))
1296
1297	(define-type 'file-descriptor "int" "sgtk_rep_to_fd"
1298	"sgtk_fd_to_rep" "sgtk_valid_fd")
1299
1300	(define-type 'list "GList*" output-rep-to-list output-list-to-rep
1301	output-cvec-pred (cons 'finish output-list-finish))
1302
1303	(define-type 'slist "GSList*" output-rep-to-list output-list-to-rep
1304	output-cvec-pred (cons 'finish output-list-finish))
1305
1306	(define-type 'cvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep
1307	output-cvec-pred (cons 'finish output-cvec-finish)
1308	(cons 'c2args output-cvec-args))
1309
1310	(define-type 'cvecr "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep
1311	output-cvec-pred (cons 'finish output-cvec-finish)
1312	(cons 'c2args output-cvec-args))
1313
1314	(define-type 'fvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep
1315	output-cvec-pred (cons 'finish output-cvec-finish)
1316	(cons 'c2args output-cvec-args))
1317
1318	(define-type 'tvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep
1319	output-cvec-pred (cons 'finish output-cvec-finish)
1320	(cons 'c2args output-cvec-args))
1321
1322	(define-type 'ret "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep
1323	output-cvec-pred (cons 'finish output-cvec-finish)
1324	(cons 'c2args output-cvec-args))
1325
1326	(define-type 'double "gdouble" "sgtk_rep_to_double"
1327	"sgtk_double_to_rep" "sgtk_valid_double")
1328
1329	(define-type 'point "GdkPoint" "sgtk_rep_to_point"
1330	"sgtk_point_to_rep" "sgtk_valid_point")
1331
1332	(define-type 'rect "GdkRectangle" "sgtk_rep_to_rect"
1333	"sgtk_rect_to_rep" "sgtk_valid_rect")
1334
1335	(define-type 'SCM "repv" "" "" nil)

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format