4686 lines
186 KiB
Scheme
4686 lines
186 KiB
Scheme
;;; Portable implementation of syntax-case
|
|
;;; Extracted from Chez Scheme Version 7.1 (Aug 01, 2006)
|
|
;;; 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
|
|
(fx+ (length (syntax (id1 ...))) 1))
|
|
((index ...)
|
|
(let f ((i 1) (ids (syntax (id1 ...))))
|
|
(if (null? ids)
|
|
'()
|
|
(cons i (f (fx+ i 1) (cdr ids)))))))
|
|
(syntax (begin
|
|
(define constructor
|
|
(lambda (id1 ...)
|
|
(vector 'name id1 ... )))
|
|
(define predicate
|
|
(lambda (x)
|
|
(and (vector? x)
|
|
(fx= (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))
|
|
(define annotation-expression
|
|
(lambda (x) (error 'annotation-expression "not yet")))
|
|
(define annotation-stripped
|
|
(lambda (x) (error 'annotation-stripped "not yet")))
|
|
|
|
; 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-syntax gensym-hook
|
|
(syntax-rules ()
|
|
((_) (gensym))))
|
|
|
|
;;; AZIZ
|
|
;;; (define put-cte-hook
|
|
;;; (lambda (symbol val)
|
|
;;; ($sc-put-cte symbol val '*top*)))
|
|
|
|
(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 put-import-binding
|
|
(lambda (symbol token x)
|
|
(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 gensym-hook 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))))))))
|
|
;;; AZIZ
|
|
(define generate-id
|
|
(lambda (name)
|
|
(if name (gensym name) (gensym))))
|
|
)
|
|
|
|
|
|
|
|
;;; 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))))
|
|
|
|
;;; AZIZ
|
|
;;; (define-syntax build-global-reference
|
|
;;; (syntax-rules ()
|
|
;;; ((_ ae var)
|
|
;;; var)))
|
|
(define-syntax build-global-reference
|
|
(syntax-rules ()
|
|
[(_ ae var)
|
|
`(top-level-value ',var)]))
|
|
|
|
;;; AZIZ
|
|
;;; (define-syntax build-global-assignment
|
|
;;; (syntax-rules ()
|
|
;;; ((_ ae var exp)
|
|
;;; `(set! ,var ,exp))))
|
|
(define-syntax build-global-assignment
|
|
(syntax-rules ()
|
|
[(_ ae var exp)
|
|
`(set-top-level-value! ',var ,exp)]))
|
|
|
|
;;; AZIZ
|
|
;;; (define-syntax build-global-definition
|
|
;;; (syntax-rules ()
|
|
;;; ((_ ae var exp)
|
|
;;; `(define ,var ,exp))))
|
|
(define-syntax build-global-definition
|
|
(syntax-rules ()
|
|
[(_ ae var exp)
|
|
(build-global-assignment ae 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)))
|
|
|
|
;;; AZIZ
|
|
;;; (define-syntax build-lambda
|
|
;;; (syntax-rules ()
|
|
;;; ((_ ae vars exp)
|
|
;;; `(lambda ,vars ,exp))))
|
|
(define-syntax build-lambda
|
|
(syntax-rules ()
|
|
[(_ ae vars exp)
|
|
`(case-lambda [,vars ,exp])]))
|
|
|
|
(define build-case-lambda
|
|
(lambda (ae vars* exp*)
|
|
`(case-lambda . ,(map list vars* exp*))))
|
|
|
|
;;; AZIZ
|
|
;;; (define built-lambda?
|
|
;;; (lambda (x)
|
|
;;; (and (pair? x) (eq? (car x) 'lambda))))
|
|
(define built-lambda?
|
|
(lambda (x)
|
|
(and (pair? x) (eq? (car x) 'case-lambda))))
|
|
|
|
;;; AZIZ
|
|
;;; (define-syntax build-primref
|
|
;;; (syntax-rules ()
|
|
;;; ((_ ae name) name)
|
|
;;; ((_ ae level name) name)))
|
|
(define-syntax build-primref
|
|
(syntax-rules ()
|
|
[(_ ae name) (build-primref ae 1 name)]
|
|
[(_ ae level name)
|
|
`(|#primitive| ,name)]))
|
|
|
|
|
|
;;; AZIZ
|
|
(define-syntax build-foreign-call
|
|
(syntax-rules ()
|
|
[(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
|
|
(define-syntax build-$apply
|
|
(syntax-rules ()
|
|
[(_ ae proc arg*) `($apply ,proc . ,arg*)]))
|
|
|
|
(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) (fixnum? x) (string? x) (char? x) (null? x) (number? 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 (fixnum? n) (fx>= 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 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)))
|
|
(let ((x (weed marks (get-import-binding sym token))))
|
|
(put-import-binding sym token
|
|
(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
|
|
((fx> n1 n2) (cons (car m1) (f (fx- 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 (fx= (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))
|
|
(sym (generate-id (id-sym-name id)))
|
|
(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))
|
|
;;; AZIZ
|
|
((core-primitive)
|
|
(build-primref 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"))
|
|