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

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

handle import-for-syntax differently

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