source: project/chicken/branches/beyond-hope/chicken-more-macros.scm @ 10439

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

painfully slowly debugging compiler

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