ikarus/scheme/psyntax.expander.ss

3936 lines
152 KiB
Scheme
Raw Normal View History

;;; 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 environment environment?
eval expand generate-temporaries free-identifier=?
bound-identifier=? datum->syntax syntax-error
syntax-violation
syntax->datum make-variable-transformer
2008-05-01 06:02:36 -04:00
compile-r6rs-top-level boot-library-expand
null-environment scheme-report-environment
interaction-environment
ellipsis-map)
(import
(only (ikarus) printf)
(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)
2007-11-23 16:07:38 -05:00
(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)
(cond
2008-05-01 06:02:36 -04:00
[(top-level-context) =>
(lambda (env)
(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)]))))]
[else (values (gensym) (gen-lexical id))]))
(define (gen-define-label id rib)
(cond
2008-05-01 06:02:36 -04:00
[(top-level-context)
(gen-top-level-label id rib)]
[else (gensym)]))
;;; 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)
(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
2008-05-01 06:02:36 -04:00
[(top-level-context)
;;; override label
(set-car! p label)]
[else
;;; signal an error if the identifier was already
;;; in the rib.
(stx-error id "cannot redefine")])))]
[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)
(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 (stx? e)
(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)])
(extend-rib! rib id lab)
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)
2008-05-01 06:02:36 -04:00
[(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 $module $core-rtd
2007-11-23 16:07:38 -05:00
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 $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))))
;;; 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 dots?
(lambda (x)
(and (sys.identifier? x)
(sys.free-identifier=? x (syntax (... ...))))))
(define free-identifier-member?
(lambda (x ls)
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
(define (parse-clause lits cls)
(define (parse-pat pat)
(syntax-case pat ()
(id (sys.identifier? (syntax id))
(cond
((free-identifier-member? (syntax id) lits)
(values '()
(syntax
(lambda (x)
(and (id? x)
(free-id=? x (scheme-stx 'id))
'())))))
((sys.free-identifier=? (syntax id) (syntax _))
(values '() (syntax (lambda (x) '()))))
(else
(values (list (syntax id)) (syntax (lambda (x) (list x)))))))
((pat dots) (dots? (syntax dots))
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars) (decon decon))
(values pvars
(syntax (letrec ((f (lambda (x)
(cond
((syntax-pair? x)
(let ((cars/f (decon (syntax-car x))))
(and cars/f
(let ((cdrs/f (f (syntax-cdr x))))
(and cdrs/f
(map cons cars/f cdrs/f))))))
((syntax-null? x)
(list (begin 'v* '()) ...))
(else #f)))))
f))))))
((pat dots . last) (dots? (syntax dots))
(let-values (((p1 d1) (parse-pat (syntax pat)))
((p2 d2) (parse-pat (syntax last))))
(with-syntax (((v* ...) (append p1 p2))
((v1* ...) p1)
((v2* ...) p2)
(d1 d1) (d2 d2))
(values (append p1 p2)
(syntax (letrec ((f (lambda (x)
(cond
((syntax-pair? x)
(let ((cars/f (d1 (syntax-car x))))
(and cars/f
(let ((d/f (f (syntax-cdr x))))
(and d/f
(cons (map cons cars/f (car d/f))
(cdr d/f)))))))
(else
(let ((d (d2 x)))
(and d
(cons (list (begin 'v1* '()) ...)
d))))))))
(lambda (x)
(let ((x (f x)))
(and x (append (car x) (cdr x)))))))))))
((pat1 . pat2)
(let-values (((p1 d1) (parse-pat (syntax pat1)))
((p2 d2) (parse-pat (syntax pat2))))
(with-syntax ((d1 d1) (d2 d2))
(values (append p1 p2)
(syntax (lambda (x)
(and (syntax-pair? x)
(let ((q (d1 (syntax-car x))))
(and q
(let ((r (d2 (syntax-cdr x))))
(and r (append q r))))))))))))
(#(pats ...)
(let-values (((pvars d) (parse-pat (syntax (pats ...)))))
(with-syntax ((d d))
(values pvars
(syntax (lambda (x)
(and (syntax-vector? x)
(d (syntax-vector->list x)))))))))
(datum
(values '()
(syntax (lambda (x)
(and (equal? (stx->datum x) 'datum) '())))))))
(syntax-case cls ()
((pat body)
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars))
(values decon
(syntax (lambda (v* ...) #t))
(syntax (lambda (v* ...) body))))))
((pat guard body)
(let-values (((pvars decon) (parse-pat (syntax pat))))
(with-syntax (((v* ...) pvars))
(values decon
(syntax (lambda (v* ...) guard))
(syntax (lambda (v* ...) body))))))))
(syntax-case ctx ()
((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...)))
(syntax (stx-error expr "invalid syntax")))
((_ expr (lits ...) cls cls* ...) (for-all sys.identifier?
(syntax (lits ...)))
(let-values (((decon guard body)
(parse-clause (syntax (lits ...)) (syntax cls))))
(with-syntax ((decon decon) (guard guard) (body body))
(syntax (let ((t expr))
(let ((ls/false (decon t)))
(if (and ls/false (apply guard ls/false))
(apply body ls/false)
(syntax-match t (lits ...) 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 (mkstx 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
2007-11-23 16:07:38 -05:00
(define lexical-var car)
(define lexical-mutable? cdr)
(define set-lexical-mutable! set-cdr!)
(define add-lexical
(lambda (lab lex r)
2007-11-23 16:07:38 -05:00
(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))))))
;;;