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

Last change on this file since 12803 was 12803, checked in by felix winkelmann, 11 years ago

slightly more useful warning on missing import

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