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

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

fix for begin-capturing bug (#47), removed uses of define-macro

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