source: project/chicken/branches/prerelease/expand.scm @ 13859

Last change on this file since 13859 was 13859, checked in by felix winkelmann, 11 years ago

merged trunk rev. 13858 (not including srandom change)

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