3970 lines
153 KiB
Scheme
3970 lines
153 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 expand generate-temporaries free-identifier=?
|
|
bound-identifier=? datum->syntax syntax-error
|
|
syntax-violation
|
|
syntax->datum
|
|
make-variable-transformer
|
|
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)
|
|
(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)))
|
|
|
|
;;; 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 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*) (cancel ae1* ae2*))
|
|
(values (append m1* m2*) (append s1* s2*) (append 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 ;;; QUEUE
|
|
(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*))))
|
|
|
|
;;; to add a mark, we always add a corresponding shift.
|
|
(define add-mark
|
|
(lambda (m e ae)
|
|
(mkstx e (list m) '(shift) (list ae))))
|
|
|
|
(define add-subst
|
|
(lambda (subst e)
|
|
(mkstx e '() (list subst) '())))
|
|
|
|
;;; 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->real-label i)) (t1 (id->real-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 id)
|
|
(or (id->real-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->real-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
|
|
(lambda (x r)
|
|
(cond
|
|
((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 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
|
|
(lambda (e r)
|
|
(cond
|
|
((id? e)
|
|
(let ((id e))
|
|
(let* ((label (id->label 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)
|
|
(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 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)
|
|
(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)
|
|
;;; ($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)
|
|
(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 (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 (cons fmls (cons b b*))))))
|
|
((_ 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)
|
|
(or (id->label x)
|
|
(syntax-violation #f "unbound 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* ...) `(begin ,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 no-source 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 no-source 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*) `(begin #f ,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 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)
|
|
(assertion-violation 'trace-define
|
|
"not a procedure" 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 () #f ,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* ...) `(begin ,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")))))))))))
|
|
|
|
(begin ; module (include-macro include-into-macro)
|
|
; no module to keep portable!
|
|
; dump everything in top-level, sure.
|
|
(define (do-include stx id filename)
|
|
(let ((filename (stx->datum filename)))
|
|
(unless (and (string? filename) (id? id))
|
|
(stx-error stx))
|
|
(cons
|
|
(bless 'begin)
|
|
(with-input-from-file filename
|
|
(lambda ()
|
|
(let f ((ls '()))
|
|
(let ((x (read-annotated)))
|
|
(cond
|
|
((eof-object? x) (reverse ls))
|
|
(else
|
|
(f (cons (datum->stx id x) ls)))))))))))
|
|
(define include-macro
|
|
(lambda (e)
|
|
(syntax-match e ()
|
|
((id filename)
|
|
(do-include e id filename)))))
|
|
(define include-into-macro
|
|
(lambda (e)
|
|
(syntax-match e ()
|
|
((_ id filename)
|
|
(do-include e id filename))))))
|
|
|
|
|
|
(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 '() '() '())))
|
|
(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)
|
|
(let find ((id* id*) (ok* '()))
|
|
(if (null? id*)
|
|
(stx-error e) ; shouldn't happen
|
|
(if (id? (car id*))
|
|
(if (bound-id-member? (car id*) ok*)
|
|
(syntax-error (car id*) "duplicate " class)
|
|
(find (cdr id*) (cons (car id*) ok*)))
|
|
(syntax-error (car id*) "invalid " class))))))
|
|
(define gen-clause
|
|
(lambda (x keys clauses r mr pat fender expr)
|
|
(let-values (((p pvars) (convert-pattern pat keys)))
|
|
(cond
|
|
((not (distinct-bound-ids? (map car pvars)))
|
|
(invalid-ids-error (map car pvars) pat "pattern variable"))
|
|
((not (for-all (lambda (x) (not (ellipsis? (car x)))) pvars))
|
|
(stx-error pat "misplaced ellipsis in syntax-case pattern"))
|
|
(else
|
|
(let ((y (gen-lexical 'tmp)))
|
|
(let ((test
|
|
(cond
|
|
((eq? fender #t) y)
|
|
(else
|
|
(let ((call
|
|
(build-dispatch-call
|
|
pvars fender y r mr)))
|
|
(build-conditional no-source
|
|
(build-lexical-reference no-source y)
|
|
call
|
|
(build-data no-source #f)))))))
|
|
(let ((conseq
|
|
(build-dispatch-call pvars expr
|
|
(build-lexical-reference no-source y)
|
|
r mr)))
|
|
(let ((altern
|
|
(gen-syntax-case x keys clauses r mr)))
|
|
(build-application no-source
|
|
(build-lambda no-source (list y)
|
|
(build-conditional no-source test conseq altern))
|
|
(list
|
|
(build-application no-source
|
|
(build-primref no-source 'syntax-dispatch)
|
|
(list
|
|
(build-lexical-reference no-source x)
|
|
(build-data no-source p))))))))))))))
|
|
(define gen-syntax-case
|
|
(lambda (x keys clauses r mr)
|
|
(if (null? clauses)
|
|
(build-application no-source
|
|
(build-primref no-source 'syntax-error)
|
|
(list (build-lexical-reference no-source x)))
|
|
(syntax-match (car clauses) ()
|
|
((pat expr)
|
|
(if (and (id? pat)
|
|
(not (bound-id-member? pat keys))
|
|
(not (ellipsis? pat)))
|
|
(if (free-id=? pat (scheme-stx '_))
|
|
(chi-expr expr r mr)
|
|
(let ((lab (gen-label pat))
|
|
(lex (gen-lexical pat)))
|
|
(let ((body
|
|
(chi-expr
|
|
(add-subst (make-full-rib (list pat) (list lab)) expr)
|
|
(cons (cons lab (make-binding 'syntax (cons lex 0))) r)
|
|
mr)))
|
|
(build-application no-source
|
|
(build-lambda no-source (list lex) body)
|
|
(list (build-lexical-reference no-source x))))))
|
|
(gen-clause x keys (cdr clauses) r mr pat #t expr)))
|
|
((pat fender expr)
|
|
(gen-clause x keys (cdr clauses) r mr pat fender expr))))))
|
|
(lambda (e r mr)
|
|
(syntax-match e ()
|
|
((_ expr (keys ...) clauses ...)
|
|
(begin
|
|
(verify-literals keys e)
|
|
(let ((x (gen-lexical 'tmp)))
|
|
(let ((body (gen-syntax-case x keys clauses r mr)))
|
|
(build-application no-source
|
|
(build-lambda no-source (list x) body)
|
|
(list (chi-expr expr r mr))))))))) |