source: project/chicken/branches/hygienic/expand.scm @ 11919

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

case macro uses qualified version if eqv?

File size: 49.0 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 module-indirect-exports
33        d dd dm map-se merge-se
34        lookup check-for-redef) )
35
36
37(set! ##sys#features
38  (append '(#:hygienic-macros #:syntax-rules) ##sys#features))
39
40(define (d arg1 . more)
41  (when (##sys#fudge 13)
42    (if (null? more)
43        (pp arg1)
44        (apply print arg1 more))) )
45
46(define dd d)
47(define dm d)
48
49(cond-expand
50 ((not debugbuild)
51  (cond-expand
52   (hygienic-macros
53    (define-syntax dd (syntax-rules () ((_ . _) (void)))))
54   (else                                        ;*** remove later
55    (define-macro (dd . _) '(void))))
56  (cond-expand
57   (hygienic-macros
58    (define-syntax dm (syntax-rules () ((_ . _) (void)))))
59   (else                                        ;*** remove later
60    (define-macro (dm . _) '(void)))))
61 (else))
62
63
64;;; Syntactic environments
65
66(define ##sys#current-environment (make-parameter '()))
67(define ##sys#current-meta-environment (make-parameter '()))
68
69(define (lookup id se)
70  (cond ((assq id se) => cdr)
71        ((##sys#get id '##core#macro-alias))
72        (else #f)))
73
74(define (macro-alias var se)
75  (if (or (##sys#qualified-symbol? var)
76          (let* ((str (##sys#slot var 1))
77                 (len (##sys#size str)))
78            (and (fx> len 0)
79                 (char=? #\# (##core#inline "C_subchar" str 0)))))
80      var
81      (let* ((alias (gensym var))
82             (ua (or (lookup var se) var)))
83        (##sys#put! alias '##core#macro-alias ua)
84        (dd "aliasing " alias " to " 
85            (if (pair? ua)
86                '<macro>
87                ua))
88        alias) ) )
89
90(define (map-se se)
91  (map (lambda (a) 
92         (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
93       se))
94
95(define (##sys#strip-syntax exp #!optional se)
96  ;; if se is given, retain bound vars
97  (let walk ((x exp))
98    (cond ((symbol? x)
99           (let ((x2 (if se 
100                         (lookup x se)
101                         (get x '##core#macro-alias) ) ) )
102             (cond ((not x2) x)
103                   ((pair? x2) x)
104                   (else x2))))
105          ((pair? x)
106           (cons (walk (##sys#slot x 0))
107                 (walk (cdr x))))
108          ((vector? x)
109           (list->vector (map walk (vector->list x))))
110          (else x))))
111
112(define strip-syntax ##sys#strip-syntax)
113
114
115;;; Macro handling
116
117(define ##sys#macro-environment (make-parameter '()))
118(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
119(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
120
121(define (##sys#extend-macro-environment name se handler)
122  (let ((me (##sys#macro-environment)))
123    (cond ((lookup name me) =>
124           (lambda (a)
125             (set-car! a se)
126             (set-car! (cdr a) handler) ) )
127          (else
128           (##sys#macro-environment
129            (cons (list name se handler)
130                  me))))))
131
132(define (##sys#copy-macro old new)
133  (let ((def (lookup old (##sys#macro-environment))))
134    (apply ##sys#extend-macro-environment new def) ) )
135
136(define (macro? sym #!optional (senv (##sys#current-environment)))
137  (##sys#check-symbol sym 'macro?)
138  (##sys#check-list senv 'macro?)
139  (or (let ((l (lookup sym senv)))
140        (pair? l))
141      (and-let* ((l (lookup sym (##sys#macro-environment))))
142        (pair? l))))
143
144(define (##sys#unregister-macro name)
145  (##sys#macro-environment
146    ;; this builds up stack, but isn't used often anyway...
147    (let loop ((me (##sys#macro-environment)) (me2 '()))
148      (cond ((null? me) '())
149            ((eq? name (caar me)) (cdr me))
150            (else (cons (car me) (loop (cdr me))))))))
151
152(define (undefine-macro! name)
153  (##sys#check-symbol name 'undefine-macro!)
154  (##sys#unregister-macro name) )
155
156
157;; The basic macro-expander
158
159(define (##sys#expand-0 exp dse)
160  (define (call-handler name handler exp se)
161    (dd "invoking macro: " name)
162    (dd `(STATIC-SE: ,@(map-se se)))
163    (handle-exceptions ex
164        ;; modify error message in condition object to include
165        ;; currently expanded macro-name
166        (##sys#abort
167         (if (and (##sys#structure? ex 'condition)
168                  (memv 'exn (##sys#slot ex 1)) )
169             (##sys#make-structure
170              'condition
171              (##sys#slot ex 1)
172              (let copy ([ps (##sys#slot ex 2)])
173                (if (null? ps)
174                    '()
175                    (let ([p (car ps)]
176                          [r (cdr ps)])
177                      (if (and (equal? '(exn . message) p)
178                               (pair? r)
179                               (string? (car r)) )
180                          (cons
181                           '(exn . message)
182                           (cons (string-append
183                                  "during expansion of ("
184                                  (##sys#slot name 1) 
185                                  " ...) - "
186                                  (car r) )
187                                 (cdr r) ) )
188                          (copy r) ) ) ) ) )
189             ex) )
190      (let ((exp2 (handler exp se dse)))
191        (dd `(,name --> ,exp2))
192        exp2)))
193  (define (expand head exp mdef)
194    (dd `(EXPAND: 
195          ,head 
196          ,(cond ((get head '##core#macro-alias) =>
197                  (lambda (a) (if (symbol? a) a '<macro>)) )
198                 (else '_))
199          ,exp 
200          ,(if (pair? mdef)
201               `(SE: ,@(map-se (car mdef)))
202               mdef)))
203    (cond ((not (list? exp))
204           (##sys#syntax-error-hook "invalid syntax in macro form" exp) )
205          ((pair? mdef)
206           (values
207            ;; force ref. opaqueness by passing dynamic se  [what is this comment meaning? I forgot]
208            (call-handler head (cadr mdef) exp (car mdef))
209            #t))
210          (else (values exp #f)) ) )
211  (if (pair? exp)
212      (let ((head (car exp))
213            (body (cdr exp)) )
214        (if (symbol? head)
215            (let ((head2 (or (lookup head dse) head)))
216              (unless (pair? head2)
217                (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
218              (cond [(memq head2 '(let ##core#let))
219                     (##sys#check-syntax 'let body '#(_ 2) #f dse)
220                     (let ([bindings (car body)])
221                       (cond [(symbol? bindings)
222                              (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
223                              (let ([bs (cadr body)])
224                                (values
225                                 `(##core#app
226                                   (##core#letrec
227                                    ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
228                                    ,bindings)
229                                   ,@(##sys#map cadr bs) )
230                                 #t) ) ]
231                             [else (values exp #f)] ) ) ]
232                    [(and (memq head2 '(set! ##core#set!))
233                          (pair? body)
234                          (pair? (car body)) )
235                     (let ([dest (car body)])
236                       (##sys#check-syntax 'set! body '(#(_ 1) _) #f dse)
237                       (values
238                        (append (list (list '##sys#setter (car dest)))
239                                (cdr dest)
240                                (cdr body) ) 
241                        #t) ) ]
242                    [else (expand head exp head2)] ) )
243            (values exp #f) ) )
244      (values exp #f) ) )
245
246(define ##sys#enable-runtime-macros #f)
247
248(define (##sys#module-rename sym prefix)
249  (##sys#string->symbol 
250   (string-append
251    (##sys#slot prefix 1)
252    "#" 
253    (##sys#slot sym 1) ) ) )
254
255(define (##sys#alias-global-hook sym assign)
256  (define (mrename sym)
257    (cond ((##sys#current-module) =>
258           (lambda (mod)
259             (dm "(ALIAS) global alias " sym " -> " (module-name mod))
260             (unless assign (##sys#register-undefined sym mod))
261             (##sys#module-rename sym (module-name mod))))
262          (else sym)))
263  (cond ((##sys#qualified-symbol? sym) sym)
264        ((##sys#get sym '##core#primitive) =>
265         (lambda (p)
266           (dm "(ALIAS) primitive: " p)
267           p))
268        ((##sys#get sym '##core#aliased) 
269         (dm "(ALIAS) marked: " sym)
270         sym)
271        ((assq sym (##sys#current-environment)) =>
272         (lambda (a)
273           (dm "(ALIAS) in current environment: " sym)
274           (let ((sym2 (cdr a)))
275             (if (pair? sym2)           ; macro (*** can this be?)
276                 (mrename sym)
277                 (or (##sys#get sym2 '##core#primitive) sym2)))))
278        (else (mrename sym))))
279
280
281;;; User-level macroexpansion
282
283(define (##sys#expand exp #!optional (se (##sys#current-environment)))
284  (let loop ((exp exp))
285    (let-values (((exp2 m) (##sys#expand-0 exp se)))
286      (if m
287          (loop exp2)
288          exp2) ) ) )
289
290(define expand ##sys#expand)
291
292
293;;; Extended (DSSSL-style) lambda lists
294;
295; Assumptions:
296;
297; 1) #!rest must come before #!key
298; 2) default values may refer to earlier variables
299; 3) optional/key args may be either variable or (variable default)
300; 4) an argument marker may not be specified more than once
301; 5) no special handling of extra keywords (no error)
302; 6) default value of optional/key args is #f
303; 7) mixing with dotted list syntax is allowed
304
305(define (##sys#extended-lambda-list? llist)
306  (let loop ([llist llist])
307    (and (pair? llist)
308         (case (##sys#slot llist 0)
309           [(#!rest #!optional #!key) #t]
310           [else (loop (cdr llist))] ) ) ) )
311
312(define ##sys#expand-extended-lambda-list
313  (let ([reverse reverse]
314        [gensym gensym] )
315    (lambda (llist0 body errh se)
316      (define (err msg) (errh msg llist0))
317      (define (->keyword s) (string->keyword (##sys#slot s 1)))
318      (let ([rvar #f]
319            [hasrest #f] 
320            (%let* (macro-alias 'let* se))
321            (%lambda '##core#lambda)
322            (%opt (macro-alias 'optional se))
323            (%let-optionals (macro-alias 'let-optionals se))
324            (%let-optionals* (macro-alias 'let-optionals* se))
325            (%let (macro-alias 'let se)))
326        (let loop ([mode 0]             ; req, opt, rest, key, end
327                   [req '()]
328                   [opt '()]
329                   [key '()] 
330                   [llist llist0] )
331          (cond [(null? llist)
332                 (values
333                  (if rvar (##sys#append (reverse req) rvar) (reverse req))
334                  (let ([body 
335                         (if (null? key)
336                             body
337                             `((,%let*
338                                ,(map (lambda (k)
339                                        (let ([s (car k)])
340                                          `(,s (##sys#get-keyword 
341                                                ',(->keyword s) ,rvar
342                                                ,@(if (pair? (cdr k)) 
343                                                      `((,%lambda () ,@(cdr k)))
344                                                      '() ) ) ) ) )
345                                      (reverse key) )
346                                ,@body) ) ) ] )
347                    (cond [(null? opt) body]
348                          [(and (not hasrest) (null? key) (null? (cdr opt)))
349                           `((,%let
350                              ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
351                              ,@body) ) ]
352                          [(and (not hasrest) (null? key))
353                           `((,%let-optionals
354                              ,rvar ,(reverse opt) ,@body))]
355                          [else
356                           `((,%let-optionals*
357                              ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar))) 
358                              ,@body))] ) ) ) ]
359                [(symbol? llist) 
360                 (if (fx> mode 2)
361                     (err "rest argument list specified more than once")
362                     (begin
363                       (if (not rvar) (set! rvar llist))
364                       (set! hasrest llist)
365                       (loop 4 req opt '() '()) ) ) ]
366                [(not (pair? llist))
367                 (err "invalid lambda list syntax") ]
368                [else
369                 (let* ((var (car llist))
370                        (x (or (and (symbol? var) (lookup var se)) var))
371                        (r (cdr llist)))
372                   (case x
373                     [(#!optional)
374                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
375                      (if (eq? mode 0)
376                          (loop 1 req '() '() r)
377                          (err "`#!optional' argument marker in wrong context") ) ]
378                     [(#!rest)
379                      (if (fx<= mode 1)
380                          (if (and (pair? r) (symbol? (car r)))
381                              (begin
382                                (if (not rvar) (set! rvar (car r)))
383                                (set! hasrest (car r))
384                                (loop 2 req opt '() (cdr r)) )
385                              (err "invalid syntax of `#!rest' argument") ) 
386                          (err "`#!rest' argument marker in wrong context") ) ]
387                     [(#!key)
388                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
389                      (if (fx<= mode 3)
390                          (loop 3 req opt '() r)
391                          (err "`#!key' argument marker in wrong context") ) ]
392                     [else
393                      (cond [(symbol? x)
394                             (case mode
395                               [(0) (loop 0 (cons x req) '() '() r)]
396                               [(1) (loop 1 req (cons (list x #f) opt) '() r)]
397                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
398                               [else (loop 3 req opt (cons (list x) key) r)] ) ]
399                            [(and (list? x) (eq? 2 (length x)))
400                             (case mode
401                               [(0) (err "invalid required argument syntax")]
402                               [(1) (loop 1 req (cons x opt) '() r)]
403                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
404                               [else (loop 3 req opt (cons x key) r)] ) ]
405                            [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
406
407
408;;; Expansion of bodies (and internal definitions)
409
410(define ##sys#canonicalize-body
411  (let ([reverse reverse]
412        [map map] )
413    (lambda (body #!optional (se (##sys#current-environment)))
414      (define (fini vars vals mvars mvals body)
415        (if (and (null? vars) (null? mvars))
416            (let loop ([body2 body] [exps '()])
417              (if (not (pair? body2)) 
418                  (cons
419                   (macro-alias 'begin se)
420                   body) ; no more defines, otherwise we would have called `expand'
421                  (let ([x (car body2)])
422                    (if (and (pair? x) 
423                             (let ((d (car x)))
424                               (and (symbol? d)
425                                    (or (eq? (or (lookup d se) d) 'define)
426                                        (eq? (or (lookup d se) d) 'define-values)))) )
427                        (cons
428                         (macro-alias 'begin se)
429                         (##sys#append (reverse exps) (list (expand body2))))
430                        (loop (cdr body2) (cons x exps)) ) ) ) )
431            (let* ((vars (reverse vars))
432                   (result 
433                    `(##core#let
434                      ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
435                                  (apply ##sys#append vars mvars) )
436                      ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
437                      ,@(map (lambda (vs x)
438                               (let ([tmps (##sys#map gensym vs)])
439                                 `(##sys#call-with-values
440                                   (##core#lambda () ,x)
441                                   (##core#lambda
442                                    ,tmps 
443                                    ,@(map (lambda (v t)
444                                             `(##core#set! ,v ,t)) 
445                                           vs tmps) ) ) ) ) 
446                             (reverse mvars)
447                             (reverse mvals) )
448                      ,@body) ) )
449              (dd `(BODY: ,result))
450              result)))
451      (define (fini/syntax vars vals mvars mvals body)
452        (fini
453         vars vals mvars mvals
454         (let loop ((body body) (defs '()) (done #f))
455           (cond (done `((,(macro-alias 'letrec-syntax se)
456                          ,(map cdr (reverse defs)) ,@body) ))
457                 ((not (pair? body)) (loop body defs #t))
458                 ((and (list? (car body))
459                       (>= 3 (length (car body))) 
460                       (symbol? (caar body))
461                       (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
462                  (let ((def (car body)))
463                    (loop 
464                     (cdr body) 
465                     (cons (if (pair? (cadr def))
466                               `(define-syntax ,(caadr def) (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
467                               def)
468                           defs) 
469                     #f)))
470                 (else (loop body defs #t))))))               
471      (define (expand body)
472        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
473          (if (not (pair? body))
474              (fini vars vals mvars mvals body)
475              (let* ((x (car body))
476                     (rest (cdr body))
477                     (exp1 (and (pair? x) (car x)))
478                     (head (and exp1
479                                (symbol? exp1)
480                                (or (lookup exp1 se) exp1))))
481                (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
482                      [(eq? 'define head)
483                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
484                       (let loop2 ([x x])
485                         (let ([head (cadr x)])
486                           (cond [(not (pair? head))
487                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
488                                  (loop rest (cons head vars)
489                                        (cons (if (pair? (cddr x))
490                                                  (caddr x)
491                                                  '(##core#undefined) )
492                                              vals)
493                                        mvars mvals) ]
494                                 [(pair? (car head))
495                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
496                                  (loop2 (cons (macro-alias 'define se)
497                                               (##sys#expand-curried-define head (cddr x) se))) ]
498                                 [else
499                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
500                                  (loop rest
501                                        (cons (car head) vars)
502                                        (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
503                                        mvars mvals) ] ) ) ) ]
504                      ((eq? 'define-syntax head)
505                       (##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
506                       (fini/syntax vars vals mvars mvals body) )
507                      [(eq? 'define-values head)
508                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
509                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
510                      [(eq? 'begin head)
511                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
512                       (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
513                      ((or (memq head vars) (memq head mvars))
514                       (fini vars vals mvars mvals body))
515                      [else
516                       (let ([x2 (##sys#expand-0 x se)])
517                         (if (eq? x x2)
518                             (fini vars vals mvars mvals body)
519                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
520      (expand body) ) ) )
521
522
523;;; A simple expression matcher
524
525(define match-expression
526  (lambda (exp pat vars)
527    (let ((env '()))
528      (define (mwalk x p)
529        (cond ((not (pair? p))
530               (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
531                     ((memq p vars)
532                      (set! env (cons (cons p x) env))
533                      #t)
534                     (else (eq? x p)) ) )
535              ((pair? x)
536               (and (mwalk (car x) (car p))
537                    (mwalk (cdr x) (cdr p)) ) )
538              (else #f) ) )
539      (and (mwalk exp pat) env) ) ) )
540
541
542;;; Expand "curried" lambda-list syntax for `define'
543
544(define (##sys#expand-curried-define head body se)
545  (let ((name #f))
546    (define (loop head body)
547      (if (symbol? (car head))
548          (begin
549            (set! name (car head))
550            `(##core#lambda ,(cdr head) ,@body) )
551          (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))
552    (let ([exp (loop head body)])
553      (list name exp) ) ) )
554
555
556;;; General syntax checking routine:
557
558(define ##sys#line-number-database #f)
559(define ##sys#syntax-error-culprit #f)
560
561(define (##sys#syntax-error-hook . args)
562  (apply ##sys#signal-hook #:syntax-error
563         (##sys#strip-syntax args)))
564
565(define syntax-error ##sys#syntax-error-hook)
566
567(define (get-line-number sexp)
568  (and ##sys#line-number-database
569       (pair? sexp)
570       (let ([head (car sexp)])
571         (and (symbol? head)
572              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
573                     => (lambda (pl)
574                          (let ([a (assq sexp pl)])
575                            (and a (cdr a)) ) ) ]
576                    [else #f] ) ) ) ) )
577
578(define ##sys#check-syntax
579  (let ([string-append string-append]
580        [keyword? keyword?]
581        [get-line-number get-line-number]
582        [symbol->string symbol->string] )
583    (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
584
585      (define (test x pred msg)
586        (unless (pred x) (err msg)) )
587
588      (define (err msg)
589        (let* ([sexp ##sys#syntax-error-culprit]
590               [ln (get-line-number sexp)] )
591          (##sys#syntax-error-hook
592           (if ln 
593               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
594               (string-append "(" (symbol->string id) ") " msg) )
595           exp) ) )
596
597      (define (lambda-list? x)
598        (or (##sys#extended-lambda-list? x)
599            (let loop ((x x))
600              (cond ((null? x))
601                    ((symbol? x) (not (keyword? x)))
602                    ((pair? x)
603                     (let ((s (car x)))
604                       (and (symbol? s)
605                            (loop (cdr x)) ) ) )
606                    (else #f) ) ) ) )
607
608      (define (proper-list? x)
609        (let loop ((x x))
610          (cond ((eq? x '()))
611                ((pair? x) (loop (cdr x)))
612                (else #f) ) ) )
613
614      (when culprit (set! ##sys#syntax-error-culprit culprit))
615      (let walk ((x exp) (p pat))
616        (cond ((vector? p)
617               (let* ((p2 (vector-ref p 0))
618                      (vlen (##sys#size p))
619                      (min (if (fx> vlen 1) 
620                               (vector-ref p 1)
621                               0) )
622                      (max (cond ((eq? vlen 1) 1)
623                                 ((fx> vlen 2) (vector-ref p 2))
624                                 (else 99999) ) ) )
625                 (do ((x x (cdr x))
626                      (n 0 (fx+ n 1)) )
627                     ((eq? x '())
628                      (if (fx< n min)
629                          (err "not enough arguments") ) )
630                   (cond ((fx>= n max) 
631                          (err "too many arguments") )
632                         ((not (pair? x))
633                          (err "not a proper list") )
634                         (else (walk (car x) p2) ) ) ) ) )
635              ((##sys#immediate? p)
636               (if (not (eq? p x)) (err "unexpected object")) )
637              ((symbol? p)
638               (case p
639                 ((_) #t)
640                 ((pair) (test x pair? "pair expected"))
641                 ((variable) (test x symbol? "identifier expected"))
642                 ((symbol) (test x symbol? "symbol expected"))
643                 ((list) (test x proper-list? "proper list expected"))
644                 ((number) (test x number? "number expected"))
645                 ((string) (test x string? "string expected"))
646                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
647                 (else
648                  (test
649                   x
650                   (lambda (y)
651                     (let ((y2 (and (symbol? y) (lookup y se))))
652                       (eq? (if (symbol? y2) y2 y) p)))
653                   "missing keyword")) ) )
654              ((not (pair? p))
655               (err "incomplete form") )
656              ((not (pair? x)) (err "pair expected"))
657              (else
658               (walk (car x) (car p))
659               (walk (cdr x) (cdr p)) ) ) ) ) ) )
660
661
662;;; explicit-renaming transformer
663
664(define ((##sys#er-transformer handler) form se dse)
665  (let ((renv '()))                     ; keep rename-environment for this expansion
666    (define (rename sym)
667      (cond ((assq sym renv) =>
668             (lambda (a) 
669               (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
670               (cdr a)))
671            ((lookup sym se) =>
672             (lambda (a)
673               (cond ((symbol? a)
674                      (dd `(RENAME/LOOKUP: ,sym --> ,a))
675                      a)
676                     (else
677                      (let ((a2 (macro-alias sym se)))
678                        (dd `(RENAME/LOOKUP/MACRO: ,sym --> ,a2))
679                        (set! renv (cons (cons sym a2) renv))
680                        a2)))))
681            (else
682             (let ((a (macro-alias sym se)))
683               (dd `(RENAME: ,sym --> ,a))
684               (set! renv (cons (cons sym a) renv))
685               a))))
686    (define (compare s1 s2)
687      (let ((result
688             (if (and (symbol? s1) (symbol? s2))
689                 (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
690                                (lookup2 1 s1 dse)
691                                s1) )
692                       (ss2 (or (##sys#get s2 '##core#macro-alias)
693                                (lookup2 2 s2 dse)
694                                s2) ) )
695                   (cond ((symbol? ss1)
696                          (cond ((symbol? ss2) 
697                                 (eq? (or (##sys#get ss1 '##core#primitive) ss1)
698                                      (or (##sys#get ss2 '##core#primitive) ss2)))
699                                ((assq ss1 (##sys#macro-environment)) =>
700                                 (lambda (a) (eq? (cdr a) ss2)))
701                                (else #f) ) )
702                         ((symbol? ss2)
703                          (cond ((assq ss2 (##sys#macro-environment)) =>
704                                 (lambda (a) (eq? ss1 (cdr a))))
705                                (else #f)))
706                         (else (eq? ss1 ss2))))
707                 (eq? s1 s2))) )
708        (dd `(COMPARE: ,s1 ,s2 --> ,result)) 
709        result))
710    (define (lookup2 n sym dse)
711      (let ((r (lookup sym dse)))
712        (dd "  (lookup/DSE " (list n) ": " sym " --> " 
713            (if (and r (pair? r))
714                '<macro>
715                r)
716            ")")
717        r))
718    (handler form rename compare) ) )
719
720
721;;; Macro definitions:
722
723(define (##sys#expand-import x r c import-env macro-env meta? loc)
724  (let ((%only (r 'only))
725        (%rename (r 'rename))
726        (%except (r 'except))
727        (%prefix (r 'prefix)))
728    (define (resolve sym)
729      (or (lookup sym '()) sym))        ;*** empty se?
730    (define (tostr x)
731      (cond ((string? x) x)
732            ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; why not?
733            ((symbol? x) (##sys#symbol->string x))
734            ((number? x) (number->string x))
735            (else (syntax-error loc "invalid prefix" ))))
736    (define (import-name spec)
737      (let* ((mname (resolve spec))
738             (mod (##sys#find-module mname #f)))
739        (unless mod
740          (let ((il (##sys#find-extension 
741                     (string-append (symbol->string mname) ".import")
742                     #t)))
743            (cond (il (parameterize ((##sys#current-module #f)
744                                     (##sys#current-environment '())
745                                     (##sys#current-meta-environment (##sys#current-meta-environment))
746                                     (##sys#macro-environment (##sys#meta-macro-environment)))
747                        (##sys#load il #f #f))
748                      (set! mod (##sys#find-module mname)))
749                  (else
750                   (syntax-error
751                    loc "can not import from undefined module" 
752                    mname)))))
753        (let ((vexp (module-vexports mod))
754              (sexp (module-sexports mod)))
755          (cons vexp sexp))))     
756    (define (import-spec spec)
757      (cond ((symbol? spec) (import-name spec))
758            ((or (not (list? spec)) (< (length spec) 2))
759             (syntax-error loc "invalid import specification" spec))
760            (else
761             (let* ((s (car spec))
762                    (imp (import-spec (cadr spec)))
763                    (impv (car imp))
764                    (imps (cdr imp)))
765               (cond ((c %only (car spec))
766                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
767                      (let ((ids (map resolve (cddr spec))))
768                        (let loop ((ids ids) (v '()) (s '()))
769                          (cond ((null? ids) (cons v s))
770                                ((assq (car ids) impv) =>
771                                 (lambda (a) 
772                                   (loop (cdr ids) (cons a v) s)))
773                                ((assq (car ids) imps) =>
774                                 (lambda (a) 
775                                   (loop (cdr ids) v (cons a s))))
776                                (else (loop (cdr ids) v s))))))
777                     ((c %except (car spec))
778                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
779                      (let ((ids (map resolve (cddr spec))))
780                        (let loop ((impv impv) (v '()))
781                          (cond ((null? impv)
782                                 (let loop ((imps imps) (s '()))
783                                   (cond ((null? imps) (cons v s))
784                                         ((memq (caar imps) ids) (loop (cdr imps) s))
785                                         (else (loop (cdr imps) (cons (car imps) s))))))
786                                ((memq (caar impv) ids) (loop (cdr impv) v))
787                                (else (loop (cdr impv) (cons (car impv) v)))))))
788                     ((c %rename (car spec))
789                      (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
790                      (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
791                        (cond ((null? impv) 
792                               (cond ((null? imps)
793                                      (for-each
794                                       (lambda (id)
795                                         (##sys#warn "renamed identifier not imported" id) )
796                                       ids)
797                                      (cons v s))
798                                     ((assq (caar imps) ids) =>
799                                      (lambda (a)
800                                        (loop impv (cdr imps)
801                                              v
802                                              (cons (cons (cadr a) (cdar imps)) s)
803                                              (##sys#delq a ids))))
804                                     (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
805                              ((assq (caar impv) ids) =>
806                               (lambda (a)
807                                 (loop (cdr impv) imps
808                                       (cons (cons (cadr a) (cdar impv)) v)
809                                       s
810                                       (##sys#delq a ids))))
811                              (else (loop (cdr impv) imps
812                                          (cons (car impv) v)
813                                          s ids)))))
814                     ((c %prefix (car spec))
815                      (##sys#check-syntax loc spec '(_ _ _))
816                      (let ((pref (tostr (caddr spec))))
817                        (define (ren imp)
818                          (cons
819                           (##sys#string->symbol 
820                            (##sys#string-append pref (##sys#symbol->string (car imp))) )
821                           (cdr imp) ) )
822                        (cons (map ren impv) (map ren imps))))
823                     (else (syntax-error loc "invalid import specification" spec)))))))
824    (##sys#check-syntax loc x '(_ . #(_ 1)))
825    (let ((cm (##sys#current-module)))
826      (when cm
827        ;; save import form
828        (if meta?
829            (set-module-meta-import-forms! 
830             cm
831             (append (module-meta-import-forms cm) (cdr x)))
832            (set-module-import-forms!
833             cm 
834             (append (module-import-forms cm) (cdr x)))))
835      (for-each
836       (lambda (spec)
837         (let* ((vs (import-spec spec))
838                (vsv (car vs))
839                (vss (cdr vs)))
840           (dd `(IMPORT: ,loc))
841           (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
842           (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
843           (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
844           (for-each
845            (lambda (imp)
846              (let ((id (car imp))
847                    (aid (cdr imp)))
848                (and-let* ((a (assq id (import-env)))
849                           ((not (eq? aid (cdr a)))))
850                  (##sys#warn "re-importing already imported identfier: " id))))
851            vsv)
852           (for-each
853            (lambda (imp)
854              (and-let* ((a (assq (car imp) (macro-env)))
855                         ((not (eq? (cdr imp) (cdr a)))))
856                (##sys#warn "re-importing already imported syntax: " (car imp))) )
857            vss)
858           (import-env (append vsv (import-env)))
859           (macro-env (append vss (macro-env)))))
860       (cdr x))
861      '(##core#undefined))))
862
863(##sys#extend-macro-environment
864 'import '() 
865 (##sys#er-transformer 
866  (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
867       #f 'import) ) )
868
869(##sys#extend-macro-environment
870 'import-for-syntax '() 
871 (##sys#er-transformer 
872  (cut ##sys#expand-import <> <> <> ##sys#current-meta-environment ##sys#meta-macro-environment 
873       #t 'import-for-syntax) ) )
874
875(define ##sys#initial-macro-environment (##sys#macro-environment))
876
877(##sys#extend-macro-environment
878 'define
879 '()
880 (##sys#er-transformer
881  (lambda (form r c)
882    (let loop ((form (cdr form)))
883      (let ((head (car form))
884            (body (cdr form)) )
885        (cond ((not (pair? head))
886               (##sys#check-syntax 'define head 'symbol)
887               (##sys#check-syntax 'define body '#(_ 0 1))
888               (##sys#register-export head (##sys#current-module))
889               `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) )
890              ((pair? (car head))
891               (##sys#check-syntax 'define head '(_ . lambda-list))
892               (##sys#check-syntax 'define body '#(_ 1))
893               (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
894              (else
895               (##sys#check-syntax 'define head '(symbol . lambda-list))
896               (##sys#check-syntax 'define body '#(_ 1))
897               (##sys#register-export (car head) (##sys#current-module))
898               `(##core#set!
899                 ,(car head)
900                 (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
901
902(##sys#extend-macro-environment
903 'and
904 '()
905 (##sys#er-transformer
906  (lambda (form r c)
907    (let ((body (cdr form)))
908      (if (null? body)
909          #t
910          (let ((rbody (cdr body))
911                (hbody (car body)) )
912            (if (null? rbody)
913                hbody
914                `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
915
916(##sys#extend-macro-environment
917 'or 
918 '()
919 (##sys#er-transformer
920  (lambda (form r c)
921    (let ((body (cdr form)))
922     (if (null? body)
923         #f
924         (let ((rbody (cdr body))
925               (hbody (car body)))
926           (if (null? rbody)
927               hbody
928               (let ((tmp (r 'tmp)))
929                 `(,(r 'let) ((,tmp ,hbody))
930                    (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
931
932(##sys#extend-macro-environment
933 'cond
934 '()
935 (##sys#er-transformer
936  (lambda (form r c)
937    (let ((body (cdr form))
938          (%begin (r 'begin))
939          (%let (r 'let))
940          (%if (r 'if))
941          (%=> (r '=>))
942          (%or (r 'or))
943          (%else (r 'else))
944          (%lambda (r 'lambda)))
945      (let expand ((clauses body))
946        (if (not (pair? clauses))
947            '(##core#undefined)
948            (let ((clause (car clauses))
949                  (rclauses (cdr clauses)) )
950              (##sys#check-syntax 'cond clause '#(_ 1))
951              (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
952                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
953                    ((c %=> (cadr clause))
954                     (let ((tmp (r 'tmp)))
955                       `(,%let ((,tmp ,(car clause)))
956                               (,%if ,tmp
957                                     (,(caddr clause) ,tmp)
958                                     ,(expand rclauses) ) ) ) )
959                    ((and (list? clause) (fx= (length clause) 4)
960                          (c %=> (caddr clause)))
961                     (let ((tmp (r 'tmp)))
962                       `(##sys#call-with-values
963                         (,%lambda () ,(car clause))
964                         (,%lambda ,tmp
965                                   (if (##sys#apply ,(cadr clause) ,tmp)
966                                       (##sys#apply ,(cadddr clause) ,tmp)
967                                       ,(expand rclauses) ) ) ) ) )
968                    (else `(,%if ,(car clause) 
969                                 (,%begin ,@(cdr clause))
970                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
971
972(##sys#extend-macro-environment
973 'case
974 '()
975 (##sys#er-transformer
976  (lambda (form r c)
977    (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
978    (let ((exp (cadr form))
979          (body (cddr form)) )
980      (let ((tmp (r 'tmp))
981            (%begin (r 'begin))
982            (%if (r 'if))
983            (%or (r 'or))
984            (%eqv? '##sys#eqv?)
985            (%else (r 'else)))
986        `(let ((,tmp ,exp))
987           ,(let expand ((clauses body))
988              (if (not (pair? clauses))
989                  '(##core#undefined)
990                  (let ((clause (car clauses))
991                        (rclauses (cdr clauses)) )
992                    (##sys#check-syntax 'case clause '#(_ 1))
993                    (if (c %else (car clause))
994                        `(,%begin ,@(cdr clause))
995                        `(,%if (,%or ,@(##sys#map
996                                        (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
997                               (,%begin ,@(cdr clause)) 
998                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
999
1000(##sys#extend-macro-environment
1001 'let*
1002 '()
1003 (##sys#er-transformer
1004  (lambda (form r c)
1005    (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
1006    (let ((bindings (cadr form))
1007          (body (cddr form)) 
1008          (%let (r 'let)))
1009      (let expand ((bs bindings))
1010        (if (eq? bs '())
1011            `(,%let () ,@body)
1012            `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
1013
1014(##sys#extend-macro-environment
1015 'do
1016 '()
1017 (##sys#er-transformer
1018  (lambda (form r c)
1019    (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
1020    (let ((bindings (cadr form))
1021          (test (caddr form))
1022          (body (cdddr form))
1023          (dovar (r 'doloop))
1024          (%let (r 'let))
1025          (%if (r 'if))
1026          (%begin (r 'begin)))
1027      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
1028              (,%if ,(car test)
1029                    ,(let ((tbody (cdr test)))
1030                       (if (eq? tbody '())
1031                           '(##core#undefined)
1032                           `(,%begin ,@tbody) ) )
1033                    (,%begin
1034                     ,(if (eq? body '())
1035                          '(##core#undefined)
1036                          `(,%let () ,@body) )
1037                     (##core#app
1038                      ,dovar ,@(##sys#map (lambda (b) 
1039                                            (if (eq? (cdr (cdr b)) '())
1040                                                (car b)
1041                                                (car (cdr (cdr b))) ) )
1042                                          bindings) ) ) ) ) ) ) ) )
1043
1044(##sys#extend-macro-environment
1045 'quasiquote
1046 '()
1047 (##sys#er-transformer
1048  (lambda (form r c)
1049    (let ((%quote (r 'quote))
1050          (%quasiquote (r 'quasiquote))
1051          (%unquote (r 'unquote))
1052          (%unquote-splicing (r 'unquote-splicing)))
1053      (define (walk x n) (simplify (walk1 x n)))
1054      (define (walk1 x n)
1055        (cond ((vector? x)
1056               `(##sys#list->vector ,(walk (vector->list x) n)) )
1057              ((not (pair? x)) `(,%quote ,x))
1058              (else
1059               (let ((head (car x))
1060                     (tail (cdr x)))
1061                 (cond ((c %unquote head)
1062                        (if (pair? tail)
1063                            (let ((hx (car tail)))
1064                              (if (eq? n 0)
1065                                  hx
1066                                  (list '##sys#list `(,%quote ,%unquote)
1067                                        (walk hx (fx- n 1)) ) ) )
1068                            `(,%quote ,%unquote) ) )
1069                       ((c %quasiquote head)
1070                        (if (pair? tail)
1071                            `(##sys#list (,%quote ,%quasiquote) 
1072                                         ,(walk (car tail) (fx+ n 1)) ) 
1073                            (list '##sys#cons (list %quote %quasiquote) 
1074                                  (walk tail n)) ) )
1075                       ((pair? head)
1076                        (let ((hx (car head))
1077                              (tx (cdr head)))
1078                          (if (and (c hx %unquote-splicing) (pair? tx))
1079                              (let ((htx (car tx)))
1080                                (if (eq? n 0)
1081                                    `(##sys#append ,htx
1082                                                   ,(walk tail n) )
1083                                    `(##sys#cons (##sys#list %unquote-splicing
1084                                                             ,(walk htx (fx- n 1)) )
1085                                                 ,(walk tail n) ) ) )
1086                              `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
1087                       (else
1088                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
1089      (define (simplify x)
1090        (cond ((match-expression x '(##sys#cons a '()) '(a))
1091               => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
1092              ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
1093               => (lambda (env)
1094                    (let ([bxs (assq 'b env)])
1095                      (if (fx< (length bxs) 32)
1096                          (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
1097                                                 ,@(cdr bxs) ) ) 
1098                          x) ) ) )
1099              ((match-expression x '(##sys#append a '()) '(a))
1100               => (lambda (env) (##sys#slot (assq 'a env) 1)) )
1101              (else x) ) )
1102      (##sys#check-syntax 'quasiquote form '(_ _))
1103      (walk (cadr form) 0) ) ) ) )
1104
1105(##sys#extend-macro-environment
1106 'delay
1107 '()
1108 (##sys#er-transformer
1109  (lambda (form r c)
1110    (##sys#check-syntax 'delay form '(_ _))
1111    `(##sys#make-promise (lambda () ,(cadr form))))))
1112
1113(##sys#extend-macro-environment
1114 'cond-expand
1115 '()
1116 (##sys#er-transformer
1117  (lambda (form r c)
1118    (let ((clauses (cdr form))
1119          (%or (r 'or))
1120          (%not (r 'not))
1121          (%else (r 'else))
1122          (%begin (r 'begin))
1123          (%and (r 'and)))
1124      (define (err x) 
1125        (##sys#error "syntax error in `cond-expand' form"
1126                     x
1127                     (cons 'cond-expand clauses)) )
1128      (define (test fx)
1129        (cond ((symbol? fx) (##sys#feature? fx))
1130              ((not (pair? fx)) (err fx))
1131              (else
1132               (let ((head (car fx))
1133                     (rest (cdr fx)))
1134                 (cond ((c %and head)
1135                        (or (eq? rest '())
1136                            (if (pair? rest)
1137                                (and (test (car rest))
1138                                     (test `(,%and ,@(cdr rest))) )
1139                                (err fx) ) ) )
1140                       ((c %or head)
1141                        (and (not (eq? rest '()))
1142                             (if (pair? rest)
1143                                 (or (test (car rest))
1144                                     (test `(,%or ,@(cdr rest))) )
1145                                 (err fx) ) ) )
1146                       ((c %not head) (not (test (cadr fx))))
1147                       (else (err fx)) ) ) ) ) )
1148      (let expand ((cls clauses))
1149        (cond ((eq? cls '())
1150               (##sys#apply
1151                ##sys#error "no matching clause in `cond-expand' form" 
1152                (map (lambda (x) (car x)) clauses) ) )
1153              ((not (pair? cls)) (err cls))
1154              (else
1155               (let ((clause (car cls))
1156                    (rclauses (cdr cls)) )
1157                 (if (not (pair? clause)) 
1158                     (err clause)
1159                     (let ((id (car clause)))
1160                       (cond ((c id %else)
1161                              (let ((rest (cdr clause)))
1162                                (if (eq? rest '())
1163                                    '(##core#undefined)
1164                                    `(,%begin ,@rest) ) ) )
1165                             ((test id) `(,%begin ,@(cdr clause)))
1166                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
1167
1168(##sys#extend-macro-environment
1169 'require-library
1170 '()
1171 (##sys#er-transformer
1172  (lambda (x r c)
1173    (let ((ids (cdr x)))
1174      `(##core#require-extension ,ids #f) ) ) ) )
1175
1176(##sys#extend-macro-environment
1177 'require-extension
1178 '()
1179 (##sys#er-transformer
1180  (lambda (x r c)
1181    (let ((ids (cdr x)))
1182      `(##core#require-extension ,ids #t) ) ) ) )
1183
1184(##sys#extend-macro-environment
1185 'module
1186 '()
1187 (##sys#er-transformer
1188  (lambda (x r c)
1189    (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
1190    `(##core#module 
1191      ,(cadr x)
1192      ,(if (c (r '*) (caddr x)) 
1193           #t 
1194           (caddr x))
1195      ,@(cdddr x)))))
1196
1197(##sys#extend-macro-environment
1198 'begin-for-syntax
1199 '()
1200 (##sys#er-transformer
1201  (lambda (x r c)
1202    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
1203    (and-let* ((mod (##sys#current-module)))
1204      (##sys#register-meta-expression `(begin ,@(cdr x))) )
1205    `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
1206
1207(##sys#extend-macro-environment
1208 'export
1209 '()
1210 (##sys#er-transformer
1211  (lambda (x r c)
1212    (let ((exps (cdr x))
1213          (mod (##sys#current-module)))
1214      (unless mod
1215        (syntax-error 'export "`export' used outside module body"))
1216      (for-each
1217       (lambda (exp)
1218         (when (and (not (symbol? exp)) 
1219                    (let loop ((iexp exp))
1220                      (cond ((null? iexp) #f)
1221                            ((not (pair? iexp)) #t)
1222                            ((not (symbol? (car iexp))) #t)
1223                            (else (loop (cdr iexp))))))
1224           (syntax-error 'export "invalid export syntax" exp (module-name mod))))
1225       exps)
1226      (set-module-export-list! 
1227       mod
1228       (append (module-export-list mod) 
1229               (map ##sys#strip-syntax exps)))
1230      '(##sys#void)))))
1231
1232
1233;;; syntax-rules
1234
1235(include "synrules.scm")
1236
1237
1238;;; the base macro environment ("scheme", essentially)
1239
1240(define ##sys#default-macro-environment (##sys#macro-environment))
1241
1242
1243;;; low-level module support
1244
1245(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
1246(define ##sys#current-module (make-parameter #f))
1247
1248(declare 
1249  (hide make-module module? %make-module
1250        module-name module-vexports module-sexports
1251        set-module-vexports! set-module-sexports!
1252        module-export-list set-module-export-list! 
1253        module-defined-list set-module-defined-list!
1254        module-import-forms set-module-import-forms!
1255        module-meta-import-forms set-module-meta-import-forms!
1256        module-exist-list set-module-exist-list!
1257        module-meta-expressions set-module-meta-expressions!
1258        module-defined-syntax-list set-module-defined-syntax-list!))
1259
1260(define-record-type module
1261  (%make-module name export-list defined-list exist-list defined-syntax-list
1262                undefined-list import-forms meta-import-forms meta-expressions 
1263                vexports sexports) 
1264  module?
1265  (name module-name)                    ; SYMBOL
1266  (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
1267  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)    - *exported* value definitions
1268  (exist-list module-exist-list set-module-exist-list!)       ; (SYMBOL ...)    - only for checking refs to undef'd
1269  (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
1270  (undefined-list module-undefined-list set-module-undefined-list!) ; (SYMBOL ...)
1271  (import-forms module-import-forms set-module-import-forms!)       ; (SPEC ...)
1272  (meta-import-forms module-meta-import-forms set-module-meta-import-forms!)        ; (SPEC ...)
1273  (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
1274  (vexports module-vexports set-module-vexports!)             ; (SYMBOL . SYMBOL)
1275  (sexports module-sexports set-module-sexports!) )           ; ((SYMBOL SE TRANSFORMER) ...)
1276
1277(define (make-module name explist vexports sexports)
1278  (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
1279
1280(define (##sys#find-module name #!optional (err #t))
1281  (cond ((assq name ##sys#module-table) => cdr)
1282        (err (error 'import "module not found" name))
1283        (else #f)))
1284
1285(define (##sys#toplevel-definition-hook sym mod exp val) #f)
1286
1287(define (##sys#register-meta-expression exp)
1288  (and-let* ((mod (##sys#current-module)))
1289    (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
1290
1291(define (check-for-redef sym env senv)
1292  (and-let* ((a (assq sym env)))
1293    (##sys#warn "redefinition of imported value binding" sym) )
1294  (and-let* ((a (assq sym senv)))
1295    (##sys#warn "redefinition of imported syntax binding" sym)))
1296
1297(define (##sys#register-export sym mod)
1298  (when mod
1299    (let ((exp (or (eq? #t (module-export-list mod))
1300                   (##sys#find-export sym mod #t)))
1301          (ulist (module-undefined-list mod)))
1302      (##sys#toplevel-definition-hook   ; in compiler, hides unexported bindings
1303       (##sys#module-rename sym (module-name mod)) 
1304       mod exp #f)
1305      (when (memq sym ulist)
1306        (set-module-undefined-list! mod (##sys#delq sym ulist)))
1307      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1308      (set-module-exist-list! mod (cons sym (module-exist-list mod)))
1309      (when exp
1310        (dm "defined: " sym)
1311        (set-module-defined-list! 
1312         mod
1313         (cons (cons sym #f)
1314               (module-defined-list mod)))))) )
1315
1316(define (##sys#register-syntax-export sym mod val)
1317  (when mod
1318    (let ((exp (or (eq? #t (module-export-list mod))
1319                   (##sys#find-export sym mod #t)))
1320          (ulist (module-undefined-list mod))
1321          (mname (module-name mod)))
1322      (when (memq sym ulist)
1323        (##sys#warn "use of syntax precedes definition" sym))
1324      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1325      (dm "defined syntax: " sym)
1326      (when exp
1327        (set-module-defined-list! 
1328         mod
1329         (cons (cons sym val)
1330               (module-defined-list mod))) )
1331      (set-module-defined-syntax-list! 
1332       mod
1333       (cons sym (module-defined-syntax-list mod))))))
1334
1335(define (##sys#register-undefined sym mod)
1336  (when mod
1337    (let ((ul (module-undefined-list mod)))
1338      (unless (memq sym ul)
1339        (set-module-undefined-list! mod (cons sym ul))))))
1340
1341(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
1342  (let ((mod (make-module name explist vexports sexports)))
1343    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
1344    mod) )
1345
1346(define (##sys#mark-imported-symbols se)
1347  (for-each
1348   (lambda (imp)
1349     (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
1350       (dm `(MARKING: ,(cdr imp)))
1351       (##sys#put! (cdr imp) '##core#aliased #t)))
1352   se))
1353
1354(define (module-indirect-exports mod)
1355  (let ((exports (module-export-list mod))
1356        (mname (module-name mod))
1357        (dlist (module-defined-list mod)))
1358    (define (indirect? id)
1359      (let loop ((exports exports))
1360        (and (not (null? exports))
1361             (or (and (pair? (car exports))
1362                      (memq id (cdar exports)))
1363                 (loop (cdr exports))))))
1364    (define (warn msg id)
1365      (##sys#warn
1366       (string-append msg " in module `" (symbol->string mname) "'")
1367       id))
1368    (if (eq? #t exports)
1369        '()
1370        (let loop ((exports exports))   ; walk export list
1371          (cond ((null? exports) '())
1372                ((symbol? (car exports)) (loop (cdr exports))) ; normal export
1373                (else
1374                 (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
1375                   (cond ((null? iexports) (loop (cdr exports)))
1376                         ((assq (car iexports) (##sys#macro-environment))
1377                          (warn "indirect export of syntax binding" (car iexports))
1378                          (loop2 (cdr iexports)))
1379                         ((assq (car iexports) dlist) => ; defined in current module?
1380                          (lambda (a) 
1381                            (cons
1382                             (cons
1383                              (car iexports)
1384                              (or (cdr a) (##sys#module-rename (car iexports) mname)))
1385                             (loop2 (cdr iexports)))))
1386                         ((assq (car iexports) (##sys#current-environment)) =>
1387                          (lambda (a)   ; imported in current env.
1388                            (cond ((symbol? (cdr a)) ; not syntax
1389                                   (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
1390                                  (else
1391                                   (warn "indirect reexport of syntax" (car iexports))
1392                                   (loop2 (cdr iexports))))))
1393                         (else
1394                          (warn "indirect export of unknown binding" (car iexports))
1395                          (loop2 (cdr iexports)))))))))))
1396
1397(define (merge-se . ses)                ; later occurrences take precedence to earlier ones
1398  (let ((se (apply append ses)))
1399    (dm "merging " (length ses) " se's with total length of " (length se))
1400    (let ((se2
1401           (let loop ((se se))
1402             (cond ((null? se) '())
1403                   ((assq (caar se) (cdr se)) (loop (cdr se)))
1404                   (else (cons (car se) (loop (cdr se))))))))
1405      (dm "  merged has length " (length se2))
1406      se2)))
1407
1408(define (##sys#compiled-module-registration mod)
1409  (let ((dlist (module-defined-list mod))
1410        (mname (module-name mod))
1411        (ifs (module-import-forms mod))
1412        (mifs (module-meta-import-forms mod)))
1413    `(,@(if (pair? ifs) `((eval '(import ,@ifs))) '())
1414      ,@(if (pair? mifs) `((import ,@mifs)) '())
1415      ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
1416      (##sys#register-compiled-module
1417       ',(module-name mod)
1418       (list
1419        ,@(map (lambda (ie)
1420                 (if (symbol? (cdr ie))
1421                     `'(,(car ie) . ,(cdr ie))
1422                     `(list ',(car ie) '() ,(cdr ie))))
1423               (module-indirect-exports mod)))
1424       ',(module-vexports mod)
1425       (list
1426        ,@(map (lambda (sexport)
1427                 (let* ((name (car sexport))
1428                        (a (assq name dlist)))
1429                   (unless (pair? a)
1430                     (error 'module "(internal) exported syntax has no source" name mname))
1431                   `(cons ',(car sexport) ,(cdr a))))
1432               (module-sexports mod)))))))
1433
1434(define (##sys#register-compiled-module name iexports vexports sexports)
1435  (let* ((sexps
1436          (map (lambda (se)
1437                 (list (car se) #f (##sys#er-transformer (cdr se))))
1438               sexports))
1439         (iexps 
1440          (map (lambda (ie)
1441                 (if (pair? (cdr ie))
1442                     (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
1443                     ie))
1444               iexports))
1445         (mod (make-module name '() vexports sexps))
1446         (exports (merge-se 
1447                   (##sys#macro-environment)
1448                   (##sys#current-environment)
1449                   iexps vexports sexps)))
1450    (##sys#mark-imported-symbols iexps)
1451    (for-each
1452     (lambda (sexp)
1453       (set-car! (cdr sexp) exports))
1454     sexps)
1455    (for-each
1456     (lambda (iexp)
1457       (when (pair? (cdr iexp))
1458         (set-car! (cdr iexp) exports)))
1459     iexps)
1460    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1461    mod))
1462
1463(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
1464  (let* ((me (##sys#macro-environment))
1465         (mod (make-module 
1466               name '()
1467               (map (lambda (ve)
1468                      (if (symbol? ve)
1469                          (let ((palias 
1470                                 (##sys#string->symbol 
1471                                  (##sys#string-append "#%" (##sys#slot ve 1)))))
1472                            (##sys#put! palias '##core#primitive ve)
1473                            (cons ve palias))
1474                          ve))
1475                    vexports)
1476               (map (lambda (se)
1477                      (if (symbol? se)
1478                          (or (assq se me)
1479                              (##sys#error "unknown macro referenced while registering module" se name))
1480                          se))
1481                    sexports))))
1482    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1483    mod))
1484
1485(define (##sys#find-export sym mod indirect)
1486  (let ((exports (module-export-list mod)))
1487    (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
1488      (cond ((null? xl) #f)
1489            ((eq? sym (car xl)))
1490            ((pair? (car xl))
1491             (or (eq? sym (caar xl))
1492                 (and indirect (memq sym (cdar xl)))
1493                 (loop (cdr xl))))
1494            (else (loop (cdr xl)))))))
1495
1496(define (##sys#finalize-module mod)
1497  (let* ((explist (module-export-list mod))
1498         (name (module-name mod))
1499         (dlist (module-defined-list mod))
1500         (elist (module-exist-list mod))
1501         (sdlist (map (lambda (sym) (assq sym (##sys#macro-environment)))
1502                      (module-defined-syntax-list mod)))
1503         (sexports
1504          (if (eq? #t explist)
1505              (map (lambda (sd) (assq (car sd) (##sys#macro-environment)))
1506                   sdlist)
1507              (let loop ((me (##sys#macro-environment)))
1508                (cond ((null? me) '())
1509                      ((##sys#find-export (caar me) mod #f)
1510                       (cons (car me) (loop (cdr me))))
1511                      (else (loop (cdr me)))))))
1512         (vexports
1513          (let loop ((xl (if (eq? #t explist) elist explist)))
1514            (if (null? xl)
1515                '()
1516                (let* ((h (car xl))
1517                       (id (if (symbol? h) h (car h))))
1518                  (if (assq id sexports) 
1519                      (loop (cdr xl))
1520                      (cons
1521                       (cons
1522                        id
1523                        (let ((def (assq id dlist)))
1524                          (if (and def (symbol? (cdr def))) 
1525                              (cdr def)
1526                              (let ((a (assq id (##sys#current-environment))))
1527                                (cond ((and a (symbol? (cdr a))) 
1528                                       (dm "reexporting: " id " -> " (cdr a))
1529                                       (cdr a)) 
1530                                      ((not def)
1531                                       (##sys#warn 
1532                                        (string-append
1533                                         "exported identifier for module `" 
1534                                         (symbol->string name)
1535                                         "' has not been defined")
1536                                        id) )
1537                                      (else (##sys#module-rename id name)))))))
1538                       (loop (cdr xl)))))))))
1539    (for-each
1540     (lambda (u)
1541       (unless (memq u elist)
1542         (##sys#warn "reference to possibly unbound identifier" u)))
1543     (module-undefined-list mod))
1544    (let* ((exports 
1545            (map (lambda (exp)
1546                   (cond ((symbol? (cdr exp)) exp)
1547                         ((assq (car exp) (##sys#macro-environment)))
1548                         (else (##sys#error "(internal) indirect export not found" (car exp)))) )
1549                 (module-indirect-exports mod)))
1550           (new-se (merge-se 
1551                    (##sys#macro-environment) 
1552                    (##sys#current-environment) 
1553                    exports)))
1554      (##sys#mark-imported-symbols exports)
1555      (for-each
1556       (lambda (m)
1557         (let ((se (merge-se (cadr m) new-se)))
1558           (dm `(FIXUP: ,(car m) ,@(map-se se)))
1559           (set-car! (cdr m) se)))
1560       sdlist)
1561      (dm `(EXPORTS: 
1562            ,(module-name mod) 
1563            (DLIST: ,@dlist)
1564            (SDLIST: ,@(map-se sdlist))
1565            (IEXPORTS: ,@(map-se exports))
1566            (VEXPORTS: ,@(map-se vexports))
1567            (SEXPORTS: ,@(map-se sexports))))
1568      (set-module-vexports! mod vexports)
1569      (set-module-sexports! mod sexports))))
1570
1571(define ##sys#module-table '())
1572
1573(define (##sys#macro-subset me0)
1574  (let loop ((me (##sys#macro-environment)))
1575    (if (or (null? me) (eq? me me0))
1576        '()
1577        (cons (car me) (loop (cdr me))))))
Note: See TracBrowser for help on using the repository browser.