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

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

low-level module attempt; converted some more macros

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