source: project/chicken/branches/scrutiny/expand.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

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