source: project/chicken/trunk/chicken-syntax.scm @ 12559

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