source: project/chicken/branches/beyond-hope/expand.scm @ 10351

Last change on this file since 10351 was 10351, checked in by felix winkelmann, 12 years ago

some macros converted, fix in body-canonicalization

File size: 29.6 KB
Line 
1;;;; expand.scm
2;
3; Copyright (c) 2008, The Chicken Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(declare
28  (unit expand)
29  (disable-interrupts)
30  (fixnum)
31  (hide match-expression
32        macro-alias
33        d
34        lookup) )
35
36
37(set! ##sys#features
38  (append '(#:hygienic-macros #:syntax-rules) ##sys#features))
39
40(define (d arg1 . more)
41  (if (null? more)
42      (pp arg1)
43      (apply print arg1 more)))
44
45(define-macro (d . _) '(void))
46
47
48;;; Syntactic environments
49
50(define ##sys#current-environment (make-parameter '()))
51(define ##sys#current-meta-environment (make-parameter '()))
52
53(define (lookup id se)
54  (cond ((assq id se) => cdr)
55        ((##sys#get id '##sys#macro-alias))
56        (else #f)))
57
58(define (macro-alias var se)
59  (let* ((alias (gensym var))
60         (ua (or (lookup var se) var)))
61    (##sys#put! alias '##sys#macro-alias ua)
62    alias) )
63
64(define (##sys#strip-syntax exp #!optional se)
65  ;; if se is given, retain bound vars
66  (let walk ((x exp))
67    (cond ((symbol? x)
68           (let ((x2 (if se 
69                         (lookup x se)
70                         (get x '##sys#macro-alias) ) ) )
71             (cond ((not x2) x)
72                   ((pair? x2) x)
73                   (else x2))))
74          ((pair? x)
75           (cons (walk (##sys#slot x 0))
76                 (walk (##sys#slot x 1))))
77          ((vector? x)
78           (list->vector (map walk (vector->list x))))
79          (else x))))
80
81
82;;; Macro handling
83
84(define ##sys#macro-environment '())
85
86(define (##sys#extend-macro-environment name se handler)
87  (cond ((lookup name ##sys#macro-environment) =>
88         (lambda (a)
89           (set-car! a se)
90           (set-car! (cdr a) handler) ) )
91        (else
92         (set! ##sys#macro-environment
93           (cons (list name se handler) ##sys#macro-environment)))))
94
95(define (##sys#copy-macro old new)
96  (let ((def (lookup old ##sys#macro-environment)))
97    (apply ##sys#extend-macro-environment new def) ) )
98
99(define (macro? sym #!optional (senv (##sys#current-environment)))
100  (##sys#check-symbol sym 'macro?)
101  (##sys#check-list senv 'macro?)
102  (or (lookup sym senv)
103      (and (lookup sym ##sys#macro-environment) #t) ) )
104
105(define (##sys#unregister-macro name)
106  (set! ##sys#macro-environment
107    ;; this builds up stack, but isn't used often anyway...
108    (let loop ((me ##sys#macro-environment) (me2 '()))
109      (cond ((null? me) '())
110            ((eq? x (caar me)) (cdr me))
111            (else (cons (car me) (loop (cdr me))))))))
112
113(define (undefine-macro! name)
114  (##sys#check-symbol name 'undefine-macro!)
115  (##sys#unregister-macro name) )
116
117
118;; The basic macro-expander
119
120(define ##sys#macroexpand-0
121  (let ([string-append string-append])
122    (lambda (exp dse)
123      (define (call-handler name handler exp se)
124        (d "invoking macro: " name)
125        (handle-exceptions ex
126            (##sys#abort
127             (if (and (##sys#structure? ex 'condition)
128                      (memv 'exn (##sys#slot ex 1)) )
129                 (##sys#make-structure
130                  'condition
131                  (##sys#slot ex 1)
132                  (let copy ([ps (##sys#slot ex 2)])
133                    (if (null? ps)
134                        '()
135                        (let ([p (car ps)]
136                              [r (cdr ps)])
137                          (if (and (equal? '(exn . message) p)
138                                   (pair? r)
139                                   (string? (car r)) )
140                              (cons
141                               '(exn . message)
142                               (cons (string-append
143                                      "during expansion of ("
144                                      (##sys#slot name 1) 
145                                      " ...) - "
146                                      (car r) )
147                                     (cdr r) ) )
148                              (copy r) ) ) ) ) )
149                 ex) )
150          (handler exp se dse)))
151      (define (expand head exp mdef)
152        (d `(EXPAND: ,head ,exp ,(map car dse)))
153        (cond ((not (list? exp))
154               (##sys#syntax-error-hook "invalid syntax in macro form" exp) )
155              ((pair? mdef)
156               (values
157                ;; if stored se is #f, then this is a lisp macro,
158                ;; force ref. opaqueness by passing dynamic se
159                (call-handler head (cadr mdef) exp (or (car mdef) dse))
160                #t))
161              (else (values exp #f)) ) )
162      (if (pair? exp)
163          (let ((head (##sys#slot exp 0))
164                (body (##sys#slot exp 1)) )
165            (if (symbol? head)
166                (let ((head2 (or (lookup head dse) head)))
167                  (unless (pair? head2)
168                    (set! head2 (or (lookup head2 ##sys#macro-environment) head2)) )
169                  (cond [(eq? head2 'let)
170                         (##sys#check-syntax 'let body '#(_ 2) #f dse)
171                         (let ([bindings (car body)])
172                           (cond [(symbol? bindings)
173                                  (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f se)
174                                  (let ([bs (cadr body)])
175                                    (values
176                                     `(##core#app
177                                       (,(macro-alias 'letrec dse)
178                                        ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
179                                        ,bindings)
180                                       ,@(##sys#map cadr bs) )
181                                     #t) ) ]
182                                 [else (values exp #f)] ) ) ]
183                        [(and (memq head2 '(set! ##core#set!))
184                              (pair? body)
185                              (pair? (car body)) )
186                         (let ([dest (car body)])
187                           (##sys#check-syntax 'set! body '(#(_ 1) _) #f dse)
188                           (values
189                            (append (list (list '##sys#setter (car dest)))
190                                    (cdr dest)
191                                    (cdr body) ) 
192                            #t) ) ]
193                        [else (expand head exp head2)] ) )
194                (values exp #f) ) )
195          (values exp #f) ) ) ) )
196
197
198;;; These are needed to hook other module/macro systems into the evaluator and compiler
199
200(define (##sys#compiler-toplevel-macroexpand-hook exp) exp)
201(define (##sys#interpreter-toplevel-macroexpand-hook exp) exp)
202(define ##sys#enable-runtime-macros #f)
203
204
205;;; User-level macroexpansion
206
207(define (##sys#expand exp #!optional (me (##sys#current-environment)))
208  (let loop ((exp exp))
209    (let-values (((exp2 m) (##sys#macroexpand-0 exp me)))
210      (if m
211          (loop exp2)
212          exp2) ) ) )
213
214(define macroexpand ##sys#expand)
215
216(define (macroexpand-1 exp #!optional (me (##sys#current-environment)))
217  (##sys#macroexpand-0 exp me) )
218
219
220;;; Extended (DSSSL-style) lambda lists
221;
222; Assumptions:
223;
224; 1) #!rest must come before #!key
225; 2) default values may refer to earlier variables
226; 3) optional/key args may be either variable or (variable default)
227; 4) an argument marker may not be specified more than once
228; 5) no special handling of extra keywords (no error)
229; 6) default value of optional/key args is #f
230; 7) mixing with dotted list syntax is allowed
231
232(define (##sys#extended-lambda-list? llist)
233  (let loop ([llist llist])
234    (and (pair? llist)
235         (case (##sys#slot llist 0)
236           [(#!rest #!optional #!key) #t]
237           [else (loop (##sys#slot llist 1))] ) ) ) )
238
239(define ##sys#expand-extended-lambda-list
240  (let ([reverse reverse]
241        [gensym gensym] )
242    (lambda (llist0 body errh se)
243      (define (err msg) (errh msg llist0))
244      (define (->keyword s) (string->keyword (##sys#slot s 1)))
245      (let ([rvar #f]
246            [hasrest #f] )
247        (let loop ([mode 0]             ; req, opt, rest, key, end
248                   [req '()]
249                   [opt '()]
250                   [key '()] 
251                   [llist llist0] )
252          (cond [(null? llist)
253                 (values
254                  (if rvar (##sys#append (reverse req) rvar) (reverse req))
255                  (let ([body 
256                         (if (null? key)
257                             body
258                             `((,(macro-alias 'let* se)
259                                ,(map (lambda (k)
260                                        (let ([s (car k)])
261                                          `[,s (##sys#get-keyword 
262                                                ',(->keyword s) ,rvar
263                                                ,@(if (pair? (cdr k)) 
264                                                      `((,(macro-alias 'lambda se)
265                                                         () ,@(cdr k)))
266                                                      '() ) ) ] ) )
267                                      (reverse key) )
268                                ,@body) ) ) ] )
269                    (cond [(null? opt) body]
270                          [(and (not hasrest) (null? key) (null? (cdr opt)))
271                           `((,(macro-alias 'let se)
272                              ([,(caar opt) (,(macro-alias 'optional se)
273                                             ,rvar ,(cadar opt))])
274                               ,@body) ) ]
275                          [(and (not hasrest) (null? key))
276                           `((,(macro-alias 'let-optionals se)
277                              ,rvar ,(reverse opt) ,@body))]
278                          [else
279                           `((,(macro-alias 'let-optionals* se)
280                              ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar))) 
281                              ,@body))] ) ) ) ]
282                [(symbol? llist) 
283                 (if (fx> mode 2)
284                     (err "rest argument list specified more than once")
285                     (begin
286                       (if (not rvar) (set! rvar llist))
287                       (set! hasrest llist)
288                       (loop 4 req opt '() '()) ) ) ]
289                [(not (pair? llist))
290                 (err "invalid lambda list syntax") ]
291                [else
292                 (let ([x (or (lookup (car llist) se) (car llist))]
293                       [r (##sys#slot llist 1)])
294                   (case x
295                     [(#!optional)
296                      (if (not rvar) (set! rvar (gensym)))
297                      (if (eq? mode 0)
298                          (loop 1 req '() '() r)
299                          (err "`#!optional' argument marker in wrong context") ) ]
300                     [(#!rest)
301                      (if (fx<= mode 1)
302                          (if (and (pair? r) (symbol? (##sys#slot r 0)))
303                              (begin
304                                (if (not rvar) (set! rvar (##sys#slot r 0)))
305                                (set! hasrest (##sys#slot r 0))
306                                (loop 2 req opt '() (##sys#slot r 1)) )
307                              (err "invalid syntax of `#!rest' argument") ) 
308                          (err "`#!rest' argument marker in wrong context") ) ]
309                     [(#!key)
310                      (if (not rvar) (set! rvar (gensym)))
311                      (if (fx<= mode 3)
312                          (loop 3 req opt '() r)
313                          (err "`#!key' argument marker in wrong context") ) ]
314                     [else
315                      (cond [(symbol? x)
316                             (case mode
317                               [(0) (loop 0 (cons x req) '() '() r)]
318                               [(1) (loop 1 req (cons (list x #f) opt) '() r)]
319                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
320                               [else (loop 3 req opt (cons (list x) key) r)] ) ]
321                            [(and (list? x) (eq? 2 (length x)))
322                             (case mode
323                               [(0) (err "invalid required argument syntax")]
324                               [(1) (loop 1 req (cons x opt) '() r)]
325                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
326                               [else (loop 3 req opt (cons x key) r)] ) ]
327                            [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
328
329
330;;; Expansion of bodies (and internal definitions)
331
332(define ##sys#canonicalize-body
333  (let ([reverse reverse]
334        [map map] )
335    (lambda (body #!optional (se (##sys#current-environment)))
336      (define (fini vars vals mvars mvals body)
337        (if (and (null? vars) (null? mvars))
338            (let loop ([body2 body] [exps '()])
339              (if (not (pair? body2)) 
340                  (cons
341                   (macro-alias 'begin se)
342                   body) ; no more defines, otherwise we would have called `expand'
343                  (let ([x (car body2)])
344                    (if (and (pair? x) 
345                             (let ((d (car x)))
346                               (and (symbol? d)
347                                    (or (eq? (or (lookup d se) d) 'define)
348                                        (eq? (or (lookup d se) d) 'define-values)))) )
349                        (cons
350                         (macro-alias 'begin se)
351                         (##sys#append (reverse exps) (list (expand body2))))
352                        (loop (cdr body2) (cons x exps)) ) ) ) )
353            (let ([vars (reverse vars)]
354                  (lam (macro-alias 'lambda se)))
355              `(,(macro-alias 'let se)
356                ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
357                            (apply ##sys#append vars mvars) )
358                ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
359                ,@(map (lambda (vs x)
360                         (let ([tmps (##sys#map gensym vs)])
361                           `(##sys#call-with-values
362                             (,lam () ,x)
363                             (,lam ,tmps 
364                                   ,@(map (lambda (v t) `(##core#set! ,v ,t)) vs tmps) ) ) ) ) 
365                       (reverse mvars)
366                       (reverse mvals) )
367                ,@body) ) ) )
368      (define (fini/syntax vars vals mvars mvals body)
369        (fini
370         vars vals mvars mvals
371         (let loop ((body body) (defs '()) (done #f))
372           (cond (done `(,(macro-alias 'letrec-syntax se)
373                         ,(map cdr (reverse defs)) ,@body) )
374                 ((not (pair? body)) (loop body defs #t))
375                 ((and (list? (car body))
376                       (= 3 (length (car body))) 
377                       (symbol? (caar body))
378                       (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
379                  (loop (cdr body) (cons (car body) defs) #f))
380                 (else (loop body defs #t))))))               
381      (define (expand body)
382        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
383          (if (not (pair? body))
384              (fini vars vals mvars mvals body)
385              (let* ((x (car body))
386                     (rest (cdr body))
387                     (exp1 (and (pair? x) (car x)))
388                     (head (and exp1
389                                (symbol? exp1)
390                                (or (lookup exp1 se) exp1))))
391                (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
392                      [(eq? 'define head)
393                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
394                       (let loop2 ([x x])
395                         (let ([head (cadr x)])
396                           (cond [(not (pair? head))
397                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
398                                  (loop rest (cons head vars)
399                                        (cons (if (pair? (cddr x))
400                                                  (caddr x)
401                                                  '(##sys#void) )
402                                              vals)
403                                        mvars mvals) ]
404                                 [(pair? (##sys#slot head 0))
405                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
406                                  (loop2 (cons (macro-alias 'define se)
407                                               (##sys#expand-curried-define head (cddr x) se))) ]
408                                 [else
409                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
410                                  (loop rest
411                                        (cons (##sys#slot head 0) vars)
412                                        (cons `(,(macro-alias 'lambda se) ,(##sys#slot head 1) ,@(cddr x)) vals)
413                                        mvars mvals) ] ) ) ) ]
414                      ((eq? 'define-syntax head)
415                       (##sys#check-syntax 'define-syntax x '(define-syntax variable _) se)
416                       (fini/syntax vars vals mvars mvals body) )
417                      [(eq? 'define-values head)
418                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
419                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
420                      [(eq? 'begin head)
421                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
422                       (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
423                      [else
424                       (let ([x2 (##sys#macroexpand-0 x se)])
425                         (if (eq? x x2)
426                             (fini vars vals mvars mvals body)
427                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
428      (expand body) ) ) )
429
430
431;;; A simple expression matcher
432
433(define match-expression
434  (lambda (exp pat vars)
435    (let ((env '()))
436      (define (mwalk x p)
437        (cond ((not (pair? p))
438               (cond ((assq p env) => (lambda (a) (equal? x (##sys#slot a 1))))
439                     ((memq p vars)
440                      (set! env (cons (cons p x) env))
441                      #t)
442                     (else (eq? x p)) ) )
443              ((pair? x)
444               (and (mwalk (##sys#slot x 0) (##sys#slot p 0))
445                    (mwalk (##sys#slot x 1) (##sys#slot p 1)) ) )
446              (else #f) ) )
447      (and (mwalk exp pat) env) ) ) )
448
449
450;;; Expand "curried" lambda-list syntax for `define'
451
452(define (##sys#expand-curried-define head body se)
453  (let* ([name #f]
454         (lam (macro-alias 'lambda se)))
455    (define (loop head body)
456      (if (symbol? (car head))
457          (begin
458            (set! name (car head))
459            `(,lam ,(cdr head) ,@body) )
460          (loop (car head) `((,lam ,(cdr head) ,@body)) ) ))
461    (let ([exp (loop head body)])
462      (list name exp) ) ) )
463
464
465;;; General syntax checking routine:
466
467(define ##sys#line-number-database #f)
468(define ##sys#syntax-error-culprit #f)
469
470(define (##sys#syntax-error-hook . args)
471  (apply ##sys#signal-hook #:syntax-error
472         (##sys#strip-syntax args)))
473
474(define syntax-error ##sys#syntax-error-hook)
475
476(define (get-line-number sexp)
477  (and ##sys#line-number-database
478       (pair? sexp)
479       (let ([head (car sexp)])
480         (and (symbol? head)
481              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
482                     => (lambda (pl)
483                          (let ([a (assq sexp pl)])
484                            (and a (cdr a)) ) ) ]
485                    [else #f] ) ) ) ) )
486
487(define ##sys#check-syntax
488  (let ([string-append string-append]
489        [keyword? keyword?]
490        [get-line-number get-line-number]
491        [symbol->string symbol->string] )
492    (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
493
494      (define (test x pred msg)
495        (unless (pred x) (err msg)) )
496
497      (define (err msg)
498        (let* ([sexp ##sys#syntax-error-culprit]
499               [ln (get-line-number sexp)] )
500          (##sys#syntax-error-hook
501           (if ln 
502               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
503               (string-append "(" (symbol->string id) ") " msg) )
504           exp) ) )
505
506      (define (lambda-list? x)
507        (or (##sys#extended-lambda-list? x)
508            (let loop ((x x))
509              (cond ((null? x))
510                    ((symbol? x) (not (keyword? x)))
511                    ((pair? x)
512                     (let ((s (##sys#slot x 0)))
513                       (and (symbol? s)
514                            (loop (##sys#slot x 1)) ) ) )
515                    (else #f) ) ) ) )
516
517      (define (proper-list? x)
518        (let loop ((x x))
519          (cond ((eq? x '()))
520                ((pair? x) (loop (##sys#slot x 1)))
521                (else #f) ) ) )
522
523      (when culprit (set! ##sys#syntax-error-culprit culprit))
524      (let walk ((x exp) (p pat))
525        (cond ((vector? p)
526               (let* ((p2 (##sys#slot p 0))
527                      (vlen (##sys#size p))
528                      (min (if (fx> vlen 1) 
529                               (##sys#slot p 1)
530                               0) )
531                      (max (cond ((eq? vlen 1) 1)
532                                 ((fx> vlen 2) (##sys#slot p 2))
533                                 (else 99999) ) ) )
534                 (do ((x x (##sys#slot x 1))
535                      (n 0 (fx+ n 1)) )
536                     ((eq? x '())
537                      (if (fx< n min)
538                          (err "not enough arguments") ) )
539                   (cond ((fx>= n max) 
540                          (err "too many arguments") )
541                         ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
542                          (err "not a proper list") )
543                         (else (walk (##sys#slot x 0) p2) ) ) ) ) )
544              ((##sys#immediate? p)
545               (if (not (eq? p x)) (err "unexpected object")) )
546              ((symbol? p)
547               (case p
548                 ((_) #t)
549                 ((pair) (test x pair? "pair expected"))
550                 ((variable) (test x symbol? "identifier expected"))
551                 ((symbol) (test x symbol? "symbol expected"))
552                 ((list) (test x proper-list? "proper list expected"))
553                 ((number) (test x number? "number expected"))
554                 ((string) (test x string? "string expected"))
555                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
556                 (else (test
557                        x
558                        (lambda (y)
559                          (let ((y2 (lookup y se)))
560                            (eq? (if (symbol? y2) y2 y) p)))
561                        "missing keyword")) ) )
562              ((not (pair? p))
563               (err "incomplete form") )
564              (else
565               (walk (##sys#slot x 0) (##sys#slot p 0))
566               (walk (##sys#slot x 1) (##sys#slot p 1)) ) ) ) ) ) )
567
568
569;;; explicit-renaming transformer
570
571(define ((##sys#er-transformer handler) form se dse)
572  (let ((renv '()))                     ; keep rename-environment for this expansion
573    (define (rename sym)
574      (cond ((assq sym renv) => cdr)
575            ((lookup sym se) =>
576             (lambda (a)
577               (if (symbol? a)
578                   a
579                   sym) ) )
580            (else
581             (let ((a (macro-alias sym se)))
582               (set! renv (cons (cons sym a) renv))
583               a))))
584    (define (compare s1 s2)
585      (if (and (symbol? s1) (symbol? s2))
586          (eq? (or (##sys#get s1 '##sys#macro-alias)
587                   (lookup s1 dse)
588                   s1)
589               (or (##sys#get s2 '##sys#macro-alias)
590                   (lookup s2 dse)
591                   s2) )
592          (eq? s1 s2)))
593    (handler form rename compare) ) )
594
595
596;;; transformer for normal low-level macros
597
598(define (##sys#lisp-transformer handler #!optional manyargs) 
599  (if manyargs
600      (lambda (form se dse) (handler (##sys#strip-syntax (cdr form) se)))
601      (lambda (form se dse) (apply handler (##sys#strip-syntax (cdr form) se))) ) )
602
603
604;;; Macro definitions:
605
606(##sys#extend-macro-environment
607 'define
608 '()
609 (##sys#er-transformer
610  (lambda (form r c)
611   (let loop ((form (cdr form)))
612     (let ((head (car form))
613           (body (cdr form)) )
614       (cond ((not (pair? head))
615              (##sys#check-syntax 'define head 'symbol)
616              (##sys#check-syntax 'define body '#(_ 0 1))
617              `(##core#set! ,head ,(if (pair? body) (car body) '(##sys#void))) )
618             ((pair? (##sys#slot head 0))
619              (##sys#check-syntax 'define head '(_ . lambda-list))
620              (##sys#check-syntax 'define body '#(_ 1))
621              (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
622             (else
623              (##sys#check-syntax 'define head '(symbol . lambda-list))
624              (##sys#check-syntax 'define body '#(_ 1))
625              `(##core#set!
626                ,(car head)
627                (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
628
629(##sys#extend-macro-environment
630 'and
631 '()
632 (##sys#er-transformer
633  (lambda (form r c)
634    (let ((body (cdr form)))
635      (if (null? body)
636          #t
637          (let ((rbody (cdr body))
638                (hbody (car body)) )
639            (if (null? rbody)
640                hbody
641                `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
642
643(##sys#extend-macro-environment
644 'or 
645 '()
646 (##sys#er-transformer
647  (lambda (form r c)
648    (let ((body (cdr form)))
649     (if (null? body)
650         #f
651         (let ((rbody (cdr body))
652               (hbody (car body)))
653           (if (null? rbody)
654               hbody
655               (let ((tmp (r 'tmp)))
656                 `(,(r 'let) ((,tmp ,hbody))
657                    (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
658
659(##sys#extend-macro-environment
660 'cond
661 '()
662 (##sys#er-transformer
663  (lambda (form r c)
664    (let ((body (cdr form))
665          (%begin (r 'begin))
666          (%let (r 'let))
667          (%if (r 'if))
668          (%=> (r '=>))
669          (%or (r 'or))
670          (%else (r 'else))
671          (%lambda (r 'lambda)))
672      (let expand ((clauses body))
673        (if (not (pair? clauses))
674            '(##core#undefined)
675            (let ((clause (car clauses))
676                  (rclauses (cdr clauses)) )
677              (##sys#check-syntax 'cond clause '#(_ 1))
678              (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
679                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
680                    ((c %=> (cadr clause))
681                     (let ((tmp (r 'tmp)))
682                       `(,%let ((,tmp ,(car clause)))
683                               (,%if ,tmp
684                                     (,(caddr clause) ,tmp)
685                                     ,(expand rclauses) ) ) ) )
686                    ((and (list? clause) (fx= (length clause) 4)
687                          (c %=> (caddr clause)))
688                     (let ((tmp (r 'tmp)))
689                       `(##sys#call-with-values
690                         (,%lambda () ,(car clause))
691                         (,%lambda ,tmp
692                                   (if (##sys#apply ,(cadr clause) ,tmp)
693                                       (##sys#apply ,(cadddr clause) ,tmp)
694                                       ,(expand rclauses) ) ) ) ) )
695                    (else `(,%if ,(car clause) 
696                                 (,%begin ,@(cdr clause))
697                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
698
699(##sys#extend-macro-environment
700 'case
701 '()
702 (##sys#er-transformer
703  (lambda (form r c)
704    (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
705    (let ((exp (cadr form))
706          (body (cddr form)) )
707      (let ((tmp (r 'tmp))
708            (%begin (r 'begin))
709            (%if (r 'if))
710            (%or (r 'or))
711            (%eqv? (r 'eqv?))
712            (%else (r 'else)))
713        `(let ((,tmp ,exp))
714           ,(let expand ((clauses body))
715              (if (not (pair? clauses))
716                  '(##core#undefined)
717                  (let ((clause (car clauses))
718                        (rclauses (cdr clauses)) )
719                    (##sys#check-syntax 'case clause '#(_ 1))
720                    (if (c %else (car clause))
721                        `(,%begin ,@(cdr clause))
722                        `(,%if (,%or ,@(##sys#map
723                                        (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
724                               (,%begin ,@(cdr clause)) 
725                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
726
727(##sys#extend-macro-environment
728 'let*
729 '()
730 (##sys#er-transformer
731  (lambda (form r c)
732    (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
733    (let ((bindings (cadr form))
734          (body (cddr form)) 
735          (%let (r 'let)))
736      (let expand ((bs bindings))
737        (if (eq? bs '())
738            `(,%let () ,@body)
739            `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
740
741(##sys#extend-macro-environment
742 'letrec
743 '()
744 (##sys#er-transformer
745  (lambda (form r c)
746    (##sys#check-syntax 'letrec _ '(_ #((symbol _) 0) . #(_ 1)))
747    (let ((bindings (cadr form))
748          (body (cddr form)) 
749          (%let (r 'let)) )
750      `(,%let ,(##sys#map (lambda (b) (list (car b) '(##core#undefined))) bindings)
751              ,@(##sys#map (lambda (b) `(##core#set! ,(car b) ,(cadr b))) bindings)
752              (,%let () ,@body) ) ) ) ) )
753
754(##sys#extend-macro-environment
755 'do
756 '()
757 (##sys#er-transformer
758  (lambda (form r c)
759    (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
760    (let ((bindings (cadr form))
761          (test (caddr form))
762          (body (cdddr form))
763          (dovar (r 'doloop))
764          (%let (r 'let))
765          (%if (r 'if))
766          (%begin (r 'begin)))
767      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
768              (,%if ,(car test)
769                    ,(let ((tbody (cdr test)))
770                       (if (eq? tbody '())
771                           '(##core#undefined)
772                           `(,%begin ,@tbody) ) )
773                    (,%begin
774                     ,(if (eq? body '())
775                          '(##core#undefined)
776                          `(,%let () ,@body) )
777                     (##core#app
778                      ,dovar ,@(##sys#map (lambda (b) 
779                                            (if (eq? (cdr (cdr b)) '())
780                                                (car b)
781                                                (car (cdr (cdr b))) ) )
782                                          bindings) ) ) ) ) ) ) ) )
783
784(##sys#extend-macro-environment
785 'quasiquote
786 '()
787 (##sys#er-transformer
788  (lambda (form r c)
789    (let ((%quote (r 'quote))
790          (%quasiquote (r 'quasiquote))
791          (%unquote (r 'unquote))
792          (%unquote-splicing (r 'unquote-splicing)))
793      (define (walk x n) (simplify (walk1 x n)))
794      (define (walk1 x n)
795        (cond ((vector? x)
796               `(##sys#list->vector ,(walk (vector->list x) n)) )
797              ((not (pair? x)) `(,%quote ,x))
798              (else
799               (let ((head (car x))
800                     (tail (cdr x)))
801                 (cond ((c %unquote head)
802                        (if (pair? tail)
803                            (let ((hx (car tail)))
804                              (if (eq? n 0)
805                                  hx
806                                  (list '##sys#list `(,%quote ,%unquote)
807                                        (walk hx (fx- n 1)) ) ) )
808                            `(,%quote ,%unquote) ) )
809                       ((c %quasiquote head)
810                        (if (pair? tail)
811                            `(##sys#list (,%quote ,%quasiquote) 
812                                         ,(walk (car tail) (fx+ n 1)) ) 
813                            (list '##sys#cons (list %quote %quasiquote) 
814                                  (walk tail n)) ) )
815                       ((pair? head)
816                        (let ((hx (car head))
817                              (tx (cdr head)))
818                          (if (and (c hx %unquote-splicing) (pair? tx))
819                              (let ((htx (car tx)))
820                                (if (eq? n 0)
821                                    `(##sys#append ,htx
822                                                   ,(walk tail n) )
823                                    `(##sys#cons (##sys#list %unquote-splicing
824                                                             ,(walk htx (fx- n 1)) )
825                                                 ,(walk tail n) ) ) )
826                              `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
827                       (else
828                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
829      (define (simplify x)
830        (cond ((match-expression x '(##sys#cons a '()) '(a))
831               => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
832              ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
833               => (lambda (env)
834                    (let ([bxs (assq 'b env)])
835                      (if (fx< (length bxs) 32)
836                          (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
837                                                 ,@(##sys#slot bxs 1) ) ) 
838                          x) ) ) )
839              ((match-expression x '(##sys#append a '()) '(a))
840               => (lambda (env) (##sys#slot (assq 'a env) 1)) )
841              (else x) ) )
842      (##sys#check-syntax 'quasiquote form '(_ _))
843      (walk (cadr form) 0) ) ) ) )
844
845(##sys#extend-macro-environment
846 'delay
847 '()
848 (##sys#er-transformer
849  (lambda (form r c)
850    (##sys#check-syntax 'delay form '(_ _))
851    `(##sys#make-promise (lambda () ,(cadr form))))))
852
853(##sys#extend-macro-environment
854 'cond-expand
855 '()
856 (##sys#er-transformer
857  (lambda (form r c)
858    (let ((clauses (cdr form))
859          (%or (r 'or))
860          (%not (r 'not))
861          (%else (r 'else))
862          (%begin (r 'begin))
863          (%and (r 'and)))
864      (define (err x) 
865        (##sys#error "syntax error in `cond-expand' form"
866                     x
867                     (cons 'cond-expand clauses)) )
868      (define (test fx)
869        (cond ((symbol? fx) (##sys#feature? fx))
870              ((not (pair? fx)) (err fx))
871              (else
872               (let ((head (car fx))
873                     (rest (cdr fx)))
874                 (cond ((c %and head)
875                        (or (eq? rest '())
876                            (if (pair? rest)
877                                (and (test (car rest))
878                                     (test `(,%and ,@(cdr rest))) )
879                                (err fx) ) ) )
880                       ((c %or head)
881                        (and (not (eq? rest '()))
882                             (if (pair? rest)
883                                 (or (test (car rest))
884                                     (test `(,%or ,@(cdr rest))) )
885                                 (err fx) ) ) )
886                       ((c %not head) (not (test (cadr fx))))
887                       (else (err fx)) ) ) ) ) )
888      (let expand ((cls clauses))
889        (cond ((eq? cls '())
890               (##sys#apply
891                ##sys#error "no matching clause in `cond-expand' form" 
892                (map (lambda (x) (car x)) clauses) ) )
893              ((not (pair? cls)) (err cls))
894              (else
895               (let ((clause (car cls))
896                    (rclauses (cdr cls)) )
897                 (if (not (pair? clause)) 
898                     (err clause)
899                     (let ((id (car clause)))
900                       (cond ((c id %else)
901                              (let ((rest (cdr clause)))
902                                (if (eq? rest '())
903                                    '(##core#undefined)
904                                    `(,%begin ,@rest) ) ) )
905                             ((test id) `(,%begin ,@(cdr clause)))
906                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
907
908(##sys#extend-macro-environment         ;*** keep this?
909 'define-macro
910 '()
911 (##sys#er-transformer
912  (lambda (form r c)
913    (##sys#check-syntax 'define-macro form '(_ . #(_ 1)))
914    (let ((head (cadr form))
915          (body (cddr form))
916          (%lambda (r 'lambda)))
917      (define (expand name val)
918        `(,(if ##sys#enable-runtime-macros
919               '##core#elaborationtimetoo 
920               '##core#elaborationtimeonly)
921          ,(if (symbol? val)
922               `(##sys#copy-macro ',val ',name)
923               `(##sys#extend-macro-environment
924                 ',name
925                 (##sys#current-environment)
926                 (##sys#lisp-transformer ,val)))))
927      (cond ((symbol? head)
928             (##sys#check-syntax 'define-macro body '(_))
929             (expand head (car body)) )
930            (else
931             (##sys#check-syntax 'define-macro head '(symbol . lambda-list))
932             (##sys#check-syntax 'define-macro body '#(_ 1)) 
933             (expand (car head) `(,%lambda ,(cdr head) ,@body))))))))
934
935(##sys#extend-macro-environment
936 'require-extension
937 '()
938 (##sys#er-transformer
939  (lambda (x r c)
940    (let ((ids (cdr x))
941          (%quote (r 'quote)))
942      (##sys#check-syntax 'require-extension ids '#(_ 0))
943      `(##core#require-extension 
944        ,@(map (lambda (x) (list %quote x)) ids) ) ) ) ))
945
946(##sys#extend-macro-environment
947 'define-syntax
948 '()
949 (lambda (form se dse)
950   (##sys#check-syntax 'define-syntax form '(define-syntax variable _) #f se)
951   `(,(if ##sys#enable-runtime-macros '##core#elaborationtimetoo '##core#elaborationtimeonly)
952     (##sys#extend-macro-environment
953      ',(cadr form)
954      (##sys#current-environment)
955      (##sys#er-transformer ,(caddr form))))))
956
957
958;;;*** only for backwards compatibility (will break for high argument counts)
959
960(define (##sys#register-macro name h)
961  (##sys#extend-macro-environment
962   name '() 
963   (##sys#lisp-transformer h) ) )
964
965(define (##sys#register-macro-2 name h2)
966  (##sys#extend-macro-environment
967   name '()
968   (##sys#lisp-transformer
969    (lambda body (h2 body)))))
970
971
972;;; syntax-rules
973
974(include "synrules.scm")
Note: See TracBrowser for help on using the repository browser.