source: project/chicken/branches/lazy-gensyms/expand.scm @ 12629

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

support for lazy gensyms; some refactoring in get/put\!

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