source: project/chicken/branches/prerelease/chicken-syntax.scm @ 15101

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

merged trunk changes from 14491:15100 into prerelease branch

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