;;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see according
;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
;;; 2000-09-12, 2001-03-08
;;; Copyright (c) 1992-1997 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,
;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). 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.
;;; The remaining exports are listed below:
;;;
;;; (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 (see the Chez Scheme System Manual,
;;; Revision 3, for a complete description)
;;; (syntax-error object message)
;;; used to report errors found during expansion
;;; (install-global-transformer symbol value)
;;; used by expanded code to install top-level syntactic abstractions
;;; (syntax-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the
;;; implementation for this code to run.
;;;
;;; (void)
;;; returns the implementation's cannonical "unspecified value". This
;;; 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)))))))))
;;;
;;; 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, will result 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 : "
;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
;;;
;;; (putprop symbol key value)
;;; (getprop symbol key)
;;; key is always the symbol *sc-expander*; value may be any object.
;;; putprop should associate the given value with the given symbol in
;;; some way that it can be retrieved later with getprop.
;;; 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 ) to be
;;; abbreviated to #', just as (quote ) may be
;;; abbreviated to '. The #' syntax makes programs written
;;; using syntax-case shorter and more readable and draws out the
;;; intuitive connection between syntax and quote.
;;; 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 information:
;;; "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 R4RS appendix and probably the R5RS
;;; when it comes out. A consequence, 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 R4RS/expected R5RS.
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, 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.
;;; All identifiers that don't have macro definitions and are not bound
;;; lexically are assumed to be global variables
;;; Top-level definitions of macro-introduced identifiers are allowed.
;;; This may not be appropriate for implementations in which the
;;; model is that bindings are created by definitions, as opposed to
;;; one in which initial values are assigned by definitions.
;;; Top-level variable definitions of syntax keywords is not permitted.
;;; Any solution allowing this would be kludgey and would yield
;;; surprising results in some cases. We can provide an undefine-syntax
;;; form. The questions is, should define be an implicit undefine-syntax?
;;; We've decided no for now.
;;; Identifiers and syntax objects are implemented as vectors for
;;; portability. As a result, it is possible to "forge" syntax
;;; objects.
;;; The implementation of generate-temporaries assumes that it is possible
;;; to generate globally unique symbols (gensyms).
;;; 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 make-annotation, annotation-expression,
;;; annotation-source, annotation-stripped, and set-annotation-stripped!
;;; are supplied. If annotations are supplied, the proper annotation
;;; source 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.
;;; 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 recognize old representations and treat
;;; them as not lexically bound.
(let ()
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
(datum->syntax-object
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
(symbol->string (syntax-object->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
(andmap identifier? (syntax (name id1 ...)))
(with-syntax
((constructor (construct-name (syntax name) "make-" (syntax name)))
(predicate (construct-name (syntax name) (syntax name) "?"))
((access ...)
(map (lambda (x) (construct-name x (syntax name) "-" x))
(syntax (id1 ...))))
((assign ...)
(map (lambda (x)
(construct-name x "set-" (syntax name) "-" x "!"))
(syntax (id1 ...))))
(structure-length
(+ (length (syntax (id1 ...))) 1))
((index ...)
(let f ((i 1) (ids (syntax (id1 ...))))
(if (null? ids)
'()
(cons i (f (+ i 1) (cdr ids)))))))
(syntax (begin
(define constructor
(lambda (id1 ...)
(vector 'name id1 ... )))
(define predicate
(lambda (x)
(and (vector? x)
(= (vector-length x) structure-length)
(eq? (vector-ref x 0) 'name))))
(define access
(lambda (x)
(vector-ref x index)))
...
(define assign
(lambda (x update)
(vector-set! x index update)))
...)))))))
(let ()
(define noexpand "noexpand")
;;; hooks to nonportable run-time helpers
(begin
(define fx+ +)
(define fx- -)
(define fx= =)
(define fx< <)
(define annotation? (lambda (x) #f))
(define top-level-eval-hook
(lambda (x)
(eval `(,noexpand ,x) (interaction-environment))))
(define local-eval-hook
(lambda (x)
(eval `(,noexpand ,x) (interaction-environment))))
(define error-hook
(lambda (who why what)
(error who "~a ~s" why what)))
(define-syntax gensym-hook
(syntax-rules ()
((_) (gensym))))
(define put-global-definition-hook
(lambda (symbol binding)
(putprop symbol '*sc-expander* binding)))
(define get-global-definition-hook
(lambda (symbol)
(getprop symbol '*sc-expander*)))
)
;;; output constructors
(begin
(define-syntax build-application
(syntax-rules ()
((_ source fun-exp arg-exps)
`(,fun-exp . ,arg-exps))))
(define-syntax build-conditional
(syntax-rules ()
((_ source test-exp then-exp else-exp)
`(if ,test-exp ,then-exp ,else-exp))))
(define-syntax build-lexical-reference
(syntax-rules ()
((_ type source var)
var)))
(define-syntax build-lexical-assignment
(syntax-rules ()
((_ source var exp)
`(set! ,var ,exp))))
(define-syntax build-global-reference
(syntax-rules ()
((_ source var)
var)))
(define-syntax build-global-assignment
(syntax-rules ()
((_ source var exp)
`(set! ,var ,exp))))
(define-syntax build-global-definition
(syntax-rules ()
((_ source var exp)
`(define ,var ,exp))))
(define-syntax build-lambda
(syntax-rules ()
((_ src vars exp)
`(lambda ,vars ,exp))))
(define-syntax build-primref
(syntax-rules ()
((_ src name) name)
((_ src level name) name)))
(define (build-data src exp)
(if (and (self-evaluating? exp)
(not (vector? exp)))
exp
(list 'quote exp)))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
`(begin ,@exps))))
(define build-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
body-exp
`(let ,(map list vars val-exps) ,body-exp))))
(define build-named-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
body-exp
`(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
(define build-letrec
(lambda (src vars val-exps body-exp)
(if (null? vars)
body-exp
`(letrec ,(map list vars val-exps) ,body-exp))))
(define-syntax build-lexical-var
(syntax-rules ()
((_ src id) (gensym (symbol->string id)))))
)
(define-structure (syntax-object expression wrap))
(define-syntax unannotate
(syntax-rules ()
((_ x)
(let ((e x))
(if (annotation? e)
(annotation-expression e)
e)))))
(define-syntax no-source (identifier-syntax #f))
(define source-annotation
(lambda (x)
(cond
((annotation? x) (annotation-source x))
((syntax-object? x) (source-annotation (syntax-object-expression x)))
(else no-source))))
(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 -->
;;; 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.
;;; ::= (( . )*)
;;; identifier bindings include a type and a value
;;; ::= (macro . ) macros
;;; (core . ) core forms
;;; (external-macro . ) external-macro
;;; (begin) begin
;;; (define) define
;;; (define-syntax) define-syntax
;;; (local-syntax . rec?) let-syntax/letrec-syntax
;;; (eval-when) eval-when
;;; (syntax . ( . )) pattern variables
;;; (global) assumed global variable
;;; (lexical . ) lexical variables
;;; (displaced-lexical) displaced lexicals
;;; ::=
;;; ::= 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, and eval-when are
;;; treated specially since they are sensitive to whether the form is
;;; at top-level and (except for eval-when) 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-syntax make-binding
(syntax-rules (quote)
((_ type value) (cons type value))
((_ 'type) '(type))
((_ type) (cons type '()))))
(define binding-type car)
(define binding-value cdr)
(define-syntax null-env (identifier-syntax '()))
(define extend-env
(lambda (labels bindings r)
(if (null? labels)
r
(extend-env (cdr labels) (cdr bindings)
(cons (cons (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)
(cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
;;; we use a "macros only" environment in expansion of local macro
;;; definitions so that their definitions can use local macros without
;;; attempting to use other lexical identifiers.
(define macros-only-env
(lambda (r)
(if (null? r)
'()
(let ((a (car r)))
(if (memq (cadr a) '(macro ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
(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)))
(else (make-binding 'displaced-lexical)))))
(define global-extend
(lambda (type sym val)
(put-global-definition-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-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
;;; ::= (( ...) . ( ...))
;;; ::= |
;;; ::= #( ( ...))
;;; ::= positive fixnum
(define make-wrap cons)
(define wrap-marks car)
(define wrap-subst cdr)
(define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
(define-syntax make-rename
(syntax-rules ()
((_ old new marks) (vector old new marks))))
;;; labels must be comparable with "eq?" and distinct from symbols.
(define gen-label
(lambda () (string #\i)))
(define gen-labels
(lambda (ls)
(if (null? ls)
'()
(cons (gen-label) (gen-labels (cdr ls))))))
(define-structure (ribcage symnames marks labels))
(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)))))
;;; 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))))
;;; 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
(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)))))
;;; 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))
(if (not (null? ids))
(call-with-values
(lambda () (id-sym-name&marks (car ids) w))
(lambda (symname marks)
(vector-set! symnamevec i symname)
(vector-set! marksvec i marks)
(f (cdr ids) (fx+ i 1))))))
(make-ribcage symnamevec marksvec labelvec))))
(wrap-subst w))))))
(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)
(smart-append s1 (wrap-subst w2))))
(make-wrap
(smart-append m1 (wrap-marks w2))
(smart-append s1 (wrap-subst w2)))))))
(define join-marks
(lambda (m1 m2)
(smart-append m1 m2)))
(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 id-var-name
(lambda (id w)
(define-syntax first
(syntax-rules ()
((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
(define search
(lambda (sym subst marks)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
(search sym (cdr subst) (cdr marks))
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
(search-vector-rib sym subst marks symnames fst)
(search-list-rib sym subst marks symnames fst))))))))
(define search-list-rib
(lambda (sym subst marks symnames ribcage)
(let f ((symnames symnames) (i 0))
(cond
((null? symnames) (search sym (cdr subst) marks))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
(values (list-ref (ribcage-labels ribcage) i) 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)
(or (first (search id (wrap-subst w) (wrap-marks w))) id))
((syntax-object? id)
(let ((id (unannotate (syntax-object-expression id)))
(w1 (syntax-object-wrap id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks))
(lambda (new-id marks)
(or new-id
(first (search id (wrap-subst w1) marks))
id))))))
((annotation? id)
(let ((id (unannotate id)))
(or (first (search id (wrap-subst w) (wrap-marks w))) id)))
(else (error-hook 'id-var-name "invalid id" id)))))
;;; 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)))))
;;; 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 bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
(and (eq? (unannotate (syntax-object-expression i))
(unannotate (syntax-object-expression j)))
(same-marks? (wrap-marks (syntax-object-wrap i))
(wrap-marks (syntax-object-wrap j))))
(eq? (unannotate i) (unannotate 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 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 s)
(wrap (if s (make-annotation x s #f) x) w)))
;;; expanding
(define chi-sequence
(lambda (body r w s)
(build-sequence s
(let dobody ((body body) (r r) (w w))
(if (null? body)
'()
(let ((first (chi (car body) r w)))
(cons first (dobody (cdr body) r w))))))))
(define chi-top-sequence
(lambda (body r w s m esew)
(build-sequence s
(let dobody ((body body) (r r) (w w) (m m) (esew esew))
(if (null? body)
'()
(let ((first (chi-top (car body) r w m esew)))
(cons first (dobody (cdr body) r w m esew))))))))
(define chi-install-global
(lambda (name e)
(build-application no-source
(build-primref no-source 'install-global-transformer)
(list (build-data no-source name) e))))
(define chi-when-list
(lambda (e when-list w)
; when-list is syntax'd version of list of situations
(let f ((when-list when-list) (situations '()))
(if (null? when-list)
situations
(f (cdr when-list)
(cons (let ((x (car when-list)))
(cond
((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval)
(else (syntax-error (wrap x w)
"invalid eval-when situation"))))
situations))))))
;;; syntax-type returns five values: type, value, e, w, and s. The first
;;; two are described in the table below.
;;;
;;; type value explanation
;;; -------------------------------------------------------------------
;;; core procedure core form (including singleton)
;;; external-macro procedure external macro
;;; lexical name lexical variable reference
;;; global name global variable reference
;;; begin none begin keyword
;;; define none define keyword
;;; define-syntax none define-syntax keyword
;;; local-syntax rec? letrec-syntax/let-syntax keyword
;;; eval-when none eval-when keyword
;;; syntax level pattern variable
;;; displaced-lexical none displaced lexical identifier
;;; lexical-call name call to lexical variable
;;; global-call name call to global variable
;;; call none any other call
;;; begin-form none begin expression
;;; define-form id variable definition
;;; define-syntax-form id syntax definition
;;; local-syntax-form rec? syntax definition
;;; eval-when-form none eval-when form
;;; constant none self-evaluating datum
;;; other none anything else
;;;
;;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form. w is the wrap for e.
;;; s is the source for the entire form.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer.
(define syntax-type
(lambda (e r w s rib)
(cond
((symbol? e)
(let* ((n (id-var-name e w))
(b (lookup n r))
(type (binding-type b)))
(case type
((lexical) (values type (binding-value b) e w s))
((global) (values type n e w s))
((macro)
(syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
(else (values type (binding-value b) e w s)))))
((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 s))
((global) (values 'global-call n e w s))
((macro)
(syntax-type (chi-macro (binding-value b) e r w rib)
r empty-wrap s rib))
((core external-macro) (values type (binding-value b) e w s))
((local-syntax)
(values 'local-syntax-form (binding-value b) e w s))
((begin) (values 'begin-form #f e w s))
((eval-when) (values 'eval-when-form #f e w s))
((define)
(syntax-case e ()
((_ name val)
(id? (syntax name))
(values 'define-form (syntax name) (syntax val) w s))
((_ (name . args) e1 e2 ...)
(and (id? (syntax name))
(valid-bound-ids? (lambda-var-list (syntax args))))
; need lambda here...
(values 'define-form (wrap (syntax name) w)
(cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
empty-wrap s))
((_ name)
(id? (syntax name))
(values 'define-form (wrap (syntax name) w)
(syntax (void))
empty-wrap s))))
((define-syntax)
(syntax-case e ()
((_ name val)
(id? (syntax name))
(values 'define-syntax-form (syntax name)
(syntax val) w s))))
((ellipsis)
(values 'ellipsis
(make-syntax-object (syntax-object-expression value)
(anti-mark (syntax-object-wrap value)))))
(else (values 'call #f e w s))))
(values 'call #f e w s))))
((syntax-object? e)
;; s can't be valid source if we've unwrapped
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
no-source rib))
((annotation? e)
(syntax-type (annotation-expression e) r w (annotation-source e) rib))
((self-evaluating? e) (values 'constant #f e w s))
(else (values 'other #f e w s)))))
(define chi-top
(lambda (e r w m esew)
(define-syntax eval-if-c&e
(syntax-rules ()
((_ m e)
(let ((x e))
(if (eq? m 'c&e) (top-level-eval-hook x))
x))))
(call-with-values
(lambda () (syntax-type e r w no-source #f))
(lambda (type value e w s)
(case type
((begin-form)
(syntax-case e ()
((_) (chi-void))
((_ e1 e2 ...)
(chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
((local-syntax-form)
(chi-local-syntax value e r w s
(lambda (body r w s)
(chi-top-sequence body r w s m esew))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e (syntax (x ...)) w))
(body (syntax (e1 e2 ...))))
(cond
((eq? m 'e)
(if (memq 'eval when-list)
(chi-top-sequence body r w s 'e '(eval))
(chi-void)))
((memq 'load when-list)
(if (or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(chi-top-sequence body r w s 'c&e '(compile load))
(if (memq m '(c c&e))
(chi-top-sequence body r w s 'c '(load))
(chi-void))))
((or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval)))
(chi-void))
(else (chi-void)))))))
((define-syntax-form)
(let ((n (id-var-name value w)) (r (macros-only-env r)))
(case m
((c)
(if (memq 'compile esew)
(let ((e (chi-install-global n (chi e r w))))
(top-level-eval-hook e)
(if (memq 'load esew) e (chi-void)))
(if (memq 'load esew)
(chi-install-global n (chi e r w))
(chi-void))))
((c&e)
(let ((e (chi-install-global n (chi e r w))))
(top-level-eval-hook e)
e))
(else
(if (memq 'eval esew)
(top-level-eval-hook
(chi-install-global n (chi e r w))))
(chi-void)))))
((define-form)
(let* ((n (id-var-name value w))
(type (binding-type (lookup n r))))
(case type
((global)
(eval-if-c&e m
(build-global-definition s n (chi e r w))))
((displaced-lexical)
(syntax-error (wrap value w) "identifier out of context"))
(else
(if (eq? type 'external-macro)
(eval-if-c&e m
(build-global-definition s n (chi e r w)))
(syntax-error (wrap value w)
"cannot define keyword at top level"))))))
(else (eval-if-c&e m (chi-expr type value e r w s))))))))
(define chi
(lambda (e r w)
(call-with-values
(lambda () (syntax-type e r w no-source #f))
(lambda (type value e w s)
(chi-expr type value e r w s)))))
(define chi-expr
(lambda (type value e r w s)
(case type
((lexical)
(build-lexical-reference 'value s value))
((core external-macro) (value e r w s))
((lexical-call)
(chi-application
(build-lexical-reference 'fun (source-annotation (car e)) value)
e r w s))
((global-call)
(chi-application
(build-global-reference (source-annotation (car e)) value)
e r w s))
((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
((global) (build-global-reference s value))
((call) (chi-application (chi (car e) r w) e r w s))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
((local-syntax-form)
(chi-local-syntax value e r w s chi-sequence))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e (syntax (x ...)) w)))
(if (memq 'eval when-list)
(chi-sequence (syntax (e1 e2 ...)) r w s)
(chi-void))))))
((define-form define-syntax-form)
(syntax-error (wrap value w) "invalid context for definition of"))
((syntax)
(syntax-error (source-wrap e w s)
"reference to pattern variable outside syntax form"))
((displaced-lexical)
(syntax-error (source-wrap e w s)
"reference to identifier outside its scope"))
(else (syntax-error (source-wrap e w s))))))
(define chi-application
(lambda (x e r w s)
(syntax-case e ()
((e0 e1 ...)
(build-application s x
(map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
(define chi-macro
(lambda (p e r w 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)
(if rib (cons rib (cdr s)) (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 x "encountered raw symbol in macro output"))
(else x))))
(rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
(define chi-body
;; 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 + +), which is itself
;; problematic since we don't know if a begin contains only
;; definitions until we've expanded it).
;;
;; Before processing the body, we also create a new environment
;; containing a placeholder for the bindings we will add later and
;; associate this environment with each form. In processing a
;; let-syntax or letrec-syntax, the associated environment may be
;; augmented with local keyword bindings, so the environment may
;; be different for different forms in the body. Once we have
;; gathered up all of the definitions, we evaluate the transformer
;; expressions and splice into r at the placeholder the new variable
;; and keyword bindings. This allows let-syntax or letrec-syntax
;; forms local to a portion or all of the body to shadow the
;; definition bindings.
;;
;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
;; into the body.
;;
;; outer-form is fully wrapped w/source
(lambda (body outer-form r w)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
(ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
(syntax-error outer-form "no expressions in body")
(let ((e (cdar body)) (er (caar body)))
(call-with-values
(lambda () (syntax-type e er empty-wrap no-source ribcage))
(lambda (type value e w s)
(case type
((define-form)
(let ((id (wrap value w)) (label (gen-label)))
(let ((var (gen-var id)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
(cons var vars) (cons (cons er (wrap e w)) vals)
(cons (make-binding 'lexical var) bindings)))))
((define-syntax-form)
(let ((id (wrap value w)) (label (gen-label)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
vars vals
(cons (make-binding 'macro (cons er (wrap e w)))
bindings))))
((begin-form)
(syntax-case e ()
((_ e1 ...)
(parse (let f ((forms (syntax (e1 ...))))
(if (null? forms)
(cdr body)
(cons (cons er (wrap (car forms) w))
(f (cdr forms)))))
ids labels vars vals bindings))))
((local-syntax-form)
(chi-local-syntax value e er w s
(lambda (forms er w s)
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
(cons (cons er (wrap (car forms) w))
(f (cdr forms)))))
ids labels vars vals bindings))))
(else ; found a non-definition
(if (null? ids)
(build-sequence no-source
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap))
(cons (cons er (source-wrap e w s))
(cdr body))))
(begin
(if (not (valid-bound-ids? ids))
(syntax-error outer-form
"invalid or duplicate identifier in definition"))
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
(if (eq? (car b) 'macro)
(let* ((er (cadr b))
(r-cache
(if (eq? er er-cache)
r-cache
(macros-only-env er))))
(set-cdr! b
(eval-local-transformer
(chi (cddr b) r-cache empty-wrap)))
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source
vars
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap))
vals)
(build-sequence no-source
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap))
(cons (cons er (source-wrap e w s))
(cdr body)))))))))))))))))
(define chi-lambda-clause
(lambda (e c r w k)
(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)))
(k new-vars
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(make-binding-wrap ids labels w)))))))
((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)))
(k (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)
(make-binding-wrap old-ids labels w)))))))
(_ (syntax-error e)))))
(define chi-local-syntax
(lambda (rec? e r w s k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-error e "duplicate bound keyword in")
(let ((labels (gen-labels ids)))
(let ((new-w (make-binding-wrap ids labels w)))
(k (syntax (e1 e2 ...))
(extend-env
labels
(let ((w (if rec? new-w w))
(trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
(eval-local-transformer (chi x trans-r w))))
(syntax (val ...))))
r)
new-w
s))))))
(_ (syntax-error (source-wrap e w s))))))
(define eval-local-transformer
(lambda (expanded)
(let ((p (local-eval-hook expanded)))
(if (procedure? p)
p
(syntax-error p "nonprocedure transformer")))))
(define chi-void
(lambda ()
(build-application no-source (build-primref no-source 'void) '())))
(define ellipsis?
(lambda (e r)
(and (nonsymbol-id? e)
;; If there is a binding for the special identifier
;; #{ $sc-ellipsis }# in the lexical environment of E,
;; and if the associated binding type is 'ellipsis',
;; then the binding's value specifies the custom ellipsis
;; identifier within that lexical environment, and the
;; comparison is done using 'bound-id=?'.
(let* ((id (make-syntax-object '$sc-ellipsis
(syntax-object-wrap e)))
(n (id-var-name id empty-wrap))
(b (lookup n r)))
(if (eq? (binding-type b) 'ellipsis)
(bound-id=? e (binding-value b))
(free-id=? e (syntax (... ...))))))))
;;; data
;;; strips all annotations from potentially circular reader output
(define strip-annotation
(lambda (x parent)
(cond
((pair? x)
(let ((new (cons #f #f)))
(when parent (set-annotation-stripped! parent new))
(set-car! new (strip-annotation (car x) #f))
(set-cdr! new (strip-annotation (cdr x) #f))
new))
((annotation? x)
(or (annotation-stripped x)
(strip-annotation (annotation-expression x) x)))
((vector? x)
(let ((new (make-vector (vector-length x))))
(when parent (set-annotation-stripped! parent new))
(let loop ((i (- (vector-length x) 1)))
(unless (fx< i 0)
(vector-set! new i (strip-annotation (vector-ref x i) #f))
(loop (fx- i 1))))
new))
(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)
(if (top-marked? w)
(if (or (annotation? x) (and (pair? x) (annotation? (car x))))
(strip-annotation x #f)
x)
(let f ((x x))
(cond
((syntax-object? x)
(strip (syntax-object-expression x) (syntax-object-wrap x)))
((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))))))
;;; lexical variables
(define gen-var
(lambda (id)
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
(if (annotation? id)
(build-lexical-var (annotation-source id) (annotation-expression id))
(build-lexical-var no-source 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))))))
;;; 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 w s)
(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)
(syntax-error (source-wrap id w s)
"identifier out of context"))))
(syntax (var ...))
names)
(chi-body
(syntax (e1 e2 ...))
(source-wrap e w s)
(extend-env
names
(let ((trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
(eval-local-transformer (chi x trans-r w))))
(syntax (val ...))))
r)
w)))
(_ (syntax-error (source-wrap e w s))))))
(global-extend 'core 'quote
(lambda (e r w s)
(syntax-case e ()
((_ e) (build-data s (strip (syntax e) w)))
(_ (syntax-error (source-wrap e w s))))))
(global-extend 'core 'syntax
(let ()
(define gen-syntax
(lambda (src e r maps ellipsis?)
(if (id? e)
(let ((label (id-var-name e empty-wrap)))
(let ((b (lookup label r)))
(if (eq? (binding-type b) 'syntax)
(call-with-values
(lambda ()
(let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e r)
(syntax-error src "misplaced ellipsis in syntax form")
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
(ellipsis? (syntax dots) r)
(gen-syntax src (syntax e) r maps (lambda (e r) #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) r)
(let f ((y (syntax y))
(k (lambda (maps)
(call-with-values
(lambda ()
(gen-syntax src (syntax x) r
(cons '() maps) ellipsis?))
(lambda (x maps)
(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) r)
(f (syntax y)
(lambda (maps)
(call-with-values
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
(syntax-error src
"extra ellipsis in syntax form")
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
(lambda () (gen-syntax src y r maps ellipsis?))
(lambda (y maps)
(call-with-values
(lambda () (k maps))
(lambda (x maps)
(values (gen-append x y) maps)))))))))
((x . y)
(call-with-values
(lambda () (gen-syntax src (syntax x) r maps ellipsis?))
(lambda (x maps)
(call-with-values
(lambda () (gen-syntax src (syntax y) r maps ellipsis?))
(lambda (y maps) (values (gen-cons x y) maps))))))
(#(e1 e2 ...)
(call-with-values
(lambda ()
(gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
(lambda (e maps) (values (gen-vector e) 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")
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-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-mappend
(lambda (e map-env)
`(apply (primitive append) ,(gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond
((eq? (car e) 'ref)
; identity map equivalence:
; (map (lambda (x) x) y) == y
(car actuals))
((andmap
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
`(map (primitive ,(car e))
,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else `(map (lambda ,formals ,e) ,@actuals))))))
(define gen-cons
(lambda (x y)
(case (car y)
((quote)
(if (eq? (car x) 'quote)
`(quote (,(cadr x) . ,(cadr y)))
(if (eq? (cadr y) '())
`(list ,x)
`(cons ,x ,y))))
((list) `(list ,x ,@(cdr y)))
(else `(cons ,x ,y)))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ()))
x
`(append ,x ,y))))
(define gen-vector
(lambda (x)
(cond
((eq? (car x) 'list) `(vector ,@(cdr x)))
((eq? (car x) 'quote) `(quote #(,@(cadr x))))
(else `(list->vector ,x)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
(if (fx= (length ls) 2)
(build-primref no-source 'map)
; really need to do our own checking here
(build-primref no-source 2 'map)) ; require error check
ls)))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r w s)
(let ((e (source-wrap e w s)))
(syntax-case e ()
((_ x)
(call-with-values
(lambda () (gen-syntax e (syntax x) r '() ellipsis?))
(lambda (e maps) (regen e))))
(_ (syntax-error e)))))))
(global-extend 'core 'lambda
(lambda (e r w s)
(syntax-case e ()
((_ . c)
(chi-lambda-clause (source-wrap e w s) (syntax c) r w
(lambda (vars body) (build-lambda s vars body)))))))
(global-extend 'core 'with-ellipsis
(lambda (e r w s)
(let* ((tmp e) (tmp (syntax-dispatch tmp '(_ any any . each-any))))
(if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
(apply (lambda (dots e1 e2)
(let ((id (if (symbol? dots)
'$sc-ellipsis
(make-syntax-object
'$sc-ellipsis
(syntax-object-wrap dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots w s)))))
(let ((nw (make-binding-wrap ids labels w))
(nr (extend-env labels bindings r)))
(chi-body (cons e1 e2) (source-wrap e nw s) nr nw)))))
tmp)
(syntax-error 'with-ellipsis "bad syntax")))))
(global-extend 'core 'let
(let ()
(define (chi-let e r w s constructor ids vals exps)
(if (not (valid-bound-ids? ids))
(syntax-error e "duplicate bound variable in")
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((nw (make-binding-wrap ids labels w))
(nr (extend-var-env labels new-vars r)))
(constructor s
new-vars
(map (lambda (x) (chi x r w)) vals)
(chi-body exps (source-wrap e nw s) nr nw))))))
(lambda (e r w s)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(chi-let e r w s
build-let
(syntax (id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
((_ f ((id val) ...) e1 e2 ...)
(id? (syntax f))
(chi-let e r w s
build-named-let
(syntax (f id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
(_ (syntax-error (source-wrap e w s)))))))
(global-extend 'core 'letrec
(lambda (e r w s)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-error e "duplicate bound variable in")
(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 s
new-vars
(map (lambda (x) (chi x r w)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
(_ (syntax-error (source-wrap e w s))))))
(global-extend 'core 'set!
(lambda (e r w s)
(syntax-case e ()
((_ id val)
(id? (syntax id))
(let ((val (chi (syntax val) r w))
(n (id-var-name (syntax id) w)))
(let ((b (lookup n r)))
(case (binding-type b)
((lexical)
(build-lexical-assignment s (binding-value b) val))
((global) (build-global-assignment s n val))
((displaced-lexical)
(syntax-error (wrap (syntax id) w)
"identifier out of context"))
(else (syntax-error (source-wrap e w s)))))))
((_ (getter arg ...) val)
(build-application s
(chi (syntax (setter getter)) r w)
(map (lambda (e) (chi e r w))
(syntax (arg ... val)))))
(_ (syntax-error (source-wrap e w s))))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())
(global-extend 'eval-when 'eval-when '())
(global-extend 'core 'syntax-case
(let ()
(define convert-pattern
; accepts pattern & keys
; returns syntax-dispatch pattern & ids
(lambda (pattern keys ellipsis?)
(let cvt ((p pattern) (n 0) (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))
(call-with-values
(lambda () (cvt (syntax x) (fx+ n 1) ids))
(lambda (p ids)
(values (if (eq? p 'any) 'each-any (vector 'each p))
ids))))
((x . y)
(call-with-values
(lambda () (cvt (syntax y) n ids))
(lambda (y ids)
(call-with-values
(lambda () (cvt (syntax x) n ids))
(lambda (x ids)
(values (cons x y) ids))))))
(() (values '() ids))
(#(x ...)
(call-with-values
(lambda () (cvt (syntax (x ...)) n ids))
(lambda (p ids) (values (vector 'vector p) ids))))
(x (values (vector 'atom (strip p empty-wrap)) ids)))))))
(define build-dispatch-call
(lambda (pvars exp y r)
(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)
(make-binding-wrap ids labels empty-wrap)))
y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp)
(call-with-values
(lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r))))
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
(syntax-error pat
"duplicate pattern variable in syntax-case pattern"))
((not (andmap (lambda (x) (not (ellipsis? (car x) r))) 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 ((y (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)
(build-data no-source #f))))
(build-dispatch-call pvars exp y r)
(gen-syntax-case x keys clauses r))))
(list (if (eq? p 'any)
(build-application no-source
(build-primref no-source 'list)
(list x))
(build-application no-source
(build-primref no-source 'syntax-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r)
(if (null? clauses)
(build-application no-source
(build-primref no-source 'syntax-error)
(list x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
(andmap (lambda (x) (not (free-id=? (syntax pat) x)))
(cons (syntax (... ...)) keys)))
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
(build-lambda no-source (list var)
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
r)
(make-binding-wrap (syntax (pat))
labels empty-wrap)))
(list x)))
(gen-clause x keys (cdr clauses) r
(syntax pat) #t (syntax exp))))
((pat fender exp)
(gen-clause x keys (cdr clauses) r
(syntax pat) (syntax fender) (syntax exp)))
(_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
(lambda (e r w s)
(let ((e (source-wrap e w s)))
(syntax-case e ()
((_ val (key ...) m ...)
(if (andmap (lambda (x) (and (id? x) (not (ellipsis? x r))))
(syntax (key ...)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
(build-lambda no-source (list x)
(gen-syntax-case (build-lexical-reference 'value no-source x)
(syntax (key ...)) (syntax (m ...))
r))
(list (chi (syntax val) r empty-wrap))))
(syntax-error e "invalid literals list in"))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;;; if we are compiling a file, and esew is set to
;;; (eval-syntactic-expanders-when), which defaults to the list
;;; '(compile load eval). This means that, by default, top-level
;;; syntactic definitions are evaluated immediately after they are
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
(set! sc-expand
(let ((m 'e) (esew '(eval)))
(lambda (x)
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top x null-env top-wrap m esew)))))
(set! sc-expand3
(let ((m 'e) (esew '(eval)))
(lambda (x . rest)
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top x
null-env
top-wrap
(if (null? rest) m (car rest))
(if (or (null? rest) (null? (cdr rest)))
esew
(cadr rest)))))))
(set! identifier?
(lambda (x)
(nonsymbol-id? x)))
(set! datum->syntax-object
(lambda (id datum)
(make-syntax-object datum (syntax-object-wrap id))))
(set! syntax-object->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
(strip x empty-wrap)))
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?)
(arg-check nonsymbol-id? y 'free-identifier=?)
(free-id=? x y)))
(set! bound-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'bound-identifier=?)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
(set! 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)))))
(set! install-global-transformer
(lambda (sym v)
(arg-check symbol? sym 'define-syntax)
(arg-check procedure? v 'define-syntax)
(global-extend 'macro sym v)))
;;; 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:
;;; pattern: matches:
;;; () empty list
;;; any anything
;;; (1 . 2) (1 . 2)
;;; each-any (any*)
;;; #(free-id ) with free-identifier=?
;;; #(each ) (*)
;;; #(vector ) (list->vector )
;;; #(atom ) with "equal?"
;;; Vector cops out to pair under assumption that vectors are rare. If
;;; not, should convert to:
;;; #(vector *) #(*)
(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-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 '_) 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))
((free-id atom) r)
((vector) (match-empty (vector-ref p 1) 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 ((l (match-each e (vector-ref p 1) w)))
(and l
(let collect ((l l))
(if (null? (car l))
r
(cons (map car l) (collect (map cdr l)))))))))
((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) 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 '_) r)
((eq? p 'any) (cons (wrap e w) r))
((syntax-object? e)
(match*
(unannotate (syntax-object-expression e))
p
(join-wraps w (syntax-object-wrap e))
r))
(else (match* (unannotate e) p w r)))))
(set! syntax-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
((eq? p '_) '())
((syntax-object? e)
(match* (unannotate (syntax-object-expression e))
p (syntax-object-wrap e) '()))
(else (match* (unannotate e) p empty-wrap '())))))
(set! sc-chi chi)
))
)
(define-syntax with-syntax
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
(syntax (let () e1 e2 ...)))
((_ ((out in)) e1 e2 ...)
(syntax (syntax-case in () (out (let () e1 e2 ...)))))
((_ ((out in) ...) e1 e2 ...)
(syntax (syntax-case (list in ...) ()
((out ...) (let () e1 e2 ...))))))))
(define-syntax syntax-rules
(lambda (xx)
(define (expand-syntax-rules dots keys docstrings clauses)
(with-syntax
(((k ...) keys)
((docstring ...) docstrings)
((((keyword . pattern) template) ...) clauses))
(with-syntax
((form (syntax (lambda (x)
docstring ... ; optional docstring
;; #((macro-type . syntax-rules)
;; (patterns pattern ...)) ; embed patterns as procedure metadata
(syntax-case x (k ...)
((dummy . pattern) (syntax template))
...)))))
(if dots
(with-syntax ((dots dots))
(syntax (with-ellipsis dots form)))
(syntax form)))))
(syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...)
(expand-syntax-rules #f (syntax (k ...)) (syntax ()) (syntax (((keyword . pattern) template) ...))))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax-object->datum (syntax docstring)))
(expand-syntax-rules #f (syntax (k ...)) (syntax (docstring)) (syntax (((keyword . pattern) template) ...))))
((_ dots (k ...) ((keyword . pattern) template) ...)
(identifier? (syntax dots))
(expand-syntax-rules (syntax dots) (syntax (k ...)) (syntax ()) (syntax (((keyword . pattern) template) ...))))
((_ dots (k ...) docstring ((keyword . pattern) template) ...)
(and (identifier? (syntax dots)) (string? (syntax-object->datum (syntax docstring))))
(expand-syntax-rules (syntax dots) (syntax (k ...)) (syntax (docstring)) (syntax (((keyword . pattern) template) ...)))))))
(define-syntax define-syntax-rule
(lambda (x)
(syntax-case x ()
((_ (name . pattern) template)
(syntax (define-syntax name
(syntax-rules ()
((_ . pattern) template)))))
((_ (name . pattern) docstring template)
(string? (syntax-object->datum (syntax docstring)))
(syntax (define-syntax name
(syntax-rules ()
docstring
((_ . pattern) template))))))))
(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 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 doloop ((var init) ...)
(if (not e0)
(begin c ... (doloop step ...))))))
((e1 e2 ...)
(syntax (let doloop ((var init) ...)
(if e0
(begin e1 e2 ...)
(begin c ... (doloop step ...))))))))))))
(define-syntax quasiquote
(letrec
((quasicons
(lambda (x y)
(with-syntax ((x x) (y y))
(syntax-case (syntax y) (quote list)
((quote dy)
(syntax-case (syntax x) (quote)
((quote dx) (syntax (quote (dx . dy))))
(_ (if (null? (syntax dy))
(syntax (list x))
(syntax (cons x y))))))
((list . stuff) (syntax (list x . stuff)))
(else (syntax (cons x y)))))))
(quasiappend
(lambda (x y)
(with-syntax ((x x) (y y))
(syntax-case (syntax y) (quote)
((quote ()) (syntax x))
(_ (syntax (append x y)))))))
(quasivector
(lambda (x)
(with-syntax ((x x))
(syntax-case (syntax x) (quote list)
((quote (x ...)) (syntax (quote #(x ...))))
((list x ...) (syntax (vector x ...)))
(_ (syntax (list->vector x)))))))
(quasi
(lambda (p lev)
(syntax-case p (unquote unquote-splicing quasiquote)
((unquote p)
(if (= lev 0)
(syntax p)
(quasicons (syntax (quote unquote))
(quasi (syntax (p)) (- lev 1)))))
(((unquote-splicing p) . q)
(if (= lev 0)
(quasiappend (syntax p) (quasi (syntax q) lev))
(quasicons (quasicons (syntax (quote unquote-splicing))
(quasi (syntax (p)) (- lev 1)))
(quasi (syntax q) lev))))
((quasiquote p)
(quasicons (syntax (quote quasiquote))
(quasi (syntax (p)) (+ lev 1))))
((p . q)
(quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
(#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
(p (syntax (quote p)))))))
(lambda (x)
(syntax-case x ()
((_ e) (quasi (syntax e) 0))))))
(define-syntax include
(lambda (x)
(define read-file
(lambda (fn k)
(let ((p (open-input-file fn)))
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
(cons (datum->syntax-object k x)
(f (read p))))))))
(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 unquote
(lambda (x)
(syntax-case x ()
((_ e)
(error 'unquote
"expression ,~s not valid outside of quasiquote"
(syntax-object->datum (syntax e)))))))
(define-syntax unquote-splicing
(lambda (x)
(syntax-case x ()
((_ e)
(error 'unquote-splicing
"expression ,@~s not valid outside of quasiquote"
(syntax-object->datum (syntax e)))))))
(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
(lambda (x)
(syntax-case x ()
((_ e)
(syntax
(lambda (x)
(syntax-case x ()
(id
(identifier? (syntax id))
(syntax e))
((_ x (... ...))
(syntax (e x (... ...)))))))))))