| blob | c400439385b60463943bda6623cde81ccfc51035 |
1 ;;; Portable implementation of syntax-case
2 ;;; Extracted from Chez Scheme Version 7.3 (Feb 26, 2007)
3 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
5 ;;; ***************************************************************************
6 ;;; *** Modified for Gambit 4.4.0 by Marc Feeley (February 4, 2009). ***
7 ;;; *** Look for "***" to see what was modified. ***
8 ;;; ***************************************************************************
10 ;;; Copyright (c) 1992-2002 Cadence Research Systems
11 ;;; Permission to copy this software, in whole or in part, to use this
12 ;;; software for any lawful purpose, and to redistribute this software
13 ;;; is granted subject to the restriction that all copies made of this
14 ;;; software must include this copyright notice in full. This software
15 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
16 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
17 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
18 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
19 ;;; NATURE WHATSOEVER.
21 ;;; Before attempting to port this code to a new implementation of
22 ;;; Scheme, please read the notes below carefully.
24 ;;; This file defines the syntax-case expander, sc-expand, and a set
25 ;;; of associated syntactic forms and procedures. Of these, the
26 ;;; following are documented in The Scheme Programming Language,
27 ;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
28 ;;; found online at http://www.scheme.com/tspl3/. Most are also documented
29 ;;; in the R4RS and draft R5RS.
30 ;;;
31 ;;; bound-identifier=?
32 ;;; datum->syntax-object
33 ;;; define-syntax
34 ;;; fluid-let-syntax
35 ;;; free-identifier=?
36 ;;; generate-temporaries
37 ;;; identifier?
38 ;;; identifier-syntax
39 ;;; let-syntax
40 ;;; letrec-syntax
41 ;;; syntax
42 ;;; syntax-case
43 ;;; syntax-object->datum
44 ;;; syntax-rules
45 ;;; with-syntax
46 ;;;
47 ;;; All standard Scheme syntactic forms are supported by the expander
48 ;;; or syntactic abstractions defined in this file. Only the R4RS
49 ;;; delay is omitted, since its expansion is implementation-dependent.
51 ;;; Also defined are three forms that support modules: module, import,
52 ;;; and import-only. These are documented in the Chez Scheme User's
53 ;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
54 ;;; also be found online at http://www.scheme.com/csug/. They are
55 ;;; described briefly here as well.
57 ;;; All are definitions and may appear where and only where other
58 ;;; definitions may appear. modules may be named:
59 ;;;
60 ;;; (module id (ex ...) defn ... init ...)
61 ;;;
62 ;;; or anonymous:
63 ;;;
64 ;;; (module (ex ...) defn ... init ...)
65 ;;;
66 ;;; The latter form is semantically equivalent to:
67 ;;;
68 ;;; (module T (ex ...) defn ... init ...)
69 ;;; (import T)
70 ;;;
71 ;;; where T is a fresh identifier.
72 ;;;
73 ;;; In either form, each of the exports in (ex ...) is either an
74 ;;; identifier or of the form (id ex ...). In the former case, the
75 ;;; single identifier ex is exported. In the latter, the identifier
76 ;;; id is exported and the exports ex ... are "implicitly" exported.
77 ;;; This listing of implicit exports is useful only when id is a
78 ;;; keyword bound to a transformer that expands into references to
79 ;;; the listed implicit exports. In the present implementation,
80 ;;; listing of implicit exports is necessary only for top-level
81 ;;; modules and allows the implementation to avoid placing all
82 ;;; identifiers into the top-level environment where subsequent passes
83 ;;; of the compiler will be unable to deal effectively with them.
84 ;;;
85 ;;; Named modules may be referenced in import statements, which
86 ;;; always take one of the forms:
87 ;;;
88 ;;; (import id)
89 ;;; (import-only id)
90 ;;;
91 ;;; id must name a module. Each exported identifier becomes visible
92 ;;; within the scope of the import form. In the case of import-only,
93 ;;; all other identifiers become invisible in the scope of the
94 ;;; import-only form, except for those established by definitions
95 ;;; that appear textually after the import-only form.
97 ;;; import and import-only also support a variety of identifier
98 ;;; selection and renaming forms: only, except, add-prefix,
99 ;;; drop-prefix, rename, and alias.
100 ;;;
101 ;;; (import (only m x y))
102 ;;;
103 ;;; imports x and y (and nothing else) from m.
104 ;;;
105 ;;; (import (except m x y))
106 ;;;
107 ;;; imports all of m's imports except for x and y.
108 ;;;
109 ;;; (import (add-prefix (only m x y) m:))
110 ;;;
111 ;;; imports x and y as m:x and m:y.
112 ;;;
113 ;;; (import (drop-prefix m foo:))
114 ;;;
115 ;;; imports all of m's imports, dropping the common foo: prefix
116 ;;; (which must appear on all of m's exports).
117 ;;;
118 ;;; (import (rename (except m a b) (m-c c) (m-d d)))
119 ;;;
120 ;;; imports all of m's imports except for x and y, renaming c
121 ;;; m-c and d m-d.
122 ;;;
123 ;;; (import (alias (except m a b) (m-c c) (m-d d)))
124 ;;;
125 ;;; imports all of m's imports except for x and y, with additional
126 ;;; aliases m-c for c and m-d for d.
127 ;;;
128 ;;; multiple imports may be specified with one import form:
129 ;;;
130 ;;; (import (except m1 x) (only m2 x))
131 ;;;
132 ;;; imports all of m1's exports except for x plus x from m2.
134 ;;; Another form, meta, may be used as a prefix for any definition and
135 ;;; causes any resulting variable bindings to be created at expansion
136 ;;; time. Meta variables (variables defined using meta) are available
137 ;;; only at expansion time. Meta definitions are often used to create
138 ;;; data and helpers that can be shared by multiple macros, for example:
140 ;;; (module (alpha beta)
141 ;;; (meta define key-error
142 ;;; (lambda (key)
143 ;;; (syntax-error key "invalid key")))
144 ;;; (meta define parse-keys
145 ;;; (lambda (keys)
146 ;;; (let f ((keys keys) (c #'white) (s 10))
147 ;;; (syntax-case keys (color size)
148 ;;; (() (list c s))
149 ;;; (((color c) . keys) (f #'keys #'c s))
150 ;;; (((size s) . keys) (f #'keys c #'s))
151 ;;; ((k . keys) (key-error #'k))))))
152 ;;; (define-syntax alpha
153 ;;; (lambda (x)
154 ;;; (syntax-case x ()
155 ;;; ((_ (k ...) <other stuff>)
156 ;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
157 ;;; ---)))))
158 ;;; (define-syntax beta
159 ;;; (lambda (x)
160 ;;; (syntax-case x ()
161 ;;; ((_ (k ...) <other stuff>)
162 ;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
163 ;;; ---))))))
165 ;;; As with define-syntax rhs expressions, meta expressions can evaluate
166 ;;; references only to identifiers whose values are (already) available
167 ;;; in the compile-time environment, e.g., macros and meta variables.
168 ;;; They can, however, like define-syntax rhs expressions, build syntax
169 ;;; objects containing occurrences of any identifiers in their scope.
171 ;;; meta definitions propagate through macro expansion, so one can write,
172 ;;; for example:
173 ;;;
174 ;;; (module (a)
175 ;;; (meta define-structure (foo x))
176 ;;; (define-syntax a
177 ;;; (let ((q (make-foo (syntax 'q))))
178 ;;; (lambda (x)
179 ;;; (foo-x q)))))
180 ;;; a -> q
181 ;;;
182 ;;; where define-record is a macro that expands into a set of defines.
183 ;;;
184 ;;; It is also sometimes convenient to write
185 ;;;
186 ;;; (meta begin defn ...)
187 ;;;
188 ;;; or
189 ;;;
190 ;;; (meta module {exports} defn ...)
191 ;;;
192 ;;; to create groups of meta bindings.
194 ;;; Another form, alias, is used to create aliases from one identifier
195 ;;; to another. This is used primarily to support the extended import
196 ;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
198 ;;; (let ((x 3)) (alias y x) y) -> 3
200 ;;; The remaining exports are listed below. sc-expand, eval-when, and
201 ;;; syntax-error are described in the Chez Scheme User's Guide.
202 ;;;
203 ;;; (sc-expand datum)
204 ;;; if datum represents a valid expression, sc-expand returns an
205 ;;; expanded version of datum in a core language that includes no
206 ;;; syntactic abstractions. The core language includes begin,
207 ;;; define, if, lambda, letrec, quote, and set!.
208 ;;; (eval-when situations expr ...)
209 ;;; conditionally evaluates expr ... at compile-time or run-time
210 ;;; depending upon situations
211 ;;; (syntax-error object message)
212 ;;; used to report errors found during expansion
213 ;;; ($syntax-dispatch e p)
214 ;;; used by expanded code to handle syntax-case matching
215 ;;; ($sc-put-cte symbol val top-token)
216 ;;; used to establish top-level compile-time (expand-time) bindings.
218 ;;; The following nonstandard procedures must be provided by the
219 ;;; implementation for this code to run.
220 ;;;
221 ;;; (void)
222 ;;; returns the implementation's cannonical "unspecified value". The
223 ;;; following usually works:
224 ;;;
225 ;;; (define void (lambda () (if #f #f))).
226 ;;;
227 ;;; (andmap proc list1 list2 ...)
228 ;;; returns true if proc returns true when applied to each element of list1
229 ;;; along with the corresponding elements of list2 .... The following
230 ;;; definition works but does no error checking:
231 ;;;
232 ;;; (define andmap
233 ;;; (lambda (f first . rest)
234 ;;; (or (null? first)
235 ;;; (if (null? rest)
236 ;;; (let andmap ((first first))
237 ;;; (let ((x (car first)) (first (cdr first)))
238 ;;; (if (null? first)
239 ;;; (f x)
240 ;;; (and (f x) (andmap first)))))
241 ;;; (let andmap ((first first) (rest rest))
242 ;;; (let ((x (car first))
243 ;;; (xr (map car rest))
244 ;;; (first (cdr first))
245 ;;; (rest (map cdr rest)))
246 ;;; (if (null? first)
247 ;;; (apply f (cons x xr))
248 ;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
249 ;;;
250 ;;; (ormap proc list1)
251 ;;; returns the first non-false return result of proc applied to
252 ;;; the elements of list1 or false if none. The following definition
253 ;;; works but does no error checking:
254 ;;;
255 ;;; (define ormap
256 ;;; (lambda (proc list1)
257 ;;; (and (not (null? list1))
258 ;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
259 ;;;
260 ;;; The following nonstandard procedures must also be provided by the
261 ;;; implementation for this code to run using the standard portable
262 ;;; hooks and output constructors. They are not used by expanded code,
263 ;;; and so need be present only at expansion time.
264 ;;;
265 ;;; (eval x)
266 ;;; where x is always in the form ("noexpand" expr).
267 ;;; returns the value of expr. the "noexpand" flag is used to tell the
268 ;;; evaluator/expander that no expansion is necessary, since expr has
269 ;;; already been fully expanded to core forms.
270 ;;;
271 ;;; eval will not be invoked during the loading of psyntax.pp. After
272 ;;; psyntax.pp has been loaded, the expansion of any macro definition,
273 ;;; whether local or global, results in a call to eval. If, however,
274 ;;; sc-expand has already been registered as the expander to be used
275 ;;; by eval, and eval accepts one argument, nothing special must be done
276 ;;; to support the "noexpand" flag, since it is handled by sc-expand.
277 ;;;
278 ;;; (error who format-string why what)
279 ;;; where who is either a symbol or #f, format-string is always "~a ~s",
280 ;;; why is always a string, and what may be any object. error should
281 ;;; signal an error with a message something like
282 ;;;
283 ;;; "error in <who>: <why> <what>"
284 ;;;
285 ;;; (gensym)
286 ;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
287 ;;; returns a symbol with a "globally" unique name so that gensyms that
288 ;;; end up in the object code of separately compiled files cannot conflict.
289 ;;; This is necessary only if you intend to support compiled files.
290 ;;;
291 ;;; (gensym? x)
292 ;;; returns #t if x is a gensym, otherwise false.
293 ;;;
294 ;;; (putprop symbol key value)
295 ;;; (getprop symbol key)
296 ;;; (remprop symbol key)
297 ;;; key is always a symbol; value may be any object. putprop should
298 ;;; associate the given value with the given symbol and key in some way
299 ;;; that it can be retrieved later with getprop. getprop should return
300 ;;; #f if no value is associated with the given symbol and key. remprop
301 ;;; should remove the association between the given symbol and key.
303 ;;; When porting to a new Scheme implementation, you should define the
304 ;;; procedures listed above, load the expanded version of psyntax.ss
305 ;;; (psyntax.pp, which should be available whereever you found
306 ;;; psyntax.ss), and register sc-expand as the current expander (how
307 ;;; you do this depends upon your implementation of Scheme). You may
308 ;;; change the hooks and constructors defined toward the beginning of
309 ;;; the code below, but to avoid bootstrapping problems, do so only
310 ;;; after you have a working version of the expander.
312 ;;; Chez Scheme allows the syntactic form (syntax <template>) to be
313 ;;; abbreviated to #'<template>, just as (quote <datum>) may be
314 ;;; abbreviated to '<datum>. The #' syntax makes programs written
315 ;;; using syntax-case shorter and more readable and draws out the
316 ;;; intuitive connection between syntax and quote. If you have access
317 ;;; to the source code of your Scheme system's reader, you might want
318 ;;; to implement this extension.
320 ;;; If you find that this code loads or runs slowly, consider
321 ;;; switching to faster hardware or a faster implementation of
322 ;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
323 ;;; compiling (with full optimization), and loading this file takes
324 ;;; between one and two seconds.
326 ;;; In the expander implementation, we sometimes use syntactic abstractions
327 ;;; when procedural abstractions would suffice. For example, we define
328 ;;; top-wrap and top-marked? as
329 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
330 ;;; (define-syntax top-marked?
331 ;;; (syntax-rules ()
332 ;;; ((_ w) (memq 'top (wrap-marks w)))))
333 ;;; rather than
334 ;;; (define top-wrap '((top)))
335 ;;; (define top-marked?
336 ;;; (lambda (w) (memq 'top (wrap-marks w))))
337 ;;; On ther other hand, we don't do this consistently; we define make-wrap,
338 ;;; wrap-marks, and wrap-subst simply as
339 ;;; (define make-wrap cons)
340 ;;; (define wrap-marks car)
341 ;;; (define wrap-subst cdr)
342 ;;; In Chez Scheme, the syntactic and procedural forms of these
343 ;;; abstractions are equivalent, since the optimizer consistently
344 ;;; integrates constants and small procedures. Some Scheme
345 ;;; implementations, however, may benefit from more consistent use
346 ;;; of one form or the other.
349 ;;; Implementation notes:
351 ;;; "begin" is treated as a splicing construct at top level and at
352 ;;; the beginning of bodies. Any sequence of expressions that would
353 ;;; be allowed where the "begin" occurs is allowed.
355 ;;; "let-syntax" and "letrec-syntax" are also treated as splicing
356 ;;; constructs, in violation of the R5RS. A consequence is that let-syntax
357 ;;; and letrec-syntax do not create local contours, as do let and letrec.
358 ;;; Although the functionality is greater as it is presently implemented,
359 ;;; we will probably change it to conform to the R5RS. modules provide
360 ;;; similar functionality to nonsplicing letrec-syntax when the latter is
361 ;;; used as a definition.
363 ;;; Objects with no standard print syntax, including objects containing
364 ;;; cycles and syntax objects, are allowed in quoted data as long as they
365 ;;; are contained within a syntax form or produced by datum->syntax-object.
366 ;;; Such objects are never copied.
368 ;;; When the expander encounters a reference to an identifier that has
369 ;;; no global or lexical binding, it treats it as a global-variable
370 ;;; reference. This allows one to write mutually recursive top-level
371 ;;; definitions, e.g.:
372 ;;;
373 ;;; (define f (lambda (x) (g x)))
374 ;;; (define g (lambda (x) (f x)))
375 ;;;
376 ;;; but may not always yield the intended when the variable in question
377 ;;; is later defined as a keyword.
379 ;;; Top-level variable definitions of syntax keywords are permitted.
380 ;;; In order to make this work, top-level define not only produces a
381 ;;; top-level definition in the core language, but also modifies the
382 ;;; compile-time environment (using $sc-put-cte) to record the fact
383 ;;; that the identifier is a variable.
385 ;;; Top-level definitions of macro-introduced identifiers are visible
386 ;;; only in code produced by the macro. That is, a binding for a
387 ;;; hidden (generated) identifier is created instead, and subsequent
388 ;;; references within the macro output are renamed accordingly. For
389 ;;; example:
390 ;;;
391 ;;; (define-syntax a
392 ;;; (syntax-rules ()
393 ;;; ((_ var exp)
394 ;;; (begin
395 ;;; (define secret exp)
396 ;;; (define var
397 ;;; (lambda ()
398 ;;; (set! secret (+ secret 17))
399 ;;; secret))))))
400 ;;; (a x 0)
401 ;;; (x) => 17
402 ;;; (x) => 34
403 ;;; secret => Error: variable secret is not bound
404 ;;;
405 ;;; The definition above would fail if the definition for secret
406 ;;; were placed after the definition for var, since the expander would
407 ;;; encounter the references to secret before the definition that
408 ;;; establishes the compile-time map from the identifier secret to
409 ;;; the generated identifier.
411 ;;; Identifiers and syntax objects are implemented as vectors for
412 ;;; portability. As a result, it is possible to "forge" syntax
413 ;;; objects.
415 ;;; The input to sc-expand may contain "annotations" describing, e.g., the
416 ;;; source file and character position from where each object was read if
417 ;;; it was read from a file. These annotations are handled properly by
418 ;;; sc-expand only if the annotation? hook (see hooks below) is implemented
419 ;;; properly and the operators annotation-expression and annotation-stripped
420 ;;; are supplied. If annotations are supplied, the proper annotated
421 ;;; expression is passed to the various output constructors, allowing
422 ;;; implementations to accurately correlate source and expanded code.
423 ;;; Contact one of the authors for details if you wish to make use of
424 ;;; this feature.
426 ;;; Implementation of modules:
427 ;;;
428 ;;; The implementation of modules requires that implicit top-level exports
429 ;;; be listed with the exported macro at some level where both are visible,
430 ;;; e.g.,
431 ;;;
432 ;;; (module M (alpha (beta b))
433 ;;; (module ((alpha a) b)
434 ;;; (define-syntax alpha (identifier-syntax a))
435 ;;; (define a 'a)
436 ;;; (define b 'b))
437 ;;; (define-syntax beta (identifier-syntax b)))
438 ;;;
439 ;;; Listing of implicit imports is not needed for macros that do not make
440 ;;; it out to top level, including all macros that are local to a "body".
441 ;;; (They may be listed in this case, however.) We need this information
442 ;;; for top-level modules since a top-level module expands into a letrec
443 ;;; for non-top-level variables and top-level definitions (assignments) for
444 ;;; top-level variables. Because of the general nature of macro
445 ;;; transformers, we cannot determine the set of implicit exports from the
446 ;;; transformer code, so without the user's help, we'd have to put all
447 ;;; variables at top level.
448 ;;;
449 ;;; Each such top-level identifier is given a generated name (gensym).
450 ;;; When a top-level module is imported at top level, a compile-time
451 ;;; alias is established from the top-level name to the generated name.
452 ;;; The expander follows these aliases transparently. When any module is
453 ;;; imported anywhere other than at top level, the id-var-name of the
454 ;;; import identifier is set to the id-var-name of the export identifier.
455 ;;; Since we can't determine the actual labels for identifiers defined in
456 ;;; top-level modules until we determine which are placed in the letrec
457 ;;; and which make it to top level, we give each an "indirect" label---a
458 ;;; pair whose car will eventually contain the actual label. Import does
459 ;;; not follow the indirect, but id-var-name does.
460 ;;;
461 ;;; All identifiers defined within a local module are folded into the
462 ;;; letrec created for the enclosing body. Visibility is controlled in
463 ;;; this case and for nested top-level modules by introducing a new wrap
464 ;;; for each module.
467 ;;; Bootstrapping:
469 ;;; When changing syntax-object representations, it is necessary to support
470 ;;; both old and new syntax-object representations in id-var-name. It
471 ;;; should be sufficient to redefine syntax-object-expression to work for
472 ;;; both old and new representations and syntax-object-wrap to return the
473 ;;; empty-wrap for old representations.
476 ;;; The following set of definitions establishes bindings for the
477 ;;; top-level variables assigned values in the let expression below.
478 ;;; Uncomment them here and copy them to the front of psyntax.pp if
479 ;;; required by your system.
481 ; (define $sc-put-cte #f)
482 ; (define sc-expand #f)
483 ; (define $make-environment #f)
484 ; (define environment? #f)
485 ; (define interaction-environment #f)
486 ; (define identifier? #f)
487 ; (define syntax->list #f)
488 ; (define syntax-object->datum #f)
489 ; (define datum->syntax-object #f)
490 ; (define generate-temporaries #f)
491 ; (define free-identifier=? #f)
492 ; (define bound-identifier=? #f)
493 ; (define literal-identifier=? #f)
494 ; (define syntax-error #f)
495 ; (define $syntax-dispatch #f)
497 (let ()
499 (define-syntax when
500 (syntax-rules ()
501 ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
502 (define-syntax unless
503 (syntax-rules ()
504 ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
505 (define-syntax define-structure
506 (lambda (x)
507 (define construct-name
508 (lambda (template-identifier . args)
509 (datum->syntax-object
510 template-identifier
511 (string->symbol
512 (apply string-append
513 (map (lambda (x)
514 (if (string? x)
515 x
516 (symbol->string (syntax-object->datum x))))
517 args))))))
518 (syntax-case x ()
519 ((_ (name id1 ...))
520 (andmap identifier? (syntax (name id1 ...)))
521 (with-syntax
522 ((constructor (construct-name (syntax name) "make-" (syntax name)))
523 (predicate (construct-name (syntax name) (syntax name) "?"))
524 ((access ...)
525 (map (lambda (x) (construct-name x (syntax name) "-" x))
526 (syntax (id1 ...))))
527 ((assign ...)
528 (map (lambda (x)
529 (construct-name x "set-" (syntax name) "-" x "!"))
530 (syntax (id1 ...))))
531 (structure-length
532 (+ (length (syntax (id1 ...))) 1))
533 ((index ...)
534 (let f ((i 1) (ids (syntax (id1 ...))))
535 (if (null? ids)
536 '()
537 (cons i (f (+ i 1) (cdr ids)))))))
538 (syntax (begin
539 (define constructor
540 (lambda (id1 ...)
541 (vector 'name id1 ... )))
542 (define predicate
543 (lambda (x)
544 (and (vector? x)
545 (= (vector-length x) structure-length)
546 (eq? (vector-ref x 0) 'name))))
547 (define access
548 (lambda (x)
549 (vector-ref x index)))
550 ...
551 (define assign
552 (lambda (x update)
553 (vector-set! x index update)))
554 ...)))))))
556 (define-syntax let-values ; impoverished one-clause version
557 (syntax-rules ()
558 ((_ ((formals expr)) form1 form2 ...)
559 (call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
561 (define noexpand "noexpand")
563 (define-structure (syntax-object expression wrap))
565 ;;; hooks to nonportable run-time helpers
566 (begin
567 ;*** Gambit supports fx+, etc.
568 ;*** (define-syntax fx+ (identifier-syntax +))
569 ;*** (define-syntax fx- (identifier-syntax -))
570 ;*** (define-syntax fx= (identifier-syntax =))
571 ;*** (define-syntax fx< (identifier-syntax <))
572 ;*** (define-syntax fx> (identifier-syntax >))
573 ;*** (define-syntax fx<= (identifier-syntax <=))
574 ;*** (define-syntax fx>= (identifier-syntax >=))
576 ;*** (define annotation? (lambda (x) #f))
578 ; top-level-eval-hook is used to create "permanent" code (e.g., top-level
579 ; transformers), so it might be a good idea to compile it
580 (define top-level-eval-hook
581 (lambda (x)
582 (eval `(,noexpand ,x))))
584 ; local-eval-hook is used to create "temporary" code (e.g., local
585 ; transformers), so it might be a good idea to interpret it
586 (define local-eval-hook
587 (lambda (x)
588 (eval `(,noexpand ,x))))
590 (define define-top-level-value-hook
591 (lambda (sym val)
592 (top-level-eval-hook
593 (build-global-definition no-source sym
594 (build-data no-source val)))))
596 ;*** (define error-hook
597 ;*** (lambda (who why what)
598 ;*** (error who "~a ~s" why what)))
600 (define put-cte-hook
601 (lambda (symbol val)
602 ($sc-put-cte symbol val '*top*)))
604 (define get-global-definition-hook
605 (lambda (symbol)
606 (getprop symbol '*sc-expander*)))
608 (define put-global-definition-hook
609 (lambda (symbol x)
610 (if (not x)
611 (remprop symbol '*sc-expander*)
612 (putprop symbol '*sc-expander* x))))
614 ; if you treat certain bindings (say from environments like ieee or r5rs)
615 ; read-only, this should return #t for those bindings
616 (define read-only-binding?
617 (lambda (symbol)
618 #f))
620 ; should return #f if symbol has no binding for token
621 (define get-import-binding
622 (lambda (symbol token)
623 (getprop symbol token)))
625 ; remove binding if x is false
626 (define update-import-binding!
627 (lambda (symbol token p)
628 (let ((x (p (get-import-binding symbol token))))
629 (if (not x)
630 (remprop symbol token)
631 (putprop symbol token x)))))
633 ;;; generate-id ideally produces globally unique symbols, i.e., symbols
634 ;;; unique across system runs, to support separate compilation/expansion.
635 ;;; Use gensyms if you do not need to support separate compilation/
636 ;;; expansion or if your system's gensym creates globally unique
637 ;;; symbols (as in Chez Scheme). Otherwise, use the following code
638 ;;; as a starting point. session-key should be a unique string for each
639 ;;; system run to support separate compilation; the default value given
640 ;;; is satisfactory during initial development only.
641 (define generate-id
642 (let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
643 (let ((base (string-length digits)) (session-key "_"))
644 (define make-digit (lambda (x) (string-ref digits x)))
645 (define fmt
646 (lambda (n)
647 (let fmt ((n n) (a '()))
648 (if (< n base)
649 (list->string (cons (make-digit n) a))
650 (let ((r (modulo n base)) (rest (quotient n base)))
651 (fmt rest (cons (make-digit r) a)))))))
652 (let ((n -1))
653 (lambda (name) ; name is #f or a symbol
654 (set! n (+ n 1))
655 (string->symbol (string-append session-key (fmt n))))))))
656 )
660 ;;; output constructors
661 (begin
662 (define-syntax build-application
663 (syntax-rules ()
664 ((_ ae fun-exp arg-exps)
665 ;*** `(,fun-exp . ,arg-exps))))
666 (build-source ae `(,fun-exp . ,arg-exps)))))
668 (define-syntax build-conditional
669 (syntax-rules ()
670 ((_ ae test-exp then-exp else-exp)
671 ;*** `(if ,test-exp ,then-exp ,else-exp))))
672 (build-source ae `(,(build-source ae 'if) ,test-exp ,then-exp ,else-exp)))))
674 (define-syntax build-lexical-reference
675 (syntax-rules ()
676 ((_ type ae var)
677 ;*** var)))
678 (build-source ae var))))
680 (define-syntax build-lexical-assignment
681 (syntax-rules ()
682 ((_ ae var exp)
683 ;*** `(set! ,var ,exp))))
684 (build-source ae `(,(build-source ae 'set!) ,(build-source ae var) ,exp)))))
686 (define-syntax build-global-reference
687 (syntax-rules ()
688 ((_ ae var)
689 ;*** var)))
690 (build-source ae var))))
692 (define-syntax build-global-assignment
693 (syntax-rules ()
694 ((_ ae var exp)
695 ;*** `(set! ,var ,exp))))
696 (build-source ae `(,(build-source ae 'set!) ,(build-source ae var) ,exp)))))
698 (define-syntax build-global-definition
699 (syntax-rules ()
700 ((_ ae var exp)
701 ;*** `(define ,var ,exp))))
702 (build-source ae `(,(build-source ae 'define) ,(build-source ae var) ,exp)))))
704 (define-syntax build-cte-install
705 ; should build a call that has the same effect as calling put-cte-hook
706 (syntax-rules ()
707 ;*** ((_ sym exp token) `($sc-put-cte ',sym ,exp ',token))))
708 ((_ sym exp token) (build-source #f `(,(build-source #f '$sc-put-cte) ',sym ,exp ,(build-source #f (list (build-source #f 'quote) token)))))))
710 (define-syntax build-visit-only
711 ; should mark the result as "visit only" for compile-file
712 ; in implementations that support visit/revisit
713 (syntax-rules ()
714 ((_ exp) exp)))
716 (define-syntax build-revisit-only
717 ; should mark the result as "revisit only" for compile-file,
718 ; in implementations that support visit/revisit
719 (syntax-rules ()
720 ((_ exp) exp)))
722 (define-syntax build-lambda
723 (syntax-rules ()
724 ((_ ae vars exp)
725 ;*** `(lambda ,vars ,exp))))
726 (build-source ae
727 `(,(build-source ae 'lambda)
728 ,(build-params ae vars)
729 ,exp)))))
731 (define built-lambda?
732 (lambda (x)
733 ;*** (and (pair? x) (eq? (car x) 'lambda))))
734 (or (and (pair? x) (eq? (car x) 'lambda))
735 (and (##source? x)
736 (pair? (##source-code x))
737 (##source? (car (##source-code x)))
738 (eq? (##source-code (car (##source-code x))) 'lambda)))))
740 (define-syntax build-primref
741 (syntax-rules ()
742 ;*** ((_ ae name) name)
743 ;*** ((_ ae level name) name)))
744 ((_ ae name) (build-source ae name))
745 ((_ ae level name) (build-source ae name))))
747 (define-syntax build-data
748 (syntax-rules ()
749 ;*** ((_ ae exp) `',exp)))
750 ((_ ae exp) (let ((x (attach-source ae exp))) (if (self-eval? exp) x (build-source ae (list (build-source ae 'quote) x)))))))
752 (define build-sequence
753 (lambda (ae exps)
754 (let loop ((exps exps))
755 (if (null? (cdr exps))
756 (car exps)
757 ; weed out leading void calls, assuming ordinary list representation
758 ;*** (if (equal? (car exps) '(void))
759 ;*** (loop (cdr exps))
760 ;*** `(begin ,@exps))))))
761 (if (let ((x (car exps)))
762 (or (equal? x '(void))
763 (and (##source? x)
764 (pair? (##source-code x))
765 (##source? (car (##source-code x)))
766 (eq? (##source-code (car (##source-code x))) 'void)
767 (null? (cdr (##source-code x))))))
768 (loop (cdr exps))
769 (build-source ae (cons (build-source ae 'begin) exps)))))))
771 (define build-letrec
772 (lambda (ae vars val-exps body-exp)
773 (if (null? vars)
774 body-exp
775 ;*** `(letrec ,(map list vars val-exps) ,body-exp))))
776 (build-source ae `(,(build-source ae 'letrec) ,(build-source ae (map (lambda (var val) (build-source ae (list (build-source ae var) val))) vars val-exps)) ,body-exp)))))
778 (define build-body
779 (lambda (ae vars val-exps body-exp)
780 (build-letrec ae vars val-exps body-exp)))
782 (define build-top-module
783 ; each type is either global (exported) or local (not exported)
784 ; we produce global definitions and assignments for globals and
785 ; letrec bindings for locals. if you don't need the definitions,
786 ; (just assignments) you can eliminate them. if you wish to
787 ; have your module definitions ordered from left-to-right (ala
788 ; letrec*), you can replace the global var-exps with dummy vars
789 ; and global val-exps with global assignments, and produce a letrec*
790 ; in place of a letrec.
791 (lambda (ae types vars val-exps body-exp)
792 (let-values (((vars defns sets)
793 (let f ((types types) (vars vars))
794 (if (null? types)
795 (values '() '() '())
796 (let ((var (car vars)))
797 (let-values (((vars defns sets) (f (cdr types) (cdr vars))))
798 (if (eq? (car types) 'global)
799 (let ((x (build-lexical-var no-source var)))
800 (values
801 (cons x vars)
802 (cons (build-global-definition no-source var (chi-void)) defns)
803 (cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
804 (values (cons var vars) defns sets))))))))
805 (if (null? defns)
806 (build-letrec ae vars val-exps body-exp)
807 (build-sequence no-source
808 (append defns
809 (list
810 (build-letrec ae vars val-exps
811 (build-sequence no-source (append sets (list body-exp)))))))))))
813 (define-syntax build-lexical-var
814 (syntax-rules ()
815 ;*** ((_ ae id) (gensym))))
816 ((_ ae id) (gensym id))))
818 (define-syntax lexical-var? gensym?)
820 (define-syntax self-evaluating?
821 (syntax-rules ()
822 ((_ e)
823 (let ((x e))
824 ;*** (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
825 (self-eval? x)))))
826 )
828 (define-syntax unannotate
829 (syntax-rules ()
830 ((_ x)
831 (let ((e x))
832 (if (annotation? e)
833 (annotation-expression e)
834 e)))))
836 (define-syntax no-source (identifier-syntax #f))
838 (define-syntax arg-check
839 (syntax-rules ()
840 ((_ pred? e who)
841 (let ((x e))
842 ;*** (if (not (pred? x)) (error-hook who "invalid argument" x))))))
843 (if (not (pred? x))
844 (error (string-append "(in "
845 (symbol->string who)
846 ") invalid argument")
847 x))))))
849 ;;; compile-time environments
851 ;;; wrap and environment comprise two level mapping.
852 ;;; wrap : id --> label
853 ;;; env : label --> <element>
855 ;;; environments are represented in two parts: a lexical part and a global
856 ;;; part. The lexical part is a simple list of associations from labels
857 ;;; to bindings. The global part is implemented by
858 ;;; {put,get}-global-definition-hook and associates symbols with
859 ;;; bindings.
861 ;;; global (assumed global variable) and displaced-lexical (see below)
862 ;;; do not show up in any environment; instead, they are fabricated by
863 ;;; lookup when it finds no other bindings.
865 ;;; <environment> ::= ((<label> . <binding>)*)
867 ;;; identifier bindings include a type and a value
869 ;;; <binding> ::= <procedure> macro keyword
870 ;;; (macro . <procedure>) macro keyword
871 ;;; (deferred . <thunk>) macro keyword w/lazily evaluated transformer
872 ;;; (macro! . <procedure>) extended identifier macro keyword
873 ;;; (core . <procedure>) core keyword
874 ;;; (begin) begin keyword
875 ;;; (define) define keyword
876 ;;; (define-syntax) define-syntax keyword
877 ;;; (local-syntax . <boolean>) let-syntax (#f)/letrec-syntax (#t) keyword
878 ;;; (eval-when) eval-when keyword
879 ;;; (set!) set! keyword
880 ;;; (meta) meta keyword
881 ;;; ($module-key) $module keyword
882 ;;; ($import) $import keyword
883 ;;; ($module . <interface>) modules
884 ;;; (syntax . (<var> . <level>)) pattern variables
885 ;;; (global . <symbol>) assumed global variable
886 ;;; (meta-variable . <symbol>) meta variable
887 ;;; (lexical . <var>) lexical variables
888 ;;; (displaced-lexical . #f) id-var-name not found in store
889 ;;; <level> ::= <nonnegative integer>
890 ;;; <var> ::= variable returned by build-lexical-var
892 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
893 ;;; syntactic form. begin, define, define-syntax, let-syntax, letrec-syntax,
894 ;;; eval-when, and meta are treated specially since they are sensitive to
895 ;;; whether the form is at top-level and can denote valid internal
896 ;;; definitions.
898 ;;; a pattern variable is a variable introduced by syntax-case and can
899 ;;; be referenced only within a syntax form.
901 ;;; any identifier for which no top-level syntax definition or local
902 ;;; binding of any kind has been seen is assumed to be a global
903 ;;; variable.
905 ;;; a lexical variable is a lambda- or letrec-bound variable.
907 ;;; a displaced-lexical identifier is a lexical identifier removed from
908 ;;; it's scope by the return of a syntax object containing the identifier.
909 ;;; a displaced lexical can also appear when a letrec-syntax-bound
910 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
911 ;;; a displaced lexical should never occur with properly written macros.
913 (define sanitize-binding
914 (lambda (b)
915 (cond
916 ((procedure? b) (make-binding 'macro b))
917 ((binding? b)
918 (and (case (binding-type b)
919 ((core macro macro! deferred) (and (procedure? (binding-value b))))
920 (($module) (interface? (binding-value b)))
921 ((lexical) (lexical-var? (binding-value b)))
922 ((global meta-variable) (symbol? (binding-value b)))
923 ((syntax) (let ((x (binding-value b)))
924 (and (pair? x)
925 (lexical-var? (car x))
926 (let ((n (cdr x)))
927 (and (integer? n) (exact? n) (>= n 0))))))
928 ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
929 ((local-syntax) (boolean? (binding-value b)))
930 ((displaced-lexical) (eq? (binding-value b) #f))
931 (else #t))
932 b))
933 (else #f))))
935 (define-syntax make-binding
936 (syntax-rules (quote)
937 ((_ 'type #f) '(type . #f))
938 ((_ type value) (cons type value))))
939 (define binding-type car)
940 (define binding-value cdr)
941 (define set-binding-type! set-car!)
942 (define set-binding-value! set-cdr!)
943 (define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
945 (define-syntax null-env (identifier-syntax '()))
947 (define extend-env
948 (lambda (label binding r)
949 (cons (cons label binding) r)))
951 (define extend-env*
952 (lambda (labels bindings r)
953 (if (null? labels)
954 r
955 (extend-env* (cdr labels) (cdr bindings)
956 (extend-env (car labels) (car bindings) r)))))
958 (define extend-var-env*
959 ; variant of extend-env* that forms "lexical" binding
960 (lambda (labels vars r)
961 (if (null? labels)
962 r
963 (extend-var-env* (cdr labels) (cdr vars)
964 (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
966 (define (displaced-lexical? id r)
967 (let ((n (id-var-name id empty-wrap)))
968 (and n
969 (let ((b (lookup n r)))
970 (eq? (binding-type b) 'displaced-lexical)))))
972 (define displaced-lexical-error
973 (lambda (id)
974 (syntax-error id
975 (if (id-var-name id empty-wrap)
976 "identifier out of context"
977 "identifier not visible"))))
979 (define lookup*
980 ; x may be a label or a symbol
981 ; although symbols are usually global, we check the environment first
982 ; anyway because a temporary binding may have been established by
983 ; fluid-let-syntax
984 (lambda (x r)
985 (cond
986 ((assq x r) => cdr)
987 ((symbol? x)
988 (or (get-global-definition-hook x) (make-binding 'global x)))
989 (else (make-binding 'displaced-lexical #f)))))
991 (define lookup
992 (lambda (x r)
993 (define whack-binding!
994 (lambda (b *b)
995 (set-binding-type! b (binding-type *b))
996 (set-binding-value! b (binding-value *b))))
997 (let ((b (lookup* x r)))
998 (when (eq? (binding-type b) 'deferred)
999 (whack-binding! b (make-transformer-binding ((binding-value b)))))
1000 b)))
1002 (define make-transformer-binding
1003 (lambda (b)
1004 (or (sanitize-binding b)
1005 (syntax-error b "invalid transformer"))))
1007 (define defer-or-eval-transformer
1008 (lambda (eval x)
1009 (if (built-lambda? x)
1010 (make-binding 'deferred (lambda () (eval x)))
1011 (make-transformer-binding (eval x)))))
1013 (define global-extend
1014 (lambda (type sym val)
1015 (put-cte-hook sym (make-binding type val))))
1018 ;;; Conceptually, identifiers are always syntax objects. Internally,
1019 ;;; however, the wrap is sometimes maintained separately (a source of
1020 ;;; efficiency and confusion), so that symbols are also considered
1021 ;;; identifiers by id?. Externally, they are always wrapped.
1023 (define nonsymbol-id?
1024 (lambda (x)
1025 (and (syntax-object? x)
1026 (symbol? (unannotate (syntax-object-expression x))))))
1028 (define id?
1029 (lambda (x)
1030 (cond
1031 ((symbol? x) #t)
1032 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
1033 ((annotation? x) (symbol? (annotation-expression x)))
1034 (else #f))))
1036 (define-syntax id-sym-name
1037 (syntax-rules ()
1038 ((_ e)
1039 (let ((x e))
1040 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
1042 (define id-marks
1043 (lambda (id)
1044 (if (syntax-object? id)
1045 (wrap-marks (syntax-object-wrap id))
1046 (wrap-marks top-wrap))))
1048 (define id-subst
1049 (lambda (id)
1050 (if (syntax-object? id)
1051 (wrap-subst (syntax-object-wrap id))
1052 (wrap-marks top-wrap))))
1054 (define id-sym-name&marks
1055 (lambda (x w)
1056 (if (syntax-object? x)
1057 (values
1058 (unannotate (syntax-object-expression x))
1059 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
1060 (values (unannotate x) (wrap-marks w)))))
1062 ;;; syntax object wraps
1064 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
1065 ;;; <subst> ::= <ribcage> | <shift>
1066 ;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
1067 ;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
1068 ;;; <ex-symname> ::= <symname> | <import token> | <barrier>
1069 ;;; <shift> ::= shift
1070 ;;; <barrier> ::= #f ; inserted by import-only
1071 ;;; <import interface> ::= #<import-interface interface new-marks>
1072 ;;; <token> ::= <generated id>
1074 (define make-wrap cons)
1075 (define wrap-marks car)
1076 (define wrap-subst cdr)
1079 (define-syntax empty-wrap (identifier-syntax '(())))
1081 (define-syntax top-wrap (identifier-syntax '((top))))
1083 (define-syntax tmp-wrap (identifier-syntax '((tmp)))) ; for generate-temporaries
1085 (define-syntax top-marked?
1086 (syntax-rules ()
1087 ((_ w) (memq 'top (wrap-marks w)))))
1089 (define-syntax only-top-marked?
1090 (syntax-rules ()
1091 ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
1093 ;;; labels
1095 ;;; simple labels must be comparable with "eq?" and distinct from symbols
1096 ;;; and pairs.
1098 ;;; indirect labels, which are implemented as pairs, are used to support
1099 ;;; import aliasing for identifiers exported (explictly or implicitly) from
1100 ;;; top-level modules. chi-external creates an indirect label for each
1101 ;;; defined identifier, import causes the pair to be shared with aliases it
1102 ;;; establishes, and chi-top-module whacks the pair to hold the top-level
1103 ;;; identifier name (symbol) if the id is to be placed at top level, before
1104 ;;; expanding the right-hand sides of the definitions in the module.
1106 (module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
1107 (define-structure (indirect-label label))
1108 (define gen-indirect-label
1109 (lambda ()
1110 (make-indirect-label (gen-label))))
1111 (define get-indirect-label (lambda (x) (indirect-label-label x)))
1112 (define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
1114 (define gen-label
1115 (lambda () (string #\i)))
1116 (define label?
1117 (lambda (x)
1118 (or (string? x) ; normal lexical labels
1119 (symbol? x) ; global labels (symbolic names)
1120 (indirect-label? x))))
1122 (define gen-labels
1123 (lambda (ls)
1124 (if (null? ls)
1125 '()
1126 (cons (gen-label) (gen-labels (cdr ls))))))
1128 (define-structure (ribcage symnames marks labels))
1129 (define-structure (top-ribcage key mutable?))
1130 (define-structure (import-interface interface new-marks))
1131 (define-structure (env top-ribcage wrap))
1133 ;;; Marks must be comparable with "eq?" and distinct from pairs and
1134 ;;; the symbol top. We do not use integers so that marks will remain
1135 ;;; unique even across file compiles.
1137 (define-syntax the-anti-mark (identifier-syntax #f))
1139 (define anti-mark
1140 (lambda (w)
1141 (make-wrap (cons the-anti-mark (wrap-marks w))
1142 (cons 'shift (wrap-subst w)))))
1144 (define-syntax new-mark
1145 (syntax-rules ()
1146 ((_) (string #\m))))
1148 (define barrier-marker #f)
1150 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
1151 ;;; internal definitions, in which the ribcages are built incrementally
1152 (define-syntax make-empty-ribcage
1153 (syntax-rules ()
1154 ((_) (make-ribcage '() '() '()))))
1156 (define extend-ribcage!
1157 ; must receive ids with complete wraps
1158 ; ribcage guaranteed to be list-based
1159 (lambda (ribcage id label)
1160 (set-ribcage-symnames! ribcage
1161 (cons (unannotate (syntax-object-expression id))
1162 (ribcage-symnames ribcage)))
1163 (set-ribcage-marks! ribcage
1164 (cons (wrap-marks (syntax-object-wrap id))
1165 (ribcage-marks ribcage)))
1166 (set-ribcage-labels! ribcage
1167 (cons label (ribcage-labels ribcage)))))
1169 (define import-extend-ribcage!
1170 ; must receive ids with complete wraps
1171 ; ribcage guaranteed to be list-based
1172 (lambda (ribcage new-marks id label)
1173 (set-ribcage-symnames! ribcage
1174 (cons (unannotate (syntax-object-expression id))
1175 (ribcage-symnames ribcage)))
1176 (set-ribcage-marks! ribcage
1177 (cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
1178 (ribcage-marks ribcage)))
1179 (set-ribcage-labels! ribcage
1180 (cons label (ribcage-labels ribcage)))))
1182 (define extend-ribcage-barrier!
1183 ; must receive ids with complete wraps
1184 ; ribcage guaranteed to be list-based
1185 (lambda (ribcage killer-id)
1186 (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
1188 (define extend-ribcage-barrier-help!
1189 (lambda (ribcage wrap)
1190 (set-ribcage-symnames! ribcage
1191 (cons barrier-marker (ribcage-symnames ribcage)))
1192 (set-ribcage-marks! ribcage
1193 (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
1195 (define extend-ribcage-subst!
1196 ; ribcage guaranteed to be list-based
1197 (lambda (ribcage import-iface)
1198 (set-ribcage-symnames! ribcage
1199 (cons import-iface (ribcage-symnames ribcage)))))
1201 (define lookup-import-binding-name
1202 (lambda (sym marks token new-marks)
1203 (let ((new (get-import-binding sym token)))
1204 (and new
1205 (let f ((new new))
1206 (cond
1207 ((pair? new) (or (f (car new)) (f (cdr new))))
1208 ((symbol? new)
1209 (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
1210 ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
1211 (else #f)))))))
1213 (define store-import-binding
1214 (lambda (id token new-marks)
1215 (define cons-id
1216 (lambda (id x)
1217 (if (not x) id (cons id x))))
1218 (define weed ; remove existing binding for id, if any
1219 (lambda (marks x)
1220 (if (pair? x)
1221 (if (same-marks? (id-marks (car x)) marks)
1222 (weed marks (cdr x))
1223 (cons-id (car x) (weed marks (cdr x))))
1224 (and x (not (same-marks? (id-marks x) marks)) x))))
1225 (let ((id (if (null? new-marks)
1226 id
1227 (make-syntax-object (id-sym-name id)
1228 (make-wrap
1229 (join-marks new-marks (id-marks id))
1230 (id-subst id))))))
1231 (let ((sym (id-sym-name id)))
1232 ; no need to record bindings mapping symbol to self, since this
1233 ; assumed by default.
1234 (unless (eq? id sym)
1235 (let ((marks (id-marks id)))
1236 (update-import-binding! sym token
1237 (lambda (old-binding)
1238 (let ((x (weed marks old-binding)))
1239 (cons-id
1240 (if (same-marks? marks (wrap-marks top-wrap))
1241 ; need full id only if more than top-marked.
1242 (resolved-id-var-name id)
1243 id)
1244 x))))))))))
1246 ;;; make-binding-wrap creates vector-based ribcages
1247 (define make-binding-wrap
1248 (lambda (ids labels w)
1249 (if (null? ids)
1250 w
1251 (make-wrap
1252 (wrap-marks w)
1253 (cons
1254 (let ((labelvec (list->vector labels)))
1255 (let ((n (vector-length labelvec)))
1256 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
1257 (let f ((ids ids) (i 0))
1258 (unless (null? ids)
1259 (let-values (((symname marks) (id-sym-name&marks (car ids) w)))
1260 (vector-set! symnamevec i symname)
1261 (vector-set! marksvec i marks)
1262 (f (cdr ids) (fx+ i 1)))))
1263 (make-ribcage symnamevec marksvec labelvec))))
1264 (wrap-subst w))))))
1266 ;;; resolved ids contain no unnecessary substitutions or marks. they are
1267 ;;; used essentially as indirects or aliases in modules interfaces.
1268 (define make-resolved-id
1269 (lambda (fromsym marks tosym)
1270 (make-syntax-object fromsym
1271 (make-wrap marks
1272 (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
1274 (define id->resolved-id
1275 (lambda (id)
1276 (let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
1277 (unless tosym
1278 (syntax-error id "identifier not visible for export"))
1279 (make-resolved-id (id-sym-name id) marks tosym))))
1281 (define resolved-id-var-name
1282 (lambda (id)
1283 (vector-ref
1284 (ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
1285 0)))
1287 ;;; Scheme's append should not copy the first argument if the second is
1288 ;;; nil, but it does, so we define a smart version here.
1289 (define smart-append
1290 (lambda (m1 m2)
1291 (if (null? m2)
1292 m1
1293 (append m1 m2))))
1295 (define join-wraps
1296 (lambda (w1 w2)
1297 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
1298 (if (null? m1)
1299 (if (null? s1)
1300 w2
1301 (make-wrap
1302 (wrap-marks w2)
1303 (join-subst s1 (wrap-subst w2))))
1304 (make-wrap
1305 (join-marks m1 (wrap-marks w2))
1306 (join-subst s1 (wrap-subst w2)))))))
1308 (define join-marks
1309 (lambda (m1 m2)
1310 (smart-append m1 m2)))
1312 (define join-subst
1313 (lambda (s1 s2)
1314 (smart-append s1 s2)))
1316 (define same-marks?
1317 (lambda (x y)
1318 (or (eq? x y)
1319 (and (not (null? x))
1320 (not (null? y))
1321 (eq? (car x) (car y))
1322 (same-marks? (cdr x) (cdr y))))))
1324 (define diff-marks
1325 (lambda (m1 m2)
1326 (let ((n1 (length m1)) (n2 (length m2)))
1327 (let f ((n1 n1) (m1 m1))
1328 (cond
1329 ((> n1 n2) (cons (car m1) (f (- n1 1) (cdr m1))))
1330 ((equal? m1 m2) '())
1331 ;*** (else (error 'sc-expand
1332 ;*** "internal error in diff-marks: ~s is not a tail of ~s"
1333 ;*** m1 m2)))))))
1334 (else (error
1335 "internal error in diff-marks"
1336 m1 m2)))))))
1338 (module (top-id-bound-var-name top-id-free-var-name)
1339 ;; top-id-bound-var-name is used to look up or establish new top-level
1340 ;; substitutions, while top-id-free-var-name is used to look up existing
1341 ;; (possibly implicit) substitutions. Implicit substitutions exist
1342 ;; for top-marked names in all environments, but we represent them
1343 ;; explicitly only on demand.
1344 ;;
1345 ;; In both cases, we first look for an existing substitution for sym
1346 ;; and the given marks. If we find one, we return it. Otherwise, we
1347 ;; extend the appropriate top-level environment
1348 ;;
1349 ;; For top-id-bound-var-name, we extend the environment with a substition
1350 ;; keyed by the given marks, so that top-level definitions introduced by
1351 ;; a macro are distinct from other top-level definitions for the same
1352 ;; name. For example, if macros a and b both introduce definitions and
1353 ;; bound references to identifier x, the two x's should be different,
1354 ;; i.e., keyed by their own marks.
1355 ;;
1356 ;; For top-id-free-var-name, we extend the environment with a substition
1357 ;; keyed by the top marks, since top-level free identifier references
1358 ;; should refer to the existing implicit (top-marked) substitution. For
1359 ;; example, if macros a and b both introduce free references to identifier
1360 ;; x, they should both refer to the same (global, unmarked) x.
1361 ;;
1362 ;; If the environment is *top*, we map a symbol to itself
1364 (define leave-implicit? (lambda (token) (eq? token '*top*)))
1366 (define new-binding
1367 (lambda (sym marks token)
1368 (let ((loc (if (and (leave-implicit? token)
1369 (same-marks? marks (wrap-marks top-wrap)))
1370 sym
1371 (generate-id sym))))
1372 (let ((id (make-resolved-id sym marks loc)))
1373 (store-import-binding id token '())
1374 (values loc id)))))
1376 (define top-id-bound-var-name
1377 ; should be called only when top-ribcage is mutable
1378 (lambda (sym marks top-ribcage)
1379 (let ((token (top-ribcage-key top-ribcage)))
1380 (cond
1381 ((lookup-import-binding-name sym marks token '()) =>
1382 (lambda (id)
1383 (if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
1384 (if (read-only-binding? id)
1385 (new-binding sym marks token)
1386 (values id (make-resolved-id sym marks id)))
1387 (values (resolved-id-var-name id) id))))
1388 (else (new-binding sym marks token))))))
1390 (define top-id-free-var-name
1391 (lambda (sym marks top-ribcage)
1392 (let ((token (top-ribcage-key top-ribcage)))
1393 (cond
1394 ((lookup-import-binding-name sym marks token '()) =>
1395 (lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
1396 ((and (top-ribcage-mutable? top-ribcage)
1397 (same-marks? marks (wrap-marks top-wrap)))
1398 (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
1399 sym))
1400 (else #f))))))
1402 (define id-var-name-loc&marks
1403 (lambda (id w)
1404 (define search
1405 (lambda (sym subst marks)
1406 (if (null? subst)
1407 (values #f marks)
1408 (let ((fst (car subst)))
1409 (cond
1410 ((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
1411 ((ribcage? fst)
1412 (let ((symnames (ribcage-symnames fst)))
1413 (if (vector? symnames)
1414 (search-vector-rib sym subst marks symnames fst)
1415 (search-list-rib sym subst marks symnames fst))))
1416 ((top-ribcage? fst)
1417 (cond
1418 ((top-id-free-var-name sym marks fst) =>
1419 (lambda (var-name) (values var-name marks)))
1420 (else (search sym (cdr subst) marks))))
1421 (else
1422 ;*** (error 'sc-expand
1423 ;*** "internal error in id-var-name-loc&marks: improper subst ~s"
1424 ;*** subst)))))))
1425 (error
1426 "internal error in id-var-name-loc&marks: improper subst"
1427 subst)))))))
1428 (define search-list-rib
1429 (lambda (sym subst marks symnames ribcage)
1430 (let f ((symnames symnames) (i 0))
1431 (if (null? symnames)
1432 (search sym (cdr subst) marks)
1433 (let ((x (car symnames)))
1434 (cond
1435 ((and (eq? x sym)
1436 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
1437 (values (list-ref (ribcage-labels ribcage) i) marks))
1438 ((import-interface? x)
1439 (let ((iface (import-interface-interface x))
1440 (new-marks (import-interface-new-marks x)))
1441 (cond
1442 ((interface-token iface) =>
1443 (lambda (token)
1444 (cond
1445 ((lookup-import-binding-name sym marks token new-marks) =>
1446 (lambda (id)
1447 (values
1448 (if (symbol? id) id (resolved-id-var-name id))
1449 marks)))
1450 (else (f (cdr symnames) i)))))
1451 (else
1452 (let* ((ie (interface-exports iface))
1453 (n (vector-length ie)))
1454 (let g ((j 0))
1455 (if (fx= j n)
1456 (f (cdr symnames) i)
1457 (let ((id (vector-ref ie j)))
1458 (let ((id.sym (id-sym-name id))
1459 (id.marks (join-marks new-marks (id-marks id))))
1460 (if (help-bound-id=? id.sym id.marks sym marks)
1461 (values (lookup-import-label id) marks)
1462 (g (fx+ j 1))))))))))))
1463 ((and (eq? x barrier-marker)
1464 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
1465 (values #f marks))
1466 (else (f (cdr symnames) (fx+ i 1)))))))))
1467 (define search-vector-rib
1468 (lambda (sym subst marks symnames ribcage)
1469 (let ((n (vector-length symnames)))
1470 (let f ((i 0))
1471 (cond
1472 ((fx= i n) (search sym (cdr subst) marks))
1473 ((and (eq? (vector-ref symnames i) sym)
1474 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
1475 (values (vector-ref (ribcage-labels ribcage) i) marks))
1476 (else (f (fx+ i 1))))))))
1477 (cond
1478 ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
1479 ((syntax-object? id)
1480 (let ((sym (unannotate (syntax-object-expression id)))
1481 (w1 (syntax-object-wrap id)))
1482 (let-values (((name marks) (search sym (wrap-subst w)
1483 (join-marks
1484 (wrap-marks w)
1485 (wrap-marks w1)))))
1486 (if name
1487 (values name marks)
1488 (search sym (wrap-subst w1) marks)))))
1489 ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
1490 ;*** (else (error-hook 'id-var-name "invalid id" id)))))
1491 (else (error "(in id-var-name) invalid id" id)))))
1493 (define id-var-name&marks
1494 ; this version follows indirect labels
1495 (lambda (id w)
1496 (let-values (((label marks) (id-var-name-loc&marks id w)))
1497 (values (if (indirect-label? label) (get-indirect-label label) label) marks))))
1499 (define id-var-name-loc
1500 ; this version doesn't follow indirect labels
1501 (lambda (id w)
1502 (let-values (((label marks) (id-var-name-loc&marks id w)))
1503 label)))
1505 (define id-var-name
1506 ; this version follows indirect labels
1507 (lambda (id w)
1508 (let-values (((label marks) (id-var-name-loc&marks id w)))
1509 (if (indirect-label? label) (get-indirect-label label) label))))
1511 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
1512 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
1514 (define free-id=?
1515 (lambda (i j)
1516 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
1517 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
1519 (define literal-id=?
1520 (lambda (id literal)
1521 (and (eq? (id-sym-name id) (id-sym-name literal))
1522 (let ((n-id (id-var-name id empty-wrap))
1523 (n-literal (id-var-name literal empty-wrap)))
1524 (or (eq? n-id n-literal)
1525 (and (or (not n-id) (symbol? n-id))
1526 (or (not n-literal) (symbol? n-literal))))))))
1528 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
1529 ;;; long as the missing portion of the wrap is common to both of the ids
1530 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
1532 (define help-bound-id=?
1533 (lambda (i.sym i.marks j.sym j.marks)
1534 (and (eq? i.sym j.sym)
1535 (same-marks? i.marks j.marks))))
1537 (define bound-id=?
1538 (lambda (i j)
1539 (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
1541 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
1542 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
1543 ;;; as long as the missing portion of the wrap is common to all of the
1544 ;;; ids.
1546 (define valid-bound-ids?
1547 (lambda (ids)
1548 (and (let all-ids? ((ids ids))
1549 (or (null? ids)
1550 (and (id? (car ids))
1551 (all-ids? (cdr ids)))))
1552 (distinct-bound-ids? ids))))
1554 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
1555 ;;; no duplicates. It is quadratic on the length of the id list; long
1556 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
1557 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
1558 ;;; missing portion of the wrap is common to all of the ids.
1560 (define distinct-bound-ids?
1561 (lambda (ids)
1562 (let distinct? ((ids ids))
1563 (or (null? ids)
1564 (and (not (bound-id-member? (car ids) (cdr ids)))
1565 (distinct? (cdr ids)))))))
1567 (define invalid-ids-error
1568 ; find first bad one and complain about it
1569 (lambda (ids exp class)
1570 (let find ((ids ids) (gooduns '()))
1571 (if (null? ids)
1572 (syntax-error exp) ; shouldn't happen
1573 (if (id? (car ids))
1574 (if (bound-id-member? (car ids) gooduns)
1575 (syntax-error (car ids) "duplicate " class)
1576 (find (cdr ids) (cons (car ids) gooduns)))
1577 (syntax-error (car ids) "invalid " class))))))
1579 (define bound-id-member?
1580 (lambda (x list)
1581 (and (not (null? list))
1582 (or (bound-id=? x (car list))
1583 (bound-id-member? x (cdr list))))))
1585 ;;; wrapping expressions and identifiers
1587 (define wrap
1588 (lambda (x w)
1589 (cond
1590 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
1591 ((syntax-object? x)
1592 (make-syntax-object
1593 (syntax-object-expression x)
1594 (join-wraps w (syntax-object-wrap x))))
1595 ((null? x) x)
1596 (else (make-syntax-object x w)))))
1598 (define source-wrap
1599 (lambda (x w ae)
1600 (wrap (if (annotation? ae)
1601 (begin
1602 (unless (eq? (annotation-expression ae) x)
1603 ;*** (error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
1604 (error "internal error in source-wrap: ae/x mismatch"))
1605 ae)
1606 x)
1607 w)))
1609 ;;; expanding
1611 (define chi-when-list
1612 (lambda (when-list w)
1613 ; when-list is syntax'd version of list of situations
1614 (map (lambda (x)
1615 (cond
1616 ((literal-id=? x (syntax compile)) 'compile)
1617 ((literal-id=? x (syntax load)) 'load)
1618 ((literal-id=? x (syntax visit)) 'visit)
1619 ((literal-id=? x (syntax revisit)) 'revisit)
1620 ((literal-id=? x (syntax eval)) 'eval)
1621 (else (syntax-error (wrap x w) "invalid eval-when situation"))))
1622 when-list)))
1624 ;;; syntax-type returns five values: type, value, e, w, and ae. The first
1625 ;;; two are described in the table below.
1626 ;;;
1627 ;;; type value explanation
1628 ;;; -------------------------------------------------------------------
1629 ;;; alias none alias keyword
1630 ;;; alias-form none alias expression
1631 ;;; begin none begin keyword
1632 ;;; begin-form none begin expression
1633 ;;; call none any other call
1634 ;;; constant none self-evaluating datum
1635 ;;; core procedure core form (including singleton)
1636 ;;; define none define keyword
1637 ;;; define-form none variable definition
1638 ;;; define-syntax none define-syntax keyword
1639 ;;; define-syntax-form none syntax definition
1640 ;;; displaced-lexical none displaced lexical identifier
1641 ;;; eval-when none eval-when keyword
1642 ;;; eval-when-form none eval-when form
1643 ;;; global name global variable reference
1644 ;;; $import none $import keyword
1645 ;;; $import-form none $import form
1646 ;;; lexical name lexical variable reference
1647 ;;; lexical-call name call to lexical variable
1648 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
1649 ;;; local-syntax-form rec? syntax definition
1650 ;;; meta none meta keyword
1651 ;;; meta-form none meta form
1652 ;;; meta-variable name meta variable
1653 ;;; $module none $module keyword
1654 ;;; $module-form none $module definition
1655 ;;; syntax level pattern variable
1656 ;;; other none anything else
1657 ;;;
1658 ;;; For all forms, e is the form, w is the wrap for e. and ae is the
1659 ;;; (possibly) source-annotated form.
1660 ;;;
1661 ;;; syntax-type expands macros and unwraps as necessary to get to
1662 ;;; one of the forms above.
1664 (define syntax-type
1665 (lambda (e r w ae rib)
1666 (cond
1667 ((symbol? e)
1668 (let* ((n (id-var-name e w))
1669 (b (lookup n r))
1670 (type (binding-type b)))
1671 (case type
1672 ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
1673 (else (values type (binding-value b) e w ae)))))
1674 ((pair? e)
1675 (let ((first (car e)))
1676 (if (id? first)
1677 (let* ((n (id-var-name first w))
1678 (b (lookup n r))
1679 (type (binding-type b)))
1680 (case type
1681 ((lexical) (values 'lexical-call (binding-value b) e w ae))
1682 ((macro macro!)
1683 (syntax-type (chi-macro (binding-value b) e r w ae rib)
1684 r empty-wrap #f rib))
1685 ((core) (values type (binding-value b) e w ae))
1686 ((begin) (values 'begin-form #f e w ae))
1687 ((alias) (values 'alias-form #f e w ae))
1688 ((define) (values 'define-form #f e w ae))
1689 ((define-syntax) (values 'define-syntax-form #f e w ae))
1690 ((set!) (chi-set! e r w ae rib))
1691 (($module-key) (values '$module-form #f e w ae))
1692 (($import) (values '$import-form #f e w ae))
1693 ((eval-when) (values 'eval-when-form #f e w ae))
1694 ((meta) (values 'meta-form #f e w ae))
1695 ((local-syntax)
1696 (values 'local-syntax-form (binding-value b) e w ae))
1697 (else (values 'call #f e w ae))))
1698 (values 'call #f e w ae))))
1699 ((syntax-object? e)
1700 (syntax-type (syntax-object-expression e)
1701 r
1702 (join-wraps w (syntax-object-wrap e))
1703 #f rib))
1704 ((annotation? e)
1705 (syntax-type (annotation-expression e) r w e rib))
1706 ((self-evaluating? e) (values 'constant #f e w ae))
1707 (else (values 'other #f e w ae)))))
1709 (define chi-top*
1710 (lambda (e r w ctem rtem meta? top-ribcage)
1711 (let ((meta-residuals '()))
1712 (define meta-residualize!
1713 (lambda (x)
1714 (set! meta-residuals
1715 (cons x meta-residuals))))
1716 (let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
1717 (build-sequence no-source
1718 (reverse (cons e meta-residuals)))))))
1720 (define chi-top-sequence
1721 (lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
1722 (build-sequence ae
1723 (let dobody ((body body))
1724 (if (null? body)
1725 '()
1726 (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
1727 (cons first (dobody (cdr body)))))))))
1729 (define chi-top
1730 (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
1731 (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
1732 (case type
1733 ((begin-form)
1734 (let ((forms (parse-begin e w ae #t)))
1735 (if (null? forms)
1736 (chi-void)
1737 (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
1738 ((local-syntax-form)
1739 (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
1740 ; mr should be same as r here
1741 (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
1742 ((eval-when-form)
1743 (let-values (((when-list forms) (parse-eval-when e w ae)))
1744 (let ((ctem (update-mode-set when-list ctem))
1745 (rtem (update-mode-set when-list rtem)))
1746 (if (and (null? ctem) (null? rtem))
1747 (chi-void)
1748 (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
1749 ((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
1750 ((define-syntax-form)
1751 (let-values (((id rhs w) (parse-define-syntax e w ae)))
1752 (let ((id (wrap id w)))
1753 (when (displaced-lexical? id r) (displaced-lexical-error id))
1754 (unless (top-ribcage-mutable? top-ribcage)
1755 (syntax-error (source-wrap e w ae)
1756 "invalid definition in read-only environment"))
1757 (let ((sym (id-sym-name id)))
1758 (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
1759 (unless (eq? (id-var-name id empty-wrap) valsym)
1760 (syntax-error (source-wrap e w ae)
1761 "definition not permitted"))
1762 (when (read-only-binding? valsym)
1763 (syntax-error (source-wrap e w ae)
1764 "invalid definition of read-only identifier"))
1765 (ct-eval/residualize2 ctem
1766 (lambda ()
1767 (build-cte-install
1768 bound-id
1769 (chi rhs r r w #t)
1770 (top-ribcage-key top-ribcage)))))))))
1771 ((define-form)
1772 (let-values (((id rhs w) (parse-define e w ae)))
1773 (let ((id (wrap id w)))
1774 (when (displaced-lexical? id r) (displaced-lexical-error id))
1775 (unless (top-ribcage-mutable? top-ribcage)
1776 (syntax-error (source-wrap e w ae)
1777 "invalid definition in read-only environment"))
1778 (let ((sym (id-sym-name id)))
1779 (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
1780 (unless (eq? (id-var-name id empty-wrap) valsym)
1781 (syntax-error (source-wrap e w ae)
1782 "definition not permitted"))
1783 (when (read-only-binding? valsym)
1784 (syntax-error (source-wrap e w ae)
1785 "invalid definition of read-only identifier"))
1786 (if meta?
1787 (ct-eval/residualize2 ctem
1788 (lambda ()
1789 (build-sequence no-source
1790 (list
1791 (build-cte-install bound-id
1792 (build-data no-source (make-binding 'meta-variable valsym))
1793 (top-ribcage-key top-ribcage))
1794 (build-global-definition ae valsym (chi rhs r r w #t))))))
1795 ; make sure compile-time definitions occur before we
1796 ; expand the run-time code
1797 (let ((x (ct-eval/residualize2 ctem
1798 (lambda ()
1799 (build-cte-install
1800 bound-id
1801 (build-data no-source (make-binding 'global valsym))
1802 (top-ribcage-key top-ribcage))))))
1803 (build-sequence no-source
1804 (list
1805 x
1806 (rt-eval/residualize rtem
1807 (lambda ()
1808 (build-global-definition ae valsym (chi rhs r r w #f)))))))))
1809 ))))
1810 (($module-form)
1811 (let ((ribcage (make-empty-ribcage)))
1812 (let-values (((orig id exports forms)
1813 (parse-module e w ae
1814 (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
1815 (when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
1816 (unless (top-ribcage-mutable? top-ribcage)
1817 (syntax-error orig
1818 "invalid definition in read-only environment"))
1819 (chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
1820 (($import-form)
1821 (let-values (((orig only? mid) (parse-import e w ae)))
1822 (unless (top-ribcage-mutable? top-ribcage)
1823 (syntax-error orig
1824 "invalid definition in read-only environment"))
1825 (ct-eval/residualize2 ctem
1826 (lambda ()
1827 (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
1828 (case (binding-type binding)
1829 (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
1830 ((displaced-lexical) (displaced-lexical-error mid))
1831 (else (syntax-error mid "unknown module"))))))))
1832 ((alias-form)
1833 (let-values (((new-id old-id) (parse-alias e w ae)))
1834 (let ((new-id (wrap new-id w)))
1835 (when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
1836 (unless (top-ribcage-mutable? top-ribcage)
1837 (syntax-error (source-wrap e w ae)
1838 "invalid definition in read-only environment"))
1839 (let ((sym (id-sym-name new-id)))
1840 (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
1841 (unless (eq? (id-var-name new-id empty-wrap) valsym)
1842 (syntax-error (source-wrap e w ae)
1843 "definition not permitted"))
1844 (when (read-only-binding? valsym)
1845 (syntax-error (source-wrap e w ae)
1846 "invalid definition of read-only identifier"))
1847 (ct-eval/residualize2 ctem
1848 (lambda ()
1849 (build-cte-install
1850 (make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
1851 (build-data no-source (make-binding 'do-alias #f))
1852 (top-ribcage-key top-ribcage)))))))))
1853 (else
1854 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
1855 (if meta?
1856 (let ((x (chi-expr type value e r r w ae #t)))
1857 (top-level-eval-hook x)
1858 (ct-eval/residualize3 ctem void (lambda () x)))
1859 (rt-eval/residualize rtem
1860 (lambda ()
1861 (chi-expr type value e r r w ae #f)))))))))
1863 (define flatten-exports
1864 (lambda (exports)
1865 (let loop ((exports exports) (ls '()))
1866 (if (null? exports)
1867 ls
1868 (loop (cdr exports)
1869 (if (pair? (car exports))
1870 (loop (car exports) ls)
1871 (cons (car exports) ls)))))))
1874 (define-structure (interface marks exports token))
1876 ;; leaves interfaces unresolved so that indirect labels can be followed.
1877 ;; (can't resolve until indirect labels have their final value)
1878 (define make-unresolved-interface
1879 ; trim out implicit exports
1880 (lambda (mid exports)
1881 (make-interface
1882 (wrap-marks (syntax-object-wrap mid))
1883 (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
1884 #f)))
1886 (define make-resolved-interface
1887 ; trim out implicit exports & resolve others to actual top-level symbol
1888 (lambda (mid exports token)
1889 (make-interface
1890 (wrap-marks (syntax-object-wrap mid))
1891 (list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
1892 token)))
1894 (define-structure (module-binding type id label imps val exported))
1895 (define create-module-binding
1896 (lambda (type id label imps val)
1897 (make-module-binding type id label imps val #f)))
1899 ;;; frobs represent body forms
1900 (define-structure (frob e meta?))
1902 (define chi-top-module
1903 (lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
1904 (let ((fexports (flatten-exports exports)))
1905 (let-values (((r mr bindings inits)
1906 (chi-external ribcage orig
1907 (map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
1908 meta-residualize!)))
1909 ; identify exported identifiers, create ctdefs
1910 (let process-exports ((fexports fexports) (ctdefs (lambda () '())))
1911 (if (null? fexports)
1912 ; remaining bindings are either identified global vars,
1913 ; local vars, or local compile-time entities
1914 ; dts: type (local/global)
1915 ; dvs & des: define lhs & rhs
1916 (let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
1917 (if (null? bs)
1918 (let ((des (chi-frobs des r mr #f))
1919 (inits (chi-frobs inits r mr #f)))
1920 (build-sequence no-source
1921 (append
1922 ; we wait to establish global compile-time definitions so that
1923 ; expansion of des use local versions of modules and macros
1924 ; in case ctem tells us not to eval ctdefs now. this means that
1925 ; local code can use exported compile-time values (modules, macros,
1926 ; meta variables) just as it can unexported ones.
1927 (ctdefs)
1928 (list
1929 (ct-eval/residualize2 ctem
1930 (lambda ()
1931 (let ((sym (id-sym-name id)))
1932 (let* ((token (generate-id sym))
1933 (b (build-data no-source
1934 (make-binding '$module
1935 (make-resolved-interface id exports token)))))
1936 (let-values (((valsym bound-id)
1937 (top-id-bound-var-name sym
1938 (wrap-marks (syntax-object-wrap id))
1939 top-ribcage)))
1940 (unless (eq? (id-var-name id empty-wrap) valsym)
1941 (syntax-error orig
1942 "definition not permitted"))
1943 (when (read-only-binding? valsym)
1944 (syntax-error orig
1945 "invalid definition of read-only identifier"))
1946 (build-cte-install bound-id b
1947 (top-ribcage-key top-ribcage)))))))
1948 (rt-eval/residualize rtem
1949 (lambda ()
1950 (build-top-module no-source dts dvs des
1951 (if (null? inits)
1952 (chi-void)
1953 (build-sequence no-source
1954 (append inits (list (chi-void))))))))))))
1955 (let ((b (car bs)) (bs (cdr bs)))
1956 (let ((t (module-binding-type b)))
1957 (case (module-binding-type b)
1958 ((define-form)
1959 (let ((label (get-indirect-label (module-binding-label b))))
1960 (if (module-binding-exported b)
1961 (let ((var (module-binding-id b)))
1962 (process-locals bs r (cons 'global dts) (cons label dvs)
1963 (cons (module-binding-val b) des)))
1964 (let ((var (gen-var (module-binding-id b))))
1965 (process-locals bs
1966 ; add lexical bindings only to run-time environment
1967 (extend-env label (make-binding 'lexical var) r)
1968 (cons 'local dts) (cons var dvs)
1969 (cons (module-binding-val b) des))))))
1970 ((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
1971 ;*** (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
1972 (else (error "unexpected module binding type" t)))))))
1973 (let ((id (car fexports)) (fexports (cdr fexports)))
1974 (let loop ((bs bindings))
1975 (if (null? bs)
1976 ; must be rexport from an imported module
1977 (process-exports fexports ctdefs)
1978 (let ((b (car bs)) (bs (cdr bs)))
1979 ; following formerly used bound-id=?, but free-id=? can prevent false positives
1980 ; and is okay since the substitutions have already been applied
1981 (if (free-id=? (module-binding-id b) id)
1982 (if (module-binding-exported b)
1983 (process-exports fexports ctdefs)
1984 (let* ((t (module-binding-type b))
1985 (label (module-binding-label b))
1986 (imps (module-binding-imps b))
1987 (fexports (append imps fexports)))
1988 (set-module-binding-exported! b #t)
1989 (case t
1990 ((define-form)
1991 (let ((sym (generate-id (id-sym-name id))))
1992 (set-indirect-label! label sym)
1993 (process-exports fexports ctdefs)))
1994 ((ctdefine-form)
1995 (let ((b (module-binding-val b)))
1996 (process-exports fexports
1997 (lambda ()
1998 (let ((sym (binding-value b)))
1999 (set-indirect-label! label sym)
2000 (cons (ct-eval/residualize3 ctem
2001 (lambda () (put-cte-hook sym b))
2002 (lambda () (build-cte-install sym (build-data no-source b) #f)))
2003 (ctdefs)))))))
2004 ((define-syntax-form)
2005 (let ((sym (generate-id (id-sym-name id))))
2006 (process-exports fexports
2007 (lambda ()
2008 (let ((local-label (get-indirect-label label)))
2009 (set-indirect-label! label sym)
2010 (cons
2011 (ct-eval/residualize3 ctem
2012 (lambda () (put-cte-hook sym (car (module-binding-val b))))
2013 (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
2014 (ctdefs)))))))
2015 (($module-form)
2016 (let ((sym (generate-id (id-sym-name id)))
2017 (exports (module-binding-val b)))
2018 (process-exports (append (flatten-exports exports) fexports)
2019 (lambda ()
2020 (set-indirect-label! label sym)
2021 (let ((rest (ctdefs))) ; set indirect labels before resolving
2022 (let ((x (make-binding '$module (make-resolved-interface id exports sym))))
2023 (cons (ct-eval/residualize3 ctem
2024 (lambda () (put-cte-hook sym x))
2025 (lambda () (build-cte-install sym (build-data no-source x) #f)))
2026 rest)))))))
2027 ((alias-form)
2028 (process-exports
2029 fexports
2030 (lambda ()
2031 (let ((rest (ctdefs))) ; set indirect labels before resolving
2032 (when (indirect-label? label)
2033 (unless (symbol? (get-indirect-label label))
2034 (syntax-error (module-binding-id b) "unexported target of alias")))
2035 rest))))
2036 ;*** (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
2037 (else (error "unexpected module binding type" t)))))
2038 (loop bs))))))))))))
2040 (define id-set-diff
2041 (lambda (exports defs)
2042 (cond
2043 ((null? exports) '())
2044 ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
2045 (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
2047 (define check-module-exports
2048 ; After processing the definitions of a module this is called to verify that the
2049 ; module has defined or imported each exported identifier. Because ids in fexports are
2050 ; wrapped with the given ribcage, they will contain substitutions for anything defined
2051 ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
2052 ; provide access to reexported bindings, for example.
2053 (lambda (source-exp fexports ids)
2054 (define defined?
2055 (lambda (e ids)
2056 (ormap (lambda (x)
2057 (if (import-interface? x)
2058 (let ((x.iface (import-interface-interface x))
2059 (x.new-marks (import-interface-new-marks x)))
2060 (cond
2061 ((interface-token x.iface) =>
2062 (lambda (token)
2063 (lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
2064 (else
2065 (let ((v (interface-exports x.iface)))
2066 (let lp ((i (fx- (vector-length v) 1)))
2067 (and (fx>= i 0)
2068 (or (let ((id (vector-ref v i)))
2069 (help-bound-id=?
2070 (id-sym-name id)
2071 (join-marks x.new-marks (id-marks id))
2072 (id-sym-name e) (id-marks e)))
2073 (lp (fx- i 1)))))))))
2074 (bound-id=? e x)))
2075 ids)))
2076 (let loop ((fexports fexports) (missing '()))
2077 (if (null? fexports)
2078 (unless (null? missing)
2079 (syntax-error (car missing)
2080 (if (= (length missing) 1)
2081 "missing definition for export"
2082 "missing definition for multiple exports, including")))
2083 (let ((e (car fexports)) (fexports (cdr fexports)))
2084 (if (defined? e ids)
2085 (loop fexports missing)
2086 (loop fexports (cons e missing))))))))
2088 (define check-defined-ids
2089 (lambda (source-exp ls)
2090 (define vfold
2091 (lambda (v p cls)
2092 (let ((len (vector-length v)))
2093 (let lp ((i 0) (cls cls))
2094 (if (fx= i len)
2095 cls
2096 (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
2097 (define conflicts
2098 (lambda (x y cls)
2099 (if (import-interface? x)
2100 (let ((x.iface (import-interface-interface x))
2101 (x.new-marks (import-interface-new-marks x)))
2102 (if (import-interface? y)
2103 (let ((y.iface (import-interface-interface y))
2104 (y.new-marks (import-interface-new-marks y)))
2105 (let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
2106 (if (fx> (vector-length xe) (vector-length ye))
2107 (vfold ye
2108 (lambda (id cls)
2109 (id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
2110 (vfold xe
2111 (lambda (id cls)
2112 (id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
2113 (id-iface-conflicts y '() x.iface x.new-marks cls)))
2114 (if (import-interface? y)
2115 (let ((y.iface (import-interface-interface y))
2116 (y.new-marks (import-interface-new-marks y)))
2117 (id-iface-conflicts x '() y.iface y.new-marks cls))
2118 (if (bound-id=? x y) (cons x cls) cls)))))
2119 (define id-iface-conflicts
2120 (lambda (id id.new-marks iface iface.new-marks cls)
2121 (let ((id.sym (id-sym-name id))
2122 (id.marks (join-marks id.new-marks (id-marks id))))
2123 (cond
2124 ((interface-token iface) =>
2125 (lambda (token)
2126 (if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
2127 (cons id cls)
2128 cls)))
2129 (else
2130 (vfold (interface-exports iface)
2131 (lambda (*id cls)
2132 (let ((*id.sym (id-sym-name *id))
2133 (*id.marks (join-marks iface.new-marks (id-marks *id))))
2134 (if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
2135 (cons *id cls)
2136 cls)))
2137 cls))))))
2138 (unless (null? ls)
2139 (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
2140 (if (null? ls)
2141 (unless (null? cls)
2142 (let ((cls (syntax-object->datum cls)))
2143 (syntax-error source-exp "duplicate definition for "
2144 (symbol->string (car cls))
2145 " in")))
2146 (let lp2 ((ls2 ls) (cls cls))
2147 (if (null? ls2)
2148 (lp (car ls) (cdr ls) cls)
2149 (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
2151 (define chi-external
2152 (lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
2153 (define return
2154 (lambda (r mr bindings ids inits)
2155 (check-defined-ids source-exp ids)
2156 (check-module-exports source-exp fexports ids)
2157 (values r mr bindings inits)))
2158 (define get-implicit-exports
2159 (lambda (id)
2160 (let f ((exports exports))
2161 (if (null? exports)
2162 '()
2163 (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
2164 (flatten-exports (cdar exports))
2165 (f (cdr exports)))))))
2166 (define update-imp-exports
2167 (lambda (bindings exports)
2168 (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
2169 (map (lambda (b)
2170 (let ((id (module-binding-id b)))
2171 (if (not (bound-id-member? id exports))
2172 b
2173 (create-module-binding
2174 (module-binding-type b)
2175 id
2176 (module-binding-label b)
2177 (append (get-implicit-exports id) (module-binding-imps b))
2178 (module-binding-val b)))))
2179 bindings))))
2180 (let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
2181 (if (null? body)
2182 (return r mr bindings ids inits)
2183 (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
2184 (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
2185 (case type
2186 ((define-form)
2187 (let-values (((id rhs w) (parse-define e w ae)))
2188 (let* ((id (wrap id w))
2189 (label (gen-indirect-label))
2190 (imps (get-implicit-exports id)))
2191 (extend-ribcage! ribcage id label)
2192 (cond
2193 (meta?
2194 (let* ((sym (generate-id (id-sym-name id)))
2195 (b (make-binding 'meta-variable sym)))
2196 ; add meta bindings only to meta environment
2197 (let ((mr (extend-env (get-indirect-label label) b mr)))
2198 (let ((exp (chi rhs mr mr w #t)))
2199 (define-top-level-value-hook sym (top-level-eval-hook exp))
2200 (meta-residualize!
2201 (ct-eval/residualize3 ctem
2202 void
2203 (lambda () (build-global-definition no-source sym exp))))
2204 (parse (cdr body) r mr
2205 (cons id ids)
2206 (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
2207 inits
2208 #f)))))
2209 (else
2210 (parse (cdr body) r mr
2211 (cons id ids)
2212 (cons (create-module-binding type id label
2213 imps (make-frob (wrap rhs w) meta?))
2214 bindings)
2215 inits
2216 #f))))))
2217 ((define-syntax-form)
2218 (let-values (((id rhs w) (parse-define-syntax e w ae)))
2219 (let* ((id (wrap id w))
2220 (label (gen-indirect-label))
2221 (imps (get-implicit-exports id))
2222 (exp (chi rhs mr mr w #t)))
2223 (extend-ribcage! ribcage id label)
2224 (let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
2225 (parse (cdr body)
2226 (extend-env l b r)
2227 (extend-env l b mr)
2228 (cons id ids)
2229 (cons (create-module-binding type id label imps (cons b exp))
2230 bindings)
2231 inits
2232 #f)))))
2233 (($module-form)
2234 (let* ((*ribcage (make-empty-ribcage))
2235 (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
2236 (let-values (((orig id *exports forms) (parse-module e w ae *w)))
2237 (let-values (((r mr *bindings *inits)
2238 (chi-external *ribcage orig
2239 (map (lambda (d) (make-frob d meta?)) forms)
2240 r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
2241 (let ((iface (make-unresolved-interface id *exports))
2242 (bindings (append *bindings bindings))
2243 (inits (append inits *inits))
2244 (label (gen-indirect-label))
2245 (imps (get-implicit-exports id)))
2246 (extend-ribcage! ribcage id label)
2247 (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
2248 (parse (cdr body)
2249 (extend-env l b r)
2250 (extend-env l b mr)
2251 (cons id ids)
2252 (cons (create-module-binding type id label imps *exports) bindings)
2253 inits
2254 #f)))))))
2255 (($import-form)
2256 (let-values (((orig only? mid) (parse-import e w ae)))
2257 (let ((mlabel (id-var-name mid empty-wrap)))
2258 (let ((binding (lookup mlabel r)))
2259 (case (binding-type binding)
2260 (($module)
2261 (let* ((iface (binding-value binding))
2262 (import-iface (make-import-interface iface (import-mark-delta mid iface))))
2263 (when only? (extend-ribcage-barrier! ribcage mid))
2264 (do-import! import-iface ribcage)
2265 (parse (cdr body) r mr
2266 (cons import-iface ids)
2267 (update-imp-exports bindings (vector->list (interface-exports iface)))
2268 inits
2269 #f)))
2270 ((displaced-lexical) (displaced-lexical-error mid))
2271 (else (syntax-error mid "unknown module")))))))
2272 ((alias-form)
2273 (let-values (((new-id old-id) (parse-alias e w ae)))
2274 (let* ((new-id (wrap new-id w))
2275 (label (id-var-name-loc old-id w))
2276 (imps (get-implicit-exports new-id)))
2277 (extend-ribcage! ribcage new-id label)
2278 (parse (cdr body) r mr
2279 (cons new-id ids)
2280 (cons (create-module-binding type new-id label imps #f)
2281 bindings)
2282 inits
2283 #f))))
2284 ((begin-form)
2285 (parse (let f ((forms (parse-begin e w ae #t)))
2286 (if (null? forms)
2287 (cdr body)
2288 (cons (make-frob (wrap (car forms) w) meta?)
2289 (f (cdr forms)))))
2290 r mr ids bindings inits #f))
2291 ((eval-when-form)
2292 (let-values (((when-list forms) (parse-eval-when e w ae)))
2293 (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
2294 (let f ((forms forms))
2295 (if (null? forms)
2296 (cdr body)
2297 (cons (make-frob (wrap (car forms) w) meta?)
2298 (f (cdr forms)))))
2299 (cdr body))
2300 r mr ids bindings inits #f)))
2301 ((meta-form)
2302 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
2303 (cdr body))
2304 r mr ids bindings inits #t))
2305 ((local-syntax-form)
2306 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2307 (parse (let f ((forms forms))
2308 (if (null? forms)
2309 (cdr body)
2310 (cons (make-frob (wrap (car forms) w) meta?)
2311 (f (cdr forms)))))
2312 r mr ids bindings inits #f)))
2313 (else ; found an init expression
2314 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
2315 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
2316 (if (or (null? body) (not (frob-meta? (car body))))
2317 (return r mr bindings ids (append inits body))
2318 (begin
2319 ; expand and eval meta inits for effect only
2320 (let ((x (chi-meta-frob (car body) mr)))
2321 (top-level-eval-hook x)
2322 (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
2323 (f (cdr body)))))))))))))
2325 (define vmap
2326 (lambda (fn v)
2327 (do ((i (fx- (vector-length v) 1) (fx- i 1))
2328 (ls '() (cons (fn (vector-ref v i)) ls)))
2329 ((fx< i 0) ls))))
2331 (define vfor-each
2332 (lambda (fn v)
2333 (let ((len (vector-length v)))
2334 (do ((i 0 (fx+ i 1)))
2335 ((fx= i len))
2336 (fn (vector-ref v i))))))
2338 (define do-top-import
2339 (lambda (import-only? top-ribcage mid token)
2340 ; silently treat import-only like regular import at top level
2341 (build-cte-install mid
2342 (build-data no-source
2343 (make-binding 'do-import token))
2344 (top-ribcage-key top-ribcage))))
2346 (define update-mode-set
2347 (let ((table
2348 '((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
2349 (C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
2350 (V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
2351 (R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
2352 (E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
2353 (lambda (when-list mode-set)
2354 (define remq
2355 (lambda (x ls)
2356 (if (null? ls)
2357 '()
2358 (if (eq? (car ls) x)
2359 (remq x (cdr ls))
2360 (cons (car ls) (remq x (cdr ls)))))))
2361 (remq '-
2362 (apply append
2363 (map (lambda (m)
2364 (let ((row (cdr (assq m table))))
2365 (map (lambda (s) (cdr (assq s row)))
2366 when-list)))
2367 mode-set))))))
2369 (define initial-mode-set
2370 (lambda (when-list compiling-a-file)
2371 (apply append
2372 (map (lambda (s)
2373 (if compiling-a-file
2374 (case s
2375 ((compile) '(C))
2376 ((load) '(L))
2377 ((visit) '(V))
2378 ((revisit) '(R))
2379 (else '()))
2380 (case s
2381 ((eval) '(E))
2382 (else '()))))
2383 when-list))))
2385 (define rt-eval/residualize
2386 (lambda (rtem thunk)
2387 (if (memq 'E rtem)
2388 (thunk)
2389 (let ((thunk (if (memq 'C rtem)
2390 (let ((x (thunk)))
2391 (top-level-eval-hook x)
2392 (lambda () x))
2393 thunk)))
2394 (if (memq 'V rtem)
2395 (if (or (memq 'L rtem) (memq 'R rtem))
2396 (thunk) ; visit-revisit
2397 (build-visit-only (thunk)))
2398 (if (or (memq 'L rtem) (memq 'R rtem))
2399 (build-revisit-only (thunk))
2400 (chi-void)))))))
2402 (define ct-eval/residualize2
2403 (lambda (ctem thunk)
2404 (let ((t #f))
2405 (ct-eval/residualize3 ctem
2406 (lambda ()
2407 (unless t (set! t (thunk)))
2408 (top-level-eval-hook t))
2409 (lambda () (or t (thunk)))))))
2410 (define ct-eval/residualize3
2411 (lambda (ctem eval-thunk residualize-thunk)
2412 (if (memq 'E ctem)
2413 (begin (eval-thunk) (chi-void))
2414 (begin
2415 (when (memq 'C ctem) (eval-thunk))
2416 (if (memq 'R ctem)
2417 (if (or (memq 'L ctem) (memq 'V ctem))
2418 (residualize-thunk) ; visit-revisit
2419 (build-revisit-only (residualize-thunk)))
2420 (if (or (memq 'L ctem) (memq 'V ctem))
2421 (build-visit-only (residualize-thunk))
2422 (chi-void)))))))
2424 (define chi-frobs
2425 (lambda (frob* r mr m?)
2426 (map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
2428 (define chi-meta-frob
2429 (lambda (x mr)
2430 (chi (frob-e x) mr mr empty-wrap #t)))
2432 (define chi-sequence
2433 (lambda (body r mr w ae m?)
2434 (build-sequence ae
2435 (let dobody ((body body))
2436 (if (null? body)
2437 '()
2438 (let ((first (chi (car body) r mr w m?)))
2439 (cons first (dobody (cdr body)))))))))
2441 (define chi
2442 (lambda (e r mr w m?)
2443 (let-values (((type value e w ae) (syntax-type e r w no-source #f)))
2444 (chi-expr type value e r mr w ae m?))))
2446 (define chi-expr
2447 (lambda (type value e r mr w ae m?)
2448 (case type
2449 ((lexical)
2450 (build-lexical-reference 'value ae value))
2451 ((core) (value e r mr w ae m?))
2452 ((lexical-call)
2453 (chi-application
2454 (build-lexical-reference 'fun
2455 (let ((x (car e)))
2456 (if (syntax-object? x) (syntax-object-expression x) x))
2457 value)
2458 e r mr w ae m?))
2459 ((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
2460 ((global) (build-global-reference ae value))
2461 ((meta-variable)
2462 (if m?
2463 (build-global-reference ae value)
2464 (displaced-lexical-error (source-wrap e w ae))))
2465 ((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
2466 ((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
2467 ((local-syntax-form)
2468 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2469 (chi-sequence forms r mr w ae m?)))
2470 ((eval-when-form)
2471 (let-values (((when-list forms) (parse-eval-when e w ae)))
2472 (if (memq 'eval when-list) ; mode set is implicitly (E)
2473 (chi-sequence forms r mr w ae m?)
2474 (chi-void))))
2475 ((meta-form)
2476 (syntax-error (source-wrap e w ae) "invalid context for meta definition"))
2477 ((define-form)
2478 (parse-define e w ae)
2479 (syntax-error (source-wrap e w ae) "invalid context for definition"))
2480 ((define-syntax-form)
2481 (parse-define-syntax e w ae)
2482 (syntax-error (source-wrap e w ae) "invalid context for definition"))
2483 (($module-form)
2484 (let-values (((orig id exports forms) (parse-module e w ae w)))
2485 (syntax-error orig "invalid context for definition")))
2486 (($import-form)
2487 (let-values (((orig only? mid) (parse-import e w ae)))
2488 (syntax-error orig "invalid context for definition")))
2489 ((alias-form)
2490 (parse-alias e w ae)
2491 (syntax-error (source-wrap e w ae) "invalid context for definition"))
2492 ((syntax)
2493 (syntax-error (source-wrap e w ae)
2494 "reference to pattern variable outside syntax form"))
2495 ((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
2496 (else (syntax-error (source-wrap e w ae))))))
2498 (define chi-application
2499 (lambda (x e r mr w ae m?)
2500 (syntax-case e ()
2501 ((e0 e1 ...)
2502 (build-application ae x
2503 (map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
2504 (_ (syntax-error (source-wrap e w ae))))))
2506 (define chi-set!
2507 (lambda (e r w ae rib)
2508 (syntax-case e ()
2509 ((_ id val)
2510 (id? (syntax id))
2511 (let ((n (id-var-name (syntax id) w)))
2512 (let ((b (lookup n r)))
2513 (case (binding-type b)
2514 ((macro!)
2515 (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
2516 (syntax-type (chi-macro (binding-value b)
2517 `(,(syntax set!) ,id ,val)
2518 r empty-wrap #f rib) r empty-wrap #f rib)))
2519 (else
2520 (values 'core
2521 (lambda (e r mr w ae m?)
2522 ; repeat lookup in case we were first expression (init) in
2523 ; module or lambda body. we repeat id-var-name as well,
2524 ; although this is only necessary if we allow inits to
2525 ; preced definitions
2526 (let ((val (chi (syntax val) r mr w m?))
2527 (n (id-var-name (syntax id) w)))
2528 (let ((b (lookup n r)))
2529 (case (binding-type b)
2530 ((lexical) (build-lexical-assignment ae (binding-value b) val))
2531 ((global)
2532 (let ((sym (binding-value b)))
2533 (when (read-only-binding? n)
2534 (syntax-error (source-wrap e w ae)
2535 "invalid assignment to read-only variable"))
2536 (build-global-assignment ae sym val)))
2537 ((meta-variable)
2538 (if m?
2539 (build-global-assignment ae (binding-value b) val)
2540 (displaced-lexical-error (wrap (syntax id) w))))
2541 ((displaced-lexical)
2542 (displaced-lexical-error (wrap (syntax id) w)))
2543 (else (syntax-error (source-wrap e w ae)))))))
2544 e w ae))))))
2545 (_ (syntax-error (source-wrap e w ae))))))
2547 (define chi-macro
2548 (lambda (p e r w ae rib)
2549 (define rebuild-macro-output
2550 (lambda (x m)
2551 (cond ((pair? x)
2552 (cons (rebuild-macro-output (car x) m)
2553 (rebuild-macro-output (cdr x) m)))
2554 ((syntax-object? x)
2555 (let ((w (syntax-object-wrap x)))
2556 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
2557 (make-syntax-object (syntax-object-expression x)
2558 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
2559 (make-wrap (cdr ms) (cdr s))
2560 (make-wrap (cons m ms)
2561 (if rib
2562 (cons rib (cons 'shift s))
2563 (cons 'shift s))))))))
2564 ((vector? x)
2565 (let* ((n (vector-length x)) (v (make-vector n)))
2566 (do ((i 0 (fx+ i 1)))
2567 ((fx= i n) v)
2568 (vector-set! v i
2569 (rebuild-macro-output (vector-ref x i) m)))))
2570 ((symbol? x)
2571 (syntax-error (source-wrap e w ae)
2572 "encountered raw symbol "
2573 (symbol->string x)
2574 " in output of macro"))
2575 (else x))))
2576 (rebuild-macro-output
2577 (let ((out (p (source-wrap e (anti-mark w) ae))))
2578 (if (procedure? out)
2579 (out (lambda (id)
2580 (unless (identifier? id)
2581 (syntax-error id
2582 "environment argument is not an identifier"))
2583 (lookup (id-var-name id empty-wrap) r)))
2584 out))
2585 (new-mark))))
2587 (define chi-body
2588 (lambda (body outer-form r mr w m?)
2589 (let* ((ribcage (make-empty-ribcage))
2590 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
2591 (body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
2592 (let-values (((r mr exprs ids vars vals inits)
2593 (chi-internal ribcage outer-form body r mr m?)))
2594 (when (null? exprs) (syntax-error outer-form "no expressions in body"))
2595 (build-body no-source
2596 (reverse vars) (chi-frobs (reverse vals) r mr m?)
2597 (build-sequence no-source
2598 (chi-frobs (append inits exprs) r mr m?)))))))
2600 (define chi-internal
2601 ;; In processing the forms of the body, we create a new, empty wrap.
2602 ;; This wrap is augmented (destructively) each time we discover that
2603 ;; the next form is a definition. This is done:
2604 ;;
2605 ;; (1) to allow the first nondefinition form to be a call to
2606 ;; one of the defined ids even if the id previously denoted a
2607 ;; definition keyword or keyword for a macro expanding into a
2608 ;; definition;
2609 ;; (2) to prevent subsequent definition forms (but unfortunately
2610 ;; not earlier ones) and the first nondefinition form from
2611 ;; confusing one of the bound identifiers for an auxiliary
2612 ;; keyword; and
2613 ;; (3) so that we do not need to restart the expansion of the
2614 ;; first nondefinition form, which is problematic anyway
2615 ;; since it might be the first element of a begin that we
2616 ;; have just spliced into the body (meaning if we restarted,
2617 ;; we'd really need to restart with the begin or the macro
2618 ;; call that expanded into the begin, and we'd have to give
2619 ;; up allowing (begin <defn>+ <expr>+), which is itself
2620 ;; problematic since we don't know if a begin contains only
2621 ;; definitions until we've expanded it).
2622 ;;
2623 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
2624 ;; into the body.
2625 ;;
2626 ;; outer-form is fully wrapped w/source
2627 (lambda (ribcage source-exp body r mr m?)
2628 (define return
2629 (lambda (r mr exprs ids vars vals inits)
2630 (check-defined-ids source-exp ids)
2631 (values r mr exprs ids vars vals inits)))
2632 (let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
2633 (if (null? body)
2634 (return r mr body ids vars vals inits)
2635 (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
2636 (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
2637 (case type
2638 ((define-form)
2639 (let-values (((id rhs w) (parse-define e w ae)))
2640 (let ((id (wrap id w)) (label (gen-label)))
2641 (cond
2642 (meta?
2643 (let ((sym (generate-id (id-sym-name id))))
2644 (extend-ribcage! ribcage id label)
2645 ; add meta bindings only to meta environment
2646 ; so visible only to next higher level and beyond
2647 (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
2648 (define-top-level-value-hook sym
2649 (top-level-eval-hook (chi rhs mr mr w #t)))
2650 (parse (cdr body) r mr (cons id ids) vars vals inits #f))))
2651 (else
2652 (let ((var (gen-var id)))
2653 (extend-ribcage! ribcage id label)
2654 ; add lexical bindings only to run-time environment
2655 (parse (cdr body)
2656 (extend-env label (make-binding 'lexical var) r)
2657 mr
2658 (cons id ids)
2659 (cons var vars)
2660 (cons (make-frob (wrap rhs w) meta?) vals)
2661 inits
2662 #f)))))))
2663 ((define-syntax-form)
2664 (let-values (((id rhs w) (parse-define-syntax e w ae)))
2665 (let ((id (wrap id w))
2666 (label (gen-label))
2667 (exp (chi rhs mr mr w #t)))
2668 (extend-ribcage! ribcage id label)
2669 (let ((b (defer-or-eval-transformer local-eval-hook exp)))
2670 (parse (cdr body)
2671 (extend-env label b r) (extend-env label b mr)
2672 (cons id ids) vars vals inits #f)))))
2673 (($module-form)
2674 (let* ((*ribcage (make-empty-ribcage))
2675 (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
2676 (let-values (((orig id exports forms) (parse-module e w ae *w)))
2677 (let-values (((r mr *body *ids *vars *vals *inits)
2678 (chi-internal *ribcage orig
2679 (map (lambda (d) (make-frob d meta?)) forms)
2680 r mr m?)))
2681 ; valid bound ids checked already by chi-internal
2682 (check-module-exports source-exp (flatten-exports exports) *ids)
2683 (let ((iface (make-resolved-interface id exports #f))
2684 (vars (append *vars vars))
2685 (vals (append *vals vals))
2686 (inits (append inits *inits *body))
2687 (label (gen-label)))
2688 (extend-ribcage! ribcage id label)
2689 (let ((b (make-binding '$module iface)))
2690 (parse (cdr body)
2691 (extend-env label b r) (extend-env label b mr)
2692 (cons id ids) vars vals inits #f)))))))
2693 (($import-form)
2694 (let-values (((orig only? mid) (parse-import e w ae)))
2695 (let ((mlabel (id-var-name mid empty-wrap)))
2696 (let ((binding (lookup mlabel r)))
2697 (case (binding-type binding)
2698 (($module)
2699 (let* ((iface (binding-value binding))
2700 (import-iface (make-import-interface iface (import-mark-delta mid iface))))
2701 (when only? (extend-ribcage-barrier! ribcage mid))
2702 (do-import! import-iface ribcage)
2703 (parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
2704 ((displaced-lexical) (displaced-lexical-error mid))
2705 (else (syntax-error mid "unknown module")))))))
2706 ((alias-form)
2707 (let-values (((new-id old-id) (parse-alias e w ae)))
2708 (let ((new-id (wrap new-id w)))
2709 (extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
2710 (parse (cdr body) r mr
2711 (cons new-id ids)
2712 vars
2713 vals
2714 inits
2715 #f))))
2716 ((begin-form)
2717 (parse (let f ((forms (parse-begin e w ae #t)))
2718 (if (null? forms)
2719 (cdr body)
2720 (cons (make-frob (wrap (car forms) w) meta?)
2721 (f (cdr forms)))))
2722 r mr ids vars vals inits #f))
2723 ((eval-when-form)
2724 (let-values (((when-list forms) (parse-eval-when e w ae)))
2725 (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
2726 (let f ((forms forms))
2727 (if (null? forms)
2728 (cdr body)
2729 (cons (make-frob (wrap (car forms) w) meta?)
2730 (f (cdr forms)))))
2731 (cdr body))
2732 r mr ids vars vals inits #f)))
2733 ((meta-form)
2734 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
2735 (cdr body))
2736 r mr ids vars vals inits #t))
2737 ((local-syntax-form)
2738 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2739 (parse (let f ((forms forms))
2740 (if (null? forms)
2741 (cdr body)
2742 (cons (make-frob (wrap (car forms) w) meta?)
2743 (f (cdr forms)))))
2744 r mr ids vars vals inits #f)))
2745 (else ; found a non-definition
2746 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
2747 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
2748 (if (or (null? body) (not (frob-meta? (car body))))
2749 (return r mr body ids vars vals inits)
2750 (begin
2751 ; expand meta inits for effect only
2752 (top-level-eval-hook (chi-meta-frob (car body) mr))
2753 (f (cdr body)))))))))))))
2755 (define import-mark-delta
2756 ; returns list of marks layered on top of module id beyond those
2757 ; cached in the interface
2758 (lambda (mid iface)
2759 (diff-marks (id-marks mid) (interface-marks iface))))
2761 (define lookup-import-label
2762 (lambda (id)
2763 (let ((label (id-var-name-loc id empty-wrap)))
2764 (unless label
2765 (syntax-error id "exported identifier not visible"))
2766 label)))
2768 (define do-import!
2769 (lambda (import-iface ribcage)
2770 (let ((ie (interface-exports (import-interface-interface import-iface))))
2771 (if (<= (vector-length ie) 20)
2772 (let ((new-marks (import-interface-new-marks import-iface)))
2773 (vfor-each
2774 (lambda (id)
2775 (import-extend-ribcage! ribcage new-marks id
2776 (lookup-import-label id)))
2777 ie))
2778 (extend-ribcage-subst! ribcage import-iface)))))
2780 (define parse-module
2781 (lambda (e w ae *w)
2782 (define listify
2783 (lambda (exports)
2784 (if (null? exports)
2785 '()
2786 (cons (syntax-case (car exports) ()
2787 ((ex ...) (listify (syntax (ex ...))))
2788 (x (if (id? (syntax x))
2789 (wrap (syntax x) *w)
2790 (syntax-error (source-wrap e w ae)
2791 "invalid exports list in"))))
2792 (listify (cdr exports))))))
2793 (syntax-case e ()
2794 ((_ orig mid (ex ...) form ...)
2795 (id? (syntax mid))
2796 ; id receives old wrap so it won't be confused with id of same name
2797 ; defined within the module
2798 (values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
2799 (_ (syntax-error (source-wrap e w ae))))))
2801 (define parse-import
2802 (lambda (e w ae)
2803 (syntax-case e ()
2804 ((_ orig #t mid)
2805 (id? (syntax mid))
2806 (values (syntax orig) #t (wrap (syntax mid) w)))
2807 ((_ orig #f mid)
2808 (id? (syntax mid))
2809 (values (syntax orig) #f (wrap (syntax mid) w)))
2810 (_ (syntax-error (source-wrap e w ae))))))
2812 (define parse-define
2813 (lambda (e w ae)
2814 (syntax-case e ()
2815 ((_ name val)
2816 (id? (syntax name))
2817 (values (syntax name) (syntax val) w))
2818 ((_ (name . args) e1 e2 ...)
2819 (and (id? (syntax name))
2820 (valid-bound-ids? (lambda-var-list (syntax args))))
2821 (values (wrap (syntax name) w)
2822 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
2823 empty-wrap))
2824 ((_ name)
2825 (id? (syntax name))
2826 (values (wrap (syntax name) w) (syntax (void)) empty-wrap))
2827 (_ (syntax-error (source-wrap e w ae))))))
2829 (define parse-define-syntax
2830 (lambda (e w ae)
2831 (syntax-case e ()
2832 ((_ (name id) e1 e2 ...)
2833 (and (id? (syntax name)) (id? (syntax id)))
2834 (values (wrap (syntax name) w)
2835 `(,(syntax lambda) ,(wrap (syntax (id)) w)
2836 ,@(wrap (syntax (e1 e2 ...)) w))
2837 empty-wrap))
2838 ((_ name val)
2839 (id? (syntax name))
2840 (values (syntax name) (syntax val) w))
2841 (_ (syntax-error (source-wrap e w ae))))))
2843 (define parse-meta
2844 (lambda (e w ae)
2845 (syntax-case e ()
2846 ((_ . form) (syntax form))
2847 (_ (syntax-error (source-wrap e w ae))))))
2849 (define parse-eval-when
2850 (lambda (e w ae)
2851 (syntax-case e ()
2852 ((_ (x ...) e1 e2 ...)
2853 (values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
2854 (_ (syntax-error (source-wrap e w ae))))))
2856 (define parse-alias
2857 (lambda (e w ae)
2858 (syntax-case e ()
2859 ((_ new-id old-id)
2860 (and (id? (syntax new-id)) (id? (syntax old-id)))
2861 (values (syntax new-id) (syntax old-id)))
2862 (_ (syntax-error (source-wrap e w ae))))))
2864 (define parse-begin
2865 (lambda (e w ae empty-okay?)
2866 (syntax-case e ()
2867 ((_) empty-okay? '())
2868 ((_ e1 e2 ...) (syntax (e1 e2 ...)))
2869 (_ (syntax-error (source-wrap e w ae))))))
2871 (define chi-lambda-clause
2872 (lambda (e c r mr w m?)
2873 (syntax-case c ()
2874 (((id ...) e1 e2 ...)
2875 (let ((ids (syntax (id ...))))
2876 (if (not (valid-bound-ids? ids))
2877 (syntax-error e "invalid parameter list in")
2878 (let ((labels (gen-labels ids))
2879 (new-vars (map gen-var ids)))
2880 (values
2881 new-vars
2882 (chi-body (syntax (e1 e2 ...))
2883 e
2884 (extend-var-env* labels new-vars r)
2885 mr
2886 (make-binding-wrap ids labels w)
2887 m?))))))
2888 ((ids e1 e2 ...)
2889 (let ((old-ids (lambda-var-list (syntax ids))))
2890 (if (not (valid-bound-ids? old-ids))
2891 (syntax-error e "invalid parameter list in")
2892 (let ((labels (gen-labels old-ids))
2893 (new-vars (map gen-var old-ids)))
2894 (values
2895 (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
2896 (if (null? ls1)
2897 ls2
2898 (f (cdr ls1) (cons (car ls1) ls2))))
2899 (chi-body (syntax (e1 e2 ...))
2900 e
2901 (extend-var-env* labels new-vars r)
2902 mr
2903 (make-binding-wrap old-ids labels w)
2904 m?))))))
2905 (_ (syntax-error e)))))
2907 (define chi-local-syntax
2908 (lambda (rec? e r mr w ae)
2909 (syntax-case e ()
2910 ((_ ((id val) ...) e1 e2 ...)
2911 (let ((ids (syntax (id ...))))
2912 (if (not (valid-bound-ids? ids))
2913 (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
2914 (source-wrap e w ae)
2915 "keyword")
2916 (let ((labels (gen-labels ids)))
2917 (let ((new-w (make-binding-wrap ids labels w)))
2918 (let ((b* (let ((w (if rec? new-w w)))
2919 (map (lambda (x)
2920 (defer-or-eval-transformer
2921 local-eval-hook
2922 (chi x mr mr w #t)))
2923 (syntax (val ...))))))
2924 (values
2925 (syntax (e1 e2 ...))
2926 (extend-env* labels b* r)
2927 (extend-env* labels b* mr)
2928 new-w
2929 ae)))))))
2930 (_ (syntax-error (source-wrap e w ae))))))
2932 (define chi-void
2933 (lambda ()
2934 (build-application no-source (build-primref no-source 'void) '())))
2936 (define ellipsis?
2937 (lambda (x)
2938 (and (nonsymbol-id? x)
2939 (literal-id=? x (syntax (... ...))))))
2941 ;;; data
2943 ;;; strips all annotations from potentially circular reader output.
2945 (define strip-annotation
2946 (lambda (x)
2947 (cond
2948 ((pair? x)
2949 (cons (strip-annotation (car x))
2950 (strip-annotation (cdr x))))
2951 ((annotation? x) (annotation-stripped x))
2952 (else x))))
2954 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
2955 ;;; on an annotation, strips the annotation as well.
2956 ;;; since only the head of a list is annotated by the reader, not each pair
2957 ;;; in the spine, we also check for pairs whose cars are annotated in case
2958 ;;; we've been passed the cdr of an annotated list
2960 (define strip*
2961 (lambda (x w fn)
2962 (if (top-marked? w)
2963 (fn x)
2964 (let f ((x x))
2965 (cond
2966 ((syntax-object? x)
2967 (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
2968 ((pair? x)
2969 (let ((a (f (car x))) (d (f (cdr x))))
2970 (if (and (eq? a (car x)) (eq? d (cdr x)))
2971 x
2972 (cons a d))))
2973 ((vector? x)
2974 (let ((old (vector->list x)))
2975 (let ((new (map f old)))
2976 (if (andmap eq? old new) x (list->vector new)))))
2977 (else x))))))
2979 (define strip
2980 (lambda (x w)
2981 (strip* x w
2982 (lambda (x)
2983 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
2984 (strip-annotation x)
2985 x)))))
2987 ;;; lexical variables
2989 (define gen-var
2990 (lambda (id)
2991 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
2992 (if (annotation? id)
2993 (build-lexical-var id (annotation-expression id))
2994 (build-lexical-var id id)))))
2996 (define lambda-var-list
2997 (lambda (vars)
2998 (let lvl ((vars vars) (ls '()) (w empty-wrap))
2999 (cond
3000 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
3001 ((id? vars) (cons (wrap vars w) ls))
3002 ((null? vars) ls)
3003 ((syntax-object? vars)
3004 (lvl (syntax-object-expression vars)
3005 ls
3006 (join-wraps w (syntax-object-wrap vars))))
3007 ((annotation? vars)
3008 (lvl (annotation-expression vars) ls w))
3009 ; include anything else to be caught by subsequent error
3010 ; checking
3011 (else (cons vars ls))))))
3014 ; must precede global-extends
3016 (set! $sc-put-cte
3017 (lambda (id b top-token)
3018 (define sc-put-module
3019 (lambda (exports token new-marks)
3020 (vfor-each
3021 (lambda (id) (store-import-binding id token new-marks))
3022 exports)))
3023 (define (put-cte id binding token)
3024 (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
3025 (store-import-binding id token '())
3026 (put-global-definition-hook sym
3027 ; global binding is assumed; if global pass #f to remove existing binding, if any
3028 (if (and (eq? (binding-type binding) 'global)
3029 (eq? (binding-value binding) sym))
3030 #f
3031 binding))))
3032 (let ((binding (make-transformer-binding b)))
3033 (case (binding-type binding)
3034 (($module)
3035 (let ((iface (binding-value binding)))
3036 (sc-put-module (interface-exports iface) (interface-token iface) '()))
3037 (put-cte id binding top-token))
3038 ((do-alias) (store-import-binding id top-token '()))
3039 ((do-import)
3040 ; fake binding: id is module id binding-value is token
3041 (let ((token (binding-value b)))
3042 (let ((b (lookup (id-var-name id empty-wrap) null-env)))
3043 (case (binding-type b)
3044 (($module)
3045 (let* ((iface (binding-value b))
3046 (exports (interface-exports iface)))
3047 (unless (eq? (interface-token iface) token)
3048 (syntax-error id "import mismatch for module"))
3049 (sc-put-module (interface-exports iface) top-token
3050 (import-mark-delta id iface))))
3051 (else (syntax-error id "unknown module"))))))
3052 (else (put-cte id binding top-token))))
3053 ))
3056 ;;; core transformers
3058 ;*** These special forms are handled by Gambit, so pass them through
3060 (global-extend 'core '##c-define-type
3061 (lambda (e r mr w ae m?)
3062 (attach-source ae (strip e w))))
3064 (global-extend 'core '##c-declare
3065 (lambda (e r mr w ae m?)
3066 (attach-source ae (strip e w))))
3068 (global-extend 'core '##c-initialize
3069 (lambda (e r mr w ae m?)
3070 (attach-source ae (strip e w))))
3072 (global-extend 'core '##c-lambda
3073 (lambda (e r mr w ae m?)
3074 (attach-source ae (strip e w))))
3076 (global-extend 'core '##c-define
3077 (lambda (e r mr w ae m?)
3078 (attach-source ae (strip e w))))
3080 (global-extend 'core '##define
3081 (lambda (e r mr w ae m?)
3082 (attach-source ae (strip e w))))
3084 (global-extend 'core '##define-macro
3085 (lambda (e r mr w ae m?)
3086 (attach-source ae (strip e w))))
3088 (global-extend 'core '##define-syntax
3089 (lambda (e r mr w ae m?)
3090 (attach-source ae (strip e w))))
3092 (global-extend 'core '##include
3093 (lambda (e r mr w ae m?)
3094 (attach-source ae (strip e w))))
3096 (global-extend 'core '##declare
3097 (lambda (e r mr w ae m?)
3098 (attach-source ae (strip e w))))
3100 (global-extend 'core '##namespace
3101 (lambda (e r mr w ae m?)
3102 (attach-source ae (strip e w))))
3105 (global-extend 'local-syntax 'letrec-syntax #t)
3106 (global-extend 'local-syntax 'let-syntax #f)
3109 (global-extend 'core 'fluid-let-syntax
3110 (lambda (e r mr w ae m?)
3111 (syntax-case e ()
3112 ((_ ((var val) ...) e1 e2 ...)
3113 (valid-bound-ids? (syntax (var ...)))
3114 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
3115 (for-each
3116 (lambda (id n)
3117 (case (binding-type (lookup n r))
3118 ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
3119 (syntax (var ...))
3120 names)
3121 (let ((b* (map (lambda (x)
3122 (defer-or-eval-transformer
3123 local-eval-hook
3124 (chi x mr mr w #t)))
3125 (syntax (val ...)))))
3126 (chi-body
3127 (syntax (e1 e2 ...))
3128 (source-wrap e w ae)
3129 (extend-env* names b* r)
3130 (extend-env* names b* mr)
3131 w
3132 m?))))
3133 (_ (syntax-error (source-wrap e w ae))))))
3135 (global-extend 'core 'quote
3136 (lambda (e r mr w ae m?)
3137 (syntax-case e ()
3138 ((_ e) (build-data ae (strip (syntax e) w)))
3139 (_ (syntax-error (source-wrap e w ae))))))
3141 (global-extend 'core 'syntax
3142 (let ()
3143 (define gen-syntax
3144 (lambda (src e r maps ellipsis? vec?)
3145 (if (id? e)
3146 (let ((label (id-var-name e empty-wrap)))
3147 (let ((b (lookup label r)))
3148 (if (eq? (binding-type b) 'syntax)
3149 (let-values (((var maps)
3150 (let ((var.lev (binding-value b)))
3151 (gen-ref src (car var.lev) (cdr var.lev) maps))))
3152 (values `(ref ,var) maps))
3153 (if (ellipsis? e)
3154 (syntax-error src "misplaced ellipsis in syntax form")
3155 (values `(quote ,e) maps)))))
3156 (syntax-case e ()
3157 ((dots e)
3158 (ellipsis? (syntax dots))
3159 (if vec?
3160 (syntax-error src "misplaced ellipsis in syntax template")
3161 (gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
3162 ((x dots . y)
3163 ; this could be about a dozen lines of code, except that we
3164 ; choose to handle (syntax (x ... ...)) forms
3165 (ellipsis? (syntax dots))
3166 (let f ((y (syntax y))
3167 (k (lambda (maps)
3168 (let-values (((x maps)
3169 (gen-syntax src (syntax x) r
3170 (cons '() maps) ellipsis? #f)))
3171 (if (null? (car maps))
3172 (syntax-error src
3173 "extra ellipsis in syntax form")
3174 (values (gen-map x (car maps))
3175 (cdr maps)))))))
3176 (syntax-case y ()
3177 ((dots . y)
3178 (ellipsis? (syntax dots))
3179 (f (syntax y)
3180 (lambda (maps)
3181 (let-values (((x maps) (k (cons '() maps))))
3182 (if (null? (car maps))
3183 (syntax-error src
3184 "extra ellipsis in syntax form")
3185 (values (gen-mappend x (car maps))
3186 (cdr maps)))))))
3187 (_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
3188 (let-values (((x maps) (k maps)))
3189 (values (gen-append x y) maps)))))))
3190 ((x . y)
3191 (let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
3192 (let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
3193 (values (gen-cons e (syntax x) (syntax y) xnew ynew)
3194 maps))))
3195 (#(x1 x2 ...)
3196 (let ((ls (syntax (x1 x2 ...))))
3197 (let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
3198 (values (gen-vector e ls lsnew) maps))))
3199 (_ (values `(quote ,e) maps))))))
3201 (define gen-ref
3202 (lambda (src var level maps)
3203 (if (fx= level 0)
3204 (values var maps)
3205 (if (null? maps)
3206 (syntax-error src "missing ellipsis in syntax form")
3207 (let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
3208 (let ((b (assq outer-var (car maps))))
3209 (if b
3210 (values (cdr b) maps)
3211 (let ((inner-var (gen-var 'tmp)))
3212 (values inner-var
3213 (cons (cons (cons outer-var inner-var)
3214 (car maps))
3215 outer-maps))))))))))
3217 (define gen-append
3218 (lambda (x y)
3219 (if (equal? y '(quote ()))
3220 x
3221 `(append ,x ,y))))
3223 (define gen-mappend
3224 (lambda (e map-env)
3225 `(apply (primitive append) ,(gen-map e map-env))))
3227 (define gen-map
3228 (lambda (e map-env)
3229 (let ((formals (map cdr map-env))
3230 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
3231 (cond
3232 ((eq? (car e) 'ref)
3233 ; identity map equivalence:
3234 ; (map (lambda (x) x) y) == y
3235 (car actuals))
3236 ((andmap
3237 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
3238 (cdr e))
3239 ; eta map equivalence:
3240 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
3241 `(map (primitive ,(car e))
3242 ,@(map (let ((r (map cons formals actuals)))
3243 (lambda (x) (cdr (assq (cadr x) r))))
3244 (cdr e))))
3245 (else `(map (lambda ,formals ,e) ,@actuals))))))
3247 ; 12/12/00: semantic change: we now return original syntax object (e)
3248 ; if no pattern variables were found within, to avoid dropping
3249 ; source annotations prematurely. the "syntax returns lists" for
3250 ; lists in its input guarantee counts only for substructure that
3251 ; contains pattern variables
3252 (define gen-cons
3253 (lambda (e x y xnew ynew)
3254 (case (car ynew)
3255 ((quote)
3256 (if (eq? (car xnew) 'quote)
3257 (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
3258 (if (and (eq? xnew x) (eq? ynew y))
3259 `',e
3260 `'(,xnew . ,ynew)))
3261 (if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
3262 ((list) `(list ,xnew ,@(cdr ynew)))
3263 (else `(cons ,xnew ,ynew)))))
3265 (define gen-vector
3266 (lambda (e ls lsnew)
3267 (cond
3268 ((eq? (car lsnew) 'quote)
3269 (if (eq? (cadr lsnew) ls)
3270 `',e
3271 `(quote #(,@(cadr lsnew)))))
3272 ((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
3273 (else `(list->vector ,lsnew)))))
3276 (define regen
3277 (lambda (x)
3278 (case (car x)
3279 ((ref) (build-lexical-reference 'value no-source (cadr x)))
3280 ((primitive) (build-primref no-source (cadr x)))
3281 ((quote) (build-data no-source (cadr x)))
3282 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
3283 ((map) (let ((ls (map regen (cdr x))))
3284 (build-application no-source
3285 (if (fx= (length ls) 2)
3286 (build-primref no-source 'map)
3287 ; really need to do our own checking here
3288 (build-primref no-source 2 'map)) ; require error check
3289 ls)))
3290 (else (build-application no-source
3291 (build-primref no-source (car x))
3292 (map regen (cdr x)))))))
3294 (lambda (e r mr w ae m?)
3295 (let ((e (source-wrap e w ae)))
3296 (syntax-case e ()
3297 ((_ x)
3298 (let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
3299 (regen e)))
3300 (_ (syntax-error e)))))))
3303 (global-extend 'core 'lambda
3304 (lambda (e r mr w ae m?)
3305 (syntax-case e ()
3306 ((_ . c)
3307 (let-values (((vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r mr w m?)))
3308 (build-lambda ae vars body))))))
3311 (global-extend 'core 'letrec
3312 (lambda (e r mr w ae m?)
3313 (syntax-case e ()
3314 ((_ ((id val) ...) e1 e2 ...)
3315 (let ((ids (syntax (id ...))))
3316 (if (not (valid-bound-ids? ids))
3317 (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
3318 (source-wrap e w ae) "bound variable")
3319 (let ((labels (gen-labels ids))
3320 (new-vars (map gen-var ids)))
3321 (let ((w (make-binding-wrap ids labels w))
3322 (r (extend-var-env* labels new-vars r)))
3323 (build-letrec ae
3324 new-vars
3325 (map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
3326 (chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
3327 (_ (syntax-error (source-wrap e w ae))))))
3330 (global-extend 'core 'if
3331 (lambda (e r mr w ae m?)
3332 (syntax-case e ()
3333 ((_ test then)
3334 (build-conditional ae
3335 (chi (syntax test) r mr w m?)
3336 (chi (syntax then) r mr w m?)
3337 (chi-void)))
3338 ((_ test then else)
3339 (build-conditional ae
3340 (chi (syntax test) r mr w m?)
3341 (chi (syntax then) r mr w m?)
3342 (chi (syntax else) r mr w m?)))
3343 (_ (syntax-error (source-wrap e w ae))))))
3347 (global-extend 'set! 'set! '())
3349 (global-extend 'alias 'alias '())
3350 (global-extend 'begin 'begin '())
3352 (global-extend '$module-key '$module '())
3353 (global-extend '$import '$import '())
3355 (global-extend 'define 'define '())
3357 (global-extend 'define-syntax 'define-syntax '())
3359 (global-extend 'eval-when 'eval-when '())
3361 (global-extend 'meta 'meta '())
3363 (global-extend 'core 'syntax-case
3364 (let ()
3365 (define convert-pattern
3366 ; accepts pattern & keys
3367 ; returns syntax-dispatch pattern & ids
3368 (lambda (pattern keys)
3369 (define cvt*
3370 (lambda (p* n ids)
3371 (if (null? p*)
3372 (values '() ids)
3373 (let-values (((y ids) (cvt* (cdr p*) n ids)))
3374 (let-values (((x ids) (cvt (car p*) n ids)))
3375 (values (cons x y) ids))))))
3376 (define cvt
3377 (lambda (p n ids)
3378 (if (id? p)
3379 (if (bound-id-member? p keys)
3380 (values (vector 'free-id p) ids)
3381 (values 'any (cons (cons p n) ids)))
3382 (syntax-case p ()
3383 ((x dots)
3384 (ellipsis? (syntax dots))
3385 (let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
3386 (values (if (eq? p 'any) 'each-any (vector 'each p))
3387 ids)))
3388 ((x dots y ... . z)
3389 (ellipsis? (syntax dots))
3390 (let-values (((z ids) (cvt (syntax z) n ids)))
3391 (let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
3392 (let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
3393 (values `#(each+ ,x ,(reverse y) ,z) ids)))))
3394 ((x . y)
3395 (let-values (((y ids) (cvt (syntax y) n ids)))
3396 (let-values (((x ids) (cvt (syntax x) n ids)))
3397 (values (cons x y) ids))))
3398 (() (values '() ids))
3399 (#(x ...)
3400 (let-values (((p ids) (cvt (syntax (x ...)) n ids)))
3401 (values (vector 'vector p) ids)))
3402 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
3403 (cvt pattern 0 '())))
3405 (define build-dispatch-call
3406 (lambda (pvars exp y r mr m?)
3407 (let ((ids (map car pvars)) (levels (map cdr pvars)))
3408 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
3409 (build-application no-source
3410 (build-primref no-source 'apply)
3411 (list (build-lambda no-source new-vars
3412 (chi exp
3413 (extend-env*
3414 labels
3415 (map (lambda (var level)
3416 (make-binding 'syntax `(,var . ,level)))
3417 new-vars
3418 (map cdr pvars))
3419 r)
3420 mr
3421 (make-binding-wrap ids labels empty-wrap)
3422 m?))
3423 y))))))
3425 (define gen-clause
3426 (lambda (x keys clauses r mr m? pat fender exp)
3427 (let-values (((p pvars) (convert-pattern pat keys)))
3428 (cond
3429 ((not (distinct-bound-ids? (map car pvars)))
3430 (invalid-ids-error (map car pvars) pat "pattern variable"))
3431 ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
3432 (syntax-error pat
3433 "misplaced ellipsis in syntax-case pattern"))
3434 (else
3435 (let ((y (gen-var 'tmp)))
3436 ; fat finger binding and references to temp variable y
3437 (build-application no-source
3438 (build-lambda no-source (list y)
3439 (let-syntax ((y (identifier-syntax
3440 (build-lexical-reference 'value no-source y))))
3441 (build-conditional no-source
3442 (syntax-case fender ()
3443 (#t y)
3444 (_ (build-conditional no-source
3445 y
3446 (build-dispatch-call pvars fender y r mr m?)
3447 (build-data no-source #f))))
3448 (build-dispatch-call pvars exp y r mr m?)
3449 (gen-syntax-case x keys clauses r mr m?))))
3450 (list (if (eq? p 'any)
3451 (build-application no-source
3452 (build-primref no-source 'list)
3453 (list (build-lexical-reference no-source 'value x)))
3454 (build-application no-source
3455 (build-primref no-source '$syntax-dispatch)
3456 (list (build-lexical-reference no-source 'value x)
3457 (build-data no-source p))))))))))))
3459 (define gen-syntax-case
3460 (lambda (x keys clauses r mr m?)
3461 (if (null? clauses)
3462 (build-application no-source
3463 (build-primref no-source 'syntax-error)
3464 (list (build-lexical-reference 'value no-source x)))
3465 (syntax-case (car clauses) ()
3466 ((pat exp)
3467 (if (and (id? (syntax pat))
3468 (not (bound-id-member? (syntax pat) keys))
3469 (not (ellipsis? (syntax pat))))
3470 (let ((label (gen-label))
3471 (var (gen-var (syntax pat))))
3472 (build-application no-source
3473 (build-lambda no-source (list var)
3474 (chi (syntax exp)
3475 (extend-env label (make-binding 'syntax `(,var . 0)) r)
3476 mr
3477 (make-binding-wrap (syntax (pat))
3478 (list label) empty-wrap)
3479 m?))
3480 (list (build-lexical-reference 'value no-source x))))
3481 (gen-clause x keys (cdr clauses) r mr m?
3482 (syntax pat) #t (syntax exp))))
3483 ((pat fender exp)
3484 (gen-clause x keys (cdr clauses) r mr m?
3485 (syntax pat) (syntax fender) (syntax exp)))
3486 (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
3488 (lambda (e r mr w ae m?)
3489 (let ((e (source-wrap e w ae)))
3490 (syntax-case e ()
3491 ((_ val (key ...) m ...)
3492 (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
3493 (syntax (key ...)))
3494 (let ((x (gen-var 'tmp)))
3495 ; fat finger binding and references to temp variable x
3496 (build-application ae
3497 (build-lambda no-source (list x)
3498 (gen-syntax-case x
3499 (syntax (key ...)) (syntax (m ...))
3500 r mr m?))
3501 (list (chi (syntax val) r mr empty-wrap m?))))
3502 (syntax-error e "invalid literals list in"))))))))
3504 (put-cte-hook 'module
3505 (lambda (x)
3506 (define proper-export?
3507 (lambda (e)
3508 (syntax-case e ()
3509 ((id e ...)
3510 (and (identifier? (syntax id))
3511 (andmap proper-export? (syntax (e ...)))))
3512 (id (identifier? (syntax id))))))
3513 (with-syntax ((orig x))
3514 (syntax-case x ()
3515 ((_ (e ...) d ...)
3516 (if (andmap proper-export? (syntax (e ...)))
3517 (syntax (begin ($module orig anon (e ...) d ...) ($import orig #f anon)))
3518 (syntax-error x "invalid exports list in")))
3519 ((_ m (e ...) d ...)
3520 (identifier? (syntax m))
3521 (if (andmap proper-export? (syntax (e ...)))
3522 (syntax ($module orig m (e ...) d ...))
3523 (syntax-error x "invalid exports list in")))))))
3525 (let ()
3526 (define $module-exports
3527 (lambda (m r)
3528 (let ((b (r m)))
3529 (case (binding-type b)
3530 (($module)
3531 (let* ((interface (binding-value b))
3532 (new-marks (import-mark-delta m interface)))
3533 (vmap (lambda (x)
3534 (let ((id (if (pair? x) (car x) x)))
3535 (make-syntax-object
3536 (syntax-object->datum id)
3537 (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
3538 (make-wrap marks
3539 ; the anti mark should always be present at the head
3540 ; of new-marks, but we paranoically check anyway
3541 (if (eq? (car marks) the-anti-mark)
3542 (cons 'shift (wrap-subst top-wrap))
3543 (wrap-subst top-wrap)))))))
3544 (interface-exports interface))))
3545 ((displaced-lexical) (displaced-lexical-error m))
3546 (else (syntax-error m "unknown module"))))))
3547 (define $import-help
3548 (lambda (orig import-only?)
3549 (lambda (r)
3550 (define difference
3551 (lambda (ls1 ls2)
3552 (if (null? ls1)
3553 ls1
3554 (if (bound-id-member? (car ls1) ls2)
3555 (difference (cdr ls1) ls2)
3556 (cons (car ls1) (difference (cdr ls1) ls2))))))
3557 (define prefix-add
3558 (lambda (prefix-id)
3559 (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
3560 (lambda (id)
3561 (datum->syntax-object id
3562 (string->symbol
3563 (string-append prefix
3564 (symbol->string (syntax-object->datum id)))))))))
3565 (define prefix-drop
3566 (lambda (prefix-id)
3567 (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
3568 (lambda (id)
3569 (let ((s (symbol->string (syntax-object->datum id))))
3570 (let ((np (string-length prefix)) (ns (string-length s)))
3571 (unless (and (>= ns np) (string=? (substring s 0 np) prefix))
3572 (syntax-error id (string-append "missing expected prefix " prefix)))
3573 (datum->syntax-object id
3574 (string->symbol (substring s np ns)))))))))
3575 (define gen-mid
3576 (lambda (mid)
3577 ; introduced module ids must have same marks as original
3578 ; for import-only, since the barrier carries the marks of
3579 ; the module id
3580 (datum->syntax-object mid (generate-id (id-sym-name mid)))))
3581 (define (modspec m exports?)
3582 (with-syntax ((orig orig) (import-only? import-only?))
3583 (syntax-case m (only-for-syntax also-for-syntax
3584 only except
3585 add-prefix drop-prefix rename alias)
3586 ((only m id ...)
3587 (andmap identifier? (syntax (id ...)))
3588 (let-values (((mid d exports) (modspec (syntax m) #f)))
3589 (with-syntax ((d d) (tmid (gen-mid mid)))
3590 (values mid
3591 (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
3592 (and exports? (syntax (id ...)))))))
3593 ((except m id ...)
3594 (andmap identifier? (syntax (id ...)))
3595 (let-values (((mid d exports) (modspec (syntax m) #t)))
3596 (with-syntax ((d d)
3597 (tmid (gen-mid mid))
3598 ((id ...) (difference exports (syntax (id ...)))))
3599 (values mid
3600 (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
3601 (and exports? (syntax (id ...)))))))
3602 ((add-prefix m prefix-id)
3603 (identifier? (syntax prefix-id))
3604 (let-values (((mid d exports) (modspec (syntax m) #t)))
3605 (with-syntax ((d d)
3606 (tmid (gen-mid mid))
3607 ((old-id ...) exports)
3608 ((tmp ...) (generate-temporaries exports))
3609 ((id ...) (map (prefix-add (syntax prefix-id)) exports)))
3610 (values mid
3611 (syntax (begin ($module orig tmid ((id tmp) ...)
3612 ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
3613 ($import orig import-only? tmid)
3614 (alias id tmp) ...)
3615 ($import orig import-only? tmid)))
3616 (and exports? (syntax (id ...)))))))
3617 ((drop-prefix m prefix-id)
3618 (identifier? (syntax prefix-id))
3619 (let-values (((mid d exports) (modspec (syntax m) #t)))
3620 (with-syntax ((d d)
3621 (tmid (gen-mid mid))
3622 ((old-id ...) exports)
3623 ((tmp ...) (generate-temporaries exports))
3624 ((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
3625 (values mid
3626 (syntax (begin ($module orig tmid ((id tmp) ...)
3627 ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
3628 ($import orig import-only? tmid)
3629 (alias id tmp) ...)
3630 ($import orig import-only? tmid)))
3631 (and exports? (syntax (id ...)))))))
3632 ((rename m (new-id old-id) ...)
3633 (and (andmap identifier? (syntax (new-id ...)))
3634 (andmap identifier? (syntax (old-id ...))))
3635 (let-values (((mid d exports) (modspec (syntax m) #t)))
3636 (with-syntax ((d d)
3637 (tmid (gen-mid mid))
3638 ((tmp ...) (generate-temporaries (syntax (old-id ...))))
3639 ((other-id ...) (difference exports (syntax (old-id ...)))))
3640 (values mid
3641 (syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
3642 ($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
3643 ($import orig import-only? tmid)
3644 (alias new-id tmp) ...)
3645 ($import orig import-only? tmid)))
3646 (and exports? (syntax (new-id ... other-id ...)))))))
3647 ((alias m (new-id old-id) ...)
3648 (and (andmap identifier? (syntax (new-id ...)))
3649 (andmap identifier? (syntax (old-id ...))))
3650 (let-values (((mid d exports) (modspec (syntax m) #t)))
3651 (with-syntax ((d d)
3652 (tmid (gen-mid mid))
3653 ((other-id ...) exports))
3654 (values mid
3655 (syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
3656 ($import orig import-only? tmid)))
3657 (and exports? (syntax (new-id ... other-id ...)))))))
3658 ; base cases
3659 (mid
3660 (identifier? (syntax mid))
3661 (values (syntax mid)
3662 (syntax ($import orig import-only? mid))
3663 (and exports? ($module-exports (syntax mid) r))))
3664 ((mid)
3665 (identifier? (syntax mid))
3666 (values (syntax mid)
3667 (syntax ($import orig import-only? mid))
3668 (and exports? ($module-exports (syntax mid) r))))
3669 (_ (syntax-error m "invalid module specifier")))))
3670 (define modspec*
3671 (lambda (m)
3672 (let-values (((mid d exports) (modspec m #f))) d)))
3673 (syntax-case orig ()
3674 ((_ m ...)
3675 (with-syntax (((d ...) (map modspec* (syntax (m ...)))))
3676 (syntax (begin d ...))))))))
3678 (put-cte-hook 'import
3679 (lambda (orig)
3680 ($import-help orig #f)))
3682 (put-cte-hook 'import-only
3683 (lambda (orig)
3684 ($import-help orig #t)))
3685 )
3687 ;;; To support eval-when, we maintain two mode sets:
3688 ;;;
3689 ;;; ctem (compile-time-expression mode)
3690 ;;; determines whether/when to evaluate compile-time expressions such
3691 ;;; as macro definitions, module definitions, and compile-time
3692 ;;; registration of variable definitions
3693 ;;;
3694 ;;; rtem (run-time-expression mode)
3695 ;;; determines whether/when to evaluate run-time expressions such
3696 ;;; as the actual assignment performed by a variable definition or
3697 ;;; arbitrary top-level expressions
3699 ;;; Possible modes in the mode set are:
3700 ;;;
3701 ;;; L (load): evaluate at load time. implies V for compile-time
3702 ;;; expressions and R for run-time expressions.
3703 ;;;
3704 ;;; C (compile): evaluate at compile (file) time
3705 ;;;
3706 ;;; E (eval): evaluate at evaluation (compile or interpret) time
3707 ;;;
3708 ;;; V (visit): evaluate at visit time
3709 ;;;
3710 ;;; R (revisit): evaluate at revisit time
3712 ;;; The mode set for the body of an eval-when is determined by
3713 ;;; translating each mode in the old mode set based on the situations
3714 ;;; present in the eval-when form and combining these into a set,
3715 ;;; using the following table. See also update-mode-set.
3717 ;;; load compile visit revisit eval
3718 ;;;
3719 ;;; L L C V R -
3720 ;;;
3721 ;;; C - - - - C
3722 ;;;
3723 ;;; V V C V - -
3724 ;;;
3725 ;;; R R C - R -
3726 ;;;
3727 ;;; E - - - - E
3729 ;;; When we complete the expansion of a compile or run-time expression,
3730 ;;; the current ctem or rtem determines how the expression will be
3731 ;;; treated. See ct-eval/residualize and rt-eval/residualize.
3733 ;;; Initial mode sets
3734 ;;;
3735 ;;; when compiling a file:
3736 ;;;
3737 ;;; initial ctem: (L C)
3738 ;;;
3739 ;;; initial rtem: (L)
3740 ;;;
3741 ;;; when not compiling a file:
3742 ;;;
3743 ;;; initial ctem: (E)
3744 ;;;
3745 ;;; initial rtem: (E)
3746 ;;;
3747 ;;;
3748 ;;; This means that top-level syntactic definitions are evaluated
3749 ;;; immediately after they are expanded, and the expanded definitions
3750 ;;; are also residualized into the object file if we are compiling
3751 ;;; a file.
3753 (set! sc-expand
3754 (let ((ctem '(E)) (rtem '(E)))
3755 (lambda (x)
3756 (let ((env (interaction-environment)))
3757 (if (and (pair? x) (equal? (car x) noexpand))
3758 (cadr x)
3759 (chi-top* x null-env
3760 (env-wrap env)
3761 ctem rtem #f
3762 (env-top-ribcage env)))))))
3766 (set! $make-environment
3767 (lambda (token mutable?)
3768 (let ((top-ribcage (make-top-ribcage token mutable?)))
3769 (make-env
3770 top-ribcage
3771 (make-wrap
3772 (wrap-marks top-wrap)
3773 (cons top-ribcage (wrap-subst top-wrap)))))))
3775 (set! environment?
3776 (lambda (x)
3777 (env? x)))
3781 (set! interaction-environment
3782 (let ((e ($make-environment '*top* #t)))
3783 (lambda () e)))
3785 (set! identifier?
3786 (lambda (x)
3787 (nonsymbol-id? x)))
3789 (set! datum->syntax-object
3790 (lambda (id datum)
3791 (arg-check nonsymbol-id? id 'datum->syntax-object)
3792 (make-syntax-object
3793 datum
3794 (syntax-object-wrap id))))
3796 (set! syntax->list
3797 (lambda (orig-ls)
3798 (let f ((ls orig-ls))
3799 (syntax-case ls ()
3800 (() '())
3801 ((x . r) (cons #'x (f #'r)))
3802 ;*** (_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
3803 (_ (error "(in syntax->list) invalid argument" orig-ls))))))
3805 (set! syntax->vector
3806 (lambda (v)
3807 (syntax-case v ()
3808 ;*** (#(x ...) (apply vector (syntax->list #'(x ...))))
3809 ;*** (_ (error 'syntax->vector "invalid argument ~s" v)))))
3810 (#(x ...) (list->vector (syntax->list #'(x ...))))
3811 (_ (error "(in syntax->vector) invalid argument" v)))))
3813 (set! syntax-object->datum
3814 ; accepts any object, since syntax objects may consist partially
3815 ; or entirely of unwrapped, nonsymbolic data
3816 (lambda (x)
3817 (strip x empty-wrap)))
3819 (set! generate-temporaries
3820 (let ((n 0))
3821 (lambda (ls)
3822 (arg-check list? ls 'generate-temporaries)
3823 (map (lambda (x)
3824 (set! n (+ n 1))
3825 (wrap
3826 ; unique name to distinguish from other temporaries
3827 (string->symbol (string-append "t" (number->string n)))
3828 ; unique mark (in tmp-wrap) to distinguish from non-temporaries
3829 tmp-wrap))
3830 ls))))
3832 (set! free-identifier=?
3833 (lambda (x y)
3834 (arg-check nonsymbol-id? x 'free-identifier=?)
3835 (arg-check nonsymbol-id? y 'free-identifier=?)
3836 (free-id=? x y)))
3838 (set! bound-identifier=?
3839 (lambda (x y)
3840 (arg-check nonsymbol-id? x 'bound-identifier=?)
3841 (arg-check nonsymbol-id? y 'bound-identifier=?)
3842 (bound-id=? x y)))
3844 (set! literal-identifier=?
3845 (lambda (x y)
3846 (arg-check nonsymbol-id? x 'literal-identifier=?)
3847 (arg-check nonsymbol-id? y 'literal-identifier=?)
3848 (literal-id=? x y)))
3850 (set! syntax-error
3851 (lambda (object . messages)
3852 (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
3853 (let ((message (if (null? messages)
3854 "invalid syntax"
3855 (apply string-append messages))))
3856 ;*** (error-hook #f message (strip object empty-wrap)))))
3857 (error message (strip object empty-wrap)))))
3859 ;;; syntax-dispatch expects an expression and a pattern. If the expression
3860 ;;; matches the pattern a list of the matching expressions for each
3861 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
3862 ;;; not work on r4rs implementations that violate the ieee requirement
3863 ;;; that #f and () be distinct.)
3865 ;;; The expression is matched with the pattern as follows:
3867 ;;; p in pattern: matches:
3868 ;;; () empty list
3869 ;;; any anything
3870 ;;; (p1 . p2) pair (list)
3871 ;;; #(free-id <key>) <key> with literal-identifier=?
3872 ;;; each-any any proper list
3873 ;;; #(each p) (p*)
3874 ;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3)
3875 ;;; #(vector p) (list->vector p)
3876 ;;; #(atom <object>) <object> with "equal?"
3878 ;;; Vector cops out to pair under assumption that vectors are rare. If
3879 ;;; not, should convert to:
3880 ;;; #(vector p) #(p*)
3882 (let ()
3884 (define match-each
3885 (lambda (e p w)
3886 (cond
3887 ((annotation? e)
3888 (match-each (annotation-expression e) p w))
3889 ((pair? e)
3890 (let ((first (match (car e) p w '())))
3891 (and first
3892 (let ((rest (match-each (cdr e) p w)))
3893 (and rest (cons first rest))))))
3894 ((null? e) '())
3895 ((syntax-object? e)
3896 (match-each (syntax-object-expression e)
3897 p
3898 (join-wraps w (syntax-object-wrap e))))
3899 (else #f))))
3901 (define match-each+
3902 (lambda (e x-pat y-pat z-pat w r)
3903 (let f ((e e) (w w))
3904 (cond
3905 ((pair? e)
3906 (let-values (((xr* y-pat r) (f (cdr e) w)))
3907 (if r
3908 (if (null? y-pat)
3909 (let ((xr (match (car e) x-pat w '())))
3910 (if xr
3911 (values (cons xr xr*) y-pat r)
3912 (values #f #f #f)))
3913 (values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
3914 (values #f #f #f))))
3915 ((annotation? e) (f (annotation-expression e) w))
3916 ((syntax-object? e) (f (syntax-object-expression e)
3917 (join-wraps w (syntax-object-wrap e))))
3918 (else (values '() y-pat (match e z-pat w r)))))))
3920 (define match-each-any
3921 (lambda (e w)
3922 (cond
3923 ((annotation? e)
3924 (match-each-any (annotation-expression e) w))
3925 ((pair? e)
3926 (let ((l (match-each-any (cdr e) w)))
3927 (and l (cons (wrap (car e) w) l))))
3928 ((null? e) '())
3929 ((syntax-object? e)
3930 (match-each-any (syntax-object-expression e)
3931 (join-wraps w (syntax-object-wrap e))))
3932 (else #f))))
3934 (define match-empty
3935 (lambda (p r)
3936 (cond
3937 ((null? p) r)
3938 ((eq? p 'any) (cons '() r))
3939 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
3940 ((eq? p 'each-any) (cons '() r))
3941 (else
3942 (case (vector-ref p 0)
3943 ((each) (match-empty (vector-ref p 1) r))
3944 ((each+) (match-empty (vector-ref p 1)
3945 (match-empty (reverse (vector-ref p 2))
3946 (match-empty (vector-ref p 3) r))))
3947 ((free-id atom) r)
3948 ((vector) (match-empty (vector-ref p 1) r)))))))
3950 (define combine
3951 (lambda (r* r)
3952 (if (null? (car r*))
3953 r
3954 (cons (map car r*) (combine (map cdr r*) r)))))
3956 (define match*
3957 (lambda (e p w r)
3958 (cond
3959 ((null? p) (and (null? e) r))
3960 ((pair? p)
3961 (and (pair? e) (match (car e) (car p) w
3962 (match (cdr e) (cdr p) w r))))
3963 ((eq? p 'each-any)
3964 (let ((l (match-each-any e w))) (and l (cons l r))))
3965 (else
3966 (case (vector-ref p 0)
3967 ((each)
3968 (if (null? e)
3969 (match-empty (vector-ref p 1) r)
3970 (let ((r* (match-each e (vector-ref p 1) w)))
3971 (and r* (combine r* r)))))
3972 ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
3973 ((each+)
3974 (let-values (((xr* y-pat r)
3975 (match-each+ e (vector-ref p 1) (vector-ref p 2)
3976 (vector-ref p 3) w r)))
3977 (and r (null? y-pat)
3978 (if (null? xr*)
3979 (match-empty (vector-ref p 1) r)
3980 (combine xr* r)))))
3981 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
3982 ((vector)
3983 (and (vector? e)
3984 (match (vector->list e) (vector-ref p 1) w r))))))))
3986 (define match
3987 (lambda (e p w r)
3988 (cond
3989 ((not r) #f)
3990 ((eq? p 'any) (cons (wrap e w) r))
3991 ((syntax-object? e)
3992 (match*
3993 (unannotate (syntax-object-expression e))
3994 p
3995 (join-wraps w (syntax-object-wrap e))
3996 r))
3997 (else (match* (unannotate e) p w r)))))
3999 (set! $syntax-dispatch
4000 (lambda (e p)
4001 (cond
4002 ((eq? p 'any) (list e))
4003 ((syntax-object? e)
4004 (match* (unannotate (syntax-object-expression e))
4005 p (syntax-object-wrap e) '()))
4006 (else (match* (unannotate e) p empty-wrap '())))))
4007 ))
4010 (define-syntax with-syntax
4011 (lambda (x)
4012 (syntax-case x ()
4013 ((_ () e1 e2 ...)
4014 (syntax (begin e1 e2 ...)))
4015 ((_ ((out in)) e1 e2 ...)
4016 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
4017 ((_ ((out in) ...) e1 e2 ...)
4018 (syntax (syntax-case (list in ...) ()
4019 ((out ...) (begin e1 e2 ...))))))))
4021 (define-syntax with-implicit
4022 (syntax-rules ()
4023 ((_ (tid id ...) e1 e2 ...)
4024 (andmap identifier? (syntax (tid id ...)))
4025 (begin
4026 (unless (identifier? (syntax tid))
4027 (syntax-error (syntax tid) "non-identifier with-implicit template"))
4028 (with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
4029 e1 e2 ...)))))
4031 (define-syntax datum
4032 (syntax-rules ()
4033 ((_ x) (syntax-object->datum (syntax x)))))
4035 (define-syntax syntax-rules
4036 (lambda (x)
4037 (define clause
4038 (lambda (y)
4039 (syntax-case y ()
4040 (((keyword . pattern) template)
4041 (syntax ((dummy . pattern) (syntax template))))
4042 (((keyword . pattern) fender template)
4043 (syntax ((dummy . pattern) fender (syntax template))))
4044 (_ (syntax-error x)))))
4045 (syntax-case x ()
4046 ((_ (k ...) cl ...)
4047 (andmap identifier? (syntax (k ...)))
4048 (with-syntax (((cl ...) (map clause (syntax (cl ...)))))
4049 (syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
4051 (define-syntax or
4052 (lambda (x)
4053 (syntax-case x ()
4054 ((_) (syntax #f))
4055 ((_ e) (syntax e))
4056 ((_ e1 e2 e3 ...)
4057 (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
4059 (define-syntax and
4060 (lambda (x)
4061 (syntax-case x ()
4062 ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
4063 ((_ e) (syntax e))
4064 ((_) (syntax #t)))))
4066 (define-syntax let
4067 (lambda (x)
4068 (syntax-case x ()
4069 ((_ ((x v) ...) e1 e2 ...)
4070 (andmap identifier? (syntax (x ...)))
4071 (syntax ((lambda (x ...) e1 e2 ...) v ...)))
4072 ((_ f ((x v) ...) e1 e2 ...)
4073 (andmap identifier? (syntax (f x ...)))
4074 (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
4075 v ...))))))
4077 (define-syntax let*
4078 (lambda (x)
4079 (syntax-case x ()
4080 ((let* ((x v) ...) e1 e2 ...)
4081 (andmap identifier? (syntax (x ...)))
4082 (let f ((bindings (syntax ((x v) ...))))
4083 (if (null? bindings)
4084 (syntax (let () e1 e2 ...))
4085 (with-syntax ((body (f (cdr bindings)))
4086 (binding (car bindings)))
4087 (syntax (let (binding) body)))))))))
4089 (define-syntax cond
4090 (lambda (x)
4091 (syntax-case x ()
4092 ((_ m1 m2 ...)
4093 (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
4094 (if (null? clauses)
4095 (syntax-case clause (else =>)
4096 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
4097 ((e0) (syntax (let ((t e0)) (if t t))))
4098 ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
4099 ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
4100 (_ (syntax-error x)))
4101 (with-syntax ((rest (f (car clauses) (cdr clauses))))
4102 (syntax-case clause (else =>)
4103 ((e0) (syntax (let ((t e0)) (if t t rest))))
4104 ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
4105 ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
4106 (_ (syntax-error x))))))))))
4108 (define-syntax do
4109 (lambda (orig-x)
4110 (syntax-case orig-x ()
4111 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
4112 (with-syntax (((step ...)
4113 (map (lambda (v s)
4114 (syntax-case s ()
4115 (() v)
4116 ((e) (syntax e))
4117 (_ (syntax-error orig-x))))
4118 (syntax (var ...))
4119 (syntax (step ...)))))
4120 (syntax-case (syntax (e1 ...)) ()
4121 (() (syntax (let do ((var init) ...)
4122 (if (not e0)
4123 (begin c ... (do step ...))))))
4124 ((e1 e2 ...)
4125 (syntax (let do ((var init) ...)
4126 (if e0
4127 (begin e1 e2 ...)
4128 (begin c ... (do step ...))))))))))))
4130 (define-syntax quasiquote
4131 (let ()
4132 (define (quasi p lev)
4133 (syntax-case p (unquote quasiquote)
4134 ((unquote p)
4135 (if (= lev 0)
4136 #'("value" p)
4137 (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
4138 ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
4139 ((p . q)
4140 (syntax-case #'p (unquote unquote-splicing)
4141 ((unquote p ...)
4142 (if (= lev 0)
4143 (quasilist* #'(("value" p) ...) (quasi #'q lev))
4144 (quasicons
4145 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
4146 (quasi #'q lev))))
4147 ((unquote-splicing p ...)
4148 (if (= lev 0)
4149 (quasiappend #'(("value" p) ...) (quasi #'q lev))
4150 (quasicons
4151 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
4152 (quasi #'q lev))))
4153 (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
4154 (#(x ...) (quasivector (vquasi #'(x ...) lev)))
4155 (p #'("quote" p))))
4156 (define (vquasi p lev)
4157 (syntax-case p ()
4158 ((p . q)
4159 (syntax-case #'p (unquote unquote-splicing)
4160 ((unquote p ...)
4161 (if (= lev 0)
4162 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
4163 (quasicons
4164 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
4165 (vquasi #'q lev))))
4166 ((unquote-splicing p ...)
4167 (if (= lev 0)
4168 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
4169 (quasicons
4170 (quasicons
4171 #'("quote" unquote-splicing)
4172 (quasi #'(p ...) (- lev 1)))
4173 (vquasi #'q lev))))
4174 (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
4175 (() #'("quote" ()))))
4176 (define (quasicons x y)
4177 (with-syntax ((x x) (y y))
4178 (syntax-case #'y ()
4179 (("quote" dy)
4180 (syntax-case #'x ()
4181 (("quote" dx) #'("quote" (dx . dy)))
4182 (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
4183 (("list" . stuff) #'("list" x . stuff))
4184 (("list*" . stuff) #'("list*" x . stuff))
4185 (_ #'("list*" x y)))))
4186 (define (quasiappend x y)
4187 (syntax-case y ()
4188 (("quote" ())
4189 (cond
4190 ((null? x) #'("quote" ()))
4191 ((null? (cdr x)) (car x))
4192 (else (with-syntax (((p ...) x)) #'("append" p ...)))))
4193 (_
4194 (cond
4195 ((null? x) y)
4196 (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
4197 (define (quasilist* x y)
4198 (let f ((x x))
4199 (if (null? x)
4200 y
4201 (quasicons (car x) (f (cdr x))))))
4202 (define (quasivector x)
4203 (syntax-case x ()
4204 (("quote" (x ...)) #'("quote" #(x ...)))
4205 (_
4206 (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
4207 (syntax-case y ()
4208 (("quote" (y ...)) (k #'(("quote" y) ...)))
4209 (("list" y ...) (k #'(y ...)))
4210 (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
4211 (else #`("list->vector" #,x)))))))
4212 (define (emit x)
4213 (syntax-case x ()
4214 (("quote" x) #''x)
4215 (("list" x ...) #`(list #,@(map emit #'(x ...))))
4216 ; could emit list* for 3+ arguments if implementation supports list*
4217 (("list*" x ... y)
4218 (let f ((x* #'(x ...)))
4219 (if (null? x*)
4220 (emit #'y)
4221 #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
4222 (("append" x ...) #`(append #,@(map emit #'(x ...))))
4223 (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
4224 (("list->vector" x) #`(list->vector #,(emit #'x)))
4225 (("value" x) #'x)))
4226 (lambda (x)
4227 (syntax-case x ()
4228 ; convert to intermediate language, combining introduced (but not
4229 ; unquoted source) quote expressions where possible and choosing
4230 ; optimal construction code otherwise, then emit Scheme code
4231 ; corresponding to the intermediate language forms.
4232 ((_ e) (emit (quasi #'e 0)))))))
4234 ;*** "unquote" and "unquote-splicing" might be variables and defining
4235 ;*** them as macros would interfere.
4236 ;***
4237 ;*** (define-syntax unquote
4238 ;*** (lambda (x)
4239 ;*** (syntax-error x "misplaced")))
4240 ;***
4241 ;*** (define-syntax unquote-splicing
4242 ;*** (lambda (x)
4243 ;*** (syntax-error x "misplaced")))
4245 (define-syntax quasisyntax
4246 (lambda (x)
4247 (define (qs q n b* k)
4248 (syntax-case q (quasisyntax unsyntax unsyntax-splicing)
4249 ((quasisyntax . d)
4250 (qs #'d (+ n 1) b*
4251 (lambda (b* dnew)
4252 (k b*
4253 (if (eq? dnew #'d)
4254 q
4255 (with-syntax ((d dnew)) #'(quasisyntax . d)))))))
4256 ((unsyntax . d)
4257 (not (= n 0))
4258 (qs #'d (- n 1) b*
4259 (lambda (b* dnew)
4260 (k b*
4261 (if (eq? dnew #'d)
4262 q
4263 (with-syntax ((d dnew)) #'(unsyntax . d)))))))
4264 ((unsyntax-splicing . d)
4265 (not (= n 0))
4266 (qs #'d (- n 1) b*
4267 (lambda (b* dnew)
4268 (k b*
4269 (if (eq? dnew #'d)
4270 q
4271 (with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
4272 ((unsyntax q)
4273 (= n 0)
4274 (with-syntax (((t) (generate-temporaries #'(q))))
4275 (k (cons #'(t q) b*) #'t)))
4276 (((unsyntax q ...) . d)
4277 (= n 0)
4278 (qs #'d n b*
4279 (lambda (b* dnew)
4280 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
4281 (k (append #'((t q) ...) b*)
4282 (with-syntax ((d dnew)) #'(t ... . d)))))))
4283 (((unsyntax-splicing q ...) . d)
4284 (= n 0)
4285 (qs #'d n b*
4286 (lambda (b* dnew)
4287 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
4288 (k (append #'(((t (... ...)) q) ...) b*)
4289 (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
4290 (with-syntax ((d dnew)) #'(m ... ... . d))))))))
4291 ((a . d)
4292 (qs #'a n b*
4293 (lambda (b* anew)
4294 (qs #'d n b*
4295 (lambda (b* dnew)
4296 (k b*
4297 (if (and (eq? anew #'a) (eq? dnew #'d))
4298 q
4299 (with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
4300 (#(x ...)
4301 (vqs #'(x ...) n b*
4302 (lambda (b* xnew*)
4303 (k b*
4304 (if (let same? ((x* #'(x ...)) (xnew* xnew*))
4305 (if (null? x*)
4306 (null? xnew*)
4307 (and (not (null? xnew*))
4308 (eq? (car x*) (car xnew*))
4309 (same? (cdr x*) (cdr xnew*)))))
4310 q
4311 (with-syntax (((x ...) xnew*)) #'#(x ...)))))))
4312 (_ (k b* q))))
4313 (define (vqs x* n b* k)
4314 (if (null? x*)
4315 (k b* '())
4316 (vqs (cdr x*) n b*
4317 (lambda (b* xnew*)
4318 (syntax-case (car x*) (unsyntax unsyntax-splicing)
4319 ((unsyntax q ...)
4320 (= n 0)
4321 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
4322 (k (append #'((t q) ...) b*)
4323 (append #'(t ...) xnew*))))
4324 ((unsyntax-splicing q ...)
4325 (= n 0)
4326 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
4327 (k (append #'(((t (... ...)) q) ...) b*)
4328 (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
4329 (append #'(m ... ...) xnew*)))))
4330 (_ (qs (car x*) n b*
4331 (lambda (b* xnew)
4332 (k b* (cons xnew xnew*))))))))))
4333 (syntax-case x ()
4334 ((_ x)
4335 (qs #'x 0 '()
4336 (lambda (b* xnew)
4337 (if (eq? xnew #'x)
4338 #'(syntax x)
4339 (with-syntax (((b ...) b*) (x xnew))
4340 #'(with-syntax (b ...) (syntax x))))))))))
4342 ;*** "unsyntax" and "unsyntax-splicing" might be variables and defining
4343 ;*** them as macros would interfere.
4344 ;***
4345 ;*** (define-syntax unsyntax
4346 ;*** (lambda (x)
4347 ;*** (syntax-error x "misplaced")))
4348 ;***
4349 ;*** (define-syntax unsyntax-splicing
4350 ;*** (lambda (x)
4351 ;*** (syntax-error x "misplaced")))
4353 (define-syntax include
4354 (lambda (x)
4355 (define read-file
4356 (lambda (fn k)
4357 (let ((p (open-input-file fn)))
4358 (let f ()
4359 (let ((x (read p)))
4360 (if (eof-object? x)
4361 (begin (close-input-port p) '())
4362 (cons (datum->syntax-object k x) (f))))))))
4363 (syntax-case x ()
4364 ((k filename)
4365 (let ((fn (syntax-object->datum (syntax filename))))
4366 ;*** (with-syntax (((exp ...) (read-file fn (syntax k))))
4367 ;*** (syntax (begin exp ...))))))))
4368 (datum->syntax-object
4369 (syntax k)
4370 (let* ((src
4371 (##include-file-as-a-begin-expr
4372 (let ((y (vector-ref x 1)))
4373 (if (##source? y)
4374 y
4375 (##make-source y #f)))))
4376 (locat
4377 (##source-locat src)))
4378 src
4379 #;
4380 (##make-source (cons (##make-source 'begin locat)
4381 (cdr (##source-code src)))
4382 locat))))))))
4384 (define-syntax case
4385 (lambda (x)
4386 (syntax-case x ()
4387 ((_ e m1 m2 ...)
4388 (with-syntax
4389 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
4390 (if (null? clauses)
4391 (syntax-case clause (else)
4392 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
4393 (((k ...) e1 e2 ...)
4394 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
4395 (_ (syntax-error x)))
4396 (with-syntax ((rest (f (car clauses) (cdr clauses))))
4397 (syntax-case clause (else)
4398 (((k ...) e1 e2 ...)
4399 (syntax (if (memv t '(k ...))
4400 (begin e1 e2 ...)
4401 rest)))
4402 (_ (syntax-error x))))))))
4403 (syntax (let ((t e)) body)))))))
4405 (define-syntax identifier-syntax
4406 (syntax-rules (set!)
4407 ((_ e)
4408 (lambda (x)
4409 (syntax-case x ()
4410 (id (identifier? (syntax id)) (syntax e))
4411 ((_ x (... ...)) (syntax (e x (... ...)))))))
4412 ((_ (id exp1) ((set! var val) exp2))
4413 (and (identifier? (syntax id)) (identifier? (syntax var)))
4414 (cons 'macro!
4415 (lambda (x)
4416 (syntax-case x (set!)
4417 ((set! var val) (syntax exp2))
4418 ((id x (... ...)) (syntax (exp1 x (... ...))))
4419 (id (identifier? (syntax id)) (syntax exp1))))))))
4421 ;*** Gambit extensions:
4423 (define-syntax cond-expand
4424 (syntax-rules (and or not else srfi-0 gambit)
4425 ((cond-expand) (syntax-error "Unfulfilled cond-expand"))
4426 ((cond-expand (else body ...))
4427 (begin body ...))
4428 ((cond-expand ((and) body ...) more-clauses ...)
4429 (begin body ...))
4430 ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...)
4431 (cond-expand
4432 (req1
4433 (cond-expand
4434 ((and req2 ...) body ...)
4435 more-clauses ...))
4436 more-clauses ...))
4437 ((cond-expand ((or) body ...) more-clauses ...)
4438 (cond-expand more-clauses ...))
4439 ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...)
4440 (cond-expand
4441 (req1
4442 (begin body ...))
4443 (else
4444 (cond-expand
4445 ((or req2 ...) body ...)
4446 more-clauses ...))))
4447 ((cond-expand ((not req) body ...) more-clauses ...)
4448 (cond-expand
4449 (req
4450 (cond-expand more-clauses ...))
4451 (else body ...)))
4452 ((cond-expand (srfi-0 body ...) more-clauses ...)
4453 (begin body ...))
4454 ((cond-expand (gambit body ...) more-clauses ...)
4455 (begin body ...))
4456 ((cond-expand (feature-id body ...) more-clauses ...)
4457 (cond-expand more-clauses ...))))
4459 (define-syntax define-macro
4460 (lambda (x)
4461 (syntax-case x ()
4462 ((_ (name . params) body1 body2 ...)
4463 (syntax (define-macro name (lambda params body1 body2 ...))))
4464 ((_ name expander)
4465 (syntax (define-syntax name
4466 (lambda (y)
4467 (syntax-case y ()
4468 ((k . args)
4469 (let ((lst (syntax-object->datum (syntax args))))
4470 (datum->syntax-object
4471 (syntax k)
4472 (apply expander lst))))))))))))
4474 (define-syntax ##begin
4475 (lambda (x)
4476 (syntax-case x ()
4477 ((_ body1 ...)
4478 (syntax (begin body1 ...))))))
4480 (define-syntax future
4481 (syntax-rules ()
4482 ((_ rest ...) (##future rest ...))))
4484 (define-syntax c-define-type
4485 (syntax-rules ()
4486 ((_ rest ...) (##c-define-type rest ...))))
4488 (define-syntax c-declare
4489 (syntax-rules ()
4490 ((_ rest ...) (##c-declare rest ...))))
4492 (define-syntax c-initialize
4493 (syntax-rules ()
4494 ((_ rest ...) (##c-initialize rest ...))))
4496 (define-syntax c-lambda
4497 (syntax-rules ()
4498 ((_ rest ...) (##c-lambda rest ...))))
4500 (define-syntax c-define
4501 (syntax-rules ()
4502 ((_ rest ...) (##c-define rest ...))))
4504 (define-syntax declare
4505 (syntax-rules ()
4506 ((_ rest ...) (##declare rest ...))))
4508 (define-syntax namespace
4509 (syntax-rules ()
4510 ((_ rest ...) (##namespace rest ...))))