source: project/release/3/gtk2/trunk/wrap.scm @ 9932

Last change on this file since 9932 was 9932, checked in by Kon Lovett, 12 years ago

Rel 0.311 w/ Explict use of SRFI 69.

  • Property svn:executable set to *
File size: 22.3 KB
Line 
1; Wrap program for gtk2.
2; Copyright (c) 2002-2007 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
3;
4; Permission is hereby granted, free of charge, to any person obtaining a copy of this
5; software and associated documentation files (the "Software"), to deal in the Software
6; without restriction, including without limitation the rights to use, copy, modify,
7; merge, publish, distribute, sublicense, and/or sell copies of the Software, and to
8; permit persons to whom the Software is furnished to do so, subject to the following
9; conditions:
10;
11; The above copyright notice and this permission notice shall be included in all copies
12; or substantial portions of the Software.
13;
14; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
15; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
16; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
17; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
18; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19; DEALINGS IN THE SOFTWARE.
20#>
21#include <gtk/gtk.h>
22<#
23(define *wrap-version* "2.6")
24
25(require 'extras)       ;; To get string-map to allow it to be redefined by srfi-13
26
27(require 'srfi-1        ;; List library
28         'srfi-13       ;; String library
29         'srfi-18       ;; Raise - exceptions
30         'srfi-37       ;; args-fold - option handling
31         'srfi-69)      ;; hash-table
32(require 'utils)
33
34(require-for-syntax 'chicken-more-macros)
35;(require-for-syntax 'srfi-26)          ; I'm using cut/cute below
36                                        ; - they happen to be builtin
37                                        ; in chicken.
38
39(require 'gtk2-gobject)
40(require-for-syntax 'gtk2-gobject)
41
42(include "gobject-macros.scm")
43
44
45(gtype:init-types-from-file "gdk-types-00")
46(gtype:init-types-from-file "gdk-types-01")
47
48(gtype:init-types-from-file "gtk-types-00")
49(gtype:init-types-from-file "gtk-types-01")
50(gtype:init-types-from-file "gtk-types-02")
51(gtype:init-types-from-file "gtk-types-03")
52(gtype:init-types-from-file "gtk-types-04")
53
54
55(case-sensitive #t)
56;;@function (eprint [item]...)
57;; Prints listed items to the error output.
58(define (eprint . x)
59  (with-output-to-port (current-error-port)
60    (lambda ()
61      (apply print x))))
62
63(define *include-path* (list "."))
64(define *output-dir* #f)
65(define *header-string* "")
66(define *manual-wrap* '())
67
68;---------------------------------------------------------------------------;
69;;@function (symbol-append [arg]...)
70;; Concatenates strings and symbols into a single symbol
71(define (symbol-append . args)
72  (string->symbol
73   (apply string-append
74          (map (lambda (x)
75                 (if (symbol? x)
76                     (symbol->string x)
77                     x))
78               args))))
79
80;;@function (schemeify name)
81;; Turns a C name into an equivalent Scheme symbol.
82(define (schemeify name)
83  (string->symbol
84   (string-map (lambda (ch)
85                 (case ch
86                   ((#\_) #\-)
87                   (else (char-downcase ch))))
88               (if (string? name)
89                   name
90                   (symbol->string name)))))
91
92;;@function (cify name)
93;; Turns a Scheme symbol into an equivalent C name
94(define (cify name)
95  (string->symbol
96   (string-append (string-map (lambda (ch)
97                                (case ch
98                                  ((#\-) #\_)
99                                  (else ch)))
100                              (if (string? name)
101                                  name
102                                  (symbol->string name)))
103                  "_")))
104
105;;@function (basetype-for type)
106;; Removes C pointer symbols (*) and consts to derive the basic type referred to.
107(define (basetype-for type)
108  (let* ((typestr (if (symbol? type)
109                      (symbol->string type)
110                      type))
111         (nostars (string-trim-right typestr #\*))
112         (noconst (if (string-prefix? "const-" nostars)
113                      (substring nostars 6 (string-length nostars))
114                      nostars)))
115    (string->symbol noconst)))
116
117;;@function (basic-type type)
118;; Predicate: is type the basetype?
119(define (basic-type? type)
120  (eq? (basetype-for type) type))
121
122;;@function (unsupported-type type . reason)
123;; Raise an error condition concerning an unsupported type
124(define (unsupported-type type . reason)
125  (raise (cons* 'unsupported-type type reason)))
126
127;;@function (translate-type type is-return-type)
128;; Turn a gtk+ type into a Chicken foreign type
129(define (translate-type type is-return-type)
130  (assert (symbol? type))
131  (cond
132   ((or (string-suffix? "**" (symbol->string type))
133        (string-suffix? "[]" (symbol->string type)))
134    (unsupported-type type 'too-much-indirection))
135   (else
136    (case type
137      ((none)                           (values 'void 'simple))
138      ((gboolean bool)                  (values 'bool 'simple))
139      ((gchar char gint8)               (values 'char 'simple))
140      ((guchar guint8)                  (values 'unsigned-char 'simple))
141      ((gint gint32 int)                (values 'integer 'simple))
142      ((guint guint32 uint)             (values 'unsigned-integer 'simple))
143      ((guint16 uint16)                 (values 'unsigned-short 'simple))
144      ((gulong ulong)                   (values 'unsigned-long 'simple))
145      ((gdouble double gfloat float)    (values 'double 'simple))
146      ((const-gchar*
147        consg-gchar*    ;; there's a typo in one of the .defs files
148        const-char*
149        gchar*
150        char*
151        string)                         (values 'c-string 'simple))
152      ((const-guchar*
153        guchar*)                        (if is-return-type
154                                            (unsupported-type type
155                                                              'unsupported-as-result-type)
156                                            (values 'byte-vector 'simple)))
157
158      ((GType
159        GtkType)                        (values 'unsigned-long 'enum-or-flags))
160      ((GValue*
161        GObjectClass*)                  (values 'c-pointer 'boxed))
162
163      (else
164       (let* ((basetype (basetype-for type))
165              (g (fluid-let ((g-warning (lambda _ _)))
166                   (gtype-from-name (symbol->string basetype))))
167              (f (and g (gtype->fundamental g))))
168         (cond
169          ((not f)                              (unsupported-type type
170                                                                  'not-found-by-name basetype))
171          ((member f (list gtype:flags
172                           gtype:enum))         (values 'unsigned-integer 'enum-or-flags))
173          ((member f (list gtype:boxed
174                           gtype:interface
175                           gtype:object))       (values 'c-pointer 'boxed))
176          (else                                 (unsupported-type type g f)))))))))
177
178(define-record func-arg name cname type ctype style)
179
180;;@function (chew-parameters parameters)
181;; Given a list of parameters, take the cadr of each and then with the
182;; cadr treat it as a (type name) pair, translate the type into a chicken
183;; foreign type/style pair and construct a func-arg record containing (name,
184;; c-name, type, c-type, style).
185
186(define (chew-parameters parameters)
187  (eprint "chew-parameters: " parameters)
188  (map (lambda (param)
189         (let ((type (string->symbol (first param)))
190               (name (string->symbol (second param))))
191           (receive (ctype style)
192               (translate-type type #f)
193             (begin ;;;(eprint "About to call make-func-arg with the following parameters: (name = " name ", c-name = " (cify name) ", type = " type ", ctype = " ctype ", style = " style ")")
194             (make-func-arg name
195                            (cify name)
196                            type
197                            ctype
198                            style)))))
199       (map second parameters)))
200
201;;@function (find-manual-override name)
202;; Find a manual function definition for a given name, if there
203;; is one.
204(define (find-manual-override name)
205  (let ((scheme-name (schemeify name)))
206    (let loop ((function-defs *manual-wrap*))
207      (if (null? function-defs)
208          #f
209          (let ((fn (car function-defs)))
210            (if (eq? scheme-name (caadr fn))
211                fn
212                (loop (cdr function-defs))))))))
213
214;;@function (emit-function name c-name return-type parameters)
215;; Write a function definition
216(define (emit-function name c-name return-type parameters)
217  (eprint "emit-function: name = " name ", c-name = " c-name ", return-type = " return-type ", parameters = " parameters)
218  (if
219   (let ((x (find-manual-override name)))
220     (if x
221         (begin
222           (printf "; Manually overridden.\n")
223           (pretty-print x)))
224     x)
225   #t
226   (handle-exceptions
227    exn
228    (begin
229        ;;; (eprint "Error in emit-function: name = " name ", c-name = " c-name ", return-type = " return-type ", parameters = (" parameters "), exception = " exn)
230      (cond
231       ((and (pair? exn)
232             (eq? (car exn) 'unsupported-type))
233        (let ((emsg (list ";;; Skipped - "c-name" - unsupported type - "(cdr exn))))
234          (apply print emsg)
235          (apply eprint emsg))
236        #f)
237       (else (raise exn))))
238   
239    (let ((args (chew-parameters parameters)))
240     ;;; (eprint "Returned from chew-parameters with args = : " args)
241      (receive (chicken-rettype rettype-style) (translate-type (string->symbol return-type) #t)
242               (let* ((inner-body
243                       `((foreign-safe-lambda
244                          ;; return type
245                          ,chicken-rettype
246                         
247                          ;; c-name
248                          ,c-name
249                         
250                          ;; argument list
251                          ,@(map func-arg-ctype args)
252                         
253                          )
254                         
255                         ;; argument values
256                         ,@(map (lambda (a)
257                                  (case (func-arg-style a)
258                                    ((simple) (func-arg-name a))
259                                    ((enum-or-flags)
260                                     (if (not (basic-type? (func-arg-type a)))
261                                         (unsupported-type (func-arg-type a)))
262                                     `(,(symbol-append (func-arg-type a) '->number)
263                                       ,(func-arg-name a)))
264                                    ((boxed) `(,(symbol-append 'g:unbox- (basetype-for (func-arg-type a)))
265                                               ,(func-arg-name a)))))
266                                args)))
267                     
268                      (outer-body
269                       (case rettype-style
270                         ((simple enum-or-flags) inner-body)
271                         ((boxed) `(,(symbol-append 'g:box- (basetype-for return-type)) ,inner-body)))))
272                 
273                 (pretty-print
274                  `(define (,(schemeify c-name) ,@(map func-arg-name args))
275                     ,outer-body))))
276      #t))))
277
278;---------------------------------------------------------------------------;
279
280(define-record classdef name class-methods methods)
281
282(define *functions* (make-hash-table))
283(define *classes* (make-hash-table string=?))
284
285;;@function (register-function! name body)
286;; Store a function's name and body in the *functions* hash table
287(define (register-function! name body)
288  (eprint "Registering function: " name)
289  (cond
290   ((assq 'is-constructor-of body) (register-method! name body))
291   ((hash-table-exists? *functions* name)
292    (begin
293      (eprint ";; Warning! redefining function "name)
294      (hash-table-set! *functions* name body)))
295   (else (hash-table-set! *functions* name body))))
296
297;;@function (lookup-classdef classname)
298;;  Look up the classname in the *classes* hash table, returning #f if it
299;;  doesn't exist.
300(define (lookup-classdef classname)
301  (hash-table-ref/default *classes* classname #f))
302
303;;@function (register-method! name body)
304;; Add a method to the class definition for its class (which is created if
305;; it isn't already there)
306(define (register-method! name body)
307  (receive (classname is-class-method)
308      (cond
309       ((assq 'of-object body) => (compose (cut values <> #f) cadr))
310       ((assq 'is-constructor-of body) => (compose (cut values <> #t) cadr))
311       (else (eprint ";; Warning! Method "name" registered without class name!")
312             (values #f #f)))
313    (eprint "Registering method: " name " (class " classname ")")
314    (if classname
315        (let* ((classname (if (symbol? classname)
316                              (symbol->string classname)
317                              classname))
318               (classdef (or (lookup-classdef classname)
319                             (let ((cd (make-classdef classname '() '())))
320                               (hash-table-set! *classes* classname cd)
321                               cd))))
322          (if is-class-method
323              (classdef-class-methods-set! classdef
324                                           (cons (list name body)
325                                                 (classdef-class-methods classdef)))
326              (classdef-methods-set! classdef
327                                     (cons (list name body)
328                                           (classdef-methods classdef))))))))
329
330;---------------------------------------------------------------------------;
331
332;;@function (generate-file filename thunk)
333;; Write out a generated (code) file
334(define (generate-file filename thunk)
335  (let ((path (make-pathname *output-dir* filename "scm")))
336    (eprint "; Generating file " path)
337    (with-output-to-file path
338      (lambda ()
339        (print ";;; -*- scheme -*-")
340        (print ";;; Auto-generated from file "filename" by wrap.scm")
341        (print ";;; $Id: wrap.scm,v 1.5 2002/10/12 23:54:40 tonyg Exp $")
342        (print *header-string*)
343        (newline)
344        (thunk)))))
345
346;---------------------------------------------------------------------------;
347
348(define class-units '())
349
350;;@function (emit-methods-for classname)
351;; Write class methods out
352(define (emit-methods-for classname)
353  ;;; (eprint "emit-methods-for: " classname)
354  (let ((classdef (lookup-classdef classname)))
355    (when classdef
356      ;; Class methods.
357      ;;
358      (for-each (lambda (function)
359                  (let ((name (first function))
360                        (body (second function)))
361                    ;;; (eprint "emit-function call  1 in emit-methods-for " classname)
362                    (emit-function name
363                                   (cadr (assq 'c-name body))
364                                   (cond
365                                    ((assq 'return-type body) => cadr)
366                                    (else "none"))
367                                   (cond
368                                    ((assq 'parameters body) => cdr)
369                                    (else '())))))
370                (classdef-class-methods classdef))
371
372      ;; Methods.
373      ;;
374      (for-each (lambda (method)
375                  (let ((gfname (first method))
376                        (body (second method)))
377                    (let ((c-name (cadr (assq 'c-name body)))
378                          (of-object (cadr (assq 'of-object body))))
379                      ;;; (eprint "emit-function call 2 in emit-methods-for " classname)
380                      (if (emit-function c-name
381                                         c-name
382                                         (cond
383                                          ((assq 'return-type body) => cadr)
384                                          (else "none"))
385                                         (cons `(quote (,(string-append of-object "*")
386                                                        "self__param"))
387                                               (cond
388                                                ((assq 'parameters body) => cdr)
389                                                (else '()))))
390                          (begin
391                            (newline)
392                            (pretty-print
393                             `(gobject:register-method! ,of-object
394                                                        ',(schemeify gfname)
395                                                        ',(schemeify c-name)
396                                                        ,(schemeify c-name)))
397                            (newline))))))
398                (classdef-methods classdef)))))
399
400;;@function (emit-classdef classname filebase)
401;; Write a class out
402(define (emit-classdef classname filebase)
403  ;;; (eprint "emit-classdef: " classname ", filebase: " filebase)
404  (generate-file
405   filebase
406   (lambda ()
407     (set! class-units (cons filebase class-units))
408     (for-each pretty-print
409               (list
410
411                ;; We're a unit, because we'll all be assembled
412                ;; into a giant extension later.
413                ;;
414                `(declare (unit ,(string->symbol filebase)))
415
416                ;; Predicate.
417                ;;
418                `(define ,(symbol-append classname '?)
419                   (let ((t (gtype-from-name ,classname)))
420                     (lambda (x)
421                       (and (gobject? x)
422                            (gtype-isa? (gobject-type x) t)))))
423
424                ;; Wrapper.
425                ;;
426                `(define ,(symbol-append 'g:box- classname) wrap-gobject)
427
428                ;; Unwrapper.
429                ;;
430                `(define ,(symbol-append 'g:unbox- classname) gobject-pointer)))
431     (newline)
432
433     (emit-methods-for classname)
434     (newline))))
435
436;;@function (for-each-type fn root-type)
437;; Traverse a family tree of a type
438(define (for-each-type fn root-type)
439  ;;; (eprint "for-each-type: " root-type)
440  (let walk ((t root-type))
441    (let ((kids (gtype-children t)))
442      ;;; (eprint "for-each-type: in walk, kids = " kids)
443      (fn t)
444      (for-each walk kids))))
445
446;;@function (for-each-child-type fn root-type)
447;; Hm....
448(define (for-each-child-type fn root-type)
449  ;;; (eprint "for-each-child-type: " root-type)
450  (let ((kids (gtype-children root-type)))
451    ;;; (eprint "for-each-child-type: kids = " kids)
452    (for-each (cute for-each-type fn <>) kids)))
453
454;;@function (emit-classes root-type prefix)
455;; Write out all classes of a root type
456(define (emit-classes root-type prefix)
457  ;;; (eprint "emit-classes: " root-type ", prefix: " prefix)
458  (for-each-child-type
459   (lambda (class)
460     (let* ((classname (gtype-name class))
461            (filebase (string-downcase (string-append prefix"-"classname))))
462       (emit-classdef classname filebase)))
463   root-type))
464
465;;@function (emit-objects)
466;; Thunk to write out all classes derived from GObject.
467(define (emit-objects)
468  ;;; (eprint "emit-objects")
469  (emit-classes (gtype-from-name "GObject")
470                "wrap-class"))
471
472;;@function (emit-interfaces)
473;; Thunk to write out all classes derived from Ginterface
474(define (emit-interfaces)
475  ;;; (eprint "emit-interfaces")
476  (emit-classes (gtype-from-name "GInterface")
477                "wrap-interface"))
478
479;;@function (emit-classes-main)
480;; Thunk to produce the file wrap-classes.scm which incorporates all
481;; the other wrap files through the "use" form.
482(define (emit-classes-main)
483  ;;; (eprint "emit-classes-main")
484  (generate-file
485   "wrap-classes"
486   (lambda ()
487    (for-each (lambda (x) (display (string-append "(declare (uses " x "))\n"))) class-units))))
488
489;;@function (emit-boxeds)
490;; Thunk to produce the file wrap-boxed.scm which produces definitions
491;; for the boxed classes.
492(define (emit-boxeds)
493  ;;; (eprint "emit-boxeds")
494  (generate-file
495   "wrap-boxed"
496   (lambda ()
497     (for-each-child-type
498      (lambda (t)
499        (let ((c-name (gtype-name t)))
500          (for-each pretty-print
501                    (list
502                     `(define ,(symbol-append c-name '?)
503                        (let ((t (gtype-from-name ,c-name)))
504                          (lambda (x)
505                            (and (gboxed? x)
506                                 (gtype-isa? (gboxed-type x) t)))))
507                     `(define ,(symbol-append 'g:box- c-name)
508                        (let ((t (gtype-from-name ,c-name)))
509                          (lambda (p)
510                            (wrap-gboxed t p))))
511                     `(define ,(symbol-append 'g:unbox- c-name) gboxed-pointer)))
512          (newline)
513          (emit-methods-for c-name)
514          (newline)))
515      (gtype-from-name "GBoxed")))))
516
517;;@function (emit-enums)
518;; Thunk to produce the file wrap-enum.scm which produces definitions
519;; for the enum classes.
520(define (emit-enums)
521  ;;; (eprint "emit-enums")
522  (generate-file
523   "wrap-enum"
524   (lambda ()
525     (for-each-child-type
526      (lambda (t)
527        (let ((c-name (gtype-name t)))
528          (for-each pretty-print
529                    (list
530                     `(define ,(symbol-append c-name '->number)
531                        (make-genum-nick->number (gtype-from-name ,c-name)))
532                     `(define ,(symbol-append 'number-> c-name)
533                        (make-genum-number->nick (gtype-from-name ,c-name))))))
534        (newline))
535      (gtype-from-name "GEnum")))))
536
537;;@function (emit-flags)
538;; Thunk to produce the file wrap-flags.scm which produces definitions
539;; for the flags classes.
540(define (emit-flags)
541  ;;; (eprint "emit-flags")
542  (generate-file
543   "wrap-flags"
544   (lambda ()
545     (for-each-child-type
546      (lambda (t)
547        (let ((c-name (gtype-name t)))
548          (for-each pretty-print
549                    (list
550                     `(define ,(symbol-append c-name '->number)
551                        (make-gflags->number (gtype-from-name ,c-name)))
552                     `(define ,(symbol-append 'number-> c-name)
553                        (make-number->gflags (gtype-from-name ,c-name))))))
554        (newline))
555      (gtype-from-name "GFlags")))))
556
557;;@function (emit-functions)
558;; Thunk to produce the file wrap-functions.scm which produces definitions
559;; for the functions.
560(define (emit-functions)
561  ;;; (eprint "emit-functions")
562  (generate-file
563   "wrap-functions"
564   (lambda ()
565     (hash-table-walk
566      *functions*
567      (lambda (name body)
568        ;;; (eprint "emit-function call in emit-functions")
569        (emit-function name
570                       (cadr (assq 'c-name body))
571                       (cond
572                        ((assq 'return-type body) => cadr)
573                        (else "none"))
574                       (cond
575                        ((assq 'parameters body) => cdr)
576                        (else '()))))))))
577
578;---------------------------------------------------------------------------;
579
580;;@function (process-include filename)
581;; Handle an include in the main input stream.
582(define (process-include filename)
583  (eprint ";; Including definitions from " filename)
584  (input-file filename))
585
586;;@function (process-definition defsym name body)
587;; Gobble up method and function definitions and store them in the hash tables
588(define (process-definition defsym name body)
589  (let* ((defstr (symbol->string defsym))
590         (kind (string->symbol (substring defstr 7 (string-length defstr)))))
591    (case kind
592      ((method)         (register-method! name body))
593      ((function)       (register-function! name body))
594      (else             #t)))) ;; Ignore it. Use reflection instead.
595
596;;@function (with-input-from-file-in-include-path filename thunk)
597;; Locate an include file and process it using the thunk
598(define (with-input-from-file-in-include-path filename thunk)
599  (let ((h (any (lambda (dir)
600                  (handle-exceptions exn #f
601                                     (let ((p (string-append dir "/" filename)))
602                                       (list (open-input-file p)
603                                             p))))
604                *include-path*)))
605    (if h
606        (let ((port (first h))
607              (path (second h)))
608          (eprint ";; Reading from file "path"...")
609          (handle-exceptions exn
610                             (begin
611                               (close-input-port port)
612                               (raise exn))
613                             (with-input-from-port
614                                 port
615                               thunk)))
616        (error "Could not open file" filename))))
617
618;;@function (input-file filename)
619;; Read and process a definition file
620(define (input-file filename)
621  (eprint "(input-file " filename ")")
622  (with-input-from-file-in-include-path filename
623    (lambda ()
624      (let loop ()
625        (let ((d (read)))
626          (unless (eof-object? d)
627            (cond
628             ((not (pair? d))
629              (print "; Skipping non-pair " d))
630             ((eq? (car d) 'include)
631              (process-include (cadr d)))
632             ((string-prefix? "define-" (symbol->string (car d)))
633              (process-definition (car d) (cadr d) (cddr d)))
634             (else
635              (print "; Skipping unhandled key " (car d))))
636            (loop)))))))
637
638(define (help)
639  (with-output-to-port (current-error-port)
640    (lambda ()
641      (display #<<EOF
642Usage: wrap -o <directory> [[-I <directory>] [-i <filename>] <filename>] ...
643
644  -h --help             Prints this message.
645  -I --include-path     Prepend a directory to the path searched
646                        for included files.
647  -i --include-file     Include a single file.
648  -H --header           Specify the header file to include in each
649                        generated file.
650  -m --manual           Specify a single file containing manually written code which
651                        will override generated definitions.  There may be more than
652                        one of these files.
653  -o --output-dir       Generate output in the named directory.
654                        The directory must exist.
655                        This argument must be supplied.
656  -v --version          Print version of wrap to stdout.
657
658EOF
659)
660      (newline))))
661
662(define (main argv)
663  (let ((filenames (args-fold argv
664                              (list (option '(#\h "help") #f #f
665                                            (lambda (o n a x)
666                                              (help)
667                                              (exit 0)))
668                                    (option '(#\I "include-path") #t #f
669                                            (lambda (o n a x)
670                                              (set! *include-path*
671                                                    (cons a *include-path*)) x))
672                                    (option '(#\i "include-file") #t #f
673                                            (lambda (o n a x)
674                                              (process-include a) x))
675                                    (option '(#\H "header") #t #f
676                                            (lambda (o n a x)
677                                              (set! *header-string*
678                                                    (string-join
679                                                     (with-input-from-file
680                                                         a
681                                                       read-lines)
682                                                     "\n")) x))
683                                    (option '(#\m "manual") #t #f
684                                            (lambda (o n a x)
685                                              (set! *manual-wrap*
686                                                   (append
687                                                     (with-input-from-file
688                                                        a read)
689                                                    *manual-wrap*)) x))
690                                    (option '(#\o "output-dir") #t #f
691                                            (lambda (o n a x)
692                                              (set! *output-dir* a) x))
693                                    (option '(#\v "version") #f #f
694                                            (lambda (o n a x)
695                                              (print "Version " *wrap-version*)
696                                              (exit 0))))
697                              (lambda (o n a x)
698                                (help)
699                                (error "Unrecognised option" n))
700                              cons
701                              '())))
702    (if (or (null? filenames)
703            (not *output-dir*))
704        (help)
705        (begin
706          (for-each input-file filenames)
707          (emit-objects)
708          (emit-interfaces)
709          (emit-classes-main)
710          (emit-boxeds)
711          (emit-enums)
712          (emit-flags)
713          (emit-functions)))))
714
715(main (command-line-arguments))
716(exit 0)
Note: See TracBrowser for help on using the repository browser.