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

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