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)]
[Block ?body bderiv]
[#:pass2]
[#:hide-check rs]
[#:pattern ?form]
[#:walk e2 'macro])]

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

@ -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
(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)))))))]
(map bigframe-term (state-lctx (protostep-s1 thing)))))]))]
['expected-sequence expected])
(compare-step-sequences actual expected)))
@ -137,13 +142,19 @@
[else 'ok]))
(define (compare-steps actual expected)
(cond [(eq? expected 'error)
(match 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)))])
[(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))

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 (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)

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

@ -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"

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

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

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

@ -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")))