ikarus/scheme/psyntax.expander.ss

4212 lines
162 KiB
Scheme

;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(library (psyntax expander)
(export identifier? syntax-dispatch
eval core-expand
generate-temporaries free-identifier=?
bound-identifier=? datum->syntax syntax-error
syntax-violation
syntax->datum
make-variable-transformer make-compile-time-value
variable-transformer?
variable-transformer-procedure
compile-r6rs-top-level boot-library-expand
null-environment scheme-report-environment
interaction-environment
ellipsis-map assertion-error
environment environment? environment-symbols
new-interaction-environment syntax-transpose)
(import
(except (rnrs)
environment environment? identifier?
eval generate-temporaries free-identifier=?
bound-identifier=? datum->syntax syntax-error
syntax-violation syntax->datum make-variable-transformer
null-environment scheme-report-environment)
(rnrs base)
(rnrs lists)
(rnrs control)
(rnrs io simple)
(rnrs mutable-pairs)
(psyntax library-manager)
(psyntax builders)
(psyntax compat)
(psyntax config)
(psyntax internal)
(only (rnrs syntax-case) syntax-case syntax with-syntax)
(prefix (rnrs syntax-case) sys.))
(define (set-cons x ls)
(cond
((memq x ls) ls)
(else (cons x ls))))
(define (set-union ls1 ls2)
(cond
((null? ls1) ls2)
((memq (car ls1) ls2) (set-union (cdr ls1) ls2))
(else (cons (car ls1) (set-union (cdr ls1) ls2)))))
(define-syntax no-source
(lambda (x) #f))
;;; the body of a library, when it's first processed, gets this
;;; set of marks.
(define top-mark* '(top))
;;; consequently, every syntax object that has a top in its marks
;;; set was present in the program source.
(define top-marked?
(lambda (m*) (memq 'top m*)))
;;; This procedure generates a fresh lexical name for renaming.
;;; It's also use it to generate temporaries.
(define gen-lexical
(lambda (sym)
(cond
((symbol? sym) (gensym sym))
((stx? sym) (gen-lexical (id->sym sym)))
(else (assertion-violation 'gen-lexical "BUG: invalid arg" sym)))))
;;; gen-global is used to generate global names (e.g. locations
;;; for library exports). We use gen-lexical since it works just
;;; fine.
(define (gen-global x) (gen-lexical x))
;;; every identifier in the program would have a label associated
;;; with it in its substitution. gen-label generates such labels.
;;; the labels have to have read/write eq? invariance to support
;;; separate compilation.
(define gen-label
(lambda (_) (gensym)))
(define (gen-top-level-label id rib)
(define (find sym mark* sym* mark** label*)
(and (pair? sym*)
(if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**)))
(car label*)
(find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
(let ((sym (id->sym id))
(mark* (stx-mark* id)))
(let ((sym* (rib-sym* rib)))
(cond
((and (memq sym (rib-sym* rib))
(find sym mark* sym* (rib-mark** rib) (rib-label* rib)))
=>
(lambda (label)
(cond
((imported-label->binding label)
;;; create new label to shadow imported binding
(gensym))
(else
;;; recycle old label
label))))
(else
;;; create new label for new binding
(gensym))))))
(define (gen-define-label+loc id rib sd?)
(if sd?
(values (gensym) (gen-lexical id))
(let ([env (top-level-context)])
(let ((label (gen-top-level-label id rib))
(locs (interaction-env-locs env)))
(values label
(cond
((assq label locs) => cdr)
(else
(let ((loc (gen-lexical id)))
(set-interaction-env-locs! env
(cons (cons label loc) locs))
loc))))))))
(define (gen-define-label id rib sd?)
(if sd?
(gensym)
(gen-top-level-label id rib)))
;;; A rib is a record constructed at every lexical contour in the
;;; program to hold information about the variables introduced in that
;;; contour. Adding an identifier->label mapping to an extensible rib
;;; is achieved by consing the identifier's name to the list of
;;; symbols, consing the identifier's list of marks to the rib's
;;; mark**, and consing the label to the rib's labels.
(define-record rib (sym* mark** label* sealed/freq))
(define make-empty-rib
(lambda ()
(make-rib '() '() '() #f)))
(define (top-marked-symbols rib)
(let-values ([(sym* mark**)
(let ([sym* (rib-sym* rib)] [mark** (rib-mark** rib)])
(if (rib-sealed/freq rib)
(values (vector->list sym*) (vector->list mark**))
(values sym* mark**)))])
(let f ([sym* sym*] [mark** mark**])
(cond
[(null? sym*) '()]
[(equal? (car mark**) top-mark*)
(cons (car sym*) (f (cdr sym*) (cdr mark**)))]
[else (f (cdr sym*) (cdr mark**))]))))
;;; For example, when processing a lambda's internal define, a new rib
;;; is created and is added to the body of the lambda expression.
;;; When an internal definition is encountered, a new entry for the
;;; identifier is added (via side effect) to the rib. A rib may be
;;; extensible, or sealed. An extensible rib looks like:
;;; #<rib list-of-symbols list-of-list-of-marks list-of-labels #f>
(define (extend-rib! rib id label sd?)
(define (find sym mark* sym* mark** label*)
(and (pair? sym*)
(if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**)))
label*
(find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
(when (rib-sealed/freq rib)
(assertion-violation 'extend-rib! "BUG: rib is sealed" rib))
(let ((sym (id->sym id))
(mark* (stx-mark* id)))
(let ((sym* (rib-sym* rib)))
(cond
((and (memq sym (rib-sym* rib))
(find sym mark* sym* (rib-mark** rib) (rib-label* rib)))
=>
(lambda (p)
(unless (eq? label (car p))
(cond
((not sd?) ;(top-level-context)
;;; XXX override label
(set-car! p label))
(else
;;; signal an error if the identifier was already
;;; in the rib.
(stx-error id "multiple definitions of identifier"))))))
(else
(set-rib-sym*! rib (cons sym sym*))
(set-rib-mark**! rib (cons mark* (rib-mark** rib)))
(set-rib-label*! rib (cons label (rib-label* rib))))))))
;;; A rib can be sealed once all bindings are inserted. To seal
;;; a rib, we convert the lists sym*, mark**, and label* to vectors
;;; and insert a frequency vector in the sealed/freq field.
;;; The frequency vector is an optimization that allows the rib to
;;; reorganize itself by bubbling frequently used mappings to the
;;; top of the rib. The vector is maintained in non-descending
;;; order and an identifier's entry in the rib is incremented at
;;; every access. If an identifier's frequency exceeds the
;;; preceeding one, the identifier's position is promoted to the
;;; top of its class (or the bottom of the previous class).
(define (seal-rib! rib)
(let ((sym* (rib-sym* rib)))
(unless (null? sym*)
;;; only seal if rib is not empty.
(let ((sym* (list->vector sym*)))
(set-rib-sym*! rib sym*)
(set-rib-mark**! rib
(list->vector (rib-mark** rib)))
(set-rib-label*! rib
(list->vector (rib-label* rib)))
(set-rib-sealed/freq! rib
(make-vector (vector-length sym*) 0))))))
(define (unseal-rib! rib)
(when (rib-sealed/freq rib)
(set-rib-sealed/freq! rib #f)
(set-rib-sym*! rib (vector->list (rib-sym* rib)))
(set-rib-mark**! rib (vector->list (rib-mark** rib)))
(set-rib-label*! rib (vector->list (rib-label* rib)))))
(define (increment-rib-frequency! rib idx)
(let ((freq* (rib-sealed/freq rib)))
(let ((freq (vector-ref freq* idx)))
(let ((i
(let f ((i idx))
(cond
((zero? i) 0)
(else
(let ((j (- i 1)))
(cond
((= freq (vector-ref freq* j)) (f j))
(else i))))))))
(vector-set! freq* i (+ freq 1))
(unless (= i idx)
(let ((sym* (rib-sym* rib))
(mark** (rib-mark** rib))
(label* (rib-label* rib)))
(let ((sym (vector-ref sym* idx)))
(vector-set! sym* idx (vector-ref sym* i))
(vector-set! sym* i sym))
(let ((mark* (vector-ref mark** idx)))
(vector-set! mark** idx (vector-ref mark** i))
(vector-set! mark** i mark*))
(let ((label (vector-ref label* idx)))
(vector-set! label* idx (vector-ref label* i))
(vector-set! label* i label))))))))
(define make-full-rib ;;; it may be a good idea to seal this rib
(lambda (id* label*)
(make-rib (map id->sym id*) (map stx-mark* id*) label* #f)))
;;; Now to syntax objects which are records defined like:
(define-record stx (expr mark* subst* ae*)
(lambda (x p wr)
(display "#<syntax " p)
(write (stx->datum x) p)
(let ((expr (stx-expr x)))
(when (annotation? expr)
(let ((src (annotation-source expr)))
(when (pair? src)
(display " [char " p)
(display (cdr src) p)
(display " of " p)
(display (car src) p)
(display "]" p)))))
(display ">" p)))
;;; First, let's look at identifiers, since they're the real
;;; reason why syntax objects are here to begin with.
;;; An identifier is an stx whose expr is a symbol.
;;; In addition to the symbol naming the identifier, the identifer
;;; has a list of marks and a list of substitutions.
;;; The idea is that to get the label of an identifier, we look up
;;; the identifier's substitutions for a mapping with the same
;;; name and same marks (see same-marks? below).
;;; Since all the identifier->label bindings are encapsulated
;;; within the identifier, converting a datum to a syntax object
;;; (non-hygienically) is done simply by creating an stx that has
;;; the same marks and substitutions as the identifier.
(define datum->stx
(lambda (id datum)
(make-stx datum (stx-mark* id) (stx-subst* id) (stx-ae* id))))
;;; A syntax object may be wrapped or unwrapped, so what does that
;;; mean exactly?
;;;
;;; A wrapped syntax object is just a way of saying it's an stx
;;; record. All identifiers are stx records (with a symbol in
;;; their expr field). Other objects such as pairs and vectors
;;; may be wrapped or unwrapped. A wrapped pair is an stx whos
;;; expr is a pair. An unwrapped pair is a pair whos car and cdr
;;; fields are themselves syntax objects (wrapped or unwrapped).
;;;
;;; We always maintain the invariant that we don't double wrap
;;; syntax objects. The only way to get a doubly-wrapped syntax
;;; object is by doing datum->stx (above) where the datum is
;;; itself a wrapped syntax object (r6rs may not even consider
;;; wrapped syntax objects as datum, but let's not worry now).
;;; Syntax objects have, in addition to the expr, a
;;; substitution field (stx-subst*). The subst* is a list
;;; where each element is either a rib or the symbol "shift".
;;; Normally, a new rib is added to an stx at evert lexical
;;; contour of the program in order to capture the bindings
;;; inctroduced in that contour.
;;; The mark* field of an stx is, well, a list of marks.
;;; Each of these marks can be either a generated mark
;;; or an antimark.
;;; (two marks must be eq?-comparable, so we use a string
;;; of one char (this assumes that strings are mutable)).
;;; gen-mark generates a new unique mark
(define (gen-mark) ;;; faster
(string #\m))
;(define gen-mark ;;; useful for debugging
; (let ((i 0))
; (lambda ()
; (set! i (+ i 1))
; (string-append "m." (number->string i)))))
;;; We use #f as the anti-mark.
(define anti-mark #f)
(define anti-mark? not)
;;; So, what's an anti-mark and why is it there.
;;; The theory goes like this: when a macro call is encountered,
;;; the input stx to the macro transformer gets an extra anti-mark,
;;; and the output of the transformer gets a fresh mark.
;;; When a mark collides with an anti-mark, they cancel one
;;; another. Therefore, any part of the input transformer that
;;; gets copied to the output would have a mark followed
;;; immediately by an anti-mark, resulting in the same syntax
;;; object (no extra marks). Parts of the output that were not
;;; present in the input (e.g. inserted by the macro transformer)
;;; would have no anti-mark and, therefore, the mark would stick
;;; to them.
;;;
;;; Every time a mark is pushed to an stx-mark* list, a
;;; corresponding 'shift is pushed to the stx-subst* list.
;;; Every time a mark is cancelled by an anti-mark, the
;;; corresponding shifts are also cancelled.
;;; The procedure join-wraps, here, is used to compute the new
;;; mark* and subst* that would result when the m1* and s1* are
;;; added to an stx's mark* and subst*.
;;; The only tricky part here is that e may have an anti-mark
;;; that should cancel with the last mark in m1*.
;;; So, if m1* is (mx* ... mx)
;;; and m2* is (#f my* ...)
;;; then the resulting marks should be (mx* ... my* ...)
;;; since mx would cancel with the anti-mark.
;;; The substs would have to also cancel since
;;; s1* is (sx* ... sx)
;;; and s2* is (sy sy* ...)
;;; then the resulting substs should be (sx* ... sy* ...)
;;; Notice that both sx and sy would be shift marks.
(define join-wraps
(lambda (m1* s1* ae1* e)
(define merge-ae*
(lambda (ls1 ls2)
(if (and (pair? ls1) (pair? ls2) (not (car ls2)))
(cancel ls1 ls2)
(append ls1 ls2))))
(define cancel
(lambda (ls1 ls2)
(let f ((x (car ls1)) (ls1 (cdr ls1)))
(if (null? ls1)
(cdr ls2)
(cons x (f (car ls1) (cdr ls1)))))))
(let ((m2* (stx-mark* e))
(s2* (stx-subst* e))
(ae2* (stx-ae* e)))
(if (and (not (null? m1*))
(not (null? m2*))
(anti-mark? (car m2*)))
; cancel mark, anti-mark, and corresponding shifts
(values (cancel m1* m2*) (cancel s1* s2*) (merge-ae* ae1* ae2*))
(values (append m1* m2*) (append s1* s2*) (merge-ae* ae1* ae2*))))))
;;; The procedure mkstx is then the proper constructor for
;;; wrapped syntax objects. It takes a syntax object, a list
;;; of marks, and a list of substs. It joins the two wraps
;;; making sure that marks and anti-marks and corresponding
;;; shifts cancel properly.
(define mkstx
(lambda (e m* s* ae*)
(if (and (stx? e) (not (top-marked? m*)))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(make-stx (stx-expr e) m* s* ae*))
(make-stx e m* s* ae*))))
(define add-subst
(lambda (subst e)
(mkstx e '() (list subst) '())))
(define add-mark
(lambda (mark subst expr ae)
(define merge-ae*
(lambda (ls1 ls2)
(if (and (pair? ls1) (pair? ls2) (not (car ls2)))
(cancel ls1 ls2)
(append ls1 ls2))))
(define cancel
(lambda (ls1 ls2)
(let f ((x (car ls1)) (ls1 (cdr ls1)))
(if (null? ls1)
(cdr ls2)
(cons x (f (car ls1) (cdr ls1)))))))
(define (f e m s1* ae*)
(cond
[(pair? e)
(let ([a (f (car e) m s1* ae*)]
[d (f (cdr e) m s1* ae*)])
(if (eq? a d) e (cons a d)))]
[(vector? e)
(let ([ls1 (vector->list e)])
(let ([ls2 (map (lambda (x) (f x m s1* ae*)) ls1)])
(if (for-all eq? ls1 ls2) e (list->vector ls2))))]
[(stx? e)
(let ([m* (stx-mark* e)] [s2* (stx-subst* e)])
(cond
[(null? m*)
(f (stx-expr e) m
(append s1* s2*)
(merge-ae* ae* (stx-ae* e)))]
[(eq? (car m*) anti-mark)
(make-stx (stx-expr e) (cdr m*)
(cdr (append s1* s2*))
(merge-ae* ae* (stx-ae* e)))]
[else
(make-stx (stx-expr e)
(cons m m*)
(let ([s* (cons 'shift (append s1* s2*))])
(if subst (cons subst s*) s*))
(merge-ae* ae* (stx-ae* e)))]))]
[(symbol? e)
(syntax-violation #f
"raw symbol encountered in output of macro"
expr e)]
[else (make-stx e (list m) s1* ae*)]))
(mkstx (f expr mark '() '()) '() '() (list ae))))
;;; now are some deconstructors and predicates for syntax objects.
(define syntax-kind?
(lambda (x p?)
(cond
((stx? x) (syntax-kind? (stx-expr x) p?))
((annotation? x)
(syntax-kind? (annotation-expression x) p?))
(else (p? x)))))
(define syntax-vector->list
(lambda (x)
(cond
((stx? x)
(let ((ls (syntax-vector->list (stx-expr x)))
(m* (stx-mark* x))
(s* (stx-subst* x))
(ae* (stx-ae* x)))
(map (lambda (x) (mkstx x m* s* ae*)) ls)))
((annotation? x)
(syntax-vector->list (annotation-expression x)))
((vector? x) (vector->list x))
(else (assertion-violation 'syntax-vector->list "BUG: not a syntax vector" x)))))
(define syntax-pair?
(lambda (x) (syntax-kind? x pair?)))
(define syntax-vector?
(lambda (x) (syntax-kind? x vector?)))
(define syntax-null?
(lambda (x) (syntax-kind? x null?)))
(define syntax-list? ;;; FIXME: should terminate on cyclic input.
(lambda (x)
(or (syntax-null? x)
(and (syntax-pair? x) (syntax-list? (syntax-cdr x))))))
(define syntax-car
(lambda (x)
(cond
((stx? x)
(mkstx (syntax-car (stx-expr x))
(stx-mark* x)
(stx-subst* x)
(stx-ae* x)))
((annotation? x)
(syntax-car (annotation-expression x)))
((pair? x) (car x))
(else (assertion-violation 'syntax-car "BUG: not a pair" x)))))
(define syntax-cdr
(lambda (x)
(cond
((stx? x)
(mkstx (syntax-cdr (stx-expr x))
(stx-mark* x)
(stx-subst* x)
(stx-ae* x)))
((annotation? x)
(syntax-cdr (annotation-expression x)))
((pair? x) (cdr x))
(else (assertion-violation 'syntax-cdr "BUG: not a pair" x)))))
(define syntax->list
(lambda (x)
(if (syntax-pair? x)
(cons (syntax-car x) (syntax->list (syntax-cdr x)))
(if (syntax-null? x)
'()
(assertion-violation 'syntax->list "BUG: invalid argument" x)))))
(define id?
(lambda (x)
(and (stx? x)
(let ((expr (stx-expr x)))
(symbol? (if (annotation? expr)
(annotation-stripped expr)
expr))))))
(define id->sym
(lambda (x)
(unless (stx? x)
(error 'id->sym "BUG in ikarus: not an id" x))
(let ((expr (stx-expr x)))
(let ((sym (if (annotation? expr)
(annotation-stripped expr)
expr)))
(if (symbol? sym)
sym
(error 'id->sym "BUG in ikarus: not an id" x))))))
;;; Two lists of marks are considered the same if they have the
;;; same length and the corresponding marks on each are eq?.
(define same-marks?
(lambda (x y)
(or (and (null? x) (null? y)) ;(eq? x y)
(and (pair? x) (pair? y)
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
;;; Two identifiers are bound-id=? if they have the same name and
;;; the same set of marks.
(define bound-id=?
(lambda (x y)
(and (eq? (id->sym x) (id->sym y))
(same-marks? (stx-mark* x) (stx-mark* y)))))
;;; Two identifiers are free-id=? if either both are bound to the
;;; same label or if both are unbound and they have the same name.
(define free-id=?
(lambda (i j)
(let ((t0 (id->label i)) (t1 (id->label j)))
(if (or t0 t1)
(eq? t0 t1)
(eq? (id->sym i) (id->sym j))))))
;;; valid-bound-ids? takes checks if a list is made of identifers
;;; none of which is bound-id=? to another.
(define valid-bound-ids?
(lambda (id*)
(and (for-all id? id*)
(distinct-bound-ids? id*))))
(define distinct-bound-ids?
(lambda (id*)
(or (null? id*)
(and (not (bound-id-member? (car id*) (cdr id*)))
(distinct-bound-ids? (cdr id*))))))
(define bound-id-member?
(lambda (id id*)
(and (pair? id*)
(or (bound-id=? id (car id*))
(bound-id-member? id (cdr id*))))))
(define self-evaluating?
(lambda (x) ;;; am I missing something here?
(or (number? x) (string? x) (char? x) (boolean? x)
(bytevector? x))))
;;; strip is used to remove the wrap of a syntax object.
;;; It takes an stx's expr and marks. If the marks contain
;;; a top-mark, then the expr is returned.
(define (strip-annotations x)
(cond
((pair? x)
(cons (strip-annotations (car x))
(strip-annotations (cdr x))))
((vector? x) (vector-map strip-annotations x))
((annotation? x) (annotation-stripped x))
(else x)))
(define strip
(lambda (x m*)
(if (top-marked? m*)
(if (or (annotation? x)
(and (pair? x)
(annotation? (car x)))
(and (vector? x) (> (vector-length x) 0)
(annotation? (vector-ref x 0))))
;;; TODO: Ask Kent why this is a sufficient test
(strip-annotations x)
x)
(let f ((x x))
(cond
((stx? x) (strip (stx-expr x) (stx-mark* x)))
((annotation? x) (annotation-stripped 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 (for-all eq? old new)
x
(list->vector new)))))
(else x))))))
(define stx->datum
(lambda (x)
(strip x '())))
;;; id->label takes an id (that's a sym x marks x substs) and
;;; searches the substs for a label associated with the same sym
;;; and marks.
(define (id->label/intern id)
(or (id->label id)
(cond
((top-level-context) =>
(lambda (env)
;;; fabricate binding
(let ((rib (interaction-env-rib env)))
(let-values (((lab _loc) (gen-define-label+loc id rib #f)))
(extend-rib! rib id lab #t) ;;; FIXME
lab))))
(else #f))))
(define id->label
(lambda (id)
(let ((sym (id->sym id)))
(let search ((subst* (stx-subst* id)) (mark* (stx-mark* id)))
(cond
((null? subst*) #f)
((eq? (car subst*) 'shift)
;;; a shift is inserted when a mark is added.
;;; so, we search the rest of the substitution
;;; without the mark.
(search (cdr subst*) (cdr mark*)))
(else
(let ((rib (car subst*)))
(cond
((rib-sealed/freq rib)
(let ((sym* (rib-sym* rib)))
(let f ((i 0) (j (vector-length sym*)))
(cond
((= i j) (search (cdr subst*) mark*))
((and (eq? (vector-ref sym* i) sym)
(same-marks? mark*
(vector-ref (rib-mark** rib) i)))
(let ((label (vector-ref (rib-label* rib) i)))
(increment-rib-frequency! rib i)
label))
(else (f (+ i 1) j))))))
(else
(let f ((sym* (rib-sym* rib))
(mark** (rib-mark** rib))
(label* (rib-label* rib)))
(cond
((null? sym*) (search (cdr subst*) mark*))
((and (eq? (car sym*) sym)
(same-marks? (car mark**) mark*))
(car label*))
(else (f (cdr sym*) (cdr mark**) (cdr label*))))))))))))))
;;; label->binding looks up the label in the environment r as
;;; well as in the global environment. Since all labels are
;;; unique, it doesn't matter which environment we consult first.
;;; we lookup the global environment first because it's faster
;;; (uses a hash table) while the lexical environment is an alist.
;;; If we don't find the binding of a label, we return the binding
;;; (displaced-lexical . #f) to indicate such.
(define label->binding-no-fluids
(lambda (x r)
(cond
((not x) '(displaced-lexical))
((imported-label->binding x) =>
(lambda (b)
(cond
((and (pair? b) (eq? (car b) '$core-rtd))
(cons '$rtd (map bless (cdr b))))
((and (pair? b) (eq? (car b) 'global-rtd))
(let ((lib (cadr b)) (loc (cddr b)))
(cons '$rtd (symbol-value loc))))
(else b))))
((assq x r) => cdr)
((top-level-context) =>
(lambda (env)
(cond
((assq x (interaction-env-locs env)) =>
(lambda (p) ;;; fabricate
(cons* 'lexical (cdr p) #f)))
(else '(displaced-lexical . #f)))))
(else '(displaced-lexical . #f)))))
(define label->binding
(lambda (x r)
(let ([b (label->binding-no-fluids x r)])
(if (and (pair? b) (eq? (car b) '$fluid))
;;; fluids require reversed logic. We have to look them
;;; up in the local environment first before the global.
(let ([x (cdr b)])
(cond
[(assq x r) => cdr]
[else (label->binding-no-fluids x '())]))
b))))
(define make-binding cons)
(define binding-type car)
(define binding-value cdr)
;;; the type of an expression is determined by two things:
;;; - the shape of the expression (identifier, pair, or datum)
;;; - the binding of the identifier (for id-stx) or the type of
;;; car of the pair.
(define (raise-unbound-error id)
(syntax-violation* #f "unbound identifier" id
(make-undefined-violation)))
#;
(define (syntax-type e r)
(let-values ([(t0 t1 t2) (syntax-type^ e r)])
(printf "T ~s ~s => ~s ~s ~s\n" e r t0 t1 t2)
(values t0 t1 t2)))
(define syntax-type
(lambda (e r)
(cond
((id? e)
(let ((id e))
(let* ((label (id->label/intern id))
(b (label->binding label r))
(type (binding-type b)))
(unless label ;;; fail early.
(raise-unbound-error id))
(case type
((lexical core-prim macro macro! global local-macro
local-macro! global-macro global-macro!
displaced-lexical syntax import export $module
$core-rtd library mutable ctv local-ctv global-ctv)
(values type (binding-value b) id))
(else (values 'other #f #f))))))
((syntax-pair? e)
(let ((id (syntax-car e)))
(if (id? id)
(let* ((label (id->label/intern id))
(b (label->binding label r))
(type (binding-type b)))
(unless label ;;; fail early.
(raise-unbound-error id))
(case type
((define define-syntax core-macro begin macro
macro! local-macro local-macro! global-macro
global-macro! module library set! let-syntax
letrec-syntax import export $core-rtd
ctv local-ctv global-ctv stale-when
define-fluid-syntax)
(values type (binding-value b) id))
(else
(values 'call #f #f))))
(values 'call #f #f))))
(else (let ((d (stx->datum e)))
(if (self-evaluating? d)
(values 'constant d #f)
(values 'other #f #f)))))))
(define-syntax stx-error
(lambda (x)
(syntax-case x ()
((_ stx)
(syntax (syntax-violation #f "invalid syntax" stx)))
((_ stx msg)
(syntax (syntax-violation #f msg stx))))))
;;; when the rhs of a syntax definition is evaluated, it should be
;;; either a procedure, an identifier-syntax transformer or an
;;; ($rtd . #<rtd>) form (ikarus/chez). sanitize-binding converts
;;; the output to one of:
;;; (lacal-macro . procedure)
;;; (local-macro! . procedure)
;;; (local-ctv . compile-time-value)
;;; ($rtd . $rtd)
;;; and signals an assertion-violation otherwise.
(define sanitize-binding
(lambda (x src)
(cond
((procedure? x)
(cons* 'local-macro x src))
((and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
(cons* 'local-macro! (cdr x) src))
((and (pair? x) (eq? (car x) '$rtd)) x)
((and (pair? x) (eq? (car x) 'ctv))
(cons* 'local-ctv (cdr x) src))
(else (assertion-violation 'expand "invalid transformer" x)))))
;;; r6rs's make-variable-transformer:
(define make-variable-transformer
(lambda (x)
(if (procedure? x)
(cons 'macro! x)
(assertion-violation 'make-variable-transformer
"not a procedure" x))))
(define make-compile-time-value
(lambda (x)
(cons 'ctv x)))
(define (variable-transformer? x)
(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x))))
(define (variable-transformer-procedure x)
(if (variable-transformer? x)
(cdr x)
(assertion-violation
'variable-transformer-procedure
"not a variable transformer"
x)))
;;; make-eval-transformer takes an expanded expression,
;;; evaluates it and returns a proper syntactic binding
;;; for the resulting object.
(define make-eval-transformer
(lambda (x)
(sanitize-binding (eval-core (expanded->core x)) x)))
;;; The syntax-match macro is almost like syntax-case macro.
;;; Except that:
;;; The syntax objects matched are OUR stx objects, not
;;; the host systems syntax objects (whatever they may be
;;; we don't care).
;;; The literals are matched against those in the system
;;; library (psyntax system $all). -- see scheme-stx
;;; The variables in the patters are bound to ordinary variables
;;; not to special pattern variables.
(define-syntax syntax-match
(lambda (ctx)
(define convert-pattern
; 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 free-identifier-member?
(lambda (x ls)
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
(define (bound-id-member? x ls)
(and (pair? ls)
(or (sys.bound-identifier=? x (car ls))
(bound-id-member? x (cdr ls)))))
(define ellipsis?
(lambda (x)
(and (sys.identifier? x)
(sys.free-identifier=? x (syntax (... ...))))))
(define cvt
(lambda (p n ids)
(syntax-case p ()
(id (sys.identifier? (syntax id))
(cond
((bound-id-member? p keys)
(values `#(scheme-id ,(sys.syntax->datum p)) ids))
((sys.free-identifier=? p (syntax _))
(values '_ ids))
(else (values 'any (cons (cons p n) ids)))))
((p dots) (ellipsis? (syntax dots))
(let-values (((p ids) (cvt (syntax p) (+ n 1) ids)))
(values
(if (eq? p 'any) 'each-any `#(each ,p))
ids)))
((x dots ys ... . z) (ellipsis? (syntax dots))
(let-values (((z ids) (cvt (syntax z) n ids)))
(let-values (((ys ids) (cvt* (syntax (ys ...)) n ids)))
(let-values (((x ids) (cvt (syntax x) (+ n 1) ids)))
(values `#(each+ ,x ,(reverse ys) ,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))
(#(p ...)
(let-values (((p ids) (cvt (syntax (p ...)) n ids)))
(values `#(vector ,p) ids)))
(datum
(values `#(atom ,(sys.syntax->datum (syntax datum))) ids)))))
(cvt pattern 0 '())))
(syntax-case ctx ()
((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...)))
(syntax (stx-error expr "invalid syntax")))
((_ expr (lits ...) (pat fender body) cls* ...)
(for-all sys.identifier? (syntax (lits ...)))
(let-values (((pattern ids/levels)
(convert-pattern (syntax pat) (syntax (lits ...)))))
(with-syntax ((pattern (sys.datum->syntax (syntax here) pattern))
(((ids . levels) ...) ids/levels))
(syntax
(let ((t expr))
(let ((ls/false (syntax-dispatch t 'pattern)))
(if (and ls/false (apply (lambda (ids ...) fender) ls/false))
(apply (lambda (ids ...) body) ls/false)
(syntax-match t (lits ...) cls* ...))))))))
((_ expr (lits ...) (pat body) cls* ...)
(for-all sys.identifier? (syntax (lits ...)))
(let-values (((pattern ids/levels)
(convert-pattern (syntax pat) (syntax (lits ...)))))
(with-syntax ((pattern (sys.datum->syntax (syntax here) pattern))
(((ids . levels) ...) ids/levels))
(syntax
(let ((t expr))
(let ((ls/false (syntax-dispatch t 'pattern)))
(if ls/false
(apply (lambda (ids ...) body) ls/false)
(syntax-match t (lits ...) cls* ...))))))))
((_ expr (lits ...) (pat body) cls* ...)
(syntax (syntax-match expr (lits ...) (pat #t body) cls* ...))))))
(define parse-define
(lambda (x)
(syntax-match x ()
((_ (id . fmls) b b* ...) (id? id)
(begin
(verify-formals fmls x)
(values id (cons 'defun x))))
((_ id val) (id? id)
(values id (cons 'expr val)))
((_ id) (id? id)
(values id (cons 'expr (bless '(void))))))))
(define parse-define-syntax
(lambda (x)
(syntax-match x ()
((_ id val) (id? id) (values id val)))))
;;; scheme-stx takes a symbol and if it's in the
;;; (psyntax system $all) library, it creates a fresh identifier
;;; that maps only the symbol to its label in that library.
;;; Symbols not in that library become fresh.
(define scheme-stx-hashtable (make-eq-hashtable))
(define scheme-stx
(lambda (sym)
(or (hashtable-ref scheme-stx-hashtable sym #f)
(let* ((subst
(library-subst
(find-library-by-name '(psyntax system $all))))
(stx (make-stx sym top-mark* '() '()))
(stx
(cond
((assq sym subst) =>
(lambda (x)
(let ((name (car x)) (label (cdr x)))
(add-subst
(make-rib (list name)
(list top-mark*) (list label) #f)
stx))))
(else stx))))
(hashtable-set! scheme-stx-hashtable sym stx)
stx))))
;;; macros
(define lexical-var car)
(define lexical-mutable? cdr)
(define set-lexical-mutable! set-cdr!)
(define add-lexical
(lambda (lab lex r)
(cons (cons* lab 'lexical lex #f) r)))
;;;
(define add-lexicals
(lambda (lab* lex* r)
(cond
((null? lab*) r)
(else
(add-lexicals (cdr lab*) (cdr lex*)
(add-lexical (car lab*) (car lex*) r))))))
;;;
(define letrec-helper
(lambda (e r mr build)
(syntax-match e ()
((_ ((lhs* rhs*) ...) b b* ...)
(if (not (valid-bound-ids? lhs*))
(invalid-fmls-error e lhs*)
(let ((lex* (map gen-lexical lhs*))
(lab* (map gen-label lhs*)))
(let ((rib (make-full-rib lhs* lab*))
(r (add-lexicals lab* lex* r)))
(let ((body (chi-internal
(add-subst rib (cons b b*)) r mr))
(rhs* (chi-expr* (map (lambda (x) (add-subst rib x))
rhs*) r mr)))
(build no-source lex* rhs* body)))))))))
(define letrec-transformer
(lambda (e r mr) (letrec-helper e r mr build-letrec)))
(define letrec*-transformer
(lambda (e r mr) (letrec-helper e r mr build-letrec*)))
(define fluid-let-syntax-transformer
(lambda (e r mr)
(define (lookup x)
(let ([label
(or (id->label x)
(syntax-violation #f "unbound identifier" e x))])
(let ([b (label->binding-no-fluids label r)])
(cond
[(and (pair? b) (eq? (car b) '$fluid)) (cdr b)]
[else (syntax-violation #f "not a fluid identifier" e x)]))))
(syntax-match e ()
((_ ((lhs* rhs*) ...) b b* ...)
(if (not (valid-bound-ids? lhs*))
(invalid-fmls-error e lhs*)
(let ((lab* (map lookup lhs*))
(rhs* (map (lambda (x)
(make-eval-transformer
(expand-transformer x mr)))
rhs*)))
(chi-internal (cons b b*)
(append (map cons lab* rhs*) r)
(append (map cons lab* rhs*) mr))))))))
(define type-descriptor-transformer
(lambda (e r mr)
(syntax-match e ()
((_ id) (id? id)
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (not (list? (binding-value b))))
(stx-error e "not a record type"))
(build-data no-source (binding-value b)))))))
(define record-type-descriptor-transformer
(lambda (e r mr)
(syntax-match e ()
((_ id) (id? id)
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (list? (binding-value b)))
(stx-error e "not a record type"))
(chi-expr (car (binding-value b)) r mr))))))
(define record-constructor-descriptor-transformer
(lambda (e r mr)
(syntax-match e ()
((_ id) (id? id)
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (list? (binding-value b)))
(stx-error e "invalid type"))
(chi-expr (cadr (binding-value b)) r mr))))))
(define when-macro
(lambda (e)
(syntax-match e ()
((_ test e e* ...)
(bless `(if ,test (begin ,e . ,e*)))))))
(define unless-macro
(lambda (e)
(syntax-match e ()
((_ test e e* ...)
(bless `(if (not ,test) (begin ,e . ,e*)))))))
(define if-transformer
(lambda (e r mr)
(syntax-match e ()
((_ e0 e1 e2)
(build-conditional no-source
(chi-expr e0 r mr)
(chi-expr e1 r mr)
(chi-expr e2 r mr)))
((_ e0 e1)
(build-conditional no-source
(chi-expr e0 r mr)
(chi-expr e1 r mr)
(build-void))))))
(define case-macro
(lambda (e)
(define (build-last cls)
(syntax-match cls (else)
((else e e* ...) `(let () #f ,e . ,e*))
(_ (build-one cls '(if #f #f)))))
(define (build-one cls k)
(syntax-match cls ()
(((d* ...) e e* ...)
`(if (memv t ',d*) (begin ,e . ,e*) ,k))))
(syntax-match e ()
((_ expr)
(bless `(let ((t ,expr)) (if #f #f))))
((_ expr cls cls* ...)
(bless
`(let ((t ,expr))
,(let f ((cls cls) (cls* cls*))
(if (null? cls*)
(build-last cls)
(build-one cls (f (car cls*) (cdr cls*)))))))))))
(define quote-transformer
(lambda (e r mr)
(syntax-match e ()
((_ datum) (build-data no-source (stx->datum datum))))))
(define case-lambda-transformer
(lambda (e r mr)
(syntax-match e ()
((_ (fmls* b* b** ...) ...)
(let-values (((fmls* body*)
(chi-lambda-clause* e fmls*
(map cons b* b**) r mr)))
(build-case-lambda (syntax-annotation e) fmls* body*))))))
(define lambda-transformer
(lambda (e r mr)
(syntax-match e ()
((_ fmls b b* ...)
(let-values (((fmls body)
(chi-lambda-clause e fmls
(cons b b*) r mr)))
(build-lambda (syntax-annotation e) fmls body))))))
(define bless
(lambda (x)
(mkstx
(let f ((x x))
(cond
((stx? x) x)
((pair? x) (cons (f (car x)) (f (cdr x))))
((symbol? x) (scheme-stx x))
((vector? x)
(list->vector (map f (vector->list x))))
(else x)))
'() '() '())))
(define with-syntax-macro
(lambda (e)
(syntax-match e ()
((_ ((pat* expr*) ...) b b* ...)
(let ((idn*
(let f ((pat* pat*))
(cond
((null? pat*) '())
(else
(let-values (((pat idn*) (convert-pattern (car pat*) '())))
(append idn* (f (cdr pat*)))))))))
(verify-formals (map car idn*) e)
(let ((t* (generate-temporaries expr*)))
(bless
`(let ,(map list t* expr*)
,(let f ((pat* pat*) (t* t*))
(cond
((null? pat*) `(let () ,b . ,b*))
(else
`(syntax-case ,(car t*) ()
(,(car pat*) ,(f (cdr pat*) (cdr t*)))
(_ (assertion-violation 'with-syntax
"pattern does not match value"
',(car pat*)
,(car t*)))))))))))))))
(define (invalid-fmls-error stx fmls)
(syntax-match fmls ()
((id* ... . last)
(let f ((id* (cond
((id? last) (cons last id*))
((syntax-null? last) id*)
(else
(syntax-violation #f "not an identifier" stx last)))))
(cond
((null? id*) (values))
((not (id? (car id*)))
(syntax-violation #f "not an identifier" stx (car id*)))
(else
(f (cdr id*))
(when (bound-id-member? (car id*) (cdr id*))
(syntax-violation #f "duplicate binding" stx (car id*)))))))
(_ (syntax-violation #f "malformed binding form" stx fmls))))
(define let-macro
(lambda (stx)
(syntax-match stx ()
((_ ((lhs* rhs*) ...) b b* ...)
(if (valid-bound-ids? lhs*)
(bless `((lambda ,lhs* ,b . ,b*) . ,rhs*))
(invalid-fmls-error stx lhs*)))
((_ f ((lhs* rhs*) ...) b b* ...) (id? f)
(if (valid-bound-ids? lhs*)
(bless `((letrec ((,f (lambda ,lhs* ,b . ,b*))) ,f) . ,rhs*))
(invalid-fmls-error stx lhs*))))))
(define trace-let-macro
(lambda (stx)
(syntax-match stx ()
((_ f ((lhs* rhs*) ...) b b* ...) (id? f)
(if (valid-bound-ids? lhs*)
(bless
`((letrec ((,f (trace-lambda ,f ,lhs* ,b . ,b*))) ,f) . ,rhs*))
(invalid-fmls-error stx lhs*))))))
(define let-values-macro
(lambda (stx)
(define (rename x old* new*)
(unless (id? x)
(syntax-violation #f "not an indentifier" stx x))
(when (bound-id-member? x old*)
(syntax-violation #f "duplicate binding" stx x))
(let ((y (gensym (syntax->datum x))))
(values y (cons x old*) (cons y new*))))
(define (rename* x* old* new*)
(cond
((null? x*) (values '() old* new*))
(else
(let*-values (((x old* new*) (rename (car x*) old* new*))
((x* old* new*) (rename* (cdr x*) old* new*)))
(values (cons x x*) old* new*)))))
(syntax-match stx ()
((_ () b b* ...)
(cons* (bless 'let) '() b b*))
((_ ((lhs* rhs*) ...) b b* ...)
(bless
(let f ((lhs* lhs*) (rhs* rhs*) (old* '()) (new* '()))
(cond
((null? lhs*)
`(let ,(map list old* new*) ,b . ,b*))
(else
(syntax-match (car lhs*) ()
((x* ...)
(let-values (((y* old* new*) (rename* x* old* new*)))
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,y*
,(f (cdr lhs*) (cdr rhs*) old* new*)))))
((x* ... . x)
(let*-values (((y old* new*) (rename x old* new*))
((y* old* new*) (rename* x* old* new*)))
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,(append y* y)
,(f (cdr lhs*) (cdr rhs*)
old* new*)))))
(others
(syntax-violation #f "malformed bindings"
stx others)))))))))))
(define let*-values-macro
(lambda (stx)
(define (check x*)
(unless (null? x*)
(let ((x (car x*)))
(unless (id? x)
(syntax-violation #f "not an identifier" stx x))
(check (cdr x*))
(when (bound-id-member? x (cdr x*))
(syntax-violation #f "duplicate identifier" stx x)))))
(syntax-match stx ()
((_ () b b* ...)
(cons* (bless 'let) '() b b*))
((_ ((lhs* rhs*) ...) b b* ...)
(bless
(let f ((lhs* lhs*) (rhs* rhs*))
(cond
((null? lhs*)
`(begin ,b . ,b*))
(else
(syntax-match (car lhs*) ()
((x* ...)
(begin
(check x*)
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,x*
,(f (cdr lhs*) (cdr rhs*))))))
((x* ... . x)
(begin
(check (cons x x*))
`(call-with-values
(lambda () ,(car rhs*))
(lambda ,(append x* x)
,(f (cdr lhs*) (cdr rhs*))))))
(others
(syntax-violation #f "malformed bindings"
stx others)))))))))))
(define trace-lambda-macro
(lambda (stx)
(syntax-match stx ()
((_ who (fmls ...) b b* ...)
(if (valid-bound-ids? fmls)
(bless `(make-traced-procedure ',who
(lambda ,fmls ,b . ,b*)))
(invalid-fmls-error stx fmls)))
((_ who (fmls ... . last) b b* ...)
(if (valid-bound-ids? (cons last fmls))
(bless `(make-traced-procedure ',who
(lambda (,@fmls . ,last) ,b . ,b*)))
(invalid-fmls-error stx (append fmls last)))))))
(define trace-define-macro
(lambda (stx)
(syntax-match stx ()
((_ (who fmls ...) b b* ...)
(if (valid-bound-ids? fmls)
(bless `(define ,who
(make-traced-procedure ',who
(lambda ,fmls ,b . ,b*))))
(invalid-fmls-error stx fmls)))
((_ (who fmls ... . last) b b* ...)
(if (valid-bound-ids? (cons last fmls))
(bless `(define ,who
(make-traced-procedure ',who
(lambda (,@fmls . ,last) ,b . ,b*))))
(invalid-fmls-error stx (append fmls last))))
((_ who expr)
(if (id? who)
(bless `(define ,who
(let ((v ,expr))
(if (procedure? v)
(make-traced-procedure ',who v)
v))))
(stx-error stx "invalid name"))))))
(define trace-define-syntax-macro
(lambda (stx)
(syntax-match stx ()
((_ who expr)
(if (id? who)
(bless
`(define-syntax ,who
(make-traced-macro ',who ,expr)))
(stx-error stx "invalid name"))))))
(define trace-let/rec-syntax
(lambda (who)
(lambda (stx)
(syntax-match stx ()
((_ ((lhs* rhs*) ...) b b* ...)
(if (valid-bound-ids? lhs*)
(let ((rhs* (map (lambda (lhs rhs)
`(make-traced-macro ',lhs ,rhs))
lhs* rhs*)))
(bless `(,who ,(map list lhs* rhs*) ,b . ,b*)))
(invalid-fmls-error stx lhs*)))))))
(define trace-let-syntax-macro
(trace-let/rec-syntax 'let-syntax))
(define trace-letrec-syntax-macro
(trace-let/rec-syntax 'letrec-syntax))
(define guard-macro
(lambda (x)
(define (gen-clauses con outerk clause*)
(define (f x k)
(syntax-match x (=>)
((e => p)
(let ((t (gensym)))
`(let ((,t ,e))
(if ,t (,p ,t) ,k))))
((e)
(let ((t (gensym)))
`(let ((,t ,e))
(if ,t ,t ,k))))
((e v v* ...)
`(if ,e (begin ,v ,@v*) ,k))
(_ (stx-error x "invalid guard clause"))))
(define (f* x*)
(syntax-match x* (else)
(()
(let ((g (gensym)))
(values `(,g (lambda () (raise-continuable ,con))) g)))
(((else e e* ...))
(values `(begin ,e ,@e*) #f))
((cls . cls*)
(let-values (((e g) (f* cls*)))
(values (f cls e) g)))
(others (stx-error others "invalid guard clause"))))
(let-values (((code raisek) (f* clause*)))
(if raisek
`((call/cc
(lambda (,raisek)
(,outerk
(lambda () ,code)))))
`(,outerk (lambda () ,code)))))
(syntax-match x ()
((_ (con clause* ...) b b* ...)
(id? con)
(let ((outerk (gensym)))
(bless
`((call/cc
(lambda (,outerk)
(lambda ()
(with-exception-handler
(lambda (,con)
,(gen-clauses con outerk clause*))
(lambda () ,b ,@b*))))))))))))
(define define-enumeration-macro
(lambda (stx)
(define (set? x)
(or (null? x)
(and (not (memq (car x) (cdr x)))
(set? (cdr x)))))
(define (remove-dups ls)
(cond
((null? ls) '())
(else
(cons (car ls)
(remove-dups (remq (car ls) (cdr ls)))))))
(syntax-match stx ()
((_ name (id* ...) maker)
(and (id? name) (id? maker) (for-all id? id*))
(let ((name* (remove-dups (syntax->datum id*))) (mk (gensym)))
(bless
`(begin
;;; can be constructed at compile time
;;; but .... it's not worth it.
;;; also, generativity of defined enum types
;;; is completely unspecified, making them just
;;; more useless than they really are.
;;; eventually, I'll make them all compile-time
;;; generative just to piss some known people off.
(define ,mk
(enum-set-constructor
(make-enumeration ',name*)))
(define-syntax ,name
(lambda (x)
(syntax-case x ()
((_ n)
(identifier? (syntax n))
(if (memq (syntax->datum (syntax n)) ',name*)
(syntax 'n)
(syntax-violation ',name
"not a member of set"
x (syntax n)))))))
(define-syntax ,maker
(lambda (x)
(syntax-case x ()
((_ n* ...)
(begin
(for-each
(lambda (n)
(unless (identifier? n)
(syntax-violation
',maker
"non-identifier argument"
x
n))
(unless (memq (syntax->datum n) ',name*)
(syntax-violation
',maker
"not a member of set"
x
n)))
(syntax (n* ...)))
(syntax (,mk '(n* ...)))))))))))))))
(define time-macro
(lambda (stx)
(syntax-match stx ()
((_ expr)
(let ((str
(let-values (((p e) (open-string-output-port)))
(write (syntax->datum expr) p)
(e))))
(bless `(time-it ,str (lambda () ,expr))))))))
(define delay-macro
(lambda (stx)
(syntax-match stx ()
((_ expr)
(bless `(make-promise (lambda () ,expr)))))))
(define assert-macro
(lambda (stx)
(syntax-match stx ()
((_ expr)
(let ((pos (or (expression-position stx)
(expression-position expr))))
(bless
`(unless ,expr (assertion-error ',expr ',pos))))))))
(define endianness-macro
(lambda (stx)
(syntax-match stx ()
((_ e)
(case (syntax->datum e)
((little) (bless `'little))
((big) (bless `'big))
(else (stx-error stx "endianness must be big or little")))))))
(define identifier-syntax-macro
(lambda (stx)
(syntax-match stx (set!)
((_ expr)
(bless `(lambda (x)
(syntax-case x ()
(id (identifier? (syntax id)) (syntax ,expr))
((id e* ...) (identifier? (syntax id))
(cons (syntax ,expr) (syntax (e* ...))))))))
((_ (id1 expr1) ((set! id2 expr2) expr3))
(and (id? id1) (id? id2) (id? expr2))
(bless `(cons 'macro!
(lambda (x)
(syntax-case x (set!)
(id (identifier? (syntax id)) (syntax ,expr1))
((set! id ,expr2) (syntax ,expr3))
((id e* ...) (identifier? (syntax id)) (syntax (,expr1 e* ...)))))))))))
(define do-macro
(lambda (stx)
(define bind
(lambda (x)
(syntax-match x ()
((x init) `(,x ,init ,x))
((x init step) `(,x ,init ,step))
(_ (stx-error stx "invalid binding")))))
(syntax-match stx ()
((_ (binding* ...)
(test expr* ...)
command* ...)
(syntax-match (map bind binding*) ()
(((x* init* step*) ...)
(if (valid-bound-ids? x*)
(bless
`(letrec ((loop
(lambda ,x*
(if ,test
(begin (if #f #f) ,@expr*)
(begin
,@command*
(loop ,@step*))))))
(loop ,@init*)))
(stx-error stx "invalid bindings"))))))))
(define let*-macro
(lambda (stx)
(syntax-match stx ()
((_ ((lhs* rhs*) ...) b b* ...) (for-all id? lhs*)
(bless
(let f ((x* (map list lhs* rhs*)))
(cond
((null? x*) `(let () ,b . ,b*))
(else `(let (,(car x*)) ,(f (cdr x*)))))))))))
(define or-macro
(lambda (stx)
(syntax-match stx ()
((_) #f)
((_ e e* ...)
(bless
(let f ((e e) (e* e*))
(cond
((null? e*) `(begin #f ,e))
(else
`(let ((t ,e))
(if t t ,(f (car e*) (cdr e*))))))))))))
(define and-macro
(lambda (stx)
(syntax-match stx ()
((_) #t)
((_ e e* ...)
(bless
(let f ((e e) (e* e*))
(cond
((null? e*) `(begin #f ,e))
(else `(if ,e ,(f (car e*) (cdr e*)) #f)))))))))
(define cond-macro
(lambda (stx)
(syntax-match stx ()
((_ cls cls* ...)
(bless
(let f ((cls cls) (cls* cls*))
(cond
((null? cls*)
(syntax-match cls (else =>)
((else e e* ...) `(let () #f ,e . ,e*))
((e => p) `(let ((t ,e)) (if t (,p t))))
((e) `(or ,e (if #f #f)))
((e e* ...) `(if ,e (begin . ,e*)))
(_ (stx-error stx "invalid last clause"))))
(else
(syntax-match cls (else =>)
((else e e* ...) (stx-error stx "incorrect position of keyword else"))
((e => p) `(let ((t ,e)) (if t (,p t) ,(f (car cls*) (cdr cls*)))))
((e) `(or ,e ,(f (car cls*) (cdr cls*))))
((e e* ...) `(if ,e (begin . ,e*) ,(f (car cls*) (cdr cls*))))
(_ (stx-error stx "invalid last clause")))))))))))
(define syntax-rules-macro
(lambda (e)
(syntax-match e ()
((_ (lits ...)
(pat* tmp*) ...)
(begin
(verify-literals lits e)
(bless `(lambda (x)
(syntax-case x ,lits
,@(map (lambda (pat tmp)
(syntax-match pat ()
((_ . rest)
`((g . ,rest) (syntax ,tmp)))
(_
(syntax-violation #f
"invalid syntax-rules pattern"
e pat))))
pat* tmp*)))))))))
(define quasiquote-macro
(let ()
(define (datum x)
(list (scheme-stx 'quote) (mkstx x top-mark* '() '())))
(define-syntax app
(syntax-rules (quote)
((_ 'x arg* ...)
(list (scheme-stx 'x) arg* ...))))
(define-syntax app*
(syntax-rules (quote)
((_ 'x arg* ... last)
(cons* (scheme-stx 'x) arg* ... last))))
(define quasicons*
(lambda (x y)
(let f ((x x))
(if (null? x) y (quasicons (car x) (f (cdr x)))))))
(define quasicons
(lambda (x y)
(syntax-match y (quote list)
((quote dy)
(syntax-match x (quote)
((quote dx) (app 'quote (cons dx dy)))
(_
(syntax-match dy ()
(() (app 'list x))
(_ (app 'cons x y))))))
((list stuff ...)
(app* 'list x stuff))
(_ (app 'cons x y)))))
(define quasiappend
(lambda (x y)
(let ((ls (let f ((x x))
(if (null? x)
(syntax-match y (quote)
((quote ()) '())
(_ (list y)))
(syntax-match (car x) (quote)
((quote ()) (f (cdr x)))
(_ (cons (car x) (f (cdr x)))))))))
(cond
((null? ls) (app 'quote '()))
((null? (cdr ls)) (car ls))
(else (app* 'append ls))))))
(define quasivector
(lambda (x)
(let ((pat-x x))
(syntax-match pat-x (quote)
((quote (x* ...)) (app 'quote (list->vector x*)))
(_ (let f ((x x) (k (lambda (ls) (app* 'vector ls))))
(syntax-match x (quote list cons)
((quote (x* ...))
(k (map (lambda (x) (app 'quote x)) x*)))
((list x* ...)
(k x*))
((cons x y)
(f y (lambda (ls) (k (cons x ls)))))
(_ (app 'list->vector pat-x)))))))))
(define vquasi
(lambda (p lev)
(syntax-match p ()
((p . q)
(syntax-match p (unquote unquote-splicing)
((unquote p ...)
(if (= lev 0)
(quasicons* p (vquasi q lev))
(quasicons
(quasicons (datum 'unquote)
(quasi p (- lev 1)))
(vquasi q lev))))
((unquote-splicing p ...)
(if (= lev 0)
(quasiappend p (vquasi q lev))
(quasicons
(quasicons
(datum 'unquote-splicing)
(quasi p (- lev 1)))
(vquasi q lev))))
(p (quasicons (quasi p lev) (vquasi q lev)))))
(() (app 'quote '())))))
(define quasi
(lambda (p lev)
(syntax-match p (unquote unquote-splicing quasiquote)
((unquote p)
(if (= lev 0)
p
(quasicons (datum 'unquote) (quasi (list p) (- lev 1)))))
(((unquote p ...) . q)
(if (= lev 0)
(quasicons* p (quasi q lev))
(quasicons
(quasicons (datum 'unquote)
(quasi p (- lev 1)))
(quasi q lev))))
(((unquote-splicing p ...) . q)
(if (= lev 0)
(quasiappend p (quasi q lev))
(quasicons
(quasicons (datum 'unquote-splicing)
(quasi p (- lev 1)))
(quasi q lev))))
((quasiquote p)
(quasicons (datum 'quasiquote)
(quasi (list p) (+ lev 1))))
((p . q) (quasicons (quasi p lev) (quasi q lev)))
(#(x ...) (not (stx? x)) (quasivector (vquasi x lev)))
(p (app 'quote p)))))
(lambda (x)
(syntax-match x ()
((_ e) (quasi e 0))))))
(define quasisyntax-macro
(let () ;;; FIXME: not really correct
(define quasi
(lambda (p lev)
(syntax-match p (unsyntax unsyntax-splicing quasisyntax)
((unsyntax p)
(if (= lev 0)
(let ((g (gensym)))
(values (list g) (list p) g))
(let-values (((lhs* rhs* p) (quasi p (- lev 1))))
(values lhs* rhs* (list 'unsyntax p)))))
(unsyntax (= lev 0)
(stx-error p "incorrect use of unsyntax"))
(((unsyntax p* ...) . q)
(let-values (((lhs* rhs* q) (quasi q lev)))
(if (= lev 0)
(let ((g* (map (lambda (x) (gensym)) p*)))
(values
(append g* lhs*)
(append p* rhs*)
(append g* q)))
(let-values (((lhs2* rhs2* p*) (quasi p* (- lev 1))))
(values
(append lhs2* lhs*)
(append rhs2* rhs*)
`((unsyntax . ,p*) . ,q))))))
(((unsyntax-splicing p* ...) . q)
(let-values (((lhs* rhs* q) (quasi q lev)))
(if (= lev 0)
(let ((g* (map (lambda (x) (gensym)) p*)))
(values
(append
(map (lambda (g) `(,g ...)) g*)
lhs*)
(append p* rhs*)
(append
(apply append
(map (lambda (g) `(,g ...)) g*))
q)))
(let-values (((lhs2* rhs2* p*) (quasi p* (- lev 1))))
(values
(append lhs2* lhs*)
(append rhs2* rhs*)
`((unsyntax-splicing . ,p*) . ,q))))))
(unsyntax-splicing (= lev 0)
(stx-error p "incorrect use of unsyntax-splicing"))
((quasisyntax p)
(let-values (((lhs* rhs* p) (quasi p (+ lev 1))))
(values lhs* rhs* `(quasisyntax ,p))))
((p . q)
(let-values (((lhs* rhs* p) (quasi p lev))
((lhs2* rhs2* q) (quasi q lev)))
(values (append lhs2* lhs*)
(append rhs2* rhs*)
(cons p q))))
(#(x* ...)
(let-values (((lhs* rhs* x*) (quasi x* lev)))
(values lhs* rhs* (list->vector x*))))
(_ (values '() '() p)))))
(lambda (x)
(syntax-match x ()
((_ e)
(let-values (((lhs* rhs* v) (quasi e 0)))
(bless
`(syntax-case (list ,@rhs*) ()
(,lhs* (syntax ,v))))))))))
(define define-struct-macro
(if-wants-define-struct
(lambda (e)
(define enumerate
(lambda (ls)
(let f ((i 0) (ls ls))
(cond
((null? ls) '())
(else (cons i (f (+ i 1) (cdr ls))))))))
(define mkid
(lambda (id str)
(datum->stx id (string->symbol str))))
(syntax-match e ()
((_ name (field* ...))
(let* ((namestr (symbol->string (id->sym name)))
(fields (map id->sym field*))
(fieldstr* (map symbol->string fields))
(rtd (datum->stx name (make-struct-type namestr fields)))
(constr (mkid name (string-append "make-" namestr)))
(pred (mkid name (string-append namestr "?")))
(i* (enumerate field*))
(getters
(map (lambda (x)
(mkid name (string-append namestr "-" x)))
fieldstr*))
(setters
(map (lambda (x)
(mkid name (string-append "set-" namestr "-" x "!")))
fieldstr*)))
(bless
`(begin
(define-syntax ,name (cons '$rtd ',rtd))
(define ,constr
(lambda ,field*
($struct ',rtd ,@field*)))
(define ,pred
(lambda (x) ($struct/rtd? x ',rtd)))
,@(map (lambda (getter i)
`(define ,getter
(lambda (x)
(if ($struct/rtd? x ',rtd)
($struct-ref x ,i)
(assertion-violation ',getter
"not a struct of required type"
x ',rtd)))))
getters i*)
,@(map (lambda (setter i)
`(define ,setter
(lambda (x v)
(if ($struct/rtd? x ',rtd)
($struct-set! x ,i v)
(assertion-violation ',setter
"not a struct of required type"
x ',rtd)))))
setters i*)))))))
(lambda (stx)
(stx-error stx "define-struct not supported"))))
(define define-record-type-macro
(lambda (x)
(define (id ctxt . str*)
(datum->syntax ctxt
(string->symbol
(apply string-append
(map (lambda (x)
(cond
((symbol? x) (symbol->string x))
((string? x) x)
(else (assertion-violation 'define-record-type "BUG"))))
str*)))))
(define (get-record-name spec)
(syntax-match spec ()
((foo make-foo foo?) foo)
(foo foo)))
(define (get-record-constructor-name spec)
(syntax-match spec ()
((foo make-foo foo?) make-foo)
(foo (id? foo) (id foo "make-" (stx->datum foo)))))
(define (get-record-predicate-name spec)
(syntax-match spec ()
((foo make-foo foo?) foo?)
(foo (id? foo) (id foo (stx->datum foo) "?"))))
(define (get-clause id ls)
(syntax-match ls ()
(() #f)
(((x . rest) . ls)
(if (free-id=? (bless id) x)
`(,x . ,rest)
(get-clause id ls)))))
(define (foo-rtd-code name clause* parent-rtd-code)
(define (convert-field-spec* ls)
(list->vector
(map (lambda (x)
(syntax-match x (mutable immutable)
((mutable name . rest) `(mutable ,name))
((immutable name . rest) `(immutable ,name))
(name `(immutable ,name))))
ls)))
(let ((uid-code
(syntax-match (get-clause 'nongenerative clause*) ()
((_) `',(gensym))
((_ uid) `',uid)
(_ #f)))
(sealed?
(syntax-match (get-clause 'sealed clause*) ()
((_ #t) #t)
(_ #f)))
(opaque?
(syntax-match (get-clause 'opaque clause*) ()
((_ #t) #t)
(_ #f)))
(fields
(syntax-match (get-clause 'fields clause*) ()
((_ field-spec* ...)
`(quote ,(convert-field-spec* field-spec*)))
(_ ''#()))))
(bless
`(make-record-type-descriptor ',name
,parent-rtd-code
,uid-code ,sealed? ,opaque? ,fields))))
(define (parent-rtd-code clause*)
(syntax-match (get-clause 'parent clause*) ()
((_ name) `(record-type-descriptor ,name))
(#f (syntax-match (get-clause 'parent-rtd clause*) ()
((_ rtd rcd) rtd)
(#f #f)))))
(define (parent-rcd-code clause*)
(syntax-match (get-clause 'parent clause*) ()
((_ name) `(record-constructor-descriptor ,name))
(#f (syntax-match (get-clause 'parent-rtd clause*) ()
((_ rtd rcd) rcd)
(#f #f)))))
(define (foo-rcd-code clause* foo-rtd protocol parent-rcd-code)
`(make-record-constructor-descriptor ,foo-rtd
,parent-rcd-code ,protocol))
(define (get-protocol-code clause*)
(syntax-match (get-clause 'protocol clause*) ()
((_ expr) expr)
(_ #f)))
(define (get-fields clause*)
(syntax-match clause* (fields)
(() '())
(((fields f* ...) . _) f*)
((_ . rest) (get-fields rest))))
(define (get-mutator-indices fields)
(let f ((fields fields) (i 0))
(syntax-match fields (mutable)
(() '())
(((mutable . _) . rest)
(cons i (f rest (+ i 1))))
((_ . rest)
(f rest (+ i 1))))))
(define (get-mutators foo fields)
(define (gen-name x)
(datum->syntax foo
(string->symbol
(string-append
(symbol->string (syntax->datum foo))
"-"
(symbol->string (syntax->datum x))
"-set!"))))
(let f ((fields fields))
(syntax-match fields (mutable)
(() '())
(((mutable name accessor mutator) . rest)
(cons mutator (f rest)))
(((mutable name) . rest)
(cons (gen-name name) (f rest)))
((_ . rest) (f rest)))))
(define (get-accessors foo fields)
(define (gen-name x)
(datum->syntax foo
(string->symbol
(string-append
(symbol->string (syntax->datum foo))
"-"
(symbol->string (syntax->datum x))))))
(map
(lambda (field)
(syntax-match field (mutable immutable)
((mutable name accessor mutator) (id? accessor) accessor)
((immutable name accessor) (id? accessor) accessor)
((mutable name) (id? name) (gen-name name))
((immutable name) (id? name) (gen-name name))
(name (id? name) (gen-name name))
(others (stx-error field "invalid field spec"))))
fields))
(define (enumerate ls)
(let f ((ls ls) (i 0))
(cond
((null? ls) '())
(else (cons i (f (cdr ls) (+ i 1)))))))
(define (do-define-record namespec clause*)
(let* ((foo (get-record-name namespec))
(foo-rtd (gensym))
(foo-rcd (gensym))
(protocol (gensym))
(make-foo (get-record-constructor-name namespec))
(fields (get-fields clause*))
(idx* (enumerate fields))
(foo-x* (get-accessors foo fields))
(set-foo-x!* (get-mutators foo fields))
(set-foo-idx* (get-mutator-indices fields))
(foo? (get-record-predicate-name namespec))
(foo-rtd-code (foo-rtd-code foo clause* (parent-rtd-code clause*)))
(foo-rcd-code (foo-rcd-code clause* foo-rtd protocol (parent-rcd-code clause*)))
(protocol-code (get-protocol-code clause*)))
(bless
`(begin
(define ,foo-rtd ,foo-rtd-code)
(define ,protocol ,protocol-code)
(define ,foo-rcd ,foo-rcd-code)
(define-syntax ,foo
(list '$rtd (syntax ,foo-rtd) (syntax ,foo-rcd)))
(define ,foo? (record-predicate ,foo-rtd))
(define ,make-foo (record-constructor ,foo-rcd))
,@(map
(lambda (foo-x idx)
`(define ,foo-x (record-accessor ,foo-rtd ,idx)))
foo-x* idx*)
,@(map
(lambda (set-foo-x! idx)
`(define ,set-foo-x! (record-mutator ,foo-rtd ,idx)))
set-foo-x!* set-foo-idx*)))))
(define (verify-clauses x cls*)
(define valid-kwds
(map bless
'(fields parent parent-rtd protocol sealed opaque nongenerative)))
(define (free-id-member? x ls)
(and (pair? ls)
(or (free-id=? x (car ls))
(free-id-member? x (cdr ls)))))
(let f ((cls* cls*) (seen* '()))
(unless (null? cls*)
(syntax-match (car cls*) ()
((kwd . rest)
(cond
((or (not (id? kwd))
(not (free-id-member? kwd valid-kwds)))
(stx-error kwd "not a valid define-record-type keyword"))
((bound-id-member? kwd seen*)
(syntax-violation #f
"duplicate use of keyword "
x kwd))
(else (f (cdr cls*) (cons kwd seen*)))))
(cls
(stx-error cls "malformed define-record-type clause"))))))
(syntax-match x ()
((_ namespec clause* ...)
(begin
(verify-clauses x clause*)
(do-define-record namespec clause*))))))
(define define-condition-type-macro
(lambda (x)
(define (mkname name suffix)
(datum->syntax name
(string->symbol
(string-append
(symbol->string (syntax->datum name))
suffix))))
(syntax-match x ()
((ctxt name super constructor predicate (field* accessor*) ...)
(and (id? name)
(id? super)
(id? constructor)
(id? predicate)
(for-all id? field*)
(for-all id? accessor*))
(let ((aux-accessor* (map (lambda (x) (gensym)) accessor*)))
(bless
`(begin
(define-record-type (,name ,constructor ,(gensym))
(parent ,super)
(fields ,@(map (lambda (field aux)
`(immutable ,field ,aux))
field* aux-accessor*))
(nongenerative)
(sealed #f) (opaque #f))
(define ,predicate (condition-predicate
(record-type-descriptor ,name)))
,@(map
(lambda (accessor aux)
`(define ,accessor
(condition-accessor
(record-type-descriptor ,name) ,aux)))
accessor* aux-accessor*))))))))
(define incorrect-usage-macro
(lambda (e) (stx-error e "incorrect usage of auxiliary keyword")))
(define parameterize-macro
(lambda (e)
(syntax-match e ()
((_ () b b* ...)
(bless `(let () ,b . ,b*)))
((_ ((olhs* orhs*) ...) b b* ...)
(let ((lhs* (generate-temporaries olhs*))
(rhs* (generate-temporaries orhs*)))
(bless
`((lambda ,(append lhs* rhs*)
(let ((swap (lambda ()
,@(map (lambda (lhs rhs)
`(let ((t (,lhs)))
(,lhs ,rhs)
(set! ,rhs t)))
lhs* rhs*))))
(dynamic-wind
swap
(lambda () ,b . ,b*)
swap)))
,@(append olhs* orhs*))))))))
(define foreign-call-transformer
(lambda (e r mr)
(syntax-match e ()
((_ name arg* ...)
(build-foreign-call no-source
(chi-expr name r mr)
(chi-expr* arg* r mr))))))
;; p in pattern: matches:
;; () empty list
;; _ anything (no binding created)
;; any anything
;; (p1 . p2) pair
;; #(free-id <key>) <key> with free-identifier=?
;; each-any any proper list
;; #(each p) (p*)
;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;; #(vector p) #(x ...) if p matches (x ...)
;; #(atom <object>) <object> with "equal?"
(define convert-pattern
; 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)
(syntax-match p ()
(id (id? id)
(cond
((bound-id-member? p keys)
(values `#(free-id ,p) ids))
((free-id=? p (scheme-stx '_))
(values '_ ids))
(else (values 'any (cons (cons p n) ids)))))
((p dots) (ellipsis? dots)
(let-values (((p ids) (cvt p (+ n 1) ids)))
(values
(if (eq? p 'any) 'each-any `#(each ,p))
ids)))
((x dots ys ... . z) (ellipsis? dots)
(let-values (((z ids) (cvt z n ids)))
(let-values (((ys ids) (cvt* ys n ids)))
(let-values (((x ids) (cvt x (+ n 1) ids)))
(values `#(each+ ,x ,(reverse ys) ,z) ids)))))
((x . y)
(let-values (((y ids) (cvt y n ids)))
(let-values (((x ids) (cvt x n ids)))
(values (cons x y) ids))))
(() (values '() ids))
(#(p ...) (not (stx? p))
(let-values (((p ids) (cvt p n ids)))
(values `#(vector ,p) ids)))
(datum
(values `#(atom ,(stx->datum datum)) ids)))))
(cvt pattern 0 '())))
(define syntax-dispatch
(lambda (e p)
(define stx^
(lambda (e m* s* ae*)
(if (and (null? m*) (null? s*) (null? ae*))
e
(mkstx e m* s* ae*))))
(define match-each
(lambda (e p m* s* ae*)
(cond
((pair? e)
(let ((first (match (car e) p m* s* ae* '())))
(and first
(let ((rest (match-each (cdr e) p m* s* ae*)))
(and rest (cons first rest))))))
((null? e) '())
((stx? e)
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each (stx-expr e) p m* s* ae*))))
((annotation? e)
(match-each (annotation-expression e) p m* s* ae*))
(else #f))))
(define match-each+
(lambda (e x-pat y-pat z-pat m* s* ae* r)
(let f ((e e) (m* m*) (s* s*) (ae* ae*))
(cond
((pair? e)
(let-values (((xr* y-pat r) (f (cdr e) m* s* ae*)))
(if r
(if (null? y-pat)
(let ((xr (match (car e) x-pat m* s* ae* '())))
(if xr
(values (cons xr xr*) y-pat r)
(values #f #f #f)))
(values
'()
(cdr y-pat)
(match (car e) (car y-pat) m* s* ae* r)))
(values #f #f #f))))
((stx? e)
(if (top-marked? m*)
(values '() y-pat (match e z-pat m* s* ae* r))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(f (stx-expr e) m* s* ae*))))
((annotation? e)
(f (annotation-expression e) m* s* ae*))
(else (values '() y-pat (match e z-pat m* s* ae* r)))))))
(define match-each-any
(lambda (e m* s* ae*)
(cond
((pair? e)
(let ((l (match-each-any (cdr e) m* s* ae*)))
(and l (cons (stx^ (car e) m* s* ae*) l))))
((null? e) '())
((stx? e)
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each-any (stx-expr e) m* s* ae*))))
((annotation? e)
(match-each-any (annotation-expression e) m* s* ae*))
(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))
((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)
((scheme-id atom) r)
((vector) (match-empty (vector-ref p 1) r))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define combine
(lambda (r* r)
(if (null? (car r*))
r
(cons (map car r*) (combine (map cdr r*) r)))))
(define match*
(lambda (e p m* s* ae* r)
(cond
((null? p) (and (null? e) r))
((pair? p)
(and (pair? e)
(match (car e) (car p) m* s* ae*
(match (cdr e) (cdr p) m* s* ae* r))))
((eq? p 'each-any)
(let ((l (match-each-any e m* s* ae*))) (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) m* s* ae*)))
(and r* (combine r* r)))))
((free-id)
(and (symbol? e)
(top-marked? m*)
(free-id=? (stx^ e m* s* ae*) (vector-ref p 1))
r))
((scheme-id)
(and (symbol? e)
(top-marked? m*)
(free-id=? (stx^ e m* s* ae*)
(scheme-stx (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) m* s* ae* 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 m*)) r))
((vector)
(and (vector? e)
(match (vector->list e) (vector-ref p 1) m* s* ae* r)))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define match
(lambda (e p m* s* ae* r)
(cond
((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (stx^ e m* s* ae*) r))
((stx? e)
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match (stx-expr e) p m* s* ae* r))))
((annotation? e)
(match (annotation-expression e) p m* s* ae* r))
(else (match* e p m* s* ae* r)))))
(match e p '() '() '() '())))
(define ellipsis?
(lambda (x)
(and (id? x) (free-id=? x (scheme-stx '...)))))
(define underscore?
(lambda (x)
(and (id? x) (free-id=? x (scheme-stx '_)))))
(define (verify-literals lits expr)
(for-each
(lambda (x)
(when (or (not (id? x)) (ellipsis? x) (underscore? x))
(syntax-violation #f "invalid literal" expr x)))
lits))
(define syntax-case-transformer
(let ()
(define build-dispatch-call
(lambda (pvars expr y r mr)
(let ((ids (map car pvars))
(levels (map cdr pvars)))
(let ((labels (map gen-label ids))
(new-vars (map gen-lexical ids)))
(let ((body
(chi-expr
(add-subst (make-full-rib ids labels) expr)
(append
(map (lambda (label var level)
(cons label (make-binding 'syntax (cons var level))))
labels new-vars (map cdr pvars))
r)
mr)))
(build-application no-source
(build-primref no-source 'apply)
(list (build-lambda no-source new-vars body) y)))))))
(define invalid-ids-error
(lambda (id* e class)