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

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

experimental support for exception wrapper code

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