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

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

re-loading imported module into interpreter incorrectly renamed export list (export-lists are now sytax-stripped); started with guerilla setup

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