source: project/chicken/trunk/chicken-ffi-macros.scm @ 5639

Last change on this file since 5639 was 5639, checked in by Kon Lovett, 13 years ago

Added numeric -> scheme value overrides to define-foreign-enum. Bumped version number to 2.637

File size: 13.0 KB
Line 
1;;;; chicken-ffi-macros.scm
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(define-macro (define-foreign-type . xs)
37  (##sys#check-syntax 'define-foreign-type xs '(symbol . #(_ 1 3)))
38  `(##core#define-foreign-type
39    ,(list 'quote (car xs))
40    ,(list 'quote (cadr xs))
41    ,@(cddr xs) ) )
42
43(define-macro (define-foreign-variable . xs)
44  (##sys#check-syntax 'define-foreign-variable xs '(symbol . #(_ 1)))
45  `(##core#define-foreign-variable ,@(map (lambda (x) (list 'quote x)) xs)) )
46
47(define-macro (foreign-lambda . xs)
48  (##sys#check-syntax 'foreign-lambda xs '(_ _ . #(_ 0)))
49  `(##core#foreign-lambda ,@(map (lambda (x) (list 'quote x)) xs)) )
50
51(define-macro (foreign-lambda* . xs)
52  (##sys#check-syntax 'foreign-lambda* xs '(_ #((_ _) 0) . #(string 1)))
53  `(##core#foreign-lambda* ,@(map (lambda (x) (list 'quote x)) xs)) )
54
55(define-macro (foreign-safe-lambda . xs)
56  (##sys#check-syntax 'foreign-safe-lambda xs '(_ _ . #(_ 0)))
57  `(##core#foreign-callback-lambda ,@(map (lambda (x) (list 'quote x)) xs)) )
58
59(define-macro (foreign-safe-lambda* . xs)
60  (##sys#check-syntax 'foreign-safe-lambda* xs '(_ #((_ _) 0) . #(string 1)))
61  `(##core#foreign-callback-lambda* ,@(map (lambda (x) (list 'quote x)) xs)) )
62
63(define-macro (foreign-primitive . xs)
64  (##sys#check-syntax 'foreign-primitive xs '#(_ 1)) 
65  `(##core#foreign-primitive ,@(map (lambda (x) (list 'quote x)) xs)) )
66
67(define-macro (foreign-safe-wrapper . form) ; DEPRECATED
68  (##sys#check-syntax 'foreign-safe-wrapper form '(_ string . #(_ 1)))
69  (if (string? (caddr form))
70      (begin
71        (##sys#check-syntax 'foreign-safe-wrapper form '(_ string string _ (lambda lambda-list . #(_ 1))))
72        `(##core#foreign-callback-wrapper
73          ',(cadr form)
74          ',(caddr form)
75          ',(car form)
76          ',(cadddr form)
77          ,(cadddr (cdr form)) ) )
78      (begin
79        (##sys#check-syntax 'foreign-safe-wrapper form '(_ string _ (lambda lambda-list . #(_ 1))))
80        `(##core#foreign-callback-wrapper
81          ',(cadr form)
82          ',""
83          ',(car form)
84          ',(caddr form)
85          ,(cadddr form) ) ) ) )
86
87(define-macro (define-external . form)
88  (let* ([quals (and (pair? form) (string? (car form)))]
89         [var (and (not quals) (pair? form) (symbol? (car form)))] )
90    (cond [var
91           (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))
92           (let ([var (car form)])
93             `(begin
94                (##core#define-foreign-variable ',var ',(cadr form))
95                (##core#define-external-variable ',var ',(cadr form) '#t)
96                ,@(if (pair? (cddr form))
97                      `((##core#set! ,var ,(caddr form)))
98                      '() ) ) ) ]
99          [else
100           (if quals
101               (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))
102               (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )
103           (let* ([head (if quals (cadr form) (car form))]
104                  [args (cdr head)] )
105             `(define ,(car head)
106                (##core#foreign-callback-wrapper
107                 ',(car head)
108                 ',(if quals (car form) "")
109                 ',(if quals (caddr form) (cadr form))
110                 ',(map (lambda (a) (car a)) args)
111                 (lambda ,(map (lambda (a) (cadr a)) args) ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) )
112
113
114
115;;; External locations:
116
117(define-macro (define-location var type . init)
118  (let ([name (gensym)])
119    `(begin
120       (##core#define-foreign-variable ',var ',type ',(symbol->string name))
121       (##core#define-external-variable ',var ',type '#f ',name)
122       ,@(if (pair? init)
123             `((##core#set! ,var ,(car init)))
124             '() ) ) ) ) 
125
126(define-macro (let-location bindings . body)
127  (let ([aliases (map (lambda (_) (gensym)) bindings)])
128    `(let ,(append-map
129            (lambda (b a)
130              (if (pair? (cddr b))
131                  (list (cons a (cddr b)))
132                  '() ) )
133            bindings aliases)
134       ,(fold-right
135          (lambda (b a rest)
136            (if (= 3 (length b))
137               `(##core#let-location
138                 (quote ,(car b))
139                 (quote ,(cadr b))
140                 ,a
141                 ,rest)
142               `(##core#let-location
143                 (quote ,(car b))
144                 (quote ,(cadr b))
145                 ,rest) ) )
146          `(let () ,@body)
147          bindings aliases) ) ) )
148
149
150;;; Embedding code directly:
151
152(define-macro (foreign-code . strs)
153  (let ([tmp (gensym 'code_)])
154    `(begin
155       (declare 
156         (foreign-declare
157          ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n" tmp (string-intersperse strs "\n")) ) )
158       (##core#inline ,tmp) ) ) )
159
160(define-macro (foreign-value str type)
161  (let ([tmp (gensym 'code_)])
162    `(begin
163       (define-foreign-variable ,tmp ,type ,str)
164       ,tmp) ) )
165
166
167;;; Foreign records:
168
169(define-macro (define-foreign-record name . slots)
170  (let ([fname (if (pair? name) (->string (cadr name)) (sprintf "struct ~A" name))]
171        [tname (if (pair? name) (car name) name)] 
172        [var (gensym)] 
173        [renamer identity]
174        [ctor #f]
175        [dtor #f]
176        [cvar (gensym)]
177        [xvar (gensym)]
178        [svar (gensym)] )
179    (define (stype type)
180      (cond [(not (pair? type)) type]
181            [(eq? 'const (car type)) (stype (cadr type))]
182            [(memq (car type) '(struct union)) `(c-pointer ,type)]
183            [else type] ) )
184    (define (strtype type)
185      (or (eq? type tname)
186          (and (pair? type)
187               (or (and (eq? 'const (car type)) (strtype (cadr type)))
188                   (memq (car type) '(struct union)) ) ) ) ) ; handle instances?
189    (do ((slts slots (cdr slts)))
190        ((or (null? slts) (not (pair? (car slts))) (not (keyword? (caar slts))))
191         (set! slots slts) )
192      (case (caar slts)
193        ((rename:) (set! renamer (eval (cadar slts))))
194        ((constructor:) (set! ctor (cadar slts)))
195        ((destructor:) (set! dtor (cadar slts)))
196        (else (syntax-error 'define-foreign-record "invalid foreign record-type specification" (car slts))) ) )
197    (##sys#hash-table-set! ##compiler#foreign-type-table tname `(c-pointer ,fname))
198    `(begin
199       ,@(if (pair? name)
200             '() 
201             `((declare
202                 (foreign-declare
203                  ,(string-intersperse
204                    (append
205                     (cons
206                      (string-append "struct " (->string name) " { ")
207                      (map (lambda (slot)
208                             (case (length slot)
209                               [(3) 
210                                (sprintf "~A[~A];"
211                                         (##compiler#foreign-type-declaration
212                                          (car slot)
213                                          (->string (cadr slot)) )
214                                         (caddr slot) ) ]
215                               [(2)
216                                (sprintf "~A;"
217                                         (##compiler#foreign-type-declaration 
218                                          (car slot)
219                                          (->string (cadr slot)) ) ) ]
220                               [else (syntax-error 'define-foreign-record "bad slot spec" slot)] ) )
221                           slots) )
222                     (list "};") )
223                    "\n") ) ) ) )
224       ,@(if (not ctor)
225             '()
226             `((define ,ctor
227                 (foreign-lambda* ,tname () ,(sprintf "return((~a *)C_malloc(sizeof(~a)));" fname fname)))))
228       ,@(if (not dtor)
229             '()
230             `((define (,dtor ptr) (and ptr (##core#inline "C_qfree" ptr)))) )
231       ,@(map (lambda (slot)
232                (case (length slot)
233                  [(3)
234                   (let* ([type (car slot)]
235                          [sname (cadr slot)]
236                          [size (caddr slot)]
237                          [type2 (stype type)] )
238                     `(begin
239                        (define ,(string->symbol (renamer (sprintf "~A-~A" tname sname)))
240                          (let ([,cvar 
241                                 (foreign-lambda* ,type2 ([,tname ,var] [int ,svar])
242                                   ,(sprintf "return(~A~A->~A[~A]);" 
243                                             (if (not (strtype type)) "" "&")
244                                             var sname svar) ) ] )
245                            (lambda (,var ,svar)
246                              (if (##core#check (and (fx>= ,svar 0) (fx< ,svar ,size)))
247                                  (,cvar ,var ,svar)
248                                  ;; this should signal a range exn...
249                                  (syntax-error 'define-foreign-record "array access out of range" ',tname ',svar ,size) ) ) ) )
250                        ,@(if (and (pair? type) (eq? 'const (car type))) 
251                              '()
252                              (if (eq? type type2)
253                                  `((define ,(string->symbol (renamer (sprintf "~A-~A-set!" tname sname)))
254                                      (let ([,cvar
255                                             (foreign-lambda* void ([,tname ,var] [int ,svar] [,type ,xvar])
256                                               ,(sprintf "~A->~A[~A] = ~A;" var sname svar xvar) ) ] )
257                                        (lambda (,var ,svar ,xvar)
258                                          (if (##core#check (and (fx>= ,svar 0) (fx< ,svar ,size)))
259                                              (,cvar ,var ,svar ,xvar)
260                                              (syntax-error 
261                                               'define-foreign-record
262                                               "array access out of range" ',tname ',svar ,size) ) ) ) ) )
263                                  '() ) ) ) ) ]
264                  [(2)
265                   (let* ([type (car slot)]
266                          [sname (cadr slot)] 
267                          [type2 (stype type)] )
268                     `(begin
269                        (define ,(string->symbol (renamer (sprintf "~A-~A" tname sname)))
270                          (foreign-lambda* ,type2 ([,tname ,var])
271                            ,(sprintf "return(~A~A->~A);" 
272                                      (if (not (strtype type)) "" "&")
273                                      var sname) ) )
274                        ,@(if (and (pair? type) (eq? 'const (car type)))
275                              '()
276                              (if (eq? type type2)
277                                  `((define ,(string->symbol (renamer (sprintf "~A-~A-set!" tname sname)))
278                                      (foreign-lambda* void ([,tname ,var] [,type ,xvar])
279                                        ,(sprintf "~A->~A = ~A;" var sname xvar) ) ) )
280                                  '() ) ) ) ) ]
281                  [else (syntax-error 'define-foreign-record "bad slot spec" slot)] ) )
282              slots) ) ) )
283
284
285;;; Include/parse foreign code fragments
286
287(define-macro (foreign-declare . strs)
288  `(##core#declare '(foreign-declare ,@strs)))
289
290
291;;; Foreign enumerations (or enum-like constants)
292
293(define-macro (define-foreign-enum typename . enums)
294  (let ((name typename)
295        (type (->string typename))
296        (defsymval ''())
297        (symbols (map (lambda (e) (if (pair? e) (car e) e)) enums))
298        (extvals (map (lambda (e)
299                        (if (pair? e)
300                            (if (pair? (cdr e))
301                                (cadr e)
302                                (syntax-error 'define-foreign-enum
303                                              "invalid enum specification" e) )
304                            e ) )
305                      enums))
306        (symvals (map (lambda (e)
307                        (if (pair? e)
308                            (if (pair? (cddr e))
309                                (caddr e)
310                                `(quote ,(car e)))
311                            `(quote ,e)))
312                      enums)) )
313    (when (list? typename)
314      (let ([len (length typename)])
315        (unless (<= 2 len 3)
316          (syntax-error 'define-foreign-enum "invalid typename specification" typename) )
317        (set! name (car typename))
318        (set! type (cadr typename))
319        (when (= 3 len)
320          (set! defsymval (caddr typename)) ) ) )
321    (let ((aliases (map gensym symbols))
322          (s->e (string->symbol (conc name "->number")))
323          (e->s (string->symbol (conc "number->" name)) ) )
324      `(begin
325         ,@(map (lambda (a v) `(define-foreign-variable ,a integer ,(->string v))) aliases extvals)
326         (define (,s->e syms)
327           (let loop ((syms (if (symbol? syms) (list syms) syms)) (sum 0))
328             (if (null? syms) 
329                 sum
330                 (loop (cdr syms)
331                       (bitwise-ior
332                        sum
333                        (let ((val (car syms)))
334                          (case val
335                            ,@(map (lambda (a s) `((,s) ,a)) aliases symbols)
336                            (else (error "not a member of enum" val ',name)) ) ) ) ) ) ) )
337         (define (,e->s val)
338           (cond
339            ,@(map (lambda (a sv) `((= val ,a) ,sv)) aliases symvals)
340            (else ,defsymval) ) )
341         (define-foreign-type ,name ,type ,s->e ,e->s) ) ) ) )
342
343
344;;; Deprecated FFI macros
345
346(define-macro (define-deprecated-macro old new)
347  `(define-macro (,old . args)
348     (warning (sprintf "`~s' is deprecated, use `~s' instead" ',old ',new))
349     (cons ',new args) ) )
350
351(define-deprecated-macro foreign-callback-lambda foreign-safe-lambda)
352(define-deprecated-macro foreign-callback-lambda* foreign-safe-lambda*)
353(define-deprecated-macro foreign-callback-wrapper foreign-safe-wrapper)
354
355
356;;; Not for general use, yet
357
358(define-macro (define-compiler-macro head . body)
359  (define (bad)
360    (syntax-error
361     'define-compiler-macro "invalid compiler macro definition" head) )
362  (if (and (pair? head) (symbol? (car head)))
363      (cond ((memq 'compiling ##sys#features)
364             (warning "compile macros are not available in interpreted code" 
365                      (car head) ) )
366            ((not (##compiler#register-compiler-macro (car head) (cdr head) body))
367             (bad) ) )
368      (bad) )
369  '(void) )
Note: See TracBrowser for help on using the repository browser.