suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro-stepper: updated tests

Browse Source
This commit is contained in:
Ryan Culpepper 2010-07-12 17:19:55 -06:00
parent b8bf5c571a
commit e36c964a9a
6 changed files with 80 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/macro-debugger/model/reductions.rkt
View File

@ -235,6 +235,7 @@
[#:pattern (?sb . ?body)] [#:pattern (?sb . ?body)]
[Block ?body bderiv] [Block ?body bderiv]
[#:pass2] [#:pass2]
[#:hide-check rs]
[#:pattern ?form] [#:pattern ?form]
[#:walk e2 'macro])] [#:walk e2 'macro])]

31
collects/tests/macro-debugger/gentests.rkt
View File

@ -106,15 +106,20 @@
(define (check-steps expected actual) (define (check-steps expected actual)
(check-pred list? actual) (check-pred list? actual)
(check-pred reduction-sequence? actual) (check-pred reduction-sequence? actual)
(with-check-info (['actual-sequence-raw actual] (with-check-info (;;['actual-sequence-raw actual]
['actual-sequence ['actual-sequence
(for/list ([thing actual]) (for/list ([thing actual])
(if (misstep? thing) (cond [(misstep? thing)
'error 'error]
[(remarkstep? thing)
(list* 'remark
(protostep-type thing)
(map syntax->datum (filter syntax? (remarkstep-contents thing))))]
[else
(list* (protostep-type thing) (list* (protostep-type thing)
(syntax->datum (step-term2 thing)) (syntax->datum (step-term2 thing))
(map syntax->datum (map syntax->datum
(map bigframe-term (state-lctx (protostep-s1 thing)))))))] (map bigframe-term (state-lctx (protostep-s1 thing)))))]))]
['expected-sequence expected]) ['expected-sequence expected])
(compare-step-sequences actual expected))) (compare-step-sequences actual expected)))
@ -137,13 +142,19 @@
[else 'ok])) [else 'ok]))
(define (compare-steps actual expected) (define (compare-steps actual expected)
(cond [(eq? expected 'error) (match expected
['error
(check-pred misstep? actual)] (check-pred misstep? actual)]
[else [(list 'remark e-tag e-forms ...)
(let ([e-tag (car expected)] (check-pred remarkstep? actual)
[e-form (cadr expected)] (check-eq? (protostep-type actual) e-tag "Remark step type")
[e-locals (cddr expected)] (let ([contents (filter syntax? (remarkstep-contents actual))])
[lctx-terms (map bigframe-term (state-lctx (protostep-s1 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-pred step? actual)
(check-eq? (protostep-type actual) e-tag) (check-eq? (protostep-type actual) e-tag)
(check-equal-syntax? (syntax->datum (step-term2 actual)) (check-equal-syntax? (syntax->datum (step-term2 actual))

6
collects/tests/macro-debugger/tests/hiding.rkt
View File

@ -58,7 +58,8 @@
(test-trivial-hiding/id (lambda (x y) x y)) (test-trivial-hiding/id (lambda (x y) x y))
(test-trivial-hiding (lambda (x y z) (begin x y) z) (test-trivial-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) 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) (test-trivial-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y))) (lambda (x) (letrec-values ([(y) x]) y)))
(test-trivial-hiding (lambda (x) (begin (define-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/id (lambda (x y) x y))
(test-T-hiding (lambda (x y z) (begin x y) z) (test-T-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) 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) (test-T-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y))) (lambda (x) (letrec-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x)) y) (test-T-hiding (lambda (x) (begin (define-values (y) x)) y)

28
collects/tests/macro-debugger/tests/syntax-basic.rkt
View File

@ -140,28 +140,32 @@
[#:hidden-steps (splice-block (#%stratified-body 'a 'b))]) [#:hidden-steps (splice-block (#%stratified-body 'a 'b))])
(testK "internal define-values" (testK "internal define-values"
(#%stratified-body (define-values (x) 'a) 'b) (#%stratified-body (define-values (x) 'a) 'b)
[#:steps (block->letrec (#%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]) '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))] (macro (letrec-values ([(x) 'a]) 'b))]
[#:hidden-steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b))) [#:hidden-steps
(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 define-values in begin" (testK "internal define-values in begin"
(#%stratified-body (begin (define-values (x) 'a)) 'b) (#%stratified-body (begin (define-values (x) 'a)) 'b)
[#:steps [#:steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b)) (splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%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]) '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))] (macro (letrec-values ([(x) 'a]) 'b))]
[#:hidden-steps [#:hidden-steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b)) (splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%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]) 'b)))]) (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) (#%stratified-body 'b))))])
(testK "internal begin, then define-values" (testK "internal begin, then define-values"
(#%stratified-body (begin) (define-values (x) 'a) 'b) (#%stratified-body (begin) (define-values (x) 'a) 'b)
[#:steps [#:steps
(splice-block (#%stratified-body (define-values (x) 'a) 'b)) (splice-block (#%stratified-body (define-values (x) 'a) 'b))
(block->letrec (#%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]) '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))])] (macro (letrec-values ([(x) 'a]) 'b))])]
[#:suite [#:suite
@ -208,13 +212,15 @@
(block->letrec (lambda () (letrec-values ([(x) 'a]) 'b))) (block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
(rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))] (rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
#:same-hidden-steps) #:same-hidden-steps)
#|
(testK "define-values after expr" (testK "define-values after expr"
(lambda () 'a (define-values (x) 'b) 'c) (lambda () 'a (define-values (x) 'b) 'c)
[#:steps [#:steps
(rename-lambda (lambda () 'a (define-values (x) 'b) 'c)) (rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
(block->letrec (lambda () (letrec-values ([() (begin 'a (#%app 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)))] (rename-letrec-values (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))]
#:same-hidden-steps)] #:same-hidden-steps)
|#]
[#:suite [#:suite
"Top-level begin" "Top-level begin"

6
collects/tests/macro-debugger/tests/syntax-errors.rkt
View File

@ -216,14 +216,16 @@
'd) 'd)
[#:steps (block->letrec (#%stratified-body [#:steps (block->letrec (#%stratified-body
(letrec-values ([(x) 'a]) (letrec-values ([(x) 'a])
(#%stratified-body
'b 'b
(define-values (y) 'c) (define-values (y) 'c)
'd))) 'd))))
(rename-letrec-values (#%stratified-body (rename-letrec-values (#%stratified-body
(letrec-values ([(x) 'a]) (letrec-values ([(x) 'a])
(#%stratified-body
'b 'b
(define-values (y) 'c) (define-values (y) 'c)
'd))) 'd))))
error]) error])
(testKE (#%stratified-body (define-values (x) 'a)) (testKE (#%stratified-body (define-values (x) 'a))
[#:steps error])] [#:steps error])]

26
collects/tests/macro-debugger/tests/syntax-macros.rkt
View File

@ -44,7 +44,7 @@
(test "lift" (test "lift"
(lift 'a) (lift 'a)
[#:steps (local-lift (#rx"^lifted") (lift 'a)) [#:steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
@ -53,7 +53,7 @@
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with id" (test "lift with id"
(lift (id 'a)) (lift (id 'a))
[#:steps (local-lift (#rx"^lifted") (lift (id 'a))) [#:steps (remark local-lift (id 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
@ -64,52 +64,56 @@
(test "lift with Tid" (test "lift with Tid"
(lift (Tid 'a)) (lift (Tid 'a))
[#:steps (local-lift (#rx"^lifted") (lift (Tid 'a))) [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted")))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%expression (#%top . #rx"^lifted"))))]
;; Don't show lifts, but do find (Tid 'a), show in orig ctx ;; FIXME:
[#:hidden-steps (macro (lift 'a))]) ;; 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" (test "Tlift"
(Tlift 'a) (Tlift 'a)
[#:steps (local-lift (#rx"^lifted") (Tlift 'a)) [#:steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift (#rx"^lifted") (Tlift 'a)) [#:hidden-steps (remark local-lift 'a (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression #rx"^lifted")))]) (#%expression #rx"^lifted")))])
(test "Tlift with id" (test "Tlift with id"
(Tlift (id 'a)) (Tlift (id 'a))
[#:steps (local-lift (#rx"^lifted") (Tlift (id 'a))) [#:steps (remark local-lift (id 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . #rx"^lifted")))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%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")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression #rx"^lifted")))]) (#%expression #rx"^lifted")))])
(test "Tlift with Tid" (test "Tlift with Tid"
(Tlift (Tid 'a)) (Tlift (Tid 'a))
[#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a))) [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted"))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted")))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))] (#%expression (#%top . #rx"^lifted"))))]
[#:steps (local-lift (#rx"^lifted") (Tlift (Tid 'a))) [#:steps (remark local-lift (Tid 'a) (#rx"^lifted"))
(macro (#%expression #rx"^lifted")) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression #rx"^lifted"))) (#%expression #rx"^lifted")))