source: project/chicken/branches/scrutiny/chicken-syntax.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

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