source: project/chicken/trunk/chicken-ffi-syntax.scm @ 15164

Last change on this file since 15164 was 15164, checked in by Kon Lovett, 11 years ago

chicken-ffi-syntax : foreign-value macro used C-code as return type. expand - temp fix for call of undefined proc.

File size: 5.2 KB
Line 
1;;;; chicken-ffi-syntax.scm
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, 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 '(_ _ _))
141    (let ((tmp (gensym 'code_))
142          (code (cadr form)))
143      `(,(r 'begin)
144        (,(r 'define-foreign-variable) ,tmp
145         ,(cond ((string? code) code)
146                ((symbol? code) (symbol->string code))
147                (else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code)))
148         ,(caddr form))
149        ,tmp) ) ) ) )
150
151
152;;; Include/parse foreign code fragments
153
154(##sys#extend-macro-environment
155 'foreign-declare
156 '()
157 (##sys#er-transformer
158  (lambda (form r c)
159    (##sys#check-syntax 'foreign-declare form '(_ . #(string 0)))
160    `(##core#declare (foreign-declare ,@(cdr form))))))
161
162
163(##sys#macro-subset me0)))
Note: See TracBrowser for help on using the repository browser.