From 5f7993c6db978d502e3f393557d4e8a43b3fd7a7 Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 19 Oct 2010 17:42:11 -0700 Subject: [PATCH] looks like a fix for cond (cherry picked from commit 0536d52efd294638a06ad29e2e92027d777cd78b) --- collects/tests/stepper/automatic-tests.rkt | 3 +- collects/tests/stepper/test-engine.rkt | 21 ---- collects/tests/stepper/through-tests.rkt | 129 +++++++++------------ 3 files changed, 58 insertions(+), 95 deletions(-) diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index 4474909648..b7327a177d 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -1,8 +1,7 @@ #lang scheme (require "through-tests.ss" - "test-engine.ss" - test-engine/racket-tests) + "test-engine.ss") (let ((outer-namespace (current-namespace))) (parameterize ([display-only-errors #t] diff --git a/collects/tests/stepper/test-engine.rkt b/collects/tests/stepper/test-engine.rkt index cc221f1509..8757dbca38 100644 --- a/collects/tests/stepper/test-engine.rkt +++ b/collects/tests/stepper/test-engine.rkt @@ -6,7 +6,6 @@ lang/run-teaching-program (only-in srfi/13 string-contains) scheme/contract - #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") "language-level-model.ss") @@ -93,11 +92,6 @@ ;; run the named test, return #t if a failure occurred during the test. -;; WARNING: evaluating code expanded using run-teaching-program causes mutation of the -;; current namespace. Unfortunately, wrapping a parameterize around each test (i.e., in this -;; file) causes unacceptable slowdown and severe weirdness. I tried saving and restoring -;; the namespace through mutation, and got severe weirdness again. - (define (run-one-test name models exp-str expected-steps) (unless (display-only-errors) (printf "running test: ~v\n" name)) @@ -270,20 +264,5 @@ -;; DEBUGGING TO TRY TO FIND OUT WHY THIS DOESN'T WORK IN AN AUTOMATED TESTER: -;; test-sequence : ll-model? string? steps? -> (void) -;; given a language model and an expression and a sequence of steps, -;; check to see whether the stepper produces the desired steps -;;define (test-sequence the-ll-model exp-str expected-steps error-box) -#;(match mz - [(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) - (let* ([p2 (open-input-string "134")] - [module-id (gensym "stepper-module-name-")] - ;; thunk this so that syntax errors happen within the error handlers: - [expanded-thunk - (lambda () (expand-teaching-program p2 read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))]) - (display (expanded-thunk)) - (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk '() (box #f)))]) - diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index 9d31565cdb..9f1b29a3ca 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -14,7 +14,7 @@ ) -(provide run-test run-tests/s run-all-tests run-all-tests-except) +(provide run-test run-tests 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/s names) +(define (run-tests names) (ormap/no-shortcut run-test names)) @@ -107,6 +107,59 @@ :: ... -> (... {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)))) + + + (t 'simple-if m:upto-int/lam (if true false true) :: {(if true false true)} -> {false}) @@ -1416,69 +1469,7 @@ -> (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] @@ -1488,10 +1479,4 @@ #;(run-tests '(check-expect forward-ref check-within check-within-bad check-error check-error-bad)) #;(run-tests '(teachpack-universe)) (run-all-tests) - #;(run-test 'simple-if))) - - - - - - + #;(run-tests '(cond1))))