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

Last change on this file since 10426 was 10426, checked in by felix winkelmann, 13 years ago

removed current module crap and made compiler run again; fixed several bugs introduced by decruftification; I'm still the boss here.

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