4713 lines
188 KiB
Scheme
4713 lines
188 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"))
|
|
(build-body no-source
|
|
(reverse vars) (chi-frobs (reverse vals) r mr m?)
|
|
(build-sequence no-source
|
|
(chi-frobs (append inits exprs) r mr m?)))))))
|
|
|
|
(define chi-internal
|
|
;; In processing the forms of the body, we create a new, empty wrap.
|
|
;; This wrap is augmented (destructively) each time we discover that
|
|
;; the next form is a definition. This is done:
|
|
;;
|
|
;; (1) to allow the first nondefinition form to be a call to
|
|
;; one of the defined ids even if the id previously denoted a
|
|
;; definition keyword or keyword for a macro expanding into a
|
|
;; definition;
|
|
;; (2) to prevent subsequent definition forms (but unfortunately
|
|
;; not earlier ones) and the first nondefinition form from
|
|
;; confusing one of the bound identifiers for an auxiliary
|
|
;; keyword; and
|
|
;; (3) so that we do not need to restart the expansion of the
|
|
;; first nondefinition form, which is problematic anyway
|
|
;; since it might be the first element of a begin that we
|
|
;; have just spliced into the body (meaning if we restarted,
|
|
;; we'd really need to restart with the begin or the macro
|
|
;; call that expanded into the begin, and we'd have to give
|
|
;; up allowing (begin <defn>+ <expr>+), which is itself
|
|
;; problematic since we don't know if a begin contains only
|
|
;; definitions until we've expanded it).
|
|
;;
|
|
;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
|
|
;; into the body.
|
|
;;
|
|
;; outer-form is fully wrapped w/source
|
|
(lambda (ribcage source-exp body r mr m?)
|
|
(define return
|
|
(lambda (r mr exprs ids vars vals inits)
|
|
(check-defined-ids source-exp ids)
|
|
(values r mr exprs ids vars vals inits)))
|
|
(let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
|
|
(if (null? body)
|
|
(return r mr body ids vars vals inits)
|
|
(let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
|
|
(let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
|
|
(case type
|
|
((define-form)
|
|
(let-values (((id rhs w) (parse-define e w ae)))
|
|
(let ((id (wrap id w)) (label (gen-label)))
|
|
(cond
|
|
(meta?
|
|
(let ((sym (generate-id (id-sym-name id))))
|
|
(extend-ribcage! ribcage id label)
|
|
; add meta bindings only to meta environment
|
|
; so visible only to next higher level and beyond
|
|
(let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
|
|
(define-top-level-value-hook sym
|
|
(top-level-eval-hook (chi rhs mr mr w #t)))
|
|
(parse (cdr body) r mr (cons id ids) vars vals inits #f))))
|
|
(else
|
|
(let ((var (gen-var id)))
|
|
(extend-ribcage! ribcage id label)
|
|
; add lexical bindings only to run-time environment
|
|
(parse (cdr body)
|
|
(extend-env label (make-binding 'lexical var) r)
|
|
mr
|
|
(cons id ids)
|
|
(cons var vars)
|
|
(cons (make-frob (wrap rhs w) meta?) vals)
|
|
inits
|
|
#f)))))))
|
|
((define-syntax-form)
|
|
(let-values (((id rhs w) (parse-define-syntax e w ae)))
|
|
(let ((id (wrap id w))
|
|
(label (gen-label))
|
|
(exp (chi rhs mr mr w #t)))
|
|
(extend-ribcage! ribcage id label)
|
|
(let ((b (defer-or-eval-transformer local-eval-hook exp)))
|
|
(parse (cdr body)
|
|
(extend-env label b r) (extend-env label b mr)
|
|
(cons id ids) vars vals inits #f)))))
|
|
(($module-form)
|
|
(let* ((*ribcage (make-empty-ribcage))
|
|
(*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
|
|
(let-values (((orig id exports forms) (parse-module e w ae *w)))
|
|
(let-values (((r mr *body *ids *vars *vals *inits)
|
|
(chi-internal *ribcage orig
|
|
(map (lambda (d) (make-frob d meta?)) forms)
|
|
r mr m?)))
|
|
; valid bound ids checked already by chi-internal
|
|
(check-module-exports source-exp (flatten-exports exports) *ids)
|
|
(let ((iface (make-resolved-interface id exports #f))
|
|
(vars (append *vars vars))
|
|
(vals (append *vals vals))
|
|
(inits (append inits *inits *body))
|
|
(label (gen-label)))
|
|
(extend-ribcage! ribcage id label)
|
|
(let ((b (make-binding '$module iface)))
|
|
(parse (cdr body)
|
|
(extend-env label b r) (extend-env label b mr)
|
|
(cons id ids) vars vals inits #f)))))))
|
|
(($import-form)
|
|
(let-values (((orig only? mid) (parse-import e w ae)))
|
|
(let ((mlabel (id-var-name mid empty-wrap)))
|
|
(let ((binding (lookup mlabel r)))
|
|
(case (binding-type binding)
|
|
(($module)
|
|
(let* ((iface (binding-value binding))
|
|
(import-iface (make-import-interface iface (import-mark-delta mid iface))))
|
|
(when only? (extend-ribcage-barrier! ribcage mid))
|
|
(do-import! import-iface ribcage)
|
|
(parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
|
|
((displaced-lexical) (displaced-lexical-error mid))
|
|
(else (syntax-error mid "unknown module")))))))
|
|
((alias-form)
|
|
(let-values (((new-id old-id) (parse-alias e w ae)))
|
|
(let ((new-id (wrap new-id w)))
|
|
(extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
|
|
(parse (cdr body) r mr
|
|
(cons new-id ids)
|
|
vars
|
|
vals
|
|
inits
|
|
#f))))
|
|
((begin-form)
|
|
(parse (let f ((forms (parse-begin e w ae #t)))
|
|
(if (null? forms)
|
|
(cdr body)
|
|
(cons (make-frob (wrap (car forms) w) meta?)
|
|
(f (cdr forms)))))
|
|
r mr ids vars vals inits #f))
|
|
((eval-when-form)
|
|
(let-values (((when-list forms) (parse-eval-when e w ae)))
|
|
(parse (if (memq 'eval when-list) ; mode set is implicitly (E)
|
|
(let f ((forms forms))
|
|
(if (null? forms)
|
|
(cdr body)
|
|
(cons (make-frob (wrap (car forms) w) meta?)
|
|
(f (cdr forms)))))
|
|
(cdr body))
|
|
r mr ids vars vals inits #f)))
|
|
((meta-form)
|
|
(parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
|
|
(cdr body))
|
|
r mr ids vars vals inits #t))
|
|
((local-syntax-form)
|
|
(let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
|
|
(parse (let f ((forms forms))
|
|
(if (null? forms)
|
|
(cdr body)
|
|
(cons (make-frob (wrap (car forms) w) meta?)
|
|
(f (cdr forms)))))
|
|
r mr ids vars vals inits #f)))
|
|
(else ; found a non-definition
|
|
(when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
|
|
(let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
|
|
(if (or (null? body) (not (frob-meta? (car body))))
|
|
(return r mr body ids vars vals inits)
|
|
(begin
|
|
; expand meta inits for effect only
|
|
(top-level-eval-hook (chi-meta-frob (car body) mr))
|
|
(f (cdr body)))))))))))))
|
|
|
|
(define import-mark-delta
|
|
; returns list of marks layered on top of module id beyond those
|
|
; cached in the interface
|
|
(lambda (mid iface)
|
|
(diff-marks (id-marks mid) (interface-marks iface))))
|
|
|
|
(define lookup-import-label
|
|
(lambda (id)
|
|
(let ((label (id-var-name-loc id empty-wrap)))
|
|
(unless label
|
|
(syntax-error id "exported identifier not visible"))
|
|
label)))
|
|
|
|
(define do-import!
|
|
(lambda (import-iface ribcage)
|
|
(let ((ie (interface-exports (import-interface-interface import-iface))))
|
|
(if (fx<= (vector-length ie) 20)
|
|
(let ((new-marks (import-interface-new-marks import-iface)))
|
|
(vfor-each
|
|
(lambda (id)
|
|
(import-extend-ribcage! ribcage new-marks id
|
|
(lookup-import-label id)))
|
|
ie))
|
|
(extend-ribcage-subst! ribcage import-iface)))))
|
|
|
|
(define parse-module
|
|
(lambda (e w ae *w)
|
|
(define listify
|
|
(lambda (exports)
|
|
(if (null? exports)
|
|
'()
|
|
(cons (syntax-case (car exports) ()
|
|
((ex ...) (listify (syntax (ex ...))))
|
|
(x (if (id? (syntax x))
|
|
(wrap (syntax x) *w)
|
|
(syntax-error (source-wrap e w ae)
|
|
"invalid exports list in"))))
|
|
(listify (cdr exports))))))
|
|
(syntax-case e ()
|
|
((_ orig mid (ex ...) form ...)
|
|
(id? (syntax mid))
|
|
; id receives old wrap so it won't be confused with id of same name
|
|
; defined within the module
|
|
(values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-import
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ orig #t mid)
|
|
(id? (syntax mid))
|
|
(values (syntax orig) #t (wrap (syntax mid) w)))
|
|
((_ orig #f mid)
|
|
(id? (syntax mid))
|
|
(values (syntax orig) #f (wrap (syntax mid) w)))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-define
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ name val)
|
|
(id? (syntax name))
|
|
(values (syntax name) (syntax val) w))
|
|
((_ (name . args) e1 e2 ...)
|
|
(and (id? (syntax name))
|
|
(valid-bound-ids? (lambda-var-list (syntax args))))
|
|
(values (wrap (syntax name) w)
|
|
(cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
|
|
empty-wrap))
|
|
((_ name)
|
|
(id? (syntax name))
|
|
(values (wrap (syntax name) w) (syntax (void)) empty-wrap))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-define-syntax
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ (name id) e1 e2 ...)
|
|
(and (id? (syntax name)) (id? (syntax id)))
|
|
(values (wrap (syntax name) w)
|
|
`(,(syntax lambda) ,(wrap (syntax (id)) w)
|
|
,@(wrap (syntax (e1 e2 ...)) w))
|
|
empty-wrap))
|
|
((_ name val)
|
|
(id? (syntax name))
|
|
(values (syntax name) (syntax val) w))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-meta
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ . form) (syntax form))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-eval-when
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ (x ...) e1 e2 ...)
|
|
(values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-alias
|
|
(lambda (e w ae)
|
|
(syntax-case e ()
|
|
((_ new-id old-id)
|
|
(and (id? (syntax new-id)) (id? (syntax old-id)))
|
|
(values (syntax new-id) (syntax old-id)))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define parse-begin
|
|
(lambda (e w ae empty-okay?)
|
|
(syntax-case e ()
|
|
((_) empty-okay? '())
|
|
((_ e1 e2 ...) (syntax (e1 e2 ...)))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define chi-lambda-clause
|
|
(lambda (e c r mr w m?)
|
|
(syntax-case c ()
|
|
(((id ...) e1 e2 ...)
|
|
(let ((ids (syntax (id ...))))
|
|
(if (not (valid-bound-ids? ids))
|
|
(syntax-error e "invalid parameter list in")
|
|
(let ((labels (gen-labels ids))
|
|
(new-vars (map gen-var ids)))
|
|
(values
|
|
new-vars
|
|
(chi-body (syntax (e1 e2 ...))
|
|
e
|
|
(extend-var-env* labels new-vars r)
|
|
mr
|
|
(make-binding-wrap ids labels w)
|
|
m?))))))
|
|
((ids e1 e2 ...)
|
|
(let ((old-ids (lambda-var-list (syntax ids))))
|
|
(if (not (valid-bound-ids? old-ids))
|
|
(syntax-error e "invalid parameter list in")
|
|
(let ((labels (gen-labels old-ids))
|
|
(new-vars (map gen-var old-ids)))
|
|
(values
|
|
(let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
|
|
(if (null? ls1)
|
|
ls2
|
|
(f (cdr ls1) (cons (car ls1) ls2))))
|
|
(chi-body (syntax (e1 e2 ...))
|
|
e
|
|
(extend-var-env* labels new-vars r)
|
|
mr
|
|
(make-binding-wrap old-ids labels w)
|
|
m?))))))
|
|
(_ (syntax-error e)))))
|
|
|
|
(define chi-local-syntax
|
|
(lambda (rec? e r mr w ae)
|
|
(syntax-case e ()
|
|
((_ ((id val) ...) e1 e2 ...)
|
|
(let ((ids (syntax (id ...))))
|
|
(if (not (valid-bound-ids? ids))
|
|
(invalid-ids-error (map (lambda (x) (wrap x w)) ids)
|
|
(source-wrap e w ae)
|
|
"keyword")
|
|
(let ((labels (gen-labels ids)))
|
|
(let ((new-w (make-binding-wrap ids labels w)))
|
|
(let ((b* (let ((w (if rec? new-w w)))
|
|
(map (lambda (x)
|
|
(defer-or-eval-transformer
|
|
local-eval-hook
|
|
(chi x mr mr w #t)))
|
|
(syntax (val ...))))))
|
|
(values
|
|
(syntax (e1 e2 ...))
|
|
(extend-env* labels b* r)
|
|
(extend-env* labels b* mr)
|
|
new-w
|
|
ae)))))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(define chi-void
|
|
(lambda ()
|
|
(build-application no-source (build-primref no-source 'void) '())))
|
|
|
|
(define ellipsis?
|
|
(lambda (x)
|
|
(and (nonsymbol-id? x)
|
|
(literal-id=? x (syntax (... ...))))))
|
|
|
|
;;; data
|
|
|
|
;;; strips all annotations from potentially circular reader output.
|
|
|
|
(define strip-annotation
|
|
(lambda (x)
|
|
(cond
|
|
((pair? x)
|
|
(cons (strip-annotation (car x))
|
|
(strip-annotation (cdr x))))
|
|
((annotation? x) (annotation-stripped x))
|
|
(else x))))
|
|
|
|
;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
|
|
;;; on an annotation, strips the annotation as well.
|
|
;;; since only the head of a list is annotated by the reader, not each pair
|
|
;;; in the spine, we also check for pairs whose cars are annotated in case
|
|
;;; we've been passed the cdr of an annotated list
|
|
|
|
(define strip*
|
|
(lambda (x w fn)
|
|
(if (top-marked? w)
|
|
(fn x)
|
|
(let f ((x x))
|
|
(cond
|
|
((syntax-object? x)
|
|
(strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
|
|
((pair? x)
|
|
(let ((a (f (car x))) (d (f (cdr x))))
|
|
(if (and (eq? a (car x)) (eq? d (cdr x)))
|
|
x
|
|
(cons a d))))
|
|
((vector? x)
|
|
(let ((old (vector->list x)))
|
|
(let ((new (map f old)))
|
|
(if (andmap eq? old new) x (list->vector new)))))
|
|
(else x))))))
|
|
|
|
(define strip
|
|
(lambda (x w)
|
|
(strip* x w
|
|
(lambda (x)
|
|
(if (or (annotation? x) (and (pair? x) (annotation? (car x))))
|
|
(strip-annotation x)
|
|
x)))))
|
|
|
|
;;; lexical variables
|
|
|
|
(define gen-var
|
|
(lambda (id)
|
|
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
|
|
(if (annotation? id)
|
|
(build-lexical-var id (annotation-expression id))
|
|
(build-lexical-var id id)))))
|
|
|
|
(define lambda-var-list
|
|
(lambda (vars)
|
|
(let lvl ((vars vars) (ls '()) (w empty-wrap))
|
|
(cond
|
|
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
|
|
((id? vars) (cons (wrap vars w) ls))
|
|
((null? vars) ls)
|
|
((syntax-object? vars)
|
|
(lvl (syntax-object-expression vars)
|
|
ls
|
|
(join-wraps w (syntax-object-wrap vars))))
|
|
((annotation? vars)
|
|
(lvl (annotation-expression vars) ls w))
|
|
; include anything else to be caught by subsequent error
|
|
; checking
|
|
(else (cons vars ls))))))
|
|
|
|
|
|
; must precede global-extends
|
|
|
|
(primitive-set! '$sc-put-cte
|
|
(lambda (id b top-token)
|
|
(define sc-put-module
|
|
(lambda (exports token new-marks)
|
|
(vfor-each
|
|
(lambda (id) (store-import-binding id token new-marks))
|
|
exports)))
|
|
(define (put-cte id binding token)
|
|
(let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
|
|
(store-import-binding id token '())
|
|
(put-global-definition-hook sym
|
|
; global binding is assumed; if global pass #f to remove existing binding, if any
|
|
(if (and (eq? (binding-type binding) 'global)
|
|
(eq? (binding-value binding) sym))
|
|
#f
|
|
binding))))
|
|
(let ((binding (make-transformer-binding b)))
|
|
(case (binding-type binding)
|
|
(($module)
|
|
(let ((iface (binding-value binding)))
|
|
(sc-put-module (interface-exports iface) (interface-token iface) '()))
|
|
(put-cte id binding top-token))
|
|
((do-alias) (store-import-binding id top-token '()))
|
|
((do-import)
|
|
; fake binding: id is module id binding-value is token
|
|
(let ((token (binding-value b)))
|
|
(let ((b (lookup (id-var-name id empty-wrap) null-env)))
|
|
(case (binding-type b)
|
|
(($module)
|
|
(let* ((iface (binding-value b))
|
|
(exports (interface-exports iface)))
|
|
(unless (eq? (interface-token iface) token)
|
|
(syntax-error id "import mismatch for module"))
|
|
(sc-put-module (interface-exports iface) top-token
|
|
(import-mark-delta id iface))))
|
|
(else (syntax-error id "unknown module"))))))
|
|
(else (put-cte id binding top-token))))
|
|
))
|
|
|
|
|
|
;;; core transformers
|
|
|
|
(global-extend 'local-syntax 'letrec-syntax #t)
|
|
(global-extend 'local-syntax 'let-syntax #f)
|
|
|
|
|
|
(global-extend 'core 'fluid-let-syntax
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ ((var val) ...) e1 e2 ...)
|
|
(valid-bound-ids? (syntax (var ...)))
|
|
(let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
|
|
(for-each
|
|
(lambda (id n)
|
|
(case (binding-type (lookup n r))
|
|
((displaced-lexical) (displaced-lexical-error (wrap id w)))))
|
|
(syntax (var ...))
|
|
names)
|
|
(let ((b* (map (lambda (x)
|
|
(defer-or-eval-transformer
|
|
local-eval-hook
|
|
(chi x mr mr w #t)))
|
|
(syntax (val ...)))))
|
|
(chi-body
|
|
(syntax (e1 e2 ...))
|
|
(source-wrap e w ae)
|
|
(extend-env* names b* r)
|
|
(extend-env* names b* mr)
|
|
w
|
|
m?))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(global-extend 'core 'quote
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ e) (build-data ae (strip (syntax e) w)))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(global-extend 'core '|#primitive|
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ name) (id? #'name)
|
|
(let ([name (strip (syntax name) w)])
|
|
(if (or (memq name (public-primitives))
|
|
(memq name (system-primitives)))
|
|
(build-primref ae name)
|
|
(syntax-error (source-wrap e w ae)))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
(global-extend 'core 'syntax
|
|
(let ()
|
|
(define gen-syntax
|
|
(lambda (src e r maps ellipsis? vec?)
|
|
(if (id? e)
|
|
(let ((label (id-var-name e empty-wrap)))
|
|
(let ((b (lookup label r)))
|
|
(if (eq? (binding-type b) 'syntax)
|
|
(let-values (((var maps)
|
|
(let ((var.lev (binding-value b)))
|
|
(gen-ref src (car var.lev) (cdr var.lev) maps))))
|
|
(values `(ref ,var) maps))
|
|
(if (ellipsis? e)
|
|
(syntax-error src "misplaced ellipsis in syntax form")
|
|
(values `(quote ,e) maps)))))
|
|
(syntax-case e ()
|
|
((dots e)
|
|
(ellipsis? (syntax dots))
|
|
(if vec?
|
|
(syntax-error src "misplaced ellipsis in syntax template")
|
|
(gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
|
|
((x dots . y)
|
|
; this could be about a dozen lines of code, except that we
|
|
; choose to handle (syntax (x ... ...)) forms
|
|
(ellipsis? (syntax dots))
|
|
(let f ((y (syntax y))
|
|
(k (lambda (maps)
|
|
(let-values (((x maps)
|
|
(gen-syntax src (syntax x) r
|
|
(cons '() maps) ellipsis? #f)))
|
|
(if (null? (car maps))
|
|
(syntax-error src
|
|
"extra ellipsis in syntax form")
|
|
(values (gen-map x (car maps))
|
|
(cdr maps)))))))
|
|
(syntax-case y ()
|
|
((dots . y)
|
|
(ellipsis? (syntax dots))
|
|
(f (syntax y)
|
|
(lambda (maps)
|
|
(let-values (((x maps) (k (cons '() maps))))
|
|
(if (null? (car maps))
|
|
(syntax-error src
|
|
"extra ellipsis in syntax form")
|
|
(values (gen-mappend x (car maps))
|
|
(cdr maps)))))))
|
|
(_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
|
|
(let-values (((x maps) (k maps)))
|
|
(values (gen-append x y) maps)))))))
|
|
((x . y)
|
|
(let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
|
|
(let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
|
|
(values (gen-cons e (syntax x) (syntax y) xnew ynew)
|
|
maps))))
|
|
(#(x1 x2 ...)
|
|
(let ((ls (syntax (x1 x2 ...))))
|
|
(let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
|
|
(values (gen-vector e ls lsnew) maps))))
|
|
(_ (values `(quote ,e) maps))))))
|
|
|
|
(define gen-ref
|
|
(lambda (src var level maps)
|
|
(if (fx= level 0)
|
|
(values var maps)
|
|
(if (null? maps)
|
|
(syntax-error src "missing ellipsis in syntax form")
|
|
(let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
|
|
(let ((b (assq outer-var (car maps))))
|
|
(if b
|
|
(values (cdr b) maps)
|
|
(let ((inner-var (gen-var 'tmp)))
|
|
(values inner-var
|
|
(cons (cons (cons outer-var inner-var)
|
|
(car maps))
|
|
outer-maps))))))))))
|
|
|
|
(define gen-append
|
|
(lambda (x y)
|
|
(if (equal? y '(quote ()))
|
|
x
|
|
`(append ,x ,y))))
|
|
|
|
(define gen-mappend
|
|
(lambda (e map-env)
|
|
`(apply (primitive append) ,(gen-map e map-env))))
|
|
|
|
(define gen-map
|
|
(lambda (e map-env)
|
|
(let ((formals (map cdr map-env))
|
|
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
|
|
(cond
|
|
((eq? (car e) 'ref)
|
|
; identity map equivalence:
|
|
; (map (lambda (x) x) y) == y
|
|
(car actuals))
|
|
((andmap
|
|
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
|
|
(cdr e))
|
|
; eta map equivalence:
|
|
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
|
|
`(map (primitive ,(car e))
|
|
,@(map (let ((r (map cons formals actuals)))
|
|
(lambda (x) (cdr (assq (cadr x) r))))
|
|
(cdr e))))
|
|
(else `(map (case-lambda [,formals ,e]) ,@actuals))))))
|
|
|
|
; 12/12/00: semantic change: we now return original syntax object (e)
|
|
; if no pattern variables were found within, to avoid dropping
|
|
; source annotations prematurely. the "syntax returns lists" for
|
|
; lists in its input guarantee counts only for substructure that
|
|
; contains pattern variables
|
|
(define gen-cons
|
|
(lambda (e x y xnew ynew)
|
|
(case (car ynew)
|
|
((quote)
|
|
(if (eq? (car xnew) 'quote)
|
|
(let ((xnew (cadr xnew)) (ynew (cadr ynew)))
|
|
(if (and (eq? xnew x) (eq? ynew y))
|
|
`',e
|
|
`'(,xnew . ,ynew)))
|
|
(if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
|
|
((list) `(list ,xnew ,@(cdr ynew)))
|
|
(else `(cons ,xnew ,ynew)))))
|
|
|
|
(define gen-vector
|
|
(lambda (e ls lsnew)
|
|
(cond
|
|
((eq? (car lsnew) 'quote)
|
|
(if (eq? (cadr lsnew) ls)
|
|
`',e
|
|
`(quote #(,@(cadr lsnew)))))
|
|
((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
|
|
(else `(list->vector ,lsnew)))))
|
|
|
|
|
|
(define regen
|
|
(lambda (x)
|
|
(case (car x)
|
|
((ref) (build-lexical-reference 'value no-source (cadr x)))
|
|
((primitive) (build-primref no-source (cadr x)))
|
|
((quote) (build-data no-source (cadr x)))
|
|
((lambda)
|
|
(build-lambda no-source (cadr x) (regen (caddr x))))
|
|
((case-lambda)
|
|
(let ([d (cdr x)])
|
|
(build-case-lambda no-source
|
|
(map car d)
|
|
(map (lambda (x) (regen (cadr x))) d))))
|
|
((map) (let ((ls (map regen (cdr x))))
|
|
(build-application no-source
|
|
(if (fx= (length ls) 2)
|
|
(build-primref no-source 'map)
|
|
; really need to do our own checking here
|
|
(build-primref no-source 2 'map)) ; require error check
|
|
ls)))
|
|
(else (build-application no-source
|
|
(build-primref no-source (car x))
|
|
(map regen (cdr x)))))))
|
|
|
|
(lambda (e r mr w ae m?)
|
|
(let ((e (source-wrap e w ae)))
|
|
(syntax-case e ()
|
|
((_ x)
|
|
(let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
|
|
(regen e)))
|
|
(_ (syntax-error e)))))))
|
|
|
|
|
|
(global-extend 'core 'lambda
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ . c)
|
|
(let-values (((vars body)
|
|
(chi-lambda-clause
|
|
(source-wrap e w ae)
|
|
(syntax c) r mr w m?)))
|
|
(build-lambda ae vars body))))))
|
|
|
|
;;; AZIZ
|
|
(global-extend 'core 'case-lambda
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
[(_ c* ...)
|
|
(let-values ([(vars* body*)
|
|
(let f ([c* #'(c* ...)])
|
|
(syntax-case c* ()
|
|
[() (values '() '())]
|
|
[(c . c*)
|
|
(let-values ([(vars body)
|
|
(chi-lambda-clause
|
|
(source-wrap e w ae)
|
|
#'c r mr w m?)])
|
|
(let-values ([(vars* body*) (f #'c*)])
|
|
(values
|
|
(cons vars vars*)
|
|
(cons body body*))))]))])
|
|
(build-case-lambda ae vars* body*))])))
|
|
|
|
|
|
|
|
|
|
(global-extend 'core 'letrec
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ ((id val) ...) e1 e2 ...)
|
|
(let ((ids (syntax (id ...))))
|
|
(if (not (valid-bound-ids? ids))
|
|
(invalid-ids-error (map (lambda (x) (wrap x w)) ids)
|
|
(source-wrap e w ae) "bound variable")
|
|
(let ((labels (gen-labels ids))
|
|
(new-vars (map gen-var ids)))
|
|
(let ((w (make-binding-wrap ids labels w))
|
|
(r (extend-var-env* labels new-vars r)))
|
|
(build-letrec ae
|
|
new-vars
|
|
(map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
|
|
(chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
|
|
(global-extend 'core 'if
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ test then)
|
|
(build-conditional ae
|
|
(chi (syntax test) r mr w m?)
|
|
(chi (syntax then) r mr w m?)
|
|
(chi-void)))
|
|
((_ test then else)
|
|
(build-conditional ae
|
|
(chi (syntax test) r mr w m?)
|
|
(chi (syntax then) r mr w m?)
|
|
(chi (syntax else) r mr w m?)))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
;;; AZIZ
|
|
(global-extend 'core 'foreign-call
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
[(_ proc arg* ...)
|
|
(build-foreign-call ae
|
|
(chi #'proc r mr w m?)
|
|
(let f ([arg* #'(arg* ...)])
|
|
(syntax-case arg* ()
|
|
[() '()]
|
|
[(a . arg*)
|
|
(cons (chi #'a r mr w m?)
|
|
(f #'arg*))])))]
|
|
[_ (syntax-error (source-wrap e w ae))])))
|
|
|
|
(global-extend 'core '$apply
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
[(_ proc arg* ...)
|
|
(build-$apply ae
|
|
(chi #'proc r mr w m?)
|
|
(let f ([arg* #'(arg* ...)])
|
|
(syntax-case arg* ()
|
|
[() '()]
|
|
[(a . arg*)
|
|
(cons (chi #'a r mr w m?)
|
|
(f #'arg*))])))]
|
|
[_ (syntax-error (source-wrap e w ae))])))
|
|
|
|
;;; AZIZ
|
|
(global-extend 'core 'type-descriptor
|
|
(lambda (e r mr w ae m?)
|
|
(syntax-case e ()
|
|
((_ id)
|
|
(id? (syntax id))
|
|
(let ((n (id-var-name (syntax id) w)))
|
|
(let ((b (lookup n r)))
|
|
(case (binding-type b)
|
|
(($rtd)
|
|
(build-data ae (binding-value b)))
|
|
(else (syntax-error (source-wrap e w ae)))))))
|
|
(_ (syntax-error (source-wrap e w ae))))))
|
|
|
|
|
|
(global-extend 'set! 'set! '())
|
|
|
|
(global-extend 'alias 'alias '())
|
|
(global-extend 'begin 'begin '())
|
|
|
|
(global-extend '$module-key '$module '())
|
|
(global-extend '$import '$import '())
|
|
|
|
(global-extend 'define 'define '())
|
|
|
|
(global-extend 'define-syntax 'define-syntax '())
|
|
|
|
(global-extend 'eval-when 'eval-when '())
|
|
|
|
(global-extend 'meta 'meta '())
|
|
|
|
(global-extend 'core 'syntax-case
|
|
(let ()
|
|
(define convert-pattern
|
|
; accepts pattern & keys
|
|
; returns syntax-dispatch pattern & ids
|
|
(lambda (pattern keys)
|
|
(define cvt*
|
|
(lambda (p* n ids)
|
|
(if (null? p*)
|
|
(values '() ids)
|
|
(let-values (((y ids) (cvt* (cdr p*) n ids)))
|
|
(let-values (((x ids) (cvt (car p*) n ids)))
|
|
(values (cons x y) ids))))))
|
|
(define cvt
|
|
(lambda (p n ids)
|
|
(if (id? p)
|
|
(if (bound-id-member? p keys)
|
|
(values (vector 'free-id p) ids)
|
|
(values 'any (cons (cons p n) ids)))
|
|
(syntax-case p ()
|
|
((x dots)
|
|
(ellipsis? (syntax dots))
|
|
(let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
|
|
(values (if (eq? p 'any) 'each-any (vector 'each p))
|
|
ids)))
|
|
((x dots y ... . z)
|
|
(ellipsis? (syntax dots))
|
|
(let-values (((z ids) (cvt (syntax z) n ids)))
|
|
(let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
|
|
(let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
|
|
(values `#(each+ ,x ,(reverse y) ,z) ids)))))
|
|
((x . y)
|
|
(let-values (((y ids) (cvt (syntax y) n ids)))
|
|
(let-values (((x ids) (cvt (syntax x) n ids)))
|
|
(values (cons x y) ids))))
|
|
(() (values '() ids))
|
|
(#(x ...)
|
|
(let-values (((p ids) (cvt (syntax (x ...)) n ids)))
|
|
(values (vector 'vector p) ids)))
|
|
(x (values (vector 'atom (strip p empty-wrap)) ids))))))
|
|
(cvt pattern 0 '())))
|
|
|
|
(define build-dispatch-call
|
|
(lambda (pvars exp y r mr m?)
|
|
(let ((ids (map car pvars)) (levels (map cdr pvars)))
|
|
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
|
|
(build-application no-source
|
|
(build-primref no-source 'apply)
|
|
(list (build-lambda no-source new-vars
|
|
(chi exp
|
|
(extend-env*
|
|
labels
|
|
(map (lambda (var level)
|
|
(make-binding 'syntax `(,var . ,level)))
|
|
new-vars
|
|
(map cdr pvars))
|
|
r)
|
|
mr
|
|
(make-binding-wrap ids labels empty-wrap)
|
|
m?))
|
|
y))))))
|
|
|
|
(define gen-clause
|
|
(lambda (x keys clauses r mr m? pat fender exp)
|
|
(let-values (((p pvars) (convert-pattern pat keys)))
|
|
(cond
|
|
((not (distinct-bound-ids? (map car pvars)))
|
|
(invalid-ids-error (map car pvars) pat "pattern variable"))
|
|
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
|
|
(syntax-error pat
|
|
"misplaced ellipsis in syntax-case pattern"))
|
|
(else
|
|
(let ((y (gen-var 'tmp)))
|
|
; fat finger binding and references to temp variable y
|
|
(build-application no-source
|
|
(build-lambda no-source (list y)
|
|
(let-syntax ((y (identifier-syntax
|
|
(build-lexical-reference 'value no-source y))))
|
|
(build-conditional no-source
|
|
(syntax-case fender ()
|
|
(#t y)
|
|
(_ (build-conditional no-source
|
|
y
|
|
(build-dispatch-call pvars fender y r mr m?)
|
|
(build-data no-source #f))))
|
|
(build-dispatch-call pvars exp y r mr m?)
|
|
(gen-syntax-case x keys clauses r mr m?))))
|
|
(list (if (eq? p 'any)
|
|
(build-application no-source
|
|
(build-primref no-source 'list)
|
|
(list (build-lexical-reference no-source 'value x)))
|
|
(build-application no-source
|
|
(build-primref no-source '$syntax-dispatch)
|
|
(list (build-lexical-reference no-source 'value x)
|
|
(build-data no-source p))))))))))))
|
|
|
|
(define gen-syntax-case
|
|
(lambda (x keys clauses r mr m?)
|
|
(if (null? clauses)
|
|
(build-application no-source
|
|
(build-primref no-source 'syntax-error)
|
|
(list (build-lexical-reference 'value no-source x)))
|
|
(syntax-case (car clauses) ()
|
|
((pat exp)
|
|
(if (and (id? (syntax pat))
|
|
(not (bound-id-member? (syntax pat) keys))
|
|
(not (ellipsis? (syntax pat))))
|
|
(let ((label (gen-label))
|
|
(var (gen-var (syntax pat))))
|
|
(build-application no-source
|
|
(build-lambda no-source (list var)
|
|
(chi (syntax exp)
|
|
(extend-env label (make-binding 'syntax `(,var . 0)) r)
|
|
mr
|
|
(make-binding-wrap (syntax (pat))
|
|
(list label) empty-wrap)
|
|
m?))
|
|
(list (build-lexical-reference 'value no-source x))))
|
|
(gen-clause x keys (cdr clauses) r mr m?
|
|
(syntax pat) #t (syntax exp))))
|
|
((pat fender exp)
|
|
(gen-clause x keys (cdr clauses) r mr m?
|
|
(syntax pat) (syntax fender) (syntax exp)))
|
|
(_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
|
|
|
|
(lambda (e r mr w ae m?)
|
|
(let ((e (source-wrap e w ae)))
|
|
(syntax-case e ()
|
|
((_ val (key ...) m ...)
|
|
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
|
|
(syntax (key ...)))
|
|
(let ((x (gen-var 'tmp)))
|
|
; fat finger binding and references to temp variable x
|
|
(build-application ae
|
|
(build-lambda no-source (list x)
|
|
(gen-syntax-case x
|
|
(syntax (key ...)) (syntax (m ...))
|
|
r mr m?))
|
|
(list (chi (syntax val) r mr empty-wrap m?))))
|
|
(syntax-error e "invalid literals list in"))))))))
|
|
|
|
(put-cte-hook 'module
|
|
(lambda (x)
|
|
(define proper-export?
|
|
(lambda (e)
|
|
(syntax-case e ()
|
|
((id e ...)
|
|
(and (identifier? (syntax id))
|
|
(andmap proper-export? (syntax (e ...)))))
|
|
(id (identifier? (syntax id))))))
|
|
(with-syntax ((orig x))
|
|
(syntax-case x ()
|
|
((_ (e ...) d ...)
|
|
(if (andmap proper-export? (syntax (e ...)))
|
|
(syntax
|
|
(begin
|
|
($module orig anon (e ...) d ...)
|
|
($import orig #f anon)))
|
|
(syntax-error x "invalid exports list in")))
|
|
((_ m (e ...) d ...)
|
|
(identifier? (syntax m))
|
|
(if (andmap proper-export? (syntax (e ...)))
|
|
(syntax
|
|
($module orig m (e ...) d ...))
|
|
(syntax-error x "invalid exports list in")))))))
|
|
|
|
(let ()
|
|
(define $module-exports
|
|
(lambda (m r)
|
|
(let ((b (r m)))
|
|
(case (binding-type b)
|
|
(($module)
|
|
(let* ((interface (binding-value b))
|
|
(new-marks (import-mark-delta m interface)))
|
|
(vmap (lambda (x)
|
|
(let ((id (if (pair? x) (car x) x)))
|
|
(make-syntax-object
|
|
(syntax-object->datum id)
|
|
(let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
|
|
(make-wrap marks
|
|
; the anti mark should always be present at the head
|
|
; of new-marks, but we paranoically check anyway
|
|
(if (eq? (car marks) the-anti-mark)
|
|
(cons 'shift (wrap-subst top-wrap))
|
|
(wrap-subst top-wrap)))))))
|
|
(interface-exports interface))))
|
|
((displaced-lexical) (displaced-lexical-error m))
|
|
(else (syntax-error m "unknown module"))))))
|
|
(define $import-help
|
|
(lambda (orig import-only?)
|
|
(lambda (r)
|
|
(define difference
|
|
(lambda (ls1 ls2)
|
|
(if (null? ls1)
|
|
ls1
|
|
(if (bound-id-member? (car ls1) ls2)
|
|
(difference (cdr ls1) ls2)
|
|
(cons (car ls1) (difference (cdr ls1) ls2))))))
|
|
(define prefix-add
|
|
(lambda (prefix-id)
|
|
(let ((prefix (symbol->string (syntax-object->datum prefix-id))))
|
|
(lambda (id)
|
|
(datum->syntax-object id
|
|
(string->symbol
|
|
(string-append prefix
|
|
(symbol->string (syntax-object->datum id)))))))))
|
|
(define prefix-drop
|
|
(lambda (prefix-id)
|
|
(let ((prefix (symbol->string (syntax-object->datum prefix-id))))
|
|
(lambda (id)
|
|
(let ((s (symbol->string (syntax-object->datum id))))
|
|
(let ((np (string-length prefix)) (ns (string-length s)))
|
|
(unless (and (fx>= ns np) (string=? (substring s 0 np) prefix))
|
|
(syntax-error id (string-append "missing expected prefix " prefix)))
|
|
(datum->syntax-object id
|
|
(string->symbol (substring s np ns)))))))))
|
|
(define gen-mid
|
|
(lambda (mid)
|
|
; introduced module ids must have same marks as original
|
|
; for import-only, since the barrier carries the marks of
|
|
; the module id
|
|
(datum->syntax-object mid (gensym-hook))))
|
|
(define (modspec m exports?)
|
|
(with-syntax ((orig orig) (import-only? import-only?))
|
|
(syntax-case m (only-for-syntax also-for-syntax
|
|
only except
|
|
add-prefix drop-prefix rename alias)
|
|
((only m id ...)
|
|
(andmap identifier? (syntax (id ...)))
|
|
(let-values (((mid d exports) (modspec (syntax m) #f)))
|
|
(with-syntax ((d d) (tmid (gen-mid mid)))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
|
|
(and exports? (syntax (id ...)))))))
|
|
((except m id ...)
|
|
(andmap identifier? (syntax (id ...)))
|
|
(let-values (((mid d exports) (modspec (syntax m) #t)))
|
|
(with-syntax ((d d)
|
|
(tmid (gen-mid mid))
|
|
((id ...) (difference exports (syntax (id ...)))))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
|
|
(and exports? (syntax (id ...)))))))
|
|
((add-prefix m prefix-id)
|
|
(identifier? (syntax prefix-id))
|
|
(let-values (((mid d exports) (modspec (syntax m) #t)))
|
|
(with-syntax ((d d)
|
|
(tmid (gen-mid mid))
|
|
((old-id ...) exports)
|
|
((tmp ...) (generate-temporaries exports))
|
|
((id ...) (map (prefix-add (syntax prefix-id)) exports)))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid ((id tmp) ...)
|
|
($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
|
|
($import orig import-only? tmid)
|
|
(alias id tmp) ...)
|
|
($import orig import-only? tmid)))
|
|
(and exports? (syntax (id ...)))))))
|
|
((drop-prefix m prefix-id)
|
|
(identifier? (syntax prefix-id))
|
|
(let-values (((mid d exports) (modspec (syntax m) #t)))
|
|
(with-syntax ((d d)
|
|
(tmid (gen-mid mid))
|
|
((old-id ...) exports)
|
|
((tmp ...) (generate-temporaries exports))
|
|
((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid ((id tmp) ...)
|
|
($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
|
|
($import orig import-only? tmid)
|
|
(alias id tmp) ...)
|
|
($import orig import-only? tmid)))
|
|
(and exports? (syntax (id ...)))))))
|
|
((rename m (new-id old-id) ...)
|
|
(and (andmap identifier? (syntax (new-id ...)))
|
|
(andmap identifier? (syntax (old-id ...))))
|
|
(let-values (((mid d exports) (modspec (syntax m) #t)))
|
|
(with-syntax ((d d)
|
|
(tmid (gen-mid mid))
|
|
((tmp ...) (generate-temporaries (syntax (old-id ...))))
|
|
((other-id ...) (difference exports (syntax (old-id ...)))))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
|
|
($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
|
|
($import orig import-only? tmid)
|
|
(alias new-id tmp) ...)
|
|
($import orig import-only? tmid)))
|
|
(and exports? (syntax (new-id ... other-id ...)))))))
|
|
((alias m (new-id old-id) ...)
|
|
(and (andmap identifier? (syntax (new-id ...)))
|
|
(andmap identifier? (syntax (old-id ...))))
|
|
(let-values (((mid d exports) (modspec (syntax m) #t)))
|
|
(with-syntax ((d d)
|
|
(tmid (gen-mid mid))
|
|
((other-id ...) exports))
|
|
(values mid
|
|
(syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
|
|
($import orig import-only? tmid)))
|
|
(and exports? (syntax (new-id ... other-id ...)))))))
|
|
; base cases
|
|
(mid
|
|
(identifier? (syntax mid))
|
|
(values (syntax mid)
|
|
(syntax ($import orig import-only? mid))
|
|
(and exports? ($module-exports (syntax mid) r))))
|
|
((mid)
|
|
(identifier? (syntax mid))
|
|
(values (syntax mid)
|
|
(syntax ($import orig import-only? mid))
|
|
(and exports? ($module-exports (syntax mid) r))))
|
|
(_ (syntax-error m "invalid module specifier")))))
|
|
(define modspec*
|
|
(lambda (m)
|
|
(let-values (((mid d exports) (modspec m #f))) d)))
|
|
(syntax-case orig ()
|
|
((_ m ...)
|
|
(with-syntax (((d ...) (map modspec* (syntax (m ...)))))
|
|
(syntax (begin d ...))))))))
|
|
|
|
(put-cte-hook 'import
|
|
(lambda (orig)
|
|
($import-help orig #f)))
|
|
|
|
(put-cte-hook 'import-only
|
|
(lambda (orig)
|
|
($import-help orig #t)))
|
|
)
|
|
|
|
;;; To support eval-when, we maintain two mode sets:
|
|
;;;
|
|
;;; ctem (compile-time-expression mode)
|
|
;;; determines whether/when to evaluate compile-time expressions such
|
|
;;; as macro definitions, module definitions, and compile-time
|
|
;;; registration of variable definitions
|
|
;;;
|
|
;;; rtem (run-time-expression mode)
|
|
;;; determines whether/when to evaluate run-time expressions such
|
|
;;; as the actual assignment performed by a variable definition or
|
|
;;; arbitrary top-level expressions
|
|
|
|
;;; Possible modes in the mode set are:
|
|
;;;
|
|
;;; L (load): evaluate at load time. implies V for compile-time
|
|
;;; expressions and R for run-time expressions.
|
|
;;;
|
|
;;; C (compile): evaluate at compile (file) time
|
|
;;;
|
|
;;; E (eval): evaluate at evaluation (compile or interpret) time
|
|
;;;
|
|
;;; V (visit): evaluate at visit time
|
|
;;;
|
|
;;; R (revisit): evaluate at revisit time
|
|
|
|
;;; The mode set for the body of an eval-when is determined by
|
|
;;; translating each mode in the old mode set based on the situations
|
|
;;; present in the eval-when form and combining these into a set,
|
|
;;; using the following table. See also update-mode-set.
|
|
|
|
;;; load compile visit revisit eval
|
|
;;;
|
|
;;; L L C V R -
|
|
;;;
|
|
;;; C - - - - C
|
|
;;;
|
|
;;; V V C V - -
|
|
;;;
|
|
;;; R R C - R -
|
|
;;;
|
|
;;; E - - - - E
|
|
|
|
;;; When we complete the expansion of a compile or run-time expression,
|
|
;;; the current ctem or rtem determines how the expression will be
|
|
;;; treated. See ct-eval/residualize and rt-eval/residualize.
|
|
|
|
;;; Initial mode sets
|
|
;;;
|
|
;;; when compiling a file:
|
|
;;;
|
|
;;; initial ctem: (L C)
|
|
;;;
|
|
;;; initial rtem: (L)
|
|
;;;
|
|
;;; when not compiling a file:
|
|
;;;
|
|
;;; initial ctem: (E)
|
|
;;;
|
|
;;; initial rtem: (E)
|
|
;;;
|
|
;;;
|
|
;;; This means that top-level syntactic definitions are evaluated
|
|
;;; immediately after they are expanded, and the expanded definitions
|
|
;;; are also residualized into the object file if we are compiling
|
|
;;; a file.
|
|
|
|
|
|
|
|
;;; AZIZ
|
|
;;; (set! sc-expand
|
|
;;; (let ((ctem '(E)) (rtem '(E)))
|
|
;;; (lambda (x)
|
|
;;; (let ((env (interaction-environment)))
|
|
;;; (if (and (pair? x) (equal? (car x) noexpand))
|
|
;;; (cadr x)
|
|
;;; (chi-top* x null-env
|
|
;;; (env-wrap env)
|
|
;;; ctem rtem #f
|
|
;;; (env-top-ribcage env)))))))
|
|
;;;
|
|
|
|
(primitive-set! 'expand-mode
|
|
(make-parameter
|
|
'eval
|
|
(lambda (x)
|
|
(unless (memq x '(eval compile bootstrap))
|
|
(error 'expand-mode "~s is not a valid mode" x))
|
|
x)))
|
|
|
|
(primitive-set! 'sc-expand
|
|
(let ()
|
|
(define get-modes
|
|
(lambda ()
|
|
(case (expand-mode)
|
|
[(eval) (values '(E) '(E))]
|
|
[(compile) (values '(L C) '(L))]
|
|
[(bootstrap) (values '(L) '(L))])))
|
|
(lambda (x)
|
|
(let ((env (interaction-environment)))
|
|
(let-values ([(ctem rtem) (get-modes)])
|
|
(if (and (pair? x) (equal? (car x) noexpand))
|
|
(cadr x)
|
|
(chi-top* x null-env
|
|
(env-wrap env)
|
|
ctem rtem #f
|
|
(env-top-ribcage env))))))))
|
|
|
|
(primitive-set! 'current-expand
|
|
(make-parameter
|
|
sc-expand
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
(error 'current-expand "~s is not a procedure" x))
|
|
x)))
|
|
|
|
(primitive-set! 'expand
|
|
(lambda (x)
|
|
((current-expand) x)))
|
|
|
|
(primitive-set! '$make-environment
|
|
(lambda (token mutable?)
|
|
(let ((top-ribcage (make-top-ribcage token mutable?)))
|
|
(make-env
|
|
top-ribcage
|
|
(make-wrap
|
|
(wrap-marks top-wrap)
|
|
(cons top-ribcage (wrap-subst top-wrap)))))))
|
|
|
|
(primitive-set! 'environment?
|
|
(lambda (x)
|
|
(env? x)))
|
|
|
|
|
|
;;; AZIZ
|
|
;;; (primitive-set! 'interaction-environment
|
|
;;; (let ((e ($make-environment '*top* #t)))
|
|
;;; (lambda () e)))
|
|
|
|
(primitive-set! 'interaction-environment
|
|
(make-parameter
|
|
($make-environment '*top* #t)
|
|
(lambda (x)
|
|
(if (environment? x)
|
|
x
|
|
(error 'interaction-environment "~s is not an environment" x)))))
|
|
|
|
|
|
(primitive-set! 'identifier?
|
|
(lambda (x)
|
|
(nonsymbol-id? x)))
|
|
|
|
(primitive-set! 'datum->syntax-object
|
|
(lambda (id datum)
|
|
(arg-check nonsymbol-id? id 'datum->syntax-object)
|
|
(make-syntax-object
|
|
datum
|
|
(syntax-object-wrap id))))
|
|
|
|
(primitive-set! 'syntax->list
|
|
(lambda (orig-ls)
|
|
(let f ((ls orig-ls))
|
|
(syntax-case ls ()
|
|
(() '())
|
|
((x . r) (cons #'x (f #'r)))
|
|
(_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
|
|
|
|
(primitive-set! 'syntax->vector
|
|
(lambda (v)
|
|
(syntax-case v ()
|
|
(#(x ...) (apply vector (syntax->list #'(x ...))))
|
|
(_ (error 'syntax->vector "invalid argument ~s" v)))))
|
|
|
|
(primitive-set! 'syntax-object->datum
|
|
; accepts any object, since syntax objects may consist partially
|
|
; or entirely of unwrapped, nonsymbolic data
|
|
(lambda (x)
|
|
(strip x empty-wrap)))
|
|
|
|
(primitive-set! 'generate-temporaries
|
|
(lambda (ls)
|
|
(arg-check list? ls 'generate-temporaries)
|
|
(map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
|
|
|
|
(primitive-set! 'free-identifier=?
|
|
(lambda (x y)
|
|
(arg-check nonsymbol-id? x 'free-identifier=?)
|
|
(arg-check nonsymbol-id? y 'free-identifier=?)
|
|
(free-id=? x y)))
|
|
|
|
(primitive-set! 'bound-identifier=?
|
|
(lambda (x y)
|
|
(arg-check nonsymbol-id? x 'bound-identifier=?)
|
|
(arg-check nonsymbol-id? y 'bound-identifier=?)
|
|
(bound-id=? x y)))
|
|
|
|
(primitive-set! 'literal-identifier=?
|
|
(lambda (x y)
|
|
(arg-check nonsymbol-id? x 'literal-identifier=?)
|
|
(arg-check nonsymbol-id? y 'literal-identifier=?)
|
|
(literal-id=? x y)))
|
|
|
|
(primitive-set! 'syntax-error
|
|
(lambda (object . messages)
|
|
(for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
|
|
(let ((message (if (null? messages)
|
|
"invalid syntax"
|
|
(apply string-append messages))))
|
|
(error-hook #f message (strip object empty-wrap)))))
|
|
|
|
;;; syntax-dispatch expects an expression and a pattern. If the expression
|
|
;;; matches the pattern a list of the matching expressions for each
|
|
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
|
|
;;; not work on r4rs implementations that violate the ieee requirement
|
|
;;; that #f and () be distinct.)
|
|
|
|
;;; The expression is matched with the pattern as follows:
|
|
|
|
;;; p in pattern: matches:
|
|
;;; () empty list
|
|
;;; any anything
|
|
;;; (p1 . p2) pair (list)
|
|
;;; #(free-id <key>) <key> with literal-identifier=?
|
|
;;; each-any any proper list
|
|
;;; #(each p) (p*)
|
|
;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3)
|
|
;;; #(vector p) (list->vector p)
|
|
;;; #(atom <object>) <object> with "equal?"
|
|
|
|
;;; Vector cops out to pair under assumption that vectors are rare. If
|
|
;;; not, should convert to:
|
|
;;; #(vector p) #(p*)
|
|
|
|
(let ()
|
|
|
|
(define match-each
|
|
(lambda (e p w)
|
|
(cond
|
|
((annotation? e)
|
|
(match-each (annotation-expression e) p w))
|
|
((pair? e)
|
|
(let ((first (match (car e) p w '())))
|
|
(and first
|
|
(let ((rest (match-each (cdr e) p w)))
|
|
(and rest (cons first rest))))))
|
|
((null? e) '())
|
|
((syntax-object? e)
|
|
(match-each (syntax-object-expression e)
|
|
p
|
|
(join-wraps w (syntax-object-wrap e))))
|
|
(else #f))))
|
|
|
|
(define match-each+
|
|
(lambda (e x-pat y-pat z-pat w r)
|
|
(let f ((e e) (w w))
|
|
(cond
|
|
((pair? e)
|
|
(let-values (((xr* y-pat r) (f (cdr e) w)))
|
|
(if r
|
|
(if (null? y-pat)
|
|
(let ((xr (match (car e) x-pat w '())))
|
|
(if xr
|
|
(values (cons xr xr*) y-pat r)
|
|
(values #f #f #f)))
|
|
(values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
|
|
(values #f #f #f))))
|
|
((annotation? e) (f (annotation-expression e) w))
|
|
((syntax-object? e) (f (syntax-object-expression e)
|
|
(join-wraps w (syntax-object-wrap e))))
|
|
(else (values '() y-pat (match e z-pat w r)))))))
|
|
|
|
(define match-each-any
|
|
(lambda (e w)
|
|
(cond
|
|
((annotation? e)
|
|
(match-each-any (annotation-expression e) w))
|
|
((pair? e)
|
|
(let ((l (match-each-any (cdr e) w)))
|
|
(and l (cons (wrap (car e) w) l))))
|
|
((null? e) '())
|
|
((syntax-object? e)
|
|
(match-each-any (syntax-object-expression e)
|
|
(join-wraps w (syntax-object-wrap e))))
|
|
(else #f))))
|
|
|
|
(define match-empty
|
|
(lambda (p r)
|
|
(cond
|
|
((null? p) r)
|
|
((eq? p 'any) (cons '() r))
|
|
((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
|
|
((eq? p 'each-any) (cons '() r))
|
|
(else
|
|
(case (vector-ref p 0)
|
|
((each) (match-empty (vector-ref p 1) r))
|
|
((each+) (match-empty (vector-ref p 1)
|
|
(match-empty (reverse (vector-ref p 2))
|
|
(match-empty (vector-ref p 3) r))))
|
|
((free-id atom) r)
|
|
((vector) (match-empty (vector-ref p 1) r)))))))
|
|
|
|
(define combine
|
|
(lambda (r* r)
|
|
(if (null? (car r*))
|
|
r
|
|
(cons (map car r*) (combine (map cdr r*) r)))))
|
|
|
|
(define match*
|
|
(lambda (e p w r)
|
|
(cond
|
|
((null? p) (and (null? e) r))
|
|
((pair? p)
|
|
(and (pair? e) (match (car e) (car p) w
|
|
(match (cdr e) (cdr p) w r))))
|
|
((eq? p 'each-any)
|
|
(let ((l (match-each-any e w))) (and l (cons l r))))
|
|
(else
|
|
(case (vector-ref p 0)
|
|
((each)
|
|
(if (null? e)
|
|
(match-empty (vector-ref p 1) r)
|
|
(let ((r* (match-each e (vector-ref p 1) w)))
|
|
(and r* (combine r* r)))))
|
|
((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
|
|
((each+)
|
|
(let-values (((xr* y-pat r)
|
|
(match-each+ e (vector-ref p 1) (vector-ref p 2)
|
|
(vector-ref p 3) w r)))
|
|
(and r (null? y-pat)
|
|
(if (null? xr*)
|
|
(match-empty (vector-ref p 1) r)
|
|
(combine xr* r)))))
|
|
((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
|
|
((vector)
|
|
(and (vector? e)
|
|
(match (vector->list e) (vector-ref p 1) w r))))))))
|
|
|
|
(define match
|
|
(lambda (e p w r)
|
|
(cond
|
|
((not r) #f)
|
|
((eq? p 'any) (cons (wrap e w) r))
|
|
((syntax-object? e)
|
|
(match*
|
|
(unannotate (syntax-object-expression e))
|
|
p
|
|
(join-wraps w (syntax-object-wrap e))
|
|
r))
|
|
(else (match* (unannotate e) p w r)))))
|
|
|
|
(primitive-set! '$syntax-dispatch
|
|
(lambda (e p)
|
|
(cond
|
|
((eq? p 'any) (list e))
|
|
((syntax-object? e)
|
|
(match* (unannotate (syntax-object-expression e))
|
|
p (syntax-object-wrap e) '()))
|
|
(else (match* (unannotate e) p empty-wrap '())))))
|
|
))
|
|
|
|
;;; global macros
|
|
|
|
(define-syntax with-syntax
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ () e1 e2 ...)
|
|
(syntax (begin e1 e2 ...)))
|
|
((_ ((out in)) e1 e2 ...)
|
|
(syntax (syntax-case in () (out (begin e1 e2 ...)))))
|
|
((_ ((out in) ...) e1 e2 ...)
|
|
(syntax (syntax-case (list in ...) ()
|
|
((out ...) (begin e1 e2 ...))))))))
|
|
|
|
(define-syntax with-implicit
|
|
(syntax-rules ()
|
|
((_ (tid id ...) e1 e2 ...)
|
|
(andmap identifier? (syntax (tid id ...)))
|
|
(begin
|
|
(unless (identifier? (syntax tid))
|
|
(syntax-error (syntax tid) "non-identifier with-implicit template"))
|
|
(with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
|
|
e1 e2 ...)))))
|
|
|
|
(define-syntax datum
|
|
(syntax-rules ()
|
|
((_ x) (syntax-object->datum (syntax x)))))
|
|
|
|
(define-syntax syntax-rules
|
|
(lambda (x)
|
|
(define clause
|
|
(lambda (y)
|
|
(syntax-case y ()
|
|
(((keyword . pattern) template)
|
|
(syntax ((dummy . pattern) (syntax template))))
|
|
(((keyword . pattern) fender template)
|
|
(syntax ((dummy . pattern) fender (syntax template))))
|
|
(_ (syntax-error x)))))
|
|
(syntax-case x ()
|
|
((_ (k ...) cl ...)
|
|
(andmap identifier? (syntax (k ...)))
|
|
(with-syntax (((cl ...) (map clause (syntax (cl ...)))))
|
|
(syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
|
|
|
|
(define-syntax or
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_) (syntax #f))
|
|
((_ e) (syntax e))
|
|
((_ e1 e2 e3 ...)
|
|
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
|
|
|
|
(define-syntax and
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
|
|
((_ e) (syntax e))
|
|
((_) (syntax #t)))))
|
|
|
|
(define-syntax let
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ ((x v) ...) e1 e2 ...)
|
|
(andmap identifier? (syntax (x ...)))
|
|
(syntax ((lambda (x ...) e1 e2 ...) v ...)))
|
|
((_ f ((x v) ...) e1 e2 ...)
|
|
(andmap identifier? (syntax (f x ...)))
|
|
(syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
|
|
v ...))))))
|
|
|
|
(define-syntax let*
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((let* ((x v) ...) e1 e2 ...)
|
|
(andmap identifier? (syntax (x ...)))
|
|
(let f ((bindings (syntax ((x v) ...))))
|
|
(if (null? bindings)
|
|
(syntax (let () e1 e2 ...))
|
|
(with-syntax ((body (f (cdr bindings)))
|
|
(binding (car bindings)))
|
|
(syntax (let (binding) body)))))))))
|
|
|
|
(define-syntax cond
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ m1 m2 ...)
|
|
(let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
|
|
(if (null? clauses)
|
|
(syntax-case clause (else =>)
|
|
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
|
|
((e0) (syntax (let ((t e0)) (if t t))))
|
|
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
|
|
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
|
|
(_ (syntax-error x)))
|
|
(with-syntax ((rest (f (car clauses) (cdr clauses))))
|
|
(syntax-case clause (else =>)
|
|
((e0) (syntax (let ((t e0)) (if t t rest))))
|
|
((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
|
|
((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
|
|
(_ (syntax-error x))))))))))
|
|
|
|
(define-syntax do
|
|
(lambda (orig-x)
|
|
(syntax-case orig-x ()
|
|
((_ ((var init . step) ...) (e0 e1 ...) c ...)
|
|
(with-syntax (((step ...)
|
|
(map (lambda (v s)
|
|
(syntax-case s ()
|
|
(() v)
|
|
((e) (syntax e))
|
|
(_ (syntax-error orig-x))))
|
|
(syntax (var ...))
|
|
(syntax (step ...)))))
|
|
(syntax-case (syntax (e1 ...)) ()
|
|
(() (syntax (let do ((var init) ...)
|
|
(if (not e0)
|
|
(begin c ... (do step ...))))))
|
|
((e1 e2 ...)
|
|
(syntax (let do ((var init) ...)
|
|
(if e0
|
|
(begin e1 e2 ...)
|
|
(begin c ... (do step ...))))))))))))
|
|
|
|
(define-syntax quasiquote
|
|
(letrec
|
|
; these are here because syntax-case uses literal-identifier=?,
|
|
; and we want the more precise free-identifier=?
|
|
((isquote? (lambda (x)
|
|
(and (identifier? x)
|
|
(free-identifier=? x (syntax quote)))))
|
|
(islist? (lambda (x)
|
|
(and (identifier? x)
|
|
(free-identifier=? x (syntax list)))))
|
|
(iscons? (lambda (x)
|
|
(and (identifier? x)
|
|
(free-identifier=? x (syntax cons)))))
|
|
(quote-nil? (lambda (x)
|
|
(syntax-case x ()
|
|
((quote? ()) (isquote? (syntax quote?)))
|
|
(_ #f))))
|
|
(quasilist*
|
|
(lambda (x y)
|
|
(let f ((x x))
|
|
(if (null? x)
|
|
y
|
|
(quasicons (car x) (f (cdr x)))))))
|
|
(quasicons
|
|
(lambda (x y)
|
|
(with-syntax ((x x) (y y))
|
|
(syntax-case (syntax y) ()
|
|
((quote? dy)
|
|
(isquote? (syntax quote?))
|
|
(syntax-case (syntax x) ()
|
|
((quote? dx)
|
|
(isquote? (syntax quote?))
|
|
(syntax (quote (dx . dy))))
|
|
(_ (if (null? (syntax dy))
|
|
(syntax (list x))
|
|
(syntax (cons x y))))))
|
|
((listp . stuff)
|
|
(islist? (syntax listp))
|
|
(syntax (list x . stuff)))
|
|
(else (syntax (cons x y)))))))
|
|
(quasiappend
|
|
(lambda (x y)
|
|
(let ((ls (let f ((x x))
|
|
(if (null? x)
|
|
(if (quote-nil? y)
|
|
'()
|
|
(list y))
|
|
(if (quote-nil? (car x))
|
|
(f (cdr x))
|
|
(cons (car x) (f (cdr x))))))))
|
|
(cond
|
|
((null? ls) (syntax (quote ())))
|
|
((null? (cdr ls)) (car ls))
|
|
(else (with-syntax (((p ...) ls))
|
|
(syntax (append p ...))))))))
|
|
(quasivector
|
|
(lambda (x)
|
|
(with-syntax ((pat-x x))
|
|
(syntax-case (syntax pat-x) ()
|
|
((quote? (x ...))
|
|
(isquote? (syntax quote?))
|
|
(syntax (quote #(x ...))))
|
|
(_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
|
|
(syntax-case x ()
|
|
((quote? (x ...))
|
|
(isquote? (syntax quote?))
|
|
(k (syntax ((quote x) ...))))
|
|
((listp x ...)
|
|
(islist? (syntax listp))
|
|
(k (syntax (x ...))))
|
|
((cons? x y)
|
|
(iscons? (syntax cons?))
|
|
(f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
|
|
(else
|
|
(syntax (list->vector pat-x))))))))))
|
|
(vquasi
|
|
(lambda (p lev)
|
|
(syntax-case p ()
|
|
((p . q)
|
|
(syntax-case #'p (unquote unquote-splicing)
|
|
((unquote p ...)
|
|
(if (fx= lev 0)
|
|
(quasilist* (syntax (p ...)) (vquasi (syntax q) lev))
|
|
(quasicons (quasicons (syntax (quote unquote))
|
|
(quasi (syntax (p ...)) (fx- lev 1)))
|
|
(vquasi (syntax q) lev))))
|
|
((unquote-splicing p ...)
|
|
(if (fx= lev 0)
|
|
(quasiappend (syntax (p ...)) (vquasi (syntax q) lev))
|
|
(quasicons (quasicons (syntax (quote unquote-splicing))
|
|
(quasi (syntax (p ...)) (fx- lev 1)))
|
|
(vquasi (syntax q) lev))))
|
|
(p (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev)))))
|
|
(() (syntax (quote ()))))))
|
|
(quasi
|
|
(lambda (p lev)
|
|
(syntax-case p (unquote unquote-splicing quasiquote)
|
|
((unquote p)
|
|
(if (fx= lev 0)
|
|
(syntax p)
|
|
(quasicons (syntax (quote unquote))
|
|
(quasi (syntax (p)) (fx- lev 1)))))
|
|
(((unquote p ...) . q)
|
|
(if (fx= lev 0)
|
|
(quasilist* (syntax (p ...)) (quasi (syntax q) lev))
|
|
(quasicons (quasicons (syntax (quote unquote))
|
|
(quasi (syntax (p ...)) (fx- lev 1)))
|
|
(quasi (syntax q) lev))))
|
|
(((unquote-splicing p ...) . q)
|
|
(if (fx= lev 0)
|
|
(quasiappend (syntax (p ...)) (quasi (syntax q) lev))
|
|
(quasicons (quasicons (syntax (quote unquote-splicing))
|
|
(quasi (syntax (p ...)) (fx- lev 1)))
|
|
(quasi (syntax q) lev))))
|
|
((quasiquote p)
|
|
(quasicons (syntax (quote quasiquote))
|
|
(quasi (syntax (p)) (fx+ lev 1))))
|
|
((p . q)
|
|
(quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
|
|
(#(x ...) (quasivector (vquasi (syntax (x ...)) lev)))
|
|
(p (syntax (quote p)))))))
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ e) (quasi (syntax e) 0))))))
|
|
|
|
(define-syntax unquote
|
|
(lambda (x)
|
|
(syntax-error x "misplaced")))
|
|
|
|
(define-syntax unquote-splicing
|
|
(lambda (x)
|
|
(syntax-error x "misplaced")))
|
|
|
|
(define-syntax quasisyntax
|
|
(lambda (x)
|
|
(define (qs q n b* k)
|
|
(syntax-case q (quasisyntax unsyntax unsyntax-splicing)
|
|
((quasisyntax . d)
|
|
(qs #'d (fx+ n 1) b*
|
|
(lambda (b* dnew)
|
|
(k b*
|
|
(if (eq? dnew #'d)
|
|
q
|
|
(with-syntax ((d dnew)) #'(quasisyntax . d)))))))
|
|
((unsyntax . d)
|
|
(not (fx= n 0))
|
|
(qs #'d (fx- n 1) b*
|
|
(lambda (b* dnew)
|
|
(k b*
|
|
(if (eq? dnew #'d)
|
|
q
|
|
(with-syntax ((d dnew)) #'(unsyntax . d)))))))
|
|
((unsyntax-splicing . d)
|
|
(not (fx= n 0))
|
|
(qs #'d (fx- n 1) b*
|
|
(lambda (b* dnew)
|
|
(k b*
|
|
(if (eq? dnew #'d)
|
|
q
|
|
(with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
|
|
((unsyntax q)
|
|
(fx= n 0)
|
|
(with-syntax (((t) (generate-temporaries #'(q))))
|
|
(k (cons #'(t q) b*) #'t)))
|
|
(((unsyntax q ...) . d)
|
|
(fx= n 0)
|
|
(qs #'d n b*
|
|
(lambda (b* dnew)
|
|
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
|
|
(k (append #'((t q) ...) b*)
|
|
(with-syntax ((d dnew)) #'(t ... . d)))))))
|
|
(((unsyntax-splicing q ...) . d)
|
|
(fx= n 0)
|
|
(qs #'d n b*
|
|
(lambda (b* dnew)
|
|
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
|
|
(k (append #'(((t (... ...)) q) ...) b*)
|
|
(with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
|
|
(with-syntax ((d dnew)) #'(m ... ... . d))))))))
|
|
((a . d)
|
|
(qs #'a n b*
|
|
(lambda (b* anew)
|
|
(qs #'d n b*
|
|
(lambda (b* dnew)
|
|
(k b*
|
|
(if (and (eq? anew #'a) (eq? dnew #'d))
|
|
q
|
|
(with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
|
|
(#(x ...)
|
|
(vqs #'(x ...) n b*
|
|
(lambda (b* xnew*)
|
|
(k b*
|
|
(if (let same? ((x* #'(x ...)) (xnew* xnew*))
|
|
(if (null? x*)
|
|
(null? xnew*)
|
|
(and (not (null? xnew*))
|
|
(eq? (car x*) (car xnew*))
|
|
(same? (cdr x*) (cdr xnew*)))))
|
|
q
|
|
(with-syntax (((x ...) xnew*)) #'#(x ...)))))))
|
|
(_ (k b* q))))
|
|
(define (vqs x* n b* k)
|
|
(if (null? x*)
|
|
(k b* '())
|
|
(vqs (cdr x*) n b*
|
|
(lambda (b* xnew*)
|
|
(syntax-case (car x*) (unsyntax unsyntax-splicing)
|
|
((unsyntax q ...)
|
|
(fx= n 0)
|
|
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
|
|
(k (append #'((t q) ...) b*)
|
|
(append #'(t ...) xnew*))))
|
|
((unsyntax-splicing q ...)
|
|
(fx= n 0)
|
|
(with-syntax (((t ...) (generate-temporaries #'(q ...))))
|
|
(k (append #'(((t (... ...)) q) ...) b*)
|
|
(with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
|
|
(append #'(m ... ...) xnew*)))))
|
|
(_ (qs (car x*) n b*
|
|
(lambda (b* xnew)
|
|
(k b* (cons xnew xnew*))))))))))
|
|
(syntax-case x ()
|
|
((_ x)
|
|
(qs #'x 0 '()
|
|
(lambda (b* xnew)
|
|
(if (eq? xnew #'x)
|
|
#'(syntax x)
|
|
(with-syntax (((b ...) b*) (x xnew))
|
|
#'(with-syntax (b ...) (syntax x))))))))))
|
|
|
|
(define-syntax unsyntax
|
|
(lambda (x)
|
|
(syntax-error x "misplaced")))
|
|
|
|
(define-syntax unsyntax-splicing
|
|
(lambda (x)
|
|
(syntax-error x "misplaced")))
|
|
|
|
(define-syntax include
|
|
(lambda (x)
|
|
(define read-file
|
|
(lambda (fn k)
|
|
(let ((p (open-input-file fn)))
|
|
(let f ()
|
|
(let ((x (read p)))
|
|
(if (eof-object? x)
|
|
(begin (close-input-port p) '())
|
|
(cons (datum->syntax-object k x) (f))))))))
|
|
(syntax-case x ()
|
|
((k filename)
|
|
(let ((fn (syntax-object->datum (syntax filename))))
|
|
(with-syntax (((exp ...) (read-file fn (syntax k))))
|
|
(syntax (begin exp ...))))))))
|
|
|
|
(define-syntax case
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ e m1 m2 ...)
|
|
(with-syntax
|
|
((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
|
|
(if (null? clauses)
|
|
(syntax-case clause (else)
|
|
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
|
|
(((k ...) e1 e2 ...)
|
|
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
|
|
(_ (syntax-error x)))
|
|
(with-syntax ((rest (f (car clauses) (cdr clauses))))
|
|
(syntax-case clause (else)
|
|
(((k ...) e1 e2 ...)
|
|
(syntax (if (memv t '(k ...))
|
|
(begin e1 e2 ...)
|
|
rest)))
|
|
(_ (syntax-error x))))))))
|
|
(syntax (let ((t e)) body)))))))
|
|
|
|
(define-syntax identifier-syntax
|
|
(syntax-rules (set!)
|
|
((_ e)
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
(id (identifier? (syntax id)) (syntax e))
|
|
((_ x (... ...)) (syntax (e x (... ...)))))))
|
|
((_ (id exp1) ((set! var val) exp2))
|
|
(and (identifier? (syntax id)) (identifier? (syntax var)))
|
|
(cons 'macro!
|
|
(lambda (x)
|
|
(syntax-case x (set!)
|
|
((set! var val) (syntax exp2))
|
|
((id x (... ...)) (syntax (exp1 x (... ...))))
|
|
(id (identifier? (syntax id)) (syntax exp1))))))))
|
|
|
|
(define-syntax parameterize
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ () b b* ...) #'(let () b b* ...)]
|
|
[(_ ([olhs* orhs*] ...) b b* ...)
|
|
(with-syntax ([(lhs* ...) (generate-temporaries #'(olhs* ...))]
|
|
[(rhs* ...) (generate-temporaries #'(orhs* ...))])
|
|
#'(let ([lhs* olhs*] ...
|
|
[rhs* orhs*] ...)
|
|
(let ([swap
|
|
(lambda ()
|
|
(let ([t (lhs*)])
|
|
(lhs* rhs*)
|
|
(set! rhs* t)) ...)])
|
|
(dynamic-wind
|
|
swap
|
|
(lambda () b b* ...)
|
|
swap))))])))
|
|
|
|
(define-syntax when
|
|
(syntax-rules ()
|
|
[(_ test b b* ...)
|
|
(if test
|
|
(begin b b* ...)
|
|
(void))]))
|
|
|
|
(define-syntax unless
|
|
(syntax-rules ()
|
|
[(_ test b b* ...)
|
|
(if test
|
|
(void)
|
|
(begin b b* ...))]))
|
|
|
|
(define-syntax let-values
|
|
(lambda (x)
|
|
(define (bindem n** v**)
|
|
(syntax-case n** ()
|
|
[() #'()]
|
|
[((n* ...) . n**)
|
|
(syntax-case v** ()
|
|
[((v* ...) . v**)
|
|
(with-syntax ([rest (bindem #'n** #'v**)])
|
|
#'([n* v*] ... . rest))])]))
|
|
(syntax-case x ()
|
|
[(_ ([(name** ...) v*] ...) b b* ...)
|
|
(let ([n**
|
|
(let f ([n** #'((name** ...) ...)])
|
|
(syntax-case n** ()
|
|
[() #'()]
|
|
[(n* . n**)
|
|
(with-syntax ([n* (generate-temporaries #'n*)]
|
|
[n** (f #'n**)])
|
|
#'(n* . n**))]))])
|
|
(let f ([t** n**] [v* #'(v* ...)])
|
|
(syntax-case t** ()
|
|
[((t* ...) . t**)
|
|
(syntax-case v* ()
|
|
[(v . v*)
|
|
(with-syntax ([body (f #'t** #'v*)])
|
|
#'(call-with-values
|
|
(lambda () v)
|
|
(lambda (t* ...) body)))])]
|
|
[()
|
|
(with-syntax ([bind* (bindem #'((name** ...) ...) n**)])
|
|
#'(let bind* b b* ...))])))])))
|
|
|
|
|
|
|
|
(define-syntax define-record
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name (field* ...))
|
|
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
|
|
[fields (syntax-object->datum #'(field* ...))]
|
|
[fieldstr* (map symbol->string fields)]
|
|
[rtd (make-record-type namestr fields)])
|
|
(with-syntax ([constr
|
|
(datum->syntax-object #'name
|
|
(string->symbol
|
|
(string-append "make-" namestr)))]
|
|
[pred
|
|
(datum->syntax-object #'name
|
|
(string->symbol
|
|
(string-append namestr "?")))]
|
|
[(i ...)
|
|
(datum->syntax-object #'name
|
|
(let f ([i 0] [f* fieldstr*])
|
|
(cond
|
|
[(null? f*) '()]
|
|
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
|
|
[(getters ...)
|
|
(datum->syntax-object #'name
|
|
(map (lambda (x)
|
|
(string->symbol
|
|
(string-append namestr "-" x)))
|
|
fieldstr*))]
|
|
[(setters ...)
|
|
(datum->syntax-object #'name
|
|
(map (lambda (x)
|
|
(string->symbol
|
|
(string-append "set-" namestr "-" x "!")))
|
|
fieldstr*))]
|
|
[rtd rtd])
|
|
#'(begin
|
|
(define-syntax name (cons '$rtd 'rtd))
|
|
(define constr
|
|
(lambda (field* ...)
|
|
($record 'rtd field* ...)))
|
|
(define pred
|
|
(lambda (x) ($record/rtd? x 'rtd)))
|
|
(define getters
|
|
(lambda (x)
|
|
(if ($record/rtd? x 'rtd)
|
|
($record-ref x i)
|
|
(error 'getters
|
|
"~s is not a record of type ~s" x 'rtd)))) ...
|
|
(define setters
|
|
(lambda (x v)
|
|
(if ($record/rtd? x 'rtd)
|
|
($record-set! x i v)
|
|
(error 'setters
|
|
"~s is not a record of type ~s" x 'rtd)))) ...
|
|
)))])))
|
|
|
|
|
|
(define-syntax $define-record-syntax
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name (field* ...))
|
|
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
|
|
[fields (syntax-object->datum #'(field* ...))]
|
|
[fieldstr* (map symbol->string fields)]
|
|
[rtd (make-record-type namestr fields)])
|
|
(with-syntax ([constr
|
|
(datum->syntax-object #'name
|
|
(string->symbol
|
|
(string-append "make-" namestr)))]
|
|
[pred
|
|
(datum->syntax-object #'name
|
|
(string->symbol
|
|
(string-append namestr "?")))]
|
|
[(i ...)
|
|
(datum->syntax-object #'name
|
|
(let f ([i 0] [f* fieldstr*])
|
|
(cond
|
|
[(null? f*) '()]
|
|
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
|
|
[(getters ...)
|
|
(datum->syntax-object #'name
|
|
(map (lambda (x)
|
|
(string->symbol
|
|
(string-append namestr "-" x)))
|
|
fieldstr*))]
|
|
[(setters ...)
|
|
(datum->syntax-object #'name
|
|
(map (lambda (x)
|
|
(string->symbol
|
|
(string-append "set-" namestr "-" x "!")))
|
|
fieldstr*))]
|
|
[rtd rtd])
|
|
#'(begin
|
|
(define-syntax name (cons '$rtd 'rtd))
|
|
(define-syntax constr
|
|
(syntax-rules ()
|
|
[(_ field* ...) ($record 'rtd field* ...)]))
|
|
(define-syntax pred
|
|
(syntax-rules ()
|
|
[(_ x) ($record/rtd? x 'rtd)]))
|
|
(define-syntax getters
|
|
(syntax-rules ()
|
|
[(_ x) ($record-ref x i)])) ...
|
|
(define-syntax setters
|
|
(syntax-rules ()
|
|
[(_ x v) ($record-set! x i v)])) ...
|
|
)))])))
|
|
|
|
(define-syntax trace
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ id) (identifier? #'id)
|
|
#'(trace-symbol! 'id)])))
|
|
|
|
|
|
(define-syntax untrace
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ id) (identifier? #'id)
|
|
#'(untrace-symbol! 'id)])))
|
|
|
|
|
|
(define-syntax trace-lambda
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name args body body* ...)
|
|
#'(make-traced-procedure 'name (lambda args body body* ...))])))
|
|
|