source: project/chicken/branches/hygienic/chicken-more-macros.scm @ 10753

Last change on this file since 10753 was 10753, checked in by felix winkelmann, 13 years ago

chicken import lib, trivial fixes, foreign import lib (untested)

File size: 32.6 KB
Line 
1;;;; chicken-more-macros.scm - More syntax extensions
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(##sys#provide 'chicken-more-macros)
29
30(define ##sys#me-0 (##sys#macro-environment))
31
32
33;;; Non-standard macros:
34
35(##sys#extend-macro-environment
36 'receive
37 '()
38 (##sys#er-transformer
39 (lambda (form r c)
40   (let ((%lambda (r 'lambda))
41         (%let (r 'let)))
42     (##sys#check-syntax 'receive form '(_ _ . #(_ 0)))
43     (cond ((null? (cddr form))
44            `(##sys#call-with-values (,%lambda () ,@(cdr form)) ##sys#list) )
45           (else
46            (##sys#check-syntax 'receive form '(_ lambda-list _ . #(_ 1)))
47            (let ((vars (cadr form))
48                  (exp (caddr form))
49                  (rest (cdddr form)))
50              (if (and (pair? vars) (null? (cdr vars)))
51                  `(,%let ((,(car vars) ,exp)) ,@rest)
52                  `(##sys#call-with-values 
53                    (,%lambda () ,exp)
54                    (,%lambda ,vars ,@rest)) ) ) ) ) ))))
55
56(##sys#extend-macro-environment
57 'time '()
58 (##sys#er-transformer
59 (lambda (form r c)
60   (let ((rvar (r 't))
61         (%begin (r 'begin))
62         (%lambda (r 'lambda)))
63    `(,%begin
64       (##sys#start-timer)
65       (##sys#call-with-values 
66        (,%lambda () ,@(cdr form))
67        (,%lambda ,rvar
68                  (##sys#display-times (##sys#stop-timer))
69                  (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
70
71(##sys#extend-macro-environment
72 'declare '()
73 (##sys#er-transformer
74 (lambda (form r c)
75   `(##core#declare ,@(cdr form)))))
76
77(##sys#extend-macro-environment
78 'include '()
79 (##sys#er-transformer
80 (lambda (form r c)
81   (##sys#check-syntax 'include form '(_ string))
82   (let ((path (##sys#resolve-include-filename (cadr form) #t))
83         (%begin (r 'begin)))
84     (when (load-verbose) (print "; including " path " ..."))
85     `(,%begin
86       ,@(with-input-from-file path
87           (lambda ()
88             (fluid-let ((##sys#current-source-filename path))
89               (do ([x (read) (read)]
90                    [xs '() (cons x xs)] )
91                   ((eof-object? x) 
92                    (reverse xs))) ) ) ) ) ) ) ) )
93
94(##sys#extend-macro-environment
95 'assert '()
96 (##sys#er-transformer
97 (lambda (form r c)
98   (##sys#check-syntax 'assert form '#(_ 1))
99   (let* ((exp (cadr form))
100          (msg-and-args (cddr form))
101          (%if (r 'if))
102          (%quote (r 'quote))
103          (msg (if (eq? '() msg-and-args)
104                   `(##core#immutable '"assertion failed")
105                   (car msg-and-args) ) ) )
106     `(,%if (##core#check ,exp)
107            (##core#undefined)
108            (##sys#error 
109             ,msg 
110             (,%quote ,exp)
111             ,@(if (fx> (length msg-and-args) 1)
112                   (cdr msg-and-args)
113                   '() ) ) ) ) )) )
114
115(##sys#extend-macro-environment
116 'ensure
117 '()
118 (##sys#er-transformer
119  (lambda (form r c)
120    (##sys#check-syntax 'ensure form '#(_ 3))
121    (let ((pred (cadr form))
122          (exp (caddr form))
123          (args (cdddr form))
124          (tmp (r 'tmp))
125          (%let (r 'let))
126          (%if (r 'if)) )
127      `(,%let ([,tmp ,exp])
128              (,%if (##core#check (,pred ,tmp))
129                    ,tmp
130                    (##sys#signal-hook
131                     #:type-error
132                     ,@(if (pair? args)
133                           args
134                           `((##core#immutable '"argument has incorrect type")
135                             ,tmp ',pred) ) ) ) ) ) ) ) )
136
137(##sys#extend-macro-environment
138 'fluid-let '()
139 (##sys#er-transformer
140  (lambda (form r c)
141    (##sys#check-syntax 'fluid-let form '(_ #((symbol _) 0) . _))
142     (let* ((clauses (cadr form))
143           (body (cddr form))
144           (ids (##sys#map car clauses))
145           (new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
146           (old-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
147           (%let (r 'let))
148           (%lambda (r 'lambda)))
149       `(,%let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
150                ,@(map ##sys#list old-tmps
151                       (let loop ((n (length clauses)))
152                         (if (eq? n 0)
153                             '()
154                             (cons #f (loop (fx- n 1))) ) ) ) )
155               (##sys#dynamic-wind
156                (,%lambda ()
157                          ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
158                                 old-tmps ids)
159                          ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
160                                 ids new-tmps)
161                          (##core#undefined) )
162                (,%lambda () ,@body)
163                (,%lambda ()
164                          ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
165                                 new-tmps ids)
166                          ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
167                                 ids old-tmps)
168                          (##core#undefined) ) ) ) ) )))
169
170(##sys#extend-macro-environment
171 'eval-when '()
172 (##sys#er-transformer
173  (lambda (form r c)
174    (##sys#check-syntax 'eval-when form '#(_ 2))
175    (let* ((situations (cadr form))
176           (%begin (r 'begin))
177           (body `(,%begin ,@(cddr form)))
178           (%eval (r 'eval))
179           (%compile (r 'compile))
180           (%load (r 'load))
181           (e #f)
182           (co #f)
183           (l #f))
184      (let loop ([ss situations])
185        (if (pair? ss)
186            (let ((s (car ss)))
187              (cond ((c s %eval) (set! e #t))
188                    ((c s %load) (set! l #t))
189                    ((c s %compile) (set! co #t))
190                    (else (##sys#error "invalid situation specifier" (car ss)) ))
191              (loop (##sys#slot ss 1)) ) ) )
192      (if (memq '#:compiling ##sys#features)
193          (cond [(and co l) `(##core#compiletimetoo ,body)]
194                [co `(##core#compiletimeonly ,body)]
195                [l body]
196                [else '(##core#undefined)] )
197          (if e 
198              body
199              '(##core#undefined) ) ) ) ) ) )
200
201(##sys#extend-macro-environment
202 'parameterize '()
203 (##sys#er-transformer
204  (lambda (form r c)
205    (##sys#check-syntax 'parameterize form '#(_ 2))
206     (let* ((bindings (cadr form))
207            (body (cddr form))
208            (swap (r 'swap))
209            (%let (r 'let))
210            (%lambda (r 'lambda))
211            [params (##sys#map car bindings)]
212            [vals (##sys#map cadr bindings)]
213            [aliases (##sys#map (lambda (z) (r (gensym))) params)]
214            [aliases2 (##sys#map (lambda (z) (r (gensym))) params)] )
215       `(,%let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
216          (,%let ((,swap (,%lambda ()
217                                   ,@(map (lambda (a a2)
218                                            `(,%let ((t (,a))) (,a ,a2)
219                                                    (##core#set! ,a2 t)))
220                                          aliases aliases2) ) ) )
221                 (##sys#dynamic-wind 
222                  ,swap
223                  (,%lambda () ,@body)
224                  ,swap) ) ) ) )))
225
226(##sys#extend-macro-environment
227 'when '()
228 (##sys#er-transformer
229  (lambda (form r c)
230    (##sys#check-syntax 'when form '#(_ 2))
231    `(,(r 'if) ,(cadr form)
232      (,(r 'begin) ,@(cddr form))))))
233
234(##sys#extend-macro-environment
235 'unless '()
236 (##sys#er-transformer
237  (lambda (form r c)
238    (##sys#check-syntax 'unless form '#(_ 2))
239    `(,(r 'if) ,(cadr form)
240      (##core#undefined)
241      (,(r 'begin) ,@(cddr form))))))
242
243(##sys#extend-macro-environment
244 'set!-values '()
245 (##sys#er-transformer
246  (lambda (form r c)
247    (##sys#check-syntax 'set!-values form '(_ #(symbol 0) _))
248    (let ((vars (cadr form))
249          (exp (caddr form))
250          (%lambda (r 'lambda)))
251      (cond ((null? vars)
252             ;; may this be simply "exp"?
253             `(##sys#call-with-values
254               (,%lambda () ,exp)
255               (,%lambda () (##core#undefined))) )
256            ((null? (cdr vars))
257             `(##core#set! ,(car vars) ,exp)) 
258            (else
259             (let ([aliases (map gensym vars)])
260               `(##sys#call-with-values
261                 (,%lambda () ,exp)
262                 (,%lambda ,aliases
263                           ,@(map (lambda (v a)
264                                    `(##core#set! ,v ,a))
265                                  vars aliases) ) ) ) ) ) ))))
266
267(##sys#extend-macro-environment
268 'define-values '()
269 (##sys#er-transformer
270  (lambda (form r c)
271    `(,(r 'set!-values) ,@(cdr form)))))
272
273(##sys#extend-macro-environment
274 'let-values '()
275 (##sys#er-transformer
276  (lambda (form r c)
277    (##sys#check-syntax 'let-values form '(_ list . _))
278    (let ((vbindings (cadr form))
279          (body (cddr form))
280          (%let (r 'let))
281          (%lambda (r 'lambda)))
282      (letrec ((append* (lambda (il l)
283                          (if (not (pair? il))
284                              (cons il l)
285                              (cons (car il)
286                                    (append* (cdr il) l)))))
287               (map* (lambda (proc l)
288                       (cond ((null? l) '())
289                             ((not (pair? l)) (proc l))
290                             (else (cons (proc (car l)) (map* proc (cdr l))))))))
291        (let* ([llists (map car vbindings)]
292               [vars (let loop ((llists llists) (acc '()))
293                       (if (null? llists)
294                           acc
295                           (let* ((llist (car llists))
296                                  (new-acc
297                                   (cond ((list? llist) (append llist acc))
298                                         ((pair? llist) (append* llist acc))
299                                         (else (cons llist acc)))))
300                             (loop (cdr llists) new-acc))))]
301               [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
302               [lookup (lambda (v) (cdr (assq v aliases)))]
303               [llists2 (let loop ((llists llists) (acc '()))
304                          (if (null? llists)
305                              (reverse acc)
306                              (let* ((llist (car llists))
307                                     (new-acc
308                                      (cond ((not (pair? llist)) (cons (lookup llist) acc))
309                                            (else (cons (map* lookup llist) acc)))))
310                                (loop (cdr llists) new-acc))))])
311          (let fold ([llists llists]
312                     [exps (map (lambda (x) (cadr x)) vbindings)]
313                     [llists2 llists2] )
314            (cond ((null? llists)
315                   `(,%let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
316                  ((and (pair? (car llists2)) (null? (cdar llists2)))
317                   `(,%let ((,(caar llists2) ,(car exps)))
318                           ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
319                  (else
320                   `(##sys#call-with-values
321                     (,%lambda () ,(car exps))
322                     (,%lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
323
324(##sys#extend-macro-environment
325 'let*-values '()
326 (##sys#er-transformer
327  (lambda (form r c)
328    (##sys#check-syntax 'let*-values form '(_ list . _))
329    (let ((vbindings (cadr form))
330          (body (cddr form))
331          (%let (r 'let))
332          (%let-values (r 'let-values)) )
333      (let fold ([vbindings vbindings])
334        (if (null? vbindings)
335            `(,%let () ,@body)
336            `(,%let-values (,(car vbindings))
337                           ,(fold (cdr vbindings))) ) ) ))))
338
339(##sys#extend-macro-environment
340 'letrec-values '()
341 (##sys#er-transformer
342  (lambda (form r c)
343    (##sys#check-syntax 'letrec-values form '(_ list . _))
344    (let ((vbindings (cadr form))
345          (body (cddr form))
346          (%let (r 'let))
347          (%lambda (r 'lambda)))
348      (let* ([vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))] 
349             [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)] 
350             [lookup (lambda (v) (cdr (assq v aliases)))] )
351        `(,%let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
352                ,@(map (lambda (vb)
353                         `(##sys#call-with-values 
354                           (,%lambda () ,(cadr vb))
355                           (,%lambda ,(map lookup (car vb))
356                                     ,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
357                       vbindings)
358                ,@body) ) ) ) ) )
359
360(##sys#extend-macro-environment
361 'nth-value '()
362 (##sys#er-transformer
363  (lambda (form r c)
364    (##sys#check-syntax 'nth-value form '(_ _ _))
365    (let ((v (r 'tmp))
366          (%list-ref (r 'list-ref))
367          (%lambda (r 'lambda)))
368      `(##sys#call-with-values
369        (,%lambda () ,(caddr form))
370        (,%lambda ,v (,%list-ref ,v ,(cadr form))))))))
371
372(##sys#extend-macro-environment
373 'define-inline '()
374 (##sys#er-transformer
375  (lambda (form r c)
376    (let ((%lambda (r 'lambda)))
377      (letrec ([quotify-proc 
378                (lambda (xs id)
379                  (##sys#check-syntax id xs '#(_ 1))
380                  (let* ([head (car xs)]
381                         [name (if (pair? head) (car head) head)]
382                         [val (if (pair? head)
383                                  `(,%lambda ,(cdr head) ,@(cdr xs))
384                                  (cadr xs) ) ] )
385                    (when (or (not (pair? val)) (not (c %lambda (car val))))
386                      (syntax-error 
387                       'define-inline "invalid substitution form - must be lambda"
388                       name) )
389                    (list name val) ) ) ] )
390        `(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) ) )
391
392(##sys#extend-macro-environment
393 'and-let* '()
394 (##sys#er-transformer
395  (lambda (form r c)
396    (##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
397    (let ((bindings (cadr form))
398          (body (cddr form))
399          (%if (r 'if))
400          (%let (r 'let)))
401      (let fold ([bs bindings])
402        (if (null? bs)
403            `(,(r 'begin) ,@body)
404            (let ([b (car bs)]
405                  [bs2 (cdr bs)] )
406              (cond [(not (pair? b)) `(,%if ,b ,(fold bs2) #f)]
407                    [(null? (cdr b)) `(,%if ,(car b) ,(fold bs2) #f)]
408                    [else
409                     (let ((var (car b)))
410                       `(,%let ((,var ,(cadr b)))
411                         (,%if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
412
413(##sys#extend-macro-environment
414 'select '()
415 (##sys#er-transformer
416  (lambda (form r c)
417    (##sys#check-syntax 'select form '(_ _ . _))
418    (let ((exp (cadr form))
419          (body (cddr form))
420          (tmp (r 'tmp))
421          (%if (r 'if))
422          (%else (r 'else))
423          (%or (r 'or))
424          (%eqv? (r 'eqv?))
425          (%begin (r 'begin)))
426      `(,(r 'let) ((,tmp ,exp))
427        ,(let expand ((clauses body))
428           (if (not (pair? clauses))
429               '(##core#undefined)
430               (let ((clause (##sys#slot clauses 0))
431                     (rclauses (##sys#slot clauses 1)) )
432                 (##sys#check-syntax 'select clause '#(_ 1))
433                 (if (c %else (car clause))
434                     `(,%begin ,@(cdr clause))
435                     `(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x)) 
436                                         (car clause) ) )
437                            (,%begin ,@(cdr clause)) 
438                            ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
439
440
441;;; Optional argument handling:
442
443;;; Copyright (C) 1996 by Olin Shivers.
444;;;
445;;; This file defines three macros for parsing optional arguments to procs:
446;;;     (LET-OPTIONALS  arg-list ((var1 default1) ...) . body)
447;;;     (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
448;;;     (:OPTIONAL rest-arg default-exp)
449;;;
450;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
451;;; explicit-renaming low-level macro system. You'll have to do some work to
452;;; port it to another macro system.
453;;;
454;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
455;;; high-level macros, and should be portable to any R4RS system.
456;;;
457;;; These macros are all careful to evaluate their default forms *only* if
458;;; their values are needed.
459;;;
460;;; The only non-R4RS dependencies in the macros are ERROR
461;;; and CALL-WITH-VALUES.
462;;;     -Olin
463
464;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
465;;;   body
466;;;   ...)
467;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
468;;; This form is for binding a procedure's optional arguments to either
469;;; the passed-in values or a default.
470;;;
471;;; The expression takes a rest list ARG-LIST and binds the VARi to
472;;; the elements of the rest list. When there are no more elements, then
473;;; the remaining VARi are bound to their corresponding DEFAULTi values.
474;;; It is an error if there are more args than variables.
475;;;
476;;; - The default expressions are *not* evaluated unless needed.
477;;;
478;;; - When evaluated, the default expressions are carried out in the *outer*
479;;;   environment. That is, the DEFAULTi forms do *not* see any of the VARi
480;;;   bindings.
481;;;
482;;;   I originally wanted to have the DEFAULTi forms get eval'd in a LET*
483;;;   style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
484;;;   impossible to implement without side effects or redundant conditional
485;;;   tests. If I drop this requirement, I can use the efficient expansion
486;;;   shown below. If you need LET* scope, use the less-efficient
487;;;   LET-OPTIONALS* form defined below.
488;;;
489;;; Example:
490;;; (define (read-string! str . maybe-args)
491;;;   (let-optionals maybe-args ((port (current-input-port))
492;;;                              (start 0)
493;;;                              (end (string-length str)))
494;;;     ...))
495;;;
496;;; expands to:
497;;;
498;;; (let* ((body (lambda (port start end) ...))
499;;;        (end-def (lambda (%port %start) (body %port %start <end-default>)))
500;;;        (start-def (lambda (%port) (end-def %port <start-default>)))
501;;;        (port-def  (lambda () (start-def <port-def>))))
502;;;   (if (null? rest) (port-def)
503;;;       (let ((%port (car rest))
504;;;             (rest (cdr rest)))
505;;;       (if (null? rest) (start-def %port)
506;;;           (let ((%start (car rest))
507;;;                 (rest (cdr rest)))
508;;;             (if (null? rest) (end-def %port %start)
509;;;                 (let ((%end (car rest))
510;;;                       (rest (cdr rest)))
511;;;                   (if (null? rest) (body %port %start %end)
512;;;                       (error ...)))))))))
513
514
515;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
516
517(##sys#extend-macro-environment
518 'let-optionals '()
519 (##sys#er-transformer
520  (lambda (form r c)
521    (##sys#check-syntax 'let-optionals form '(_ _ . _))
522    (let ((arg-list (cadr form))
523          (var/defs (caddr form))
524          (body (cdddr form))
525          (%null? (r 'null?))
526          (%if (r 'if))
527          (%let (r 'let))
528          (%car (r 'car))
529          (%cdr (r 'cdr))
530          (%lambda (r 'lambda)))
531
532      ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
533      ;; I wish I had a reasonable loop macro.
534
535      (define (make-default-procs vars body-proc defaulter-names defs rename)
536        (let recur ((vars (reverse vars))
537                    (defaulter-names (reverse defaulter-names))
538                    (defs (reverse defs))
539                    (next-guy body-proc))
540          (if (null? vars) '()
541              (let ((vars (cdr vars)))
542                `((,(car defaulter-names)
543                   (,%lambda ,(reverse vars)
544                             (,next-guy ,@(reverse vars) ,(car defs))))
545                  . ,(recur vars
546                            (cdr defaulter-names)
547                            (cdr defs)
548                            (car defaulter-names)))))))
549
550
551      ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
552
553      (define (make-if-tree vars defaulters body-proc rest rename)
554        (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
555          (if (null? vars)
556              `(,%if (##core#check (,%null? ,rest))
557                     (,body-proc . ,(reverse non-defaults))
558                     (##sys#error (##core#immutable '"too many optional arguments") ,rest))
559              (let ((v (car vars)))
560                `(,%if (null? ,rest)
561                       (,(car defaulters) . ,(reverse non-defaults))
562                       (,%let ((,v (,%car ,rest))
563                               (,rest (,%cdr ,rest)))
564                              ,(recur (cdr vars)
565                                      (cdr defaulters)
566                                      (cons v non-defaults))))))))
567
568      (##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
569      (##sys#check-syntax 'let-optionals body '#(_ 1))
570      (let* ((vars (map car var/defs))
571             (prefix-sym (lambda (prefix sym)
572                           (string->symbol (string-append prefix (symbol->string sym)))))
573
574             ;; Private vars, one for each user var.
575             ;; We prefix the % to help keep macro-expanded code from being
576             ;; too confusing.
577             (vars2 (map (lambda (v) (r (prefix-sym "%" v)))
578                         vars))
579
580             (defs (map cadr var/defs))
581             (body-proc (r 'body))
582
583             ;; A private var, bound to the value of the ARG-LIST expression.
584             (rest-var (r '%rest))
585
586             (defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
587                                   vars))
588
589             (defaulters (make-default-procs vars2 body-proc
590                                             defaulter-names defs gensym))
591             (if-tree (make-if-tree vars2 defaulter-names body-proc
592                                    rest-var gensym)))
593
594        `(,(r 'let*) ((,rest-var ,arg-list)
595                      (,body-proc (,%lambda ,vars . ,body))
596                      . ,defaulters)
597          ,if-tree) ) ))))
598
599
600;;; (optional rest-arg default-exp)
601;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
602;;; This form is for evaluating optional arguments and their defaults
603;;; in simple procedures that take a *single* optional argument. It is
604;;; a macro so that the default will not be computed unless it is needed.
605;;;
606;;; REST-ARG is a rest list from a lambda -- e.g., R in
607;;;     (lambda (a b . r) ...)
608;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
609;;; - If REST-ARG has 1 element, return that element.
610;;; - If REST-ARG has >1 element, error.
611
612(##sys#extend-macro-environment
613 'optional '()
614 (##sys#er-transformer
615  (lambda (form r c)
616    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
617    (let ((var (r 'tmp))
618          (%null? (r 'null?))
619          (%if (r 'if)))
620      `(,(r 'let) ((,var ,(cadr form)))
621        (,%if (,%null? ,var) 
622              ,(optional (cddr form) #f)
623              (,%if (##core#check (,%null? (,(r 'cdr) ,var)))
624                    (,(r 'car) ,var)
625                    (##sys#error
626                     (##core#immutable '"too many optional arguments") 
627                     ,var))))))))
628
629
630;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
631;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
632;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
633;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
634;;; within the scope of VAR1 and VAR2, and so forth.
635;;;
636;;; - If the last form in the ((var1 default1) ...) list is not a
637;;;   (VARi DEFAULTi) pair, but a simple variable REST, then it is
638;;;   bound to any left-over values. For example, if we have VAR1 through
639;;;   VAR7, and ARGS has 9 values, then REST will be bound to the list of
640;;;   the two values of ARGS. If ARGS is too short, causing defaults to
641;;;   be used, then REST is bound to '().
642;;; - If there is no REST variable, then it is an error to have excess
643;;;   values in the ARGS list.
644
645(##sys#extend-macro-environment
646 'let-optionals* '()
647 (##sys#er-transformer
648  (lambda (form r c)
649    (##sys#check-syntax 'let-optionals* form '(_ _ list . _))
650    (let ((args (cadr form))
651          (var/defs (caddr form))
652          (body (cdddr form))
653          (%let (r 'let))
654          (%if (r 'if))
655          (%null? (r 'null?))
656          (%car (r 'car))
657          (%cdr (r 'cdr)))
658      (let ((rvar (r 'tmp)))
659        `(,%let ((,rvar ,args))
660                ,(let loop ([args rvar] [vardefs var/defs])
661                   (if (null? vardefs)
662                       `(,%if (##core#check (,%null? ,args))
663                              (,%let () ,@body)
664                              (##sys#error 
665                               (##core#immutable '"too many optional arguments") 
666                               ,args) )
667                       (let ([head (car vardefs)])
668                         (if (pair? head)
669                             (let ((rvar2 (r 'tmp2)))
670                               `(,%let ((,(car head) (,%if (,%null? ,args)
671                                                           ,(cadr head)
672                                                           (,%car ,args)))
673                                        (,rvar2 (,%if (,%null? ,args) 
674                                                      '()
675                                                      (,%cdr ,args))) )
676                                       ,(loop rvar2 (cdr vardefs)) ) )
677                             `(,%let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
678
679
680;;; case-lambda (SRFI-16):
681
682(##sys#extend-macro-environment
683 'case-lambda '()
684 (##sys#er-transformer
685  (lambda (form r c)
686    (##sys#check-syntax 'case-lambda form '(_ . _))
687    (define (genvars n)
688      (let loop ([i 0])
689        (if (fx>= i n)
690            '()
691            (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
692    (require 'srfi-1)                   ; Urgh...
693    (let* ((mincount (apply min (map (lambda (c)
694                                       (##sys#decompose-lambda-list 
695                                        (car c)
696                                        (lambda (vars argc rest) argc) ) )
697                                     (cdr form))))
698           (minvars (genvars mincount))
699           (rvar (r 'rvar))
700           (lvar (r 'lvar))
701           (%lambda (r 'lambda))
702           (%let (r 'let))
703           (%if (r 'if)))
704      `(,%lambda ,(append minvars rvar)
705                 (,%let ((,lvar (length ,rvar)))
706                        ,(fold-right
707                          (lambda (c body)
708                            (##sys#decompose-lambda-list
709                             (car c)
710                             (lambda (vars argc rest)
711                               (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
712                               `(,%if ,(let ([a2 (fx- argc mincount)])
713                                         (if rest
714                                             (if (zero? a2)
715                                                 #t
716                                                 `(,(r 'fx>=) ,lvar ,a2) )
717                                             `(,(r 'fx=) ,lvar ,a2) ) )
718                                      ,(receive (vars1 vars2)
719                                           (split-at! (take vars argc) mincount)
720                                         (let ((bindings
721                                                (let build ((vars2 vars2) (vrest rvar))
722                                                  (if (null? vars2)
723                                                      (cond (rest `(,%let ((,rest ,vrest)) ,@(cdr c)))
724                                                            ((null? (cddr c)) (cadr c))
725                                                            (else `(,%let () ,@(cdr c))) )
726                                                      (let ((vrest2 (r (gensym))))
727                                                        `(,%let ((,(car vars2) (,(r 'car) ,vrest))
728                                                                 (,vrest2 (,(r 'cdr) ,vrest)) )
729                                                                ,(if (pair? (cdr vars2))
730                                                                     (build (cdr vars2) vrest2)
731                                                                     (build '() vrest2) ) ) ) ) ) ) )
732                                           (if (null? vars1)
733                                               bindings
734                                               `(,%let ,(map list vars1 minvars) ,bindings) ) ) )
735                                      ,body) ) ) )
736                          '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
737                          (cdr form))))))))
738
739
740;;; Record printing:
741
742(##sys#extend-macro-environment
743 'define-record-printer '()
744 (##sys#er-transformer
745  (lambda (form r c)
746    (##sys#check-syntax 'define-record-printer form '(_ . _))
747    (cond [(pair? head)
748           (##sys#check-syntax 
749            'define-record-printer (cons head body)
750            '((symbol symbol symbol) . #(_ 1)))
751           `(##sys#register-record-printer 
752             ',(##sys#slot head 0)
753             (,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
754          [else
755           (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
756           `(##sys#register-record-printer ',head ,@body) ] ) )))
757
758
759;;; Exceptions:
760
761(##sys#extend-macro-environment
762 'handle-exceptions '()
763 (##sys#er-transformer
764  (lambda (form r c)
765    (##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
766  (let ((k (r 'k))
767        (args (r 'args))
768        (%lambda (r 'lambda)))
769    `((,(r 'call-with-current-continuation)
770       (,%lambda (,k)
771         (,(r 'with-exception-handler)
772          (,%lambda (,(cadr form)) (,k (,%lambda () ,(caddr form))))
773          (,%lambda ()
774            (##sys#call-with-values
775             (,%lambda () ,@(cdddr form))
776             (,%lambda 
777              ,args 
778              (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
779
780(##sys#extend-macro-environment
781 'condition-case '()
782 (##sys#er-transformer
783  (lambda (form r c)
784    (##sys#check-syntax 'condition-case form '(_ _ . _))
785    (let ((exvar (r 'exvar))
786          (kvar (r 'kvar))
787          (%and (r 'and))
788          (%let (r 'let))
789          (%memv (r 'memv))
790          (%else (r 'else)))
791      (define (parse-clause c)
792        (let* ([var (and (symbol? (car c)) (car c))]
793               [kinds (if var (cadr c) (car c))]
794               [body (if var (cddr c) (cdr c))] )
795          (if (null? kinds)
796              `(,%else 
797                ,(if var
798                     `(,%let ([,var ,exvar]) ,@body)
799                     `(,%let () ,@body) ) )
800              `((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
801                ,(if var
802                     `(,%let ([,var ,exvar]) ,@body)
803                     `(,%let () ,@body) ) ) ) ) )
804      `(,(r 'handle-exceptions) ,exvar
805        (,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition) 
806                              (##sys#slot ,exvar 1))])
807               (,(r 'cond) ,@(map parse-clause (cddr form))
808                (,%else (##sys#signal ,exvar)) ) )
809        ,(cadr form))))))
810
811
812;;; SRFI-9:
813
814(##sys#extend-macro-environment
815 'define-record-type '()
816 (##sys#er-transformer
817  (lambda (form r c)
818    (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _)) 
819    (let* ((t (cadr form))
820          (conser (caddr form))
821          (pred (cadddr form))
822          (slots (cddddr form))
823          (%begin (r 'begin))
824          (%lambda (r 'lambda))
825          (%define (r 'define))
826          (vars (cdr conser))
827          (x (r 'x))
828          (y (r 'y))
829          (%getter-with-setter (r 'getter-with-setter))
830          (slotnames (map car slots)))
831      `(,%begin
832        (,%define ,conser
833                  (##sys#make-structure 
834                   ',t 
835                   ,@(map (lambda (sname)
836                            (if (memq sname vars)
837                                sname
838                                '(##core#undefined) ) )
839                          slotnames) ) )
840        (,%define (,pred ,x) (##sys#structure? ,x ',t))
841        ,@(let loop ([slots slots] [i 1])
842            (if (null? slots)
843                '()
844                (let* ([slot (car slots)]
845                       (setters (memq #:record-setters ##sys#features))
846                       (setr? (pair? (cddr slot))) 
847                       (getr `(,%lambda (,x)
848                                        (##core#check (##sys#check-structure ,x ',t))
849                                        (##sys#block-ref ,x ,i) ) ) )
850                  `(,@(if setr?
851                          `((,%define (,(caddr slot) ,x ,y)
852                                      (##core#check (##sys#check-structure ,x ',t))
853                                      (##sys#block-set! ,x ,i ,y)) )
854                          '() )
855                    (,%define ,(cadr slot) 
856                              ,(if (and setr? setters)
857                                   `(,%getter-with-setter ,getr ,(caddr slot))
858                                   getr) )
859                    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
860
861
862;;; Compile-time `require':
863
864(##sys#extend-macro-environment
865 'require-for-syntax '()
866 (##sys#er-transformer
867  (lambda (form r c)
868    `(##core#require-for-syntax ,@(cdr form)))))
869
870(##sys#extend-macro-environment
871 'use '()
872 (##sys#er-transformer
873  (lambda (form r c)
874    `(##core#require-extension ,@(cdr form)))))
875
876
877;;; SRFI-26:
878
879(##sys#extend-macro-environment
880 'cut '()
881 (##sys#er-transformer
882  (lambda (form r c)
883    (let ((%<> (r '<>))
884          (%<...> (r '<...>))
885          (%apply (r 'apply))
886          (%begin (r 'begin))
887          (%lambda (r 'lambda)))
888      (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
889        (if (null? xs)
890            (let ([rvars (reverse vars)]
891                  [rvals (reverse vals)] )
892              (if rest
893                  (let ([rv (r (gensym))])
894                    `(,%lambda (,@rvars . ,rv)
895                               (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
896                  `(,%lambda ,rvars ((,%begin ,(car rvals)) ,@(cdr rvals)) ) ) )
897            (cond ((c %<> (car xs))
898                   (let ([v (r (gensym))])
899                     (loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
900                  ((c %<...> (car xs)) (loop '() vars vals #t))
901                  (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
902
903(##sys#extend-macro-environment
904 'cute '()
905 (##sys#er-transformer
906  (lambda (form r c)
907    (let ((%let (r 'let))
908          (%lambda (r 'lambda))
909          (%<> (r '<>))
910          (%<...> (r '<...>))
911          (%apply (r 'apply)))
912      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
913        (if (null? xs)
914            (let ([rvars (reverse vars)]
915                  [rvals (reverse vals)] )
916              (if rest
917                  (let ([rv (r (gensym))])
918                    `(,%let 
919                      ,bs
920                      (,%lambda (,@rvars . ,rv)
921                                (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
922                  `(,%let ,bs
923                          (,%lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
924            (cond ((c %<> (car xs))
925                   (let ([v (r (gensym))])
926                     (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
927                  ((c %<...> (car xs)) (loop '() vars bs vals #t))
928                  (else
929                   (let ([v (r (gensym))])
930                     (loop (cdr xs) 
931                           vars
932                           (cons (list v (car xs)) bs)
933                           (cons v vals) #f) ) ))))))))
934
935
936;;; SRFI-13:
937
938(##sys#extend-macro-environment
939 'let-string-start+end '()
940 (##sys#er-transformer
941  (lambda (form r c)
942    (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
943    (let ((s-e-r (cadr form))
944          (proc (caddr form))
945          (s-exp (cadddr form))
946          (args-exp (car (cddddr form)))
947          (body (cdr (cddddr form)))
948          (%receive (r 'receive))
949          (%string-parse-start+end (r 'string-parse-start+end))
950          (%string-parse-final-start+end (r 'string-parse-final-start+end)))
951      (if (pair? (cddr s-e-r))
952          `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
953                      (,%string-parse-start+end ,proc ,s-exp ,args-exp)
954                      ,@body)
955          `(,%receive ,s-e-r
956                      (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
957                      ,@body) ) ))))
958
959
960;;; Extension helper:
961
962(##sys#extend-macro-environment
963 'define-extension '()
964 (##sys#er-transformer
965  (lambda (form r c)
966    (##sys#check-syntax 'define-extension form '(_ symbol . _))
967    (let ((%declare (r 'declare))
968          (%begin (r 'begin))
969          (%static (r 'static))
970          (%dynamic (r 'dynamic))
971          (%export (r 'export)))
972      (let loop ((s '()) (d '()) (cs (cddr form)) (exports #f))
973        (cond ((null? cs)
974               (let ((exps (if exports
975                               `(,%declare (,%export ,@exports))
976                               '(,%begin))))
977                 `(,(r 'cond-expand)
978                   (chicken-compile-shared ,exps ,@d)
979                   ((,(r 'not) compiling) ,@d)
980                   (,(r 'else)
981                    (,%declare (unit ,name))
982                    ,exps
983                    (,(r 'provide) (,(r 'quote) ,name))
984                    ,@s) ) ) )
985              ((and (pair? cs) (pair? (car cs)))
986               (let ((t (caar cs))
987                     (next (cdr cs)) )
988                 (cond ((c %static t)
989                        (loop (cons `(,%begin ,@(cdar cs)) s) d next exports))
990                       ((c %dynamic t) 
991                        (loop s (cons `(,%begin ,@(cdar cs)) d) next exports))
992                       ((c %export t)
993                        (loop s d next (append (or exports '()) (cdar cs))))
994                       (else
995                        (syntax-error 'define-extension "invalid clause specifier" (caar cs))) ) ) )
996              (else
997               (syntax-error
998                'define-extension
999                "invalid clause syntax" cs)) ) ) ))))
1000
1001
1002;;; SRFI-31
1003
1004(##sys#extend-macro-environment
1005 'rec '()
1006 (##sys#er-transformer
1007  (lambda (form r c)
1008    (##sys#check-syntax 'rec form '(_ _ . _))
1009    (let ((head (cadr form))
1010          (%letrec (r 'letrec)))
1011      (if (pair? head)
1012          `(,%letrec ((,(car head) 
1013                       (,(r 'lambda) ,(cdr head)
1014                        ,@(cddr form))))
1015                     ,(car head))
1016          `(,%letrec ((,head ,@(cddr form))) ,head))))))
1017
1018
1019;;; Definitions available at macroexpansion-time:
1020
1021(##sys#extend-macro-environment
1022 'define-for-syntax '()
1023 (##sys#er-transformer
1024  (lambda (form r c)
1025    (##sys#check-syntax 'define-for-syntax form '(_ _ . _))
1026    (let ((head (cadr form))
1027          (body (cddr form)))
1028      (let* ((body (if (null? body) '((##core#undefined)) body))
1029             (name (if (pair? head) (car head) head)) 
1030             (body (if (pair? head)
1031                       `(,(r 'lambda) ,(cdr head) ,@body)
1032                       (car body))))
1033        (if (symbol? name)
1034            (##sys#setslot name 0 (eval body))
1035            (syntax-error 'define-for-syntax "invalid identifier" name) )
1036        (if ##sys#enable-runtime-macros
1037            `(,(r 'define) ,name ,body)
1038            '(##core#undefined)))))))
1039
1040
1041;;; Register features provided by this file
1042
1043(define ##sys#chicken-macro-environment
1044  (let loop ((me (##sys#macro-environment)))
1045    (if (or (null? me) (eq? me ##sys#me-0))
1046        '()
1047        (cons (car me) (loop (cdr me))))))
1048
1049(eval-when (compile load eval)
1050  (register-feature! 'srfi-8 'srfi-16 'srfi-26 'srfi-31 'srfi-15 'srfi-11) )
Note: See TracBrowser for help on using the repository browser.