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

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

removed redundant module check

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