diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt
index 2ab5dc6..c155e64 100644
--- a/collects/macro-debugger/model/deriv-c.rkt
+++ b/collects/macro-debugger/model/deriv-c.rkt
@@ -94,6 +94,9 @@
;; (make-p:require (listof LocalAction))
(define-struct (p:require prule) (locals) #:transparent)
+;; (make-p:#%stratified-body BDeriv)
+(define-struct (p:#%stratified-body prule) (bderiv) #:transparent)
+
;; (make-p:stop )
;; (make-p:unknown )
;; (make-p:#%top Stx)
diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt
index c24e0d2..a140435 100644
--- a/collects/macro-debugger/model/deriv-parser.rkt
+++ b/collects/macro-debugger/model/deriv-parser.rkt
@@ -260,7 +260,8 @@
[((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
[((? PrimRequire)) ($1 e1 e2 rs)]
[((? PrimProvide)) ($1 e1 e2 rs)]
- [((? PrimVarRef)) ($1 e1 e2 rs)])
+ [((? PrimVarRef)) ($1 e1 e2 rs)]
+ [((? PrimStratifiedBody)) ($1 e1 e2 rs)])
(PrimModule
(#:args e1 e2 rs)
@@ -472,6 +473,10 @@
(#:args e1 e2 rs)
[(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
+ (PrimStratifiedBody
+ (#:args e1 e2 rs)
+ [(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
+
(PrimSet
(#:args e1 e2 rs)
;; Unrolled to avoid shift/reduce
diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt
index d33e3c2..3c5cb9d 100644
--- a/collects/macro-debugger/model/deriv-tokens.rkt
+++ b/collects/macro-debugger/model/deriv-tokens.rkt
@@ -83,6 +83,7 @@
prim-set!
prim-expression
prim-varref
+ prim-#%stratified-body
))
;; ** Signals to tokens
@@ -174,6 +175,7 @@
(149 prim-varref)
(150 lift-require ,token-lift-require)
(151 lift-provide ,token-lift-provide)
+ (155 prim-#%stratified-body)
))
(define (signal->symbol sig)
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
index ba5503f..34f23c0 100644
--- a/collects/macro-debugger/model/reductions.rkt
+++ b/collects/macro-debugger/model/reductions.rkt
@@ -229,6 +229,15 @@
[#:pattern ?form]
[LocalActions ?form locals])]
+ [(Wrap p:#%stratified-body (e1 e2 rs ?1 bderiv))
+ (R [! ?1]
+ [#:pass1]
+ [#:pattern (?sb . ?body)]
+ [Block ?body bderiv]
+ [#:pass2]
+ [#:pattern ?form]
+ [#:walk e2 'macro])]
+
[(Wrap p:stop (e1 e2 rs ?1))
(R [! ?1])]
diff --git a/collects/tests/macro-debugger/all-tests.rkt b/collects/tests/macro-debugger/all-tests.rkt
index ec20b78..f742952 100644
--- a/collects/tests/macro-debugger/all-tests.rkt
+++ b/collects/tests/macro-debugger/all-tests.rkt
@@ -1,7 +1,6 @@
#lang scheme/base
(require rackunit
- rackunit/gui)
-(require macro-debugger/model/debug
+ macro-debugger/model/debug
"gentest-framework.ss"
"gentests.ss"
"test-setup.ss"
@@ -12,11 +11,16 @@
"tests/hiding.ss"
"tests/regression.ss"
"tests/policy.ss"
- "tests/collects.ss")
-(provide go)
+ ;;"tests/collects.ss"
+ )
+(provide all-tests)
+#|
+(require rackunit/gui)
(define (go) (test/gui all-tests))
(define (collects) (test/gui big-libs-tests))
+(provide go)
+|#
(define protos
(list proto:kernel-forms
@@ -30,6 +34,11 @@
(define hiding-deriv-test (mk-hidden-deriv-test protos))
(define hiding-steps-test (mk-hidden-steps-test protos))
+(provide deriv-test
+ steps-test
+ hiding-deriv-test
+ hiding-steps-test)
+
(define all-tests
(test-suite "All tests"
deriv-test
@@ -38,5 +47,4 @@
hiding-steps-test
specialized-hiding-tests
regression-tests
- #;seek-tests
policy-tests))
diff --git a/collects/tests/macro-debugger/gentests.rkt b/collects/tests/macro-debugger/gentests.rkt
index 5d4e1c1..dad2542 100644
--- a/collects/tests/macro-debugger/gentests.rkt
+++ b/collects/tests/macro-debugger/gentests.rkt
@@ -41,23 +41,25 @@
(define (checker-for-deriv label form attrs)
(cond [(assq '#:ok-deriv? attrs)
=> (lambda (key+expect-ok?)
- (test-case label
- (let ([d (trace/ns form (assq '#:kernel attrs))])
- (check-pred deriv? d)
- (if (cdr key+expect-ok?)
- (check-pred ok-node? d)
- (check-pred interrupted-node? d)))))]
+ (delay-test
+ (test-case label
+ (let ([d (trace/ns form (assq '#:kernel attrs))])
+ (check-pred deriv? d)
+ (if (cdr key+expect-ok?)
+ (check-pred ok-node? d)
+ (check-pred interrupted-node? d))))))]
[else #f]))
(define (checker-for-hidden-deriv label form attrs)
(cond [(assq '#:ok-deriv? attrs)
=> (lambda (key+expect-ok?)
- (test-case label
- (let ([d (trace/ns form (assq '#:kernel attrs))]
- [expect-ok? (cdr key+expect-ok?)])
- (check-hide d hide-none-policy expect-ok?)
- (check-hide d hide-all-policy expect-ok?)
- (check-hide d T-policy expect-ok?))))]
+ (delay-test
+ (test-case label
+ (let ([d (trace/ns form (assq '#:kernel attrs))]
+ [expect-ok? (cdr key+expect-ok?)])
+ (check-hide d hide-none-policy expect-ok?)
+ (check-hide d hide-all-policy expect-ok?)
+ (check-hide d T-policy expect-ok?)))))]
[else #f]))
(define (check-hide d policy expect-ok?)
@@ -74,28 +76,31 @@
(define (checker-for-steps label form attrs)
(cond [(assq '#:steps attrs)
=> (lambda (key+expected)
- (test-case label
- (let* ([d (trace/ns form (assq '#:kernel attrs))]
- [rs (reductions d)])
- (check-steps (cdr key+expected) rs))))]
+ (delay-test
+ (test-case label
+ (let* ([d (trace/ns form (assq '#:kernel attrs))]
+ [rs (reductions d)])
+ (check-steps (cdr key+expected) rs)))))]
[else #f]))
(define (checker-for-hidden-steps label form attrs)
(cond [(assq '#:same-hidden-steps attrs)
(unless (assq '#:steps attrs)
(error 'checker-for-hidden-steps "no steps given for ~s" label))
- (test-case label
- (let* ([d (trace/ns form (assq '#:kernel attrs))]
- [rs (parameterize ((macro-policy T-policy))
- (reductions d))])
- (check-steps (cdr (assq '#:steps attrs)) rs)))]
+ (delay-test
+ (test-case label
+ (let* ([d (trace/ns form (assq '#:kernel attrs))]
+ [rs (parameterize ((macro-policy T-policy))
+ (reductions d))])
+ (check-steps (cdr (assq '#:steps attrs)) rs))))]
[(assq '#:hidden-steps attrs)
=> (lambda (key+expected)
- (test-case label
- (let* ([d (trace/ns form (assq '#:kernel attrs))]
- [rs (parameterize ((macro-policy T-policy))
- (reductions d))])
- (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
+ (delay-test
+ (test-case label
+ (let* ([d (trace/ns form (assq '#:kernel attrs))]
+ [rs (parameterize ((macro-policy T-policy))
+ (reductions d))])
+ (check-steps (cdr (assq '#:hidden-steps attrs)) rs)))))]
[else #f]))
(define (check-steps expected actual)
diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt
index d4f6531..ca882ec 100644
--- a/collects/tests/macro-debugger/tests/collects.rkt
+++ b/collects/tests/macro-debugger/tests/collects.rkt
@@ -1,6 +1,5 @@
#lang scheme/base
-(require rackunit
- rackunit/gui)
+(require rackunit)
(require macro-debugger/model/debug
scheme/path
scheme/gui)
diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/collects/tests/macro-debugger/tests/syntax-basic.rkt
index a474e29..f5a95a6 100644
--- a/collects/tests/macro-debugger/tests/syntax-basic.rkt
+++ b/collects/tests/macro-debugger/tests/syntax-basic.rkt
@@ -1,4 +1,3 @@
-
#lang scheme/base
(require "../gentest-framework.ss")
(provide proto:kernel-forms
@@ -43,7 +42,7 @@
(testK "require for-template"
(#%require (for-template mzscheme))
#:no-steps)]
-
+
[#:suite
"Definitions"
(testK "define-values"
@@ -52,7 +51,7 @@
(testK "define-syntaxes"
(define-syntaxes (x) 'a)
#:no-steps)]
-
+
[#:suite
"Simple expressions"
(testK "if"
@@ -64,7 +63,7 @@
(testK "set!"
(set! x 'a)
#:no-steps)]
-
+
[#:suite
"Sequence-containing expressions"
(testK "begin"
@@ -86,9 +85,9 @@
(testK "#%app (explicit)"
(#%app + '1 '2 '3)
#:no-steps)]
-
+
[#:suite
- "Binding forms and blocks"
+ "Binding forms"
(testK "lambda (simple)"
(lambda (x) x)
[#:steps (rename-lambda (lambda (x) x))]
@@ -123,7 +122,50 @@
#:same-hidden-steps)]
[#:suite
- "Internal definitions"
+ "Internal definitions within #%stratified-body"
+ (testK "internal begin (empty)"
+ (#%stratified-body (begin) 'a)
+ [#:steps (splice-block (#%stratified-body 'a))
+ (macro 'a)]
+ [#:hidden-steps (splice-block (#%stratified-body 'a))])
+ (testK "internal begin (solo)"
+ (#%stratified-body (begin 'b))
+ [#:steps (splice-block (#%stratified-body 'b))
+ (macro 'b)]
+ [#:hidden-steps (splice-block (#%stratified-body 'b))])
+ (testK "internal begin"
+ (#%stratified-body (begin 'a) 'b)
+ [#:steps (splice-block (#%stratified-body 'a 'b))
+ (macro (begin 'a 'b))]
+ [#:hidden-steps (splice-block (#%stratified-body 'a 'b))])
+ (testK "internal define-values"
+ (#%stratified-body (define-values (x) 'a) 'b)
+ [#:steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (macro (letrec-values ([(x) 'a]) 'b))]
+ [#:hidden-steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
+ (testK "internal define-values in begin"
+ (#%stratified-body (begin (define-values (x) 'a)) 'b)
+ [#:steps
+ (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (macro (letrec-values ([(x) 'a]) 'b))]
+ [#:hidden-steps
+ (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
+ (testK "internal begin, then define-values"
+ (#%stratified-body (begin) (define-values (x) 'a) 'b)
+ [#:steps
+ (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+ (macro (letrec-values ([(x) 'a]) 'b))])]
+
+ [#:suite
+ "Internal definitions (mixed defs and exprs)"
(testK "internal begin (empty)"
(lambda () (begin) 'a)
[#:steps (rename-lambda (lambda () (begin) 'a))
@@ -165,8 +207,15 @@
(splice-block (lambda () (define-values (x) 'a) 'b))
(block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
+ #:same-hidden-steps)
+ (testK "define-values after expr"
+ (lambda () 'a (define-values (x) 'b) 'c)
+ [#:steps
+ (rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
+ (block->letrec (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))
+ (rename-letrec-values (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))]
#:same-hidden-steps)]
-
+
[#:suite
"Top-level begin"
(testK "begin (top-level)"
diff --git a/collects/tests/macro-debugger/tests/syntax-errors.rkt b/collects/tests/macro-debugger/tests/syntax-errors.rkt
index 57c9721..1ddb4e1 100644
--- a/collects/tests/macro-debugger/tests/syntax-errors.rkt
+++ b/collects/tests/macro-debugger/tests/syntax-errors.rkt
@@ -183,7 +183,7 @@
#:error-step)
(testKE (letrec-values ([(x) 1] [(x) 2]) 3)
#:error-step)]
-
+
[#:suite
"Internal definitions"
[#:suite
@@ -206,28 +206,27 @@
(define-values (x) 1)
(define-values (x) 2)
3)
- [#:rename+error-step rename-lambda])
- (testKE (lambda (x)
- (define-values (x) 'a)
- 'b
- (define-values (y) 'c)
- 'd)
- [#:steps (rename-lambda (lambda (x)
- (define-values (x) 'a)
- 'b
- (define-values (y) 'c)
- 'd))
- (block->letrec (lambda (x)
- (letrec-values ([(x) 'a])
- 'b
- (define-values (y) 'c)
- 'd)))
- (rename-letrec-values (lambda (x)
- (letrec-values ([(x) 'a])
- 'b
- (define-values (y) 'c)
- 'd)))
- error])]
+ [#:rename+error-step rename-lambda])]
+ [#:suite
+ "#%stratified-body"
+ (testKE (#%stratified-body
+ (define-values (x) 'a)
+ 'b
+ (define-values (y) 'c)
+ 'd)
+ [#:steps (block->letrec (#%stratified-body
+ (letrec-values ([(x) 'a])
+ 'b
+ (define-values (y) 'c)
+ 'd)))
+ (rename-letrec-values (#%stratified-body
+ (letrec-values ([(x) 'a])
+ 'b
+ (define-values (y) 'c)
+ 'd)))
+ error])
+ (testKE (#%stratified-body (define-values (x) 'a))
+ [#:steps error])]
[#:suite
"bad internal begin"
(testKE (lambda () (begin . 1))