source: project/chicken/branches/hygienic/chicken-ffi-macros.scm @ 10788

Last change on this file since 10788 was 10788, checked in by felix winkelmann, 13 years ago
  • added remaining import libraries
  • csi uses srfi-69 now to avoid bootstrapping problem
  • csi: renamed "-se" to "-sx"
  • global assigns get variable name in comment in generated C code
  • import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy)
  • removed a lot of deprecated stuff
  • it really seems to work...
File size: 5.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 ##sys#chicken-ffi-macro-environment
29  (let ((me0 (##sys#macro-environment)))
30
31(##sys#extend-macro-environment
32 'define-external
33 '()
34 (##sys#er-transformer
35  (lambda (form r c)
36    (let* ((form (cdr form))
37           (%quote (r 'quote))
38           (quals (and (pair? form) (string? (car form))))
39           (var (and (not quals) (pair? form) (symbol? (car form)))) )
40      (cond [var
41             (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))
42             (let ([var (car form)])
43               `(,(r 'begin)
44                 (,(r 'define-foreign-variable) ,var ,(cadr form))
45                 (,(r 'define-external-variable) ,var ,(cadr form) #t)
46                 ,@(if (pair? (cddr form))
47                       `((##core#set! ,var ,(caddr form)))
48                       '() ) ) ) ]
49            [else
50             (if quals
51                 (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))
52                 (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )
53             (let* ([head (if quals (cadr form) (car form))]
54                    [args (cdr head)] )
55               `(,(r 'define) ,(car head)
56                 (##core#foreign-callback-wrapper
57                  ',(car head)
58                  ,(if quals (car form) "")
59                  ',(if quals (caddr form) (cadr form))
60                  ',(map (lambda (a) (car a)) args)
61                  (,(r 'lambda) 
62                   ,(map (lambda (a) (cadr a)) args)
63                   ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) ) ) )
64
65
66
67;;; External locations:
68
69(##sys#extend-macro-environment
70 'define-location
71 '()
72 (##sys#er-transformer
73  (lambda (form r c)
74    (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
75    (let ((var (cadr form))
76          (type (caddr form))
77          (init (optional (cdddr form) #f))
78          (name (r (gensym))))
79      `(,(r 'begin)
80        (,(r 'define-foreign-variable) ,var ,type ,(symbol->string name))
81        (,(r 'define-external-variable) ,var ,type #f ,name)
82        ,@(if (pair? init)
83              `((##core#set! ,var ,(car init)))
84              '() ) ) ) ) ) )
85
86(##sys#extend-macro-environment
87 'let-location
88 '()
89 (##sys#er-transformer
90  (lambda (form r c)
91    (##sys#check-syntax 'let-location form '(_ #((variable _ . #(_ 0 1)) 0) . _))
92    (let* ((bindings (cadr form))
93           (body (cddr form))
94           (%let (r 'let))
95           [aliases (map (lambda (_) (r (gensym))) bindings)])
96      `(,%let ,(append-map
97                (lambda (b a)
98                  (if (pair? (cddr b))
99                      (list (cons a (cddr b)))
100                      '() ) )
101                bindings aliases)
102              ,(fold-right
103                (lambda (b a rest)
104                  (if (= 3 (length b))
105                      `(##core#let-location
106                        ,(car b)
107                        ,(cadr b)
108                        ,a
109                        ,rest)
110                      `(##core#let-location
111                        ,(car b)
112                        ,(cadr b)
113                        ,rest) ) )
114                `(,%let () ,@body)
115                bindings aliases) ) ) ) ) )
116
117
118;;; Embedding code directly:
119
120(##sys#extend-macro-environment
121 'foreign-code
122 '()
123 (##sys#er-transformer
124  (lambda (form r c)
125    (##sys#check-syntax 'foreign-code form '(_ . #(string 0)))
126    (let ([tmp (gensym 'code_)])
127      `(,(r 'begin)
128         (,(r 'declare)
129          (foreign-declare
130           ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n" 
131                     tmp
132                     (string-intersperse (cdr form) "\n")) ) )
133         (##core#inline ,tmp) ) ) ) ) )
134
135(##sys#extend-macro-environment
136 'foreign-value
137 '()
138 (##sys#er-transformer
139  (lambda (form r c)
140    (##sys#check-syntax 'foreign-value form '(_ string _))
141    (let ([tmp (gensym 'code_)])
142      `(,(r 'begin)
143        (,(r 'define-foreign-variable) ,tmp ,(caddr form) ,(cadr form))
144        ,tmp) ) ) ) )
145
146
147;;; Include/parse foreign code fragments
148
149(##sys#extend-macro-environment
150 'foreign-declare
151 '()
152 (##sys#er-transformer
153  (lambda (form r c)
154    (##sys#check-syntax 'foreign-declare form '(_ . #(string 0)))
155    `(##core#declare (foreign-declare ,@(cdr form))))))
156
157
158;;; Not for general use, yet
159
160(##sys#extend-macro-environment
161 'define-compiler-macro
162 '()
163 (##sys#er-transformer
164  (lambda (form r c)
165    (##sys#check-syntax 'define-compiler-macro form '(_ . _))
166    (let ((head (cadr form))
167          (body (cddr form)))
168      (define (bad)
169        (syntax-error
170         'define-compiler-macro "invalid compiler macro definition" head) )
171      (if (and (pair? head) (symbol? (car head)))
172          (cond ((memq 'compiling ##sys#features)
173                 (warning "compile macros are not available in interpreted code"
174                          (car head) ) )
175                ((not (##compiler#register-compiler-macro (car head) (cdr head) body))
176                 (bad) ) )
177          (bad) )
178      '(##core#undefined) ) ) ) )
179
180(##sys#macro-subset me0)))
Note: See TracBrowser for help on using the repository browser.