commit ff83df9eb1bcca29df6d216279381aecec08254c
parent 8baedfcf1d8c12aa9806b18672de5d0e3553b1d3
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 3 Jan 2009 19:58:06 +0000
macro stepper tests:
added regression test for PR 10000
updated lifting tests for new variable name convention
svn: r12994
original commit: b6312ff3ca2765dcb132f5e740803e2dcdd6edfa
Diffstat:
4 files changed, 98 insertions(+), 72 deletions(-)
diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss
@@ -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 (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-binary-check (check-equal-syntax? a e)
+ (equal-syntax? a e))
+
+(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)]))
diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss
@@ -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?))
diff --git a/collects/tests/macro-debugger/tests/regression.ss b/collects/tests/macro-debugger/tests/regression.ss
@@ -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)))))))
+ ))
diff --git a/collects/tests/macro-debugger/tests/syntax-macros.ss b/collects/tests/macro-debugger/tests/syntax-macros.ss
@@ -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)"
