macro stepper tests:
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
parent
8baedfcf1d
commit
ff83df9eb1
|
|
@ -101,15 +101,15 @@
|
|||
(define (check-steps expected actual)
|
||||
(check-pred list? actual)
|
||||
(check-pred reduction-sequence? actual)
|
||||
(compare-step-sequences expected actual))
|
||||
(compare-step-sequences actual expected))
|
||||
|
||||
(define (reduction-sequence? rs)
|
||||
(andmap protostep? rs))
|
||||
|
||||
(define (compare-step-sequences expected actual)
|
||||
(define (compare-step-sequences actual expected)
|
||||
(cond [(and (pair? expected) (pair? actual))
|
||||
(begin (compare-steps (car expected) (car actual))
|
||||
(compare-step-sequences (cdr expected) (cdr actual)))]
|
||||
(begin (compare-steps (car actual) (car expected))
|
||||
(compare-step-sequences (cdr actual) (cdr expected)))]
|
||||
[(pair? expected)
|
||||
(fail (format "missing expected steps:\n~s" expected))]
|
||||
[(pair? actual)
|
||||
|
|
@ -121,7 +121,7 @@
|
|||
(stx->datum (step-term2 step)))))))]
|
||||
[else 'ok]))
|
||||
|
||||
(define (compare-steps expected actual)
|
||||
(define (compare-steps actual expected)
|
||||
(cond [(eq? expected 'error)
|
||||
(check-pred misstep? actual)]
|
||||
[else
|
||||
|
|
@ -140,14 +140,16 @@
|
|||
e-local
|
||||
"Context frame")))]))
|
||||
|
||||
(define-binary-check (check-equal-syntax? a b)
|
||||
(equal-syntax? a b))
|
||||
(define-binary-check (check-equal-syntax? a e)
|
||||
(equal-syntax? a e))
|
||||
|
||||
(define (equal-syntax? a b)
|
||||
(cond [(and (pair? a) (pair? b))
|
||||
(and (equal-syntax? (car a) (car b))
|
||||
(equal-syntax? (cdr a) (cdr b)))]
|
||||
[(and (symbol? a) (symbol? b))
|
||||
(equal? (string->symbol (symbol->string a))
|
||||
b)]
|
||||
[else (equal? a b)]))
|
||||
(define (equal-syntax? a e)
|
||||
(cond [(and (pair? a) (pair? e))
|
||||
(and (equal-syntax? (car a) (car e))
|
||||
(equal-syntax? (cdr a) (cdr e)))]
|
||||
[(and (symbol? a) (symbol? e))
|
||||
(equal? (symbol->string a)
|
||||
(symbol->string e))]
|
||||
[(and (symbol? a) (regexp? e))
|
||||
(regexp-match? e (symbol->string a))]
|
||||
[else (equal? a e)]))
|
||||
|
|
|
|||
|
|
@ -10,11 +10,13 @@
|
|||
(eval '(require (prefix-in base: scheme/base)) 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?)
|
||||
(test-case (format "~s" 'name)
|
||||
(check-eq? (policy
|
||||
(parameterize ((current-namespace ns))
|
||||
(namespace-symbol->identifier 'name)))
|
||||
(check-eq? (policy (make-test-id 'name))
|
||||
show?)))
|
||||
(define-syntax-rule (test-standard name show?)
|
||||
(test-policy standard-policy name show?))
|
||||
|
|
|
|||
|
|
@ -167,4 +167,25 @@
|
|||
(add1 (g 2))))))])
|
||||
(check-pred list? 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)))))))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -44,76 +44,77 @@
|
|||
|
||||
(test "lift"
|
||||
(lift 'a)
|
||||
[#:steps (local-lift lifted (lift 'a))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:steps (local-lift #rx"^lifted" (lift 'a))
|
||||
(macro (#%expression #rx"^lifted"))
|
||||
(tag-top (#%expression (#%top . #rx"^lifted")))
|
||||
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
|
||||
(#%expression
|
||||
(#%top . #rx"^lifted"))))]
|
||||
#:no-hidden-steps)
|
||||
(test "lift with id"
|
||||
(lift (id 'a))
|
||||
[#:steps (local-lift lifted (lift (id 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) (id 'a))
|
||||
(#%expression (#%top . lifted))))
|
||||
(macro (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:steps (local-lift #rx"^lifted" (lift (id 'a)))
|
||||
(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"))))]
|
||||
#:no-hidden-steps)
|
||||
|
||||
(test "lift with Tid"
|
||||
(lift (Tid 'a))
|
||||
[#:steps (local-lift lifted (lift (Tid 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) (Tid 'a))
|
||||
(#%expression (#%top . lifted))))
|
||||
(macro (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:steps (local-lift #rx"^lifted" (lift (Tid 'a)))
|
||||
(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))])
|
||||
|
||||
(test "Tlift"
|
||||
(Tlift 'a)
|
||||
[#:steps (local-lift lifted (Tlift 'a))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:hidden-steps (local-lift lifted (Tlift 'a))
|
||||
(macro (#%expression lifted))
|
||||
(capture-lifts (begin (define-values (lifted) 'a)
|
||||
(#%expression lifted)))])
|
||||
[#:steps (local-lift #rx"^lifted" (Tlift 'a))
|
||||
(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))
|
||||
(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 lifted (Tlift (id 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) (id 'a))
|
||||
(#%expression (#%top . lifted))))
|
||||
(macro (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:hidden-steps (local-lift lifted (Tlift (id 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(capture-lifts (begin (define-values (lifted) (id 'a))
|
||||
(#%expression lifted)))])
|
||||
[#:steps (local-lift #rx"^lifted" (Tlift (id 'a)))
|
||||
(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)))
|
||||
(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 lifted (Tlift (Tid 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(tag-top (#%expression (#%top . lifted)))
|
||||
(capture-lifts (begin (define-values (lifted) (Tid 'a))
|
||||
(#%expression (#%top . lifted))))
|
||||
(macro (begin (define-values (lifted) 'a)
|
||||
(#%expression (#%top . lifted))))]
|
||||
[#:steps (local-lift lifted (Tlift (Tid 'a)))
|
||||
(macro (#%expression lifted))
|
||||
(capture-lifts (begin (define-values (lifted) (Tid 'a))
|
||||
(#%expression lifted)))
|
||||
(macro (begin (define-values (lifted) 'a)
|
||||
(#%expression lifted)))])
|
||||
[#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
|
||||
(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)))
|
||||
(macro (#%expression #rx"^lifted"))
|
||||
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
|
||||
(#%expression #rx"^lifted")))
|
||||
(macro (begin (define-values (#rx"^lifted") 'a)
|
||||
(#%expression #rx"^lifted")))])
|
||||
|
||||
[#:suite "set! macros"
|
||||
(test "set! (macro)"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user