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

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

low-level module attempt; converted some more macros

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