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

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

Changes for PCRE 7.4, use of compiled regexp in posix & utils units.

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-foreign-enum TYPE [USE-ALIASES] ENUM ...)
294;; TYPE : TYPENAME or (SCHEMENAME REALTYPE [DEFAULT-SCHEME-VALUE])
295;; USE-ALIAES : boolean, default #t
296;; ENUM : TYPENAME or (SCHEMENAME REALTYPE [SCHEME-VALUE])
297
298(define-macro (define-foreign-enum typespec . enums)
299  (let ([use-aliases (if (pair? enums)
300                         (let ([flag (car enums)])
301                           (if (boolean? flag)
302                               (begin (set! enums (cdr enums)) flag)
303                               #t ) )
304                         #t ) ] )
305    (let ((name typespec)
306          (type (->string typespec))
307          (defsymval ''())
308
309          (symbols (map (lambda (e) (if (pair? e) (car e) e)) enums))
310          (extvals (map (lambda (e)
311                          (if (pair? e)
312                              (if (pair? (cdr e))
313                                  (cadr e)
314                                  (syntax-error 'define-foreign-enum
315                                                "invalid enum specification" e) )
316                              e ) )
317                        enums))
318          (symvals (map (lambda (e)
319                          (if (pair? e)
320                              (if (pair? (cddr e))
321                                  (caddr e)
322                                  `(quote ,(car e)))
323                              `(quote ,e)))
324                        enums)) )
325      (when (list? typespec)
326        (let ([len (length typespec)])
327          (unless (<= 2 len 3)
328            (syntax-error 'define-foreign-enum "invalid type specification" typespec) )
329          (set! name (car typespec))
330          (set! type (cadr typespec))
331          (when (= 3 len)
332            (set! defsymval (caddr typespec)) ) ) )
333      (let ((aliases (if use-aliases (map gensym symbols) symbols))
334            (s->e (string->symbol (conc name "->number")))
335            (e->s (string->symbol (conc "number->" name)) ) )
336        `(begin
337           ,@(map (lambda (a v) `(define-foreign-variable ,a ,type ,(->string v))) aliases extvals)
338           (define (,s->e syms)
339             (let loop ((syms (if (symbol? syms) (list syms) syms)) (sum 0))
340               (if (null? syms)
341                   sum
342                   (loop (cdr syms)
343                         (bitwise-ior
344                          sum
345                          (let ((val (car syms)))
346                            (case val
347                              ,@(map (lambda (a s) `((,s) ,a)) aliases symbols)
348                              (else (error "not a member of enum" val ',name)) ) ) ) ) ) ) )
349           (define (,e->s val)
350             (cond
351              ,@(map (lambda (a sv) `((= val ,a) ,sv)) aliases symvals)
352              (else ,defsymval) ) )
353           (define-foreign-type ,name ,type ,s->e ,e->s) ) ) ) ) )
354
355
356;;; Deprecated FFI macros
357
358(define-macro (define-deprecated-macro old new)
359  `(define-macro (,old . args)
360     (warning (sprintf "`~s' is deprecated, use `~s' instead" ',old ',new))
361     (cons ',new args) ) )
362
363(define-deprecated-macro foreign-callback-lambda foreign-safe-lambda)
364(define-deprecated-macro foreign-callback-lambda* foreign-safe-lambda*)
365(define-deprecated-macro foreign-callback-wrapper foreign-safe-wrapper)
366
367
368;;; Not for general use, yet
369
370(define-macro (define-compiler-macro head . body)
371  (define (bad)
372    (syntax-error
373     'define-compiler-macro "invalid compiler macro definition" head) )
374  (if (and (pair? head) (symbol? (car head)))
375      (cond ((memq 'compiling ##sys#features)
376             (warning "compile macros are not available in interpreted code"
377                      (car head) ) )
378            ((not (##compiler#register-compiler-macro (car head) (cdr head) body))
379             (bad) ) )
380      (bad) )
381  '(void) )
Note: See TracBrowser for help on using the repository browser.