source: project/chicken/branches/dsssl-delegate/expand.scm @ 16107

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

delegation function argument for ##sys#expand-extended-lambda-list

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