source: project/release/3/cmk/chicken-more-macros.scm @ 12843

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago

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