source: project/release/4/easyffi/easyffi-base.scm @ 11080

Last change on this file since 11080 was 11080, checked in by felix winkelmann, 12 years ago

simplification of match pattern

File size: 50.1 KB
Line 
1;;;; easyffi-base.scm
2;
3; Copyright (c) 2008, The CHICKEN Team
4; Copyright (c) 2000-2007, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (uses srfi-13 srfi-1 utils regex)
30  ;(disable-warning var)
31  (no-procedure-checks-for-usual-bindings) )
32
33
34(module easyffi-base (parse-easy-ffi 
35                      register-ffi-macro
36                      ffi-include-path-list ffi-dont-include 
37                      foreign-type-declaration check-c-syntax
38                      no-c-syntax-checks)
39 
40  (import scheme chicken extras data-structures 
41          ports silex srfi-13 srfi-1 utils regex matchable)
42
43(include "easyffi.l.scm")
44
45(define mutable-fields #f)
46(define use-finalizers #f)
47(define exception-handler #f)
48(define destructor-name 'destroy)
49(define pp-mode #f)
50(define processed-output '())
51(define macro-table '((|CHICKEN| * ())))
52(define pp-conditional-stack '())
53(define pp-process #t)
54(define type-map '())
55(define ffi-include-path-list '("."))
56(define ffi-dont-include #f)
57(define export-constants #f)
58(define prefix #f)
59(define name-substitution-rxs '())
60(define name-substitution-repls '())
61(define declared-types '())
62(define rename-list '())
63(define abstract-classes '())
64(define full-specialization #f)
65(define defined-enums '())
66(define parsing-error error)
67(define imported-headers '())
68(define no-c-syntax-checks #f)
69
70(unless (or (memq #:compiling ##sys#features) (memq #:compiler-extension ##sys#features))
71  (set! ##compiler#foreign-type-table (make-vector 301 '())) )
72
73(define (lexer-error chr)
74  (parsing-error (sprintf "FFI lexer error: illegal character: `~c' (code ~s)" chr (char->integer chr))) )
75
76
77;;; Split lexed tokens into chunks
78
79(define (chunkify)
80  (let ((iparts 0))
81    (let rec ([scope 0])
82      (let ([chunks '()])
83        (let loop ([mode #f] [tokens '()])
84          (let ([t (lexer)])
85            (case t
86              [(stop)
87               (when (not (zero? iparts))
88                 (parsing-error "unbalanced `@interface'/`@implementation'") )
89               (case mode
90                 ((interface implementation)
91                  (parsing-error "missing `@end' declaration") ) )
92               (reverse (cons (reverse tokens) chunks)) ]
93              [(pp-end)
94               (when (pair? tokens)
95                 (set! chunks (cons (reverse tokens) chunks)) )
96               (loop #f '()) ]
97              [(pp-define pp-include pp-if pp-ifdef pp-ifndef pp-else pp-endif pp-undef pp-import
98                          pp-pragma pp-error)
99               (loop 'pp (list t)) ]
100              [(close-curly)
101               (cond [(not (positive? scope)) (parsing-error "`}' out of context")]
102                     [(null? tokens) (reverse chunks)]
103                     [else (cons (reverse tokens) chunks)] ) ]
104              [(open-curly)
105               (let ([new (rec (add1 scope))])
106                 (set! chunks (cons (append-reverse tokens `((scope . ,new))) chunks))
107                 (loop #f '()) ) ]
108              [(close-paren)
109               (if (eq? mode 'declare)
110                   (begin
111                     (set! chunks (cons (reverse (cons 'close-paren tokens)) chunks))
112                     (loop #f '()) )
113                   (loop mode (cons t tokens)) ) ]
114              [(declare)
115               (loop 'declare '(declare)) ]
116              [(interface implementation)
117               (when (not (zero? iparts))
118                 (parsing-error "`@interface'/`@implementation' without matching `@end'") )
119               (set! iparts (add1 iparts))
120               (loop t (list t)) ]
121              [(end)
122               (set! iparts (sub1 iparts))
123               (set! chunks (cons* '(end) (reverse tokens) chunks))
124               (loop #f '()) ]
125              [(semicolon)
126               (if mode
127                   (parsing-error "unexpected semicolon")
128                   (begin
129                     (set! chunks (cons (reverse tokens) chunks))
130                     (loop #f '()) ) ) ]
131              [else (loop mode (cons t tokens))] ) ) ) ) ) ) )
132
133
134;;; Parse each chunk separately
135
136(define (parse c)
137  (when (memq 'C ##compiler#debugging-chicken)
138    (pp `(CHUNK: ,c) (current-error-port)) )
139  (match c
140    [() #f]
141    [('pp-else)
142     (when (null? pp-conditional-stack)
143       (parsing-error "unbalanced preprocessor conditionals") )
144     (set! pp-process (and (not (car pp-conditional-stack)) (every identity (cdr pp-conditional-stack)))) ]
145    [('pp-endif)
146     (when (null? pp-conditional-stack)
147       (parsing-error "unbalanced preprocessor conditionals") )
148     (set! pp-conditional-stack (cdr pp-conditional-stack))
149     (set! pp-process (every identity pp-conditional-stack)) ]
150    [('pp-ifdef ('id name))
151     (set! pp-process (and pp-process (assq (string->symbol name) macro-table)))
152     (set! pp-conditional-stack (cons pp-process pp-conditional-stack)) ]
153    [('pp-ifndef ('id name))
154     (set! pp-process (and pp-process (not (assq (string->symbol name) macro-table))))
155     (set! pp-conditional-stack (cons pp-process pp-conditional-stack)) ]
156    [('pp-if . _)
157     (warning "preprocessor conditional `~A' ignored (assuming false)" c)
158     (set! pp-process #f)
159     (set! pp-conditional-stack (cons #f pp-conditional-stack)) ]
160    [_ (when pp-process
161         (match c
162           [('pp-define ('id name))
163            (let ([s (string->symbol name)])
164              (set! macro-table (cons (list s '* '()) macro-table)) ) ]
165           [('pp-define ('id name) . (or (('num n)) ('open-paren ('num n) 'close-paren)))
166            (let ([s (string->symbol name)])
167              (set! macro-table (cons (list s (if (exact? n) 'integer 'double) `((num ,n))) macro-table))
168              (process-constant-def s n) ) ]
169           [('pp-define ('id name) ('char c))
170            (let ([s (string->symbol name)])
171              (set! macro-table (cons (list s 'char `((char ,c))) macro-table))
172              (process-constant-def s c) ) ]
173           [('pp-define ('id name) . more)
174            (let ([t (compute-macro-type more)]
175                  [s (string->symbol name)] )
176              (set! macro-table (cons (list s t more) macro-table))
177              (process-macro-def s t) ) ]
178           [('pp-undef ('id name))
179            (set! macro-table (delete (assq (string->symbol name) macro-table) eq?)) ]
180           [('pp-error msgs ...)
181            (parsing-error (string-intersperse (cons "(#error) " (map reparse-item msgs)) "")) ]
182           [('pp-include ((or 'string 'i-string) filename))
183            (unless ffi-dont-include
184              (let ([fname (resolve-ffi-include-file filename)])
185                (if fname
186                    (begin
187                      (when (memq 'F ##compiler#debugging-chicken)
188                        (fprintf (current-error-port) "parsing ~a ...~%" fname) )
189                      (call-with-input-file fname parse-easy-ffi-rec) )
190                    (parsing-error "can not open include file" filename) ) ) ) ]
191           [('pp-import ((or 'string 'i-string) filename))
192            (unless ffi-dont-include
193              (let ([fname (resolve-ffi-include-file filename)])
194                (if (and fname (not member fname imported-headers))
195                    (call-with-input-file fname
196                      (lambda (f)
197                        (set! imported-headers (cons fname imported-headers))
198                        (parse-easy-ffi-rec f) ) )
199                    (parsing-error "can not open include file" filename) ) ) ) ]
200           [('pp-pragma . more) #f]
201           [('declare 'open-paren ('id decl) 'comma val 'close-paren)
202            (parse-declaration decl val) ]
203           [('declare . _)
204            (parsing-error "invalid syntax in pseudo declaration" c) ]
205           [_ (let ([cb #f] 
206                    [ab #f]
207                    [sp #f]
208                    [dc #f]
209                    [ds #f] )
210                (let loop ([c (subst-macros c)])
211                  (match c
212                    [((or 'extern 'static 'volatile 'inline) . more)
213                     (loop more) ]
214                    [('abstract . more)
215                     (set! ab #t)
216                     (loop more) ]
217                    [('specialize . more)
218                     (set! sp #t)
219                     (loop more) ]
220                    [('callback . more)
221                     (set! cb #t) 
222                     (loop more) ]
223                    [('discard . more)
224                     (set! ds #t)
225                     (loop more) ]
226                    [('const . more)
227                     (if (memq 'open-paren more)
228                         (parse-prototype c cb sp dc ds)
229                         (begin
230                           (set! dc #t)
231                           (loop more) ) ) ]
232                    [('enum ('scope more))
233                     (parse-enum-def #f (subst-macros more)) ]
234                    [('enum ('id name) ('scope more))
235                     (parse-enum-def name (subst-macros more)) ]
236                    [('class . more)
237                     (parse-class-def more ab) ]
238                    [((or 'union 'struct) ('id name) ('scope . more))
239                     (parse-struct-def (car c) name ab (subst-macros more)) ]
240                    [((or 'union 'struct) ('id name)) #f]
241                    [('namespace ('id name) (scope . more))
242                     (for-each parse more) ]
243                    [('typedef . more)
244                     (parse-typedef more) ]
245                    [(and more (('id name) . _))
246                     (parse-prototype more cb sp dc ds) ]
247                    [more
248                     (parse-prototype more cb sp dc ds)] ) ) ) ] ) ) ] ) )
249
250(define parse-again parse)
251
252(define parse-type-rec
253  (match-lambda
254    [('const . more) 
255     (let-values ([(t0 more) (parse-type-rec more)])
256       (values `(const ,t0) more) ) ]
257    [('unsigned t 'star . more)
258     (let-values ([(t0 more) (parse-type-rec (cons* 'unsigned t more))])
259       (values `(pointer ,t0) more) ) ]
260    [('signed t 'star . more)
261     (let-values ([(t0 more) (parse-type-rec (cons* 'signed t more))])
262       (values `(pointer ,t0) more) ) ]
263    [(t ('op "<") . more)
264     (let*-values ([(ts more) (parse-typelist more)]
265                   [(t0 _) (parse-type-rec (list t))] )
266       (values `(template ,t0 ,@ts) more) ) ]
267    [('signed . more) (parse-type-rec more)]
268    [`(unsigned fixnum . ,more) (values 'unsigned-int more)]
269    [`(unsigned int . ,more)
270     (values 'unsigned-integer more)]
271    [`(unsigned char . ,more) (values 'unsigned-char more)]
272    [`(unsigned short int . ,more) (values 'unsigned-short more)]
273    [`(unsigned long int . ,more) (values 'unsigned-long more)]
274    [`(unsigned short . ,more) (values 'unsigned-short more)]
275    [`(unsigned long . ,more) (values 'unsigned-long more)]
276    [`(u32 . ,more) (values 'unsigned-integer32 more)]
277    [`(s32 . ,more) (values 'integer32 more)]
278    [`(s64 . ,more) (values 'integer64 more)]
279    [`(void . ,more) (values 'void more)]
280    [`(bool . ,more) (values 'bool more)]
281    [`(symbol . ,more) (values 'symbol more)]
282    [`(unsigned byte . ,more) (values 'unsigned-byte more)]
283    [`(size_t . ,more) (values 'unsigned-integer more)]
284    [`(byte . ,more) (values 'byte more)]
285    [`(scheme-value . ,more) (values 'scheme-object more)]
286    [`(scheme-pointer . ,more) (values 'scheme-pointer more)]
287    [`(byte-vector . ,more) (values 'byte-vector more)]
288    [`(fixnum . ,more) (values 'int more)]
289    [`(pointer unsigned short int star . ,more) (values '(c-pointer unsigned-short) more)]
290    [`(pointer unsigned long int star . ,more) (values '(c-pointer unsigned-long) more)]
291    [`(pointer unsigned ,(and t (or 'char 'short 'long 'int 'byte)) star . ,more) 
292     (values `(c-pointer ,(string->symbol (string-append "unsigned-" (symbol->string t)))) more) ]
293    [`(pointer ,t star . ,more) (values `(c-pointer ,t) more)]
294    [`(int . ,more) (values 'integer more)]
295    [`(char . ,more) (values 'char more)]
296    [`(short int . ,more) (values 'short more)]
297    [`(long int . ,more) (values 'long more)]
298    [`(short . ,more) (values 'short more)]
299    [`(long . ,more) (values 'long more)]
300    [`(float . ,more) (values 'float more)]
301    [`(double . ,more) (values 'double more)]
302    [`(number . ,more) (values 'number more)]
303    [((and m (or 'union 'struct)) ('id sname) . more)
304     (values `(,m ,sname) more) ]
305    [('enum ('id sname) . more) (values `(enum ,sname) more)]
306    [(('id t) . more)
307     (let ([st (string->symbol t)])
308       (cond [(assq st type-map) => (lambda (a) (values (cdr a) more))]
309             [(memq st defined-enums) (values `(enum ,t) more)]
310             [(memq st declared-types) (values st more)]
311             [else (values t more)] ) ) ]
312    [x (parsing-error "invalid type specifier" x)] ) )
313
314(define (parse-type ts #!optional io return-type discard ftype-name)
315  (let-values ([(t0 more) (parse-type-rec ts)])
316    (let loop ([t0 t0] [more more])
317      (match more
318        [('star . more)
319         (loop `(pointer ,t0) more) ]
320        [(('op "&") . more)
321         (loop `(ref ,t0) more) ]
322        [('open-paren 'star 'close-paren 'open-paren . more)
323         (when ftype-name (vector-set! ftype-name 0 #f))
324         (let-values ([(ts _ _ more) (parse-arglist more)])
325           (values `(function ,t0 ,ts) more) ) ]
326        [('open-paren 'star ('id ftname) 'close-paren 'open-paren . more)
327         (when ftype-name (vector-set! ftype-name 0 ftname))
328         (let-values ([(ts _ _ more) (parse-arglist more)])
329           (values `(function ,t0 ,ts) more) ) ]
330        [(('id _) 'open-bracket . more2)
331         (let ([a (memq 'close-bracket more2)])
332           (if a
333               (loop `(pointer ,t0) (cons (car more) (cdr a)))
334               (values (simplify-type t0 io return-type discard) more) ) ) ]
335        [_ (values (simplify-type t0 io return-type discard) more)] ) ) ) )
336
337(define (simplify-type t0 io return-type discard)
338  (define (strtype) (if discard 'c-string* 'c-string))
339  (define (simplify-ptr t0 t)
340    (let ([st (string->symbol t)])
341      (if (memq st defined-classes) 
342          `(instance ,t ,(fix-cname t))
343          t0) ) )
344  (define (simplify-ref t0 t)
345    (let ([st (string->symbol t)])
346      (if (memq st defined-classes) 
347          `(instance-ref ,t ,(fix-cname t))
348          t0) ) )
349  (cond [io t0]
350        [return-type
351         (match t0
352           ['(pointer char) (strtype)]
353           ['(pointer (const char)) (strtype)]
354           [`(pointer (const ,(? string? t))) (simplify-ptr t0 t)]
355           [`(pointer ,(? string? t)) (simplify-ptr t0 t)]
356           [`(ref (const ,(? string? t))) (simplify-ref t0 t)]
357           [`(ref ,(? string? t)) (simplify-ref t0 t)]
358           [_ t0] ) ]
359        [else
360         (let loop ([t1 t0])
361           (match t1
362             [`(pointer (const ,t2)) (loop `(pointer ,t2))]
363             [`(ref (const ,t2)) (loop `(ref ,t2))]
364             ['(pointer unsigned-fixnum) 'u32vector]
365             [(or '(pointer unsigned-integer)
366                  '(pointer unsigned-int)
367                  '(pointer unsigned-int32)
368                  '(pointer unsigned-integer32)) 
369              'u32vector]
370             ['(pointer unsigned-short) 'u16vector]
371             ['(pointer unsigned-char) 'u8vector]
372             ['(pointer unsigned-byte) 'u8vector]
373             ['(pointer byte) 's8vector]
374             ['(pointer unsigned-long) 'u32vector]
375             ['(pointer fixnum) 's32vector]
376             [(or '(pointer integer)
377                  '(pointer integer32)
378                  '(pointer int32)
379                  '(pointer int) )
380              's32vector]
381             ['(pointer short) 's16vector]
382             ['(pointer char) (strtype)]
383             ['(pointer long) 's32vector]
384             ['(pointer float) 'f32vector]
385             [`(pointer ,(or 'double 'number)) 'f64vector]
386             [`(pointer ,(? string? t)) (simplify-ptr t1 t)]
387             [`(ref ,(? string? t)) (simplify-ref t1 t)]
388             [_ t1] ) ) ] ) )
389
390(define (parse-arglist ts)
391  (let ([vars '()])
392    (define (index! v i lens)
393      (set! vars (append vars (list v)))
394      (and-let* ([a (rassoc v lens equal?)])
395        (set-cdr! a i) ) )
396    (define (check-lvars lvars)
397      (for-each
398       (lambda (lv) 
399         (let ([name (cdr lv)])
400           (when (string? name)
401             (cond [(list-index (cut equal? name <>) vars) =>
402                    (lambda (i) (set-cdr! lv i)) ]
403                   [else
404                    (parsing-error (sprintf "no argument named `~a' given for length indicator" name)) ] ) ) ) )
405       lvars) )
406    (let rec ([more ts] [args '()] [inout '()] [i 0] [lens '()])
407      (match more
408        [('close-paren . more)
409         (check-lvars lens)
410         (values (reverse args) (reverse inout) lens more) ]
411        [('dots . _)
412         (parsing-error "varargs are not supported") ]
413        [_ (let ([io #f])
414             (match more
415               [((and iov (or 'in 'out 'inout)) . more2)
416                (set! more more2)
417                (set! io iov) ]
418               [('length 'open-paren ('id lvar) 'close-paren . more2)
419                (set! more more2)
420                (set! lens (alist-cons i lvar lens)) ]
421               [_ #f])
422             (let-values ([(type more) (parse-type more io #f)])
423               (match more
424                 [(('id str) 'comma . more)
425                  (index! str i lens)
426                  (rec more (cons type args) (cons io inout) (add1 i) lens) ]
427                 [(('id str) 'close-paren . more)
428                  (index! str i lens)
429                  (check-lvars lens)
430                  (values (reverse (cons type args)) (reverse (cons io inout)) lens more) ]
431                 [('comma . more) 
432                  (rec more (cons type args) (cons io inout) (add1 i) lens) ]
433                 [('close-paren . more)
434                  (check-lvars lens)
435                  (values (reverse (cons type args)) (reverse (cons io inout)) lens more) ]
436                 [_ (parsing-error "bad argument list syntax" more)] ) ) ) ] ) ) ) )
437
438(define (parse-typelist ts)
439  (let rec ([more ts] [ts '()])
440    (match more
441      [(('op ">") . more)
442       (values (reverse ts) more) ]
443      [_ (let-values ([(type more) (parse-type more #f #f)])
444           (match more
445             [('comma . more)
446              (rec more (cons type ts)) ]
447             [(('op ">") . more)
448              (values (reverse (cons type ts)) more) ]
449             [_ (parsing-error "bad template type list syntax" more)] ) ) ] ) ) )
450
451(define (subst-macros chunk)
452  (let loop ([c chunk])
453    (match c
454      [() '()]
455      [((and x ('id name)) . more)
456        (let ([a (assq (string->symbol name) macro-table)])
457          (if a
458              (loop (append (third a) more))
459              (cons x (loop more)) ) ) ]
460      [(x . y) (cons x (loop y))] ) ) )
461
462(define (parse-prototype ts cb sp const discard)
463  (fluid-let ([full-specialization (or sp full-specialization)])
464    (let-values ([(rtype more) (parse-type ts #f #t discard)])
465      (let loop ([more more])
466        (match more
467          [() #f]
468          [(('id str) ('op "::") . more) #f]
469          [(('id str) 'open-paren 'void 'close-paren . more)
470           (process-prototype-def rtype (string->symbol str) '() '() '() cb)
471           (match more
472             [(('scope . _) . more) (parse-again more)]
473             [() #f]
474             [_ (parsing-error "unexpected tokens" more)] ) ]
475          [(('id str) 'open-paren . more)
476           (let-values ([(args io lvars more) (parse-arglist more)])
477             (process-prototype-def rtype (string->symbol str) args io lvars cb)
478             (match more
479               [(('scope . _) . more) (parse-again more)]
480               [() #f]
481               [_ (parsing-error "unexpected tokens" more)] ) ) ]
482          [(('id str) 'comma . more)
483           (process-variable-def rtype (string->symbol str) const)
484           (loop more) ]
485          [(('id str))
486           (process-variable-def rtype (string->symbol str) const) ]
487          [(('id str) . (or (('op "=") . _) ()))
488           (process-variable-def rtype (string->symbol str) const) ]
489          [else (parsing-error "bad prototype syntax" more)] ) ) ) ) )
490
491(define (parse-enum-def ename ts)
492  (when ename (set! defined-enums (cons (string->symbol ename) defined-enums)))
493  (let loop ([ts ts] [i 0] [items '()])
494    (match ts
495      [('close-curly) #f]
496      [_ (let-values ([(sym val more) (parse-enum-item ts i items)])
497           (let ([items (alist-cons sym val items)]
498                 [i (add1 val)] )
499             (match more
500               [() (process-enum-def ename items)]
501               [('comma . more) (loop more i items)]
502               [_ (parsing-error "syntax error in enum form" more)] ) ) ) ] ) ) )
503
504(define (parse-enum-item ts i items)
505  (match ts
506    [(('id name) ('op "=") ('id name2) . more)
507     (cond ((assq (string->symbol name2) items)
508            => (lambda (a) (values (string->symbol name) (cdr a) more)))
509           (else (parsing-error "undefined enum value" name2)) ) ]
510    [(('id name) ('op "=") ('num n) . more)
511     (if (integer? n)
512         (values (string->symbol name) n more) 
513         (parsing-error "inexact enum value" n name) ) ]
514    [(('id name) . more)
515     (values (string->symbol name) i more) ] 
516    [_ (parsing-error "invalid enum syntax" ts)] ) )
517
518(define (parse-struct-def m sname ab ts)
519  (let ([fields '()])
520    (let loop ([ts ts])
521      (unless (null? ts)
522        (let*-values ([(mut? more) 
523                       (match (car ts)
524                         [('mutable . more) (values #t more)]
525                         [x (values #f x)] ) ]
526                      [(type more) (parse-type more #f #t)] )
527          (let loop2 ([type type] [more more])
528            (match more
529              [('star . more)
530               (loop2 (simplify-type `(pointer ,type) #f #t #f) more) ]
531              [(('id name) . more)
532               (set! fields (cons (list type (string->symbol name)) fields))
533               (process-struct-member-def m sname name type (or mut? mutable-fields))
534               (match more
535                 [('comma . more) (loop2 type more)]
536                 [() (loop (cdr ts))]
537                 [_ (parsing-error (sprintf "syntax error in struct/union member (~A): `~A'" sname more))] ) ]
538              [() (loop (cdr ts))]
539              [_ (parsing-error (sprintf "syntax error in struct/union form (~A): `~A'" 
540                                         sname more))] ) ) ) ) )
541    (unless ab 
542      (let ([maker (fix-name (string-append "make-" (->string sname)))]
543            [fields (reverse fields)] )
544        (emit
545         `(define ,maker
546            (foreign-lambda* (pointer (,m ,sname)) ,fields
547              ,(sprintf "~A ~A *tmp_ = (~A ~A *)C_malloc(sizeof(~A ~A));~%~Areturn(tmp_);"
548                        m sname m sname m sname
549                        (string-intersperse
550                         (map (lambda (f) (sprintf "tmp_->~A = ~A;~%" (cadr f) (cadr f)))
551                              fields)
552                         "") ) ) ) ) ) ) ) )
553
554(define (parse-typedef ts)
555  (let ([box (vector #f)])
556    (let-values ([(type more) (parse-type ts #f #t #f box)])
557      (let loop ([more 
558                  (let ([name (vector-ref box 0)])
559                    (if name
560                        `((id ,name))
561                        more) ) ]
562                 [type type] )
563        (match more
564          [('star . more)
565           (loop more `(pointer ,type)) ]
566          [(('id tname))
567           (set! type-map (alist-cons (string->symbol tname) 
568                                      (simplify-type type #f #t #f)
569                                      type-map)) ]
570          [_ (parsing-error "invalid typedef syntax" more)] ) ) ) ) )
571
572(define has-constructor #f)
573(define defined-classes '())
574
575(define (parse-class-def ts ab)
576  (match ts
577    [(('id name)) 
578     (set! defined-classes (cons (string->symbol name) defined-classes)) ]
579    [(('id name) . more)
580     (let ([sym (string->symbol name)])
581       (set! defined-classes (cons sym defined-classes))
582       (when ab (set! abstract-classes (cons sym abstract-classes))) )
583     (let loop ([more more] [t '(op ":")] [bases '()])
584       (if (and (pair? more) (equal? t (car more)))
585           (match more
586             [(_ (or 'public 'protected 'private) ('id bname) . more)
587              (loop more 'comma 
588                    (if (memq (string->symbol bname) defined-classes)
589                        (cons bname bases)
590                        bases) ) ]
591             [(_ ('id bname) . more)
592              (loop more 'comma
593                    (if (memq (string->symbol bname) defined-classes)
594                        (cons bname bases)
595                        bases) ) ]
596             [_ (parsing-error (sprintf "invalid class definition for `~A': ~S" name more))] ) 
597           (match more
598             [(('scope . chunks))
599              (let ([cname (fix-cname name)]
600                    [csname (string->symbol name)] )
601                (process-class-def name cname bases)
602                (fluid-let ([has-constructor #f])
603                  (let ([exp #f])
604                    (for-each
605                     (lambda (chunk)
606                       (let loop ([more (subst-macros chunk)])
607                         (match more
608                           [() #f]
609                           [('public ('op ":") . more) 
610                            (set! exp #t)
611                            (loop more) ]
612                           [((or 'private 'protected) ('op ":") . more) 
613                            (set! exp #f)
614                            (loop more) ]
615                           [more 
616                            (when exp 
617                              (fluid-let ([parse-again loop])
618                                (parse-member-prototype name cname more #f #f) ) ) ] ) ) )
619                     chunks)
620                    (when (and (not has-constructor) (not (memq csname abstract-classes)))
621                      (process-constructor-def name cname '() '() '()) ) ) ) ) ]
622             [_ (parsing-error (sprintf "invalid class definition for `~A': ~S" name more))] ) ) ) ]
623    [_ (parsing-error "invalid class definition" ts)] ) )
624
625(define (parse-member-prototype name cname ts cb discard)
626  (match ts
627    [('specialize . more)
628     (fluid-let ([full-specialization #t])
629       (parse-member-prototype name cname more #t discard) ) ]
630    [('callback . more) 
631     (parse-member-prototype name cname more #t discard) ]
632    [('discard . more)
633     (parse-member-prototype name cname more cb #t) ]
634    [((or 'explicit 'virtual) . more)
635     (parse-member-prototype name cname more cb discard) ]
636    [(('id name2) 'open-paren 'void 'close-paren . more)
637     (if (string=? name2 name)
638         (begin
639           (process-constructor-def name cname '() '() '())
640           (set! has-constructor #t)
641           (match more
642             [(('scope . _) . more) (parse-again more)]
643             [() #f]
644             [(('op ":") . more) (skip-base-constructors more)]
645             [_ (parsing-error "unexpected tokens" more)] ) )
646         (parsing-error (sprintf "invalid constructor for `~A': ~S" name ts) )) ]
647    [(('id name2) 'open-paren . more)
648     (if (string=? name2 name)
649         (let-values ([(args io lvars more) (parse-arglist more)])
650           (process-constructor-def name cname args io lvars) 
651           (set! has-constructor #t)
652           (match more
653             [(('scope . _) . more) (parse-again more)]
654             [() #f]
655             [(('op ":") . more) (skip-base-constructors more)]
656             [_ (parsing-error "unexpected tokens" more)] ) )
657         (parsing-error (sprintf "invalid constructor for `~A': ~S" name ts) ) )]
658    [(('op "~") ('id name2) 'open-paren . (or ('void 'close-paren . more) ('close-paren . more)))
659     (if (string=? name2 name)
660         (match more
661           [(('scope . _) . more) (parse-again more)]
662           [() #f]
663           [_ (parsing-error "unexpected tokens" more)] )
664         (parsing-error (sprintf "invalid destructor for `~A': ~S" name ts) )) ]
665    [('static . more)
666     (let-values ([(rtype more) (parse-type more #f #t)])
667       (match more
668         [(('id str) 'open-paren 'void 'close-paren . more)
669            (process-prototype-def
670             rtype
671             (string->symbol (string-append name "::" str)) '() '() '() cb #f)
672            (match more
673              [(('scope . _) . more) (parse-again more)]
674              [() #f]
675              [_ (parsing-error "unexpected tokens" more)] ) ]
676         [(('id str) 'open-paren . more)
677          (let-values ([(args io lvars more) (parse-arglist more)])
678            (process-prototype-def 
679             rtype (string->symbol (string-append name "::" str)) 
680             args io lvars cb #f)
681            (match more
682              [(('scope . _) . more) (parse-again more)]
683              [() #f]
684              [_ (parsing-error "unexpected tokens" more)] ) ) ]
685         [_ (parsing-error "bad static member prototype syntax" more)] ) ) ]
686    [_ (let-values ([(rtype more) (parse-type ts #f #t discard)])
687         (match more
688           [(('id str) 'open-paren 'void 'close-paren . more)
689            (process-member-prototype-def name cname rtype (string->symbol str) '() '() '() cb)
690            (parse-member-body more) ]
691           [(('id str) 'open-paren . more)
692            (let-values ([(args io lvars more) (parse-arglist more)])
693              (process-member-prototype-def name cname rtype (string->symbol str) args io lvars cb)
694              (parse-member-body more) ) ]
695           [(('id str) . (or (('op "=") . _) ()))
696            #f]                         ; member variables are ignored
697           [_ (parsing-error "bad member prototype syntax" more)] ) ) ] ) )
698
699(define (skip-base-constructors ts)
700  (let loop ((ts ts))
701    (match ts
702      (() #f)
703      ((('scope . _) . more) (parse-again more))
704      ((_ . ts) (loop ts)))))
705
706(define (parse-member-body ts)
707  (let loop ([more ts])
708    (match more
709      [('const . more) (loop more)]
710      [(('op "=") (num 0) . more) 
711       (set! has-constructor #t)
712       (loop more) ]
713      [(('scope . _) . more) (parse-again more)]
714      [() #f]
715      [_ (parsing-error "unexpected tokens" more)] ) ) )
716
717(define reparse-item 
718  (match-lambda 
719   ['pp-define "#define"]
720   ['pp-include "#include"]
721   ['pp-undef "#undef"]
722   ['pp-ifndef "#ifndef"]
723   ['pp-ifdef "#ifdef"]
724   ['pp-if "#if"]
725   ['pp-pragma "#pragma"]
726   ['pp-error "#error"]
727   ['pp-else "#else"]
728   ['pp-endif "#endif"]
729   [('id str) str]
730   [('num num) num]
731   [('op op) op]
732   ['star "*"]
733   ['open-paren "("]
734   ['close-paren ")"]
735   ['open-bracket "["]
736   ['close-bracket "]"]
737   ['open-curly "{"]
738   ['close-curly "}"]
739   ['fixnum "int"]
740   ['comma ","]
741   [('string str) (string-append "\"" str "\"")]
742   [('i-string str) (string-append "<" str ">")]
743   ['class "class"]
744   ['protected "protected"]
745   ['public "public"]
746   ['private "private"]
747   [c c] ) )
748
749(define (type-union t1 t2)
750  (cond [(eq? '_ t2) t1]
751        [(eq? t1 t2) t1]
752        [(eq? 'integer t1)
753         (case t2
754           [(double) 'double]
755           [else '*] ) ]
756        [(and (eq? t1 'double) (eq? 'integer t2)) 'double]
757        [else '*] ) )
758
759(define (compute-macro-type ts)
760  (let rec ([ts ts])
761    (if (null? ts)
762        '_
763        (match (car ts)
764          [('num n) (type-union (if (exact? n) 'integer 'double) (rec (cdr ts)))]
765          [('char n) (type-union 'char (rec (cdr ts)))]
766          [('id str)
767           (let ([a (assq (string->symbol str) macro-table)])
768             (if a 
769                 (type-union (second a) (rec (cdr ts)))
770                 '*) ) ]
771          [_ (rec (cdr ts))] ) ) ) )
772
773(define (emit x)
774  (let ((dbg (memq 'F ##compiler#debugging-chicken)))
775    (when dbg (pp x (current-error-port)))
776    (set! processed-output (cons x processed-output) ) ) )
777
778(define (process-macro-def name type)
779  (if (memq type '(* _))
780      (warning (sprintf "can not compute macro type `~A' (ignored)" name))
781      (let* ([name2 (fix-name name)]
782             [sname (->string name)] )
783        (emit `(define-foreign-variable ,name2 ,type ,sname))
784        (when export-constants
785          (emit `(define ,name2 ,name2))))))
786
787(define (process-constant-def name val)
788  (let ([name (fix-name name)])
789    (emit `(define-constant ,name ,val))
790    (when export-constants 
791      (emit `(define ,name ,name)))))
792
793(define (process-prototype-def rtype name args io lvars cb #!optional (use-prefix #t))
794  (let* ([name2 (fix-name name use-prefix)]
795         [slist (gen-spec-list args io)] 
796         [vars (unzip1 slist)] )
797    (emit
798     (if (and full-specialization (pair? args))
799         (let ([tmp (gensym)])
800           `(begin
801              (declare (hide ,tmp))
802              (define ,tmp
803                (,(if cb 'foreign-safe-lambda 'foreign-lambda)
804                 ,rtype ,(->string name) ,@args) )
805              (define-method (,name2 ,@(filter-map (lambda (spec io i)
806                                                     (and (memq io '(#f in inout))
807                                                          (not (assq i lvars))
808                                                          spec) )
809                                                   slist io (iota (length slist)) ))
810                ,(make-inout-wrapper tmp rtype vars args io lvars) ) ) )
811         (let* ([io? (or (any identity io) (pair? lvars))]
812                [fname (if io? (gensym) name2)] )
813           `(begin
814              ,@(if io? `((declare (hide ,fname))) '())
815              (define ,fname
816                (,(if cb 'foreign-safe-lambda 'foreign-lambda)
817                 ,rtype ,(->string name) ,@args))
818              ,@(if io?
819                    (let ([inlist (filter-map (lambda (var io i)
820                                                (and (memq io '(#f in inout)) 
821                                                     (not (assq i lvars))
822                                                     var) )
823                                              vars io (iota (length vars))) ] )
824                      `((define (,name2 ,@inlist) 
825                          ,(make-inout-wrapper fname rtype vars args io lvars) ) ) )
826                    '() ) ) ) ) ) ) )
827
828(define (make-inout-wrapper rname rtype vars args io lvars)
829  (let ([tmp (gensym)] 
830        [results (map (lambda _ (gensym)) vars)] )
831    (if (or (any identity io) (pair? lvars))
832        `(let-location ,(filter-map
833                         (lambda (rvar var io arg)
834                           (let ([pt (match arg
835                                       [('pointer t) t]
836                                       [('ref t) t]
837                                       [_ (if io
838                                              (begin
839                                                (warning 
840                                                 (sprintf "~A parameter used with non-pointer type"
841                                                          io arg) )
842                                                arg)
843                                              arg) ] ) ] )
844                             (case io
845                               [(in inout) (list rvar pt var)]
846                               [(out) (list rvar pt)] 
847                               [else #f] ) ) )
848                         results vars io args)
849           (let ([,tmp (,rname ,@(map
850                                  (lambda (rvar var io i)
851                                    (cond [io `(location ,rvar)]
852                                          [(assq i lvars) =>
853                                           (lambda (a)
854                                             (let ([i2 (cdr a)])
855                                               `(,(length-procedure (list-ref args i2))
856                                                 ,(list-ref vars i2)) ) ) ]
857                                          [else var] ) )
858                                  results vars io (iota (length vars))) ) ] )
859             ,(if (any identity io)
860                  `(values
861                    ,@(if (eq? rtype 'void)
862                          '()
863                          (list tmp) ) 
864                    ,@(filter-map (lambda (rvar io) (and (memq io '(out inout)) rvar))
865                                  results io) )
866                  tmp) ) )
867        `(,rname ,@vars) ) ) )
868
869(define (length-procedure t)
870  (case t
871    [(u8vector) 'u8vector-length]
872    [(s8vector) 's8vector-length]
873    [(u16vector) 'u16vector-length]
874    [(s16vector) 's16vector-length]
875    [(u32vector) 'u32vector-length]
876    [(s32vector) 's32vector-length]
877    [(f32vector) 'f32vector-length]
878    [(f64vector) 'f64vector-length]
879    [(byte-vector) 'byte-vector-length]
880    [(c-string c-string*) 'string-length]
881    [else (parsing-error "do not know how to compute length of foreign type argument" t)] ) )
882
883(define (process-variable-def rtype name const)
884  (let ([tmp (gensym)]
885        [var (gensym)] 
886        [name2 (fix-name name)] 
887        [sname (->string name)] )
888    (emit `(define-foreign-variable ,tmp ,rtype ,sname))
889    (if const
890        (emit `(define ,name2 ,tmp))
891        (emit `(define (,name2 . ,var)
892                 (if (pair? ,var)
893                     (set! ,tmp (car ,var))
894                     ,tmp) )))))
895
896(define (process-enum-def ename items)
897  (for-each
898   (match-lambda
899     [(name . val)
900      (let ([name (fix-name name)])
901        (emit `(define-constant ,name ,val))
902        (when export-constants 
903          (emit `(define ,name ,name)))) ] )
904   (reverse items) ) )
905
906(define (process-struct-member-def m sname name type mut?)
907  (let ([getter (fix-name (string-append (->string sname) "-" (->string name)))])
908    (let ((g `(foreign-lambda* ,type (((pointer (,m ,sname)) s))
909               ,(sprintf "return(s->~A);" name) ) )
910          (s `(foreign-lambda* void (((pointer (,m ,sname)) s)
911                                     (,type x) )
912                ,(sprintf "s->~A = x;" name) ) ) )
913      (emit
914       (if mut?
915           `(define ,getter (getter-with-setter ,g ,s))
916           `(define ,getter ,g) ) ) ) ) )
917
918(define (process-class-def name cname basenames)
919  (let ([destr (gensym)]
920        [csname (string->symbol name)] 
921        [bases (if (null? basenames)
922                   '(<c++-object>)
923                   (map (lambda (b) (fix-cname b)) (reverse basenames) ) ) ] )
924    (emit
925     `(begin
926        (declare (hide ,destr))
927        (define-class ,cname ,bases () ) ) )
928    (unless (memq csname abstract-classes)
929      (emit
930       `(begin
931          (define ,destr (foreign-lambda void "delete " (pointer ,name)))
932          (define-method (,destructor-name (this ,cname))
933            (,destr (slot-ref this 'this)) ) )))))
934
935(define (process-constructor-def name cname args io lvars)
936  (let ([constr (gensym)]
937        [finalize (and use-finalizers (not (memq (string->symbol name) abstract-classes)))] )
938    (emit
939     `(begin
940        (declare (hide ,constr))
941        (define ,constr (foreign-lambda (pointer ,name) ,(string-append "new " name) ,@args))
942        (define-method (initialize (this ,cname) initargs) 
943          ;; no CALL-NEXT-METHOD here: we don't want to invoke the base-class constructor.
944          ,@(if finalize
945                `((set-finalizer! this ,destructor-name))
946                '() )
947          (slot-set! 
948           this 'this
949           (if (and (pair? initargs) (eq? 'this (##sys#slot initargs 0)))
950               (cadr initargs)
951               (##sys#apply
952                ,(if (or (any identity io) (pair? lvars))
953                     (let ([vars (map (lambda _ (gensym)) args)])
954                       `(lambda ,(filter-map (lambda (var io i)
955                                               ;;*** ___inout and ___out doesn't make sense here!
956                                               (and (memq io '(#f in inout)) 
957                                                    (not (assq i lvars))
958                                                    var))
959                                             vars io (iota (length vars)))
960                          ,(make-inout-wrapper constr `(pointer ,name) vars args io lvars) ) )
961                     constr) 
962                initargs) ) ) ) ))))
963
964(define (process-member-prototype-def name cname rtype mname args io lvars cb)
965  (define (uplvars lvars)
966    (map (lambda (x) (cons (add1 (car x)) (add1 (cdr x)))) lvars) )
967  (let* ([stub (gensym)]
968         [this (gensym)] 
969         [slist (gen-spec-list args io)]
970         [vars (unzip1 slist)]
971         [fvars (map list args vars)] 
972         [io? (or (any identity io) (pair? lvars))] )
973    (emit
974     `(begin
975        (declare (hide ,stub))
976        (define ,stub 
977          (,(if cb 'foreign-safe-lambda* 'foreign-lambda*)
978           ,rtype (((pointer ,name) ,this) ,@fvars)
979           ,(sprintf (let ([code (if (eq? 'void rtype) 
980                                     "~A->~A(~A);"
981                                     "return(~A->~A(~A));") ] )
982                       (if exception-handler
983                           (sprintf "try { ~A } ~A;" code exception-handler)
984                           code) )
985                     this mname
986                     (string-intersperse (map ->string vars) ",")) ) )
987        ,(if (and full-specialization (pair? args))
988             `(define-method (,(fix-name mname) (this ,cname)
989                              ,@(filter-map (lambda (var io i)
990                                              (and (memq io '(#f in inout)) 
991                                                   (not (assq i lvars))
992                                                   var))
993                                            vars io (iota (length vars))) )
994                ,(make-inout-wrapper 
995                  stub rtype
996                  (cons '(slot-ref this 'this) vars)
997                  (cons #f args)        ; #f is ok, it will be ignored
998                  (cons #f io)
999                  (uplvars lvars)) )
1000             `(define-method (,(fix-name mname) (this ,cname) . args)
1001                (##sys#apply 
1002                 ,(if io?
1003                      `(lambda ,(filter-map (lambda (var io i) 
1004                                              (and (memq io '(#f in inout)) 
1005                                                   (not (assq i lvars))
1006                                                   var))
1007                                            vars io (iota (length lvars)))
1008                         ,(make-inout-wrapper
1009                           stub rtype 
1010                           (cons '(slot-ref this 'this) vars)
1011                           (cons #f args) 
1012                           (cons #f io)
1013                           (uplvars lvars)) )
1014                      stub)
1015                 ,@(if io? '() '((slot-ref this 'this)))
1016                 args) ) ) ) ) ) )
1017
1018(define parse-declaration
1019  (match-lambda*
1020    [("export_constants" ('id "yes"))
1021     (set! export-constants #t) ]
1022    [("export_constants" _)
1023     (set! export-constants #f) ]
1024    [("abstract" ('id cls))
1025     (set! abstract-classes (cons (string->symbol cls) abstract-classes)) ]
1026    [("class_finalizers" ('id "yes"))
1027     (set! use-finalizers #t) ]
1028    [("class_finalizers" _)
1029     (set! use-finalizers #f) ]
1030    [("destructor_name")
1031     (set! destructor-name 'destroy) ]
1032    [("destructor_name" ('string name))
1033     (set! destructor-name (string->symbol name)) ]
1034    [("exception_handler" ('string code))
1035     (set! exception-handler code) ]
1036    [("mutable_fields" ('id "yes"))
1037     (set! mutable-fields #t) ]
1038    [("mutable_fields" _)
1039     (set! mutable-fields #f) ]
1040    [("default_renaming" ('string str))
1041     (set! prefix str)
1042     (set! name-substitution-rxs (append name-substitution-rxs (list ".*[_A-Z].*")))
1043     (set! name-substitution-repls (append name-substitution-repls (list usual-naming-transform))) ]
1044    [("prefix" ('string str))
1045     (set! prefix str) ]
1046    [("prefix" (or ('id "no") 0))
1047     (set! prefix #f) ]
1048    [("scheme" ('string str))
1049     (let ([exp (with-input-from-string str read)])
1050       (emit exp) ) ]
1051    [("type" ('string str))
1052     (parse-type-declaration (string-split str ";")) ]
1053    [("opaque" ('string str))
1054     (parse-type-declaration
1055      (match (string-split str ";")
1056        [(name type)
1057         (list name type
1058               "(lambda (x) (##sys#block-ref x 1))"
1059               (sprintf "(lambda (x) (##sys#make-structure '~a x))" name) ) ]
1060        [_ (parsing-error "invalid `opaque' declaration" str)] ) ) ]
1061    [("rename" ('string str))
1062     (match (string-split str ";")
1063       [(from to) 
1064        (set! rename-list (alist-cons (string->symbol from) (string->symbol to) rename-list)) ]
1065       [_ (parsing-error "invalid rename declaration" str)] ) ]
1066    [("substitute" ('string str))
1067     (match (string-split str ";")
1068       [(from to) 
1069        (set! name-substitution-rxs (append name-substitution-rxs (list from)))
1070        (set! name-substitution-repls (append name-substitution-repls (list to))) ]
1071       [_ (parsing-error "invalid name substitution string" str)] ) ]
1072    [("transform" ('string str))
1073     (match (string-split str ";")
1074       [(from to)
1075        (let ([tr (handle-exceptions ex (parsing-error "error in transformation expression" to)
1076                    (eval (safe-read-from-string to)) ) ] )
1077          (unless (procedure? tr)
1078            (parsing-error "transformation expression does not evaluate to procedure" to) )
1079          (set! name-substitution-rxs (append name-substitution-rxs (list from)))
1080          (set! name-substitution-repls (append name-substitution-repls (list tr))) ) ]
1081       [_ (parsing-error "invalid transformation" str)] ) ]
1082    [("full_specialization" ('id "yes"))
1083     (set! full-specialization #t) ]
1084    [("full_specialization" _)
1085     (set! full-specialization #f) ]
1086    [(decl _)
1087     (parsing-error "invalid pseudo declaration" decl) ] ) )
1088
1089(define usual-naming-transform
1090  (let ()
1091    (define (downcase-string str)               ; so we don't have to use srfi-13
1092      (let ([s2 (string-copy str)]
1093            [n (string-length str)] )
1094        (do ([i 0 (fx+ i 1)])
1095            ((fx>= i n) s2)
1096          (string-set! s2 i (char-downcase (string-ref str i))) ) ) )
1097    (lambda (m)
1098      (downcase-string
1099       (string-translate 
1100        (string-substitute "([a-z])([A-Z])" "\\1-\\2" (car m) #t)
1101        "_" "-") ) ) ) )
1102
1103(define (safe-read-from-string str)
1104  (handle-exceptions ex (parsing-error "can not parse expression" str)
1105    (with-input-from-string str read) ) )
1106
1107(define (parse-type-declaration vals)
1108  (let rec ([vals vals])
1109    (match vals
1110      [(tname stype arg ret)
1111       (let ([stype (safe-read-from-string stype)]
1112             [arg (and arg (safe-read-from-string arg))]
1113             [ret (and ret (safe-read-from-string ret))] 
1114             [stname (string->symbol tname)] )
1115         (emit `(foreign-declare ,(sprintf "#define ~A ~A~%" tname (foreign-type-declaration stype ""))))
1116         (emit `(define-foreign-type ,stname ,stype ,@(if arg (list arg) '()) ,@(if ret (list ret) '())))
1117         (##sys#hash-table-set! ##compiler#foreign-type-table stname stype) ; will be overwritten later
1118         (set! declared-types (cons stname declared-types)) ) ]
1119      [(tname stype arg) (rec (list tname stype arg #f))]
1120      [(tname stype) (rec (list tname stype #f #f))]
1121      [_ (parsing-error "invalid value-syntax in type declaration: ~S" vals)] ) ) )
1122
1123(define (foreign-type-declaration type target)
1124  (let ([err (lambda () (error "illegal foreign type" type))]
1125        [str (lambda (ts) (string-append ts " " target))] )
1126    (case type
1127      [(scheme-object) (str "C_word")]
1128      [(char byte) (str "char")]
1129      [(unsigned-char unsigned-byte) (str "unsigned char")]
1130      [(unsigned-int unsigned-integer) (str "unsigned int")]
1131      [(unsigned-int32 unsigned-integer32) (str "C_u32")]
1132      [(int integer bool) (str "int")]
1133      [(int32 integer32) (str "C_s32")]
1134      [(integer64) (str "C_s64")]
1135      [(short) (str "short")]
1136      [(long) (str "long")]
1137      [(unsigned-short) (str "unsigned short")]
1138      [(unsigned-long) (str "unsigned long")]
1139      [(float) (str "float")]
1140      [(double number) (str "double")]
1141      ;; pointer and nonnull-pointer are DEPRECATED
1142      [(pointer nonnull-pointer c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer)
1143       (str "void *")]
1144      [(byte-vector nonnull-byte-vector u8vector nonnull-u8vector) (str "unsigned char *")]
1145      [(u16vector nonnull-u16vector) (str "unsigned short *")]
1146      [(s8vector nonnull-s8vector) (str "char *")]
1147      [(u32vector nonnull-u32vector) (str "unsigned int *")]
1148      [(s16vector nonnull-s16vector) (str "short *")]
1149      [(s32vector nonnull-s32vector) (str "int *")]
1150      [(f32vector nonnull-f32vector) (str "float *")]
1151      [(f64vector nonnull-f64vector) (str "double *")]
1152      [(nonnull-c-string c-string nonnull-c-string* c-string* symbol) (str "char *")]
1153      [(void) (str "void")]
1154      [else
1155       (cond [(and (symbol? type) (##sys#hash-table-ref ##compiler#foreign-type-table type))
1156              => (lambda (t)
1157                   (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
1158             [(string? type) (str type)]
1159             [(pair? type)
1160              (match type
1161                [((or 'pointer 'c-pointer 'nonnull-pointer 'nonnull-c-pointer) ptype)
1162                 (foreign-type-declaration ptype (string-append "*" target)) ]
1163                [('ref rtype)
1164                 (foreign-type-declaration rtype (string-append "&" target)) ]
1165                [`(template ,t0 ,ts ...)
1166                 (str
1167                  (string-append
1168                   (foreign-type-declaration t0 "")
1169                   "<"
1170                   (string-intersperse (map (cut foreign-type-declaration <> "") ts) ",")
1171                   "> ") ) ]
1172                [`(const ,t) (string-append "const " (foreign-type-declaration t target))]
1173                [`(struct ,sname) (string-append "struct " (->string sname) " " target)]
1174                [`(union ,uname) (string-append "union " (->string uname) " " target)]
1175                [`(enum ,ename) (string-append "enum " (->string ename) " " target)]
1176                [((or 'instance 'nonnull-instance) cname sname) (string-append (->string cname) "*" target)]
1177                [('instance-ref cname sname) (string-append (->string cname) "&" target)]
1178                [('function rtype argtypes . callconv)
1179                 (string-append
1180                  (foreign-type-declaration rtype "")
1181                  (or (and-let* ([(pair? callconv)]
1182                                 [cc (car callconv)]
1183                                 [(string? cc)] )
1184                        cc)
1185                      "")
1186                  " (*" target ")("
1187                  (string-intersperse
1188                   (map (lambda (at)
1189                          (if (eq? '... at) 
1190                              "..."
1191                              (foreign-type-declaration at "") ) )
1192                        argtypes) 
1193                   ",")
1194                  ")" ) ]
1195                [_ (err)] ) ]
1196             [else (err)] ) ] ) ) )
1197
1198(define (fix-name str #!optional (use-prefix #t))
1199  (let ([a (assq (->symbol str) rename-list)])
1200    (if a 
1201        (cdr a)
1202        (let ([n1 (fold 
1203                   (lambda (rx repl str)
1204                     (if (procedure? repl)
1205                         (let ([m (string-match rx str)])
1206                           (if m (repl m) str) )
1207                         (string-substitute rx repl str #t) ) )
1208                   (->string str)
1209                   name-substitution-rxs
1210                   name-substitution-repls) ] )
1211          (string->symbol
1212           (strdowncase
1213            (if (and use-prefix prefix)
1214                (string-append prefix n1)
1215                n1) ) ) ) ) ) )
1216
1217(define (fix-cname str)
1218  (let ([a (assq (->symbol str) rename-list)])
1219    (if a 
1220        (cdr a)
1221        (string->symbol (string-append "<" (->string (fix-name str #f)) ">")) ) ) )
1222
1223(define (->symbol s)
1224  (if (symbol? s)
1225      s
1226      (string->symbol s) ) )
1227
1228(define (parse-easy-ffi text)
1229  (lexer-init 'string text)
1230  (set! processed-output '())
1231  (set! pp-conditional-stack '())
1232  (set! pp-process #t)
1233  (let ([chunks (chunkify)])
1234    (for-each parse chunks)
1235    (reverse processed-output) ) )
1236
1237(define (parse-easy-ffi-rec port)
1238  (lexer-init 'port port)
1239  (let* ([output processed-output]
1240         [chunks (chunkify)] )
1241    (set! processed-output '())
1242    (for-each parse chunks)
1243    (set! processed-output (append output processed-output)) ) )
1244
1245(define (register-ffi-macro name)
1246  (set! macro-table (cons (list (string->symbol name) '* '()) macro-table)) )
1247
1248(define (resolve-ffi-include-file fname)
1249  (find file-exists? (map (cut make-pathname <> fname) ffi-include-path-list)) )
1250
1251(define (foreign-type->class ftype io)
1252  (let rec ([ftype ftype])
1253    (match ftype
1254      ['char '<char>]
1255      ['bool '<boolean>]
1256      ['c-string '<string>]
1257      [(or 'unsigned-char 'int 'unsigned-int 'short 'unsigned-short 'unsigned-int32 'int32 'integer32)
1258       '<exact>]
1259      [(or 'long 'unsigned-long 'integer32 'integer 'unsigned-integer 'unsigned-integer32 'integer64) '<integer>]
1260      [(or 'float 'double) '<inexact>]
1261      ['number '<number>]
1262      [('enum _) '<exact>]
1263      [('const t) (rec t)]
1264      [('function . _) '<pointer>]
1265      [('instance _ c) c]
1266      [((or 'pointer 'c-pointer 'ref) x)
1267       (if io
1268           (rec x)
1269           '<pointer>) ]
1270      ['u8vector '<u8vector>]
1271      ['s8vector '<s8vector>]
1272      ['u16vector '<u16vector>]
1273      ['s16vector '<s16vector>]
1274      ['u32vector '<u32vector>]
1275      ['s32vector '<s32vector>]
1276      ['f32vector '<f32vector>]
1277      ['f64vector '<f64vector>]
1278      [(? symbol?)
1279       (let ([a (##sys#hash-table-ref ##compiler#foreign-type-table ftype)])
1280         (if a
1281             (rec (if (vector? a) (vector-ref a 0) a))
1282             '<top>) ) ] ) ) )
1283
1284(define (gen-spec-list args io)
1285  (map (lambda (t io) (list (gensym) (foreign-type->class t io))) args io) )
1286
1287(define strdowncase
1288  (let ([cs case-sensitive])
1289    (lambda (str)
1290      (if (cs)
1291          str
1292          (let ([s2 (string-copy str)]
1293                [len (string-length str)] )
1294            (do ([i (sub1 len) (sub1 i)])
1295                ((negative? i) s2)
1296              (string-set! s2 i (char-downcase (string-ref str i))) ) ) ) ) ) )
1297
1298
1299;;; C syntax checker:
1300
1301(define syntax-check-location #f)
1302
1303(define (check-syntax-error text)
1304  (lambda (fstr . args)
1305    (error (sprintf #<<EOF
1306suspicious foreign code fragment~A:
1307------------------------------------------------------------
1308~A
1309------------------------------------------------------------
1310~?
1311EOF
1312          (if syntax-check-location
1313              (sprintf " in `~A' form" syntax-check-location)
1314              "")
1315          text
1316          fstr
1317          args) ) ) )
1318
1319(define (check-c-syntax text . loc)
1320  (unless no-c-syntax-checks
1321    (fluid-let ([parsing-error (check-syntax-error text)]
1322                [syntax-check-location (optional loc #f)] )
1323      (define (checkp p s)
1324        (cond [(null? s) (parsing-error (sprintf "unbalanced parantheses - missing match to `~A'" p))]
1325              [(not (eq? p (car s)))
1326               (parsing-error (sprintf "unbalanced parantheses - expected `~A', but found `~A'" p (car s))) ] ) )
1327      (define (checkpp p s)
1328        (cond [(null? s) (parsing-error (sprintf "unbalanced parantheses - missing match to `~A'" p))]
1329              [(not (equal? p (car s)))
1330               (parsing-error (sprintf "unbalanced preprocessor conditional - expected `~A', but found `~A'" p (car s))) ] ) )
1331      (lexer-init 'string text)
1332      (set! pp-process #t)
1333      (let loop ([pstack '()] [ppstack '()])
1334        (let ([t (lexer)])
1335          (case t
1336            [(stop)
1337             (when (pair? pstack)
1338               (parsing-error (sprintf "unbalanced parentheses - missing `~A'" (car pstack)) ))
1339             (when (pair? ppstack)
1340               (parsing-error (sprintf "unbalanced preprocessor command - missing `~A'" (car ppstack)) ) ) ]
1341            [(pp-else)
1342             (checkpp "#endif" ppstack) 
1343             (loop pstack ppstack) ]
1344            [(pp-endif)
1345             (checkpp "#endif" ppstack) 
1346             (loop pstack (cdr ppstack)) ]
1347            [(pp-if pp-ifdef pp-ifndef)
1348             (loop pstack (cons "#endif" ppstack)) ]
1349            [(open-curly)
1350             (loop (cons #\} pstack) ppstack) ]
1351            [(close-curly)
1352             (checkp #\} pstack) 
1353             (loop (cdr pstack) ppstack) ]
1354            [(open-paren)
1355             (loop (cons #\) pstack) ppstack) ]
1356            [(close-paren)
1357             (checkp #\) pstack)
1358             (loop (cdr pstack) ppstack) ] 
1359            [(open-bracket)
1360             (loop (cons #\] pstack) ppstack) ]
1361            [(close-bracket)
1362             (checkp #\] pstack)
1363             (loop (cdr pstack) ppstack) ] 
1364            [else (loop pstack ppstack)] ) ) ) ) ) )
1365
1366
1367;;; "#> ... <#" syntax:
1368
1369(set! ##sys#user-read-hook
1370  (let ([old-hook ##sys#user-read-hook])
1371    (lambda (char port)
1372      (if (char=? #\> char)           
1373          (let ([_ (read-char port)]    ; swallow #\>
1374                [decl #f]
1375                [parse #f]
1376                [exec #f] )
1377            (case (peek-char port)
1378              [(#\!)
1379               (read-char port)
1380               (set! parse #t)
1381               (set! decl #t) ]
1382              [(#\?)
1383               (read-char port)
1384               (set! parse #t) ]
1385              [(#\:)
1386               (read-char port)
1387               (set! exec #t) ]
1388              [(#\()
1389               (let ([head (read port)])
1390                 (for-each
1391                  (lambda (t)
1392                    (case t
1393                      [(declare) (set! decl #t)]
1394                      [(parse) (set! parse #t)]
1395                      [(execute) (set! exec #t)]
1396                      [else (error "invalid tag in `#>(...) ...<#' form" t)] ) )
1397                  head) ) ]
1398              [else (set! decl #t)] )
1399            (let ([text (##easyffi#scan-sharp-greater-string port)])
1400              (check-c-syntax text)
1401              `(begin
1402                 ,@(if decl
1403                       `((foreign-declare ,text))
1404                       '() )
1405                 ,@(if parse
1406                       `((foreign-parse ,text))
1407                       '() )
1408                 ,@(if exec
1409                       (let ([tmp (gensym 'code_)])
1410                         `((foreign-declare
1411                            ,(sprintf "static C_word ~A() { ~A; return C_SCHEME_UNDEFINED; }\n" tmp text) )
1412                           (##core#inline ,(symbol->string tmp)) ) )
1413                       '() ) ) ) )
1414          (old-hook char port) ) ) ) )
1415
1416(define (##easyffi#scan-sharp-greater-string port)
1417  (let ([out (open-output-string)])
1418    (let loop ()
1419      (let ([c (read-char port)])
1420        (cond [(eof-object? c) (error "unexpected end of `#> ... <#' sequence")]
1421              [(char=? c #\newline)
1422               (newline out)
1423               (loop) ]
1424              [(char=? c #\<)
1425               (let ([c (read-char port)])
1426                 (if (eqv? #\# c)
1427                     (get-output-string out)
1428                     (begin
1429                       (write-char #\< out)
1430                       (write-char c out) 
1431                       (loop) ) ) ) ]
1432              [else
1433               (write-char c out)
1434               (loop) ] ) ) ) ) )
1435
1436)
Note: See TracBrowser for help on using the repository browser.