source: project/chicken/branches/release/chicken-more-macros.scm @ 7276

Last change on this file since 7276 was 7276, checked in by felix winkelmann, 12 years ago

merged trunk

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