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

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

some types; fixnum and float type specifiers

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