commit b7804c2303b73c57cde607a4a35da66278ff0168
parent ba6819f1ed302be85d5305025cd60de471369faa
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 8 Oct 2006 04:14:56 +0000
Improved handling of lifts in modules
svn: r4522
original commit: d2fbbc4a9b70421309d3768a119ef64fb761e180
Diffstat:
3 files changed, 32 insertions(+), 30 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -243,17 +243,17 @@
[() null]
[(next (? ModulePass1-Part) (? ModulePass1))
(cons $2 $3)]
- [(lift-end-loop (? ModulePass1))
+ [(module-lift-end-loop (? ModulePass1))
(cons (make-mod:lift-end $1) $2)])
(ModulePass1-Part
(#:no-wrap)
[((? EE) (? ModulePass1/Prim))
(make-mod:prim $1 $2)]
- [(EE splice)
- (make-mod:splice $1 $2)]
- [(EE lift-loop)
- (make-mod:lift $1 $2)])
+ [(EE NoError module-lift-loop)
+ (make-mod:lift $1 $2)]
+ [(EE ! splice)
+ (make-mod:splice $1 $3)])
(ModulePass1/Prim
[(enter-prim prim-define-values ! exit-prim)
@@ -277,7 +277,7 @@
[() null]
[(next (? ModulePass2-Part) (? ModulePass2))
(cons $2 $3)]
- [(lift-end-loop (? ModulePass2))
+ [(module-lift-end-loop (? ModulePass2))
(cons (make-mod:lift-end $1) $2)])
(ModulePass2-Part
@@ -289,7 +289,7 @@
[((? EE))
(make-mod:cons $1)]
;; catch lifts
- [(EE lift-loop)
+ [(EE module-lift-loop)
(make-mod:lift $1 $2)])
;; Definitions
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -31,7 +31,8 @@
syntax-error ; exn
lift-loop ; syntax
lift/let-loop ; syntax
- lift-end-loop ; syntax
+ module-lift-loop ; syntaxes
+ module-lift-end-loop ; syntaxes
lift ; (cons syntax id)
lift-statement ; syntax
enter-local ; syntax
@@ -128,8 +129,9 @@
(132 . ,token-local-pre)
(133 . ,token-local-post)
(134 . ,token-lift-statement)
- (135 . ,token-lift-end-loop)
+ (135 . ,token-module-lift-end-loop)
(136 . ,token-lift/let-loop)
+ (137 . ,token-module-lift-loop)
))
(define (tokenize sig-n val pos)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -25,6 +25,7 @@
;; reductions : Derivation -> ReductionSequence
(define (reductions d)
(match d
+
;; Primitives
[(struct p:variable (e1 e2 rs))
null]
@@ -64,7 +65,8 @@
(R e1 _
[! exni]
[#:pattern (?define-values formals RHS)]
- [Expr RHS rhs])]
+ [#:if rhs
+ [Expr RHS rhs]])]
[(AnyQ p:if (e1 e2 rs full? test then else) exni)
(if full?
(R e1 _
@@ -396,34 +398,33 @@
(let* ([final-stxs #f]
[reductions
(let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
+ (define (the-context x)
+ (revappend prefix (cons x (stx-cdr suffix))))
;(printf "** MB loop~n")
;(printf " rules: ~s~n" mbrules)
;(printf " suffix: ~s~n" suffix)
;(printf " prefix: ~s~n" prefix)
(match mbrules
- [(cons ($$ mod:skip ()) next)
+ [(cons (struct mod:skip ()) next)
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
- [(cons ($$ mod:cons (head) _exni) next)
- (append (with-context (lambda (x)
- (revappend prefix (cons x (stx-cdr suffix))))
- (append (reductions head)))
+ [(cons (struct mod:cons (head)) next)
+ (append (with-context the-context (append (reductions head)))
(let ([estx (and (deriv? head) (deriv-e2 head))])
(loop next (stx-cdr suffix) (cons estx prefix))))]
- [(cons ($$ mod:prim (head prim) _exni) next)
- (append (with-context (lambda (x)
- (revappend prefix (cons x (stx-cdr suffix))))
- (if (and prim (not (p:define-values? prim)))
- (append (reductions head)
- (reductions prim))
- (reductions head)))
+ [(cons (AnyQ mod:prim (head prim)) next)
+ (append (with-context the-context
+ (append (reductions head)
+ (reductions prim)))
(let ([estx (and (deriv? head) (deriv-e2 head))])
(loop next (stx-cdr suffix) (cons estx prefix))))]
- [(cons ($$ mod:splice (head stxs)) next)
- ;(printf "suffix is: ~s~n~n" suffix)
+ [(cons (ErrW mod:splice (head stxs) exn) next)
+ (append (with-context the-context (reductions head))
+ (list (stumble (deriv-e2 head) exn)))]
+ [(cons (struct mod:splice (head stxs)) next)
+ ;(printf "suffix is: ~s~n" suffix)
;(printf "stxs is: ~s~n" stxs)
(append
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))
+ (with-context the-context (reductions head))
(let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)])
(cons (walk/foci head-e2
@@ -434,12 +435,11 @@
(E (revappend prefix stxs))
"Splice module-level begin")
(loop next stxs prefix))))]
- [(cons ($$ mod:lift (head stxs)) next)
+ [(cons (struct mod:lift (head stxs)) next)
;(printf "suffix is: ~s~n~n" suffix)
;(printf "stxs is: ~s~n" stxs)
(append
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))
+ (with-context the-context (reductions head))
(let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)])
(let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
@@ -451,7 +451,7 @@
(loop next
new-suffix
prefix)))))]
- [(cons ($$ mod:lift-end (tail)) next)
+ [(cons (struct mod:lift-end (tail)) next)
(append
(if (pair? tail)
(list (walk/foci null
