diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index 638b280cc3..4474909648 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -1,7 +1,8 @@ #lang scheme (require "through-tests.ss" - "test-engine.ss") + "test-engine.ss" + test-engine/racket-tests) (let ((outer-namespace (current-namespace))) (parameterize ([display-only-errors #t] @@ -9,6 +10,7 @@ [current-namespace (make-base-namespace)]) ;; make sure the tests' print-convert sees the teaching languages' properties (namespace-attach-module outer-namespace 'mzlib/pconvert-prop (current-namespace)) + (namespace-require 'test-engine/racket-tests) (if (run-all-tests-except '(bad-and bad-cons check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3 local-struct/i local-struct/ilam)) (exit 0) diff --git a/collects/tests/stepper/test-engine.rkt b/collects/tests/stepper/test-engine.rkt index 7ae23940f2..cc221f1509 100644 --- a/collects/tests/stepper/test-engine.rkt +++ b/collects/tests/stepper/test-engine.rkt @@ -183,14 +183,20 @@ (error-display-handler current-error-display-handler))) ;; call-iter-on-each : (-> syntax?) (syntax? (-> 'a) -> 'a) -> void/c -;; call the given iter on each syntax in turn (iter bounces control) -;; back to us by calling the followup-thunk. +;; call the given iter on each syntax in turn (iter bounces control +;; back to us by calling the followup-thunk). (define (call-iter-on-each stx-thunk iter) - (let* ([next (stx-thunk)] - [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))] - [expanded (expand next)]) - ;;(printf "~v\n" expanded) - (iter expanded followup-thunk))) + (parameterize ([current-namespace (make-base-empty-namespace)]) + (namespace-require 'racket/base) + (namespace-require 'test-engine/racket-tests) + ;; make the test engine happy by adding a binding for test~object: + (namespace-set-variable-value! 'test~object #f) + (let iter-loop () + (let* ([next (stx-thunk)] + [followup-thunk (if (eof-object? next) void iter-loop)] + [expanded (expand next)]) + ;;(printf "~v\n" expanded) + (iter expanded followup-thunk))))) (define (warn error-box who fmt . args) diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index c0086856ca..9d31565cdb 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -14,7 +14,7 @@ ) -(provide run-test run-tests run-all-tests run-all-tests-except) +(provide run-test run-tests/s run-all-tests run-all-tests-except) (define list-of-tests null) @@ -57,7 +57,7 @@ (run-one-test/helper maybe-test) (error 'run-test "test not found: ~.s" name)))) -(define (run-tests names) +(define (run-tests/s names) (ormap/no-shortcut run-test names)) @@ -68,12 +68,7 @@ (define (andmap/no-shortcut f args) (foldl (lambda (a b) (and a b)) #t (map f args))) -(t 'mz1 m:mz - (for-each (lambda (x) x) '(1 2 3)) - :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) - :: ... -> (... {2} ...) - :: ... -> (... {3} ...) - :: ... -> {(void)}) + ;; new test case language: ;; an expected is (listof step) @@ -105,17 +100,12 @@ ;; * a `finished-stepping' is added if no error was specified ;; * a `{...}' is replaced with `(hilite ...)' -(t 'mz-app m:mz - (+ 3 4) - :: {(+ 3 4)} -> {7}) - -(t 'mz-app2 m:mz - ((lambda (x) (+ x 3)) 4) - :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) - -(t 'mz-if m:mz - (if 3 4 5) - :: {(if 3 4 5)} -> {4}) + (t 'mz1 m:mz + (for-each (lambda (x) x) '(1 2 3)) + :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) + :: ... -> (... {2} ...) + :: ... -> (... {3} ...) + :: ... -> {(void)}) (t 'simple-if m:upto-int/lam (if true false true) @@ -126,44 +116,6 @@ :: (if {(if true false true)} false true) -> (if {false} false true) :: {(if false false true)} -> {true}) -(t 'direct-app m:mz - ((lambda (x) x) 3) - :: {((lambda (x) x) 3)} -> {3}) - -; (m:mz "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" -; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) -; ((begin (hilite 7) (+ 4 5)))) -; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) -; (before-after ((hilite (+ 4 5))) ((hilite 9))) -; (finished-stepping))) - -(t 'curried m:mz - ((lambda (a) (lambda (b) (+ a b))) 14) - :: {((lambda (a) (lambda (b) (+ a b))) 14)} - -> {(lambda (b) (+ 14 b))}) - -(t 'case-lambda m:mz - ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) - :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} - -> {(+ 5 6)} - -> {11}) - -;; not really a part of base mzscheme anymore -#;(t '2armed-if m:mz - (if 3 4) - :: {(if 3 4)} -> {4}) - -;(m:mz "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" -; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) -; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) -; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) -; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) - -;(m:mz '(begin (define g 3) g) -; `((before-after ((hilite ,h-p)) (g) -; ((hilite ,h-p)) 3))) - -;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) (t 'top-def m:upto-int/lam (define a (+ 3 4)) @@ -1464,8 +1416,69 @@ -> (define (f x) (local ((define-struct a (b c))) x)) {(define-struct a_1 (b c))} {1}) - + ;; oh dear heavens; putting these tests early on seems to "mess up" the namespace + ;; so that test~object can't be seen by the teaching-language tests. This is almost + ;; certainly the stepper test framework doing something stupid. + #;(t 'mz1 m:mz + (for-each (lambda (x) x) '(1 2 3)) + :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) + :: ... -> (... {2} ...) + :: ... -> (... {3} ...) + :: ... -> {(void)}) + +(t 'mz-app m:mz + (+ 3 4) + :: {(+ 3 4)} -> {7}) + +(t 'mz-app2 m:mz + ((lambda (x) (+ x 3)) 4) + :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) + +(t 'mz-if m:mz + (if 3 4 5) + :: {(if 3 4 5)} -> {4}) + +(t 'direct-app m:mz + ((lambda (x) x) 3) + :: {((lambda (x) x) 3)} -> {3}) + +; (m:mz "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" +; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) +; ((begin (hilite 7) (+ 4 5)))) +; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) +; (before-after ((hilite (+ 4 5))) ((hilite 9))) +; (finished-stepping))) + +(t 'curried m:mz + ((lambda (a) (lambda (b) (+ a b))) 14) + :: {((lambda (a) (lambda (b) (+ a b))) 14)} + -> {(lambda (b) (+ 14 b))}) + +(t 'case-lambda m:mz + ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) + :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} + -> {(+ 5 6)} + -> {11}) + +;; not really a part of base mzscheme anymore +#;(t '2armed-if m:mz + (if 3 4) + :: {(if 3 4)} -> {4}) + +;(m:mz "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" +; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) +; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) +; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) +; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) + +;(m:mz '(begin (define g 3) g) +; `((before-after ((hilite ,h-p)) (g) +; ((hilite ,h-p)) 3))) + +;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) + + ;; run whatever tests are enabled (intended for interactive use): (define (ggg) (parameterize (#;[disable-stepper-error-handling #t] @@ -1474,8 +1487,8 @@ #;[show-all-steps #t]) #;(run-tests '(check-expect forward-ref check-within check-within-bad check-error check-error-bad)) #;(run-tests '(teachpack-universe)) - (run-tests '(local-struct/i local-struct/ilam)) - #;(run-all-tests))) + (run-all-tests) + #;(run-test 'simple-if)))