commit 4822a649324590d4e7dc3b4d296ab528a7e5abb9
parent 0c1ea4fc7b9d17d0d814dd4eb197c74e75cdb88d
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 12 Jul 2010 17:19:55 -0600
macro-stepper: updated tests
original commit: e36c964a9aa963e1069818f98f526d266dac644d
Diffstat:
6 files changed, 80 insertions(+), 54 deletions(-)
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
@@ -235,6 +235,7 @@
[#:pattern (?sb . ?body)]
[Block ?body bderiv]
[#:pass2]
+ [#:hide-check rs]
[#:pattern ?form]
[#:walk e2 'macro])]
diff --git a/collects/tests/macro-debugger/gentests.rkt b/collects/tests/macro-debugger/gentests.rkt
@@ -106,15 +106,20 @@
(define (check-steps expected actual)
(check-pred list? actual)
(check-pred reduction-sequence? actual)
- (with-check-info (['actual-sequence-raw actual]
+ (with-check-info (;;['actual-sequence-raw actual]
['actual-sequence
(for/list ([thing actual])
- (if (misstep? thing)
- 'error
- (list* (protostep-type thing)
- (syntax->datum (step-term2 thing))
- (map syntax->datum
- (map bigframe-term (state-lctx (protostep-s1 thing)))))))]
+ (cond [(misstep? thing)
+ 'error]
+ [(remarkstep? thing)
+ (list* 'remark
+ (protostep-type thing)
+ (map syntax->datum (filter syntax? (remarkstep-contents thing))))]
+ [else
+ (list* (protostep-type thing)
+ (syntax->datum (step-term2 thing))
+ (map syntax->datum
+ (map bigframe-term (state-lctx (protostep-s1 thing)))))]))]
['expected-sequence expected])
(compare-step-sequences actual expected)))
@@ -137,23 +142,29 @@
[else 'ok]))
(define (compare-steps actual expected)
- (cond [(eq? expected 'error)
- (check-pred misstep? actual)]
- [else
- (let ([e-tag (car expected)]
- [e-form (cadr expected)]
- [e-locals (cddr expected)]
- [lctx-terms (map bigframe-term (state-lctx (protostep-s1 actual)))])
- (check-pred step? actual)
- (check-eq? (protostep-type actual) e-tag)
- (check-equal-syntax? (syntax->datum (step-term2 actual))
- e-form)
- (check-equal? (length lctx-terms) (length e-locals)
- "Wrong number of context frames")
- (for ([lctx-term lctx-terms] [e-local e-locals])
- (check-equal-syntax? (syntax->datum lctx-term)
- e-local
- "Context frame")))]))
+ (match expected
+ ['error
+ (check-pred misstep? actual)]
+ [(list 'remark e-tag e-forms ...)
+ (check-pred remarkstep? actual)
+ (check-eq? (protostep-type actual) e-tag "Remark step type")
+ (let ([contents (filter syntax? (remarkstep-contents actual))])
+ (check-equal? (length contents) (length e-forms)
+ "Wrong number of syntaxes in remark")
+ (for ([astx contents] [e-form e-forms])
+ (check-equal-syntax? (syntax->datum astx) e-form "Syntax in remark")))]
+ [(list e-tag e-form e-locals ...)
+ (let ([lctx-terms (map bigframe-term (state-lctx (protostep-s1 actual)))])
+ (check-pred step? actual)
+ (check-eq? (protostep-type actual) e-tag)
+ (check-equal-syntax? (syntax->datum (step-term2 actual))
+ e-form)
+ (check-equal? (length lctx-terms) (length e-locals)
+ "Wrong number of context frames")
+ (for ([lctx-term lctx-terms] [e-local e-locals])
+ (check-equal-syntax? (syntax->datum lctx-term)
+ e-local
+ "Context frame")))]))
(define-binary-check (check-equal-syntax? a e)
(equal-syntax? a e))
diff --git a/collects/tests/macro-debugger/tests/hiding.rkt b/collects/tests/macro-debugger/tests/hiding.rkt
@@ -58,7 +58,8 @@
(test-trivial-hiding/id (lambda (x y) x y))
(test-trivial-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
- (test-trivial-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
+ (test-trivial-hiding (lambda (x y z) x (begin y z))
+ (lambda (x y z) x y z))
(test-trivial-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-trivial-hiding (lambda (x) (begin (define-values (y) x)) y)
@@ -125,7 +126,8 @@
(test-T-hiding/id (lambda (x y) x y))
(test-T-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
- (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
+ (test-T-hiding (lambda (x y z) x (begin y z))
+ (lambda (x y z) x y z))
(test-T-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x)) y)
diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/collects/tests/macro-debugger/tests/syntax-basic.rkt
@@ -140,28 +140,32 @@
[#: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)))
+ [#:steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (macro (#%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)))])
+ [#:hidden-steps
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body '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)))
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (macro (#%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)))])
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body '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)))
+ (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))
+ (macro (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
(macro (letrec-values ([(x) 'a]) 'b))])]
[#:suite
@@ -208,13 +212,15 @@
(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)]
+ #:same-hidden-steps)
+ |#]
[#:suite
"Top-level begin"
diff --git a/collects/tests/macro-debugger/tests/syntax-errors.rkt b/collects/tests/macro-debugger/tests/syntax-errors.rkt
@@ -216,14 +216,16 @@
'd)
[#:steps (block->letrec (#%stratified-body
(letrec-values ([(x) 'a])
- 'b
- (define-values (y) 'c)
- 'd)))
+ (#%stratified-body
+ 'b
+ (define-values (y) 'c)
+ 'd))))
(rename-letrec-values (#%stratified-body
(letrec-values ([(x) 'a])
- 'b
- (define-values (y) 'c)
- 'd)))
+ (#%stratified-body
+ 'b
+ (define-values (y) 'c)
+ 'd))))
error])
(testKE (#%stratified-body (define-values (x) 'a))
[#:steps error])]
diff --git a/collects/tests/macro-debugger/tests/syntax-macros.rkt b/collects/tests/macro-debugger/tests/syntax-macros.rkt
@@ -44,7 +44,7 @@
(test "lift"
(lift 'a)
- [#:steps (local-lift (#rx"^lifted") (lift 'a))
+ [#:steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
@@ -53,7 +53,7 @@
#:no-hidden-steps)
(test "lift with id"
(lift (id 'a))
- [#:steps (local-lift (#rx"^lifted") (lift (id 'a)))
+ [#:steps (remark local-lift (id 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
@@ -64,52 +64,56 @@
(test "lift with Tid"
(lift (Tid 'a))
- [#:steps (local-lift (#rx"^lifted") (lift (Tid 'a)))
+ [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
- ;; Don't show lifts, but do find (Tid 'a), show in orig ctx
- [#:hidden-steps (macro (lift 'a))])
+ ;; FIXME:
+ ;; maybe don't show lifts, but do find (Tid 'a), show in orig ctx
+ ;; but maybe not a good idea
+ #|
+ [#:hidden-steps (macro (lift 'a))]
+ |#)
(test "Tlift"
(Tlift 'a)
- [#:steps (local-lift (#rx"^lifted") (Tlift 'a))
+ [#:steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
- [#:hidden-steps (local-lift (#rx"^lifted") (Tlift 'a))
+ [#:hidden-steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression #rx"^lifted")))])
(test "Tlift with id"
(Tlift (id 'a))
- [#:steps (local-lift (#rx"^lifted") (Tlift (id 'a)))
+ [#:steps (remark local-lift (id 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
- [#:hidden-steps (local-lift (#rx"^lifted") (Tlift (id 'a)))
+ [#:hidden-steps (remark local-lift (id 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression #rx"^lifted")))])
(test "Tlift with Tid"
(Tlift (Tid 'a))
- [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a)))
+ [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
- [#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a)))
+ [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression #rx"^lifted")))
