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

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

local compiler macros; compiler macro synrules fallthrough handling; refactored define-syntax and define-compiler-syntax; bumped version to 4.0.9

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