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

Last change on this file since 16443 was 16443, checked in by felix winkelmann, 10 years ago

global registration of generic functions; explicit pointer check instead of backdoor in compiler

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