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

Last change on this file since 14720 was 14720, checked in by Ivan Raikov, 10 years ago

typo fix

File size: 53.2 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 (chicken ;(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#+(not 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 'er-macro-transformer se)
539                                   (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def))))
540                               def)
541                           defs) 
542                     #f)))
543                 (else (loop body defs #t))))))               
544      (define (expand body)
545        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
546          (if (not (pair? body))
547              (fini vars vals mvars mvals body)
548              (let* ((x (car body))
549                     (rest (cdr body))
550                     (exp1 (and (pair? x) (car x)))
551                     (head (and exp1
552                                (symbol? exp1)
553                                (or (lookup exp1 se) exp1))))
554                (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
555                      [(eq? 'define head)
556                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
557                       (let loop2 ([x x])
558                         (let ([head (cadr x)])
559                           (cond [(not (pair? head))
560                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
561                                  (loop rest (cons head vars)
562                                        (cons (if (pair? (cddr x))
563                                                  (caddr x)
564                                                  '(##core#undefined) )
565                                              vals)
566                                        mvars mvals) ]
567                                 [(pair? (car head))
568                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
569                                  (loop2 (cons (macro-alias 'define se)
570                                               (##sys#expand-curried-define head (cddr x) se))) ]
571                                 [else
572                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
573                                  (loop rest
574                                        (cons (car head) vars)
575                                        (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
576                                        mvars mvals) ] ) ) ) ]
577                      ((eq? 'define-syntax head)
578                       (##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
579                       (fini/syntax vars vals mvars mvals body) )
580                      [(eq? 'define-values head)
581                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
582                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
583                      [(eq? 'begin head)
584                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
585                       (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
586                      ((or (memq head vars) (memq head mvars))
587                       (fini vars vals mvars mvals body))
588                      [else
589                       (let ([x2 (##sys#expand-0 x se)])
590                         (if (eq? x x2)
591                             (fini vars vals mvars mvals body)
592                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
593      (expand body) ) ) )
594
595
596;;; A simple expression matcher
597
598(define match-expression
599  (lambda (exp pat vars)
600    (let ((env '()))
601      (define (mwalk x p)
602        (cond ((not (pair? p))
603               (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
604                     ((memq p vars)
605                      (set! env (cons (cons p x) env))
606                      #t)
607                     (else (eq? x p)) ) )
608              ((pair? x)
609               (and (mwalk (car x) (car p))
610                    (mwalk (cdr x) (cdr p)) ) )
611              (else #f) ) )
612      (and (mwalk exp pat) env) ) ) )
613
614
615;;; Expand "curried" lambda-list syntax for `define'
616
617(define (##sys#expand-curried-define head body se)
618  (let ((name #f))
619    (define (loop head body)
620      (if (symbol? (car head))
621          (begin
622            (set! name (car head))
623            `(##core#lambda ,(cdr head) ,@body) )
624          (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))
625    (let ([exp (loop head body)])
626      (list name exp) ) ) )
627
628
629;;; General syntax checking routine:
630
631(define ##sys#line-number-database #f)
632(define ##sys#syntax-error-culprit #f)
633
634(define (##sys#syntax-error-hook . args)
635  (apply ##sys#signal-hook #:syntax-error
636         (##sys#strip-syntax args)))
637
638(define syntax-error ##sys#syntax-error-hook)
639
640(define (get-line-number sexp)
641  (and ##sys#line-number-database
642       (pair? sexp)
643       (let ([head (car sexp)])
644         (and (symbol? head)
645              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
646                     => (lambda (pl)
647                          (let ([a (assq sexp pl)])
648                            (and a (cdr a)) ) ) ]
649                    [else #f] ) ) ) ) )
650
651(define ##sys#check-syntax
652  (let ([string-append string-append]
653        [keyword? keyword?]
654        [get-line-number get-line-number]
655        [symbol->string symbol->string] )
656    (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
657
658      (define (test x pred msg)
659        (unless (pred x) (err msg)) )
660
661      (define (err msg)
662        (let* ([sexp ##sys#syntax-error-culprit]
663               [ln (get-line-number sexp)] )
664          (##sys#syntax-error-hook
665           (if ln 
666               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
667               (string-append "(" (symbol->string id) ") " msg) )
668           exp) ) )
669
670      (define (lambda-list? x)
671        (or (##sys#extended-lambda-list? x)
672            (let loop ((x x))
673              (cond ((null? x))
674                    ((symbol? x) (not (keyword? x)))
675                    ((pair? x)
676                     (let ((s (car x)))
677                       (and (symbol? s)
678                            (loop (cdr x)) ) ) )
679                    (else #f) ) ) ) )
680
681      (define (proper-list? x)
682        (let loop ((x x))
683          (cond ((eq? x '()))
684                ((pair? x) (loop (cdr x)))
685                (else #f) ) ) )
686
687      (when culprit (set! ##sys#syntax-error-culprit culprit))
688      (let walk ((x exp) (p pat))
689        (cond ((vector? p)
690               (let* ((p2 (vector-ref p 0))
691                      (vlen (##sys#size p))
692                      (min (if (fx> vlen 1) 
693                               (vector-ref p 1)
694                               0) )
695                      (max (cond ((eq? vlen 1) 1)
696                                 ((fx> vlen 2) (vector-ref p 2))
697                                 (else 99999) ) ) )
698                 (do ((x x (cdr x))
699                      (n 0 (fx+ n 1)) )
700                     ((eq? x '())
701                      (if (fx< n min)
702                          (err "not enough arguments") ) )
703                   (cond ((fx>= n max) 
704                          (err "too many arguments") )
705                         ((not (pair? x))
706                          (err "not a proper list") )
707                         (else (walk (car x) p2) ) ) ) ) )
708              ((##sys#immediate? p)
709               (if (not (eq? p x)) (err "unexpected object")) )
710              ((symbol? p)
711               (case p
712                 ((_) #t)
713                 ((pair) (test x pair? "pair expected"))
714                 ((variable) (test x symbol? "identifier expected"))
715                 ((symbol) (test x symbol? "symbol expected"))
716                 ((list) (test x proper-list? "proper list expected"))
717                 ((number) (test x number? "number expected"))
718                 ((string) (test x string? "string expected"))
719                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
720                 (else
721                  (test
722                   x
723                   (lambda (y)
724                     (let ((y2 (and (symbol? y) (lookup y se))))
725                       (eq? (if (symbol? y2) y2 y) p)))
726                   "missing keyword")) ) )
727              ((not (pair? p))
728               (err "incomplete form") )
729              ((not (pair? x)) (err "pair expected"))
730              (else
731               (walk (car x) (car p))
732               (walk (cdr x) (cdr p)) ) ) ) ) ) )
733
734
735;;; explicit-renaming transformer
736
737(define (er-macro-transformer x) x)
738
739(define ((##sys#er-transformer handler) form se dse)
740  (let ((renv '()))                     ; keep rename-environment for this expansion
741    (define (rename sym)
742      (cond ((assq sym renv) =>
743             (lambda (a) 
744               (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
745               (cdr a)))
746            ((lookup sym se) =>
747             (lambda (a)
748               (cond ((symbol? a)
749                      (dd `(RENAME/LOOKUP: ,sym --> ,a))
750                      a)
751                     (else
752                      (let ((a2 (macro-alias sym se)))
753                        (dd `(RENAME/LOOKUP/MACRO: ,sym --> ,a2))
754                        (set! renv (cons (cons sym a2) renv))
755                        a2)))))
756            (else
757             (let ((a (macro-alias sym se)))
758               (dd `(RENAME: ,sym --> ,a))
759               (set! renv (cons (cons sym a) renv))
760               a))))
761    (define (compare s1 s2)
762      (let ((result
763             (if (and (symbol? s1) (symbol? s2))
764                 (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
765                                (lookup2 1 s1 dse)
766                                s1) )
767                       (ss2 (or (##sys#get s2 '##core#macro-alias)
768                                (lookup2 2 s2 dse)
769                                s2) ) )
770                   (cond ((symbol? ss1)
771                          (cond ((symbol? ss2) 
772                                 (eq? (or (##sys#get ss1 '##core#primitive) ss1)
773                                      (or (##sys#get ss2 '##core#primitive) ss2)))
774                                ((assq ss1 (##sys#macro-environment)) =>
775                                 (lambda (a) (eq? (cdr a) ss2)))
776                                (else #f) ) )
777                         ((symbol? ss2)
778                          (cond ((assq ss2 (##sys#macro-environment)) =>
779                                 (lambda (a) (eq? ss1 (cdr a))))
780                                (else #f)))
781                         (else (eq? ss1 ss2))))
782                 (eq? s1 s2))) )
783        (dd `(COMPARE: ,s1 ,s2 --> ,result)) 
784        result))
785    (define (lookup2 n sym dse)
786      (let ((r (lookup sym dse)))
787        (dd "  (lookup/DSE " (list n) ": " sym " --> " 
788            (if (and r (pair? r))
789                '<macro>
790                r)
791            ")")
792        r))
793    (handler form rename compare) ) )
794
795
796;;; Macro definitions:
797
798(define (##sys#expand-import x r c import-env macro-env meta? loc)
799  (let ((%only (r 'only))
800        (%rename (r 'rename))
801        (%except (r 'except))
802        (%prefix (r 'prefix)))
803    (define (resolve sym)
804      (or (lookup sym '()) sym))        ;*** empty se?
805    (define (tostr x)
806      (cond ((string? x) x)
807            ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; why not?
808            ((symbol? x) (##sys#symbol->string x))
809            ((number? x) (number->string x))
810            (else (syntax-error loc "invalid prefix" ))))
811    (define (import-name spec)
812      (let* ((mname (resolve spec))
813             (mod (##sys#find-module mname #f)))
814        (unless mod
815          (let ((il (##sys#find-extension
816                     (string-append (symbol->string mname) ".import")
817                     #t)))
818            (cond (il (parameterize ((##sys#current-module #f)
819                                     (##sys#current-environment '())
820                                     (##sys#current-meta-environment (##sys#current-meta-environment))
821                                     (##sys#macro-environment (##sys#meta-macro-environment)))
822                        (##sys#load il #f #f))
823                      (set! mod (##sys#find-module mname)))
824                  (else
825                   (syntax-error
826                    loc "cannot import from undefined module" 
827                    mname)))))
828        (let ((vexp (module-vexports mod))
829              (sexp (module-sexports mod)))
830          (cons vexp sexp))))     
831    (define (import-spec spec)
832      (cond ((symbol? spec) (import-name spec))
833            ((or (not (list? spec)) (< (length spec) 2))
834             (syntax-error loc "invalid import specification" spec))
835            (else
836             (let* ((s (car spec))
837                    (imp (import-spec (cadr spec)))
838                    (impv (car imp))
839                    (imps (cdr imp)))
840               (cond ((c %only (car spec))
841                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
842                      (let ((ids (map resolve (cddr spec))))
843                        (let loop ((ids ids) (v '()) (s '()))
844                          (cond ((null? ids) (cons v s))
845                                ((assq (car ids) impv) =>
846                                 (lambda (a) 
847                                   (loop (cdr ids) (cons a v) s)))
848                                ((assq (car ids) imps) =>
849                                 (lambda (a) 
850                                   (loop (cdr ids) v (cons a s))))
851                                (else (loop (cdr ids) v s))))))
852                     ((c %except (car spec))
853                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
854                      (let ((ids (map resolve (cddr spec))))
855                        (let loop ((impv impv) (v '()))
856                          (cond ((null? impv)
857                                 (let loop ((imps imps) (s '()))
858                                   (cond ((null? imps) (cons v s))
859                                         ((memq (caar imps) ids) (loop (cdr imps) s))
860                                         (else (loop (cdr imps) (cons (car imps) s))))))
861                                ((memq (caar impv) ids) (loop (cdr impv) v))
862                                (else (loop (cdr impv) (cons (car impv) v)))))))
863                     ((c %rename (car spec))
864                      (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
865                      (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
866                        (cond ((null? impv) 
867                               (cond ((null? imps)
868                                      (for-each
869                                       (lambda (id)
870                                         (##sys#warn "renamed identifier not imported" id) )
871                                       ids)
872                                      (cons v s))
873                                     ((assq (caar imps) ids) =>
874                                      (lambda (a)
875                                        (loop impv (cdr imps)
876                                              v
877                                              (cons (cons (cadr a) (cdar imps)) s)
878                                              (##sys#delq a ids))))
879                                     (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
880                              ((assq (caar impv) ids) =>
881                               (lambda (a)
882                                 (loop (cdr impv) imps
883                                       (cons (cons (cadr a) (cdar impv)) v)
884                                       s
885                                       (##sys#delq a ids))))
886                              (else (loop (cdr impv) imps
887                                          (cons (car impv) v)
888                                          s ids)))))
889                     ((c %prefix (car spec))
890                      (##sys#check-syntax loc spec '(_ _ _))
891                      (let ((pref (tostr (caddr spec))))
892                        (define (ren imp)
893                          (cons
894                           (##sys#string->symbol 
895                            (##sys#string-append pref (##sys#symbol->string (car imp))) )
896                           (cdr imp) ) )
897                        (cons (map ren impv) (map ren imps))))
898                     (else (syntax-error loc "invalid import specification" spec)))))))
899    (##sys#check-syntax loc x '(_ . #(_ 1)))
900    (let ((cm (##sys#current-module)))
901      (when cm
902        ;; save import form
903        (if meta?
904            (set-module-meta-import-forms! 
905             cm
906             (append (module-meta-import-forms cm) (cdr x)))
907            (set-module-import-forms!
908             cm 
909             (append (module-import-forms cm) (cdr x)))))
910      (for-each
911       (lambda (spec)
912         (let* ((vs (import-spec spec))
913                (vsv (car vs))
914                (vss (cdr vs)))
915           (dd `(IMPORT: ,loc))
916           (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
917           (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
918           (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
919           (for-each
920            (lambda (imp)
921              (let ((id (car imp))
922                    (aid (cdr imp)))
923                (and-let* ((a (assq id (import-env)))
924                           ((not (eq? aid (cdr a)))))
925                  (##sys#warn "re-importing already imported identifier" id))))
926            vsv)
927           (for-each
928            (lambda (imp)
929              (and-let* ((a (assq (car imp) (macro-env)))
930                         ((not (eq? (cdr imp) (cdr a)))))
931                (##sys#warn "re-importing already imported syntax" (car imp))) )
932            vss)
933           (import-env (append vsv (import-env)))
934           (macro-env (append vss (macro-env)))))
935       (cdr x))
936      '(##core#undefined))))
937
938(##sys#extend-macro-environment
939 'import '() 
940 (##sys#er-transformer 
941  (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
942       #f 'import) ) )
943
944(##sys#extend-macro-environment
945 'import-for-syntax '() 
946 (##sys#er-transformer 
947  (cut ##sys#expand-import <> <> <> ##sys#current-meta-environment ##sys#meta-macro-environment 
948       #t 'import-for-syntax) ) )
949
950(define ##sys#initial-macro-environment (##sys#macro-environment))
951
952(##sys#extend-macro-environment
953 'define
954 '()
955 (##sys#er-transformer
956  (lambda (form r c)
957    (let loop ((form (cdr form)))
958      (let ((head (car form))
959            (body (cdr form)) )
960        (cond ((not (pair? head))
961               (##sys#check-syntax 'define head 'symbol)
962               (##sys#check-syntax 'define body '#(_ 0 1))
963               (##sys#register-export head (##sys#current-module))
964               `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) )
965              ((pair? (car head))
966               (##sys#check-syntax 'define head '(_ . lambda-list))
967               (##sys#check-syntax 'define body '#(_ 1))
968               (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
969              (else
970               (##sys#check-syntax 'define head '(symbol . lambda-list))
971               (##sys#check-syntax 'define body '#(_ 1))
972               (##sys#register-export (car head) (##sys#current-module))
973               `(##core#set!
974                 ,(car head)
975                 (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
976
977(##sys#extend-macro-environment
978 'and
979 '()
980 (##sys#er-transformer
981  (lambda (form r c)
982    (let ((body (cdr form)))
983      (if (null? body)
984          #t
985          (let ((rbody (cdr body))
986                (hbody (car body)) )
987            (if (null? rbody)
988                hbody
989                `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
990
991(##sys#extend-macro-environment
992 'or 
993 '()
994 (##sys#er-transformer
995  (lambda (form r c)
996    (let ((body (cdr form)))
997     (if (null? body)
998         #f
999         (let ((rbody (cdr body))
1000               (hbody (car body)))
1001           (if (null? rbody)
1002               hbody
1003               (let ((tmp (r 'tmp)))
1004                 `(,(r 'let) ((,tmp ,hbody))
1005                    (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
1006
1007(##sys#extend-macro-environment
1008 'cond
1009 '()
1010 (##sys#er-transformer
1011  (lambda (form r c)
1012    (let ((body (cdr form))
1013          (%begin (r 'begin))
1014          (%let (r 'let))
1015          (%if (r 'if))
1016          (%=> (r '=>))
1017          (%or (r 'or))
1018          (%else (r 'else))
1019          (%lambda (r 'lambda)))
1020      (let expand ((clauses body))
1021        (if (not (pair? clauses))
1022            '(##core#undefined)
1023            (let ((clause (car clauses))
1024                  (rclauses (cdr clauses)) )
1025              (##sys#check-syntax 'cond clause '#(_ 1))
1026              (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
1027                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
1028                    ((c %=> (cadr clause))
1029                     (let ((tmp (r 'tmp)))
1030                       `(,%let ((,tmp ,(car clause)))
1031                               (,%if ,tmp
1032                                     (,(caddr clause) ,tmp)
1033                                     ,(expand rclauses) ) ) ) )
1034                    ((and (list? clause) (fx= (length clause) 4)
1035                          (c %=> (caddr clause)))
1036                     (let ((tmp (r 'tmp)))
1037                       `(##sys#call-with-values
1038                         (,%lambda () ,(car clause))
1039                         (,%lambda ,tmp
1040                                   (if (##sys#apply ,(cadr clause) ,tmp)
1041                                       (##sys#apply ,(cadddr clause) ,tmp)
1042                                       ,(expand rclauses) ) ) ) ) )
1043                    (else `(,%if ,(car clause) 
1044                                 (,%begin ,@(cdr clause))
1045                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
1046
1047(##sys#extend-macro-environment
1048 'case
1049 '()
1050 (##sys#er-transformer
1051  (lambda (form r c)
1052    (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
1053    (let ((exp (cadr form))
1054          (body (cddr form)) )
1055      (let ((tmp (r 'tmp))
1056            (%begin (r 'begin))
1057            (%if (r 'if))
1058            (%or (r 'or))
1059            (%eqv? '##sys#eqv?)
1060            (%else (r 'else)))
1061        `(let ((,tmp ,exp))
1062           ,(let expand ((clauses body))
1063              (if (not (pair? clauses))
1064                  '(##core#undefined)
1065                  (let ((clause (car clauses))
1066                        (rclauses (cdr clauses)) )
1067                    (##sys#check-syntax 'case clause '#(_ 1))
1068                    (if (c %else (car clause))
1069                        `(,%begin ,@(cdr clause))
1070                        `(,%if (,%or ,@(##sys#map
1071                                        (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
1072                               (,%begin ,@(cdr clause)) 
1073                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
1074
1075(##sys#extend-macro-environment
1076 'let*
1077 '()
1078 (##sys#er-transformer
1079  (lambda (form r c)
1080    (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
1081    (let ((bindings (cadr form))
1082          (body (cddr form)) 
1083          (%let (r 'let)))
1084      (let expand ((bs bindings))
1085        (if (eq? bs '())
1086            `(,%let () ,@body)
1087            `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
1088
1089(##sys#extend-macro-environment
1090 'do
1091 '()
1092 (##sys#er-transformer
1093  (lambda (form r c)
1094    (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
1095    (let ((bindings (cadr form))
1096          (test (caddr form))
1097          (body (cdddr form))
1098          (dovar (r 'doloop))
1099          (%let (r 'let))
1100          (%if (r 'if))
1101          (%begin (r 'begin)))
1102      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
1103              (,%if ,(car test)
1104                    ,(let ((tbody (cdr test)))
1105                       (if (eq? tbody '())
1106                           '(##core#undefined)
1107                           `(,%begin ,@tbody) ) )
1108                    (,%begin
1109                     ,(if (eq? body '())
1110                          '(##core#undefined)
1111                          `(,%let () ,@body) )
1112                     (##core#app
1113                      ,dovar ,@(##sys#map (lambda (b) 
1114                                            (if (eq? (cdr (cdr b)) '())
1115                                                (car b)
1116                                                (car (cdr (cdr b))) ) )
1117                                          bindings) ) ) ) ) ) ) ) )
1118
1119(##sys#extend-macro-environment
1120 'quasiquote
1121 '()
1122 (##sys#er-transformer
1123  (lambda (form r c)
1124    (let ((%quote (r 'quote))
1125          (%quasiquote (r 'quasiquote))
1126          (%unquote (r 'unquote))
1127          (%unquote-splicing (r 'unquote-splicing)))
1128      (define (walk x n) (simplify (walk1 x n)))
1129      (define (walk1 x n)
1130        (cond ((vector? x)
1131               `(##sys#list->vector ,(walk (vector->list x) n)) )
1132              ((not (pair? x)) `(,%quote ,x))
1133              (else
1134               (let ((head (car x))
1135                     (tail (cdr x)))
1136                 (cond ((c %unquote head)
1137                        (if (pair? tail)
1138                            (let ((hx (car tail)))
1139                              (if (eq? n 0)
1140                                  hx
1141                                  (list '##sys#list `(,%quote ,%unquote)
1142                                        (walk hx (fx- n 1)) ) ) )
1143                            `(,%quote ,%unquote) ) )
1144                       ((c %quasiquote head)
1145                        (if (pair? tail)
1146                            `(##sys#list (,%quote ,%quasiquote) 
1147                                         ,(walk (car tail) (fx+ n 1)) ) 
1148                            (list '##sys#cons (list %quote %quasiquote) 
1149                                  (walk tail n)) ) )
1150                       ((pair? head)
1151                        (let ((hx (car head))
1152                              (tx (cdr head)))
1153                          (if (and (c hx %unquote-splicing) (pair? tx))
1154                              (let ((htx (car tx)))
1155                                (if (eq? n 0)
1156                                    `(##sys#append ,htx
1157                                                   ,(walk tail n) )
1158                                    `(##sys#cons (##sys#list %unquote-splicing
1159                                                             ,(walk htx (fx- n 1)) )
1160                                                 ,(walk tail n) ) ) )
1161                              `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
1162                       (else
1163                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
1164      (define (simplify x)
1165        (cond ((match-expression x '(##sys#cons a '()) '(a))
1166               => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
1167              ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
1168               => (lambda (env)
1169                    (let ([bxs (assq 'b env)])
1170                      (if (fx< (length bxs) 32)
1171                          (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
1172                                                 ,@(cdr bxs) ) ) 
1173                          x) ) ) )
1174              ((match-expression x '(##sys#append a '()) '(a))
1175               => (lambda (env) (##sys#slot (assq 'a env) 1)) )
1176              (else x) ) )
1177      (##sys#check-syntax 'quasiquote form '(_ _))
1178      (walk (cadr form) 0) ) ) ) )
1179
1180(##sys#extend-macro-environment
1181 'delay
1182 '()
1183 (##sys#er-transformer
1184  (lambda (form r c)
1185    (##sys#check-syntax 'delay form '(_ _))
1186    `(##sys#make-promise (lambda () ,(cadr form))))))
1187
1188(##sys#extend-macro-environment
1189 'cond-expand
1190 '()
1191 (##sys#er-transformer
1192  (lambda (form r c)
1193    (let ((clauses (cdr form))
1194          (%or (r 'or))
1195          (%not (r 'not))
1196          (%else (r 'else))
1197          (%begin (r 'begin))
1198          (%and (r 'and)))
1199      (define (err x) 
1200        (##sys#error "syntax error in `cond-expand' form"
1201                     x
1202                     (cons 'cond-expand clauses)) )
1203      (define (test fx)
1204        (cond ((symbol? fx) (##sys#feature? fx))
1205              ((not (pair? fx)) (err fx))
1206              (else
1207               (let ((head (car fx))
1208                     (rest (cdr fx)))
1209                 (cond ((c %and head)
1210                        (or (eq? rest '())
1211                            (if (pair? rest)
1212                                (and (test (car rest))
1213                                     (test `(,%and ,@(cdr rest))) )
1214                                (err fx) ) ) )
1215                       ((c %or head)
1216                        (and (not (eq? rest '()))
1217                             (if (pair? rest)
1218                                 (or (test (car rest))
1219                                     (test `(,%or ,@(cdr rest))) )
1220                                 (err fx) ) ) )
1221                       ((c %not head) (not (test (cadr fx))))
1222                       (else (err fx)) ) ) ) ) )
1223      (let expand ((cls clauses))
1224        (cond ((eq? cls '())
1225               (##sys#apply
1226                ##sys#error "no matching clause in `cond-expand' form" 
1227                (map (lambda (x) (car x)) clauses) ) )
1228              ((not (pair? cls)) (err cls))
1229              (else
1230               (let ((clause (car cls))
1231                    (rclauses (cdr cls)) )
1232                 (if (not (pair? clause)) 
1233                     (err clause)
1234                     (let ((id (car clause)))
1235                       (cond ((c id %else)
1236                              (let ((rest (cdr clause)))
1237                                (if (eq? rest '())
1238                                    '(##core#undefined)
1239                                    `(,%begin ,@rest) ) ) )
1240                             ((test id) `(,%begin ,@(cdr clause)))
1241                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
1242
1243(##sys#extend-macro-environment
1244 'require-library
1245 '()
1246 (##sys#er-transformer
1247  (lambda (x r c)
1248    (let ((ids (cdr x)))
1249      `(##core#require-extension ,ids #f) ) ) ) )
1250
1251(##sys#extend-macro-environment
1252 'require-extension
1253 '()
1254 (##sys#er-transformer
1255  (lambda (x r c)
1256    (let ((ids (cdr x)))
1257      `(##core#require-extension ,ids #t) ) ) ) )
1258
1259(##sys#extend-macro-environment
1260 'module
1261 '()
1262 (##sys#er-transformer
1263  (lambda (x r c)
1264    (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
1265    `(##core#module 
1266      ,(cadr x)
1267      ,(if (eq? '* (strip-syntax (caddr x))) 
1268           #t 
1269           (caddr x))
1270      ,@(cdddr x)))))
1271
1272(##sys#extend-macro-environment
1273 'begin-for-syntax
1274 '()
1275 (##sys#er-transformer
1276  (lambda (x r c)
1277    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
1278    (##sys#register-meta-expression `(begin ,@(cdr x)))
1279    `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
1280
1281(##sys#extend-macro-environment
1282 'export
1283 '()
1284 (##sys#er-transformer
1285  (lambda (x r c)
1286    (let ((exps (cdr x))
1287          (mod (##sys#current-module)))
1288      (unless mod
1289        (syntax-error 'export "`export' used outside module body"))
1290      (for-each
1291       (lambda (exp)
1292         (when (and (not (symbol? exp)) 
1293                    (let loop ((iexp exp))
1294                      (cond ((null? iexp) #f)
1295                            ((not (pair? iexp)) #t)
1296                            ((not (symbol? (car iexp))) #t)
1297                            (else (loop (cdr iexp))))))
1298           (syntax-error 'export "invalid export syntax" exp (module-name mod))))
1299       exps)
1300      (set-module-export-list! 
1301       mod
1302       (append (module-export-list mod) 
1303               (map ##sys#strip-syntax exps)))
1304      '(##sys#void)))))
1305
1306
1307;;; syntax-rules
1308
1309(include "synrules.scm")
1310
1311
1312;;; the base macro environment ("scheme", essentially)
1313
1314(define ##sys#default-macro-environment (##sys#macro-environment))
1315
1316
1317;;; low-level module support
1318
1319(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
1320(define ##sys#current-module (make-parameter #f))
1321
1322(declare 
1323  (hide make-module module? %make-module
1324        module-name module-vexports module-sexports
1325        set-module-vexports! set-module-sexports!
1326        module-export-list set-module-export-list! 
1327        module-defined-list set-module-defined-list!
1328        module-import-forms set-module-import-forms!
1329        module-meta-import-forms set-module-meta-import-forms!
1330        module-exist-list set-module-exist-list!
1331        module-meta-expressions set-module-meta-expressions!
1332        module-defined-syntax-list set-module-defined-syntax-list!))
1333
1334(define-record-type module
1335  (%make-module name export-list defined-list exist-list defined-syntax-list
1336                undefined-list import-forms meta-import-forms meta-expressions 
1337                vexports sexports) 
1338  module?
1339  (name module-name)                    ; SYMBOL
1340  (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
1341  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)    - *exported* value definitions
1342  (exist-list module-exist-list set-module-exist-list!)       ; (SYMBOL ...)    - only for checking refs to undef'd
1343  (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
1344  (undefined-list module-undefined-list set-module-undefined-list!) ; (SYMBOL ...)
1345  (import-forms module-import-forms set-module-import-forms!)       ; (SPEC ...)
1346  (meta-import-forms module-meta-import-forms set-module-meta-import-forms!)        ; (SPEC ...)
1347  (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
1348  (vexports module-vexports set-module-vexports!)             ; (SYMBOL . SYMBOL)
1349  (sexports module-sexports set-module-sexports!) )           ; ((SYMBOL SE TRANSFORMER) ...)
1350
1351(define ##sys#module-name module-name)
1352
1353(define (##sys#module-exports m)
1354  (values
1355   (module-export-list m)
1356   (module-vexports m)
1357   (module-sexports m)))
1358
1359(define (make-module name explist vexports sexports)
1360  (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
1361
1362(define (##sys#find-module name #!optional (err #t))
1363  (cond ((assq name ##sys#module-table) => cdr)
1364        (err (error 'import "module not found" name))
1365        (else #f)))
1366
1367(declare (not inline ##sys#toplevel-definition-hook))
1368
1369(define (##sys#toplevel-definition-hook sym mod exp val) #f)
1370
1371(define (##sys#register-meta-expression exp)
1372  (and-let* ((mod (##sys#current-module)))
1373    (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
1374
1375(define (check-for-redef sym env senv)
1376  (and-let* ((a (assq sym env)))
1377    (##sys#warn "redefinition of imported value binding" sym) )
1378  (and-let* ((a (assq sym senv)))
1379    (##sys#warn "redefinition of imported syntax binding" sym)))
1380
1381(define (##sys#register-export sym mod)
1382  (when mod
1383    (let ((exp (or (eq? #t (module-export-list mod))
1384                   (##sys#find-export sym mod #t)))
1385          (ulist (module-undefined-list mod)))
1386      (##sys#toplevel-definition-hook   ; in compiler, hides unexported bindings
1387       (##sys#module-rename sym (module-name mod)) 
1388       mod exp #f)
1389      (when (memq sym ulist)
1390        (set-module-undefined-list! mod (##sys#delq sym ulist)))
1391      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1392      (set-module-exist-list! mod (cons sym (module-exist-list mod)))
1393      (when exp
1394        (dm "defined: " sym)
1395        (set-module-defined-list! 
1396         mod
1397         (cons (cons sym #f)
1398               (module-defined-list mod)))))) )
1399
1400(define (##sys#register-syntax-export sym mod val)
1401  (when mod
1402    (let ((exp (or (eq? #t (module-export-list mod))
1403                   (##sys#find-export sym mod #t)))
1404          (ulist (module-undefined-list mod))
1405          (mname (module-name mod)))
1406      (when (memq sym ulist)
1407        (##sys#warn "use of syntax precedes definition" sym))
1408      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1409      (dm "defined syntax: " sym)
1410      (when exp
1411        (set-module-defined-list! 
1412         mod
1413         (cons (cons sym val)
1414               (module-defined-list mod))) )
1415      (set-module-defined-syntax-list! 
1416       mod
1417       (cons (cons sym val) (module-defined-syntax-list mod))))))
1418
1419(define (##sys#register-undefined sym mod)
1420  (when mod
1421    (let ((ul (module-undefined-list mod)))
1422      (unless (memq sym ul)
1423        (set-module-undefined-list! mod (cons sym ul))))))
1424
1425(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
1426  (let ((mod (make-module name explist vexports sexports)))
1427    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
1428    mod) )
1429
1430(define (##sys#mark-imported-symbols se)
1431  (for-each
1432   (lambda (imp)
1433     (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
1434       (dm `(MARKING: ,(cdr imp)))
1435       (##sys#put! (cdr imp) '##core#aliased #t)))
1436   se))
1437
1438(define (module-indirect-exports mod)
1439  (let ((exports (module-export-list mod))
1440        (mname (module-name mod))
1441        (dlist (module-defined-list mod)))
1442    (define (indirect? id)
1443      (let loop ((exports exports))
1444        (and (not (null? exports))
1445             (or (and (pair? (car exports))
1446                      (memq id (cdar exports)))
1447                 (loop (cdr exports))))))
1448    (define (warn msg id)
1449      (##sys#warn
1450       (string-append msg " in module `" (symbol->string mname) "'")
1451       id))
1452    (if (eq? #t exports)
1453        '()
1454        (let loop ((exports exports))   ; walk export list
1455          (cond ((null? exports) '())
1456                ((symbol? (car exports)) (loop (cdr exports))) ; normal export
1457                (else
1458                 (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
1459                   (cond ((null? iexports) (loop (cdr exports)))
1460                         ((assq (car iexports) (##sys#macro-environment))
1461                          (warn "indirect export of syntax binding" (car iexports))
1462                          (loop2 (cdr iexports)))
1463                         ((assq (car iexports) dlist) => ; defined in current module?
1464                          (lambda (a) 
1465                            (cons
1466                             (cons
1467                              (car iexports)
1468                              (or (cdr a) (##sys#module-rename (car iexports) mname)))
1469                             (loop2 (cdr iexports)))))
1470                         ((assq (car iexports) (##sys#current-environment)) =>
1471                          (lambda (a)   ; imported in current env.
1472                            (cond ((symbol? (cdr a)) ; not syntax
1473                                   (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
1474                                  (else
1475                                   (warn "indirect reexport of syntax" (car iexports))
1476                                   (loop2 (cdr iexports))))))
1477                         (else
1478                          (warn "indirect export of unknown binding" (car iexports))
1479                          (loop2 (cdr iexports)))))))))))
1480
1481(define (merge-se . ses)                ; later occurrences take precedence to earlier ones
1482  (let ((se (apply append ses)))
1483    (dm "merging " (length ses) " se's with total length of " (length se))
1484    (let ((se2
1485           (let loop ((se se))
1486             (cond ((null? se) '())
1487                   ((assq (caar se) (cdr se)) (loop (cdr se)))
1488                   (else (cons (car se) (loop (cdr se))))))))
1489      (dm "  merged has length " (length se2))
1490      se2)))
1491
1492(define (##sys#compiled-module-registration mod)
1493  (let ((dlist (module-defined-list mod))
1494        (mname (module-name mod))
1495        (ifs (module-import-forms mod))
1496        (sexports (module-sexports mod))
1497        (mifs (module-meta-import-forms mod)))
1498    `(,@(if (pair? ifs) `((eval '(import ,@ifs))) '())
1499      ,@(if (pair? mifs) `((import ,@mifs)) '())
1500      ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
1501      (##sys#register-compiled-module
1502       ',(module-name mod)
1503       (list
1504        ,@(map (lambda (ie)
1505                 (if (symbol? (cdr ie))
1506                     `'(,(car ie) . ,(cdr ie))
1507                     `(list ',(car ie) '() ,(cdr ie))))
1508               (module-indirect-exports mod)))
1509       ',(module-vexports mod)
1510       (list
1511        ,@(map (lambda (sexport)
1512                 (let* ((name (car sexport))
1513                        (a (assq name dlist)))
1514                   (cond ((pair? a) 
1515                          `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
1516                         (else
1517                          (dm "re-exported syntax" name mname)
1518                          `',name))))
1519               sexports))
1520       (list
1521        ,@(if (null? sexports)
1522              '()                       ; no syntax exported - no more info needed
1523              (let loop ((sd (module-defined-syntax-list mod)))
1524                (cond ((null? sd) '())
1525                      ((assq (caar sd) sexports) (loop (cdr sd)))
1526                      (else
1527                       (let ((name (caar sd)))
1528                         (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
1529                               (loop (cdr sd)))))))))))))
1530
1531(define (##sys#register-compiled-module name iexports vexports sexports #!optional
1532                                        (sdefs '()))
1533  (define (find-reexport name)
1534    (let ((a (assq name (##sys#macro-environment))))
1535      (if (and a (pair? (cdr a)))
1536          a
1537          (##sys#error
1538           'import "cannot find implementation of re-exported syntax"
1539           name))))
1540  (let* ((sexps
1541          (map (lambda (se)
1542                 (if (symbol? se)
1543                     (find-reexport se)
1544                     (list (car se) #f (##sys#er-transformer (cdr se)))))
1545               sexports))
1546         (iexps 
1547          (map (lambda (ie)
1548                 (if (pair? (cdr ie))
1549                     (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
1550                     ie))
1551               iexports))
1552         (nexps
1553          (map (lambda (ne)
1554                 (list (car ne) #f (##sys#er-transformer (cdr ne))))
1555               sdefs))
1556         (mod (make-module name '() vexports sexps))
1557         (senv (merge-se 
1558                (##sys#macro-environment)
1559                (##sys#current-environment)
1560                iexps vexports sexps nexps)))
1561    (##sys#mark-imported-symbols iexps)
1562    (for-each
1563     (lambda (sexp)
1564       (set-car! (cdr sexp) senv))
1565     sexps)
1566    (for-each
1567     (lambda (iexp)
1568       (when (pair? (cdr iexp))
1569         (set-car! (cdr iexp) senv)))
1570     iexps)
1571    (for-each
1572     (lambda (nexp)
1573       (set-car! (cdr nexp) senv))
1574     nexps)
1575    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1576    mod))
1577
1578(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
1579  (let* ((me (##sys#macro-environment))
1580         (mod (make-module 
1581               name '()
1582               (map (lambda (ve)
1583                      (if (symbol? ve)
1584                          (let ((palias 
1585                                 (##sys#string->symbol 
1586                                  (##sys#string-append "#%" (##sys#slot ve 1)))))
1587                            (##sys#put! palias '##core#primitive ve)
1588                            (cons ve palias))
1589                          ve))
1590                    vexports)
1591               (map (lambda (se)
1592                      (if (symbol? se)
1593                          (or (assq se me)
1594                              (##sys#error "unknown macro referenced while registering module" se name))
1595                          se))
1596                    sexports))))
1597    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1598    mod))
1599
1600(define (##sys#find-export sym mod indirect)
1601  (let ((exports (module-export-list mod)))
1602    (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
1603      (cond ((null? xl) #f)
1604            ((eq? sym (car xl)))
1605            ((pair? (car xl))
1606             (or (eq? sym (caar xl))
1607                 (and indirect (memq sym (cdar xl)))
1608                 (loop (cdr xl))))
1609            (else (loop (cdr xl)))))))
1610
1611(define (##sys#finalize-module mod)
1612  (let* ((explist (module-export-list mod))
1613         (name (module-name mod))
1614         (dlist (module-defined-list mod))
1615         (elist (module-exist-list mod))
1616         (missing #f)
1617         (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
1618                      (module-defined-syntax-list mod)))
1619         (sexports
1620          (if (eq? #t explist)
1621              sdlist
1622              (let loop ((me (##sys#macro-environment)))
1623                (cond ((null? me) '())
1624                      ((##sys#find-export (caar me) mod #f)
1625                       (cons (car me) (loop (cdr me))))
1626                      (else (loop (cdr me)))))))
1627         (vexports
1628          (let loop ((xl (if (eq? #t explist) elist explist)))
1629            (if (null? xl)
1630                '()
1631                (let* ((h (car xl))
1632                       (id (if (symbol? h) h (car h))))
1633                  (if (assq id sexports) 
1634                      (loop (cdr xl))
1635                      (cons
1636                       (cons
1637                        id
1638                        (let ((def (assq id dlist)))
1639                          (if (and def (symbol? (cdr def))) 
1640                              (cdr def)
1641                              (let ((a (assq id (##sys#current-environment))))
1642                                (cond ((and a (symbol? (cdr a))) 
1643                                       (dm "reexporting: " id " -> " (cdr a))
1644                                       (cdr a)) 
1645                                      ((not def)
1646                                       (set! missing #t)
1647                                       (##sys#warn 
1648                                        (string-append
1649                                         "exported identifier for module `" 
1650                                         (symbol->string name)
1651                                         "' has not been defined")
1652                                        id)
1653                                       #f)
1654                                      (else (##sys#module-rename id name)))))))
1655                       (loop (cdr xl)))))))))
1656    (for-each
1657     (lambda (u)
1658       (unless (memq u elist)
1659         (set! missing #t)
1660         (##sys#warn "reference to possibly unbound identifier" u)
1661         (and-let* ((a (##sys#get u '##core#db)))
1662           (if (= 1 (length a))
1663               (##sys#warn
1664                (string-append
1665                 "  suggesting: `(import " (symbol->string (cadar a)) 
1666                 ")'"))
1667               (##sys#warn
1668                (string-append
1669                 "  suggesting one of:\n"
1670                 (let loop ((lst a))
1671                   (if (null? lst)
1672                       ""
1673                       (string-append
1674                        "Warning:     `(import " (symbol->string (cadar lst)) ")'\n"
1675                        (loop (cdr lst)))))))))))
1676     (module-undefined-list mod))
1677    (when missing
1678      (##sys#error "module unresolved" name))
1679    (let* ((exports 
1680            (map (lambda (exp)
1681                   (cond ((symbol? (cdr exp)) exp)
1682                         ((assq (car exp) (##sys#macro-environment)))
1683                         (else (##sys#error "(internal) indirect export not found" (car exp)))) )
1684                 (module-indirect-exports mod)))
1685           (new-se (merge-se 
1686                    (##sys#macro-environment) 
1687                    (##sys#current-environment) 
1688                    exports)))
1689      (##sys#mark-imported-symbols exports)
1690      (for-each
1691       (lambda (m)
1692         (let ((se (merge-se (cadr m) new-se)))
1693           (dm `(FIXUP: ,(car m) ,@(map-se se)))
1694           (set-car! (cdr m) se)))
1695       sdlist)
1696      (dm `(EXPORTS: 
1697            ,(module-name mod) 
1698            (DLIST: ,@dlist)
1699            (SDLIST: ,@(map-se sdlist))
1700            (IEXPORTS: ,@(map-se exports))
1701            (VEXPORTS: ,@(map-se vexports))
1702            (SEXPORTS: ,@(map-se sexports))))
1703      (set-module-vexports! mod vexports)
1704      (set-module-sexports! mod sexports))))
1705
1706(define ##sys#module-table '())
1707
1708(define (##sys#macro-subset me0)
1709  (let loop ((me (##sys#macro-environment)))
1710    (if (or (null? me) (eq? me me0))
1711        '()
1712        (cons (car me) (loop (cdr me))))))
Note: See TracBrowser for help on using the repository browser.