source: project/chicken/trunk/expand.scm @ 15171

Last change on this file since 15171 was 15171, checked in by felix winkelmann, 10 years ago

fix in foreign-value; tests use own repo; other fixes (thanks to sjaaman)

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