From e36c964a9aa963e1069818f98f526d266dac644d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 12 Jul 2010 17:19:55 -0600 Subject: [PATCH] macro-stepper: updated tests --- collects/macro-debugger/model/reductions.rkt | 1 + collects/tests/macro-debugger/gentests.rkt | 59 +++++++++++-------- .../tests/macro-debugger/tests/hiding.rkt | 6 +- .../macro-debugger/tests/syntax-basic.rkt | 28 +++++---- .../macro-debugger/tests/syntax-errors.rkt | 14 +++-- .../macro-debugger/tests/syntax-macros.rkt | 26 ++++---- 6 files changed, 80 insertions(+), 54 deletions(-) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 34f23c0fa3..3f04bf1f70 100644 --- 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 index dad2542688..add1446b42 100644 --- 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 index 376bbfa2f0..41780be436 100644 --- 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 index f5a95a6917..6e113c044c 100644 --- 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 index 1ddb4e11a6..d51bfc3fbd 100644 --- 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 index fc7c263c21..8837463a1e 100644 --- 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")))