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

macro stepper tests:

Browse Source 
added regression test for PR 10000
  updated lifting tests for new variable name convention

svn: r12994

original commit: b6312ff3ca2765dcb132f5e740803e2dcdd6edfa
This commit is contained in:
Ryan Culpepper 2009-01-03 19:58:06 +00:00
parent 8baedfcf1d
commit ff83df9eb1
4 changed files with 97 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/tests/macro-debugger/gentests.ss
View File

@ -101,15 +101,15 @@
(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)
(compare-step-sequences expected actual)) (compare-step-sequences actual expected))
(define (reduction-sequence? rs) (define (reduction-sequence? rs)
(andmap protostep? rs)) (andmap protostep? rs))
(define (compare-step-sequences expected actual) (define (compare-step-sequences actual expected)
(cond [(and (pair? expected) (pair? actual)) (cond [(and (pair? expected) (pair? actual))
(begin (compare-steps (car expected) (car actual)) (begin (compare-steps (car actual) (car expected))
(compare-step-sequences (cdr expected) (cdr actual)))] (compare-step-sequences (cdr actual) (cdr expected)))]
[(pair? expected) [(pair? expected)
(fail (format "missing expected steps:\n~s" expected))] (fail (format "missing expected steps:\n~s" expected))]
[(pair? actual) [(pair? actual)
@ -121,7 +121,7 @@
(stx->datum (step-term2 step)))))))] (stx->datum (step-term2 step)))))))]
[else 'ok])) [else 'ok]))
(define (compare-steps expected actual) (define (compare-steps actual expected)
(cond [(eq? expected 'error) (cond [(eq? expected 'error)
(check-pred misstep? actual)] (check-pred misstep? actual)]
[else [else
@ -140,14 +140,16 @@
e-local e-local
"Context frame")))])) "Context frame")))]))
(define-binary-check (check-equal-syntax? a b) (define-binary-check (check-equal-syntax? a e)
(equal-syntax? a b)) (equal-syntax? a e))
(define (equal-syntax? a b) (define (equal-syntax? a e)
(cond [(and (pair? a) (pair? b)) (cond [(and (pair? a) (pair? e))
(and (equal-syntax? (car a) (car b)) (and (equal-syntax? (car a) (car e))
(equal-syntax? (cdr a) (cdr b)))] (equal-syntax? (cdr a) (cdr e)))]
[(and (symbol? a) (symbol? b)) [(and (symbol? a) (symbol? e))
(equal? (string->symbol (symbol->string a)) (equal? (symbol->string a)
b)] (symbol->string e))]
[else (equal? a b)])) [(and (symbol? a) (regexp? e))
(regexp-match? e (symbol->string a))]
[else (equal? a e)]))

8
collects/tests/macro-debugger/tests/policy.ss
View File

@ -10,11 +10,13 @@
(eval '(require (prefix-in base: scheme/base)) ns) (eval '(require (prefix-in base: scheme/base)) ns)
(eval '(require (prefix-in scheme: scheme)) ns) (eval '(require (prefix-in scheme: scheme)) ns)
(define (make-test-id sym)
(parameterize ((current-namespace ns))
(namespace-symbol->identifier sym)))
(define-syntax-rule (test-policy policy name show?) (define-syntax-rule (test-policy policy name show?)
(test-case (format "~s" 'name) (test-case (format "~s" 'name)
(check-eq? (policy (check-eq? (policy (make-test-id 'name))
(parameterize ((current-namespace ns))
(namespace-symbol->identifier 'name)))
show?))) show?)))
(define-syntax-rule (test-standard name show?) (define-syntax-rule (test-standard name show?)
(test-policy standard-policy name show?)) (test-policy standard-policy name show?))

23
collects/tests/macro-debugger/tests/regression.ss
View File

@ -167,4 +167,25 @@
(add1 (g 2))))))]) (add1 (g 2))))))])
(check-pred list? rs) (check-pred list? rs)
(check-true (ormap misstep? rs)))) (check-true (ormap misstep? rs))))
))
;; Added 1/3/2008
;; Based on PR 10000
(test-case "eval within module expansion"
(let ([freshname (gensym)])
(eval `(module ,freshname scheme
(provide meval)
(define-syntax (meval stx)
(syntax-case stx ()
[(meval e)
(parameterize ((current-namespace (make-base-namespace)))
(eval `(define one '1))
(let ([v (eval `(+ 1 ,#'e))])
#`(quote #,v)))]))))
(eval `(require ',freshname))
(check-pred deriv?
(trace `(meval (+ 1 2))))
(check-pred deriv?
(trace `(module m mzscheme
(require ',freshname)
(meval (+ 1 2)))))))
))

105
collects/tests/macro-debugger/tests/syntax-macros.ss
View File

@ -44,76 +44,77 @@
(test "lift" (test "lift"
(lift 'a) (lift 'a)
[#:steps (local-lift lifted (lift 'a)) [#:steps (local-lift #rx"^lifted" (lift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression
(#%top . #rx"^lifted"))))]
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with id" (test "lift with id"
(lift (id 'a)) (lift (id 'a))
[#:steps (local-lift lifted (lift (id 'a))) [#:steps (local-lift #rx"^lifted" (lift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with Tid" (test "lift with Tid"
(lift (Tid 'a)) (lift (Tid 'a))
[#:steps (local-lift lifted (lift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (lift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
;; Don't show lifts, but do find (Tid 'a), show in orig ctx ;; Don't show lifts, but do find (Tid 'a), show in orig ctx
[#:hidden-steps (macro (lift 'a))]) [#:hidden-steps (macro (lift 'a))])
(test "Tlift" (test "Tlift"
(Tlift 'a) (Tlift 'a)
[#:steps (local-lift lifted (Tlift 'a)) [#:steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift lifted (Tlift 'a)) [#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
(test "Tlift with id" (test "Tlift with id"
(Tlift (id 'a)) (Tlift (id 'a))
[#:steps (local-lift lifted (Tlift (id 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift lifted (Tlift (id 'a))) [#:hidden-steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
(test "Tlift with Tid" (test "Tlift with Tid"
(Tlift (Tid 'a)) (Tlift (Tid 'a))
[#:steps (local-lift lifted (Tlift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:steps (local-lift lifted (Tlift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression lifted))) (#%expression #rx"^lifted")))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
[#:suite "set! macros" [#:suite "set! macros"
(test "set! (macro)" (test "set! (macro)"