ref: f02ba63fa7b86631ccd8d71157dd88e745e7f1cc
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))))))))