source: project/release/4/dollar/trunk/dollar.scm @ 13599

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

Save.

File size: 6.7 KB
Line 
1;;;; dollar.scm
2;;;; Kon Lovett, Mar '09
3;
4; Copyright (c) 2006, Felix L. Winkelmann
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; Send bugs, suggestions and ideas to:
28;
29; felix@call-with-current-continuation.org
30;
31; Felix L. Winkelmann
32; Unter den Gleichen 1
33; 37130 Gleichen
34; Germany
35
36(require-library srfi-4)
37
38;;; The dollar macro
39
40(module dollar ($)
41
42(import scheme chicken foreign)
43(import srfi-4)
44
45;;
46
47(define-syntax er-case
48  (lambda (form r c)
49    (##sys#check-syntax 'er-case form '(_ variable _ . #(_ 0)))
50    (let ((cmp (cadr form))
51          (exp (caddr form))
52          (body (cdddr form)))
53      (let ((tmp (r 'tmp))
54            (%begin (r 'begin))
55            (%if (r 'if))
56            (%or (r 'or))
57            (%else (r 'else)))
58        `(let ((,tmp ,exp))
59           ,(let expand ((clauses body))
60              (if (not (pair? clauses))
61                  '(void)
62                  (let ((clause (car clauses))
63                        (rclauses (cdr clauses)) )
64                    (##sys#check-syntax 'er-case clause '#(_ 1))
65                    (if (c %else (car clause))
66                        `(,%begin ,@(cdr clause))
67                        `(,%if (,%or ,@(map (lambda (x) `(,cmp ,tmp ,x)) (car clause)))
68                               (,%begin ,@(cdr clause)) 
69                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
70
71;;
72
73(define-syntax $
74  (lambda (form r c)
75    (##sys#check-syntax '$ form '(_ symbol . #(_ 0)))
76    (let (($quote (r 'quote))
77          ($location (r 'location))
78                                        ($void (r 'void))
79                                        ($bool (r 'bool))
80                                        ($char (r 'char))
81                                        ($int (r 'int))
82                                        ($double (r 'double))
83                                        ($symbol (r 'symbol))
84                                        ($scheme-object (r 'scheme-object))
85                                        ($nonnull-c-string (r 'nonnull-c-string))
86                                        ($nonnull-c-pointer (r 'nonnull-c-pointer))
87                                        ($nonnull-u8vector (r 'nonnull-u8vector))
88                                        ($nonnull-s8vector (r 'nonnull-s8vector))
89                                        ($nonnull-u16vector (r 'nonnull-u16vector))
90                                        ($nonnull-s16vector (r 'nonnull-s16vector))
91                                        ($nonnull-u32vector (r 'nonnull-u32vector))
92                                        ($nonnull-s32vector (r 'nonnull-s32vector))
93                                        ($nonnull-f32vector (r 'nonnull-f32vector))
94                                        ($nonnull-f64vector (r 'nonnull-f64vector))
95          ($foreign-code (r 'foreign-code))
96                                        ($foreign-value (r 'foreign-value))
97                                        ($foreign-lambda* (r 'foreign-lambda*)))
98    (define (unknown-type-error x)
99      (syntax-error '$ "argument is of unsupported type" x) )
100    (define (ensure-typed-atom val)
101      (cond ((fixnum? val)      `(,$int ,val))
102            ((number? val)      `(,$double ,val))
103            ((string? val)      `(,$nonnull-c-string ,val))
104            ((char? val)        `(,$char ,val))
105            ((boolean? val)     `(,$bool ,val))
106            ((null? val)        `(,$scheme-object ,val))
107            ((eof-object? val)  `(,$scheme-object ,val))
108            (else
109             (unknown-type-error val)) ) )
110    (define (pair|vector? x)
111      (or (pair? x) (vector? x)) )
112    (define (ensure-typed-arg arg)
113      (cond ((atom? arg)
114             (ensure-typed-atom arg))
115            ((list? arg)
116             (er-case c (car arg)
117               (($quote)
118                (if (pair? (cdr arg))
119                    (let ((val (cadr arg)))
120                      (cond ((symbol? val)      `(,$symbol ',val))
121                            ((u8vector? val)    `(,$nonnull-u8vector ',val))
122                            ((s8vector? val)    `(,$nonnull-s8vector ',val))
123                            ((u16vector? val)   `(,$nonnull-u16vector ',val))
124                            ((s16vector? val)   `(,$nonnull-s16vector ',val))
125                            ((u32vector? val)   `(,$nonnull-u32vector ',val))
126                            ((s32vector? val)   `(,$nonnull-s32vector ',val))
127                            ((f32vector? val)   `(,$nonnull-f32vector ',val))
128                            ((f64vector? val)   `(,$nonnull-f64vector ',val))
129                            ((pair|vector? val) `(,$scheme-object ',val))
130                            (else                (ensure-typed-atom val)) ) )
131                    arg))
132               (($location)
133                `(,$nonnull-c-pointer ,arg))
134               (else
135                (list (car arg) #;(r (car arg))
136                      (cadr arg)))))
137            (else
138             (unknown-type-error arg)) ) )
139    (let* ((func (cadr form))
140           (args (cddr form))
141           (rtype (cond ((and (pair? args) (symbol? (car args)))
142                         (let ((rtype func))
143                           (set! func (car args))
144                           (set! args (cdr args))
145                           rtype))
146                        (else
147                         $void)))
148           (cargs (map ensure-typed-arg args))
149           (fargs (map
150                   (lambda (_)
151                     (let ((sym (r (gensym 'arg))))
152                       (cons sym (symbol->string sym))))
153                   cargs)))
154      (if (null? cargs)
155          (if (c $void rtype) `(,$foreign-code ,(conc func "();"))
156              `(,$foreign-value ,(conc func "()") ,rtype))
157          `((,$foreign-lambda*
158             ,rtype
159             ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
160             ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
161                (conc (if (c $void rtype) body (string-append "C_return( " body ")")) #\;)))
162            ,@(map cadr cargs)) ) ) ) ) )
163
164) ;module dollar
Note: See TracBrowser for help on using the repository browser.