2007-10-09 08:54:28 -04:00
|
|
|
;;; 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
|
2007-12-07 03:00:25 -05:00
|
|
|
syntax-violation
|
2007-10-09 08:54:28 -04:00
|
|
|
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)
|
2007-10-09 08:54:28 -04:00
|
|
|
(import
|
2008-05-03 06:23:35 -04:00
|
|
|
(only (ikarus) printf)
|
2007-10-09 08:54:28 -04:00
|
|
|
(except (rnrs)
|
|
|
|
environment environment? identifier?
|
|
|
|
eval generate-temporaries free-identifier=?
|
2007-11-10 23:50:54 -05:00
|
|
|
bound-identifier=? datum->syntax syntax-error
|
2007-12-07 03:00:25 -05:00
|
|
|
syntax-violation syntax->datum make-variable-transformer
|
2007-11-23 14:38:25 -05:00
|
|
|
null-environment scheme-report-environment)
|
2007-10-09 08:54:28 -04:00
|
|
|
(rnrs base)
|
|
|
|
(rnrs lists)
|
|
|
|
(rnrs control)
|
|
|
|
(rnrs io simple)
|
2007-11-23 16:07:38 -05:00
|
|
|
(rnrs mutable-pairs)
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)))))
|
|
|
|
|
2007-11-19 04:18:35 -05:00
|
|
|
(define-syntax no-source
|
|
|
|
(lambda (x) #f))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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)))
|
2007-12-15 08:22:49 -05:00
|
|
|
(else (assertion-violation 'gen-lexical "BUG: invalid arg" sym)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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)))
|
|
|
|
|
2008-05-01 04:21:07 -04:00
|
|
|
(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)]))))]
|
2008-05-01 04:21:07 -04:00
|
|
|
[else (values (gensym) (gen-lexical id))]))
|
|
|
|
|
|
|
|
|
|
|
|
(define (gen-define-label id rib)
|
|
|
|
(cond
|
2008-05-01 06:02:36 -04:00
|
|
|
[(top-level-context)
|
2008-05-01 04:21:07 -04:00
|
|
|
(gen-top-level-label id rib)]
|
|
|
|
[else (gensym)]))
|
|
|
|
|
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
;;; 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)
|
2007-11-12 05:01:25 -05:00
|
|
|
(define (find sym mark* sym* mark** label*)
|
2007-10-09 08:54:28 -04:00
|
|
|
(and (pair? sym*)
|
2007-11-12 05:01:25 -05:00
|
|
|
(if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**)))
|
2008-05-01 04:21:07 -04:00
|
|
|
label*
|
2007-11-12 05:01:25 -05:00
|
|
|
(find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
(when (rib-sealed/freq rib)
|
2007-12-19 23:42:27 -05:00
|
|
|
(assertion-violation 'extend-rib! "BUG: rib is sealed" rib))
|
2007-11-12 05:01:25 -05:00
|
|
|
(let ((sym (id->sym id))
|
|
|
|
(mark* (stx-mark* id)))
|
2007-10-09 08:54:28 -04:00
|
|
|
(let ((sym* (rib-sym* rib)))
|
2007-11-12 05:01:25 -05:00
|
|
|
(cond
|
|
|
|
[(and (memq sym (rib-sym* rib))
|
|
|
|
(find sym mark* sym* (rib-mark** rib) (rib-label* rib)))
|
|
|
|
=>
|
2008-05-01 04:21:07 -04:00
|
|
|
(lambda (p)
|
|
|
|
(unless (eq? label (car p))
|
|
|
|
(cond
|
2008-05-01 06:02:36 -04:00
|
|
|
[(top-level-context)
|
2008-05-01 04:21:07 -04:00
|
|
|
;;; override label
|
|
|
|
(set-car! p label)]
|
|
|
|
[else
|
|
|
|
;;; signal an error if the identifier was already
|
|
|
|
;;; in the rib.
|
|
|
|
(stx-error id "cannot redefine")])))]
|
2007-11-12 05:01:25 -05:00
|
|
|
[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)))]))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
2008-05-01 04:21:07 -04:00
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
;;; 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:
|
2008-02-14 04:01:09 -05:00
|
|
|
(define-record stx (expr mark* subst* ae*)
|
2007-10-09 08:54:28 -04:00
|
|
|
(lambda (x p)
|
2007-12-20 00:31:49 -05:00
|
|
|
(display "#<syntax " p)
|
|
|
|
(write (stx->datum x) p)
|
2007-12-19 19:05:23 -05:00
|
|
|
(let ([expr (stx-expr x)])
|
|
|
|
(when (annotation? expr)
|
|
|
|
(let ([src (annotation-source expr)])
|
|
|
|
(when (pair? src)
|
2008-05-06 15:38:05 -04:00
|
|
|
(display " [char " p)
|
2007-12-19 19:05:23 -05:00
|
|
|
(display (cdr src) p)
|
2007-12-20 00:31:49 -05:00
|
|
|
(display " of " p)
|
|
|
|
(display (car src) p)
|
|
|
|
(display "]" p)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)
|
2008-02-14 04:01:09 -05:00
|
|
|
(make-stx datum (stx-mark* id) (stx-subst* id) (stx-ae* id))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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
|
2008-02-14 04:01:09 -05:00
|
|
|
(lambda (m1* s1* ae1* e)
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)))))))
|
2008-02-14 04:01:09 -05:00
|
|
|
(let ((m2* (stx-mark* e))
|
|
|
|
(s2* (stx-subst* e))
|
|
|
|
(ae2* (stx-ae* e)))
|
2007-10-09 08:54:28 -04:00
|
|
|
(if (and (not (null? m1*))
|
|
|
|
(not (null? m2*))
|
|
|
|
(anti-mark? (car m2*)))
|
|
|
|
; cancel mark, anti-mark, and corresponding shifts
|
2008-02-14 04:01:09 -05:00
|
|
|
(values (cancel m1* m2*) (cancel s1* s2*) (cancel ae1* ae2*))
|
|
|
|
(values (append m1* m2*) (append s1* s2*) (append ae1* ae2*))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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.
|
2008-02-14 04:01:09 -05:00
|
|
|
(define mkstx ;;; QUEUE
|
|
|
|
(lambda (e m* s* ae*)
|
2007-10-09 08:54:28 -04:00
|
|
|
(if (stx? e)
|
2008-02-14 04:01:09 -05:00
|
|
|
(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*))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; to add a mark, we always add a corresponding shift.
|
|
|
|
(define add-mark
|
2008-02-14 04:01:09 -05:00
|
|
|
(lambda (m e ae)
|
|
|
|
(mkstx e (list m) '(shift) (list ae))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
(define add-subst
|
|
|
|
(lambda (subst e)
|
2008-02-14 04:01:09 -05:00
|
|
|
(mkstx e '() (list subst) '())))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; now are some deconstructors and predicates for syntax objects.
|
|
|
|
(define syntax-kind?
|
|
|
|
(lambda (x p?)
|
2007-12-19 19:05:23 -05:00
|
|
|
(cond
|
|
|
|
[(stx? x) (syntax-kind? (stx-expr x) p?)]
|
|
|
|
[(annotation? x)
|
|
|
|
(syntax-kind? (annotation-expression x) p?)]
|
|
|
|
[else (p? x)])))
|
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
(define syntax-vector->list
|
|
|
|
(lambda (x)
|
|
|
|
(cond
|
|
|
|
((stx? x)
|
|
|
|
(let ((ls (syntax-vector->list (stx-expr x)))
|
2008-02-14 04:01:09 -05:00
|
|
|
(m* (stx-mark* x))
|
|
|
|
(s* (stx-subst* x))
|
|
|
|
(ae* (stx-ae* x)))
|
|
|
|
(map (lambda (x) (mkstx x m* s* ae*)) ls)))
|
2007-12-19 19:05:23 -05:00
|
|
|
[(annotation? x)
|
|
|
|
(syntax-vector->list (annotation-expression x))]
|
2007-10-09 08:54:28 -04:00
|
|
|
((vector? x) (vector->list x))
|
2007-12-19 23:42:27 -05:00
|
|
|
(else (assertion-violation 'syntax-vector->list "BUG: not a syntax vector" x)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)
|
2007-12-19 19:05:23 -05:00
|
|
|
(cond
|
|
|
|
[(stx? x)
|
2008-02-14 04:01:09 -05:00
|
|
|
(mkstx (syntax-car (stx-expr x))
|
|
|
|
(stx-mark* x)
|
|
|
|
(stx-subst* x)
|
|
|
|
(stx-ae* x))]
|
2007-12-19 19:05:23 -05:00
|
|
|
[(annotation? x)
|
|
|
|
(syntax-car (annotation-expression x))]
|
|
|
|
[(pair? x) (car x)]
|
2007-12-19 23:42:27 -05:00
|
|
|
[else (assertion-violation 'syntax-car "BUG: not a pair" x)])))
|
2007-12-19 19:05:23 -05:00
|
|
|
(define syntax-cdr
|
|
|
|
(lambda (x)
|
|
|
|
(cond
|
|
|
|
[(stx? x)
|
2008-02-14 04:01:09 -05:00
|
|
|
(mkstx (syntax-cdr (stx-expr x))
|
|
|
|
(stx-mark* x)
|
|
|
|
(stx-subst* x)
|
|
|
|
(stx-ae* x))]
|
2007-12-19 19:05:23 -05:00
|
|
|
[(annotation? x)
|
|
|
|
(syntax-cdr (annotation-expression x))]
|
|
|
|
[(pair? x) (cdr x)]
|
2007-12-19 23:42:27 -05:00
|
|
|
[else (assertion-violation 'syntax-cdr "BUG: not a pair" x)])))
|
2007-10-09 08:54:28 -04:00
|
|
|
(define syntax->list
|
|
|
|
(lambda (x)
|
|
|
|
(if (syntax-pair? x)
|
|
|
|
(cons (syntax-car x) (syntax->list (syntax-cdr x)))
|
|
|
|
(if (syntax-null? x)
|
|
|
|
'()
|
2007-12-19 23:42:27 -05:00
|
|
|
(assertion-violation 'syntax->list "BUG: invalid argument" x)))))
|
2008-04-28 14:01:49 -04:00
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
(define id?
|
2008-04-28 14:01:49 -04:00
|
|
|
(lambda (x)
|
|
|
|
(and (stx? x)
|
|
|
|
(let ([expr (stx-expr x)])
|
|
|
|
(symbol? (if (annotation? expr)
|
|
|
|
(annotation-stripped expr)
|
|
|
|
expr))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
(define id->sym
|
|
|
|
(lambda (x)
|
2008-04-28 14:01:49 -04:00
|
|
|
(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))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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)
|
2008-05-01 15:04:43 -04:00
|
|
|
(let ((t0 (id->real-label i)) (t1 (id->real-label j)))
|
2007-10-09 08:54:28 -04:00
|
|
|
(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?
|
2007-11-12 03:34:48 -05:00
|
|
|
(or (number? x) (string? x) (char? x) (boolean? x)
|
|
|
|
(bytevector? x))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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.
|
2007-12-23 16:23:20 -05:00
|
|
|
|
|
|
|
(define (strip-annotations x)
|
|
|
|
(cond
|
|
|
|
[(pair? x)
|
|
|
|
(cons (strip-annotations (car x))
|
|
|
|
(strip-annotations (cdr x)))]
|
2008-05-03 06:49:36 -04:00
|
|
|
[(vector? x) (vector-map strip-annotations x)]
|
2007-12-23 16:23:20 -05:00
|
|
|
[(annotation? x) (annotation-stripped x)]
|
|
|
|
[else x]))
|
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
(define strip
|
|
|
|
(lambda (x m*)
|
|
|
|
(if (top-marked? m*)
|
2007-12-23 16:23:20 -05:00
|
|
|
(if (or (annotation? x)
|
2008-05-03 06:49:36 -04:00
|
|
|
(and (pair? x)
|
|
|
|
(annotation? (car x)))
|
|
|
|
(and (vector? x) (> (vector-length x) 0)
|
|
|
|
(annotation? (vector-ref x 0))))
|
2007-12-23 16:23:20 -05:00
|
|
|
;;; TODO: Ask Kent why this is a sufficient test
|
|
|
|
(strip-annotations x)
|
2007-12-19 19:05:23 -05:00
|
|
|
x)
|
2007-10-09 08:54:28 -04:00
|
|
|
(let f ((x x))
|
|
|
|
(cond
|
|
|
|
((stx? x) (strip (stx-expr x) (stx-mark* x)))
|
2007-12-19 19:05:23 -05:00
|
|
|
[(annotation? x) (annotation-stripped x)]
|
2007-10-09 08:54:28 -04:00
|
|
|
((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.
|
2008-05-01 15:04:43 -04:00
|
|
|
(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)])
|
2008-05-15 09:40:07 -04:00
|
|
|
(extend-rib! rib id lab)
|
2008-05-01 15:04:43 -04:00
|
|
|
lab)))]
|
|
|
|
[else #f])))
|
|
|
|
|
|
|
|
(define id->real-label
|
2007-10-09 08:54:28 -04:00
|
|
|
(lambda (id)
|
|
|
|
(let ((sym (id->sym id)))
|
|
|
|
(let search ((subst* (stx-subst* id)) (mark* (stx-mark* id)))
|
|
|
|
(cond
|
2008-05-01 15:04:43 -04:00
|
|
|
((null? subst*) #f)
|
2007-10-09 08:54:28 -04:00
|
|
|
((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
|
2007-10-23 17:24:55 -04:00
|
|
|
((imported-label->binding x) =>
|
|
|
|
(lambda (b)
|
2007-12-17 11:37:10 -05:00
|
|
|
(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])))
|
2007-10-09 08:54:28 -04:00
|
|
|
((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)]))]
|
2007-10-09 08:54:28 -04:00
|
|
|
(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.
|
2007-12-23 19:52:18 -05:00
|
|
|
(define (raise-unbound-error id)
|
|
|
|
(syntax-violation* #f "unbound identifier" id
|
|
|
|
(make-undefined-violation)))
|
2007-10-09 08:54:28 -04:00
|
|
|
(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.
|
2007-12-23 19:52:18 -05:00
|
|
|
(raise-unbound-error id))
|
2007-10-09 08:54:28 -04:00
|
|
|
(case type
|
|
|
|
((lexical core-prim macro macro! global local-macro
|
|
|
|
local-macro! global-macro global-macro!
|
2007-11-12 01:27:47 -05:00
|
|
|
displaced-lexical syntax import $module $core-rtd
|
2007-11-23 16:07:38 -05:00
|
|
|
library mutable)
|
2007-10-09 08:54:28 -04:00
|
|
|
(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.
|
2007-12-23 19:52:18 -05:00
|
|
|
(raise-unbound-error id))
|
2007-10-09 08:54:28 -04:00
|
|
|
(case type
|
|
|
|
((define define-syntax core-macro begin macro
|
|
|
|
macro! local-macro local-macro! global-macro
|
2007-11-12 01:27:47 -05:00
|
|
|
global-macro! module library set! let-syntax
|
2007-10-23 17:24:55 -04:00
|
|
|
letrec-syntax import $core-rtd)
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)
|
2007-12-19 23:42:27 -05:00
|
|
|
(syntax (syntax-violation #f "invalid syntax" stx)))
|
|
|
|
((_ stx msg)
|
|
|
|
(syntax (syntax-violation #f msg stx))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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)
|
2007-12-15 08:22:49 -05:00
|
|
|
;;; and signals an assertion-violation otherwise.
|
2007-10-09 08:54:28 -04:00
|
|
|
(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)
|
2007-12-15 08:22:49 -05:00
|
|
|
(else (assertion-violation 'expand "invalid transformer" x)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; r6rs's make-variable-transformer:
|
|
|
|
(define make-variable-transformer
|
|
|
|
(lambda (x)
|
|
|
|
(if (procedure? x)
|
|
|
|
(cons 'macro! x)
|
2007-12-15 08:22:49 -05:00
|
|
|
(assertion-violation 'make-variable-transformer
|
2007-10-25 14:32:26 -04:00
|
|
|
"not a procedure" x))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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* ...)))))))))))
|
|
|
|
|
2008-01-27 19:12:20 -05:00
|
|
|
|
2007-10-09 08:54:28 -04:00
|
|
|
(define parse-define
|
|
|
|
(lambda (x)
|
|
|
|
(syntax-match x ()
|
|
|
|
((_ (id . fmls) b b* ...) (id? id)
|
2008-01-27 19:12:20 -05:00
|
|
|
(begin
|
|
|
|
(verify-formals fmls x)
|
|
|
|
(values id (cons 'defun (cons fmls (cons b b*))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
((_ id val) (id? id)
|
2008-01-18 22:18:26 -05:00
|
|
|
(values id (cons 'expr val)))
|
2008-01-27 19:12:20 -05:00
|
|
|
((_ id) (id? id)
|
2008-01-18 22:18:26 -05:00
|
|
|
(values id (cons 'expr (bless '(void))))))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
(define parse-define-syntax
|
|
|
|
(lambda (x)
|
|
|
|
(syntax-match x ()
|
2007-11-19 04:18:35 -05:00
|
|
|
((_ id val) (id? id) (values id val)))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; 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.
|
2008-03-12 18:12:57 -04:00
|
|
|
(define scheme-stx-hashtable (make-eq-hashtable))
|
2007-10-09 08:54:28 -04:00
|
|
|
(define scheme-stx
|
|
|
|
(lambda (sym)
|
2008-03-12 18:12:57 -04:00
|
|
|
(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))))
|
2007-10-09 08:54:28 -04:00
|
|
|
|
|
|
|
;;; macros
|
2007-11-23 16:07:38 -05:00
|
|
|
(define lexical-var car)
|
|
|
|
(define lexical-mutable? cdr)
|
|
|
|
(define set-lexical-mutable! set-cdr!)
|
2007-10-09 08:54:28 -04:00
|
|
|
(define add-lexical
|
|
|
|
(lambda (lab lex r)
|
2007-11-23 16:07:38 -05:00
|
|
|
(cons (cons* lab 'lexical lex #f) r)))
|
2007-10-09 08:54:28 -04:00
|
|
|
;;;
|
|
|
|
(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))))))
|
|
|
|
;;;
|