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

Last change on this file since 13713 was 13713, checked in by Kon Lovett, 11 years ago

Removed my stupid -chicken-syntax option.

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