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

Last change on this file since 10788 was 10788, checked in by felix winkelmann, 13 years ago
  • added remaining import libraries
  • csi uses srfi-69 now to avoid bootstrapping problem
  • csi: renamed "-se" to "-sx"
  • global assigns get variable name in comment in generated C code
  • import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy)
  • removed a lot of deprecated stuff
  • it really seems to work...
File size: 37.8 KB
Line 
1;;;; expand.scm
2;
3; Copyright (c) 2008, The Chicken Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(declare
28  (unit expand)
29  (disable-interrupts)
30  (fixnum)
31  (hide match-expression
32        macro-alias
33        d dd
34        lookup) )
35
36
37(set! ##sys#features
38  (append '(#:hygienic-macros #:syntax-rules) ##sys#features))
39
40(define (d arg1 . more)
41  (if (null? more)
42      (pp arg1)
43      (apply print arg1 more)))
44
45(define dd d)
46
47(cond-expand
48 (hygienic-macros
49  (define-syntax d (syntax-rules () ((_ . _) (void)))))
50 (else                                  ;*** remove later
51  (define-macro (d . _) '(void))))
52
53(cond-expand
54 (hygienic-macros
55  (define-syntax dd (syntax-rules () ((_ . _) (void)))))
56 (else                                  ;*** remove later
57  (define-macro (dd . _) '(void))))
58
59
60;;; Syntactic environments
61
62(define ##sys#current-environment (make-parameter '()))
63(define ##sys#current-meta-environment (make-parameter '()))
64
65(define (lookup id se)
66  (cond ((assq id se) => cdr)
67        ((##sys#get id '##sys#macro-alias))
68        (else #f)))
69
70(define (macro-alias var se)
71  (if (or (##sys#qualified-symbol? var)
72          (let* ((str (##sys#slot var 1))
73                 (len (##sys#size str)))
74            (and (fx> len 0)
75                 (char=? #\# (##core#inline "C_subchar" str 0)))))
76      var
77      (let* ((alias (gensym var))
78             (ua (or (lookup var se) var)))
79        (##sys#put! alias '##sys#macro-alias ua)
80        alias) ) )
81
82(define (##sys#strip-syntax exp #!optional se)
83  ;; if se is given, retain bound vars
84  (let walk ((x exp))
85    (cond ((symbol? x)
86           (let ((x2 (if se 
87                         (lookup x se)
88                         (get x '##sys#macro-alias) ) ) )
89             (cond ((not x2) x)
90                   ((pair? x2) x)
91                   (else x2))))
92          ((pair? x)
93           (cons (walk (##sys#slot x 0))
94                 (walk (cdr x))))
95          ((vector? x)
96           (list->vector (map walk (vector->list x))))
97          (else x))))
98
99
100;;; Macro handling
101
102(define ##sys#macro-environment (make-parameter '()))
103
104(define (##sys#extend-macro-environment name se handler)
105  (let ((me (##sys#macro-environment)))
106    (cond ((lookup name me) =>
107           (lambda (a)
108             (set-car! a se)
109             (set-car! (cdr a) handler) ) )
110          (else
111           (##sys#macro-environment
112            (cons (list name se handler)
113                  me))))))
114
115(define (##sys#copy-macro old new)
116  (let ((def (lookup old (##sys#macro-environment))))
117    (apply ##sys#extend-macro-environment new def) ) )
118
119(define (macro? sym #!optional (senv (##sys#current-environment)))
120  (##sys#check-symbol sym 'macro?)
121  (##sys#check-list senv 'macro?)
122  (or (lookup sym senv)
123      (and (lookup sym (##sys#macro-environment)) #t) ) )
124
125(define (##sys#unregister-macro name)
126  (##sys#macro-environment
127    ;; this builds up stack, but isn't used often anyway...
128    (let loop ((me (##sys#macro-environment)) (me2 '()))
129      (cond ((null? me) '())
130            ((eq? x (caar me)) (cdr me))
131            (else (cons (car me) (loop (cdr me))))))))
132
133(define (undefine-macro! name)
134  (##sys#check-symbol name 'undefine-macro!)
135  (##sys#unregister-macro name) )
136
137
138;; The basic macro-expander
139
140(define ##sys#expand-0
141  (let ([string-append string-append])
142    (lambda (exp dse)
143      (define (call-handler name handler exp se)
144        (dd "invoking macro: " name)
145        (handle-exceptions ex
146            (##sys#abort
147             (if (and (##sys#structure? ex 'condition)
148                      (memv 'exn (##sys#slot ex 1)) )
149                 (##sys#make-structure
150                  'condition
151                  (##sys#slot ex 1)
152                  (let copy ([ps (##sys#slot ex 2)])
153                    (if (null? ps)
154                        '()
155                        (let ([p (car ps)]
156                              [r (cdr ps)])
157                          (if (and (equal? '(exn . message) p)
158                                   (pair? r)
159                                   (string? (car r)) )
160                              (cons
161                               '(exn . message)
162                               (cons (string-append
163                                      "during expansion of ("
164                                      (##sys#slot name 1) 
165                                      " ...) - "
166                                      (car r) )
167                                     (cdr r) ) )
168                              (copy r) ) ) ) ) )
169                 ex) )
170          (handler exp se dse)))
171      (define (expand head exp mdef)
172        (dd `(EXPAND: ,head ,exp ,(map car dse)))
173        (cond ((not (list? exp))
174               (##sys#syntax-error-hook "invalid syntax in macro form" exp) )
175              ((pair? mdef)
176               (values
177                ;; force ref. opaqueness by passing dynamic se
178                (call-handler head (cadr mdef) exp (car mdef))
179                #t))
180              (else (values exp #f)) ) )
181      (if (pair? exp)
182          (let ((head (##sys#slot exp 0))
183                (body (cdr exp)) )
184            (if (symbol? head)
185                (let ((head2 (or (lookup head dse) head)))
186                  (unless (pair? head2)
187                    (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
188                  (cond [(eq? head2 'let)
189                         (##sys#check-syntax 'let body '#(_ 2) #f dse)
190                         (let ([bindings (car body)])
191                           (cond [(symbol? bindings)
192                                  (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
193                                  (let ([bs (cadr body)])
194                                    (values
195                                     `(##core#app
196                                       (,(macro-alias 'letrec dse)
197                                        ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
198                                        ,bindings)
199                                       ,@(##sys#map cadr bs) )
200                                     #t) ) ]
201                                 [else (values exp #f)] ) ) ]
202                        [(and (memq head2 '(set! ##core#set!))
203                              (pair? body)
204                              (pair? (car body)) )
205                         (let ([dest (car body)])
206                           (##sys#check-syntax 'set! body '(#(_ 1) _) #f dse)
207                           (values
208                            (append (list (list '##sys#setter (car dest)))
209                                    (cdr dest)
210                                    (cdr body) ) 
211                            #t) ) ]
212                        [else (expand head exp head2)] ) )
213                (values exp #f) ) )
214          (values exp #f) ) ) ) )
215
216(define ##sys#enable-runtime-macros #f)
217(define ##sys#import-environment (make-parameter '()))
218
219(define (##sys#module-rename sym prefix)
220  (##sys#string->symbol 
221   (string-append
222    (##sys#slot prefix 1)
223    "#" 
224    (##sys#slot sym 1) ) ) )
225
226(define (##sys#alias-global-hook sym) 
227  (define (mrename sym)
228    (cond ((##sys#current-module) =>
229           (lambda (mod)
230             (d "global alias " sym " -> " (module-name mod))
231             (##sys#module-rename sym (module-name mod))))
232          (else sym)))
233  (cond ((##sys#qualified-symbol? sym) sym)
234        ((assq sym (##sys#import-environment)) =>
235         (lambda (a)
236           (if (pair? (cdr a))
237               (mrename sym)
238               (cdr a) ) ) )
239        (else (mrename sym))))
240
241
242;;; User-level macroexpansion
243
244(define (##sys#expand exp #!optional (me (##sys#current-environment)))
245  (let loop ((exp exp))
246    (let-values (((exp2 m) (##sys#expand-0 exp me)))
247      (if m
248          (loop exp2)
249          exp2) ) ) )
250
251(define expand ##sys#expand)
252
253(define (expand* exp #!optional (me (##sys#current-environment)))
254  (##sys#expand-0 exp me) )
255
256
257;;; Extended (DSSSL-style) lambda lists
258;
259; Assumptions:
260;
261; 1) #!rest must come before #!key
262; 2) default values may refer to earlier variables
263; 3) optional/key args may be either variable or (variable default)
264; 4) an argument marker may not be specified more than once
265; 5) no special handling of extra keywords (no error)
266; 6) default value of optional/key args is #f
267; 7) mixing with dotted list syntax is allowed
268
269(define (##sys#extended-lambda-list? llist)
270  (let loop ([llist llist])
271    (and (pair? llist)
272         (case (##sys#slot llist 0)
273           [(#!rest #!optional #!key) #t]
274           [else (loop (cdr llist))] ) ) ) )
275
276(define ##sys#expand-extended-lambda-list
277  (let ([reverse reverse]
278        [gensym gensym] )
279    (lambda (llist0 body errh se)
280      (define (err msg) (errh msg llist0))
281      (define (->keyword s) (string->keyword (##sys#slot s 1)))
282      (let ([rvar #f]
283            [hasrest #f] 
284            (%let* (macro-alias 'let* se))
285            (%lambda (macro-alias 'lambda se))
286            (%opt (macro-alias 'optional se))
287            (%let-optionals (macro-alias 'let-optionals se))
288            (%let-optionals* (macro-alias 'let-optionals* se))
289            (%let (macro-alias 'let se)))
290        (let loop ([mode 0]             ; req, opt, rest, key, end
291                   [req '()]
292                   [opt '()]
293                   [key '()] 
294                   [llist llist0] )
295          (cond [(null? llist)
296                 (values
297                  (if rvar (##sys#append (reverse req) rvar) (reverse req))
298                  (let ([body 
299                         (if (null? key)
300                             body
301                             `((,%let*
302                                ,(map (lambda (k)
303                                        (let ([s (car k)])
304                                          `(,s (##sys#get-keyword 
305                                                ',(->keyword s) ,rvar
306                                                ,@(if (pair? (cdr k)) 
307                                                      `((,%lambda () ,@(cdr k)))
308                                                      '() ) ) ) ) )
309                                      (reverse key) )
310                                ,@body) ) ) ] )
311                    (cond [(null? opt) body]
312                          [(and (not hasrest) (null? key) (null? (cdr opt)))
313                           `((,%let
314                              ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
315                              ,@body) ) ]
316                          [(and (not hasrest) (null? key))
317                           `((,%let-optionals
318                              ,rvar ,(reverse opt) ,@body))]
319                          [else
320                           `((,%let-optionals*
321                              ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar))) 
322                              ,@body))] ) ) ) ]
323                [(symbol? llist) 
324                 (if (fx> mode 2)
325                     (err "rest argument list specified more than once")
326                     (begin
327                       (if (not rvar) (set! rvar llist))
328                       (set! hasrest llist)
329                       (loop 4 req opt '() '()) ) ) ]
330                [(not (pair? llist))
331                 (err "invalid lambda list syntax") ]
332                [else
333                 (let* ((var (car llist))
334                        (x (or (and (symbol? var) (lookup var se)) var))
335                        (r (cdr llist)))
336                   (case x
337                     [(#!optional)
338                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
339                      (if (eq? mode 0)
340                          (loop 1 req '() '() r)
341                          (err "`#!optional' argument marker in wrong context") ) ]
342                     [(#!rest)
343                      (if (fx<= mode 1)
344                          (if (and (pair? r) (symbol? (car r)))
345                              (begin
346                                (if (not rvar) (set! rvar (car r)))
347                                (set! hasrest (car r))
348                                (loop 2 req opt '() (cdr r)) )
349                              (err "invalid syntax of `#!rest' argument") ) 
350                          (err "`#!rest' argument marker in wrong context") ) ]
351                     [(#!key)
352                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
353                      (if (fx<= mode 3)
354                          (loop 3 req opt '() r)
355                          (err "`#!key' argument marker in wrong context") ) ]
356                     [else
357                      (cond [(symbol? x)
358                             (case mode
359                               [(0) (loop 0 (cons x req) '() '() r)]
360                               [(1) (loop 1 req (cons (list x #f) opt) '() r)]
361                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
362                               [else (loop 3 req opt (cons (list x) key) r)] ) ]
363                            [(and (list? x) (eq? 2 (length x)))
364                             (case mode
365                               [(0) (err "invalid required argument syntax")]
366                               [(1) (loop 1 req (cons x opt) '() r)]
367                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
368                               [else (loop 3 req opt (cons x key) r)] ) ]
369                            [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
370
371
372;;; Expansion of bodies (and internal definitions)
373
374(define ##sys#canonicalize-body
375  (let ([reverse reverse]
376        [map map] )
377    (lambda (body #!optional (se (##sys#current-environment)))
378      (define (fini vars vals mvars mvals body)
379        (if (and (null? vars) (null? mvars))
380            (let loop ([body2 body] [exps '()])
381              (if (not (pair? body2)) 
382                  (cons
383                   (macro-alias 'begin se)
384                   body) ; no more defines, otherwise we would have called `expand'
385                  (let ([x (car body2)])
386                    (if (and (pair? x) 
387                             (let ((d (car x)))
388                               (and (symbol? d)
389                                    (or (eq? (or (lookup d se) d) 'define)
390                                        (eq? (or (lookup d se) d) 'define-values)))) )
391                        (cons
392                         (macro-alias 'begin se)
393                         (##sys#append (reverse exps) (list (expand body2))))
394                        (loop (cdr body2) (cons x exps)) ) ) ) )
395            (let ([vars (reverse vars)]
396                  (lam (macro-alias 'lambda se)))
397              `(,(macro-alias 'let se)
398                ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
399                            (apply ##sys#append vars mvars) )
400                ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
401                ,@(map (lambda (vs x)
402                         (let ([tmps (##sys#map gensym vs)])
403                           `(##sys#call-with-values
404                             (,lam () ,x)
405                             (,lam ,tmps 
406                                   ,@(map (lambda (v t) `(##core#set! ,v ,t)) vs tmps) ) ) ) ) 
407                       (reverse mvars)
408                       (reverse mvals) )
409                ,@body) ) ) )
410      (define (fini/syntax vars vals mvars mvals body)
411        (fini
412         vars vals mvars mvals
413         (let loop ((body body) (defs '()) (done #f))
414           (cond (done `(,(macro-alias 'letrec-syntax se)
415                         ,(map cdr (reverse defs)) ,@body) )
416                 ((not (pair? body)) (loop body defs #t))
417                 ((and (list? (car body))
418                       (= 3 (length (car body))) 
419                       (symbol? (caar body))
420                       (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
421                  (loop (cdr body) (cons (car body) defs) #f))
422                 (else (loop body defs #t))))))               
423      (define (expand body)
424        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
425          (if (not (pair? body))
426              (fini vars vals mvars mvals body)
427              (let* ((x (car body))
428                     (rest (cdr body))
429                     (exp1 (and (pair? x) (car x)))
430                     (head (and exp1
431                                (symbol? exp1)
432                                (or (lookup exp1 se) exp1))))
433                (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
434                      [(eq? 'define head)
435                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
436                       (let loop2 ([x x])
437                         (let ([head (cadr x)])
438                           (cond [(not (pair? head))
439                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
440                                  (loop rest (cons head vars)
441                                        (cons (if (pair? (cddr x))
442                                                  (caddr x)
443                                                  '(##core#undefined) )
444                                              vals)
445                                        mvars mvals) ]
446                                 [(pair? (car head))
447                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
448                                  (loop2 (cons (macro-alias 'define se)
449                                               (##sys#expand-curried-define head (cddr x) se))) ]
450                                 [else
451                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
452                                  (loop rest
453                                        (cons (car head) vars)
454                                        (cons `(,(macro-alias 'lambda se) ,(cdr head) ,@(cddr x)) vals)
455                                        mvars mvals) ] ) ) ) ]
456                      ((eq? 'define-syntax head)
457                       (##sys#check-syntax 'define-syntax x '(define-syntax variable _) se)
458                       (fini/syntax vars vals mvars mvals body) )
459                      [(eq? 'define-values head)
460                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
461                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
462                      [(eq? 'begin head)
463                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
464                       (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
465                      [else
466                       (let ([x2 (##sys#expand-0 x se)])
467                         (if (eq? x x2)
468                             (fini vars vals mvars mvals body)
469                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
470      (expand body) ) ) )
471
472
473;;; A simple expression matcher
474
475(define match-expression
476  (lambda (exp pat vars)
477    (let ((env '()))
478      (define (mwalk x p)
479        (cond ((not (pair? p))
480               (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
481                     ((memq p vars)
482                      (set! env (cons (cons p x) env))
483                      #t)
484                     (else (eq? x p)) ) )
485              ((pair? x)
486               (and (mwalk (car x) (car p))
487                    (mwalk (cdr x) (cdr p)) ) )
488              (else #f) ) )
489      (and (mwalk exp pat) env) ) ) )
490
491
492;;; Expand "curried" lambda-list syntax for `define'
493
494(define (##sys#expand-curried-define head body se)
495  (let* ([name #f]
496         (lam (macro-alias 'lambda se)))
497    (define (loop head body)
498      (if (symbol? (car head))
499          (begin
500            (set! name (car head))
501            `(,lam ,(cdr head) ,@body) )
502          (loop (car head) `((,lam ,(cdr head) ,@body)) ) ))
503    (let ([exp (loop head body)])
504      (list name exp) ) ) )
505
506
507;;; General syntax checking routine:
508
509(define ##sys#line-number-database #f)
510(define ##sys#syntax-error-culprit #f)
511
512(define (##sys#syntax-error-hook . args)
513  (apply ##sys#signal-hook #:syntax-error
514         (##sys#strip-syntax args)))
515
516(define syntax-error ##sys#syntax-error-hook)
517
518(define (get-line-number sexp)
519  (and ##sys#line-number-database
520       (pair? sexp)
521       (let ([head (car sexp)])
522         (and (symbol? head)
523              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
524                     => (lambda (pl)
525                          (let ([a (assq sexp pl)])
526                            (and a (cdr a)) ) ) ]
527                    [else #f] ) ) ) ) )
528
529(define ##sys#check-syntax
530  (let ([string-append string-append]
531        [keyword? keyword?]
532        [get-line-number get-line-number]
533        [symbol->string symbol->string] )
534    (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
535
536      (define (test x pred msg)
537        (unless (pred x) (err msg)) )
538
539      (define (err msg)
540        (let* ([sexp ##sys#syntax-error-culprit]
541               [ln (get-line-number sexp)] )
542          (##sys#syntax-error-hook
543           (if ln 
544               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
545               (string-append "(" (symbol->string id) ") " msg) )
546           exp) ) )
547
548      (define (lambda-list? x)
549        (or (##sys#extended-lambda-list? x)
550            (let loop ((x x))
551              (cond ((null? x))
552                    ((symbol? x) (not (keyword? x)))
553                    ((pair? x)
554                     (let ((s (car x)))
555                       (and (symbol? s)
556                            (loop (cdr x)) ) ) )
557                    (else #f) ) ) ) )
558
559      (define (proper-list? x)
560        (let loop ((x x))
561          (cond ((eq? x '()))
562                ((pair? x) (loop (cdr x)))
563                (else #f) ) ) )
564
565      (when culprit (set! ##sys#syntax-error-culprit culprit))
566      (let walk ((x exp) (p pat))
567        (cond ((vector? p)
568               (let* ((p2 (vector-ref p 0))
569                      (vlen (##sys#size p))
570                      (min (if (fx> vlen 1) 
571                               (vector-ref p 1)
572                               0) )
573                      (max (cond ((eq? vlen 1) 1)
574                                 ((fx> vlen 2) (vector-ref p 2))
575                                 (else 99999) ) ) )
576                 (do ((x x (cdr x))
577                      (n 0 (fx+ n 1)) )
578                     ((eq? x '())
579                      (if (fx< n min)
580                          (err "not enough arguments") ) )
581                   (cond ((fx>= n max) 
582                          (err "too many arguments") )
583                         ((not (pair? x))
584                          (err "not a proper list") )
585                         (else (walk (car x) p2) ) ) ) ) )
586              ((##sys#immediate? p)
587               (if (not (eq? p x)) (err "unexpected object")) )
588              ((symbol? p)
589               (case p
590                 ((_) #t)
591                 ((pair) (test x pair? "pair expected"))
592                 ((variable) (test x symbol? "identifier expected"))
593                 ((symbol) (test x symbol? "symbol expected"))
594                 ((list) (test x proper-list? "proper list expected"))
595                 ((number) (test x number? "number expected"))
596                 ((string) (test x string? "string expected"))
597                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
598                 (else
599                  (test
600                   x
601                   (lambda (y)
602                     (let ((y2 (and (symbol? y) (lookup y se))))
603                       (eq? (if (symbol? y2) y2 y) p)))
604                   "missing keyword")) ) )
605              ((not (pair? p))
606               (err "incomplete form") )
607              ((not (pair? x)) (err "pair expected"))
608              (else
609               (walk (car x) (car p))
610               (walk (cdr x) (cdr p)) ) ) ) ) ) )
611
612
613;;; explicit-renaming transformer
614
615(define ((##sys#er-transformer handler) form se dse)
616  (let ((renv '()))                     ; keep rename-environment for this expansion
617    (define (rename sym)
618      (cond ((assq sym renv) => cdr)
619            ((lookup sym se) =>
620             (lambda (a)
621               (if (symbol? a)
622                   a
623                   sym) ) )
624            (else
625             (let ((a (macro-alias sym se)))
626               (set! renv (cons (cons sym a) renv))
627               a))))
628    (define (compare s1 s2)
629      (if (and (symbol? s1) (symbol? s2))
630          (eq? (or (##sys#get s1 '##sys#macro-alias)
631                   (lookup s1 dse)
632                   s1)
633               (or (##sys#get s2 '##sys#macro-alias)
634                   (lookup s2 dse)
635                   s2) )
636          (eq? s1 s2)))
637    (handler form rename compare) ) )
638
639
640;;; Macro definitions:
641
642(##sys#extend-macro-environment
643 'import
644 '()
645 (##sys#er-transformer
646  (lambda (x r c)
647    (let ((%only (r 'only))
648          (%rename (r 'rename))
649          (%except (r 'except))
650          (%prefix (r 'prefix)))
651      (define (resolve sym)
652        (or (lookup sym '()) sym))      ;*** empty se?
653      (define (tostr x)
654        (cond ((string? x) x)
655              ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; why not?
656              ((symbol? x) (##sys#symbol->string x))
657              ((number? x) (number->string x))
658              (else (syntax-error 'import "invalid prefix" ))))
659      (define (import-name spec)
660        (let* ((mname (resolve spec))
661               (mod (##sys#find-module mname #f)))
662          (unless mod
663            (let ((il (##sys#find-extension 
664                       (string-append (symbol->string mname) ".import")
665                       #t)))
666              (cond (il (parameterize ((##sys#current-module #f)
667                                       (##sys#import-environment '())
668                                       (##sys#macro-environment ##sys#default-macro-environment))
669                          (##sys#load il #f #f))
670                        (set! mod (##sys#find-module mname)))
671                    (else
672                     (syntax-error
673                      'import "can not import from undefined module" 
674                      mname)))))
675          (cons (module-vexports mod) 
676                (module-sexports mod))))
677      (define (import-spec spec)
678        (cond ((symbol? spec) (import-name spec))
679              ((or (not (list? spec)) (< (length spec) 2))
680               (syntax-error 'import "invalid import specification" spec))
681              (else
682               (let* ((s (car spec))
683                      (imp (import-spec (cadr spec)))
684                      (impv (car imp))
685                      (imps (cdr imp)))
686                 (cond ((c %only (car spec))
687                        (##sys#check-syntax 'only spec '(_ _ . #(symbol 0)))
688                        (let ((ids (map resolve (cddr spec))))
689                          (let loop ((ids ids) (v '()) (s '()))
690                            (cond ((null? ids) (cons v s))
691                                  ((assq (car ids) impv) =>
692                                   (lambda (a) 
693                                     (loop (cdr ids) (cons a v) s)))
694                                  ((assq (car ids) imps) =>
695                                   (lambda (a) 
696                                     (loop (cdr ids) v (cons a s))))
697                                  (else (loop (cdr ids) v s))))))
698                       ((c %except (car spec))
699                        (##sys#check-syntax 'except spec '(_ _ . #(symbol 0)))
700                        (let ((ids (map resolve (cddr spec))))
701                          (let loop ((impv impv) (v '()))
702                            (cond ((null? impv)
703                                   (let loop ((imps imps) (s '()))
704                                     (cond ((null? imps) (cons v s))
705                                           ((memq (caar imps) ids) (loop (cdr imps) s))
706                                           (else (loop (cdr imps) (cons (car imps) s))))))
707                                  ((memq (caar impv) ids) (loop (cdr impv) v))
708                                  (else (loop (cdr impv) (cons (car impv) v)))))))
709                       ((c %rename (car spec))
710                        (##sys#check-syntax 'rename spec '(_ _ . #((symbol symbol) 0)))
711                        (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
712                          (cond ((null? impv) 
713                                 (cond ((null? imps)
714                                        (for-each
715                                         (lambda (id)
716                                           (##sys#warn "renamed identifier not imported" id) )
717                                         ids)
718                                        (cons v s))
719                                       ((assq (caar imps) ids) =>
720                                        (lambda (a)
721                                          (loop impv (cdr imps)
722                                                v
723                                                (cons (cons (cadr a) (cdar imps)) s)
724                                                (##sys#delq a ids))))
725                                       (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
726                                ((assq (caar impv) ids) =>
727                                 (lambda (a)
728                                   (loop (cdr impv) imps
729                                         (cons (cons (cadr a) (cdar impv)) v)
730                                         s
731                                         (##sys#delq a ids))))
732                                (else (loop (cdr impv) imps
733                                            (cons (car impv) v)
734                                            s ids)))))
735                       ((c %prefix (car spec))
736                        (##sys#check-syntax 'prefix spec '(_ _ _))
737                        (let ((pref (tostr (caddr spec))))
738                          (define (ren imp)
739                            (cons
740                             (##sys#string->symbol 
741                              (##sys#string-append pref (##sys#symbol->string (car imp))) )
742                             (cdr imp) ) )
743                          (cons (map ren impv) (map ren imps))))
744                       (else (syntax-error 'import "invalid import specification" spec)))))))
745      (##sys#check-syntax 'import x '(_ . #(_ 1)))
746      (for-each
747       (lambda (spec)
748         (let* ((vs (import-spec spec))
749                (vsv (car vs))
750                (vss (cdr vs))
751                (cm (##sys#current-module)))
752           ;; fixup reexports
753           (when cm
754             (let ((dlist (module-defined-list cm)))
755               (define (fixup! imports)
756                 (for-each
757                  (lambda (imp)
758                    (when (##sys#find-export (car imp) cm) ;*** must process export list for every import
759                      (d "fixup reexport: " imp)
760                      (set! dlist (cons imp dlist))))
761                  imports) )
762               (fixup! vsv)
763               (fixup! vss)
764               (set-module-defined-list! cm dlist)) )
765           (d `(V: ,vsv))
766           (d `(S: ,vss))
767           (##sys#import-environment (append vsv (##sys#import-environment)))
768           (##sys#macro-environment (append vss (##sys#macro-environment))) ) )
769       (cdr x))
770      '(##core#undefined)))))
771
772(define ##sys#initial-macro-environment (##sys#macro-environment))
773
774(##sys#extend-macro-environment
775 'define
776 '()
777 (##sys#er-transformer
778  (lambda (form r c)
779    (let loop ((form (cdr form)))
780      (let ((head (car form))
781            (body (cdr form)) )
782        (cond ((not (pair? head))
783               (##sys#check-syntax 'define head 'symbol)
784               (##sys#check-syntax 'define body '#(_ 0 1))
785               (##sys#register-export head (##sys#current-module))
786               `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) )
787              ((pair? (car head))
788               (##sys#check-syntax 'define head '(_ . lambda-list))
789               (##sys#check-syntax 'define body '#(_ 1))
790               (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
791              (else
792               (##sys#check-syntax 'define head '(symbol . lambda-list))
793               (##sys#check-syntax 'define body '#(_ 1))
794               (##sys#register-export (car head) (##sys#current-module))
795               `(##core#set!
796                 ,(car head)
797                 (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
798
799(##sys#extend-macro-environment
800 'and
801 '()
802 (##sys#er-transformer
803  (lambda (form r c)
804    (let ((body (cdr form)))
805      (if (null? body)
806          #t
807          (let ((rbody (cdr body))
808                (hbody (car body)) )
809            (if (null? rbody)
810                hbody
811                `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
812
813(##sys#extend-macro-environment
814 'or 
815 '()
816 (##sys#er-transformer
817  (lambda (form r c)
818    (let ((body (cdr form)))
819     (if (null? body)
820         #f
821         (let ((rbody (cdr body))
822               (hbody (car body)))
823           (if (null? rbody)
824               hbody
825               (let ((tmp (r 'tmp)))
826                 `(,(r 'let) ((,tmp ,hbody))
827                    (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
828
829(##sys#extend-macro-environment
830 'cond
831 '()
832 (##sys#er-transformer
833  (lambda (form r c)
834    (let ((body (cdr form))
835          (%begin (r 'begin))
836          (%let (r 'let))
837          (%if (r 'if))
838          (%=> (r '=>))
839          (%or (r 'or))
840          (%else (r 'else))
841          (%lambda (r 'lambda)))
842      (let expand ((clauses body))
843        (if (not (pair? clauses))
844            '(##core#undefined)
845            (let ((clause (car clauses))
846                  (rclauses (cdr clauses)) )
847              (##sys#check-syntax 'cond clause '#(_ 1))
848              (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
849                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
850                    ((c %=> (cadr clause))
851                     (let ((tmp (r 'tmp)))
852                       `(,%let ((,tmp ,(car clause)))
853                               (,%if ,tmp
854                                     (,(caddr clause) ,tmp)
855                                     ,(expand rclauses) ) ) ) )
856                    ((and (list? clause) (fx= (length clause) 4)
857                          (c %=> (caddr clause)))
858                     (let ((tmp (r 'tmp)))
859                       `(##sys#call-with-values
860                         (,%lambda () ,(car clause))
861                         (,%lambda ,tmp
862                                   (if (##sys#apply ,(cadr clause) ,tmp)
863                                       (##sys#apply ,(cadddr clause) ,tmp)
864                                       ,(expand rclauses) ) ) ) ) )
865                    (else `(,%if ,(car clause) 
866                                 (,%begin ,@(cdr clause))
867                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
868
869(##sys#extend-macro-environment
870 'case
871 '()
872 (##sys#er-transformer
873  (lambda (form r c)
874    (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
875    (let ((exp (cadr form))
876          (body (cddr form)) )
877      (let ((tmp (r 'tmp))
878            (%begin (r 'begin))
879            (%if (r 'if))
880            (%or (r 'or))
881            (%eqv? (r 'eqv?))
882            (%else (r 'else)))
883        `(let ((,tmp ,exp))
884           ,(let expand ((clauses body))
885              (if (not (pair? clauses))
886                  '(##core#undefined)
887                  (let ((clause (car clauses))
888                        (rclauses (cdr clauses)) )
889                    (##sys#check-syntax 'case clause '#(_ 1))
890                    (if (c %else (car clause))
891                        `(,%begin ,@(cdr clause))
892                        `(,%if (,%or ,@(##sys#map
893                                        (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
894                               (,%begin ,@(cdr clause)) 
895                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
896
897(##sys#extend-macro-environment
898 'let*
899 '()
900 (##sys#er-transformer
901  (lambda (form r c)
902    (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
903    (let ((bindings (cadr form))
904          (body (cddr form)) 
905          (%let (r 'let)))
906      (let expand ((bs bindings))
907        (if (eq? bs '())
908            `(,%let () ,@body)
909            `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
910
911(##sys#extend-macro-environment
912 'letrec
913 '()
914 (##sys#er-transformer
915  (lambda (form r c)
916    (##sys#check-syntax 'letrec form '(_ #((symbol _) 0) . #(_ 1)))
917    (let ((bindings (cadr form))
918          (body (cddr form)) 
919          (%let (r 'let)) )
920      `(,%let ,(##sys#map (lambda (b) (list (car b) '(##core#undefined))) bindings)
921              ,@(##sys#map (lambda (b) `(##core#set! ,(car b) ,(cadr b))) bindings)
922              (,%let () ,@body) ) ) ) ) )
923
924(##sys#extend-macro-environment
925 'do
926 '()
927 (##sys#er-transformer
928  (lambda (form r c)
929    (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
930    (let ((bindings (cadr form))
931          (test (caddr form))
932          (body (cdddr form))
933          (dovar (r 'doloop))
934          (%let (r 'let))
935          (%if (r 'if))
936          (%begin (r 'begin)))
937      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
938              (,%if ,(car test)
939                    ,(let ((tbody (cdr test)))
940                       (if (eq? tbody '())
941                           '(##core#undefined)
942                           `(,%begin ,@tbody) ) )
943                    (,%begin
944                     ,(if (eq? body '())
945                          '(##core#undefined)
946                          `(,%let () ,@body) )
947                     (##core#app
948                      ,dovar ,@(##sys#map (lambda (b) 
949                                            (if (eq? (cdr (cdr b)) '())
950                                                (car b)
951                                                (car (cdr (cdr b))) ) )
952                                          bindings) ) ) ) ) ) ) ) )
953
954(##sys#extend-macro-environment
955 'quasiquote
956 '()
957 (##sys#er-transformer
958  (lambda (form r c)
959    (let ((%quote (r 'quote))
960          (%quasiquote (r 'quasiquote))
961          (%unquote (r 'unquote))
962          (%unquote-splicing (r 'unquote-splicing)))
963      (define (walk x n) (simplify (walk1 x n)))
964      (define (walk1 x n)
965        (cond ((vector? x)
966               `(##sys#list->vector ,(walk (vector->list x) n)) )
967              ((not (pair? x)) `(,%quote ,x))
968              (else
969               (let ((head (car x))
970                     (tail (cdr x)))
971                 (cond ((c %unquote head)
972                        (if (pair? tail)
973                            (let ((hx (car tail)))
974                              (if (eq? n 0)
975                                  hx
976                                  (list '##sys#list `(,%quote ,%unquote)
977                                        (walk hx (fx- n 1)) ) ) )
978                            `(,%quote ,%unquote) ) )
979                       ((c %quasiquote head)
980                        (if (pair? tail)
981                            `(##sys#list (,%quote ,%quasiquote) 
982                                         ,(walk (car tail) (fx+ n 1)) ) 
983                            (list '##sys#cons (list %quote %quasiquote) 
984                                  (walk tail n)) ) )
985                       ((pair? head)
986                        (let ((hx (car head))
987                              (tx (cdr head)))
988                          (if (and (c hx %unquote-splicing) (pair? tx))
989                              (let ((htx (car tx)))
990                                (if (eq? n 0)
991                                    `(##sys#append ,htx
992                                                   ,(walk tail n) )
993                                    `(##sys#cons (##sys#list %unquote-splicing
994                                                             ,(walk htx (fx- n 1)) )
995                                                 ,(walk tail n) ) ) )
996                              `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
997                       (else
998                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
999      (define (simplify x)
1000        (cond ((match-expression x '(##sys#cons a '()) '(a))
1001               => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
1002              ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
1003               => (lambda (env)
1004                    (let ([bxs (assq 'b env)])
1005                      (if (fx< (length bxs) 32)
1006                          (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
1007                                                 ,@(cdr bxs) ) ) 
1008                          x) ) ) )
1009              ((match-expression x '(##sys#append a '()) '(a))
1010               => (lambda (env) (##sys#slot (assq 'a env) 1)) )
1011              (else x) ) )
1012      (##sys#check-syntax 'quasiquote form '(_ _))
1013      (walk (cadr form) 0) ) ) ) )
1014
1015(##sys#extend-macro-environment
1016 'delay
1017 '()
1018 (##sys#er-transformer
1019  (lambda (form r c)
1020    (##sys#check-syntax 'delay form '(_ _))
1021    `(##sys#make-promise (lambda () ,(cadr form))))))
1022
1023(##sys#extend-macro-environment
1024 'cond-expand
1025 '()
1026 (##sys#er-transformer
1027  (lambda (form r c)
1028    (let ((clauses (cdr form))
1029          (%or (r 'or))
1030          (%not (r 'not))
1031          (%else (r 'else))
1032          (%begin (r 'begin))
1033          (%and (r 'and)))
1034      (define (err x) 
1035        (##sys#error "syntax error in `cond-expand' form"
1036                     x
1037                     (cons 'cond-expand clauses)) )
1038      (define (test fx)
1039        (cond ((symbol? fx) (##sys#feature? fx))
1040              ((not (pair? fx)) (err fx))
1041              (else
1042               (let ((head (car fx))
1043                     (rest (cdr fx)))
1044                 (cond ((c %and head)
1045                        (or (eq? rest '())
1046                            (if (pair? rest)
1047                                (and (test (car rest))
1048                                     (test `(,%and ,@(cdr rest))) )
1049                                (err fx) ) ) )
1050                       ((c %or head)
1051                        (and (not (eq? rest '()))
1052                             (if (pair? rest)
1053                                 (or (test (car rest))
1054                                     (test `(,%or ,@(cdr rest))) )
1055                                 (err fx) ) ) )
1056                       ((c %not head) (not (test (cadr fx))))
1057                       (else (err fx)) ) ) ) ) )
1058      (let expand ((cls clauses))
1059        (cond ((eq? cls '())
1060               (##sys#apply
1061                ##sys#error "no matching clause in `cond-expand' form" 
1062                (map (lambda (x) (car x)) clauses) ) )
1063              ((not (pair? cls)) (err cls))
1064              (else
1065               (let ((clause (car cls))
1066                    (rclauses (cdr cls)) )
1067                 (if (not (pair? clause)) 
1068                     (err clause)
1069                     (let ((id (car clause)))
1070                       (cond ((c id %else)
1071                              (let ((rest (cdr clause)))
1072                                (if (eq? rest '())
1073                                    '(##core#undefined)
1074                                    `(,%begin ,@rest) ) ) )
1075                             ((test id) `(,%begin ,@(cdr clause)))
1076                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
1077
1078(##sys#extend-macro-environment
1079 'require-extension
1080 '()
1081 (##sys#er-transformer
1082  (lambda (x r c)
1083    (let ((ids (cdr x))
1084          (%quote (r 'quote)))
1085      `(##core#require-extension ,@ids) ) ) ) )
1086
1087(##sys#extend-macro-environment
1088 'module
1089 '()
1090 (##sys#er-transformer
1091  (lambda (x r c)
1092    (##sys#check-syntax 'module x '(_ symbol #(_ 0) . #(_ 0)))
1093    `(##core#module ,@(cdr x)))))
1094
1095
1096;;; the base macro environment ("scheme", essentially)
1097
1098(define ##sys#default-macro-environment (##sys#macro-environment))
1099
1100
1101;;; syntax-rules
1102
1103(include "synrules.scm")
1104
1105
1106;;; low-level module support
1107
1108(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
1109(define ##sys#current-module (make-parameter #f))
1110
1111(declare 
1112  (hide make-module module?
1113        module-name module-vexports module-sexports
1114        set-module-vexports! set-module-sexports!
1115        module-export-list module-defined-list set-module-defined-list!))
1116
1117(define-record-type module
1118  (make-module name export-list defined-list vexports sexports) 
1119  module?
1120  (name module-name)                    ; SYMBOL
1121  (export-list module-export-list)      ; (SYMBOL | (SYMBOL ...) ...)
1122  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)
1123  (vexports module-vexports set-module-vexports!)             ; (SYMBOL . SYMBOL)
1124  (sexports module-sexports set-module-sexports!) )           ; ((SYMBOL SE TRANSFORMER) ...)
1125
1126(define (##sys#find-module name #!optional (err #t))
1127  (cond ((assq name ##sys#module-table) => cdr)
1128        (err (error 'import "module not found" name))
1129        (else #f)))
1130
1131(define (##sys#toplevel-definition-hook sym mod exp val) #f)
1132
1133(define (##sys#register-export sym mod #!optional val)
1134  (when mod
1135    (let ((exp (##sys#find-export sym mod)))
1136      (##sys#toplevel-definition-hook (##sys#module-rename sym (module-name mod)) mod exp val)
1137      (when exp
1138        (d "defined: " sym)
1139        (when (assq sym (module-defined-list mod))
1140          (##sys#warn
1141           "exported variable multiply defined"
1142           sym (module-name mod)))
1143        (set-module-defined-list! 
1144         mod
1145         (cons (cons sym val)
1146               (module-defined-list mod)))))) )
1147
1148(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
1149  (let ((mod (make-module name explist '() vexports sexports)))
1150    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
1151    mod) )
1152
1153(define (##sys#compiled-module-registration mod)
1154  (let ((dlist (module-defined-list mod)))
1155    `(##sys#register-compiled-module
1156      ',(module-name mod)
1157      ',(module-vexports mod)
1158      (list
1159       ,@(map (lambda (sexport)
1160                (let* ((name (car sexport))
1161                       (a (assq name dlist)))
1162                  (unless (pair? a)
1163                    (bomb "exported syntax has no source"))
1164                  `(cons ',(car sexport) ,(cdr a))))
1165              (module-sexports mod))))))
1166
1167(define (##sys#register-compiled-module name vexports sexports)
1168  (let ((mod (make-module 
1169              name '() '() 
1170              vexports
1171              (map (lambda (se)
1172                     (list (car se) '() (##sys#er-transformer (cdr se))))
1173                   sexports))))
1174    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1175    mod))
1176
1177(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
1178  (let* ((me (##sys#macro-environment))
1179         (mod (make-module 
1180              name '() '() 
1181              (map (lambda (ve)
1182                     (if (symbol? ve)
1183                         (cons ve ve)
1184                         ve))
1185                   vexports)
1186              (map (lambda (se)
1187                     (if (symbol? se)
1188                         (or (assq se me)
1189                             (##sys#error "unknown macro referenced while registering module" se name))
1190                         se))
1191                   sexports))))
1192    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1193    mod))
1194
1195(define (##sys#find-export sym mod)
1196  (let loop ((xl (module-export-list mod)))
1197    (cond ((null? xl) #f)
1198          ((and (symbol? (car xl)) (eq? sym (car xl))))
1199          ((memq sym (car xl)))
1200          (else (loop (cdr xl))))))
1201
1202(define (##sys#finalize-module mod me0)
1203  (let* ((explist (module-export-list mod))
1204         (name (module-name mod))
1205         (dlist (module-defined-list mod))
1206         (sexports
1207          (let loop ((me (##sys#macro-environment)))
1208            (cond ((or (null? me) (eq? me0 me)) '())
1209                  ((##sys#find-export (caar me) mod)
1210                   (cons (car me) (loop (cdr me))))
1211                  (else (loop (cdr me))))))
1212         (vexports
1213          (let loop ((xl explist))
1214            (cond ((null? xl) '())
1215                  ((symbol? (car xl))
1216                   (let ((id (car xl)))
1217                     (if (assq id sexports) 
1218                         (loop (cdr xl))
1219                         (cons (cons id
1220                                     (let ((def (assq id dlist)))
1221                                       (if (and def (symbol? (cdr def)))
1222                                           (cdr def)
1223                                           (##sys#module-rename id name))))
1224                               (loop (cdr xl))))))
1225                  (else (loop (append (cdar xl) (cdr xl))))))))
1226    (for-each
1227     (lambda (x)
1228       (unless (assq (car x) dlist)
1229         (##sys#warn "exported identifier has not been defined" (car x) name)))
1230     vexports)
1231    (d `(EXPORTS: ,(module-name mod) ,(map car dlist)
1232                  ,(map car vexports) ,(map car sexports)))
1233    (set-module-vexports! mod vexports)
1234    (set-module-sexports! mod sexports)))
1235
1236(define ##sys#module-table '())
1237
1238(define (##sys#macro-subset me0)
1239  (let loop ((me (##sys#macro-environment)))
1240    (if (or (null? me) (eq? me me0))
1241        '()
1242        (cons (car me) (loop (cdr me))))))
Note: See TracBrowser for help on using the repository browser.