source: project/chicken/trunk/chicken-more-macros.scm @ 12086

Last change on this file since 12086 was 12086, checked in by felix winkelmann, 11 years ago

removed some deprecated compiler options; removed compiler-macros

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