source: project/release/4/dollar/tags/2.0.0/dollar.scm @ 13843

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

Seems to work, at least w/ macosx egg.

File size: 6.9 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 srfi-4)
43
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
99    (define (unknown-type-error x)
100      (syntax-error '$ "bad argument type - unsupported" x) )
101
102    (define (ensure-typed-atom val)
103      (cond ((fixnum? val)      `(,$int ,val))
104            ((number? val)      `(,$double ,val))
105            ((string? val)      `(,$nonnull-c-string ,val))
106            ((char? val)        `(,$char ,val))
107            ((boolean? val)     `(,$bool ,val))
108            ((null? val)        `(,$scheme-object ,val))
109            ((eof-object? val)  `(,$scheme-object ,val))
110            (else
111             (unknown-type-error val)) ) )
112
113    (define (pair|vector? x)
114      (or (pair? x) (vector? x)) )
115
116    (define (ensure-typed-arg arg)
117      (cond ((atom? arg) (ensure-typed-atom arg))
118            ((list? arg)
119             (let ((typ (car arg)))
120               (cond ((c $quote typ)
121                      (if (not (pair? (cdr arg))) arg
122                          (let ((val (cadr arg)))
123                            (cond ((symbol? val)      `(,$symbol ',val))
124                                  ((u8vector? val)    `(,$nonnull-u8vector ',val))
125                                  ((s8vector? val)    `(,$nonnull-s8vector ',val))
126                                  ((u16vector? val)   `(,$nonnull-u16vector ',val))
127                                  ((s16vector? val)   `(,$nonnull-s16vector ',val))
128                                  ((u32vector? val)   `(,$nonnull-u32vector ',val))
129                                  ((s32vector? val)   `(,$nonnull-s32vector ',val))
130                                  ((f32vector? val)   `(,$nonnull-f32vector ',val))
131                                  ((f64vector? val)   `(,$nonnull-f64vector ',val))
132                                  ((pair|vector? val) `(,$scheme-object ',val))
133                                  (else                (ensure-typed-atom val) ) ) ) ) )
134                     ((c $location typ) `(,$nonnull-c-pointer ,arg))
135                     ((not (pair? (cdr arg))) (ensure-typed-atom arg))
136                     (else (list (r typ) (cadr arg)) ) ) ) )
137            (else
138             (unknown-type-error arg) ) ) )
139
140    (define (genarg _)
141      (let ((sym (r (gensym 'arg))))
142        (cons sym (symbol->string sym)) ) )
143
144    ; Note - `rtype' is NOT renamed!
145    (let* ((func (cadr form))
146           (args (cddr form))
147           (rtype (cond ((and (pair? args) (symbol? (car args)))
148                         (let ((rtype func))
149                           (set! func (car args))
150                           (set! args (cdr args))
151                           rtype))
152                        (else $void)))
153           (cargs (map ensure-typed-arg args))
154           (fargs (map genarg cargs) ) )
155      (cond ((not (null? cargs))
156             `((,$foreign-lambda*
157                ,rtype
158                ,(map (lambda (carg farg) (list (r (car carg)) (car farg))) cargs fargs)
159                ,(let ((body (conc func #\( (string-intersperse (map cdr fargs) ",") #\))))
160                   (conc (if (c $void rtype) body (string-append "return(" body ")")) #\;)))
161               ,@(map cadr cargs)) )
162            ((c $void rtype)
163             `(,$foreign-code ,(conc func #\( #\) #\;) ,rtype))
164            (else
165             `(,$foreign-value ,(conc func #\( #\)) ,rtype) ) ) ) ) ) )
166
167) ;module dollar
Note: See TracBrowser for help on using the repository browser.