source: project/chicken/branches/prerelease/expand.scm @ 13414

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

merged with trunk rev. 13389

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