source: project/chicken/branches/prerelease/chicken-ffi-macros.scm @ 9381

Last change on this file since 9381 was 9381, checked in by Ivan Raikov, 12 years ago

Merged trunk into prerelease

File size: 12.7 KB
Line 
1;;;; chicken-ffi-macros.scm
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
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(define-macro (define-foreign-type . xs)
29  (##sys#check-syntax 'define-foreign-type xs '(symbol . #(_ 1 3)))
30  `(##core#define-foreign-type
31    ,(list 'quote (car xs))
32    ,(list 'quote (cadr xs))
33    ,@(cddr xs) ) )
34
35(define-macro (define-foreign-variable . xs)
36  (##sys#check-syntax 'define-foreign-variable xs '(symbol . #(_ 1)))
37  `(##core#define-foreign-variable ,@(map (lambda (x) (list 'quote x)) xs)) )
38
39(define-macro (foreign-lambda . xs)
40  (##sys#check-syntax 'foreign-lambda xs '(_ _ . #(_ 0)))
41  `(##core#foreign-lambda ,@(map (lambda (x) (list 'quote x)) xs)) )
42
43(define-macro (foreign-lambda* . xs)
44  (##sys#check-syntax 'foreign-lambda* xs '(_ #((_ _) 0) . #(string 1)))
45  `(##core#foreign-lambda* ,@(map (lambda (x) (list 'quote x)) xs)) )
46
47(define-macro (foreign-safe-lambda . xs)
48  (##sys#check-syntax 'foreign-safe-lambda xs '(_ _ . #(_ 0)))
49  `(##core#foreign-callback-lambda ,@(map (lambda (x) (list 'quote x)) xs)) )
50
51(define-macro (foreign-safe-lambda* . xs)
52  (##sys#check-syntax 'foreign-safe-lambda* xs '(_ #((_ _) 0) . #(string 1)))
53  `(##core#foreign-callback-lambda* ,@(map (lambda (x) (list 'quote x)) xs)) )
54
55(define-macro (foreign-primitive . xs)
56  (##sys#check-syntax 'foreign-primitive xs '#(_ 1))
57  `(##core#foreign-primitive ,@(map (lambda (x) (list 'quote x)) xs)) )
58
59(define-macro (foreign-safe-wrapper . form) ; DEPRECATED
60  (##sys#check-syntax 'foreign-safe-wrapper form '(_ string . #(_ 1)))
61  (if (string? (caddr form))
62      (begin
63        (##sys#check-syntax 'foreign-safe-wrapper form '(_ string string _ (lambda lambda-list . #(_ 1))))
64        `(##core#foreign-callback-wrapper
65          ',(cadr form)
66          ',(caddr form)
67          ',(car form)
68          ',(cadddr form)
69          ,(cadddr (cdr form)) ) )
70      (begin
71        (##sys#check-syntax 'foreign-safe-wrapper form '(_ string _ (lambda lambda-list . #(_ 1))))
72        `(##core#foreign-callback-wrapper
73          ',(cadr form)
74          ',""
75          ',(car form)
76          ',(caddr form)
77          ,(cadddr form) ) ) ) )
78
79(define-macro (define-external . form)
80  (let* ([quals (and (pair? form) (string? (car form)))]
81         [var (and (not quals) (pair? form) (symbol? (car form)))] )
82    (cond [var
83           (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))
84           (let ([var (car form)])
85             `(begin
86                (##core#define-foreign-variable ',var ',(cadr form))
87                (##core#define-external-variable ',var ',(cadr form) '#t)
88                ,@(if (pair? (cddr form))
89                      `((##core#set! ,var ,(caddr form)))
90                      '() ) ) ) ]
91          [else
92           (if quals
93               (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))
94               (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )
95           (let* ([head (if quals (cadr form) (car form))]
96                  [args (cdr head)] )
97             `(define ,(car head)
98                (##core#foreign-callback-wrapper
99                 ',(car head)
100                 ',(if quals (car form) "")
101                 ',(if quals (caddr form) (cadr form))
102                 ',(map (lambda (a) (car a)) args)
103                 (lambda ,(map (lambda (a) (cadr a)) args) ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) )
104
105
106
107;;; External locations:
108
109(define-macro (define-location var type . init)
110  (let ([name (gensym)])
111    `(begin
112       (##core#define-foreign-variable ',var ',type ',(symbol->string name))
113       (##core#define-external-variable ',var ',type '#f ',name)
114       ,@(if (pair? init)
115             `((##core#set! ,var ,(car init)))
116             '() ) ) ) )
117
118(define-macro (let-location bindings . body)
119  (let ([aliases (map (lambda (_) (gensym)) bindings)])
120    `(let ,(append-map
121            (lambda (b a)
122              (if (pair? (cddr b))
123                  (list (cons a (cddr b)))
124                  '() ) )
125            bindings aliases)
126       ,(fold-right
127          (lambda (b a rest)
128            (if (= 3 (length b))
129               `(##core#let-location
130                 (quote ,(car b))
131                 (quote ,(cadr b))
132                 ,a
133                 ,rest)
134               `(##core#let-location
135                 (quote ,(car b))
136                 (quote ,(cadr b))
137                 ,rest) ) )
138          `(let () ,@body)
139          bindings aliases) ) ) )
140
141
142;;; Embedding code directly:
143
144(define-macro (foreign-code . strs)
145  (let ([tmp (gensym 'code_)])
146    `(begin
147       (declare
148         (foreign-declare
149          ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n" tmp (string-intersperse strs "\n")) ) )
150       (##core#inline ,tmp) ) ) )
151
152(define-macro (foreign-value str type)
153  (let ([tmp (gensym 'code_)])
154    `(begin
155       (define-foreign-variable ,tmp ,type ,str)
156       ,tmp) ) )
157
158
159;;; Foreign records:
160
161(define-macro (define-foreign-record name . slots)
162  (let ([fname (if (pair? name) (->string (cadr name)) (sprintf "struct ~A" name))]
163        [tname (if (pair? name) (car name) name)]
164        [var (gensym)]
165        [renamer identity]
166        [ctor #f]
167        [dtor #f]
168        [cvar (gensym)]
169        [xvar (gensym)]
170        [svar (gensym)] )
171    (define (stype type)
172      (cond [(not (pair? type)) type]
173            [(eq? 'const (car type)) (stype (cadr type))]
174            [(memq (car type) '(struct union)) `(c-pointer ,type)]
175            [else type] ) )
176    (define (strtype type)
177      (or (eq? type tname)
178          (and (pair? type)
179               (or (and (eq? 'const (car type)) (strtype (cadr type)))
180                   (memq (car type) '(struct union)) ) ) ) ) ; handle instances?
181    (do ((slts slots (cdr slts)))
182        ((or (null? slts) (not (pair? (car slts))) (not (keyword? (caar slts))))
183         (set! slots slts) )
184      (case (caar slts)
185        ((rename:) (set! renamer (eval (cadar slts))))
186        ((constructor:) (set! ctor (cadar slts)))
187        ((destructor:) (set! dtor (cadar slts)))
188        (else (syntax-error 'define-foreign-record "invalid foreign record-type specification" (car slts))) ) )
189    (##sys#hash-table-set! ##compiler#foreign-type-table tname `(c-pointer ,fname))
190    `(begin
191       ,@(if (pair? name)
192             '()
193             `((declare
194                 (foreign-declare
195                  ,(string-intersperse
196                    (append
197                     (cons
198                      (string-append "struct " (->string name) " { ")
199                      (map (lambda (slot)
200                             (case (length slot)
201                               [(3)
202                                (sprintf "~A[~A];"
203                                         (##compiler#foreign-type-declaration
204                                          (car slot)
205                                          (->string (cadr slot)) )
206                                         (caddr slot) ) ]
207                               [(2)
208                                (sprintf "~A;"
209                                         (##compiler#foreign-type-declaration
210                                          (car slot)
211                                          (->string (cadr slot)) ) ) ]
212                               [else (syntax-error 'define-foreign-record "bad slot spec" slot)] ) )
213                           slots) )
214                     (list "};") )
215                    "\n") ) ) ) )
216       ,@(if (not ctor)
217             '()
218             `((define ,ctor
219                 (foreign-lambda* ,tname () ,(sprintf "return((~a *)C_malloc(sizeof(~a)));" fname fname)))))
220       ,@(if (not dtor)
221             '()
222             `((define (,dtor ptr) (and ptr (##core#inline "C_qfree" ptr)))) )
223       ,@(map (lambda (slot)
224                (case (length slot)
225                  [(3)
226                   (let* ([type (car slot)]
227                          [sname (cadr slot)]
228                          [size (caddr slot)]
229                          [type2 (stype type)] )
230                     `(begin
231                        (define ,(string->symbol (renamer (sprintf "~A-~A" tname sname)))
232                          (let ([,cvar
233                                 (foreign-lambda* ,type2 ([,tname ,var] [int ,svar])
234                                   ,(sprintf "return(~A~A->~A[~A]);"
235                                             (if (not (strtype type)) "" "&")
236                                             var sname svar) ) ] )
237                            (lambda (,var ,svar)
238                              (if (##core#check (and (fx>= ,svar 0) (fx< ,svar ,size)))
239                                  (,cvar ,var ,svar)
240                                  ;; this should signal a range exn...
241                                  (syntax-error 'define-foreign-record "array access out of range" ',tname ',svar ,size) ) ) ) )
242                        ,@(if (and (pair? type) (eq? 'const (car type)))
243                              '()
244                              (if (eq? type type2)
245                                  `((define ,(string->symbol (renamer (sprintf "~A-~A-set!" tname sname)))
246                                      (let ([,cvar
247                                             (foreign-lambda* void ([,tname ,var] [int ,svar] [,type ,xvar])
248                                               ,(sprintf "~A->~A[~A] = ~A;" var sname svar xvar) ) ] )
249                                        (lambda (,var ,svar ,xvar)
250                                          (if (##core#check (and (fx>= ,svar 0) (fx< ,svar ,size)))
251                                              (,cvar ,var ,svar ,xvar)
252                                              (syntax-error
253                                               'define-foreign-record
254                                               "array access out of range" ',tname ',svar ,size) ) ) ) ) )
255                                  '() ) ) ) ) ]
256                  [(2)
257                   (let* ([type (car slot)]
258                          [sname (cadr slot)]
259                          [type2 (stype type)] )
260                     `(begin
261                        (define ,(string->symbol (renamer (sprintf "~A-~A" tname sname)))
262                          (foreign-lambda* ,type2 ([,tname ,var])
263                            ,(sprintf "return(~A~A->~A);"
264                                      (if (not (strtype type)) "" "&")
265                                      var sname) ) )
266                        ,@(if (and (pair? type) (eq? 'const (car type)))
267                              '()
268                              (if (eq? type type2)
269                                  `((define ,(string->symbol (renamer (sprintf "~A-~A-set!" tname sname)))
270                                      (foreign-lambda* void ([,tname ,var] [,type ,xvar])
271                                        ,(sprintf "~A->~A = ~A;" var sname xvar) ) ) )
272                                  '() ) ) ) ) ]
273                  [else (syntax-error 'define-foreign-record "bad slot spec" slot)] ) )
274              slots) ) ) )
275
276
277;;; Include/parse foreign code fragments
278
279(define-macro (foreign-declare . strs)
280  `(##core#declare '(foreign-declare ,@strs)))
281
282
283;;; Foreign enumerations (or enum-like constants)
284
285;; (define-foreign-enum TYPE [USE-ALIASES] ENUM ...)
286;; TYPE : TYPENAME or (SCHEMENAME REALTYPE [DEFAULT-SCHEME-VALUE])
287;; USE-ALIAES : boolean, default #t
288;; ENUM : TYPENAME or (SCHEMENAME REALTYPE [SCHEME-VALUE])
289
290(define-macro (define-foreign-enum typespec . enums)
291  (let ([use-aliases (if (pair? enums)
292                         (let ([flag (car enums)])
293                           (if (boolean? flag)
294                               (begin (set! enums (cdr enums)) flag)
295                               #t ) )
296                         #t ) ] )
297    (let ((name typespec)
298          (type (->string typespec))
299          (defsymval ''())
300
301          (symbols (map (lambda (e) (if (pair? e) (car e) e)) enums))
302          (extvals (map (lambda (e)
303                          (if (pair? e)
304                              (if (pair? (cdr e))
305                                  (cadr e)
306                                  (syntax-error 'define-foreign-enum
307                                                "invalid enum specification" e) )
308                              e ) )
309                        enums))
310          (symvals (map (lambda (e)
311                          (if (pair? e)
312                              (if (pair? (cddr e))
313                                  (caddr e)
314                                  `(quote ,(car e)))
315                              `(quote ,e)))
316                        enums)) )
317      (when (list? typespec)
318        (let ([len (length typespec)])
319          (unless (<= 2 len 3)
320            (syntax-error 'define-foreign-enum "invalid type specification" typespec) )
321          (set! name (car typespec))
322          (set! type (cadr typespec))
323          (when (= 3 len)
324            (set! defsymval (caddr typespec)) ) ) )
325      (let ((aliases (if use-aliases (map gensym symbols) symbols))
326            (s->e (string->symbol (conc name "->number")))
327            (e->s (string->symbol (conc "number->" name)) ) )
328        `(begin
329           ,@(map (lambda (a v) `(define-foreign-variable ,a ,type ,(->string v))) aliases extvals)
330           (define (,s->e syms)
331             (let loop ((syms (if (symbol? syms) (list syms) syms)) (sum 0))
332               (if (null? syms)
333                   sum
334                   (loop (cdr syms)
335                         (bitwise-ior
336                          sum
337                          (let ((val (car syms)))
338                            (case val
339                              ,@(map (lambda (a s) `((,s) ,a)) aliases symbols)
340                              (else (error "not a member of enum" val ',name)) ) ) ) ) ) ) )
341           (define (,e->s val)
342             (cond
343              ,@(map (lambda (a sv) `((= val ,a) ,sv)) aliases symvals)
344              (else ,defsymval) ) )
345           (define-foreign-type ,name ,type ,s->e ,e->s) ) ) ) ) )
346
347
348;;; Deprecated FFI macros
349
350(define-macro (define-deprecated-macro old new)
351  `(define-macro (,old . args)
352     (warning (sprintf "`~s' is deprecated, use `~s' instead" ',old ',new))
353     (cons ',new args) ) )
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.