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

looks like a fix for cond

Browse Source
This commit is contained in:
John Clements 2010-10-19 17:42:11 -07:00
parent 20b596b8f2
commit 0536d52efd
3 changed files with 58 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/tests/stepper/automatic-tests.rkt
View File

@ -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]

21
collects/tests/stepper/test-engine.rkt
View File

@ -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)))])

129
collects/tests/stepper/through-tests.rkt
View File

@ -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))))