ref: 20488fc4915662e0ec50bb8c4ebc2609d6e110b4
dir: /lib/psyntax.ss/
;;; Portable implementation of syntax-case
;;; Extracted from Chez Scheme Version 7.3 (Feb 26, 2007)
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
;;; Copyright (c) 1992-2002 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full. This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.
;;; Before attempting to port this code to a new implementation of
;;; Scheme, please read the notes below carefully.
;;; This file defines the syntax-case expander, sc-expand, and a set
;;; of associated syntactic forms and procedures. Of these, the
;;; following are documented in The Scheme Programming Language,
;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
;;; found online at http://www.scheme.com/tspl3/. Most are also documented
;;; in the R4RS and draft R5RS.
;;;
;;; bound-identifier=?
;;; datum->syntax-object
;;; define-syntax
;;; fluid-let-syntax
;;; free-identifier=?
;;; generate-temporaries
;;; identifier?
;;; identifier-syntax
;;; let-syntax
;;; letrec-syntax
;;; syntax
;;; syntax-case
;;; syntax-object->datum
;;; syntax-rules
;;; with-syntax
;;;
;;; All standard Scheme syntactic forms are supported by the expander
;;; or syntactic abstractions defined in this file. Only the R4RS
;;; delay is omitted, since its expansion is implementation-dependent.
;;; Also defined are three forms that support modules: module, import,
;;; and import-only. These are documented in the Chez Scheme User's
;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
;;; also be found online at http://www.scheme.com/csug/. They are
;;; described briefly here as well.
;;; All are definitions and may appear where and only where other
;;; definitions may appear. modules may be named:
;;;
;;; (module id (ex ...) defn ... init ...)
;;;
;;; or anonymous:
;;;
;;; (module (ex ...) defn ... init ...)
;;;
;;; The latter form is semantically equivalent to:
;;;
;;; (module T (ex ...) defn ... init ...)
;;; (import T)
;;;
;;; where T is a fresh identifier.
;;;
;;; In either form, each of the exports in (ex ...) is either an
;;; identifier or of the form (id ex ...). In the former case, the
;;; single identifier ex is exported. In the latter, the identifier
;;; id is exported and the exports ex ... are "implicitly" exported.
;;; This listing of implicit exports is useful only when id is a
;;; keyword bound to a transformer that expands into references to
;;; the listed implicit exports. In the present implementation,
;;; listing of implicit exports is necessary only for top-level
;;; modules and allows the implementation to avoid placing all
;;; identifiers into the top-level environment where subsequent passes
;;; of the compiler will be unable to deal effectively with them.
;;;
;;; Named modules may be referenced in import statements, which
;;; always take one of the forms:
;;;
;;; (import id)
;;; (import-only id)
;;;
;;; id must name a module. Each exported identifier becomes visible
;;; within the scope of the import form. In the case of import-only,
;;; all other identifiers become invisible in the scope of the
;;; import-only form, except for those established by definitions
;;; that appear textually after the import-only form.
;;; import and import-only also support a variety of identifier
;;; selection and renaming forms: only, except, add-prefix,
;;; drop-prefix, rename, and alias.
;;;
;;; (import (only m x y))
;;;
;;; imports x and y (and nothing else) from m.
;;;
;;; (import (except m x y))
;;;
;;; imports all of m's imports except for x and y.
;;;
;;; (import (add-prefix (only m x y) m:))
;;;
;;; imports x and y as m:x and m:y.
;;;
;;; (import (drop-prefix m foo:))
;;;
;;; imports all of m's imports, dropping the common foo: prefix
;;; (which must appear on all of m's exports).
;;;
;;; (import (rename (except m a b) (m-c c) (m-d d)))
;;;
;;; imports all of m's imports except for x and y, renaming c
;;; m-c and d m-d.
;;;
;;; (import (alias (except m a b) (m-c c) (m-d d)))
;;;
;;; imports all of m's imports except for x and y, with additional
;;; aliases m-c for c and m-d for d.
;;;
;;; multiple imports may be specified with one import form:
;;;
;;; (import (except m1 x) (only m2 x))
;;;
;;; imports all of m1's exports except for x plus x from m2.
;;; Another form, meta, may be used as a prefix for any definition and
;;; causes any resulting variable bindings to be created at expansion
;;; time. Meta variables (variables defined using meta) are available
;;; only at expansion time. Meta definitions are often used to create
;;; data and helpers that can be shared by multiple macros, for example:
;;; (module (alpha beta)
;;; (meta define key-error
;;; (lambda (key)
;;; (syntax-error key "invalid key")))
;;; (meta define parse-keys
;;; (lambda (keys)
;;; (let f ((keys keys) (c #'white) (s 10))
;;; (syntax-case keys (color size)
;;; (() (list c s))
;;; (((color c) . keys) (f #'keys #'c s))
;;; (((size s) . keys) (f #'keys c #'s))
;;; ((k . keys) (key-error #'k))))))
;;; (define-syntax alpha
;;; (lambda (x)
;;; (syntax-case x ()
;;; ((_ (k ...) <other stuff>)
;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
;;; ---)))))
;;; (define-syntax beta
;;; (lambda (x)
;;; (syntax-case x ()
;;; ((_ (k ...) <other stuff>)
;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
;;; ---))))))
;;; As with define-syntax rhs expressions, meta expressions can evaluate
;;; references only to identifiers whose values are (already) available
;;; in the compile-time environment, e.g., macros and meta variables.
;;; They can, however, like define-syntax rhs expressions, build syntax
;;; objects containing occurrences of any identifiers in their scope.
;;; meta definitions propagate through macro expansion, so one can write,
;;; for example:
;;;
;;; (module (a)
;;; (meta define-structure (foo x))
;;; (define-syntax a
;;; (let ((q (make-foo (syntax 'q))))
;;; (lambda (x)
;;; (foo-x q)))))
;;; a -> q
;;;
;;; where define-record is a macro that expands into a set of defines.
;;;
;;; It is also sometimes convenient to write
;;;
;;; (meta begin defn ...)
;;;
;;; or
;;;
;;; (meta module {exports} defn ...)
;;;
;;; to create groups of meta bindings.
;;; Another form, alias, is used to create aliases from one identifier
;;; to another. This is used primarily to support the extended import
;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
;;; (let ((x 3)) (alias y x) y) -> 3
;;; The remaining exports are listed below. sc-expand, eval-when, and
;;; syntax-error are described in the Chez Scheme User's Guide.
;;;
;;; (sc-expand datum)
;;; if datum represents a valid expression, sc-expand returns an
;;; expanded version of datum in a core language that includes no
;;; syntactic abstractions. The core language includes begin,
;;; define, if, lambda, letrec, quote, and set!.
;;; (eval-when situations expr ...)
;;; conditionally evaluates expr ... at compile-time or run-time
;;; depending upon situations
;;; (syntax-error object message)
;;; used to report errors found during expansion
;;; ($syntax-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; ($sc-put-cte symbol val top-token)
;;; used to establish top-level compile-time (expand-time) bindings.
;;; The following nonstandard procedures must be provided by the
;;; implementation for this code to run.
;;;
;;; (void)
;;; returns the implementation's cannonical "unspecified value". The
;;; following usually works:
;;;
;;; (define void (lambda () (if #f #f))).
;;;
;;; (andmap proc list1 list2 ...)
;;; returns true if proc returns true when applied to each element of list1
;;; along with the corresponding elements of list2 .... The following
;;; definition works but does no error checking:
;;;
;;; (define andmap
;;; (lambda (f first . rest)
;;; (or (null? first)
;;; (if (null? rest)
;;; (let andmap ((first first))
;;; (let ((x (car first)) (first (cdr first)))
;;; (if (null? first)
;;; (f x)
;;; (and (f x) (andmap first)))))
;;; (let andmap ((first first) (rest rest))
;;; (let ((x (car first))
;;; (xr (map car rest))
;;; (first (cdr first))
;;; (rest (map cdr rest)))
;;; (if (null? first)
;;; (apply f (cons x xr))
;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
;;;
;;; (ormap proc list1)
;;; returns the first non-false return result of proc applied to
;;; the elements of list1 or false if none. The following definition
;;; works but does no error checking:
;;;
;;; (define ormap
;;; (lambda (proc list1)
;;; (and (not (null? list1))
;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
;;;
;;; The following nonstandard procedures must also be provided by the
;;; implementation for this code to run using the standard portable
;;; hooks and output constructors. They are not used by expanded code,
;;; and so need be present only at expansion time.
;;;
;;; (eval x)
;;; where x is always in the form ("noexpand" expr).
;;; returns the value of expr. the "noexpand" flag is used to tell the
;;; evaluator/expander that no expansion is necessary, since expr has
;;; already been fully expanded to core forms.
;;;
;;; eval will not be invoked during the loading of psyntax.pp. After
;;; psyntax.pp has been loaded, the expansion of any macro definition,
;;; whether local or global, results in a call to eval. If, however,
;;; sc-expand has already been registered as the expander to be used
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by sc-expand.
;;;
;;; (error who format-string why what)
;;; where who is either a symbol or #f, format-string is always "~a ~s",
;;; why is always a string, and what may be any object. error should
;;; signal an error with a message something like
;;;
;;; "error in <who>: <why> <what>"
;;;
;;; (gensym)
;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
;;; returns a symbol with a "globally" unique name so that gensyms that
;;; end up in the object code of separately compiled files cannot conflict.
;;; This is necessary only if you intend to support compiled files.
;;;
;;; (gensym? x)
;;; returns #t if x is a gensym, otherwise false.
;;;
;;; (putprop symbol key value)
;;; (getprop symbol key)
;;; (remprop symbol key)
;;; key is always a symbol; value may be any object. putprop should
;;; associate the given value with the given symbol and key in some way
;;; that it can be retrieved later with getprop. getprop should return
;;; #f if no value is associated with the given symbol and key. remprop
;;; should remove the association between the given symbol and key.
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
;;; (psyntax.pp, which should be available whereever you found
;;; psyntax.ss), and register sc-expand as the current expander (how
;;; you do this depends upon your implementation of Scheme). You may
;;; change the hooks and constructors defined toward the beginning of
;;; the code below, but to avoid bootstrapping problems, do so only
;;; after you have a working version of the expander.
;;; Chez Scheme allows the syntactic form (syntax <template>) to be
;;; abbreviated to #'<template>, just as (quote <datum>) may be
;;; abbreviated to '<datum>. The #' syntax makes programs written
;;; using syntax-case shorter and more readable and draws out the
;;; intuitive connection between syntax and quote. If you have access
;;; to the source code of your Scheme system's reader, you might want
;;; to implement this extension.
;;; If you find that this code loads or runs slowly, consider
;;; switching to faster hardware or a faster implementation of
;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
;;; compiling (with full optimization), and loading this file takes
;;; between one and two seconds.
;;; In the expander implementation, we sometimes use syntactic abstractions
;;; when procedural abstractions would suffice. For example, we define
;;; top-wrap and top-marked? as
;;; (define-syntax top-wrap (identifier-syntax '((top))))
;;; (define-syntax top-marked?
;;; (syntax-rules ()
;;; ((_ w) (memq 'top (wrap-marks w)))))
;;; rather than
;;; (define top-wrap '((top)))
;;; (define top-marked?
;;; (lambda (w) (memq 'top (wrap-marks w))))
;;; On ther other hand, we don't do this consistently; we define make-wrap,
;;; wrap-marks, and wrap-subst simply as
;;; (define make-wrap cons)
;;; (define wrap-marks car)
;;; (define wrap-subst cdr)
;;; In Chez Scheme, the syntactic and procedural forms of these
;;; abstractions are equivalent, since the optimizer consistently
;;; integrates constants and small procedures. Some Scheme
;;; implementations, however, may benefit from more consistent use
;;; of one form or the other.
;;; Implementation notes:
;;; "begin" is treated as a splicing construct at top level and at
;;; the beginning of bodies. Any sequence of expressions that would
;;; be allowed where the "begin" occurs is allowed.
;;; "let-syntax" and "letrec-syntax" are also treated as splicing
;;; constructs, in violation of the R5RS. A consequence is that let-syntax
;;; and letrec-syntax do not create local contours, as do let and letrec.
;;; Although the functionality is greater as it is presently implemented,
;;; we will probably change it to conform to the R5RS. modules provide
;;; similar functionality to nonsplicing letrec-syntax when the latter is
;;; used as a definition.
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax objects, are allowed in quoted data as long as they
;;; are contained within a syntax form or produced by datum->syntax-object.
;;; Such objects are never copied.
;;; When the expander encounters a reference to an identifier that has
;;; no global or lexical binding, it treats it as a global-variable
;;; reference. This allows one to write mutually recursive top-level
;;; definitions, e.g.:
;;;
;;; (define f (lambda (x) (g x)))
;;; (define g (lambda (x) (f x)))
;;;
;;; but may not always yield the intended when the variable in question
;;; is later defined as a keyword.
;;; Top-level variable definitions of syntax keywords are permitted.
;;; In order to make this work, top-level define not only produces a
;;; top-level definition in the core language, but also modifies the
;;; compile-time environment (using $sc-put-cte) to record the fact
;;; that the identifier is a variable.
;;; Top-level definitions of macro-introduced identifiers are visible
;;; only in code produced by the macro. That is, a binding for a
;;; hidden (generated) identifier is created instead, and subsequent
;;; references within the macro output are renamed accordingly. For
;;; example:
;;;
;;; (define-syntax a
;;; (syntax-rules ()
;;; ((_ var exp)
;;; (begin
;;; (define secret exp)
;;; (define var
;;; (lambda ()
;;; (set! secret (+ secret 17))
;;; secret))))))
;;; (a x 0)
;;; (x) => 17
;;; (x) => 34
;;; secret => Error: variable secret is not bound
;;;
;;; The definition above would fail if the definition for secret
;;; were placed after the definition for var, since the expander would
;;; encounter the references to secret before the definition that
;;; establishes the compile-time map from the identifier secret to
;;; the generated identifier.
;;; Identifiers and syntax objects are implemented as vectors for
;;; portability. As a result, it is possible to "forge" syntax
;;; objects.
;;; The input to sc-expand may contain "annotations" describing, e.g., the
;;; source file and character position from where each object was read if
;;; it was read from a file. These annotations are handled properly by
;;; sc-expand only if the annotation? hook (see hooks below) is implemented
;;; properly and the operators annotation-expression and annotation-stripped
;;; are supplied. If annotations are supplied, the proper annotated
;;; expression is passed to the various output constructors, allowing
;;; implementations to accurately correlate source and expanded code.
;;; Contact one of the authors for details if you wish to make use of
;;; this feature.
;;; Implementation of modules:
;;;
;;; The implementation of modules requires that implicit top-level exports
;;; be listed with the exported macro at some level where both are visible,
;;; e.g.,
;;;
;;; (module M (alpha (beta b))
;;; (module ((alpha a) b)
;;; (define-syntax alpha (identifier-syntax a))
;;; (define a 'a)
;;; (define b 'b))
;;; (define-syntax beta (identifier-syntax b)))
;;;
;;; Listing of implicit imports is not needed for macros that do not make
;;; it out to top level, including all macros that are local to a "body".
;;; (They may be listed in this case, however.) We need this information
;;; for top-level modules since a top-level module expands into a letrec
;;; for non-top-level variables and top-level definitions (assignments) for
;;; top-level variables. Because of the general nature of macro
;;; transformers, we cannot determine the set of implicit exports from the
;;; transformer code, so without the user's help, we'd have to put all
;;; variables at top level.
;;;
;;; Each such top-level identifier is given a generated name (gensym).
;;; When a top-level module is imported at top level, a compile-time
;;; alias is established from the top-level name to the generated name.
;;; The expander follows these aliases transparently. When any module is
;;; imported anywhere other than at top level, the id-var-name of the
;;; import identifier is set to the id-var-name of the export identifier.
;;; Since we can't determine the actual labels for identifiers defined in
;;; top-level modules until we determine which are placed in the letrec
;;; and which make it to top level, we give each an "indirect" label---a
;;; pair whose car will eventually contain the actual label. Import does
;;; not follow the indirect, but id-var-name does.
;;;
;;; All identifiers defined within a local module are folded into the
;;; letrec created for the enclosing body. Visibility is controlled in
;;; this case and for nested top-level modules by introducing a new wrap
;;; for each module.
;;; Bootstrapping:
;;; When changing syntax-object representations, it is necessary to support
;;; both old and new syntax-object representations in id-var-name. It
;;; should be sufficient to redefine syntax-object-expression to work for
;;; both old and new representations and syntax-object-wrap to return the
;;; empty-wrap for old representations.
;;; The following set of definitions establishes bindings for the
;;; top-level variables assigned values in the let expression below.
;;; Uncomment them here and copy them to the front of psyntax.pp if
;;; required by your system.
; (define $sc-put-cte #f)
; (define sc-expand #f)
; (define $make-environment #f)
; (define environment? #f)
; (define interaction-environment #f)
; (define identifier? #f)
; (define syntax->list #f)
; (define syntax-object->datum #f)
; (define datum->syntax-object #f)
; (define generate-temporaries #f)
; (define free-identifier=? #f)
; (define bound-identifier=? #f)
; (define literal-identifier=? #f)
; (define syntax-error #f)
; (define $syntax-dispatch #f)
(let ()
(define-syntax when
(syntax-rules ()
((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
(define-syntax unless
(syntax-rules ()
((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
(datum->syntax-object
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
(symbol->string (syntax-object->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
(andmap identifier? (syntax (name id1 ...)))
(with-syntax
((constructor (construct-name (syntax name) "make-" (syntax name)))
(predicate (construct-name (syntax name) (syntax name) "?"))
((access ...)
(map (lambda (x) (construct-name x (syntax name) "-" x))
(syntax (id1 ...))))
((assign ...)
(map (lambda (x)
(construct-name x "set-" (syntax name) "-" x "!"))
(syntax (id1 ...))))
(structure-length
(+ (length (syntax (id1 ...))) 1))
((index ...)
(let f ((i 1) (ids (syntax (id1 ...))))
(if (null? ids)
'()
(cons i (f (+ i 1) (cdr ids)))))))
(syntax (begin
(define constructor
(lambda (id1 ...)
(vector 'name id1 ... )))
(define predicate
(lambda (x)
(and (vector? x)
(= (vector-length x) structure-length)
(eq? (vector-ref x 0) 'name))))
(define access
(lambda (x)
(vector-ref x index)))
...
(define assign
(lambda (x update)
(vector-set! x index update)))
...)))))))
(define-syntax let-values ; impoverished one-clause version
(syntax-rules ()
((_ ((formals expr)) form1 form2 ...)
(call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
(define noexpand "noexpand")
(define-structure (syntax-object expression wrap))
;;; hooks to nonportable run-time helpers
(begin
(define-syntax fx+ (identifier-syntax +))
(define-syntax fx- (identifier-syntax -))
(define-syntax fx= (identifier-syntax =))
(define-syntax fx< (identifier-syntax <))
(define-syntax fx> (identifier-syntax >))
(define-syntax fx<= (identifier-syntax <=))
(define-syntax fx>= (identifier-syntax >=))
(define annotation? (lambda (x) #f))
; top-level-eval-hook is used to create "permanent" code (e.g., top-level
; transformers), so it might be a good idea to compile it
(define top-level-eval-hook
(lambda (x)
(eval `(,noexpand ,x))))
; local-eval-hook is used to create "temporary" code (e.g., local
; transformers), so it might be a good idea to interpret it
(define local-eval-hook
(lambda (x)
(eval `(,noexpand ,x))))
(define define-top-level-value-hook
(lambda (sym val)
(top-level-eval-hook
(build-global-definition no-source sym
(build-data no-source val)))))
(define error-hook
(lambda (who why what)
(error who "~a ~s" why what)))
(define put-cte-hook
(lambda (symbol val)
($sc-put-cte symbol val '*top*)))
(define get-global-definition-hook
(lambda (symbol)
(getprop symbol '*sc-expander*)))
(define put-global-definition-hook
(lambda (symbol x)
(if (not x)
(remprop symbol '*sc-expander*)
(putprop symbol '*sc-expander* x))))
; if you treat certain bindings (say from environments like ieee or r5rs)
; read-only, this should return #t for those bindings
(define read-only-binding?
(lambda (symbol)
#f))
; should return #f if symbol has no binding for token
(define get-import-binding
(lambda (symbol token)
(getprop symbol token)))
; remove binding if x is false
(define update-import-binding!
(lambda (symbol token p)
(let ((x (p (get-import-binding symbol token))))
(if (not x)
(remprop symbol token)
(putprop symbol token x)))))
;;; generate-id ideally produces globally unique symbols, i.e., symbols
;;; unique across system runs, to support separate compilation/expansion.
;;; Use gensyms if you do not need to support separate compilation/
;;; expansion or if your system's gensym creates globally unique
;;; symbols (as in Chez Scheme). Otherwise, use the following code
;;; as a starting point. session-key should be a unique string for each
;;; system run to support separate compilation; the default value given
;;; is satisfactory during initial development only.
(define generate-id
(let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
(let ((base (string-length digits)) (session-key "_"))
(define make-digit (lambda (x) (string-ref digits x)))
(define fmt
(lambda (n)
(let fmt ((n n) (a '()))
(if (< n base)
(list->string (cons (make-digit n) a))
(let ((r (modulo n base)) (rest (quotient n base)))
(fmt rest (cons (make-digit r) a)))))))
(let ((n -1))
(lambda (name) ; name is #f or a symbol
(set! n (+ n 1))
(string->symbol (string-append session-key (fmt n))))))))
)
;;; output constructors
(begin
(define-syntax build-application
(syntax-rules ()
((_ ae fun-exp arg-exps)
`(,fun-exp . ,arg-exps))))
(define-syntax build-conditional
(syntax-rules ()
((_ ae test-exp then-exp else-exp)
`(if ,test-exp ,then-exp ,else-exp))))
(define-syntax build-lexical-reference
(syntax-rules ()
((_ type ae var)
var)))
(define-syntax build-lexical-assignment
(syntax-rules ()
((_ ae var exp)
`(set! ,var ,exp))))
(define-syntax build-global-reference
(syntax-rules ()
((_ ae var)
var)))
(define-syntax build-global-assignment
(syntax-rules ()
((_ ae var exp)
`(set! ,var ,exp))))
(define-syntax build-global-definition
(syntax-rules ()
((_ ae var exp)
`(define ,var ,exp))))
(define-syntax build-cte-install
; should build a call that has the same effect as calling put-cte-hook
(syntax-rules ()
((_ sym exp token) `($sc-put-cte ',sym ,exp ',token))))
(define-syntax build-visit-only
; should mark the result as "visit only" for compile-file
; in implementations that support visit/revisit
(syntax-rules ()
((_ exp) exp)))
(define-syntax build-revisit-only
; should mark the result as "revisit only" for compile-file,
; in implementations that support visit/revisit
(syntax-rules ()
((_ exp) exp)))
(define-syntax build-lambda
(syntax-rules ()
((_ ae vars exp)
`(lambda ,vars ,exp))))
(define built-lambda?
(lambda (x)
(and (pair? x) (eq? (car x) 'lambda))))
(define-syntax build-primref
(syntax-rules ()
((_ ae name) name)
((_ ae level name) name)))
(define-syntax build-data
(syntax-rules ()
((_ ae exp) `',exp)))
(define build-sequence
(lambda (ae exps)
(let loop ((exps exps))
(if (null? (cdr exps))
(car exps)
; weed out leading void calls, assuming ordinary list representation
(if (equal? (car exps) '(void))
(loop (cdr exps))
`(begin ,@exps))))))
(define build-letrec
(lambda (ae vars val-exps body-exp)
(if (null? vars)
body-exp
`(letrec ,(map list vars val-exps) ,body-exp))))
(define build-body
(lambda (ae vars val-exps body-exp)
(build-letrec ae vars val-exps body-exp)))
(define build-top-module
; each type is either global (exported) or local (not exported)
; we produce global definitions and assignments for globals and
; letrec bindings for locals. if you don't need the definitions,
; (just assignments) you can eliminate them. if you wish to
; have your module definitions ordered from left-to-right (ala
; letrec*), you can replace the global var-exps with dummy vars
; and global val-exps with global assignments, and produce a letrec*
; in place of a letrec.
(lambda (ae types vars val-exps body-exp)
(let-values (((vars defns sets)
(let f ((types types) (vars vars))
(if (null? types)
(values '() '() '())
(let ((var (car vars)))
(let-values (((vars defns sets) (f (cdr types) (cdr vars))))
(if (eq? (car types) 'global)
(let ((x (build-lexical-var no-source var)))
(values
(cons x vars)
(cons (build-global-definition no-source var (chi-void)) defns)
(cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
(values (cons var vars) defns sets))))))))
(if (null? defns)
(build-letrec ae vars val-exps body-exp)
(build-sequence no-source
(append defns
(list
(build-letrec ae vars val-exps
(build-sequence no-source (append sets (list body-exp)))))))))))
(define-syntax build-lexical-var
(syntax-rules ()
((_ ae id) (gensym))))
(define-syntax lexical-var? gensym?)
(define-syntax self-evaluating?
(syntax-rules ()
((_ e)
(let ((x e))
(or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
)
(define-syntax unannotate
(syntax-rules ()
((_ x)
(let ((e x))
(if (annotation? e)
(annotation-expression e)
e)))))
(define-syntax no-source (identifier-syntax #f))
(define-syntax arg-check
(syntax-rules ()
((_ pred? e who)
(let ((x e))
(if (not (pred? x)) (error-hook who "invalid argument" x))))))
;;; compile-time environments
;;; wrap and environment comprise two level mapping.
;;; wrap : id --> label
;;; env : label --> <element>
;;; environments are represented in two parts: a lexical part and a global
;;; part. The lexical part is a simple list of associations from labels
;;; to bindings. The global part is implemented by
;;; {put,get}-global-definition-hook and associates symbols with
;;; bindings.
;;; global (assumed global variable) and displaced-lexical (see below)
;;; do not show up in any environment; instead, they are fabricated by
;;; lookup when it finds no other bindings.
;;; <environment> ::= ((<label> . <binding>)*)
;;; identifier bindings include a type and a value
;;; <binding> ::= <procedure> macro keyword
;;; (macro . <procedure>) macro keyword
;;; (deferred . <thunk>) macro keyword w/lazily evaluated transformer
;;; (macro! . <procedure>) extended identifier macro keyword
;;; (core . <procedure>) core keyword
;;; (begin) begin keyword
;;; (define) define keyword
;;; (define-syntax) define-syntax keyword
;;; (local-syntax . <boolean>) let-syntax (#f)/letrec-syntax (#t) keyword
;;; (eval-when) eval-when keyword
;;; (set!) set! keyword
;;; (meta) meta keyword
;;; ($module-key) $module keyword
;;; ($import) $import keyword
;;; ($module . <interface>) modules
;;; (syntax . (<var> . <level>)) pattern variables
;;; (global . <symbol>) assumed global variable
;;; (meta-variable . <symbol>) meta variable
;;; (lexical . <var>) lexical variables
;;; (displaced-lexical . #f) id-var-name not found in store
;;; <level> ::= <nonnegative integer>
;;; <var> ::= variable returned by build-lexical-var
;;; a macro is a user-defined syntactic-form. a core is a system-defined
;;; syntactic form. begin, define, define-syntax, let-syntax, letrec-syntax,
;;; eval-when, and meta are treated specially since they are sensitive to
;;; whether the form is at top-level and can denote valid internal
;;; definitions.
;;; a pattern variable is a variable introduced by syntax-case and can
;;; be referenced only within a syntax form.
;;; any identifier for which no top-level syntax definition or local
;;; binding of any kind has been seen is assumed to be a global
;;; variable.
;;; a lexical variable is a lambda- or letrec-bound variable.
;;; a displaced-lexical identifier is a lexical identifier removed from
;;; it's scope by the return of a syntax object containing the identifier.
;;; a displaced lexical can also appear when a letrec-syntax-bound
;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
;;; a displaced lexical should never occur with properly written macros.
(define sanitize-binding
(lambda (b)
(cond
((procedure? b) (make-binding 'macro b))
((binding? b)
(and (case (binding-type b)
((core macro macro! deferred) (and (procedure? (binding-value b))))
(($module) (interface? (binding-value b)))
((lexical) (lexical-var? (binding-value b)))
((global meta-variable) (symbol? (binding-value b)))
((syntax) (let ((x (binding-value b)))
(and (pair? x)
(lexical-var? (car x))
(let ((n (cdr x)))
(and (integer? n) (exact? n) (>= n 0))))))
((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
((local-syntax) (boolean? (binding-value b)))
((displaced-lexical) (eq? (binding-value b) #f))
(else #t))
b))
(else #f))))
(define-syntax make-binding
(syntax-rules (quote)
((_ 'type #f) '(type . #f))
((_ type value) (cons type value))))
(define binding-type car)
(define binding-value cdr)
(define set-binding-type! set-car!)
(define set-binding-value! set-cdr!)
(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
(define-syntax null-env (identifier-syntax '()))
(define extend-env
(lambda (label binding r)
(cons (cons label binding) r)))
(define extend-env*
(lambda (labels bindings r)
(if (null? labels)
r
(extend-env* (cdr labels) (cdr bindings)
(extend-env (car labels) (car bindings) r)))))
(define extend-var-env*
; variant of extend-env* that forms "lexical" binding
(lambda (labels vars r)
(if (null? labels)
r
(extend-var-env* (cdr labels) (cdr vars)
(extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
(define (displaced-lexical? id r)
(let ((n (id-var-name id empty-wrap)))
(and n
(let ((b (lookup n r)))
(eq? (binding-type b) 'displaced-lexical)))))
(define displaced-lexical-error
(lambda (id)
(syntax-error id
(if (id-var-name id empty-wrap)
"identifier out of context"
"identifier not visible"))))
(define lookup*
; x may be a label or a symbol
; although symbols are usually global, we check the environment first
; anyway because a temporary binding may have been established by
; fluid-let-syntax
(lambda (x r)
(cond
((assq x r) => cdr)
((symbol? x)
(or (get-global-definition-hook x) (make-binding 'global x)))
(else (make-binding 'displaced-lexical #f)))))
(define lookup
(lambda (x r)
(define whack-binding!
(lambda (b *b)
(set-binding-type! b (binding-type *b))
(set-binding-value! b (binding-value *b))))
(let ((b (lookup* x r)))
(when (eq? (binding-type b) 'deferred)
(whack-binding! b (make-transformer-binding ((binding-value b)))))
b)))
(define make-transformer-binding
(lambda (b)
(or (sanitize-binding b)
(syntax-error b "invalid transformer"))))
(define defer-or-eval-transformer
(lambda (eval x)
(if (built-lambda? x)
(make-binding 'deferred (lambda () (eval x)))
(make-transformer-binding (eval x)))))
(define global-extend
(lambda (type sym val)
(put-cte-hook sym (make-binding type val))))
;;; Conceptually, identifiers are always syntax objects. Internally,
;;; however, the wrap is sometimes maintained separately (a source of
;;; efficiency and confusion), so that symbols are also considered
;;; identifiers by id?. Externally, they are always wrapped.
(define nonsymbol-id?
(lambda (x)
(and (syntax-object? x)
(symbol? (unannotate (syntax-object-expression x))))))
(define id?
(lambda (x)
(cond
((symbol? x) #t)
((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
((annotation? x) (symbol? (annotation-expression x)))
(else #f))))
(define-syntax id-sym-name
(syntax-rules ()
((_ e)
(let ((x e))
(unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
(define id-marks
(lambda (id)
(if (syntax-object? id)
(wrap-marks (syntax-object-wrap id))
(wrap-marks top-wrap))))
(define id-subst
(lambda (id)
(if (syntax-object? id)
(wrap-subst (syntax-object-wrap id))
(wrap-marks top-wrap))))
(define id-sym-name&marks
(lambda (x w)
(if (syntax-object? x)
(values
(unannotate (syntax-object-expression x))
(join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
(values (unannotate x) (wrap-marks w)))))
;;; syntax object wraps
;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
;;; <subst> ::= <ribcage> | <shift>
;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
;;; <ex-symname> ::= <symname> | <import token> | <barrier>
;;; <shift> ::= shift
;;; <barrier> ::= #f ; inserted by import-only
;;; <import interface> ::= #<import-interface interface new-marks>
;;; <token> ::= <generated id>
(define make-wrap cons)
(define wrap-marks car)
(define wrap-subst cdr)
(define-syntax empty-wrap (identifier-syntax '(())))
(define-syntax top-wrap (identifier-syntax '((top))))
(define-syntax tmp-wrap (identifier-syntax '((tmp)))) ; for generate-temporaries
(define-syntax top-marked?
(syntax-rules ()
((_ w) (memq 'top (wrap-marks w)))))
(define-syntax only-top-marked?
(syntax-rules ()
((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
;;; labels
;;; simple labels must be comparable with "eq?" and distinct from symbols
;;; and pairs.
;;; indirect labels, which are implemented as pairs, are used to support
;;; import aliasing for identifiers exported (explictly or implicitly) from
;;; top-level modules. chi-external creates an indirect label for each
;;; defined identifier, import causes the pair to be shared with aliases it
;;; establishes, and chi-top-module whacks the pair to hold the top-level
;;; identifier name (symbol) if the id is to be placed at top level, before
;;; expanding the right-hand sides of the definitions in the module.
(module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
(define-structure (indirect-label label))
(define gen-indirect-label
(lambda ()
(make-indirect-label (gen-label))))
(define get-indirect-label (lambda (x) (indirect-label-label x)))
(define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
(define gen-label
(lambda () (string #\i)))
(define label?
(lambda (x)
(or (string? x) ; normal lexical labels
(symbol? x) ; global labels (symbolic names)
(indirect-label? x))))
(define gen-labels
(lambda (ls)
(if (null? ls)
'()
(cons (gen-label) (gen-labels (cdr ls))))))
(define-structure (ribcage symnames marks labels))
(define-structure (top-ribcage key mutable?))
(define-structure (import-interface interface new-marks))
(define-structure (env top-ribcage wrap))
;;; Marks must be comparable with "eq?" and distinct from pairs and
;;; the symbol top. We do not use integers so that marks will remain
;;; unique even across file compiles.
(define-syntax the-anti-mark (identifier-syntax #f))
(define anti-mark
(lambda (w)
(make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w)))))
(define-syntax new-mark
(syntax-rules ()
((_) (string #\m))))
(define barrier-marker #f)
;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally
(define-syntax make-empty-ribcage
(syntax-rules ()
((_) (make-ribcage '() '() '()))))
(define extend-ribcage!
; must receive ids with complete wraps
; ribcage guaranteed to be list-based
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage
(cons (unannotate (syntax-object-expression id))
(ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
(cons (wrap-marks (syntax-object-wrap id))
(ribcage-marks ribcage)))
(set-ribcage-labels! ribcage
(cons label (ribcage-labels ribcage)))))
(define import-extend-ribcage!
; must receive ids with complete wraps
; ribcage guaranteed to be list-based
(lambda (ribcage new-marks id label)
(set-ribcage-symnames! ribcage
(cons (unannotate (syntax-object-expression id))
(ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
(cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
(ribcage-marks ribcage)))
(set-ribcage-labels! ribcage
(cons label (ribcage-labels ribcage)))))
(define extend-ribcage-barrier!
; must receive ids with complete wraps
; ribcage guaranteed to be list-based
(lambda (ribcage killer-id)
(extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
(define extend-ribcage-barrier-help!
(lambda (ribcage wrap)
(set-ribcage-symnames! ribcage
(cons barrier-marker (ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
(cons (wrap-marks wrap) (ribcage-marks ribcage)))))
(define extend-ribcage-subst!
; ribcage guaranteed to be list-based
(lambda (ribcage import-iface)
(set-ribcage-symnames! ribcage
(cons import-iface (ribcage-symnames ribcage)))))
(define lookup-import-binding-name
(lambda (sym marks token new-marks)
(let ((new (get-import-binding sym token)))
(and new
(let f ((new new))
(cond
((pair? new) (or (f (car new)) (f (cdr new))))
((symbol? new)
(and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
(else #f)))))))
(define store-import-binding
(lambda (id token new-marks)
(define cons-id
(lambda (id x)
(if (not x) id (cons id x))))
(define weed ; remove existing binding for id, if any
(lambda (marks x)
(if (pair? x)
(if (same-marks? (id-marks (car x)) marks)
(weed marks (cdr x))
(cons-id (car x) (weed marks (cdr x))))
(and x (not (same-marks? (id-marks x) marks)) x))))
(let ((id (if (null? new-marks)
id
(make-syntax-object (id-sym-name id)
(make-wrap
(join-marks new-marks (id-marks id))
(id-subst id))))))
(let ((sym (id-sym-name id)))
; no need to record bindings mapping symbol to self, since this
; assumed by default.
(unless (eq? id sym)
(let ((marks (id-marks id)))
(update-import-binding! sym token
(lambda (old-binding)
(let ((x (weed marks old-binding)))
(cons-id
(if (same-marks? marks (wrap-marks top-wrap))
; need full id only if more than top-marked.
(resolved-id-var-name id)
id)
x))))))))))
;;; make-binding-wrap creates vector-based ribcages
(define make-binding-wrap
(lambda (ids labels w)
(if (null? ids)
w
(make-wrap
(wrap-marks w)
(cons
(let ((labelvec (list->vector labels)))
(let ((n (vector-length labelvec)))
(let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
(let f ((ids ids) (i 0))
(unless (null? ids)
(let-values (((symname marks) (id-sym-name&marks (car ids) w)))
(vector-set! symnamevec i symname)
(vector-set! marksvec i marks)
(f (cdr ids) (fx+ i 1)))))
(make-ribcage symnamevec marksvec labelvec))))
(wrap-subst w))))))
;;; resolved ids contain no unnecessary substitutions or marks. they are
;;; used essentially as indirects or aliases in modules interfaces.
(define make-resolved-id
(lambda (fromsym marks tosym)
(make-syntax-object fromsym
(make-wrap marks
(list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
(define id->resolved-id
(lambda (id)
(let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
(unless tosym
(syntax-error id "identifier not visible for export"))
(make-resolved-id (id-sym-name id) marks tosym))))
(define resolved-id-var-name
(lambda (id)
(vector-ref
(ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
0)))
;;; Scheme's append should not copy the first argument if the second is
;;; nil, but it does, so we define a smart version here.
(define smart-append
(lambda (m1 m2)
(if (null? m2)
m1
(append m1 m2))))
(define join-wraps
(lambda (w1 w2)
(let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
(if (null? m1)
(if (null? s1)
w2
(make-wrap
(wrap-marks w2)
(join-subst s1 (wrap-subst w2))))
(make-wrap
(join-marks m1 (wrap-marks w2))
(join-subst s1 (wrap-subst w2)))))))
(define join-marks
(lambda (m1 m2)
(smart-append m1 m2)))
(define join-subst
(lambda (s1 s2)
(smart-append s1 s2)))
(define same-marks?
(lambda (x y)
(or (eq? x y)
(and (not (null? x))
(not (null? y))
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
(define diff-marks
(lambda (m1 m2)
(let ((n1 (length m1)) (n2 (length m2)))
(let f ((n1 n1) (m1 m1))
(cond
((> n1 n2) (cons (car m1) (f (- n1 1) (cdr m1))))
((equal? m1 m2) '())
(else (error 'sc-expand
"internal error in diff-marks: ~s is not a tail of ~s"
m1 m2)))))))
(module (top-id-bound-var-name top-id-free-var-name)
;; top-id-bound-var-name is used to look up or establish new top-level
;; substitutions, while top-id-free-var-name is used to look up existing
;; (possibly implicit) substitutions. Implicit substitutions exist
;; for top-marked names in all environments, but we represent them
;; explicitly only on demand.
;;
;; In both cases, we first look for an existing substitution for sym
;; and the given marks. If we find one, we return it. Otherwise, we
;; extend the appropriate top-level environment
;;
;; For top-id-bound-var-name, we extend the environment with a substition
;; keyed by the given marks, so that top-level definitions introduced by
;; a macro are distinct from other top-level definitions for the same
;; name. For example, if macros a and b both introduce definitions and
;; bound references to identifier x, the two x's should be different,
;; i.e., keyed by their own marks.
;;
;; For top-id-free-var-name, we extend the environment with a substition
;; keyed by the top marks, since top-level free identifier references
;; should refer to the existing implicit (top-marked) substitution. For
;; example, if macros a and b both introduce free references to identifier
;; x, they should both refer to the same (global, unmarked) x.
;;
;; If the environment is *top*, we map a symbol to itself
(define leave-implicit? (lambda (token) (eq? token '*top*)))
(define new-binding
(lambda (sym marks token)
(let ((loc (if (and (leave-implicit? token)
(same-marks? marks (wrap-marks top-wrap)))
sym
(generate-id sym))))
(let ((id (make-resolved-id sym marks loc)))
(store-import-binding id token '())
(values loc id)))))
(define top-id-bound-var-name
; should be called only when top-ribcage is mutable
(lambda (sym marks top-ribcage)
(let ((token (top-ribcage-key top-ribcage)))
(cond
((lookup-import-binding-name sym marks token '()) =>
(lambda (id)
(if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
(if (read-only-binding? id)
(new-binding sym marks token)
(values id (make-resolved-id sym marks id)))
(values (resolved-id-var-name id) id))))
(else (new-binding sym marks token))))))
(define top-id-free-var-name
(lambda (sym marks top-ribcage)
(let ((token (top-ribcage-key top-ribcage)))
(cond
((lookup-import-binding-name sym marks token '()) =>
(lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
((and (top-ribcage-mutable? top-ribcage)
(same-marks? marks (wrap-marks top-wrap)))
(let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
sym))
(else #f))))))
(define id-var-name-loc&marks
(lambda (id w)
(define search
(lambda (sym subst marks)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(cond
((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
((ribcage? fst)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
(search-vector-rib sym subst marks symnames fst)
(search-list-rib sym subst marks symnames fst))))
((top-ribcage? fst)
(cond
((top-id-free-var-name sym marks fst) =>
(lambda (var-name) (values var-name marks)))
(else (search sym (cdr subst) marks))))
(else
(error 'sc-expand
"internal error in id-var-name-loc&marks: improper subst ~s"
subst)))))))
(define search-list-rib
(lambda (sym subst marks symnames ribcage)
(let f ((symnames symnames) (i 0))
(if (null? symnames)
(search sym (cdr subst) marks)
(let ((x (car symnames)))
(cond
((and (eq? x sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
(values (list-ref (ribcage-labels ribcage) i) marks))
((import-interface? x)
(let ((iface (import-interface-interface x))
(new-marks (import-interface-new-marks x)))
(cond
((interface-token iface) =>
(lambda (token)
(cond
((lookup-import-binding-name sym marks token new-marks) =>
(lambda (id)
(values
(if (symbol? id) id (resolved-id-var-name id))
marks)))
(else (f (cdr symnames) i)))))
(else
(let* ((ie (interface-exports iface))
(n (vector-length ie)))
(let g ((j 0))
(if (fx= j n)
(f (cdr symnames) i)
(let ((id (vector-ref ie j)))
(let ((id.sym (id-sym-name id))
(id.marks (join-marks new-marks (id-marks id))))
(if (help-bound-id=? id.sym id.marks sym marks)
(values (lookup-import-label id) marks)
(g (fx+ j 1))))))))))))
((and (eq? x barrier-marker)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
(values #f marks))
(else (f (cdr symnames) (fx+ i 1)))))))))
(define search-vector-rib
(lambda (sym subst marks symnames ribcage)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
((fx= i n) (search sym (cdr subst) marks))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
(values (vector-ref (ribcage-labels ribcage) i) marks))
(else (f (fx+ i 1))))))))
(cond
((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
((syntax-object? id)
(let ((sym (unannotate (syntax-object-expression id)))
(w1 (syntax-object-wrap id)))
(let-values (((name marks) (search sym (wrap-subst w)
(join-marks
(wrap-marks w)
(wrap-marks w1)))))
(if name
(values name marks)
(search sym (wrap-subst w1) marks)))))
((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
(else (error-hook 'id-var-name "invalid id" id)))))
(define id-var-name&marks
; this version follows indirect labels
(lambda (id w)
(let-values (((label marks) (id-var-name-loc&marks id w)))
(values (if (indirect-label? label) (get-indirect-label label) label) marks))))
(define id-var-name-loc
; this version doesn't follow indirect labels
(lambda (id w)
(let-values (((label marks) (id-var-name-loc&marks id w)))
label)))
(define id-var-name
; this version follows indirect labels
(lambda (id w)
(let-values (((label marks) (id-var-name-loc&marks id w)))
(if (indirect-label? label) (get-indirect-label label) label))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
(define free-id=?
(lambda (i j)
(and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
(eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
(define literal-id=?
(lambda (id literal)
(and (eq? (id-sym-name id) (id-sym-name literal))
(let ((n-id (id-var-name id empty-wrap))
(n-literal (id-var-name literal empty-wrap)))
(or (eq? n-id n-literal)
(and (or (not n-id) (symbol? n-id))
(or (not n-literal) (symbol? n-literal))))))))
;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;;; long as the missing portion of the wrap is common to both of the ids
;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
(define help-bound-id=?
(lambda (i.sym i.marks j.sym j.marks)
(and (eq? i.sym j.sym)
(same-marks? i.marks j.marks))))
(define bound-id=?
(lambda (i j)
(help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;;; as long as the missing portion of the wrap is common to all of the
;;; ids.
(define valid-bound-ids?
(lambda (ids)
(and (let all-ids? ((ids ids))
(or (null? ids)
(and (id? (car ids))
(all-ids? (cdr ids)))))
(distinct-bound-ids? ids))))
;;; distinct-bound-ids? expects a list of ids and returns #t if there are
;;; no duplicates. It is quadratic on the length of the id list; long
;;; lists could be sorted to make it more efficient. distinct-bound-ids?
;;; may be passed unwrapped (or partially wrapped) ids as long as the
;;; missing portion of the wrap is common to all of the ids.
(define distinct-bound-ids?
(lambda (ids)
(let distinct? ((ids ids))
(or (null? ids)
(and (not (bound-id-member? (car ids) (cdr ids)))
(distinct? (cdr ids)))))))
(define invalid-ids-error
; find first bad one and complain about it
(lambda (ids exp class)
(let find ((ids ids) (gooduns '()))
(if (null? ids)
(syntax-error exp) ; shouldn't happen
(if (id? (car ids))
(if (bound-id-member? (car ids) gooduns)
(syntax-error (car ids) "duplicate " class)
(find (cdr ids) (cons (car ids) gooduns)))
(syntax-error (car ids) "invalid " class))))))
(define bound-id-member?
(lambda (x list)
(and (not (null? list))
(or (bound-id=? x (car list))
(bound-id-member? x (cdr list))))))
;;; wrapping expressions and identifiers
(define wrap
(lambda (x w)
(cond
((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
((syntax-object? x)
(make-syntax-object
(syntax-object-expression x)
(join-wraps w (syntax-object-wrap x))))
((null? x) x)
(else (make-syntax-object x w)))))
(define source-wrap
(lambda (x w ae)
(wrap (if (annotation? ae)
(begin
(unless (eq? (annotation-expression ae) x)
(error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
ae)
x)
w)))
;;; expanding
(define chi-when-list
(lambda (when-list w)
; when-list is syntax'd version of list of situations
(map (lambda (x)
(cond
((literal-id=? x (syntax compile)) 'compile)
((literal-id=? x (syntax load)) 'load)
((literal-id=? x (syntax visit)) 'visit)
((literal-id=? x (syntax revisit)) 'revisit)
((literal-id=? x (syntax eval)) 'eval)
(else (syntax-error (wrap x w) "invalid eval-when situation"))))
when-list)))
;;; syntax-type returns five values: type, value, e, w, and ae. The first
;;; two are described in the table below.
;;;
;;; type value explanation
;;; -------------------------------------------------------------------
;;; alias none alias keyword
;;; alias-form none alias expression
;;; begin none begin keyword
;;; begin-form none begin expression
;;; call none any other call
;;; constant none self-evaluating datum
;;; core procedure core form (including singleton)
;;; define none define keyword
;;; define-form none variable definition
;;; define-syntax none define-syntax keyword
;;; define-syntax-form none syntax definition
;;; displaced-lexical none displaced lexical identifier
;;; eval-when none eval-when keyword
;;; eval-when-form none eval-when form
;;; global name global variable reference
;;; $import none $import keyword
;;; $import-form none $import form
;;; lexical name lexical variable reference
;;; lexical-call name call to lexical variable
;;; local-syntax rec? letrec-syntax/let-syntax keyword
;;; local-syntax-form rec? syntax definition
;;; meta none meta keyword
;;; meta-form none meta form
;;; meta-variable name meta variable
;;; $module none $module keyword
;;; $module-form none $module definition
;;; syntax level pattern variable
;;; other none anything else
;;;
;;; For all forms, e is the form, w is the wrap for e. and ae is the
;;; (possibly) source-annotated form.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above.
(define syntax-type
(lambda (e r w ae rib)
(cond
((symbol? e)
(let* ((n (id-var-name e w))
(b (lookup n r))
(type (binding-type b)))
(case type
((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
(else (values type (binding-value b) e w ae)))))
((pair? e)
(let ((first (car e)))
(if (id? first)
(let* ((n (id-var-name first w))
(b (lookup n r))
(type (binding-type b)))
(case type
((lexical) (values 'lexical-call (binding-value b) e w ae))
((macro macro!)
(syntax-type (chi-macro (binding-value b) e r w ae rib)
r empty-wrap #f rib))
((core) (values type (binding-value b) e w ae))
((begin) (values 'begin-form #f e w ae))
((alias) (values 'alias-form #f e w ae))
((define) (values 'define-form #f e w ae))
((define-syntax) (values 'define-syntax-form #f e w ae))
((set!) (chi-set! e r w ae rib))
(($module-key) (values '$module-form #f e w ae))
(($import) (values '$import-form #f e w ae))
((eval-when) (values 'eval-when-form #f e w ae))
((meta) (values 'meta-form #f e w ae))
((local-syntax)
(values 'local-syntax-form (binding-value b) e w ae))
(else (values 'call #f e w ae))))
(values 'call #f e w ae))))
((syntax-object? e)
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
#f rib))
((annotation? e)
(syntax-type (annotation-expression e) r w e rib))
((self-evaluating? e) (values 'constant #f e w ae))
(else (values 'other #f e w ae)))))
(define chi-top*
(lambda (e r w ctem rtem meta? top-ribcage)
(let ((meta-residuals '()))
(define meta-residualize!
(lambda (x)
(set! meta-residuals
(cons x meta-residuals))))
(let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
(build-sequence no-source
(reverse (cons e meta-residuals)))))))
(define chi-top-sequence
(lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
(build-sequence ae
(let dobody ((body body))
(if (null? body)
'()
(let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
(cons first (dobody (cdr body)))))))))
(define chi-top
(lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
(let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
(case type
((begin-form)
(let ((forms (parse-begin e w ae #t)))
(if (null? forms)
(chi-void)
(chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
((local-syntax-form)
(let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
; mr should be same as r here
(chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
((eval-when-form)
(let-values (((when-list forms) (parse-eval-when e w ae)))
(let ((ctem (update-mode-set when-list ctem))
(rtem (update-mode-set when-list rtem)))
(if (and (null? ctem) (null? rtem))
(chi-void)
(chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
((define-syntax-form)
(let-values (((id rhs w) (parse-define-syntax e w ae)))
(let ((id (wrap id w)))
(when (displaced-lexical? id r) (displaced-lexical-error id))
(unless (top-ribcage-mutable? top-ribcage)
(syntax-error (source-wrap e w ae)
"invalid definition in read-only environment"))
(let ((sym (id-sym-name id)))
(let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
(unless (eq? (id-var-name id empty-wrap) valsym)
(syntax-error (source-wrap e w ae)
"definition not permitted"))
(when (read-only-binding? valsym)
(syntax-error (source-wrap e w ae)
"invalid definition of read-only identifier"))
(ct-eval/residualize2 ctem
(lambda ()
(build-cte-install
bound-id
(chi rhs r r w #t)
(top-ribcage-key top-ribcage)))))))))
((define-form)
(let-values (((id rhs w) (parse-define e w ae)))
(let ((id (wrap id w)))
(when (displaced-lexical? id r) (displaced-lexical-error id))
(unless (top-ribcage-mutable? top-ribcage)
(syntax-error (source-wrap e w ae)
"invalid definition in read-only environment"))
(let ((sym (id-sym-name id)))
(let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
(unless (eq? (id-var-name id empty-wrap) valsym)
(syntax-error (source-wrap e w ae)
"definition not permitted"))
(when (read-only-binding? valsym)
(syntax-error (source-wrap e w ae)
"invalid definition of read-only identifier"))
(if meta?
(ct-eval/residualize2 ctem
(lambda ()
(build-sequence no-source
(list
(build-cte-install bound-id
(build-data no-source (make-binding 'meta-variable valsym))
(top-ribcage-key top-ribcage))
(build-global-definition ae valsym (chi rhs r r w #t))))))
; make sure compile-time definitions occur before we
; expand the run-time code
(let ((x (ct-eval/residualize2 ctem
(lambda ()
(build-cte-install
bound-id
(build-data no-source (make-binding 'global valsym))
(top-ribcage-key top-ribcage))))))
(build-sequence no-source
(list
x
(rt-eval/residualize rtem
(lambda ()
(build-global-definition ae valsym (chi rhs r r w #f)))))))))
))))
(($module-form)
(let ((ribcage (make-empty-ribcage)))
(let-values (((orig id exports forms)
(parse-module e w ae
(make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
(when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
(unless (top-ribcage-mutable? top-ribcage)
(syntax-error orig
"invalid definition in read-only environment"))
(chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
(($import-form)
(let-values (((orig only? mid) (parse-import e w ae)))
(unless (top-ribcage-mutable? top-ribcage)
(syntax-error orig
"invalid definition in read-only environment"))
(ct-eval/residualize2 ctem
(lambda ()
(let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
(case (binding-type binding)
(($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
((displaced-lexical) (displaced-lexical-error mid))
(else (syntax-error mid "unknown module"))))))))
((alias-form)
(let-values (((new-id old-id) (parse-alias e w ae)))
(let ((new-id (wrap new-id w)))
(when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
(unless (top-ribcage-mutable? top-ribcage)
(syntax-error (source-wrap e w ae)
"invalid definition in read-only environment"))
(let ((sym (id-sym-name new-id)))
(let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
(unless (eq? (id-var-name new-id empty-wrap) valsym)
(syntax-error (source-wrap e w ae)
"definition not permitted"))
(when (read-only-binding? valsym)
(syntax-error (source-wrap e w ae)
"invalid definition of read-only identifier"))
(ct-eval/residualize2 ctem
(lambda ()
(build-cte-install
(make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
(build-data no-source (make-binding 'do-alias #f))
(top-ribcage-key top-ribcage)))))))))
(else
(when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
(if meta?
(let ((x (chi-expr type value e r r w ae #t)))
(top-level-eval-hook x)
(ct-eval/residualize3 ctem void (lambda () x)))
(rt-eval/residualize rtem
(lambda ()
(chi-expr type value e r r w ae #f)))))))))
(define flatten-exports
(lambda (exports)
(let loop ((exports exports) (ls '()))
(if (null? exports)
ls
(loop (cdr exports)
(if (pair? (car exports))
(loop (car exports) ls)
(cons (car exports) ls)))))))
(define-structure (interface marks exports token))
;; leaves interfaces unresolved so that indirect labels can be followed.
;; (can't resolve until indirect labels have their final value)
(define make-unresolved-interface
; trim out implicit exports
(lambda (mid exports)
(make-interface
(wrap-marks (syntax-object-wrap mid))
(list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
#f)))
(define make-resolved-interface
; trim out implicit exports & resolve others to actual top-level symbol
(lambda (mid exports token)
(make-interface
(wrap-marks (syntax-object-wrap mid))
(list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
token)))
(define-structure (module-binding type id label imps val exported))
(define create-module-binding
(lambda (type id label imps val)
(make-module-binding type id label imps val #f)))
;;; frobs represent body forms
(define-structure (frob e meta?))
(define chi-top-module
(lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
(let ((fexports (flatten-exports exports)))
(let-values (((r mr bindings inits)
(chi-external ribcage orig
(map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
meta-residualize!)))
; identify exported identifiers, create ctdefs
(let process-exports ((fexports fexports) (ctdefs (lambda () '())))
(if (null? fexports)
; remaining bindings are either identified global vars,
; local vars, or local compile-time entities
; dts: type (local/global)
; dvs & des: define lhs & rhs
(let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
(if (null? bs)
(let ((des (chi-frobs des r mr #f))
(inits (chi-frobs inits r mr #f)))
(build-sequence no-source
(append
; we wait to establish global compile-time definitions so that
; expansion of des use local versions of modules and macros
; in case ctem tells us not to eval ctdefs now. this means that
; local code can use exported compile-time values (modules, macros,
; meta variables) just as it can unexported ones.
(ctdefs)
(list
(ct-eval/residualize2 ctem
(lambda ()
(let ((sym (id-sym-name id)))
(let* ((token (generate-id sym))
(b (build-data no-source
(make-binding '$module
(make-resolved-interface id exports token)))))
(let-values (((valsym bound-id)
(top-id-bound-var-name sym
(wrap-marks (syntax-object-wrap id))
top-ribcage)))
(unless (eq? (id-var-name id empty-wrap) valsym)
(syntax-error orig
"definition not permitted"))
(when (read-only-binding? valsym)
(syntax-error orig
"invalid definition of read-only identifier"))
(build-cte-install bound-id b
(top-ribcage-key top-ribcage)))))))
(rt-eval/residualize rtem
(lambda ()
(build-top-module no-source dts dvs des
(if (null? inits)
(chi-void)
(build-sequence no-source
(append inits (list (chi-void))))))))))))
(let ((b (car bs)) (bs (cdr bs)))
(let ((t (module-binding-type b)))
(case (module-binding-type b)
((define-form)
(let ((label (get-indirect-label (module-binding-label b))))
(if (module-binding-exported b)
(let ((var (module-binding-id b)))
(process-locals bs r (cons 'global dts) (cons label dvs)
(cons (module-binding-val b) des)))
(let ((var (gen-var (module-binding-id b))))
(process-locals bs
; add lexical bindings only to run-time environment
(extend-env label (make-binding 'lexical var) r)
(cons 'local dts) (cons var dvs)
(cons (module-binding-val b) des))))))
((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
(else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
(let ((id (car fexports)) (fexports (cdr fexports)))
(let loop ((bs bindings))
(if (null? bs)
; must be rexport from an imported module
(process-exports fexports ctdefs)
(let ((b (car bs)) (bs (cdr bs)))
; following formerly used bound-id=?, but free-id=? can prevent false positives
; and is okay since the substitutions have already been applied
(if (free-id=? (module-binding-id b) id)
(if (module-binding-exported b)
(process-exports fexports ctdefs)
(let* ((t (module-binding-type b))
(label (module-binding-label b))
(imps (module-binding-imps b))
(fexports (append imps fexports)))
(set-module-binding-exported! b #t)
(case t
((define-form)
(let ((sym (generate-id (id-sym-name id))))
(set-indirect-label! label sym)
(process-exports fexports ctdefs)))
((ctdefine-form)
(let ((b (module-binding-val b)))
(process-exports fexports
(lambda ()
(let ((sym (binding-value b)))
(set-indirect-label! label sym)
(cons (ct-eval/residualize3 ctem
(lambda () (put-cte-hook sym b))
(lambda () (build-cte-install sym (build-data no-source b) #f)))
(ctdefs)))))))
((define-syntax-form)
(let ((sym (generate-id (id-sym-name id))))
(process-exports fexports
(lambda ()
(let ((local-label (get-indirect-label label)))
(set-indirect-label! label sym)
(cons
(ct-eval/residualize3 ctem
(lambda () (put-cte-hook sym (car (module-binding-val b))))
(lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
(ctdefs)))))))
(($module-form)
(let ((sym (generate-id (id-sym-name id)))
(exports (module-binding-val b)))
(process-exports (append (flatten-exports exports) fexports)
(lambda ()
(set-indirect-label! label sym)
(let ((rest (ctdefs))) ; set indirect labels before resolving
(let ((x (make-binding '$module (make-resolved-interface id exports sym))))
(cons (ct-eval/residualize3 ctem
(lambda () (put-cte-hook sym x))
(lambda () (build-cte-install sym (build-data no-source x) #f)))
rest)))))))
((alias-form)
(process-exports
fexports
(lambda ()
(let ((rest (ctdefs))) ; set indirect labels before resolving
(when (indirect-label? label)
(unless (symbol? (get-indirect-label label))
(syntax-error (module-binding-id b) "unexported target of alias")))
rest))))
(else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
(loop bs))))))))))))
(define id-set-diff
(lambda (exports defs)
(cond
((null? exports) '())
((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
(else (cons (car exports) (id-set-diff (cdr exports) defs))))))
(define check-module-exports
; After processing the definitions of a module this is called to verify that the
; module has defined or imported each exported identifier. Because ids in fexports are
; wrapped with the given ribcage, they will contain substitutions for anything defined
; or imported here. These subsitutions can be used by do-import! and do-import-top! to
; provide access to reexported bindings, for example.
(lambda (source-exp fexports ids)
(define defined?
(lambda (e ids)
(ormap (lambda (x)
(if (import-interface? x)
(let ((x.iface (import-interface-interface x))
(x.new-marks (import-interface-new-marks x)))
(cond
((interface-token x.iface) =>
(lambda (token)
(lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
(else
(let ((v (interface-exports x.iface)))
(let lp ((i (fx- (vector-length v) 1)))
(and (fx>= i 0)
(or (let ((id (vector-ref v i)))
(help-bound-id=?
(id-sym-name id)
(join-marks x.new-marks (id-marks id))
(id-sym-name e) (id-marks e)))
(lp (fx- i 1)))))))))
(bound-id=? e x)))
ids)))
(let loop ((fexports fexports) (missing '()))
(if (null? fexports)
(unless (null? missing)
(syntax-error (car missing)
(if (= (length missing) 1)
"missing definition for export"
"missing definition for multiple exports, including")))
(let ((e (car fexports)) (fexports (cdr fexports)))
(if (defined? e ids)
(loop fexports missing)
(loop fexports (cons e missing))))))))
(define check-defined-ids
(lambda (source-exp ls)
(define vfold
(lambda (v p cls)
(let ((len (vector-length v)))
(let lp ((i 0) (cls cls))
(if (fx= i len)
cls
(lp (fx+ i 1) (p (vector-ref v i) cls)))))))
(define conflicts
(lambda (x y cls)
(if (import-interface? x)
(let ((x.iface (import-interface-interface x))
(x.new-marks (import-interface-new-marks x)))
(if (import-interface? y)
(let ((y.iface (import-interface-interface y))
(y.new-marks (import-interface-new-marks y)))
(let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
(if (fx> (vector-length xe) (vector-length ye))
(vfold ye
(lambda (id cls)
(id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
(vfold xe
(lambda (id cls)
(id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
(id-iface-conflicts y '() x.iface x.new-marks cls)))
(if (import-interface? y)
(let ((y.iface (import-interface-interface y))
(y.new-marks (import-interface-new-marks y)))
(id-iface-conflicts x '() y.iface y.new-marks cls))
(if (bound-id=? x y) (cons x cls) cls)))))
(define id-iface-conflicts
(lambda (id id.new-marks iface iface.new-marks cls)
(let ((id.sym (id-sym-name id))
(id.marks (join-marks id.new-marks (id-marks id))))
(cond
((interface-token iface) =>
(lambda (token)
(if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
(cons id cls)
cls)))
(else
(vfold (interface-exports iface)
(lambda (*id cls)
(let ((*id.sym (id-sym-name *id))
(*id.marks (join-marks iface.new-marks (id-marks *id))))
(if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
(cons *id cls)
cls)))
cls))))))
(unless (null? ls)
(let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
(if (null? ls)
(unless (null? cls)
(let ((cls (syntax-object->datum cls)))
(syntax-error source-exp "duplicate definition for "
(symbol->string (car cls))
" in")))
(let lp2 ((ls2 ls) (cls cls))
(if (null? ls2)
(lp (car ls) (cdr ls) cls)
(lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
(define chi-external
(lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
(define return
(lambda (r mr bindings ids inits)
(check-defined-ids source-exp ids)
(check-module-exports source-exp fexports ids)
(values r mr bindings inits)))
(define get-implicit-exports
(lambda (id)
(let f ((exports exports))
(if (null? exports)
'()
(if (and (pair? (car exports)) (bound-id=? id (caar exports)))
(flatten-exports (cdar exports))
(f (cdr exports)))))))
(define update-imp-exports
(lambda (bindings exports)
(let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
(map (lambda (b)
(let ((id (module-binding-id b)))
(if (not (bound-id-member? id exports))
b
(create-module-binding
(module-binding-type b)
id
(module-binding-label b)
(append (get-implicit-exports id) (module-binding-imps b))
(module-binding-val b)))))
bindings))))
(let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
(if (null? body)
(return r mr bindings ids inits)
(let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
(let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
(case type
((define-form)
(let-values (((id rhs w) (parse-define e w ae)))
(let* ((id (wrap id w))
(label (gen-indirect-label))
(imps (get-implicit-exports id)))
(extend-ribcage! ribcage id label)
(cond
(meta?
(let* ((sym (generate-id (id-sym-name id)))
(b (make-binding 'meta-variable sym)))
; add meta bindings only to meta environment
(let ((mr (extend-env (get-indirect-label label) b mr)))
(let ((exp (chi rhs mr mr w #t)))
(define-top-level-value-hook sym (top-level-eval-hook exp))
(meta-residualize!
(ct-eval/residualize3 ctem
void
(lambda () (build-global-definition no-source sym exp))))
(parse (cdr body) r mr
(cons id ids)
(cons (create-module-binding 'ctdefine-form id label imps b) bindings)
inits
#f)))))
(else
(parse (cdr body) r mr
(cons id ids)
(cons (create-module-binding type id label
imps (make-frob (wrap rhs w) meta?))
bindings)
inits
#f))))))
((define-syntax-form)
(let-values (((id rhs w) (parse-define-syntax e w ae)))
(let* ((id (wrap id w))
(label (gen-indirect-label))
(imps (get-implicit-exports id))
(exp (chi rhs mr mr w #t)))
(extend-ribcage! ribcage id label)
(let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
(parse (cdr body)
(extend-env l b r)
(extend-env l b mr)
(cons id ids)
(cons (create-module-binding type id label imps (cons b exp))
bindings)
inits
#f)))))
(($module-form)
(let* ((*ribcage (make-empty-ribcage))
(*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
(let-values (((orig id *exports forms) (parse-module e w ae *w)))
(let-values (((r mr *bindings *inits)
(chi-external *ribcage orig
(map (lambda (d) (make-frob d meta?)) forms)
r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
(let ((iface (make-unresolved-interface id *exports))
(bindings (append *bindings bindings))
(inits (append inits *inits))
(label (gen-indirect-label))
(imps (get-implicit-exports id)))
(extend-ribcage! ribcage id label)
(let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
(parse (cdr body)
(extend-env l b r)
(extend-env l b mr)
(cons id ids)
(cons (create-module-binding type id label imps *exports) bindings)
inits
#f)))))))
(($import-form)
(let-values (((orig only? mid) (parse-import e w ae)))
(let ((mlabel (id-var-name mid empty-wrap)))
(let ((binding (lookup mlabel r)))
(case (binding-type binding)
(($module)
(let* ((iface (binding-value binding))
(import-iface (make-import-interface iface (import-mark-delta mid iface))))
(when only? (extend-ribcage-barrier! ribcage mid))
(do-import! import-iface ribcage)
(parse (cdr body) r mr
(cons import-iface ids)
(update-imp-exports bindings (vector->list (interface-exports iface)))
inits
#f)))
((displaced-lexical) (displaced-lexical-error mid))
(else (syntax-error mid "unknown module")))))))
((alias-form)
(let-values (((new-id old-id) (parse-alias e w ae)))
(let* ((new-id (wrap new-id w))
(label (id-var-name-loc old-id w))
(imps (get-implicit-exports new-id)))
(extend-ribcage! ribcage new-id label)
(parse (cdr body) r mr
(cons new-id ids)
(cons (create-module-binding type new-id label imps #f)
bindings)
inits
#f))))
((begin-form)
(parse (let f ((forms (parse-begin e w ae #t)))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
r mr ids bindings inits #f))
((eval-when-form)
(let-values (((when-list forms) (parse-eval-when e w ae)))
(parse (if (memq 'eval when-list) ; mode set is implicitly (E)
(let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
(cdr body))
r mr ids bindings inits #f)))
((meta-form)
(parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
(cdr body))
r mr ids bindings inits #t))
((local-syntax-form)
(let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
r mr ids bindings inits #f)))
(else ; found an init expression
(when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
(let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
(if (or (null? body) (not (frob-meta? (car body))))
(return r mr bindings ids (append inits body))
(begin
; expand and eval meta inits for effect only
(let ((x (chi-meta-frob (car body) mr)))
(top-level-eval-hook x)
(meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
(f (cdr body)))))))))))))
(define vmap
(lambda (fn v)
(do ((i (fx- (vector-length v) 1) (fx- i 1))
(ls '() (cons (fn (vector-ref v i)) ls)))
((fx< i 0) ls))))
(define vfor-each
(lambda (fn v)
(let ((len (vector-length v)))
(do ((i 0 (fx+ i 1)))
((fx= i len))
(fn (vector-ref v i))))))
(define do-top-import
(lambda (import-only? top-ribcage mid token)
; silently treat import-only like regular import at top level
(build-cte-install mid
(build-data no-source
(make-binding 'do-import token))
(top-ribcage-key top-ribcage))))
(define update-mode-set
(let ((table
'((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
(C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
(V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
(R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
(E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
(lambda (when-list mode-set)
(define remq
(lambda (x ls)
(if (null? ls)
'()
(if (eq? (car ls) x)
(remq x (cdr ls))
(cons (car ls) (remq x (cdr ls)))))))
(remq '-
(apply append
(map (lambda (m)
(let ((row (cdr (assq m table))))
(map (lambda (s) (cdr (assq s row)))
when-list)))
mode-set))))))
(define initial-mode-set
(lambda (when-list compiling-a-file)
(apply append
(map (lambda (s)
(if compiling-a-file
(case s
((compile) '(C))
((load) '(L))
((visit) '(V))
((revisit) '(R))
(else '()))
(case s
((eval) '(E))
(else '()))))
when-list))))
(define rt-eval/residualize
(lambda (rtem thunk)
(if (memq 'E rtem)
(thunk)
(let ((thunk (if (memq 'C rtem)
(let ((x (thunk)))
(top-level-eval-hook x)
(lambda () x))
thunk)))
(if (memq 'V rtem)
(if (or (memq 'L rtem) (memq 'R rtem))
(thunk) ; visit-revisit
(build-visit-only (thunk)))
(if (or (memq 'L rtem) (memq 'R rtem))
(build-revisit-only (thunk))
(chi-void)))))))
(define ct-eval/residualize2
(lambda (ctem thunk)
(let ((t #f))
(ct-eval/residualize3 ctem
(lambda ()
(unless t (set! t (thunk)))
(top-level-eval-hook t))
(lambda () (or t (thunk)))))))
(define ct-eval/residualize3
(lambda (ctem eval-thunk residualize-thunk)
(if (memq 'E ctem)
(begin (eval-thunk) (chi-void))
(begin
(when (memq 'C ctem) (eval-thunk))
(if (memq 'R ctem)
(if (or (memq 'L ctem) (memq 'V ctem))
(residualize-thunk) ; visit-revisit
(build-revisit-only (residualize-thunk)))
(if (or (memq 'L ctem) (memq 'V ctem))
(build-visit-only (residualize-thunk))
(chi-void)))))))
(define chi-frobs
(lambda (frob* r mr m?)
(map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
(define chi-meta-frob
(lambda (x mr)
(chi (frob-e x) mr mr empty-wrap #t)))
(define chi-sequence
(lambda (body r mr w ae m?)
(build-sequence ae
(let dobody ((body body))
(if (null? body)
'()
(let ((first (chi (car body) r mr w m?)))
(cons first (dobody (cdr body)))))))))
(define chi
(lambda (e r mr w m?)
(let-values (((type value e w ae) (syntax-type e r w no-source #f)))
(chi-expr type value e r mr w ae m?))))
(define chi-expr
(lambda (type value e r mr w ae m?)
(case type
((lexical)
(build-lexical-reference 'value ae value))
((core) (value e r mr w ae m?))
((lexical-call)
(chi-application
(build-lexical-reference 'fun
(let ((x (car e)))
(if (syntax-object? x) (syntax-object-expression x) x))
value)
e r mr w ae m?))
((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
((global) (build-global-reference ae value))
((meta-variable)
(if m?
(build-global-reference ae value)
(displaced-lexical-error (source-wrap e w ae))))
((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
((local-syntax-form)
(let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
(chi-sequence forms r mr w ae m?)))
((eval-when-form)
(let-values (((when-list forms) (parse-eval-when e w ae)))
(if (memq 'eval when-list) ; mode set is implicitly (E)
(chi-sequence forms r mr w ae m?)
(chi-void))))
((meta-form)
(syntax-error (source-wrap e w ae) "invalid context for meta definition"))
((define-form)
(parse-define e w ae)
(syntax-error (source-wrap e w ae) "invalid context for definition"))
((define-syntax-form)
(parse-define-syntax e w ae)
(syntax-error (source-wrap e w ae) "invalid context for definition"))
(($module-form)
(let-values (((orig id exports forms) (parse-module e w ae w)))
(syntax-error orig "invalid context for definition")))
(($import-form)
(let-values (((orig only? mid) (parse-import e w ae)))
(syntax-error orig "invalid context for definition")))
((alias-form)
(parse-alias e w ae)
(syntax-error (source-wrap e w ae) "invalid context for definition"))
((syntax)
(syntax-error (source-wrap e w ae)
"reference to pattern variable outside syntax form"))
((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
(else (syntax-error (source-wrap e w ae))))))
(define chi-application
(lambda (x e r mr w ae m?)
(syntax-case e ()
((e0 e1 ...)
(build-application ae x
(map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
(_ (syntax-error (source-wrap e w ae))))))
(define chi-set!
(lambda (e r w ae rib)
(syntax-case e ()
((_ id val)
(id? (syntax id))
(let ((n (id-var-name (syntax id) w)))
(let ((b (lookup n r)))
(case (binding-type b)
((macro!)
(let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
(syntax-type (chi-macro (binding-value b)
`(,(syntax set!) ,id ,val)
r empty-wrap #f rib) r empty-wrap #f rib)))
(else
(values 'core
(lambda (e r mr w ae m?)
; repeat lookup in case we were first expression (init) in
; module or lambda body. we repeat id-var-name as well,
; although this is only necessary if we allow inits to
; preced definitions
(let ((val (chi (syntax val) r mr w m?))
(n (id-var-name (syntax id) w)))
(let ((b (lookup n r)))
(case (binding-type b)
((lexical) (build-lexical-assignment ae (binding-value b) val))
((global)
(let ((sym (binding-value b)))
(when (read-only-binding? n)
(syntax-error (source-wrap e w ae)
"invalid assignment to read-only variable"))
(build-global-assignment ae sym val)))
((meta-variable)
(if m?
(build-global-assignment ae (binding-value b) val)
(displaced-lexical-error (wrap (syntax id) w))))
((displaced-lexical)
(displaced-lexical-error (wrap (syntax id) w)))
(else (syntax-error (source-wrap e w ae)))))))
e w ae))))))
(_ (syntax-error (source-wrap e w ae))))))
(define chi-macro
(lambda (p e r w ae rib)
(define rebuild-macro-output
(lambda (x m)
(cond ((pair? x)
(cons (rebuild-macro-output (car x) m)
(rebuild-macro-output (cdr x) m)))
((syntax-object? x)
(let ((w (syntax-object-wrap x)))
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
(make-syntax-object (syntax-object-expression x)
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
(make-wrap (cdr ms) (cdr s))
(make-wrap (cons m ms)
(if rib
(cons rib (cons 'shift s))
(cons 'shift s))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
((fx= i n) v)
(vector-set! v i
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
(syntax-error (source-wrap e w ae)
"encountered raw symbol "
(symbol->string x)
" in output of macro"))
(else x))))
(rebuild-macro-output
(let ((out (p (source-wrap e (anti-mark w) ae))))
(if (procedure? out)
(out (lambda (id)
(unless (identifier? id)
(syntax-error id
"environment argument is not an identifier"))
(lookup (id-var-name id empty-wrap) r)))
out))
(new-mark))))
(define chi-body
(lambda (body outer-form r mr w m?)
(let* ((ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
(body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
(let-values (((r mr exprs ids vars vals inits)
(chi-internal ribcage outer-form body r mr m?)))
(when (null? exprs) (syntax-error outer-form "no expressions in body"))
(build-body no-source
(reverse vars) (chi-frobs (reverse vals) r mr m?)
(build-sequence no-source
(chi-frobs (append inits exprs) r mr m?)))))))
(define chi-internal
;; In processing the forms of the body, we create a new, empty wrap.
;; This wrap is augmented (destructively) each time we discover that
;; the next form is a definition. This is done:
;;
;; (1) to allow the first nondefinition form to be a call to
;; one of the defined ids even if the id previously denoted a
;; definition keyword or keyword for a macro expanding into a
;; definition;
;; (2) to prevent subsequent definition forms (but unfortunately
;; not earlier ones) and the first nondefinition form from
;; confusing one of the bound identifiers for an auxiliary
;; keyword; and
;; (3) so that we do not need to restart the expansion of the
;; first nondefinition form, which is problematic anyway
;; since it might be the first element of a begin that we
;; have just spliced into the body (meaning if we restarted,
;; we'd really need to restart with the begin or the macro
;; call that expanded into the begin, and we'd have to give
;; up allowing (begin <defn>+ <expr>+), which is itself
;; problematic since we don't know if a begin contains only
;; definitions until we've expanded it).
;;
;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
;; into the body.
;;
;; outer-form is fully wrapped w/source
(lambda (ribcage source-exp body r mr m?)
(define return
(lambda (r mr exprs ids vars vals inits)
(check-defined-ids source-exp ids)
(values r mr exprs ids vars vals inits)))
(let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
(if (null? body)
(return r mr body ids vars vals inits)
(let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
(let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
(case type
((define-form)
(let-values (((id rhs w) (parse-define e w ae)))
(let ((id (wrap id w)) (label (gen-label)))
(cond
(meta?
(let ((sym (generate-id (id-sym-name id))))
(extend-ribcage! ribcage id label)
; add meta bindings only to meta environment
; so visible only to next higher level and beyond
(let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
(define-top-level-value-hook sym
(top-level-eval-hook (chi rhs mr mr w #t)))
(parse (cdr body) r mr (cons id ids) vars vals inits #f))))
(else
(let ((var (gen-var id)))
(extend-ribcage! ribcage id label)
; add lexical bindings only to run-time environment
(parse (cdr body)
(extend-env label (make-binding 'lexical var) r)
mr
(cons id ids)
(cons var vars)
(cons (make-frob (wrap rhs w) meta?) vals)
inits
#f)))))))
((define-syntax-form)
(let-values (((id rhs w) (parse-define-syntax e w ae)))
(let ((id (wrap id w))
(label (gen-label))
(exp (chi rhs mr mr w #t)))
(extend-ribcage! ribcage id label)
(let ((b (defer-or-eval-transformer local-eval-hook exp)))
(parse (cdr body)
(extend-env label b r) (extend-env label b mr)
(cons id ids) vars vals inits #f)))))
(($module-form)
(let* ((*ribcage (make-empty-ribcage))
(*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
(let-values (((orig id exports forms) (parse-module e w ae *w)))
(let-values (((r mr *body *ids *vars *vals *inits)
(chi-internal *ribcage orig
(map (lambda (d) (make-frob d meta?)) forms)
r mr m?)))
; valid bound ids checked already by chi-internal
(check-module-exports source-exp (flatten-exports exports) *ids)
(let ((iface (make-resolved-interface id exports #f))
(vars (append *vars vars))
(vals (append *vals vals))
(inits (append inits *inits *body))
(label (gen-label)))
(extend-ribcage! ribcage id label)
(let ((b (make-binding '$module iface)))
(parse (cdr body)
(extend-env label b r) (extend-env label b mr)
(cons id ids) vars vals inits #f)))))))
(($import-form)
(let-values (((orig only? mid) (parse-import e w ae)))
(let ((mlabel (id-var-name mid empty-wrap)))
(let ((binding (lookup mlabel r)))
(case (binding-type binding)
(($module)
(let* ((iface (binding-value binding))
(import-iface (make-import-interface iface (import-mark-delta mid iface))))
(when only? (extend-ribcage-barrier! ribcage mid))
(do-import! import-iface ribcage)
(parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
((displaced-lexical) (displaced-lexical-error mid))
(else (syntax-error mid "unknown module")))))))
((alias-form)
(let-values (((new-id old-id) (parse-alias e w ae)))
(let ((new-id (wrap new-id w)))
(extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
(parse (cdr body) r mr
(cons new-id ids)
vars
vals
inits
#f))))
((begin-form)
(parse (let f ((forms (parse-begin e w ae #t)))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
r mr ids vars vals inits #f))
((eval-when-form)
(let-values (((when-list forms) (parse-eval-when e w ae)))
(parse (if (memq 'eval when-list) ; mode set is implicitly (E)
(let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
(cdr body))
r mr ids vars vals inits #f)))
((meta-form)
(parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
(cdr body))
r mr ids vars vals inits #t))
((local-syntax-form)
(let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (make-frob (wrap (car forms) w) meta?)
(f (cdr forms)))))
r mr ids vars vals inits #f)))
(else ; found a non-definition
(when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
(let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
(if (or (null? body) (not (frob-meta? (car body))))
(return r mr body ids vars vals inits)
(begin
; expand meta inits for effect only
(top-level-eval-hook (chi-meta-frob (car body) mr))
(f (cdr body)))))))))))))
(define import-mark-delta
; returns list of marks layered on top of module id beyond those
; cached in the interface
(lambda (mid iface)
(diff-marks (id-marks mid) (interface-marks iface))))
(define lookup-import-label
(lambda (id)
(let ((label (id-var-name-loc id empty-wrap)))
(unless label
(syntax-error id "exported identifier not visible"))
label)))
(define do-import!
(lambda (import-iface ribcage)
(let ((ie (interface-exports (import-interface-interface import-iface))))
(if (<= (vector-length ie) 20)
(let ((new-marks (import-interface-new-marks import-iface)))
(vfor-each
(lambda (id)
(import-extend-ribcage! ribcage new-marks id
(lookup-import-label id)))
ie))
(extend-ribcage-subst! ribcage import-iface)))))
(define parse-module
(lambda (e w ae *w)
(define listify
(lambda (exports)
(if (null? exports)
'()
(cons (syntax-case (car exports) ()
((ex ...) (listify (syntax (ex ...))))
(x (if (id? (syntax x))
(wrap (syntax x) *w)
(syntax-error (source-wrap e w ae)
"invalid exports list in"))))
(listify (cdr exports))))))
(syntax-case e ()
((_ orig mid (ex ...) form ...)
(id? (syntax mid))
; id receives old wrap so it won't be confused with id of same name
; defined within the module
(values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-import
(lambda (e w ae)
(syntax-case e ()
((_ orig #t mid)
(id? (syntax mid))
(values (syntax orig) #t (wrap (syntax mid) w)))
((_ orig #f mid)
(id? (syntax mid))
(values (syntax orig) #f (wrap (syntax mid) w)))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-define
(lambda (e w ae)
(syntax-case e ()
((_ name val)
(id? (syntax name))
(values (syntax name) (syntax val) w))
((_ (name . args) e1 e2 ...)
(and (id? (syntax name))
(valid-bound-ids? (lambda-var-list (syntax args))))
(values (wrap (syntax name) w)
(cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
empty-wrap))
((_ name)
(id? (syntax name))
(values (wrap (syntax name) w) (syntax (void)) empty-wrap))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-define-syntax
(lambda (e w ae)
(syntax-case e ()
((_ (name id) e1 e2 ...)
(and (id? (syntax name)) (id? (syntax id)))
(values (wrap (syntax name) w)
`(,(syntax lambda) ,(wrap (syntax (id)) w)
,@(wrap (syntax (e1 e2 ...)) w))
empty-wrap))
((_ name val)
(id? (syntax name))
(values (syntax name) (syntax val) w))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-meta
(lambda (e w ae)
(syntax-case e ()
((_ . form) (syntax form))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-eval-when
(lambda (e w ae)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-alias
(lambda (e w ae)
(syntax-case e ()
((_ new-id old-id)
(and (id? (syntax new-id)) (id? (syntax old-id)))
(values (syntax new-id) (syntax old-id)))
(_ (syntax-error (source-wrap e w ae))))))
(define parse-begin
(lambda (e w ae empty-okay?)
(syntax-case e ()
((_) empty-okay? '())
((_ e1 e2 ...) (syntax (e1 e2 ...)))
(_ (syntax-error (source-wrap e w ae))))))
(define chi-lambda-clause
(lambda (e c r mr w m?)
(syntax-case c ()
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-error e "invalid parameter list in")
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(values
new-vars
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env* labels new-vars r)
mr
(make-binding-wrap ids labels w)
m?))))))
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
(syntax-error e "invalid parameter list in")
(let ((labels (gen-labels old-ids))
(new-vars (map gen-var old-ids)))
(values
(let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env* labels new-vars r)
mr
(make-binding-wrap old-ids labels w)
m?))))))
(_ (syntax-error e)))))
(define chi-local-syntax
(lambda (rec? e r mr w ae)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(invalid-ids-error (map (lambda (x) (wrap x w)) ids)
(source-wrap e w ae)
"keyword")
(let ((labels (gen-labels ids)))
(let ((new-w (make-binding-wrap ids labels w)))
(let ((b* (let ((w (if rec? new-w w)))
(map (lambda (x)
(defer-or-eval-transformer
local-eval-hook
(chi x mr mr w #t)))
(syntax (val ...))))))
(values
(syntax (e1 e2 ...))
(extend-env* labels b* r)
(extend-env* labels b* mr)
new-w
ae)))))))
(_ (syntax-error (source-wrap e w ae))))))
(define chi-void
(lambda ()
(build-application no-source (build-primref no-source 'void) '())))
(define ellipsis?
(lambda (x)
(and (nonsymbol-id? x)
(literal-id=? x (syntax (... ...))))))
;;; data
;;; strips all annotations from potentially circular reader output.
(define strip-annotation
(lambda (x)
(cond
((pair? x)
(cons (strip-annotation (car x))
(strip-annotation (cdr x))))
((annotation? x) (annotation-stripped x))
(else x))))
;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
;;; on an annotation, strips the annotation as well.
;;; since only the head of a list is annotated by the reader, not each pair
;;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list
(define strip*
(lambda (x w fn)
(if (top-marked? w)
(fn x)
(let f ((x x))
(cond
((syntax-object? x)
(strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
((pair? x)
(let ((a (f (car x))) (d (f (cdr x))))
(if (and (eq? a (car x)) (eq? d (cdr x)))
x
(cons a d))))
((vector? x)
(let ((old (vector->list x)))
(let ((new (map f old)))
(if (andmap eq? old new) x (list->vector new)))))
(else x))))))
(define strip
(lambda (x w)
(strip* x w
(lambda (x)
(if (or (annotation? x) (and (pair? x) (annotation? (car x))))
(strip-annotation x)
x)))))
;;; lexical variables
(define gen-var
(lambda (id)
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
(if (annotation? id)
(build-lexical-var id (annotation-expression id))
(build-lexical-var id id)))))
(define lambda-var-list
(lambda (vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
((id? vars) (cons (wrap vars w) ls))
((null? vars) ls)
((syntax-object? vars)
(lvl (syntax-object-expression vars)
ls
(join-wraps w (syntax-object-wrap vars))))
((annotation? vars)
(lvl (annotation-expression vars) ls w))
; include anything else to be caught by subsequent error
; checking
(else (cons vars ls))))))
; must precede global-extends
(set! $sc-put-cte
(lambda (id b top-token)
(define sc-put-module
(lambda (exports token new-marks)
(vfor-each
(lambda (id) (store-import-binding id token new-marks))
exports)))
(define (put-cte id binding token)
(let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
(store-import-binding id token '())
(put-global-definition-hook sym
; global binding is assumed; if global pass #f to remove existing binding, if any
(if (and (eq? (binding-type binding) 'global)
(eq? (binding-value binding) sym))
#f
binding))))
(let ((binding (make-transformer-binding b)))
(case (binding-type binding)
(($module)
(let ((iface (binding-value binding)))
(sc-put-module (interface-exports iface) (interface-token iface) '()))
(put-cte id binding top-token))
((do-alias) (store-import-binding id top-token '()))
((do-import)
; fake binding: id is module id binding-value is token
(let ((token (binding-value b)))
(let ((b (lookup (id-var-name id empty-wrap) null-env)))
(case (binding-type b)
(($module)
(let* ((iface (binding-value b))
(exports (interface-exports iface)))
(unless (eq? (interface-token iface) token)
(syntax-error id "import mismatch for module"))
(sc-put-module (interface-exports iface) top-token
(import-mark-delta id iface))))
(else (syntax-error id "unknown module"))))))
(else (put-cte id binding top-token))))
))
;;; core transformers
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'fluid-let-syntax
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? (syntax (var ...)))
(let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
(for-each
(lambda (id n)
(case (binding-type (lookup n r))
((displaced-lexical) (displaced-lexical-error (wrap id w)))))
(syntax (var ...))
names)
(let ((b* (map (lambda (x)
(defer-or-eval-transformer
local-eval-hook
(chi x mr mr w #t)))
(syntax (val ...)))))
(chi-body
(syntax (e1 e2 ...))
(source-wrap e w ae)
(extend-env* names b* r)
(extend-env* names b* mr)
w
m?))))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'core 'quote
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ e) (build-data ae (strip (syntax e) w)))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'core 'syntax
(let ()
(define gen-syntax
(lambda (src e r maps ellipsis? vec?)
(if (id? e)
(let ((label (id-var-name e empty-wrap)))
(let ((b (lookup label r)))
(if (eq? (binding-type b) 'syntax)
(let-values (((var maps)
(let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))))
(values `(ref ,var) maps))
(if (ellipsis? e)
(syntax-error src "misplaced ellipsis in syntax form")
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
(ellipsis? (syntax dots))
(if vec?
(syntax-error src "misplaced ellipsis in syntax template")
(gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
((x dots . y)
; this could be about a dozen lines of code, except that we
; choose to handle (syntax (x ... ...)) forms
(ellipsis? (syntax dots))
(let f ((y (syntax y))
(k (lambda (maps)
(let-values (((x maps)
(gen-syntax src (syntax x) r
(cons '() maps) ellipsis? #f)))
(if (null? (car maps))
(syntax-error src
"extra ellipsis in syntax form")
(values (gen-map x (car maps))
(cdr maps)))))))
(syntax-case y ()
((dots . y)
(ellipsis? (syntax dots))
(f (syntax y)
(lambda (maps)
(let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps))
(syntax-error src
"extra ellipsis in syntax form")
(values (gen-mappend x (car maps))
(cdr maps)))))))
(_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
(let-values (((x maps) (k maps)))
(values (gen-append x y) maps)))))))
((x . y)
(let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
(let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
(values (gen-cons e (syntax x) (syntax y) xnew ynew)
maps))))
(#(x1 x2 ...)
(let ((ls (syntax (x1 x2 ...))))
(let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
(values (gen-vector e ls lsnew) maps))))
(_ (values `(quote ,e) maps))))))
(define gen-ref
(lambda (src var level maps)
(if (fx= level 0)
(values var maps)
(if (null? maps)
(syntax-error src "missing ellipsis in syntax form")
(let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
(let ((b (assq outer-var (car maps))))
(if b
(values (cdr b) maps)
(let ((inner-var (gen-var 'tmp)))
(values inner-var
(cons (cons (cons outer-var inner-var)
(car maps))
outer-maps))))))))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ()))
x
`(append ,x ,y))))
(define gen-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
((eq? (car e) 'ref)
; identity map equivalence:
; (map (lambda (x) x) y) == y
(car actuals))
((andmap
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
`(map (primitive ,(car e))
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
; 12/12/00: semantic change: we now return original syntax object (e)
; if no pattern variables were found within, to avoid dropping
; source annotations prematurely. the "syntax returns lists" for
; lists in its input guarantee counts only for substructure that
; contains pattern variables
(define gen-cons
(lambda (e x y xnew ynew)
(case (car ynew)
((quote)
(if (eq? (car xnew) 'quote)
(let ((xnew (cadr xnew)) (ynew (cadr ynew)))
(if (and (eq? xnew x) (eq? ynew y))
`',e
`'(,xnew . ,ynew)))
(if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
((list) `(list ,xnew ,@(cdr ynew)))
(else `(cons ,xnew ,ynew)))))
(define gen-vector
(lambda (e ls lsnew)
(cond
((eq? (car lsnew) 'quote)
(if (eq? (cadr lsnew) ls)
`',e
`(quote #(,@(cadr lsnew)))))
((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
(else `(list->vector ,lsnew)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
(if (fx= (length ls) 2)
(build-primref no-source 'map)
; really need to do our own checking here
(build-primref no-source 2 'map)) ; require error check
ls)))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r mr w ae m?)
(let ((e (source-wrap e w ae)))
(syntax-case e ()
((_ x)
(let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
(regen e)))
(_ (syntax-error e)))))))
(global-extend 'core 'lambda
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ . c)
(let-values (((vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r mr w m?)))
(build-lambda ae vars body))))))
(global-extend 'core 'letrec
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(invalid-ids-error (map (lambda (x) (wrap x w)) ids)
(source-wrap e w ae) "bound variable")
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env* labels new-vars r)))
(build-letrec ae
new-vars
(map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'core 'if
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ test then)
(build-conditional ae
(chi (syntax test) r mr w m?)
(chi (syntax then) r mr w m?)
(chi-void)))
((_ test then else)
(build-conditional ae
(chi (syntax test) r mr w m?)
(chi (syntax then) r mr w m?)
(chi (syntax else) r mr w m?)))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'set! 'set! '())
(global-extend 'alias 'alias '())
(global-extend 'begin 'begin '())
(global-extend '$module-key '$module '())
(global-extend '$import '$import '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())
(global-extend 'eval-when 'eval-when '())
(global-extend 'meta 'meta '())
(global-extend 'core 'syntax-case
(let ()
(define convert-pattern
; accepts pattern & keys
; returns syntax-dispatch pattern & ids
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
(if (null? p*)
(values '() ids)
(let-values (((y ids) (cvt* (cdr p*) n ids)))
(let-values (((x ids) (cvt (car p*) n ids)))
(values (cons x y) ids))))))
(define cvt
(lambda (p n ids)
(if (id? p)
(if (bound-id-member? p keys)
(values (vector 'free-id p) ids)
(values 'any (cons (cons p n) ids)))
(syntax-case p ()
((x dots)
(ellipsis? (syntax dots))
(let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
(values (if (eq? p 'any) 'each-any (vector 'each p))
ids)))
((x dots y ... . z)
(ellipsis? (syntax dots))
(let-values (((z ids) (cvt (syntax z) n ids)))
(let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
(let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
(values `#(each+ ,x ,(reverse y) ,z) ids)))))
((x . y)
(let-values (((y ids) (cvt (syntax y) n ids)))
(let-values (((x ids) (cvt (syntax x) n ids)))
(values (cons x y) ids))))
(() (values '() ids))
(#(x ...)
(let-values (((p ids) (cvt (syntax (x ...)) n ids)))
(values (vector 'vector p) ids)))
(x (values (vector 'atom (strip p empty-wrap)) ids))))))
(cvt pattern 0 '())))
(define build-dispatch-call
(lambda (pvars exp y r mr m?)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
(list (build-lambda no-source new-vars
(chi exp
(extend-env*
labels
(map (lambda (var level)
(make-binding 'syntax `(,var . ,level)))
new-vars
(map cdr pvars))
r)
mr
(make-binding-wrap ids labels empty-wrap)
m?))
y))))))
(define gen-clause
(lambda (x keys clauses r mr m? pat fender exp)
(let-values (((p pvars) (convert-pattern pat keys)))
(cond
((not (distinct-bound-ids? (map car pvars)))
(invalid-ids-error (map car pvars) pat "pattern variable"))
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-error pat
"misplaced ellipsis in syntax-case pattern"))
(else
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
(build-lambda no-source (list y)
(let-syntax ((y (identifier-syntax
(build-lexical-reference 'value no-source y))))
(build-conditional no-source
(syntax-case fender ()
(#t y)
(_ (build-conditional no-source
y
(build-dispatch-call pvars fender y r mr m?)
(build-data no-source #f))))
(build-dispatch-call pvars exp y r mr m?)
(gen-syntax-case x keys clauses r mr m?))))
(list (if (eq? p 'any)
(build-application no-source
(build-primref no-source 'list)
(list (build-lexical-reference no-source 'value x)))
(build-application no-source
(build-primref no-source '$syntax-dispatch)
(list (build-lexical-reference no-source 'value x)
(build-data no-source p))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mr m?)
(if (null? clauses)
(build-application no-source
(build-primref no-source 'syntax-error)
(list (build-lexical-reference 'value no-source x)))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
(not (bound-id-member? (syntax pat) keys))
(not (ellipsis? (syntax pat))))
(let ((label (gen-label))
(var (gen-var (syntax pat))))
(build-application no-source
(build-lambda no-source (list var)
(chi (syntax exp)
(extend-env label (make-binding 'syntax `(,var . 0)) r)
mr
(make-binding-wrap (syntax (pat))
(list label) empty-wrap)
m?))
(list (build-lexical-reference 'value no-source x))))
(gen-clause x keys (cdr clauses) r mr m?
(syntax pat) #t (syntax exp))))
((pat fender exp)
(gen-clause x keys (cdr clauses) r mr m?
(syntax pat) (syntax fender) (syntax exp)))
(_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
(lambda (e r mr w ae m?)
(let ((e (source-wrap e w ae)))
(syntax-case e ()
((_ val (key ...) m ...)
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
(syntax (key ...)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application ae
(build-lambda no-source (list x)
(gen-syntax-case x
(syntax (key ...)) (syntax (m ...))
r mr m?))
(list (chi (syntax val) r mr empty-wrap m?))))
(syntax-error e "invalid literals list in"))))))))
(put-cte-hook 'module
(lambda (x)
(define proper-export?
(lambda (e)
(syntax-case e ()
((id e ...)
(and (identifier? (syntax id))
(andmap proper-export? (syntax (e ...)))))
(id (identifier? (syntax id))))))
(with-syntax ((orig x))
(syntax-case x ()
((_ (e ...) d ...)
(if (andmap proper-export? (syntax (e ...)))
(syntax (begin ($module orig anon (e ...) d ...) ($import orig #f anon)))
(syntax-error x "invalid exports list in")))
((_ m (e ...) d ...)
(identifier? (syntax m))
(if (andmap proper-export? (syntax (e ...)))
(syntax ($module orig m (e ...) d ...))
(syntax-error x "invalid exports list in")))))))
(let ()
(define $module-exports
(lambda (m r)
(let ((b (r m)))
(case (binding-type b)
(($module)
(let* ((interface (binding-value b))
(new-marks (import-mark-delta m interface)))
(vmap (lambda (x)
(let ((id (if (pair? x) (car x) x)))
(make-syntax-object
(syntax-object->datum id)
(let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
(make-wrap marks
; the anti mark should always be present at the head
; of new-marks, but we paranoically check anyway
(if (eq? (car marks) the-anti-mark)
(cons 'shift (wrap-subst top-wrap))
(wrap-subst top-wrap)))))))
(interface-exports interface))))
((displaced-lexical) (displaced-lexical-error m))
(else (syntax-error m "unknown module"))))))
(define $import-help
(lambda (orig import-only?)
(lambda (r)
(define difference
(lambda (ls1 ls2)
(if (null? ls1)
ls1
(if (bound-id-member? (car ls1) ls2)
(difference (cdr ls1) ls2)
(cons (car ls1) (difference (cdr ls1) ls2))))))
(define prefix-add
(lambda (prefix-id)
(let ((prefix (symbol->string (syntax-object->datum prefix-id))))
(lambda (id)
(datum->syntax-object id
(string->symbol
(string-append prefix
(symbol->string (syntax-object->datum id)))))))))
(define prefix-drop
(lambda (prefix-id)
(let ((prefix (symbol->string (syntax-object->datum prefix-id))))
(lambda (id)
(let ((s (symbol->string (syntax-object->datum id))))
(let ((np (string-length prefix)) (ns (string-length s)))
(unless (and (>= ns np) (string=? (substring s 0 np) prefix))
(syntax-error id (string-append "missing expected prefix " prefix)))
(datum->syntax-object id
(string->symbol (substring s np ns)))))))))
(define gen-mid
(lambda (mid)
; introduced module ids must have same marks as original
; for import-only, since the barrier carries the marks of
; the module id
(datum->syntax-object mid (generate-id (id-sym-name mid)))))
(define (modspec m exports?)
(with-syntax ((orig orig) (import-only? import-only?))
(syntax-case m (only-for-syntax also-for-syntax
only except
add-prefix drop-prefix rename alias)
((only m id ...)
(andmap identifier? (syntax (id ...)))
(let-values (((mid d exports) (modspec (syntax m) #f)))
(with-syntax ((d d) (tmid (gen-mid mid)))
(values mid
(syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
(and exports? (syntax (id ...)))))))
((except m id ...)
(andmap identifier? (syntax (id ...)))
(let-values (((mid d exports) (modspec (syntax m) #t)))
(with-syntax ((d d)
(tmid (gen-mid mid))
((id ...) (difference exports (syntax (id ...)))))
(values mid
(syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
(and exports? (syntax (id ...)))))))
((add-prefix m prefix-id)
(identifier? (syntax prefix-id))
(let-values (((mid d exports) (modspec (syntax m) #t)))
(with-syntax ((d d)
(tmid (gen-mid mid))
((old-id ...) exports)
((tmp ...) (generate-temporaries exports))
((id ...) (map (prefix-add (syntax prefix-id)) exports)))
(values mid
(syntax (begin ($module orig tmid ((id tmp) ...)
($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
($import orig import-only? tmid)
(alias id tmp) ...)
($import orig import-only? tmid)))
(and exports? (syntax (id ...)))))))
((drop-prefix m prefix-id)
(identifier? (syntax prefix-id))
(let-values (((mid d exports) (modspec (syntax m) #t)))
(with-syntax ((d d)
(tmid (gen-mid mid))
((old-id ...) exports)
((tmp ...) (generate-temporaries exports))
((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
(values mid
(syntax (begin ($module orig tmid ((id tmp) ...)
($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
($import orig import-only? tmid)
(alias id tmp) ...)
($import orig import-only? tmid)))
(and exports? (syntax (id ...)))))))
((rename m (new-id old-id) ...)
(and (andmap identifier? (syntax (new-id ...)))
(andmap identifier? (syntax (old-id ...))))
(let-values (((mid d exports) (modspec (syntax m) #t)))
(with-syntax ((d d)
(tmid (gen-mid mid))
((tmp ...) (generate-temporaries (syntax (old-id ...))))
((other-id ...) (difference exports (syntax (old-id ...)))))
(values mid
(syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
($import orig import-only? tmid)
(alias new-id tmp) ...)
($import orig import-only? tmid)))
(and exports? (syntax (new-id ... other-id ...)))))))
((alias m (new-id old-id) ...)
(and (andmap identifier? (syntax (new-id ...)))
(andmap identifier? (syntax (old-id ...))))
(let-values (((mid d exports) (modspec (syntax m) #t)))
(with-syntax ((d d)
(tmid (gen-mid mid))
((other-id ...) exports))
(values mid
(syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
($import orig import-only? tmid)))
(and exports? (syntax (new-id ... other-id ...)))))))
; base cases
(mid
(identifier? (syntax mid))
(values (syntax mid)
(syntax ($import orig import-only? mid))
(and exports? ($module-exports (syntax mid) r))))
((mid)
(identifier? (syntax mid))
(values (syntax mid)
(syntax ($import orig import-only? mid))
(and exports? ($module-exports (syntax mid) r))))
(_ (syntax-error m "invalid module specifier")))))
(define modspec*
(lambda (m)
(let-values (((mid d exports) (modspec m #f))) d)))
(syntax-case orig ()
((_ m ...)
(with-syntax (((d ...) (map modspec* (syntax (m ...)))))
(syntax (begin d ...))))))))
(put-cte-hook 'import
(lambda (orig)
($import-help orig #f)))
(put-cte-hook 'import-only
(lambda (orig)
($import-help orig #t)))
)
;;; To support eval-when, we maintain two mode sets:
;;;
;;; ctem (compile-time-expression mode)
;;; determines whether/when to evaluate compile-time expressions such
;;; as macro definitions, module definitions, and compile-time
;;; registration of variable definitions
;;;
;;; rtem (run-time-expression mode)
;;; determines whether/when to evaluate run-time expressions such
;;; as the actual assignment performed by a variable definition or
;;; arbitrary top-level expressions
;;; Possible modes in the mode set are:
;;;
;;; L (load): evaluate at load time. implies V for compile-time
;;; expressions and R for run-time expressions.
;;;
;;; C (compile): evaluate at compile (file) time
;;;
;;; E (eval): evaluate at evaluation (compile or interpret) time
;;;
;;; V (visit): evaluate at visit time
;;;
;;; R (revisit): evaluate at revisit time
;;; The mode set for the body of an eval-when is determined by
;;; translating each mode in the old mode set based on the situations
;;; present in the eval-when form and combining these into a set,
;;; using the following table. See also update-mode-set.
;;; load compile visit revisit eval
;;;
;;; L L C V R -
;;;
;;; C - - - - C
;;;
;;; V V C V - -
;;;
;;; R R C - R -
;;;
;;; E - - - - E
;;; When we complete the expansion of a compile or run-time expression,
;;; the current ctem or rtem determines how the expression will be
;;; treated. See ct-eval/residualize and rt-eval/residualize.
;;; Initial mode sets
;;;
;;; when compiling a file:
;;;
;;; initial ctem: (L C)
;;;
;;; initial rtem: (L)
;;;
;;; when not compiling a file:
;;;
;;; initial ctem: (E)
;;;
;;; initial rtem: (E)
;;;
;;;
;;; This means that top-level syntactic definitions are evaluated
;;; immediately after they are expanded, and the expanded definitions
;;; are also residualized into the object file if we are compiling
;;; a file.
(set! sc-expand
(let ((ctem '(E)) (rtem '(E)))
(lambda (x)
(let ((env (interaction-environment)))
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top* x null-env
(env-wrap env)
ctem rtem #f
(env-top-ribcage env)))))))
(set! $make-environment
(lambda (token mutable?)
(let ((top-ribcage (make-top-ribcage token mutable?)))
(make-env
top-ribcage
(make-wrap
(wrap-marks top-wrap)
(cons top-ribcage (wrap-subst top-wrap)))))))
(set! environment?
(lambda (x)
(env? x)))
(set! interaction-environment
(let ((e ($make-environment '*top* #t)))
(lambda () e)))
(set! identifier?
(lambda (x)
(nonsymbol-id? x)))
(set! datum->syntax-object
(lambda (id datum)
(arg-check nonsymbol-id? id 'datum->syntax-object)
(make-syntax-object
datum
(syntax-object-wrap id))))
(set! syntax->list
(lambda (orig-ls)
(let f ((ls orig-ls))
(syntax-case ls ()
(() '())
((x . r) (cons #'x (f #'r)))
(_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
(set! syntax->vector
(lambda (v)
(syntax-case v ()
(#(x ...) (apply vector (syntax->list #'(x ...))))
(_ (error 'syntax->vector "invalid argument ~s" v)))))
(set! syntax-object->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
(strip x empty-wrap)))
(set! generate-temporaries
(let ((n 0))
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(map (lambda (x)
(set! n (+ n 1))
(wrap
; unique name to distinguish from other temporaries
(string->symbol (string-append "t" (number->string n)))
; unique mark (in tmp-wrap) to distinguish from non-temporaries
tmp-wrap))
ls))))
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?)
(arg-check nonsymbol-id? y 'free-identifier=?)
(free-id=? x y)))
(set! bound-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'bound-identifier=?)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
(set! literal-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'literal-identifier=?)
(arg-check nonsymbol-id? y 'literal-identifier=?)
(literal-id=? x y)))
(set! syntax-error
(lambda (object . messages)
(for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
(let ((message (if (null? messages)
"invalid syntax"
(apply string-append messages))))
(error-hook #f message (strip object empty-wrap)))))
;;; syntax-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
;;; not work on r4rs implementations that violate the ieee requirement
;;; that #f and () be distinct.)
;;; The expression is matched with the pattern as follows:
;;; p in pattern: matches:
;;; () empty list
;;; any anything
;;; (p1 . p2) pair (list)
;;; #(free-id <key>) <key> with literal-identifier=?
;;; each-any any proper list
;;; #(each p) (p*)
;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;;; #(vector p) (list->vector p)
;;; #(atom <object>) <object> with "equal?"
;;; Vector cops out to pair under assumption that vectors are rare. If
;;; not, should convert to:
;;; #(vector p) #(p*)
(let ()
(define match-each
(lambda (e p w)
(cond
((annotation? e)
(match-each (annotation-expression e) p w))
((pair? e)
(let ((first (match (car e) p w '())))
(and first
(let ((rest (match-each (cdr e) p w)))
(and rest (cons first rest))))))
((null? e) '())
((syntax-object? e)
(match-each (syntax-object-expression e)
p
(join-wraps w (syntax-object-wrap e))))
(else #f))))
(define match-each+
(lambda (e x-pat y-pat z-pat w r)
(let f ((e e) (w w))
(cond
((pair? e)
(let-values (((xr* y-pat r) (f (cdr e) w)))
(if r
(if (null? y-pat)
(let ((xr (match (car e) x-pat w '())))
(if xr
(values (cons xr xr*) y-pat r)
(values #f #f #f)))
(values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
(values #f #f #f))))
((annotation? e) (f (annotation-expression e) w))
((syntax-object? e) (f (syntax-object-expression e)
(join-wraps w (syntax-object-wrap e))))
(else (values '() y-pat (match e z-pat w r)))))))
(define match-each-any
(lambda (e w)
(cond
((annotation? e)
(match-each-any (annotation-expression e) w))
((pair? e)
(let ((l (match-each-any (cdr e) w)))
(and l (cons (wrap (car e) w) l))))
((null? e) '())
((syntax-object? e)
(match-each-any (syntax-object-expression e)
(join-wraps w (syntax-object-wrap e))))
(else #f))))
(define match-empty
(lambda (p r)
(cond
((null? p) r)
((eq? p 'any) (cons '() r))
((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
((eq? p 'each-any) (cons '() r))
(else
(case (vector-ref p 0)
((each) (match-empty (vector-ref p 1) r))
((each+) (match-empty (vector-ref p 1)
(match-empty (reverse (vector-ref p 2))
(match-empty (vector-ref p 3) r))))
((free-id atom) r)
((vector) (match-empty (vector-ref p 1) r)))))))
(define combine
(lambda (r* r)
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))
(define match*
(lambda (e p w r)
(cond
((null? p) (and (null? e) r))
((pair? p)
(and (pair? e) (match (car e) (car p) w
(match (cdr e) (cdr p) w r))))
((eq? p 'each-any)
(let ((l (match-each-any e w))) (and l (cons l r))))
(else
(case (vector-ref p 0)
((each)
(if (null? e)
(match-empty (vector-ref p 1) r)
(let ((r* (match-each e (vector-ref p 1) w)))
(and r* (combine r* r)))))
((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
((each+)
(let-values (((xr* y-pat r)
(match-each+ e (vector-ref p 1) (vector-ref p 2)
(vector-ref p 3) w r)))
(and r (null? y-pat)
(if (null? xr*)
(match-empty (vector-ref p 1) r)
(combine xr* r)))))
((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
((vector)
(and (vector? e)
(match (vector->list e) (vector-ref p 1) w r))))))))
(define match
(lambda (e p w r)
(cond
((not r) #f)
((eq? p 'any) (cons (wrap e w) r))
((syntax-object? e)
(match*
(unannotate (syntax-object-expression e))
p
(join-wraps w (syntax-object-wrap e))
r))
(else (match* (unannotate e) p w r)))))
(set! $syntax-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
((syntax-object? e)
(match* (unannotate (syntax-object-expression e))
p (syntax-object-wrap e) '()))
(else (match* (unannotate e) p empty-wrap '())))))
))
(define-syntax with-syntax
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
(syntax (begin e1 e2 ...)))
((_ ((out in)) e1 e2 ...)
(syntax (syntax-case in () (out (begin e1 e2 ...)))))
((_ ((out in) ...) e1 e2 ...)
(syntax (syntax-case (list in ...) ()
((out ...) (begin e1 e2 ...))))))))
(define-syntax with-implicit
(syntax-rules ()
((_ (tid id ...) e1 e2 ...)
(andmap identifier? (syntax (tid id ...)))
(begin
(unless (identifier? (syntax tid))
(syntax-error (syntax tid) "non-identifier with-implicit template"))
(with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
e1 e2 ...)))))
(define-syntax datum
(syntax-rules ()
((_ x) (syntax-object->datum (syntax x)))))
(define-syntax syntax-rules
(lambda (x)
(define clause
(lambda (y)
(syntax-case y ()
(((keyword . pattern) template)
(syntax ((dummy . pattern) (syntax template))))
(((keyword . pattern) fender template)
(syntax ((dummy . pattern) fender (syntax template))))
(_ (syntax-error x)))))
(syntax-case x ()
((_ (k ...) cl ...)
(andmap identifier? (syntax (k ...)))
(with-syntax (((cl ...) (map clause (syntax (cl ...)))))
(syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
(define-syntax or
(lambda (x)
(syntax-case x ()
((_) (syntax #f))
((_ e) (syntax e))
((_ e1 e2 e3 ...)
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
(define-syntax and
(lambda (x)
(syntax-case x ()
((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
((_ e) (syntax e))
((_) (syntax #t)))))
(define-syntax let
(lambda (x)
(syntax-case x ()
((_ ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (x ...)))
(syntax ((lambda (x ...) e1 e2 ...) v ...)))
((_ f ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (f x ...)))
(syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
v ...))))))
(define-syntax let*
(lambda (x)
(syntax-case x ()
((let* ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (x ...)))
(let f ((bindings (syntax ((x v) ...))))
(if (null? bindings)
(syntax (let () e1 e2 ...))
(with-syntax ((body (f (cdr bindings)))
(binding (car bindings)))
(syntax (let (binding) body)))))))))
(define-syntax cond
(lambda (x)
(syntax-case x ()
((_ m1 m2 ...)
(let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
(if (null? clauses)
(syntax-case clause (else =>)
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
((e0) (syntax (let ((t e0)) (if t t))))
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
(_ (syntax-error x)))
(with-syntax ((rest (f (car clauses) (cdr clauses))))
(syntax-case clause (else =>)
((e0) (syntax (let ((t e0)) (if t t rest))))
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
(_ (syntax-error x))))))))))
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
((_ ((var init . step) ...) (e0 e1 ...) c ...)
(with-syntax (((step ...)
(map (lambda (v s)
(syntax-case s ()
(() v)
((e) (syntax e))
(_ (syntax-error orig-x))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
(() (syntax (let do ((var init) ...)
(if (not e0)
(begin c ... (do step ...))))))
((e1 e2 ...)
(syntax (let do ((var init) ...)
(if e0
(begin e1 e2 ...)
(begin c ... (do step ...))))))))))))
(define-syntax quasiquote
(let ()
(define (quasi p lev)
(syntax-case p (unquote quasiquote)
((unquote p)
(if (= lev 0)
#'("value" p)
(quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
((p . q)
(syntax-case #'p (unquote unquote-splicing)
((unquote p ...)
(if (= lev 0)
(quasilist* #'(("value" p) ...) (quasi #'q lev))
(quasicons
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
(quasi #'q lev))))
((unquote-splicing p ...)
(if (= lev 0)
(quasiappend #'(("value" p) ...) (quasi #'q lev))
(quasicons
(quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
(quasi #'q lev))))
(_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
(#(x ...) (quasivector (vquasi #'(x ...) lev)))
(p #'("quote" p))))
(define (vquasi p lev)
(syntax-case p ()
((p . q)
(syntax-case #'p (unquote unquote-splicing)
((unquote p ...)
(if (= lev 0)
(quasilist* #'(("value" p) ...) (vquasi #'q lev))
(quasicons
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
(vquasi #'q lev))))
((unquote-splicing p ...)
(if (= lev 0)
(quasiappend #'(("value" p) ...) (vquasi #'q lev))
(quasicons
(quasicons
#'("quote" unquote-splicing)
(quasi #'(p ...) (- lev 1)))
(vquasi #'q lev))))
(_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
(() #'("quote" ()))))
(define (quasicons x y)
(with-syntax ((x x) (y y))
(syntax-case #'y ()
(("quote" dy)
(syntax-case #'x ()
(("quote" dx) #'("quote" (dx . dy)))
(_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
(("list" . stuff) #'("list" x . stuff))
(("list*" . stuff) #'("list*" x . stuff))
(_ #'("list*" x y)))))
(define (quasiappend x y)
(syntax-case y ()
(("quote" ())
(cond
((null? x) #'("quote" ()))
((null? (cdr x)) (car x))
(else (with-syntax (((p ...) x)) #'("append" p ...)))))
(_
(cond
((null? x) y)
(else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
(define (quasilist* x y)
(let f ((x x))
(if (null? x)
y
(quasicons (car x) (f (cdr x))))))
(define (quasivector x)
(syntax-case x ()
(("quote" (x ...)) #'("quote" #(x ...)))
(_
(let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
(syntax-case y ()
(("quote" (y ...)) (k #'(("quote" y) ...)))
(("list" y ...) (k #'(y ...)))
(("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
(else #`("list->vector" #,x)))))))
(define (emit x)
(syntax-case x ()
(("quote" x) #''x)
(("list" x ...) #`(list #,@(map emit #'(x ...))))
; could emit list* for 3+ arguments if implementation supports list*
(("list*" x ... y)
(let f ((x* #'(x ...)))
(if (null? x*)
(emit #'y)
#`(cons #,(emit (car x*)) #,(f (cdr x*))))))
(("append" x ...) #`(append #,@(map emit #'(x ...))))
(("vector" x ...) #`(vector #,@(map emit #'(x ...))))
(("list->vector" x) #`(list->vector #,(emit #'x)))
(("value" x) #'x)))
(lambda (x)
(syntax-case x ()
; convert to intermediate language, combining introduced (but not
; unquoted source) quote expressions where possible and choosing
; optimal construction code otherwise, then emit Scheme code
; corresponding to the intermediate language forms.
((_ e) (emit (quasi #'e 0)))))))
(define-syntax unquote
(lambda (x)
(syntax-error x "misplaced")))
(define-syntax unquote-splicing
(lambda (x)
(syntax-error x "misplaced")))
(define-syntax quasisyntax
(lambda (x)
(define (qs q n b* k)
(syntax-case q (quasisyntax unsyntax unsyntax-splicing)
((quasisyntax . d)
(qs #'d (+ n 1) b*
(lambda (b* dnew)
(k b*
(if (eq? dnew #'d)
q
(with-syntax ((d dnew)) #'(quasisyntax . d)))))))
((unsyntax . d)
(not (= n 0))
(qs #'d (- n 1) b*
(lambda (b* dnew)
(k b*
(if (eq? dnew #'d)
q
(with-syntax ((d dnew)) #'(unsyntax . d)))))))
((unsyntax-splicing . d)
(not (= n 0))
(qs #'d (- n 1) b*
(lambda (b* dnew)
(k b*
(if (eq? dnew #'d)
q
(with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
((unsyntax q)
(= n 0)
(with-syntax (((t) (generate-temporaries #'(q))))
(k (cons #'(t q) b*) #'t)))
(((unsyntax q ...) . d)
(= n 0)
(qs #'d n b*
(lambda (b* dnew)
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
(k (append #'((t q) ...) b*)
(with-syntax ((d dnew)) #'(t ... . d)))))))
(((unsyntax-splicing q ...) . d)
(= n 0)
(qs #'d n b*
(lambda (b* dnew)
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
(k (append #'(((t (... ...)) q) ...) b*)
(with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
(with-syntax ((d dnew)) #'(m ... ... . d))))))))
((a . d)
(qs #'a n b*
(lambda (b* anew)
(qs #'d n b*
(lambda (b* dnew)
(k b*
(if (and (eq? anew #'a) (eq? dnew #'d))
q
(with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
(#(x ...)
(vqs #'(x ...) n b*
(lambda (b* xnew*)
(k b*
(if (let same? ((x* #'(x ...)) (xnew* xnew*))
(if (null? x*)
(null? xnew*)
(and (not (null? xnew*))
(eq? (car x*) (car xnew*))
(same? (cdr x*) (cdr xnew*)))))
q
(with-syntax (((x ...) xnew*)) #'#(x ...)))))))
(_ (k b* q))))
(define (vqs x* n b* k)
(if (null? x*)
(k b* '())
(vqs (cdr x*) n b*
(lambda (b* xnew*)
(syntax-case (car x*) (unsyntax unsyntax-splicing)
((unsyntax q ...)
(= n 0)
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
(k (append #'((t q) ...) b*)
(append #'(t ...) xnew*))))
((unsyntax-splicing q ...)
(= n 0)
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
(k (append #'(((t (... ...)) q) ...) b*)
(with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
(append #'(m ... ...) xnew*)))))
(_ (qs (car x*) n b*
(lambda (b* xnew)
(k b* (cons xnew xnew*))))))))))
(syntax-case x ()
((_ x)
(qs #'x 0 '()
(lambda (b* xnew)
(if (eq? xnew #'x)
#'(syntax x)
(with-syntax (((b ...) b*) (x xnew))
#'(with-syntax (b ...) (syntax x))))))))))
(define-syntax unsyntax
(lambda (x)
(syntax-error x "misplaced")))
(define-syntax unsyntax-splicing
(lambda (x)
(syntax-error x "misplaced")))
(define-syntax include
(lambda (x)
(define read-file
(lambda (fn k)
(let ((p (open-input-file fn)))
(let f ()
(let ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
(cons (datum->syntax-object k x) (f))))))))
(syntax-case x ()
((k filename)
(let ((fn (syntax-object->datum (syntax filename))))
(with-syntax (((exp ...) (read-file fn (syntax k))))
(syntax (begin exp ...))))))))
(define-syntax case
(lambda (x)
(syntax-case x ()
((_ e m1 m2 ...)
(with-syntax
((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
(if (null? clauses)
(syntax-case clause (else)
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
(_ (syntax-error x)))
(with-syntax ((rest (f (car clauses) (cdr clauses))))
(syntax-case clause (else)
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...))
(begin e1 e2 ...)
rest)))
(_ (syntax-error x))))))))
(syntax (let ((t e)) body)))))))
(define-syntax identifier-syntax
(syntax-rules (set!)
((_ e)
(lambda (x)
(syntax-case x ()
(id (identifier? (syntax id)) (syntax e))
((_ x (... ...)) (syntax (e x (... ...)))))))
((_ (id exp1) ((set! var val) exp2))
(and (identifier? (syntax id)) (identifier? (syntax var)))
(cons 'macro!
(lambda (x)
(syntax-case x (set!)
((set! var val) (syntax exp2))
((id x (... ...)) (syntax (exp1 x (... ...))))
(id (identifier? (syntax id)) (syntax exp1))))))))