source: project/syntactic-closures/syntactic-closures-chicken-macros.scm @ 4598

Last change on this file since 4598 was 4598, checked in by Jim Ursetto, 13 years ago

syntactic-closures: add rsc-macro-transfomer, update to 0.982

File size: 16.9 KB
Line 
1;;;; syntactic-closures-chicken-macros.scm
2
3
4(define-syntax define-macro
5  (syntax-rules ()
6    ((_ (id . llist) . body) 
7     (define-syntax id
8       (rsc-macro-transformer 
9        (lambda (exp env)
10          (apply (lambda llist . body) (cdr exp)) ) ) ) )
11    ((_ id expander) 
12     (define-syntax id
13       (rsc-macro-transformer 
14        (lambda (exp env)
15          (apply expander (cdr exp)) ) ) ) ) ) )
16
17(define-macro (cond-expand . clauses)
18  (define (err x) 
19    (syntax-error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
20  (define (test fx)
21    (cond ((symbol? fx) (##sys#feature? fx))
22          ((not (pair? fx)) (err fx))
23          (else
24           (let ((rest (##sys#slot fx 1)))
25             (case (##sys#slot fx 0)
26               ((and)
27                (or (eq? rest '())
28                    (if (pair? rest)
29                        (and (test (##sys#slot rest 0))
30                             (test `(and ,@(##sys#slot rest 1))) )
31                        (err fx) ) ) )
32               ((or) 
33                (and (not (eq? rest '()))
34                     (if (pair? rest)
35                         (or (test (##sys#slot rest 0))
36                             (test `(or ,@(##sys#slot rest 1))) )
37                         (err fx) ) ) )
38               ((not) (not (test (cadr fx))))
39               (else (err fx)) ) ) ) ) )
40  (let expand ((cls clauses))
41    (cond ((eq? cls '())
42           (##sys#apply
43            ##sys#error "no matching clause in `cond-expand' form" 
44            (map (lambda (x) (car x)) clauses) ) )
45          ((not (pair? cls)) (err cls))
46          (else
47           (let ((clause (##sys#slot cls 0))
48                 (rclauses (##sys#slot cls 1)) )
49             (if (not (pair? clause)) 
50                 (err clause)
51                 (let ((id (##sys#slot clause 0)))
52                   (cond ((eq? id 'else)
53                          (let ((rest (##sys#slot clause 1)))
54                            (if (eq? rest '())
55                                '(##core#undefined)
56                                `(begin ,@rest) ) ) )
57                         ((test id) `(begin ,@(##sys#slot clause 1)))
58                         (else (expand rclauses)) ) ) ) ) ) ) ) )
59
60(define-macro (include filename)
61  (let ((path (##sys#resolve-include-filename filename #t)))
62    (when (load-verbose) (print "; including " path " ..."))
63    `(begin
64       ,@(with-input-from-file path
65           (lambda ()
66             (do ([x (read) (read)]
67                  [xs '() (cons x xs)] )
68                 ((eof-object? x) 
69                  (reverse xs))) ) ) ) ) )
70 
71(define-syntax receive
72  (syntax-rules ()
73    [(_ vars) (##sys#call-with-values (lambda () vars) ##sys#list)]
74    [(_ vars x0 x1 x2 ...)
75     (##sys#call-with-values
76      (lambda () x0)
77      (lambda vars x1 x2 ...) ) ] ) )
78
79(define-syntax time
80  (syntax-rules ()
81    ((_ exp ...)
82     (begin
83       (##sys#start-timer)
84       (##sys#call-with-values
85        (lambda () exp ...)
86        (lambda tmp
87          (##sys#display-times (##sys#stop-timer))
88          (##sys#apply ##sys#values tmp) ) ) ) ) ) )
89
90(define-syntax assert
91  (syntax-rules ()
92    [(_ exp)
93     (assert exp (##core#immutable '"assertion failed")) ]
94    [(_ exp msg arg1 ...)
95     (if (##core#check exp)
96         (##core#undefined)
97         (##sys#error msg 'exp arg1 ...) ) ] ) )
98
99(define-syntax ensure
100  (syntax-rules ()
101    [(_ pred exp)
102     (let ([tmp exp])
103       (if (##core#check (pred tmp))
104           tmp
105           (##sys#error (##core#immutable '"argument has incorrect type") tmp 'pred))) ]
106    [(_ pred exp arg1 arg2 ...)
107     (let ((tmp exp))
108       (if (##core#check (pred tmp))
109           tmp
110           (##sys#error arg1 arg2 ...))) ] ) )
111
112(define-syntax case-lambda              ; (reference implementation)
113  (syntax-rules ()
114      ((case-lambda 
115        (?a1 ?e1 ...) 
116        ?clause1 ...)
117       (lambda args
118         (let ((l (length args)))
119           (case-lambda "CLAUSE" args l 
120                        (?a1 ?e1 ...)
121                        ?clause1 ...))))
122      ((case-lambda "CLAUSE" ?args ?l 
123                    ((?a1 ...) ?e1 ...) 
124                    ?clause1 ...)
125       (if (eq? ?l (length '(?a1 ...)))
126           (##sys#apply (lambda (?a1 ...) ?e1 ...) ?args)
127           (case-lambda "CLAUSE" ?args ?l 
128                        ?clause1 ...)))
129      ((case-lambda "CLAUSE" ?args ?l
130                    ((?a1 . ?ar) ?e1 ...) 
131                    ?clause1 ...)
132       (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) 
133                    ?clause1 ...))
134      ((case-lambda "CLAUSE" ?args ?l 
135                    (?a1 ?e1 ...)
136                    ?clause1 ...)
137       (let ((?a1 ?args))
138         ?e1 ...))
139      ((case-lambda "CLAUSE" ?args ?l)
140       (##core#check (##sys#error (##core#immutable '"wrong number of arguments to CASE-LAMBDA."))))
141      ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
142                    ?clause1 ...)
143       (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) 
144                    ?clause1 ...))
145      ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) 
146                    ?clause1 ...)
147       (if (fx>= ?l ?k)
148           (##sys#apply (lambda ?al ?e1 ...) ?args)
149           (case-lambda "CLAUSE" ?args ?l 
150                        ?clause1 ...)))))
151
152(define-syntax and-let*
153   (syntax-rules ()
154      ((and-let* () body ...)
155       (begin body ...))
156
157      ((and-let* ((var expr) clauses ...) body ...)
158       (let ((var expr))
159          (if var (and-let* (clauses ...) body ...) #f)))
160
161      ((and-let* ((expr) clauses ...) body ...)
162       (if expr (and-let* (clauses ...) body ...) #f))
163     
164      ((and-let* (var clauses ...) body ...)
165       (if var (and-let* (clauses ...) body ...) #f))))
166
167(define-syntax when
168  (syntax-rules ()
169    [(_ x y z ...) (if x (begin y z ...))] ) )
170
171(define-syntax unless
172  (syntax-rules ()
173    [(_ x y z ...) (if x (##core#undefined) (begin y z ...))] ) )
174
175(define-syntax let*-values
176  (syntax-rules ()
177    [(_ () exp1 ...) (let () exp1 ...)]
178    [(_ (binding0 binding1 ...) exp0 exp1 ...)
179     (let-values (binding0)
180       (let*-values (binding1 ...) exp0 exp1 ...) ) ] ) )
181
182(define-syntax let-values
183  (syntax-rules ()
184    ((let-values (?binding ...) ?body0 ?body1 ...)
185     (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
186   
187    ((let-values "bind" () ?tmps ?body)
188     (let ?tmps ?body))
189   
190    ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
191     (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
192   
193    ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
194     (call-with-values
195       (lambda () ?e0)
196       (lambda ?args
197         (let-values "bind" ?bindings ?tmps ?body))))
198   
199    ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
200     (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
201   
202    ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
203     (call-with-values
204       (lambda () ?e0)
205       (lambda (?arg ... . x)
206         (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
207
208(define-syntax switch
209  (syntax-rules (else)
210    ((_ v (else e1 e2 ...))
211     (begin e1 e2 ...))
212    ((_ v (k e1 e2 ...))
213     (let ((x v))
214       (if (eqv? x k) (begin e1 e2 ...)) ) )
215    ((_ v (k e1 e2 ...) c1 c2 ...)
216     (let ((x v))
217       (if (eqv? x k)
218           (begin e1 e2 ...)
219           (switch x c1 c2 ...))))))
220
221(define-syntax optional
222  (syntax-rules ()
223    [(_ rest default)
224     (let ((tmp rest))
225       (cond ((null? tmp) default)
226             ((null? (cdr tmp)) (car tmp))
227             (else (##core#check (##sys#error (##core#immutable '"too many optional arguments") tmp)) ) ) ) ] ) )
228
229(define-syntax :optional                ; DEPRECATED
230  (syntax-rules ()
231    ((_ . rest) (optional . rest))))
232
233(define-syntax let-optionals*
234  (syntax-rules ()
235    [(_ rest () body ...) (let () body ...)]
236    [(_ rest ((var default) . more) body ...)
237     (let* ((tmp rest)
238            (var (if (null? tmp) default (car tmp)))
239            (rest2 (if (null? tmp) '() (cdr tmp))) )
240       (let-optionals* rest2 more body ...) ) ]
241    [(_ rest (var) body ...) (let ((var rest)) body ...)] ) )
242
243;; Just generates temp variables for let-optionals*
244;; then binds them in one application, faster than
245;; Shiver's let-optionals.
246
247(define-syntax let-optionals
248 (syntax-rules ()
249   ((let-optionals ("step") rest (tmps ...) ((var default) . vars) body)
250    (let-optionals ("step") rest (tmps ... (var tmp default)) vars body))
251   ((let-optionals ("step") rest ((var tmp default) ...) () body)
252    (let-optionals* rest ((tmp default) ...)
253      (let ((var tmp) ...)
254        body)))
255   ((let-optionals rest vars body ...)
256    (let-optionals ("step") rest () vars (begin body ...)))
257   ))
258
259(define-syntax define-inline
260  (syntax-rules ()
261    [(_ head . body)
262     (define head . body)] ) )
263
264(define-syntax define-constant
265  (syntax-rules ()
266    [(_ name val) (define name val)] ) )
267
268(define-syntax critical-section
269  (syntax-rules () 
270    [(_ body ...)
271     (##sys#dynamic-wind
272         ##sys#disable-interrupts
273         (lambda () body ...)
274         ##sys#enable-interrupts) ] ) )
275
276(define-syntax nth-value
277  (syntax-rules ()
278    [(_ i exp)
279     (##sys#call-with-values
280      (lambda () exp)
281      (lambda lst (list-ref lst i)) ) ] ) )
282
283(define-syntax define-record-printer
284  (syntax-rules ()
285    [(_ (name var1 var2) body ...)
286     (##sys#register-record-printer 'name (lambda (var1 var2) body ...)) ]
287    [(_ name proc) (##sys#register-record-printer 'name proc)] ) )
288
289(define-syntax handle-exceptions
290  (syntax-rules ()
291    ((_ var handle-body e1 e2 ...)     
292     ((call-with-current-continuation
293       (lambda (k)
294         (with-exception-handler 
295          (lambda (var) (k (lambda () handle-body)))
296          (lambda ()
297            (##sys#call-with-values 
298             (lambda () e1 e2 ...)
299             (lambda args (k (lambda () (##sys#apply ##sys#values args)))))))))))))
300
301(define-syntax condition-case
302  (syntax-rules ()
303    [(_ "1" exvar kvar) (##sys#signal exvar)]
304    [(_ "1" exvar kvar (() body ...) . more) (let () body ...)]
305    [(_ "1" exvar kvar (var () body ...) . more) (let ([var exvar]) body ...)]
306    [(_ "1" exvar kvar ((kind ...) body ...) . more)
307     (if (and kvar (memv 'kind kvar) ...)
308         (let () body ...)
309         (condition-case "1" exvar kvar . more) ) ]
310    [(_ "1" exvar kvar (var (kind ...) body ...) . more)
311     (if (and kvar (memv 'kind kvar) ...)
312         (let ([var exvar]) body ...)
313         (condition-case "1" exvar kvar . more) ) ]
314    [(_ exp clauses ...)
315     (handle-exceptions exvar
316         (let ([kvar (and (##sys#structure? exvar 'condition) (##sys#slot exvar 1))])
317           (condition-case "1" exvar kvar clauses ...) )
318       exp) ] ) )
319
320(define-syntax define-class
321  (syntax-rules ()
322    [(_ name () slots)
323     (define-class name (<object>) slots) ]
324    [(_ name supers slots)
325     (define-class name supers slots <class>) ]
326    [(_ name () slots meta)
327     (define-class name (<object>) slots meta) ]
328    [(_ cname (supers ...) (slots ...) meta)
329     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )
330
331(define-syntax define-generic
332  (syntax-rules () 
333    [(_ n class) (define n (make class 'name 'n))]
334    [(_ n) (define n (make-generic 'n))] ) )
335
336(define-syntax require-for-syntax
337  (syntax-rules ()
338    [(_ names ...) 
339     (##core#require-for-syntax names ...) ] ) )
340
341(define-syntax require-extension
342  (syntax-rules ()
343    [(_ names ...) (##core#require-extension 'names ...) ] ) )
344
345(define-syntax use require-extension)
346
347(define-syntax cut
348  (syntax-rules (<> <...>)
349
350    ;; construct fixed- or variable-arity procedure:
351    ;;   (begin proc) throws an error if proc is not an <expression>
352    ((_ "1" (slot-name ...) (proc arg ...))
353     (lambda (slot-name ...) ((begin proc) arg ...)))
354    ((_ "1" (slot-name ...) (proc arg ...) <...>)
355     (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
356
357    ;; process one slot-or-expr
358    ((_ "1" (slot-name ...)   (position ...)      <>  . se)
359     (cut "1" (slot-name ... x) (position ... x)        . se))
360    ((_ "1" (slot-name ...)   (position ...)      nse . se)
361     (cut "1" (slot-name ...)   (position ... nse)      . se))
362
363    ((_ . slots-or-exprs)
364     (cut "1" () () . slots-or-exprs))) )
365
366(define-syntax cute
367  (syntax-rules (<> <...>)
368
369    ;; If there are no slot-or-exprs to process, then:
370    ;; construct a fixed-arity procedure,
371    ((_ "1"
372      (slot-name ...) nse-bindings (proc arg ...))
373     (let nse-bindings (lambda (slot-name ...) (proc arg ...))))
374    ;; or a variable-arity procedure
375    ((_ "1"
376      (slot-name ...) nse-bindings (proc arg ...) <...>)
377     (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x))))
378
379    ;; otherwise, process one slot:
380    ((_ "1"
381      (slot-name ...)         nse-bindings  (position ...)   <>  . se)
382     (cute "1"
383      (slot-name ... x)       nse-bindings  (position ... x)     . se))
384    ;; or one non-slot expression
385    ((_ "1"
386      slot-names              nse-bindings  (position ...)   nse . se)
387     (cute "1"
388      slot-names ((x nse) . nse-bindings) (position ... x)       . se))
389
390    ((cute . slots-or-exprs)
391     (cute "1" () () () . slots-or-exprs))))
392
393(define-syntax let-string-start+end
394  (syntax-rules ()
395    ((let-string-start+end (start end) proc s-exp args-exp body ...)
396     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
397       body ...))
398    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
399     (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
400       body ...))))
401
402(define-syntax rec
403  (syntax-rules ()
404    ((rec (NAME . VARIABLES) . BODY)
405     (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
406    ((rec NAME EXPRESSION)
407     (letrec ( (NAME EXPRESSION) ) NAME))))
408
409(define-macro (define-record name . slots)
410  (##sys#check-syntax 'define-record name 'symbol)
411  (##sys#check-syntax 'define-record slots '#(symbol 0))
412  (let ([prefix (symbol->string name)]
413        [setters (memq #:record-setters ##sys#features)]
414        [nsprefix (##sys#qualified-symbol-prefix name)] )
415    `(begin
416       (define ,(##sys#string->qualified-symbol nsprefix (string-append "make-" prefix))
417         (lambda ,slots (##sys#make-structure ',name ,@slots)) )
418       (define ,(##sys#string->qualified-symbol nsprefix (string-append prefix "?"))
419         (lambda (x) (##sys#structure? x ',name)) )
420       ,@(let mapslots ((slots slots) (i 1))
421           (if (eq? slots '())
422               slots
423               (let* ((slotname (symbol->string (##sys#slot slots 0)))
424                      (setr (##sys#string->qualified-symbol nsprefix (string-append prefix "-" slotname "-set!")))
425                      (getr (##sys#string->qualified-symbol nsprefix (string-append prefix "-" slotname)) ) )
426                 (cons
427                  `(begin
428                     (define ,setr
429                       (lambda (x val)
430                         (##core#check (##sys#check-structure x ',name))
431                         (##sys#block-set! x ,i val) ) )
432                     (define ,getr
433                       ,(if setters
434                            `(getter-with-setter
435                              (lambda (x) 
436                                (##core#check (##sys#check-structure x ',name))
437                                (##sys#block-ref x ,i) )
438                              ,setr)
439                            `(lambda (x)
440                               (##core#check (##sys#check-structure x ',name))
441                               (##sys#block-ref x ,i) ) ) ) )
442                  (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) )
443
444(define-macro (define-record-type t conser pred . slots)
445  (let ([vars (cdr conser)]
446        [slotnames (map car slots)] )
447    `(begin
448       (define ,conser
449         (##sys#make-structure 
450          ',t 
451          ,@(map (lambda (sname)
452                   (if (memq sname vars)
453                       sname
454                       '(##sys#void) ) )
455                 slotnames) ) )
456       (define (,pred x) (##sys#structure? x ',t))
457       ,@(let loop ([slots slots] [i 1])
458           (if (null? slots)
459               '()
460               (let* ([slot (car slots)]
461                      (setters (memq #:record-setters ##sys#features))
462                      (setr? (pair? (cddr slot))) 
463                      (getr `(lambda (x)
464                               (##core#check (##sys#check-structure x ',t))
465                               (##sys#block-ref x ,i) ) ) )
466                 `(,@(if setr?
467                         `((define (,(caddr slot) x y)
468                             (##core#check (##sys#check-structure x ',t))
469                             (##sys#block-set! x ,i y)) )
470                         '() )
471                   (define ,(cadr slot) 
472                     ,(if (and setr? setters)
473                          `(getter-with-setter ,getr ,(caddr slot))
474                          getr) )
475                   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
476
477(define-macro (define-extension name . clauses)
478  (let loop ((s '()) (d '()) (cs clauses) (exports #f))
479    (cond ((null? cs)
480           (let ((exps (if exports `(declare (export ,@exports)) '(begin))))
481             `(cond-expand
482               (chicken-compile-shared ,exps ,@d)
483               ((not compiling) ,@d)
484               (else
485                (declare (unit ,name))
486                ,exps
487                (provide ',name) 
488                ,@s) ) ) )
489          ((and (pair? cs) (pair? (car cs)))
490           (let ((t (caar cs))
491                 (next (cdr cs)) )
492             (cond ((eq? 'static t) (loop (cons `(begin ,@(cdar cs)) s) d next exports))
493                   ((eq? 'dynamic t) (loop s (cons `(begin ,@(cdar cs)) d) next exports))
494                   ((eq? 'export t) (loop s d next (append (or exports '()) (cdar cs))))
495                   (else (syntax-error 'define-extension "invalid clause specifier" (caar cs))) ) ) )
496          (else (syntax-error 'define-extension "invalid clause syntax" cs)) ) ) )
497
498(define-macro (define-for-syntax head . body)
499  (let* ((body (if (null? body) '((void)) body))
500         (name (if (pair? head) (car head) head)) 
501         (body (if (pair? head) `(lambda ,(cdr head) ,@body) (car body))))
502    (if (symbol? name)
503        (##sys#setslot name 0 (eval body))
504        (syntax-error 'define-for-syntax "invalid identifier" name) )
505    (if ##sys#enable-runtime-macros
506        `(define ,name ,body)
507        '(begin) ) ) )
508
509(define-syntax fluid-let
510  (syntax-rules ()
511    ((_ ((v1 e1) ...) b1 b2 ...)
512     (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
513    ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
514     (let ((temp e1))
515       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
516    ((_ "temps" ((t e v) ...) () b1 b2 ...)
517     (let-syntax ((swap!
518                   (syntax-rules ()
519                     ((swap! a b)
520                      (let ((tmp a))
521                        (set! a b)
522                        (set! b tmp))))))
523       (dynamic-wind
524        (lambda ()
525          (swap! t v) ...)
526        (lambda ()
527          b1 b2 ...)
528        (lambda ()
529          (swap! t v) ...))))))
Note: See TracBrowser for help on using the repository browser.