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

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

import libs only contain syntax, if syntax is exported; fixed bug in ptable-entry string reported by Brown Dragon

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