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

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

added er-macro-transformer

File size: 52.7 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)
534                                  (,(macro-alias 'er-macro-transformer se)
535                                   (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def))))
536                               def)
537                           defs) 
538                     #f)))
539                 (else (loop body defs #t))))))               
540      (define (expand body)
541        (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
542          (if (not (pair? body))
543              (fini vars vals mvars mvals body)
544              (let* ((x (car body))
545                     (rest (cdr body))
546                     (exp1 (and (pair? x) (car x)))
547                     (head (and exp1
548                                (symbol? exp1)
549                                (or (lookup exp1 se) exp1))))
550                (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
551                      [(eq? 'define head)
552                       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
553                       (let loop2 ([x x])
554                         (let ([head (cadr x)])
555                           (cond [(not (pair? head))
556                                  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
557                                  (loop rest (cons head vars)
558                                        (cons (if (pair? (cddr x))
559                                                  (caddr x)
560                                                  '(##core#undefined) )
561                                              vals)
562                                        mvars mvals) ]
563                                 [(pair? (car head))
564                                  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
565                                  (loop2 (cons (macro-alias 'define se)
566                                               (##sys#expand-curried-define head (cddr x) se))) ]
567                                 [else
568                                  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
569                                  (loop rest
570                                        (cons (car head) vars)
571                                        (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
572                                        mvars mvals) ] ) ) ) ]
573                      ((eq? 'define-syntax head)
574                       (##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
575                       (fini/syntax vars vals mvars mvals body) )
576                      [(eq? 'define-values head)
577                       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
578                       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
579                      [(eq? 'begin head)
580                       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
581                       (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
582                      ((or (memq head vars) (memq head mvars))
583                       (fini vars vals mvars mvals body))
584                      [else
585                       (let ([x2 (##sys#expand-0 x se)])
586                         (if (eq? x x2)
587                             (fini vars vals mvars mvals body)
588                             (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
589      (expand body) ) ) )
590
591
592;;; A simple expression matcher
593
594(define match-expression
595  (lambda (exp pat vars)
596    (let ((env '()))
597      (define (mwalk x p)
598        (cond ((not (pair? p))
599               (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
600                     ((memq p vars)
601                      (set! env (cons (cons p x) env))
602                      #t)
603                     (else (eq? x p)) ) )
604              ((pair? x)
605               (and (mwalk (car x) (car p))
606                    (mwalk (cdr x) (cdr p)) ) )
607              (else #f) ) )
608      (and (mwalk exp pat) env) ) ) )
609
610
611;;; Expand "curried" lambda-list syntax for `define'
612
613(define (##sys#expand-curried-define head body se)
614  (let ((name #f))
615    (define (loop head body)
616      (if (symbol? (car head))
617          (begin
618            (set! name (car head))
619            `(##core#lambda ,(cdr head) ,@body) )
620          (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))
621    (let ([exp (loop head body)])
622      (list name exp) ) ) )
623
624
625;;; General syntax checking routine:
626
627(define ##sys#line-number-database #f)
628(define ##sys#syntax-error-culprit #f)
629
630(define (##sys#syntax-error-hook . args)
631  (apply ##sys#signal-hook #:syntax-error
632         (##sys#strip-syntax args)))
633
634(define syntax-error ##sys#syntax-error-hook)
635
636(define (get-line-number sexp)
637  (and ##sys#line-number-database
638       (pair? sexp)
639       (let ([head (car sexp)])
640         (and (symbol? head)
641              (cond [(##sys#hash-table-ref ##sys#line-number-database head)
642                     => (lambda (pl)
643                          (let ([a (assq sexp pl)])
644                            (and a (cdr a)) ) ) ]
645                    [else #f] ) ) ) ) )
646
647(define ##sys#check-syntax
648  (let ([string-append string-append]
649        [keyword? keyword?]
650        [get-line-number get-line-number]
651        [symbol->string symbol->string] )
652    (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
653
654      (define (test x pred msg)
655        (unless (pred x) (err msg)) )
656
657      (define (err msg)
658        (let* ([sexp ##sys#syntax-error-culprit]
659               [ln (get-line-number sexp)] )
660          (##sys#syntax-error-hook
661           (if ln 
662               (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
663               (string-append "(" (symbol->string id) ") " msg) )
664           exp) ) )
665
666      (define (lambda-list? x)
667        (or (##sys#extended-lambda-list? x)
668            (let loop ((x x))
669              (cond ((null? x))
670                    ((symbol? x) (not (keyword? x)))
671                    ((pair? x)
672                     (let ((s (car x)))
673                       (and (symbol? s)
674                            (loop (cdr x)) ) ) )
675                    (else #f) ) ) ) )
676
677      (define (proper-list? x)
678        (let loop ((x x))
679          (cond ((eq? x '()))
680                ((pair? x) (loop (cdr x)))
681                (else #f) ) ) )
682
683      (when culprit (set! ##sys#syntax-error-culprit culprit))
684      (let walk ((x exp) (p pat))
685        (cond ((vector? p)
686               (let* ((p2 (vector-ref p 0))
687                      (vlen (##sys#size p))
688                      (min (if (fx> vlen 1) 
689                               (vector-ref p 1)
690                               0) )
691                      (max (cond ((eq? vlen 1) 1)
692                                 ((fx> vlen 2) (vector-ref p 2))
693                                 (else 99999) ) ) )
694                 (do ((x x (cdr x))
695                      (n 0 (fx+ n 1)) )
696                     ((eq? x '())
697                      (if (fx< n min)
698                          (err "not enough arguments") ) )
699                   (cond ((fx>= n max) 
700                          (err "too many arguments") )
701                         ((not (pair? x))
702                          (err "not a proper list") )
703                         (else (walk (car x) p2) ) ) ) ) )
704              ((##sys#immediate? p)
705               (if (not (eq? p x)) (err "unexpected object")) )
706              ((symbol? p)
707               (case p
708                 ((_) #t)
709                 ((pair) (test x pair? "pair expected"))
710                 ((variable) (test x symbol? "identifier expected"))
711                 ((symbol) (test x symbol? "symbol expected"))
712                 ((list) (test x proper-list? "proper list expected"))
713                 ((number) (test x number? "number expected"))
714                 ((string) (test x string? "string expected"))
715                 ((lambda-list) (test x lambda-list? "lambda-list expected"))
716                 (else
717                  (test
718                   x
719                   (lambda (y)
720                     (let ((y2 (and (symbol? y) (lookup y se))))
721                       (eq? (if (symbol? y2) y2 y) p)))
722                   "missing keyword")) ) )
723              ((not (pair? p))
724               (err "incomplete form") )
725              ((not (pair? x)) (err "pair expected"))
726              (else
727               (walk (car x) (car p))
728               (walk (cdr x) (cdr p)) ) ) ) ) ) )
729
730
731;;; explicit-renaming transformer
732
733(define (er-macro-transformer x) x)
734
735(define ((##sys#er-transformer handler) form se dse)
736  (let ((renv '()))                     ; keep rename-environment for this expansion
737    (define (rename sym)
738      (cond ((assq sym renv) =>
739             (lambda (a) 
740               (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
741               (cdr a)))
742            ((lookup sym se) =>
743             (lambda (a)
744               (cond ((symbol? a)
745                      (dd `(RENAME/LOOKUP: ,sym --> ,a))
746                      a)
747                     (else
748                      (let ((a2 (macro-alias sym se)))
749                        (dd `(RENAME/LOOKUP/MACRO: ,sym --> ,a2))
750                        (set! renv (cons (cons sym a2) renv))
751                        a2)))))
752            (else
753             (let ((a (macro-alias sym se)))
754               (dd `(RENAME: ,sym --> ,a))
755               (set! renv (cons (cons sym a) renv))
756               a))))
757    (define (compare s1 s2)
758      (let ((result
759             (if (and (symbol? s1) (symbol? s2))
760                 (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
761                                (lookup2 1 s1 dse)
762                                s1) )
763                       (ss2 (or (##sys#get s2 '##core#macro-alias)
764                                (lookup2 2 s2 dse)
765                                s2) ) )
766                   (cond ((symbol? ss1)
767                          (cond ((symbol? ss2) 
768                                 (eq? (or (##sys#get ss1 '##core#primitive) ss1)
769                                      (or (##sys#get ss2 '##core#primitive) ss2)))
770                                ((assq ss1 (##sys#macro-environment)) =>
771                                 (lambda (a) (eq? (cdr a) ss2)))
772                                (else #f) ) )
773                         ((symbol? ss2)
774                          (cond ((assq ss2 (##sys#macro-environment)) =>
775                                 (lambda (a) (eq? ss1 (cdr a))))
776                                (else #f)))
777                         (else (eq? ss1 ss2))))
778                 (eq? s1 s2))) )
779        (dd `(COMPARE: ,s1 ,s2 --> ,result)) 
780        result))
781    (define (lookup2 n sym dse)
782      (let ((r (lookup sym dse)))
783        (dd "  (lookup/DSE " (list n) ": " sym " --> " 
784            (if (and r (pair? r))
785                '<macro>
786                r)
787            ")")
788        r))
789    (handler form rename compare) ) )
790
791
792;;; Macro definitions:
793
794(define (##sys#expand-import x r c import-env macro-env meta? loc)
795  (let ((%only (r 'only))
796        (%rename (r 'rename))
797        (%except (r 'except))
798        (%prefix (r 'prefix)))
799    (define (resolve sym)
800      (or (lookup sym '()) sym))        ;*** empty se?
801    (define (tostr x)
802      (cond ((string? x) x)
803            ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; why not?
804            ((symbol? x) (##sys#symbol->string x))
805            ((number? x) (number->string x))
806            (else (syntax-error loc "invalid prefix" ))))
807    (define (import-name spec)
808      (let* ((mname (resolve spec))
809             (mod (##sys#find-module mname #f)))
810        (unless mod
811          (let ((il (##sys#find-extension
812                     (string-append (symbol->string mname) ".import")
813                     #t)))
814            (cond (il (parameterize ((##sys#current-module #f)
815                                     (##sys#current-environment '())
816                                     (##sys#current-meta-environment (##sys#current-meta-environment))
817                                     (##sys#macro-environment (##sys#meta-macro-environment)))
818                        (##sys#load il #f #f))
819                      (set! mod (##sys#find-module mname)))
820                  (else
821                   (syntax-error
822                    loc "cannot import from undefined module" 
823                    mname)))))
824        (let ((vexp (module-vexports mod))
825              (sexp (module-sexports mod)))
826          (cons vexp sexp))))     
827    (define (import-spec spec)
828      (cond ((symbol? spec) (import-name spec))
829            ((or (not (list? spec)) (< (length spec) 2))
830             (syntax-error loc "invalid import specification" spec))
831            (else
832             (let* ((s (car spec))
833                    (imp (import-spec (cadr spec)))
834                    (impv (car imp))
835                    (imps (cdr imp)))
836               (cond ((c %only (car spec))
837                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
838                      (let ((ids (map resolve (cddr spec))))
839                        (let loop ((ids ids) (v '()) (s '()))
840                          (cond ((null? ids) (cons v s))
841                                ((assq (car ids) impv) =>
842                                 (lambda (a) 
843                                   (loop (cdr ids) (cons a v) s)))
844                                ((assq (car ids) imps) =>
845                                 (lambda (a) 
846                                   (loop (cdr ids) v (cons a s))))
847                                (else (loop (cdr ids) v s))))))
848                     ((c %except (car spec))
849                      (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
850                      (let ((ids (map resolve (cddr spec))))
851                        (let loop ((impv impv) (v '()))
852                          (cond ((null? impv)
853                                 (let loop ((imps imps) (s '()))
854                                   (cond ((null? imps) (cons v s))
855                                         ((memq (caar imps) ids) (loop (cdr imps) s))
856                                         (else (loop (cdr imps) (cons (car imps) s))))))
857                                ((memq (caar impv) ids) (loop (cdr impv) v))
858                                (else (loop (cdr impv) (cons (car impv) v)))))))
859                     ((c %rename (car spec))
860                      (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
861                      (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
862                        (cond ((null? impv) 
863                               (cond ((null? imps)
864                                      (for-each
865                                       (lambda (id)
866                                         (##sys#warn "renamed identifier not imported" id) )
867                                       ids)
868                                      (cons v s))
869                                     ((assq (caar imps) ids) =>
870                                      (lambda (a)
871                                        (loop impv (cdr imps)
872                                              v
873                                              (cons (cons (cadr a) (cdar imps)) s)
874                                              (##sys#delq a ids))))
875                                     (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
876                              ((assq (caar impv) ids) =>
877                               (lambda (a)
878                                 (loop (cdr impv) imps
879                                       (cons (cons (cadr a) (cdar impv)) v)
880                                       s
881                                       (##sys#delq a ids))))
882                              (else (loop (cdr impv) imps
883                                          (cons (car impv) v)
884                                          s ids)))))
885                     ((c %prefix (car spec))
886                      (##sys#check-syntax loc spec '(_ _ _))
887                      (let ((pref (tostr (caddr spec))))
888                        (define (ren imp)
889                          (cons
890                           (##sys#string->symbol 
891                            (##sys#string-append pref (##sys#symbol->string (car imp))) )
892                           (cdr imp) ) )
893                        (cons (map ren impv) (map ren imps))))
894                     (else (syntax-error loc "invalid import specification" spec)))))))
895    (##sys#check-syntax loc x '(_ . #(_ 1)))
896    (let ((cm (##sys#current-module)))
897      (when cm
898        ;; save import form
899        (if meta?
900            (set-module-meta-import-forms! 
901             cm
902             (append (module-meta-import-forms cm) (cdr x)))
903            (set-module-import-forms!
904             cm 
905             (append (module-import-forms cm) (cdr x)))))
906      (for-each
907       (lambda (spec)
908         (let* ((vs (import-spec spec))
909                (vsv (car vs))
910                (vss (cdr vs)))
911           (dd `(IMPORT: ,loc))
912           (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
913           (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
914           (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
915           (for-each
916            (lambda (imp)
917              (let ((id (car imp))
918                    (aid (cdr imp)))
919                (and-let* ((a (assq id (import-env)))
920                           ((not (eq? aid (cdr a)))))
921                  (##sys#warn "re-importing already imported identfier" id))))
922            vsv)
923           (for-each
924            (lambda (imp)
925              (and-let* ((a (assq (car imp) (macro-env)))
926                         ((not (eq? (cdr imp) (cdr a)))))
927                (##sys#warn "re-importing already imported syntax" (car imp))) )
928            vss)
929           (import-env (append vsv (import-env)))
930           (macro-env (append vss (macro-env)))))
931       (cdr x))
932      '(##core#undefined))))
933
934(##sys#extend-macro-environment
935 'import '() 
936 (##sys#er-transformer 
937  (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
938       #f 'import) ) )
939
940(##sys#extend-macro-environment
941 'import-for-syntax '() 
942 (##sys#er-transformer 
943  (cut ##sys#expand-import <> <> <> ##sys#current-meta-environment ##sys#meta-macro-environment 
944       #t 'import-for-syntax) ) )
945
946(define ##sys#initial-macro-environment (##sys#macro-environment))
947
948(##sys#extend-macro-environment
949 'define
950 '()
951 (##sys#er-transformer
952  (lambda (form r c)
953    (let loop ((form (cdr form)))
954      (let ((head (car form))
955            (body (cdr form)) )
956        (cond ((not (pair? head))
957               (##sys#check-syntax 'define head 'symbol)
958               (##sys#check-syntax 'define body '#(_ 0 1))
959               (##sys#register-export head (##sys#current-module))
960               `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) )
961              ((pair? (car head))
962               (##sys#check-syntax 'define head '(_ . lambda-list))
963               (##sys#check-syntax 'define body '#(_ 1))
964               (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
965              (else
966               (##sys#check-syntax 'define head '(symbol . lambda-list))
967               (##sys#check-syntax 'define body '#(_ 1))
968               (##sys#register-export (car head) (##sys#current-module))
969               `(##core#set!
970                 ,(car head)
971                 (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
972
973(##sys#extend-macro-environment
974 'and
975 '()
976 (##sys#er-transformer
977  (lambda (form r c)
978    (let ((body (cdr form)))
979      (if (null? body)
980          #t
981          (let ((rbody (cdr body))
982                (hbody (car body)) )
983            (if (null? rbody)
984                hbody
985                `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
986
987(##sys#extend-macro-environment
988 'or 
989 '()
990 (##sys#er-transformer
991  (lambda (form r c)
992    (let ((body (cdr form)))
993     (if (null? body)
994         #f
995         (let ((rbody (cdr body))
996               (hbody (car body)))
997           (if (null? rbody)
998               hbody
999               (let ((tmp (r 'tmp)))
1000                 `(,(r 'let) ((,tmp ,hbody))
1001                    (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
1002
1003(##sys#extend-macro-environment
1004 'cond
1005 '()
1006 (##sys#er-transformer
1007  (lambda (form r c)
1008    (let ((body (cdr form))
1009          (%begin (r 'begin))
1010          (%let (r 'let))
1011          (%if (r 'if))
1012          (%=> (r '=>))
1013          (%or (r 'or))
1014          (%else (r 'else))
1015          (%lambda (r 'lambda)))
1016      (let expand ((clauses body))
1017        (if (not (pair? clauses))
1018            '(##core#undefined)
1019            (let ((clause (car clauses))
1020                  (rclauses (cdr clauses)) )
1021              (##sys#check-syntax 'cond clause '#(_ 1))
1022              (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
1023                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
1024                    ((c %=> (cadr clause))
1025                     (let ((tmp (r 'tmp)))
1026                       `(,%let ((,tmp ,(car clause)))
1027                               (,%if ,tmp
1028                                     (,(caddr clause) ,tmp)
1029                                     ,(expand rclauses) ) ) ) )
1030                    ((and (list? clause) (fx= (length clause) 4)
1031                          (c %=> (caddr clause)))
1032                     (let ((tmp (r 'tmp)))
1033                       `(##sys#call-with-values
1034                         (,%lambda () ,(car clause))
1035                         (,%lambda ,tmp
1036                                   (if (##sys#apply ,(cadr clause) ,tmp)
1037                                       (##sys#apply ,(cadddr clause) ,tmp)
1038                                       ,(expand rclauses) ) ) ) ) )
1039                    (else `(,%if ,(car clause) 
1040                                 (,%begin ,@(cdr clause))
1041                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
1042
1043(##sys#extend-macro-environment
1044 'case
1045 '()
1046 (##sys#er-transformer
1047  (lambda (form r c)
1048    (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
1049    (let ((exp (cadr form))
1050          (body (cddr form)) )
1051      (let ((tmp (r 'tmp))
1052            (%begin (r 'begin))
1053            (%if (r 'if))
1054            (%or (r 'or))
1055            (%eqv? '##sys#eqv?)
1056            (%else (r 'else)))
1057        `(let ((,tmp ,exp))
1058           ,(let expand ((clauses body))
1059              (if (not (pair? clauses))
1060                  '(##core#undefined)
1061                  (let ((clause (car clauses))
1062                        (rclauses (cdr clauses)) )
1063                    (##sys#check-syntax 'case clause '#(_ 1))
1064                    (if (c %else (car clause))
1065                        `(,%begin ,@(cdr clause))
1066                        `(,%if (,%or ,@(##sys#map
1067                                        (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
1068                               (,%begin ,@(cdr clause)) 
1069                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
1070
1071(##sys#extend-macro-environment
1072 'let*
1073 '()
1074 (##sys#er-transformer
1075  (lambda (form r c)
1076    (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
1077    (let ((bindings (cadr form))
1078          (body (cddr form)) 
1079          (%let (r 'let)))
1080      (let expand ((bs bindings))
1081        (if (eq? bs '())
1082            `(,%let () ,@body)
1083            `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
1084
1085(##sys#extend-macro-environment
1086 'do
1087 '()
1088 (##sys#er-transformer
1089  (lambda (form r c)
1090    (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
1091    (let ((bindings (cadr form))
1092          (test (caddr form))
1093          (body (cdddr form))
1094          (dovar (r 'doloop))
1095          (%let (r 'let))
1096          (%if (r 'if))
1097          (%begin (r 'begin)))
1098      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
1099              (,%if ,(car test)
1100                    ,(let ((tbody (cdr test)))
1101                       (if (eq? tbody '())
1102                           '(##core#undefined)
1103                           `(,%begin ,@tbody) ) )
1104                    (,%begin
1105                     ,(if (eq? body '())
1106                          '(##core#undefined)
1107                          `(,%let () ,@body) )
1108                     (##core#app
1109                      ,dovar ,@(##sys#map (lambda (b) 
1110                                            (if (eq? (cdr (cdr b)) '())
1111                                                (car b)
1112                                                (car (cdr (cdr b))) ) )
1113                                          bindings) ) ) ) ) ) ) ) )
1114
1115(##sys#extend-macro-environment
1116 'quasiquote
1117 '()
1118 (##sys#er-transformer
1119  (lambda (form r c)
1120    (let ((%quote (r 'quote))
1121          (%quasiquote (r 'quasiquote))
1122          (%unquote (r 'unquote))
1123          (%unquote-splicing (r 'unquote-splicing)))
1124      (define (walk x n) (simplify (walk1 x n)))
1125      (define (walk1 x n)
1126        (cond ((vector? x)
1127               `(##sys#list->vector ,(walk (vector->list x) n)) )
1128              ((not (pair? x)) `(,%quote ,x))
1129              (else
1130               (let ((head (car x))
1131                     (tail (cdr x)))
1132                 (cond ((c %unquote head)
1133                        (if (pair? tail)
1134                            (let ((hx (car tail)))
1135                              (if (eq? n 0)
1136                                  hx
1137                                  (list '##sys#list `(,%quote ,%unquote)
1138                                        (walk hx (fx- n 1)) ) ) )
1139                            `(,%quote ,%unquote) ) )
1140                       ((c %quasiquote head)
1141                        (if (pair? tail)
1142                            `(##sys#list (,%quote ,%quasiquote) 
1143                                         ,(walk (car tail) (fx+ n 1)) ) 
1144                            (list '##sys#cons (list %quote %quasiquote) 
1145                                  (walk tail n)) ) )
1146                       ((pair? head)
1147                        (let ((hx (car head))
1148                              (tx (cdr head)))
1149                          (if (and (c hx %unquote-splicing) (pair? tx))
1150                              (let ((htx (car tx)))
1151                                (if (eq? n 0)
1152                                    `(##sys#append ,htx
1153                                                   ,(walk tail n) )
1154                                    `(##sys#cons (##sys#list %unquote-splicing
1155                                                             ,(walk htx (fx- n 1)) )
1156                                                 ,(walk tail n) ) ) )
1157                              `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
1158                       (else
1159                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
1160      (define (simplify x)
1161        (cond ((match-expression x '(##sys#cons a '()) '(a))
1162               => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
1163              ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
1164               => (lambda (env)
1165                    (let ([bxs (assq 'b env)])
1166                      (if (fx< (length bxs) 32)
1167                          (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
1168                                                 ,@(cdr bxs) ) ) 
1169                          x) ) ) )
1170              ((match-expression x '(##sys#append a '()) '(a))
1171               => (lambda (env) (##sys#slot (assq 'a env) 1)) )
1172              (else x) ) )
1173      (##sys#check-syntax 'quasiquote form '(_ _))
1174      (walk (cadr form) 0) ) ) ) )
1175
1176(##sys#extend-macro-environment
1177 'delay
1178 '()
1179 (##sys#er-transformer
1180  (lambda (form r c)
1181    (##sys#check-syntax 'delay form '(_ _))
1182    `(##sys#make-promise (lambda () ,(cadr form))))))
1183
1184(##sys#extend-macro-environment
1185 'cond-expand
1186 '()
1187 (##sys#er-transformer
1188  (lambda (form r c)
1189    (let ((clauses (cdr form))
1190          (%or (r 'or))
1191          (%not (r 'not))
1192          (%else (r 'else))
1193          (%begin (r 'begin))
1194          (%and (r 'and)))
1195      (define (err x) 
1196        (##sys#error "syntax error in `cond-expand' form"
1197                     x
1198                     (cons 'cond-expand clauses)) )
1199      (define (test fx)
1200        (cond ((symbol? fx) (##sys#feature? fx))
1201              ((not (pair? fx)) (err fx))
1202              (else
1203               (let ((head (car fx))
1204                     (rest (cdr fx)))
1205                 (cond ((c %and head)
1206                        (or (eq? rest '())
1207                            (if (pair? rest)
1208                                (and (test (car rest))
1209                                     (test `(,%and ,@(cdr rest))) )
1210                                (err fx) ) ) )
1211                       ((c %or head)
1212                        (and (not (eq? rest '()))
1213                             (if (pair? rest)
1214                                 (or (test (car rest))
1215                                     (test `(,%or ,@(cdr rest))) )
1216                                 (err fx) ) ) )
1217                       ((c %not head) (not (test (cadr fx))))
1218                       (else (err fx)) ) ) ) ) )
1219      (let expand ((cls clauses))
1220        (cond ((eq? cls '())
1221               (##sys#apply
1222                ##sys#error "no matching clause in `cond-expand' form" 
1223                (map (lambda (x) (car x)) clauses) ) )
1224              ((not (pair? cls)) (err cls))
1225              (else
1226               (let ((clause (car cls))
1227                    (rclauses (cdr cls)) )
1228                 (if (not (pair? clause)) 
1229                     (err clause)
1230                     (let ((id (car clause)))
1231                       (cond ((c id %else)
1232                              (let ((rest (cdr clause)))
1233                                (if (eq? rest '())
1234                                    '(##core#undefined)
1235                                    `(,%begin ,@rest) ) ) )
1236                             ((test id) `(,%begin ,@(cdr clause)))
1237                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
1238
1239(##sys#extend-macro-environment
1240 'require-library
1241 '()
1242 (##sys#er-transformer
1243  (lambda (x r c)
1244    (let ((ids (cdr x)))
1245      `(##core#require-extension ,ids #f) ) ) ) )
1246
1247(##sys#extend-macro-environment
1248 'require-extension
1249 '()
1250 (##sys#er-transformer
1251  (lambda (x r c)
1252    (let ((ids (cdr x)))
1253      `(##core#require-extension ,ids #t) ) ) ) )
1254
1255(##sys#extend-macro-environment
1256 'module
1257 '()
1258 (##sys#er-transformer
1259  (lambda (x r c)
1260    (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
1261    `(##core#module 
1262      ,(cadr x)
1263      ,(if (c (r '*) (caddr x)) 
1264           #t 
1265           (caddr x))
1266      ,@(cdddr x)))))
1267
1268(##sys#extend-macro-environment
1269 'begin-for-syntax
1270 '()
1271 (##sys#er-transformer
1272  (lambda (x r c)
1273    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
1274    (##sys#register-meta-expression `(begin ,@(cdr x)))
1275    `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
1276
1277(##sys#extend-macro-environment
1278 'export
1279 '()
1280 (##sys#er-transformer
1281  (lambda (x r c)
1282    (let ((exps (cdr x))
1283          (mod (##sys#current-module)))
1284      (unless mod
1285        (syntax-error 'export "`export' used outside module body"))
1286      (for-each
1287       (lambda (exp)
1288         (when (and (not (symbol? exp)) 
1289                    (let loop ((iexp exp))
1290                      (cond ((null? iexp) #f)
1291                            ((not (pair? iexp)) #t)
1292                            ((not (symbol? (car iexp))) #t)
1293                            (else (loop (cdr iexp))))))
1294           (syntax-error 'export "invalid export syntax" exp (module-name mod))))
1295       exps)
1296      (set-module-export-list! 
1297       mod
1298       (append (module-export-list mod) 
1299               (map ##sys#strip-syntax exps)))
1300      '(##sys#void)))))
1301
1302
1303;;; syntax-rules
1304
1305(include "synrules.scm")
1306
1307
1308;;; the base macro environment ("scheme", essentially)
1309
1310(define ##sys#default-macro-environment (##sys#macro-environment))
1311
1312
1313;;; low-level module support
1314
1315(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
1316(define ##sys#current-module (make-parameter #f))
1317
1318(declare 
1319  (hide make-module module? %make-module
1320        module-name module-vexports module-sexports
1321        set-module-vexports! set-module-sexports!
1322        module-export-list set-module-export-list! 
1323        module-defined-list set-module-defined-list!
1324        module-import-forms set-module-import-forms!
1325        module-meta-import-forms set-module-meta-import-forms!
1326        module-exist-list set-module-exist-list!
1327        module-meta-expressions set-module-meta-expressions!
1328        module-defined-syntax-list set-module-defined-syntax-list!))
1329
1330(define-record-type module
1331  (%make-module name export-list defined-list exist-list defined-syntax-list
1332                undefined-list import-forms meta-import-forms meta-expressions 
1333                vexports sexports) 
1334  module?
1335  (name module-name)                    ; SYMBOL
1336  (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
1337  (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...)    - *exported* value definitions
1338  (exist-list module-exist-list set-module-exist-list!)       ; (SYMBOL ...)    - only for checking refs to undef'd
1339  (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
1340  (undefined-list module-undefined-list set-module-undefined-list!) ; (SYMBOL ...)
1341  (import-forms module-import-forms set-module-import-forms!)       ; (SPEC ...)
1342  (meta-import-forms module-meta-import-forms set-module-meta-import-forms!)        ; (SPEC ...)
1343  (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
1344  (vexports module-vexports set-module-vexports!)             ; (SYMBOL . SYMBOL)
1345  (sexports module-sexports set-module-sexports!) )           ; ((SYMBOL SE TRANSFORMER) ...)
1346
1347(define ##sys#module-name module-name)
1348
1349(define (##sys#module-exports m)
1350  (values
1351   (module-export-list m)
1352   (module-vexports m)
1353   (module-sexports m)))
1354
1355(define (make-module name explist vexports sexports)
1356  (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
1357
1358(define (##sys#find-module name #!optional (err #t))
1359  (cond ((assq name ##sys#module-table) => cdr)
1360        (err (error 'import "module not found" name))
1361        (else #f)))
1362
1363(declare (not inline ##sys#toplevel-definition-hook))
1364
1365(define (##sys#toplevel-definition-hook sym mod exp val) #f)
1366
1367(define (##sys#register-meta-expression exp)
1368  (and-let* ((mod (##sys#current-module)))
1369    (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
1370
1371(define (check-for-redef sym env senv)
1372  (and-let* ((a (assq sym env)))
1373    (##sys#warn "redefinition of imported value binding" sym) )
1374  (and-let* ((a (assq sym senv)))
1375    (##sys#warn "redefinition of imported syntax binding" sym)))
1376
1377(define (##sys#register-export sym mod)
1378  (when mod
1379    (let ((exp (or (eq? #t (module-export-list mod))
1380                   (##sys#find-export sym mod #t)))
1381          (ulist (module-undefined-list mod)))
1382      (##sys#toplevel-definition-hook   ; in compiler, hides unexported bindings
1383       (##sys#module-rename sym (module-name mod)) 
1384       mod exp #f)
1385      (when (memq sym ulist)
1386        (set-module-undefined-list! mod (##sys#delq sym ulist)))
1387      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1388      (set-module-exist-list! mod (cons sym (module-exist-list mod)))
1389      (when exp
1390        (dm "defined: " sym)
1391        (set-module-defined-list! 
1392         mod
1393         (cons (cons sym #f)
1394               (module-defined-list mod)))))) )
1395
1396(define (##sys#register-syntax-export sym mod val)
1397  (when mod
1398    (let ((exp (or (eq? #t (module-export-list mod))
1399                   (##sys#find-export sym mod #t)))
1400          (ulist (module-undefined-list mod))
1401          (mname (module-name mod)))
1402      (when (memq sym ulist)
1403        (##sys#warn "use of syntax precedes definition" sym))
1404      (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
1405      (dm "defined syntax: " sym)
1406      (when exp
1407        (set-module-defined-list! 
1408         mod
1409         (cons (cons sym val)
1410               (module-defined-list mod))) )
1411      (set-module-defined-syntax-list! 
1412       mod
1413       (cons (cons sym val) (module-defined-syntax-list mod))))))
1414
1415(define (##sys#register-undefined sym mod)
1416  (when mod
1417    (let ((ul (module-undefined-list mod)))
1418      (unless (memq sym ul)
1419        (set-module-undefined-list! mod (cons sym ul))))))
1420
1421(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
1422  (let ((mod (make-module name explist vexports sexports)))
1423    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
1424    mod) )
1425
1426(define (##sys#mark-imported-symbols se)
1427  (for-each
1428   (lambda (imp)
1429     (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
1430       (dm `(MARKING: ,(cdr imp)))
1431       (##sys#put! (cdr imp) '##core#aliased #t)))
1432   se))
1433
1434(define (module-indirect-exports mod)
1435  (let ((exports (module-export-list mod))
1436        (mname (module-name mod))
1437        (dlist (module-defined-list mod)))
1438    (define (indirect? id)
1439      (let loop ((exports exports))
1440        (and (not (null? exports))
1441             (or (and (pair? (car exports))
1442                      (memq id (cdar exports)))
1443                 (loop (cdr exports))))))
1444    (define (warn msg id)
1445      (##sys#warn
1446       (string-append msg " in module `" (symbol->string mname) "'")
1447       id))
1448    (if (eq? #t exports)
1449        '()
1450        (let loop ((exports exports))   ; walk export list
1451          (cond ((null? exports) '())
1452                ((symbol? (car exports)) (loop (cdr exports))) ; normal export
1453                (else
1454                 (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
1455                   (cond ((null? iexports) (loop (cdr exports)))
1456                         ((assq (car iexports) (##sys#macro-environment))
1457                          (warn "indirect export of syntax binding" (car iexports))
1458                          (loop2 (cdr iexports)))
1459                         ((assq (car iexports) dlist) => ; defined in current module?
1460                          (lambda (a) 
1461                            (cons
1462                             (cons
1463                              (car iexports)
1464                              (or (cdr a) (##sys#module-rename (car iexports) mname)))
1465                             (loop2 (cdr iexports)))))
1466                         ((assq (car iexports) (##sys#current-environment)) =>
1467                          (lambda (a)   ; imported in current env.
1468                            (cond ((symbol? (cdr a)) ; not syntax
1469                                   (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
1470                                  (else
1471                                   (warn "indirect reexport of syntax" (car iexports))
1472                                   (loop2 (cdr iexports))))))
1473                         (else
1474                          (warn "indirect export of unknown binding" (car iexports))
1475                          (loop2 (cdr iexports)))))))))))
1476
1477(define (merge-se . ses)                ; later occurrences take precedence to earlier ones
1478  (let ((se (apply append ses)))
1479    (dm "merging " (length ses) " se's with total length of " (length se))
1480    (let ((se2
1481           (let loop ((se se))
1482             (cond ((null? se) '())
1483                   ((assq (caar se) (cdr se)) (loop (cdr se)))
1484                   (else (cons (car se) (loop (cdr se))))))))
1485      (dm "  merged has length " (length se2))
1486      se2)))
1487
1488(define (##sys#compiled-module-registration mod)
1489  (let ((dlist (module-defined-list mod))
1490        (mname (module-name mod))
1491        (ifs (module-import-forms mod))
1492        (sexports (module-sexports mod))
1493        (mifs (module-meta-import-forms mod)))
1494    `(,@(if (pair? ifs) `((eval '(import ,@ifs))) '())
1495      ,@(if (pair? mifs) `((import ,@mifs)) '())
1496      ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
1497      (##sys#register-compiled-module
1498       ',(module-name mod)
1499       (list
1500        ,@(map (lambda (ie)
1501                 (if (symbol? (cdr ie))
1502                     `'(,(car ie) . ,(cdr ie))
1503                     `(list ',(car ie) '() ,(cdr ie))))
1504               (module-indirect-exports mod)))
1505       ',(module-vexports mod)
1506       (list
1507        ,@(map (lambda (sexport)
1508                 (let* ((name (car sexport))
1509                        (a (assq name dlist)))
1510                   (cond ((pair? a) 
1511                          `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
1512                         (else
1513                          (dm "re-exported syntax" name mname)
1514                          `',name))))
1515               sexports))
1516       (list
1517        ,@(if (null? sexports)
1518              '()                       ; no syntax exported - no more info needed
1519              (let loop ((sd (module-defined-syntax-list mod)))
1520                (cond ((null? sd) '())
1521                      ((assq (caar sd) sexports) (loop (cdr sd)))
1522                      (else
1523                       (let ((name (caar sd)))
1524                         (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
1525                               (loop (cdr sd)))))))))))))
1526
1527(define (##sys#register-compiled-module name iexports vexports sexports #!optional
1528                                        (sdefs '()))
1529  (define (find-reexport name)
1530    (let ((a (assq name (##sys#macro-environment))))
1531      (if (pair? (cdr a))
1532          a
1533          (##sys#error
1534           'import "cannot find implementation of re-exported syntax"
1535           name))))
1536  (let* ((sexps
1537          (map (lambda (se)
1538                 (if (symbol? se)
1539                     (find-reexport se)
1540                     (list (car se) #f (##sys#er-transformer (cdr se)))))
1541               sexports))
1542         (iexps 
1543          (map (lambda (ie)
1544                 (if (pair? (cdr ie))
1545                     (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
1546                     ie))
1547               iexports))
1548         (nexps
1549          (map (lambda (ne)
1550                 (list (car ne) #f (##sys#er-transformer (cdr ne))))
1551               sdefs))
1552         (mod (make-module name '() vexports sexps))
1553         (senv (merge-se 
1554                (##sys#macro-environment)
1555                (##sys#current-environment)
1556                iexps vexports sexps nexps)))
1557    (##sys#mark-imported-symbols iexps)
1558    (for-each
1559     (lambda (sexp)
1560       (set-car! (cdr sexp) senv))
1561     sexps)
1562    (for-each
1563     (lambda (iexp)
1564       (when (pair? (cdr iexp))
1565         (set-car! (cdr iexp) senv)))
1566     iexps)
1567    (for-each
1568     (lambda (nexp)
1569       (set-car! (cdr nexp) senv))
1570     nexps)
1571    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1572    mod))
1573
1574(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
1575  (let* ((me (##sys#macro-environment))
1576         (mod (make-module 
1577               name '()
1578               (map (lambda (ve)
1579                      (if (symbol? ve)
1580                          (let ((palias 
1581                                 (##sys#string->symbol 
1582                                  (##sys#string-append "#%" (##sys#slot ve 1)))))
1583                            (##sys#put! palias '##core#primitive ve)
1584                            (cons ve palias))
1585                          ve))
1586                    vexports)
1587               (map (lambda (se)
1588                      (if (symbol? se)
1589                          (or (assq se me)
1590                              (##sys#error "unknown macro referenced while registering module" se name))
1591                          se))
1592                    sexports))))
1593    (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 
1594    mod))
1595
1596(define (##sys#find-export sym mod indirect)
1597  (let ((exports (module-export-list mod)))
1598    (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
1599      (cond ((null? xl) #f)
1600            ((eq? sym (car xl)))
1601            ((pair? (car xl))
1602             (or (eq? sym (caar xl))
1603                 (and indirect (memq sym (cdar xl)))
1604                 (loop (cdr xl))))
1605            (else (loop (cdr xl)))))))
1606
1607(define (##sys#finalize-module mod)
1608  (let* ((explist (module-export-list mod))
1609         (name (module-name mod))
1610         (dlist (module-defined-list mod))
1611         (elist (module-exist-list mod))
1612         (missing #f)
1613         (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
1614                      (module-defined-syntax-list mod)))
1615         (sexports
1616          (if (eq? #t explist)
1617              sdlist
1618              (let loop ((me (##sys#macro-environment)))
1619                (cond ((null? me) '())
1620                      ((##sys#find-export (caar me) mod #f)
1621                       (cons (car me) (loop (cdr me))))
1622                      (else (loop (cdr me)))))))
1623         (vexports
1624          (let loop ((xl (if (eq? #t explist) elist explist)))
1625            (if (null? xl)
1626                '()
1627                (let* ((h (car xl))
1628                       (id (if (symbol? h) h (car h))))
1629                  (if (assq id sexports) 
1630                      (loop (cdr xl))
1631                      (cons
1632                       (cons
1633                        id
1634                        (let ((def (assq id dlist)))
1635                          (if (and def (symbol? (cdr def))) 
1636                              (cdr def)
1637                              (let ((a (assq id (##sys#current-environment))))
1638                                (cond ((and a (symbol? (cdr a))) 
1639                                       (dm "reexporting: " id " -> " (cdr a))
1640                                       (cdr a)) 
1641                                      ((not def)
1642                                       (set! missing #t)
1643                                       (##sys#warn 
1644                                        (string-append
1645                                         "exported identifier for module `" 
1646                                         (symbol->string name)
1647                                         "' has not been defined")
1648                                        id)
1649                                       #f)
1650                                      (else (##sys#module-rename id name)))))))
1651                       (loop (cdr xl)))))))))
1652    (for-each
1653     (lambda (u)
1654       (unless (memq u elist)
1655         (set! missing #t)
1656         (##sys#warn "reference to possibly unbound identifier" u)
1657         (and-let* ((a (##sys#get u '##core#db)))
1658           (if (= 1 (length a))
1659               (##sys#warn
1660                (string-append
1661                 "  suggesting: `(import " (symbol->string (cadar a)) 
1662                 ")'"))
1663               (##sys#warn
1664                (string-append
1665                 "  suggesting one of:\n"
1666                 (let loop ((lst a))
1667                   (if (null? lst)
1668                       ""
1669                       (string-append
1670                        "Warning:     `(import " (symbol->string (cadar lst)) ")'\n"
1671                        (loop (cdr lst)))))))))))
1672     (module-undefined-list mod))
1673    (when missing
1674      (##sys#error "module unresolved" name))
1675    (let* ((exports 
1676            (map (lambda (exp)
1677                   (cond ((symbol? (cdr exp)) exp)
1678                         ((assq (car exp) (##sys#macro-environment)))
1679                         (else (##sys#error "(internal) indirect export not found" (car exp)))) )
1680                 (module-indirect-exports mod)))
1681           (new-se (merge-se 
1682                    (##sys#macro-environment) 
1683                    (##sys#current-environment) 
1684                    exports)))
1685      (##sys#mark-imported-symbols exports)
1686      (for-each
1687       (lambda (m)
1688         (let ((se (merge-se (cadr m) new-se)))
1689           (dm `(FIXUP: ,(car m) ,@(map-se se)))
1690           (set-car! (cdr m) se)))
1691       sdlist)
1692      (dm `(EXPORTS: 
1693            ,(module-name mod) 
1694            (DLIST: ,@dlist)
1695            (SDLIST: ,@(map-se sdlist))
1696            (IEXPORTS: ,@(map-se exports))
1697            (VEXPORTS: ,@(map-se vexports))
1698            (SEXPORTS: ,@(map-se sexports))))
1699      (set-module-vexports! mod vexports)
1700      (set-module-sexports! mod sexports))))
1701
1702(define ##sys#module-table '())
1703
1704(define (##sys#macro-subset me0)
1705  (let loop ((me (##sys#macro-environment)))
1706    (if (or (null? me) (eq? me me0))
1707        '()
1708        (cons (car me) (loop (cdr me))))))
Note: See TracBrowser for help on using the repository browser.