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

Upgrading to new version of schemeunit

Browse Source 
svn: r6300
This commit is contained in:
Jay McCarthy 2007-05-25 16:18:02 +00:00
parent ec053fad62
commit be9259d5ac
8 changed files with 244 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
collects/web-server/prototype-web-server/tests/anormal-test.ss
View File

@ -1,5 +1,5 @@
(module anormal-test mzscheme (module anormal-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"../lang/anormal.ss") "../lang/anormal.ss")
(provide anormal-tests) (provide anormal-tests)
@ -135,98 +135,98 @@
;; ACTUAL TESTS ;; ACTUAL TESTS
(define anormal-tests (define anormal-tests
(make-test-suite (test-suite
"Tests for Normalization Phase" "Tests for Normalization Phase"
(make-test-suite (test-suite
"Base Cases" "Base Cases"
(make-test-case (test-case
"Top level identifier" "Top level identifier"
(assert alpha= (normalize-term (expand (syntax car))) (check alpha= (normalize-term (expand (syntax car)))
(expand (syntax car)))) (expand (syntax car))))
(make-test-case (test-case
"Simple arithmetic expression" "Simple arithmetic expression"
(assert alpha= (normalize-term (expand (syntax (+ 1 1)))) (check alpha= (normalize-term (expand (syntax (+ 1 1))))
(expand (syntax (+ 1 1))))) (expand (syntax (+ 1 1)))))
(make-test-case (test-case
"lambda-expression with constant body" "lambda-expression with constant body"
(assert alpha= (normalize-term (expand (syntax (lambda (x) 3)))) (check alpha= (normalize-term (expand (syntax (lambda (x) 3))))
(expand (syntax (lambda (x) 3))))) (expand (syntax (lambda (x) 3)))))
(make-test-case (test-case
"lambda-expression with var-ref body" "lambda-expression with var-ref body"
(assert alpha= (normalize-term (expand (syntax (lambda (x) x)))) (check alpha= (normalize-term (expand (syntax (lambda (x) x))))
(expand (syntax (lambda (x) x))))) (expand (syntax (lambda (x) x)))))
(make-test-case (test-case
"lambda-expression/constant-body/multiple formals" "lambda-expression/constant-body/multiple formals"
(assert alpha= (normalize-term (expand (syntax (lambda (x y z) 3)))) (check alpha= (normalize-term (expand (syntax (lambda (x y z) 3))))
(expand (syntax (lambda (x y z) 3))))) (expand (syntax (lambda (x y z) 3)))))
(make-test-case (test-case
"one-armed-if" "one-armed-if"
(assert alpha= (normalize-term (expand (syntax (if #t 1)))) (check alpha= (normalize-term (expand (syntax (if #t 1))))
(expand (syntax (if #t 1 (void)))))) (expand (syntax (if #t 1 (void))))))
(make-test-case (test-case
"two-armed-if" "two-armed-if"
(assert alpha= (normalize-term (expand (syntax (if #t 1 2)))) (check alpha= (normalize-term (expand (syntax (if #t 1 2))))
(expand (syntax (if #t 1 2))))) (expand (syntax (if #t 1 2)))))
(make-test-case (test-case
"let/var-ref in body" "let/var-ref in body"
(assert alpha= (normalize-term (expand (syntax (let ([x 1]) x)))) (check alpha= (normalize-term (expand (syntax (let ([x 1]) x))))
(expand (syntax ((lambda (x) x) 1))))) (expand (syntax ((lambda (x) x) 1)))))
(make-test-case (test-case
"call to void" "call to void"
(assert alpha= (normalize-term (expand (syntax (void)))) (check alpha= (normalize-term (expand (syntax (void))))
(expand (syntax (void))))) (expand (syntax (void)))))
(make-test-case (test-case
"primitive application/multiple arguments" "primitive application/multiple arguments"
(assert alpha= (normalize-term (expand (syntax (+ 1 2 3)))) (check alpha= (normalize-term (expand (syntax (+ 1 2 3))))
(expand (syntax (+ 1 2 3))))) (expand (syntax (+ 1 2 3)))))
(make-test-case (test-case
"empty-list" "empty-list"
(assert alpha= (normalize-term (expand (syntax ()))) (check alpha= (normalize-term (expand (syntax ())))
(expand (syntax ())))) (expand (syntax ()))))
(make-test-case (test-case
"qoted list of constants" "qoted list of constants"
(assert alpha= (normalize-term (expand (syntax '(1 2 3)))) (check alpha= (normalize-term (expand (syntax '(1 2 3))))
(expand (syntax '(1 2 3)))))) (expand (syntax '(1 2 3))))))
(make-test-suite (test-suite
"Inductive Cases" "Inductive Cases"
(make-test-case (test-case
"nested primitive applications with multiple arguments" "nested primitive applications with multiple arguments"
(assert alpha= (normalize-term (expand (syntax (* (+ 1 2) 3)))) (check alpha= (normalize-term (expand (syntax (* (+ 1 2) 3))))
(expand (syntax ((lambda (x) (* x 3)) (+ 1 2)))))) (expand (syntax ((lambda (x) (* x 3)) (+ 1 2))))))
(make-test-case (test-case
"one-armed if with prim-app in test posn" "one-armed if with prim-app in test posn"
(assert alpha= (normalize-term (expand (syntax (if (+ 1 2) 3)))) (check alpha= (normalize-term (expand (syntax (if (+ 1 2) 3))))
(expand (syntax ((lambda (x) (if x 3 (void))) (+ 1 2)))))) (expand (syntax ((lambda (x) (if x 3 (void))) (+ 1 2))))))
(make-test-case (test-case
"two-armed if with prim-app in test posn" "two-armed if with prim-app in test posn"
(assert alpha= (normalize-term (expand (syntax (if (+ 1 2) 3 4)))) (check alpha= (normalize-term (expand (syntax (if (+ 1 2) 3 4))))
(expand (syntax ((lambda (x) (if x 3 4)) (+ 1 2)))))) (expand (syntax ((lambda (x) (if x 3 4)) (+ 1 2))))))
(make-test-case (test-case
"nested single argument primitive applications" "nested single argument primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ 1))))) (check alpha= (normalize-term (expand (syntax (* (+ 1)))))
(expand (syntax ((lambda (x0) (* x0)) (+ 1)))))) (expand (syntax ((lambda (x0) (* x0)) (+ 1))))))
(make-test-case (test-case
"deeply nested primitive applications" "deeply nested primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6))))) (check alpha= (normalize-term (expand (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6)))))
(expand (syntax ((lambda (x0) (expand (syntax ((lambda (x0)
((lambda (x1) ((lambda (x1)
((lambda (x2) ((lambda (x2)
@ -236,9 +236,9 @@
(+ x0 3))) (+ x0 3)))
(+ 1 2)))))) (+ 1 2))))))
(make-test-case (test-case
"deeply nested primitive applications" "deeply nested primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4))))))) (check alpha= (normalize-term (expand (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4)))))))
(expand (syntax ((lambda (x0) (expand (syntax ((lambda (x0)
((lambda (x1) ((lambda (x1)
((lambda (x2) ((lambda (x2)
@ -249,93 +249,93 @@
(+ 3 4))) (+ 3 4)))
(+ 1 2)))))) (+ 1 2))))))
(make-test-case (test-case
"if nested in test position" "if nested in test position"
(assert alpha= (normalize-term (expand (syntax (if (if #t #f #t) #t #t)))) (check alpha= (normalize-term (expand (syntax (if (if #t #f #t) #t #t))))
(expand (syntax ((lambda (x) (if x #t #t)) (if #t #f #t)))))) (expand (syntax ((lambda (x) (if x #t #t)) (if #t #f #t))))))
(make-test-case (test-case
"procedure/body has nested if" "procedure/body has nested if"
(assert alpha= (normalize-term (expand (syntax (lambda (x) (if (if x 1 2) 3 4))))) (check alpha= (normalize-term (expand (syntax (lambda (x) (if (if x 1 2) 3 4)))))
(expand (syntax (lambda (x) (expand (syntax (lambda (x)
((lambda (y0) (if y0 3 4)) ((lambda (y0) (if y0 3 4))
(if x 1 2))))))) (if x 1 2)))))))
(make-test-case (test-case
"constant 0-arg procedure application" "constant 0-arg procedure application"
(assert alpha= (normalize-term (expand (syntax ((lambda () 3))))) (check alpha= (normalize-term (expand (syntax ((lambda () 3)))))
(expand (syntax ((lambda () 3)))))) (expand (syntax ((lambda () 3))))))
(make-test-case (test-case
"if with function application in test" "if with function application in test"
(assert alpha= (normalize-term (expand (syntax (if ((lambda () 7)) 1 2)))) (check alpha= (normalize-term (expand (syntax (if ((lambda () 7)) 1 2))))
(expand (syntax ((lambda (x) (if x 1 2)) (expand (syntax ((lambda (x) (if x 1 2))
((lambda () 7))))))) ((lambda () 7)))))))
(make-test-case (test-case
"if with lambda-expression in consequent and alternative" "if with lambda-expression in consequent and alternative"
(assert alpha= (normalize-term (expand (syntax ((if #t (lambda () 1) (lambda () 2)))))) (check alpha= (normalize-term (expand (syntax ((if #t (lambda () 1) (lambda () 2))))))
(expand (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2))))))) (expand (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2)))))))
(make-test-case (test-case
"call/cc with value argument" "call/cc with value argument"
(assert alpha= (normalize-term (expand (syntax (call/cc (lambda (x) x))))) (check alpha= (normalize-term (expand (syntax (call/cc (lambda (x) x)))))
(expand (syntax (call/cc (lambda (x) x)))))) (expand (syntax (call/cc (lambda (x) x))))))
(make-test-case (test-case
"call/cc with complex expression in argument" "call/cc with complex expression in argument"
(assert alpha= (normalize-term (expand (syntax (call/cc (f (g 7)))))) (check alpha= (normalize-term (expand (syntax (call/cc (f (g 7))))))
(expand (syntax ((lambda (x0) (expand (syntax ((lambda (x0)
((lambda (x1) (call/cc x1)) ((lambda (x1) (call/cc x1))
(f x0))) (f x0)))
(g 7))))))) (g 7)))))))
(make-test-suite (test-suite
"Check that certain errors are raised" "Check that certain errors are raised"
; XXX Turn these tests into checking versions ; XXX Turn these tests into checking versions
(make-test-case (test-case
"multiple body expressions in lambda" "multiple body expressions in lambda"
(assert-true (check-supported (check-true (check-supported
(normalize-term (expand (syntax (lambda (x y z) 3 4))))))) (normalize-term (expand (syntax (lambda (x y z) 3 4)))))))
(make-test-case (test-case
"zero-or-more argument lambda" "zero-or-more argument lambda"
(assert-true (check-supported (check-true (check-supported
(normalize-term (expand (syntax (lambda x x))))))) (normalize-term (expand (syntax (lambda x x)))))))
(make-test-case (test-case
"multi-valued let-values" "multi-valued let-values"
(assert-true (check-supported (check-true (check-supported
(normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y)))))))) (normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y))))))))
(make-test-case (test-case
"let/multiple clauses before body" "let/multiple clauses before body"
(assert-true (check-supported (check-true (check-supported
(normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y))))))))) (normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y)))))))))
(make-test-suite (test-suite
"Miscellaneous tests" "Miscellaneous tests"
(make-test-case (test-case
"empty begin" "empty begin"
(assert alpha= (normalize-term (expand (syntax (begin)))) (check alpha= (normalize-term (expand (syntax (begin))))
(syntax (#%app (#%top . void))))) (syntax (#%app (#%top . void)))))
(make-test-case (test-case
"begin with one expression" "begin with one expression"
(assert alpha= (normalize-term (expand (syntax (begin 1)))) (check alpha= (normalize-term (expand (syntax (begin 1))))
(syntax (#%datum . 1)))) (syntax (#%datum . 1))))
(make-test-case (test-case
"begin with multiple expressions" "begin with multiple expressions"
(assert alpha= (normalize-term (expand (syntax (begin 1 2 3)))) (check alpha= (normalize-term (expand (syntax (begin 1 2 3))))
(normalize-term (expand (syntax (let ([throw-away 1]) (normalize-term (expand (syntax (let ([throw-away 1])
(let ([throw-away 2]) (let ([throw-away 2])
3))))))) 3)))))))
(make-test-case (test-case
"cond expression" "cond expression"
(assert-true (check-true
(and (and
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (the-exn) #f)]) (lambda (the-exn) #f)])

24
collects/web-server/prototype-web-server/tests/certify-tests.ss
View File

@ -1,5 +1,5 @@
(module certify-tests mzscheme (module certify-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"util.ss") "util.ss")
(provide certify-suite) (provide certify-suite)
@ -9,13 +9,13 @@
((car k*v) k*v)))) ((car k*v) k*v))))
(define certify-suite (define certify-suite
(make-test-suite (test-suite
"Test the certification process" "Test the certification process"
(make-test-suite (test-suite
"Splicing tests" "Splicing tests"
(make-test-case (test-case
"quasi-quote with splicing: need to recertify context for qq-append" "quasi-quote with splicing: need to recertify context for qq-append"
(let-values ([(go test-m01.1) (let-values ([(go test-m01.1)
(make-module-eval (make-module-eval
@ -24,10 +24,10 @@
(define (start initial) (define (start initial)
`(,@(list 1 2 initial)))))]) `(,@(list 1 2 initial)))))])
(go the-dispatch) (go the-dispatch)
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3))) (check equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo))))) (check equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(make-test-case (test-case
"recertify context test (1)" "recertify context test (1)"
(let-values ([(go test-m01.2) (let-values ([(go test-m01.2)
(make-module-eval (make-module-eval
@ -36,9 +36,9 @@
(define (start initial) (define (start initial)
`(foo ,@(list 1 2 3)))))]) `(foo ,@(list 1 2 3)))))])
(go the-dispatch) (go the-dispatch)
(assert-true #t))) (check-true #t)))
(make-test-case (test-case
"recertify context test (2)" "recertify context test (2)"
(let-values ([(go test-m01.3) (let-values ([(go test-m01.3)
(make-module-eval (make-module-eval
@ -47,9 +47,9 @@
(define (start n) (define (start n)
`(n ,@(list 1 2 3)))))]) `(n ,@(list 1 2 3)))))])
(go the-dispatch) (go the-dispatch)
(assert-true #t))) (check-true #t)))
(make-test-case (test-case
"recertify context test (3)" "recertify context test (3)"
(let-values ([(go test-m01.4) (let-values ([(go test-m01.4)
(make-module-eval (make-module-eval
@ -60,4 +60,4 @@
`(n ,@(list 1 2 3))) `(n ,@(list 1 2 3)))
(bar 7))))]) (bar 7))))])
(go the-dispatch) (go the-dispatch)
(assert-true #t))))))) (check-true #t)))))))

60
collects/web-server/prototype-web-server/tests/closure-tests.ss
View File

@ -1,6 +1,6 @@
(module closure-tests mzscheme (module closure-tests mzscheme
(provide closure-tests-suite) (provide closure-tests-suite)
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "serialize.ss") (lib "serialize.ss")
(lib "match.ss") (lib "match.ss")
"../define-closure.ss") "../define-closure.ss")
@ -50,48 +50,48 @@
(define eval-app (make-clsr:eval-app (lambda () evaluate))) (define eval-app (make-clsr:eval-app (lambda () evaluate)))
(define closure-tests-suite (define closure-tests-suite
(make-test-suite (test-suite
"Tests for closure.ss" "Tests for closure.ss"
(make-test-case (test-case
"serialize id procedure" "serialize id procedure"
(assert = 7 ((deserialize (serialize (make-id))) 7))) (check = 7 ((deserialize (serialize (make-id))) 7)))
(make-test-case (test-case
"id procedure" "id procedure"
(assert = 7 ((make-id) 7))) (check = 7 ((make-id) 7)))
(make-test-case (test-case
"add-y procedure" "add-y procedure"
(assert = 2 ((make-add-y (lambda () 1)) 1))) (check = 2 ((make-add-y (lambda () 1)) 1)))
(make-test-case (test-case
"serialize the add-y procedure" "serialize the add-y procedure"
(assert = 2 ((deserialize (serialize (make-add-y (lambda () 1)))) 1))) (check = 2 ((deserialize (serialize (make-add-y (lambda () 1)))) 1)))
(make-test-case (test-case
"even-p procedure" "even-p procedure"
(assert-true (even-p 8))) (check-true (even-p 8)))
(make-test-case (test-case
"serialize the even-p procedure" "serialize the even-p procedure"
(assert-true ((deserialize (serialize even-p)) 64))) (check-true ((deserialize (serialize even-p)) 64)))
(make-test-case (test-case
"simple interpreter case" "simple interpreter case"
(assert = 3 (evaluate 3 (make-the-empty-env)))) (check = 3 (evaluate 3 (make-the-empty-env))))
(make-test-case (test-case
"serialize simple interpreter case" "serialize simple interpreter case"
(assert = 3 ((deserialize (serialize evaluate)) (check = 3 ((deserialize (serialize evaluate))
3 3
(deserialize (serialize (make-the-empty-env)))))) (deserialize (serialize (make-the-empty-env))))))
(make-test-case (test-case
"apply identity" "apply identity"
(assert = 3 (evaluate '((lambda (x) x) 3) (make-the-empty-env)))) (check = 3 (evaluate '((lambda (x) x) 3) (make-the-empty-env))))
(make-test-case (test-case
"serialize environments" "serialize environments"
(let* ([e0 (make-the-empty-env)] (let* ([e0 (make-the-empty-env)]
[e1 (make-extended-env (lambda () (values e0 'x 1)))] [e1 (make-extended-env (lambda () (values e0 'x 1)))]
@ -103,12 +103,12 @@
[env3 (deserialize (serialize e3))] [env3 (deserialize (serialize e3))]
[env5 (deserialize (serialize e5))] [env5 (deserialize (serialize e5))]
[env6 (deserialize (serialize e6))]) [env6 (deserialize (serialize e6))])
(assert = 1 (env3 'x)) (check = 1 (env3 'x))
(assert = 2 (env3 'y)) (check = 2 (env3 'y))
(assert = 3 (env3 'z)) (check = 3 (env3 'z))
(assert = 4 (env5 'x)) (check = 4 (env5 'x))
(assert = 5 (env5 'y)) (check = 5 (env5 'y))
(assert = 3 (env5 'z)) (check = 3 (env5 'z))
(assert = 4 (env6 'x)) (check = 4 (env6 'x))
(assert = 5 (env6 'y)) (check = 5 (env6 'y))
(assert = 6 (env6 'z))))))) (check = 6 (env6 'z)))))))

46
collects/web-server/prototype-web-server/tests/labels-tests.ss
View File

@ -1,11 +1,11 @@
(module labels-tests mzscheme (module labels-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "util.ss" ("schematics" "schemeunit.plt" 1)) (planet "util.ss" ("schematics" "schemeunit.plt" 2))
(lib "etc.ss") (lib "etc.ss")
"../labels.ss") "../labels.ss")
(require/expose "../labels.ss" (add1/string)) (require/expose (lib "labels.ss" "web-server" "prototype-web-server") (add1/string))
(define THE-TEST-FILENAME "labels-test-file") (define THE-TEST-FILENAME "labels-test-file")
@ -78,35 +78,35 @@
syms)))))) syms))))))
(define labels-tests-suite (define labels-tests-suite
(make-test-suite (test-suite
"Tests for labels.ss" "Tests for labels.ss"
(make-test-case (test-case
"Test the tag incrementing scheme" "Test the tag incrementing scheme"
(assert string=? "b" (add1/string "")) (check string=? "b" (add1/string ""))
(assert string=? "A" (add1/string "z")) (check string=? "A" (add1/string "z"))
(assert string=? "B" (add1/string "A")) (check string=? "B" (add1/string "A"))
(assert string=? "b" (add1/string "a")) (check string=? "b" (add1/string "a"))
(assert string=? "ab" (add1/string "Z")) (check string=? "ab" (add1/string "Z"))
(assert string=? "aab" (add1/string "ZZ")) (check string=? "aab" (add1/string "ZZ"))
(assert string=? "Azz" (add1/string "zzz")) (check string=? "Azz" (add1/string "zzz"))
(assert string=? "aaaab" (add1/string "ZZZZ")) (check string=? "aaaab" (add1/string "ZZZZ"))
(assert string=? "baaab" (add1/string "aaaab"))) (check string=? "baaab" (add1/string "aaaab")))
(make-test-case (test-case
"The same program produces the same labeling" "The same program produces the same labeling"
(assert-eqv? (l1) (l2)) (check-eqv? (l1) (l2))
(assert-eqv? (l1) (l2))) (check-eqv? (l1) (l2)))
(make-test-case (test-case
"Different programs produce different labelings" "Different programs produce different labelings"
(assert-false (eqv? (l3) (l4)))) (check-false (eqv? (l3) (l4))))
(make-test-case (test-case
"Check for race condition on make-labeling" "Check for race condition on make-labeling"
(assert-false (make-labeling-race? 256))) (check-false (make-labeling-race? 256)))
(make-test-case (test-case
"Check for race condition on delete-tag-list!" "Check for race condition on delete-tag-list!"
(assert-false (delete-tag-list!-race? 256)))))) (check-false (delete-tag-list!-race? 256))))))

147
collects/web-server/prototype-web-server/tests/lang-tests.ss
View File

@ -1,5 +1,5 @@
(module lang-tests mzscheme (module lang-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"util.ss") "util.ss")
(provide lang-suite) (provide lang-suite)
@ -20,16 +20,16 @@
((car k*v) k*v)))) ((car k*v) k*v))))
(define lang-suite (define lang-suite
(make-test-suite (test-suite
"Test the Web language" "Test the Web language"
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; BASIC TESTS ;; BASIC TESTS
(make-test-suite (test-suite
"Basic Tests" "Basic Tests"
(make-test-case (test-case
"Function application with single argument in tail position" "Function application with single argument in tail position"
(let-values ([(go test-m00.4) (let-values ([(go test-m00.4)
(make-module-eval (make-module-eval
@ -39,9 +39,9 @@
(let ([f (let ([m 7]) m)]) (let ([f (let ([m 7]) m)])
(+ f initial)))))]) (+ f initial)))))])
(go the-dispatch) (go the-dispatch)
(assert = 8 (test-m00.4 '(dispatch-start 1))))) (check = 8 (test-m00.4 '(dispatch-start 1)))))
(make-test-case (test-case
"start-interaction in argument position of a function call" "start-interaction in argument position of a function call"
(let-values ([(go test-m00.3) (let-values ([(go test-m00.3)
(make-module-eval (make-module-eval
@ -51,9 +51,9 @@
(define (start initial) (define (start initial)
(foo initial))))]) (foo initial))))])
(go the-dispatch) (go the-dispatch)
(assert eqv? 'foo (test-m00.3 '(dispatch-start 7))))) (check eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(make-test-case (test-case
"identity interaction, dispatch-start called multiple times" "identity interaction, dispatch-start called multiple times"
(let-values ([(go test-m00) (let-values ([(go test-m00)
(make-module-eval (make-module-eval
@ -63,10 +63,10 @@
(define (start initial) (define (start initial)
(id initial))))]) (id initial))))])
(go the-dispatch) (go the-dispatch)
(assert = 7 (test-m00 '(dispatch-start 7))) (check = 7 (test-m00 '(dispatch-start 7)))
(assert eqv? 'foo (test-m00 '(dispatch-start 'foo))))) (check eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
(make-test-case (test-case
"start-interaction in argument position of a primitive" "start-interaction in argument position of a primitive"
(let-values ([(go test-m00.1) (let-values ([(go test-m00.1)
(make-module-eval (make-module-eval
@ -75,9 +75,9 @@
(define (start initial) (define (start initial)
(+ 1 initial))))]) (+ 1 initial))))])
(go the-dispatch) (go the-dispatch)
(assert = 2 (test-m00.1 '(dispatch-start 1))))) (check = 2 (test-m00.1 '(dispatch-start 1)))))
(make-test-case (test-case
"dispatch-start called multiple times for s-i in non-trivial context" "dispatch-start called multiple times for s-i in non-trivial context"
(let-values ([(go test-m00.2) (let-values ([(go test-m00.2)
(make-module-eval (make-module-eval
@ -86,10 +86,10 @@
(define (start initial) (define (start initial)
(+ (+ 1 1) initial))))]) (+ (+ 1 1) initial))))])
(go the-dispatch) (go the-dispatch)
(assert = 14 (test-m00.2 '(dispatch-start 12))) (check = 14 (test-m00.2 '(dispatch-start 12)))
(assert = 20 (test-m00.2 '(dispatch-start 18))))) (check = 20 (test-m00.2 '(dispatch-start 18)))))
(make-test-case (test-case
"start-interaction in third position" "start-interaction in third position"
(let-values ([(go test-m01) (let-values ([(go test-m01)
(make-module-eval (make-module-eval
@ -98,14 +98,14 @@
(define (start initial) (define (start initial)
(+ (* 1 2) (* 3 4) initial))))]) (+ (* 1 2) (* 3 4) initial))))])
(go the-dispatch) (go the-dispatch)
(assert = 14 (test-m01 '(dispatch-start 0))) (check = 14 (test-m01 '(dispatch-start 0)))
(assert = 20 (test-m01 '(dispatch-start 6))))) (check = 20 (test-m01 '(dispatch-start 6)))))
;; start-interaction may be called mutitple times ;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction ;; each call overwrites the previous interaction
;; continuation with the latest one. ;; continuation with the latest one.
; XXX We have taken this power away. ; XXX We have taken this power away.
#;(make-test-case #;(test-case
"start-interaction called twice, dispatch-start will invoke different continuations" "start-interaction called twice, dispatch-start will invoke different continuations"
(let ([test-m02 (let ([test-m02
(make-module-eval (make-module-eval
@ -114,19 +114,19 @@
(+ (start-interaction id) (+ (start-interaction id)
(start-interaction id))))]) (start-interaction id))))])
(assert-true (void? (test-m02 '(dispatch-start 1)))) (check-true (void? (test-m02 '(dispatch-start 1))))
(assert = 3 (test-m02 '(dispatch-start 2))) (check = 3 (test-m02 '(dispatch-start 2)))
(assert = 0 (test-m02 '(dispatch-start -1)))))) (check = 0 (test-m02 '(dispatch-start -1))))))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; TESTS INVOLVING CALL/CC ;; TESTS INVOLVING CALL/CC
(make-test-suite (test-suite
"Tests Involving call/cc" "Tests Involving call/cc"
(make-test-case (test-case
"continuation invoked in non-trivial context from within proc" "continuation invoked in non-trivial context from within proc"
(let-values ([(go test-m03) (let-values ([(go test-m03)
(make-module-eval (make-module-eval
@ -136,13 +136,13 @@
(let/cc k (let/cc k
(+ 2 4 (k 3) 6 8)))))]) (+ 2 4 (k 3) 6 8)))))])
(go the-dispatch) (go the-dispatch)
(assert = 3 (test-m03 '(dispatch-start 'foo))) (check = 3 (test-m03 '(dispatch-start 'foo)))
(assert = 3 (test-m03 '(dispatch-start 7))))) (check = 3 (test-m03 '(dispatch-start 7)))))
;; in the following test, if you modify ;; in the following test, if you modify
;; resume to print the "stack" you will ;; resume to print the "stack" you will
;; see that this is not tail recursive ;; see that this is not tail recursive
(make-test-case (test-case
"non-tail-recursive 'escaping' continuation" "non-tail-recursive 'escaping' continuation"
(let-values ([(go test-m04) (let-values ([(go test-m04)
(make-module-eval (make-module-eval
@ -157,14 +157,14 @@
(* (car ln) (* (car ln)
(start (cdr ln)))])))))]) (start (cdr ln)))])))))])
(go the-dispatch) (go the-dispatch)
(assert = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9)))) (check = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9))))
(assert = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5)))))) (check = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5))))))
;; this version captures the continuation ;; this version captures the continuation
;; outside the recursion and should be tail ;; outside the recursion and should be tail
;; recursive. A "stack trace" reveals this ;; recursive. A "stack trace" reveals this
;; as expected. ;; as expected.
(make-test-case (test-case
"tail-recursive escaping continuation" "tail-recursive escaping continuation"
(let-values ([(go test-m05) (let-values ([(go test-m05)
(make-module-eval (make-module-eval
@ -183,17 +183,17 @@
(* (car ln) (* (car ln)
(mult/escape escape (cdr ln)))]))))]) (mult/escape escape (cdr ln)))]))))])
(go the-dispatch) (go the-dispatch)
(assert = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6)))) (check = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6))))
(assert = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5))))))) (check = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; TESTS INVOLVING send/suspend ;; TESTS INVOLVING send/suspend
(make-test-suite (test-suite
"Tests Involving send/suspend" "Tests Involving send/suspend"
; XXX This doesn't work, because we don't allow a different dispatcher ; XXX This doesn't work, because we don't allow a different dispatcher
#;(make-test-case #;(test-case
"curried add with send/suspend" "curried add with send/suspend"
(let ([table-01-eval (let ([table-01-eval
(make-module-eval (make-module-eval
@ -229,13 +229,13 @@
(let* ([first-key (table-01-eval '(dispatch-start 'foo))] (let* ([first-key (table-01-eval '(dispatch-start 'foo))]
[second-key (table-01-eval `(dispatch '(,first-key 1)))] [second-key (table-01-eval `(dispatch '(,first-key 1)))]
[third-key (table-01-eval `(dispatch '(,first-key -7)))]) [third-key (table-01-eval `(dispatch '(,first-key -7)))])
(assert = 3 (table-01-eval `(dispatch '(,second-key 2)))) (check = 3 (table-01-eval `(dispatch '(,second-key 2))))
(assert = 4 (table-01-eval `(dispatch '(,second-key 3)))) (check = 4 (table-01-eval `(dispatch '(,second-key 3))))
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1))))) (check-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
(assert = -7 (table-01-eval `(dispatch '(,third-key 0)))) (check = -7 (table-01-eval `(dispatch '(,third-key 0))))
(assert-true (zero? (table-01-eval `(dispatch '(,third-key 7)))))))) (check-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
(make-test-case (test-case
"curried with send/suspend and serializaztion" "curried with send/suspend and serializaztion"
(let-values ([(go test-m06.1) (let-values ([(go test-m06.1)
@ -257,20 +257,19 @@
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))] (let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))] [second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))]) [third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))])
(values (check = 3 (test-m06.1 `(dispatch (list ,second-key 2))))
(assert = 3 (test-m06.1 `(dispatch (list ,second-key 2)))) (check = 4 (test-m06.1 `(dispatch (list ,second-key 3))))
(assert = 4 (test-m06.1 `(dispatch (list ,second-key 3)))) (check-true (zero? (test-m06.1 `(dispatch (list ,second-key -1)))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,second-key -1))))) (check = -7 (test-m06.1 `(dispatch (list ,third-key 0))))
(assert = -7 (test-m06.1 `(dispatch (list ,third-key 0)))) (check-true (zero? (test-m06.1 `(dispatch (list ,third-key 7)))))))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,third-key 7))))))))))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; TESTS INVOLVING LETREC ;; TESTS INVOLVING LETREC
(make-test-suite (test-suite
"Tests Involving letrec" "Tests Involving letrec"
(make-test-case (test-case
"mutually recursive even? and odd?" "mutually recursive even? and odd?"
(let-values ([(go test-m07) (let-values ([(go test-m07)
(make-module-eval (make-module-eval
@ -285,12 +284,12 @@
(even? (sub1 n))))]) (even? (sub1 n))))])
(even? initial)))))]) (even? initial)))))])
(go the-dispatch) (go the-dispatch)
(assert-true (test-m07 '(dispatch-start 0))) (check-true (test-m07 '(dispatch-start 0)))
(assert-true (test-m07 '(dispatch-start 16))) (check-true (test-m07 '(dispatch-start 16)))
(assert-false (test-m07 '(dispatch-start 1))) (check-false (test-m07 '(dispatch-start 1)))
(assert-false (test-m07 '(dispatch-start 7))))) (check-false (test-m07 '(dispatch-start 7)))))
(make-test-case (test-case
"send/suspend on rhs of letrec binding forms" "send/suspend on rhs of letrec binding forms"
(let-values ([(go test-m08) (let-values ([(go test-m08)
(make-module-eval (make-module-eval
@ -315,21 +314,21 @@
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))] (let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))] [k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
[k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))]) [k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))])
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))) (check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))
(assert = 9 (test-m08 `(dispatch (list (deserialize ',k2) 6)))) (check = 9 (test-m08 `(dispatch (list (deserialize ',k2) 6))))
(let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))] (let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))]
[k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))]) [k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))])
(assert-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3))))) (check-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3)))))
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))))))) (check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))))))))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; TEST UNSAFE CONTEXT CONDITION ;; TEST UNSAFE CONTEXT CONDITION
(make-test-suite (test-suite
"Unsafe Context Condition Tests" "Unsafe Context Condition Tests"
; XXX Bizarre ; XXX Bizarre
#;(make-test-case #;(test-case
"simple attempt to capture a continuation from an unsafe context" "simple attempt to capture a continuation from an unsafe context"
(let-values ([(go nta-eval) (let-values ([(go nta-eval)
@ -349,10 +348,10 @@
(nta-eval '(require m09)) (nta-eval '(require m09))
(assert-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start 'foo))))))) (lambda () (nta-eval '(dispatch-start 'foo)))))))
(make-test-case (test-case
"sanity-check: capture continuation from safe version of context" "sanity-check: capture continuation from safe version of context"
(let-values ([(go m10-eval) (let-values ([(go m10-eval)
@ -366,9 +365,9 @@
(define (start ignore) (define (start ignore)
(nta (lambda (x) (let/cc k (k x))) 7))))]) (nta (lambda (x) (let/cc k (k x))) 7))))])
(go the-dispatch) (go the-dispatch)
(assert = 7 (m10-eval '(dispatch-start 'foo))))) (check = 7 (m10-eval '(dispatch-start 'foo)))))
(make-test-case (test-case
"attempt continuation capture from standard call to map" "attempt continuation capture from standard call to map"
(let-values ([(go m11-eval) (let-values ([(go m11-eval)
@ -380,13 +379,13 @@
(lambda (x) (let/cc k k)) (lambda (x) (let/cc k k))
(list 1 2 3)))))]) (list 1 2 3)))))])
(go the-dispatch) (go the-dispatch)
(assert-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (m11-eval '(dispatch-start 'foo))))))) (lambda () (m11-eval '(dispatch-start 'foo)))))))
;; if the continuation-capture is attempted in tail position then we ;; if the continuation-capture is attempted in tail position then we
;; should be just fine. ;; should be just fine.
; XXX Weird ; XXX Weird
#;(make-test-case #;(test-case
"continuation capture from tail position of untranslated procedure" "continuation capture from tail position of untranslated procedure"
(let ([ta-eval (let ([ta-eval
@ -406,9 +405,9 @@
(ta-eval '(require m12)) (ta-eval '(require m12))
(assert = 2 (ta-eval '(dispatch-start 1))))) (check = 2 (ta-eval '(dispatch-start 1)))))
(make-test-case (test-case
"attempt send/suspend from standard call to map" "attempt send/suspend from standard call to map"
(let-values ([(go m13-eval) (let-values ([(go m13-eval)
@ -423,11 +422,11 @@
k)))) k))))
(list 1 2 3)))))]) (list 1 2 3)))))])
(go the-dispatch) (go the-dispatch)
(assert-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (m13-eval '(dispatch-start 'foo))))))) (lambda () (m13-eval '(dispatch-start 'foo)))))))
; XXX Weird ; XXX Weird
#;(make-test-case #;(test-case
"attempt send/suspend from tail position of untranslated procedure" "attempt send/suspend from tail position of untranslated procedure"
(let-values ([(go ta-eval) (let-values ([(go ta-eval)
@ -452,5 +451,5 @@
(ta-eval '(require m14)) (ta-eval '(require m14))
(let ([k0 (ta-eval '(dispatch-start 'foo))]) (let ([k0 (ta-eval '(dispatch-start 'foo))])
(assert = 3 (ta-eval `(dispatch (list ,k0 2)))) (check = 3 (ta-eval `(dispatch (list ,k0 2))))
(assert = 0 (ta-eval `(dispatch (list ,k0 -1))))))))))) (check = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))

32
collects/web-server/prototype-web-server/tests/persistent-close-tests.ss
View File

@ -1,38 +1,38 @@
(module persistent-close-tests mzscheme (module persistent-close-tests mzscheme
(require (lib "file-vector.ss" "web-server" "prototype-web-server" "graveyard") (require (lib "file-vector.ss" "web-server" "prototype-web-server" "graveyard")
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "serialize.ss") (lib "serialize.ss")
(lib "persistent-close.ss" "web-server" "prototype-web-server" "graveyard")) (lib "persistent-close.ss" "web-server" "prototype-web-server" "graveyard"))
(provide persistent-close-suite) (provide persistent-close-suite)
(define persistent-close-suite (define persistent-close-suite
(make-test-suite (test-suite
"tests for persistent-close.ss" "tests for persistent-close.ss"
(make-test-case (test-case
"file-vector references" "file-vector references"
(let ([fv (make-file-vector 'foo 1 2 3)]) (let ([fv (make-file-vector 'foo 1 2 3)])
(assert = 1 (file-vector-ref fv 0)) (check = 1 (file-vector-ref fv 0))
(assert = 2 (file-vector-ref fv 1)) (check = 2 (file-vector-ref fv 1))
(assert = 3 (file-vector-ref fv 2)) (check = 3 (file-vector-ref fv 2))
(file-vector-set! fv 0 -1) (file-vector-set! fv 0 -1)
(file-vector-set! fv 1 -2) (file-vector-set! fv 1 -2)
(file-vector-set! fv 2 -3) (file-vector-set! fv 2 -3)
(assert = -1 (file-vector-ref fv 0)) (check = -1 (file-vector-ref fv 0))
(assert = -2 (file-vector-ref fv 1)) (check = -2 (file-vector-ref fv 1))
(assert = -3 (file-vector-ref fv 2)))) (check = -3 (file-vector-ref fv 2))))
(make-test-case (test-case
"serializing file vectors" "serializing file vectors"
(let* ([fv (make-file-vector 'foo -1 -2 -3)] (let* ([fv (make-file-vector 'foo -1 -2 -3)]
[fv2 (deserialize (serialize fv))]) [fv2 (deserialize (serialize fv))])
(assert = -1 (file-vector-ref fv2 0)) (check = -1 (file-vector-ref fv2 0))
(assert = -2 (file-vector-ref fv2 1)) (check = -2 (file-vector-ref fv2 1))
(assert = -3 (file-vector-ref fv2 2)))) (check = -3 (file-vector-ref fv2 2))))
(make-test-case (test-case
"close/file test" "close/file test"
(let ([x 7] [y 8]) (let ([x 7] [y 8])
(assert = 7 (close/file 'f1 (x y) x)) (check = 7 (close/file 'f1 (x y) x))
(assert = 15 (close/file 'f2 (x y) (+ x y)))))))) (check = 15 (close/file 'f2 (x y) (+ x y))))))))

26
collects/web-server/prototype-web-server/tests/stuff-url-tests.ss
View File

@ -1,7 +1,7 @@
(module stuff-url-tests mzscheme (module stuff-url-tests mzscheme
(require (lib "stuff-url.ss" "web-server" "prototype-web-server") (require (lib "stuff-url.ss" "web-server" "prototype-web-server")
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "util.ss" ("schematics" "schemeunit.plt" 1)) (planet "util.ss" ("schematics" "schemeunit.plt" 2))
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "dirs.ss" "setup") (lib "dirs.ss" "setup")
(lib "file.ss") (lib "file.ss")
@ -32,26 +32,26 @@
((car k*v) k*v)))) ((car k*v) k*v))))
(define stuff-url-suite (define stuff-url-suite
(make-test-suite (test-suite
"Tests for stuff-url.ss" "Tests for stuff-url.ss"
(make-test-case (test-case
"Test same-module?" "Test same-module?"
(assert-true (check-true
(same-module? `(file ,(path->string (build-absolute-path (find-collects-dir) "web-server" "prototype-web-server" "abort-resume.ss"))) (same-module? `(file ,(path->string (build-absolute-path (find-collects-dir) "web-server" "prototype-web-server" "abort-resume.ss")))
'(lib "abort-resume.ss" "web-server" "prototype-web-server"))) '(lib "abort-resume.ss" "web-server" "prototype-web-server")))
(assert-true (check-true
(same-module? `(file ,(path->string (build-absolute-path (current-directory) "../abort-resume.ss"))) (same-module? `(file ,(path->string (build-absolute-path (current-directory) "../abort-resume.ss")))
'(lib "abort-resume.ss" "web-server" "prototype-web-server"))) '(lib "abort-resume.ss" "web-server" "prototype-web-server")))
(assert-true (check-true
(same-module? (same-module?
'(lib "abort-resume.ss" "web-server" "prototype-web-server") '(lib "abort-resume.ss" "web-server" "prototype-web-server")
'(lib "./abort-resume.ss" "web-server" "prototype-web-server")))) '(lib "./abort-resume.ss" "web-server" "prototype-web-server"))))
(make-test-case (test-case
"compose url-parts and recover-serial (1)" "compose url-parts and recover-serial (1)"
(let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")]) (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
(go the-dispatch) (go the-dispatch)
@ -61,17 +61,17 @@
`(file "modules/mm00.ss"))] `(file "modules/mm00.ss"))]
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) [k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
`(file "modules/mm00.ss"))]) `(file "modules/mm00.ss"))])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))) (check-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))
(make-test-case (test-case
"compose url-parts and recover-serial (2)" "compose url-parts and recover-serial (2)"
(let-values ([(go ev) (make-eval/mod-path "modules/mm01.ss")]) (let-values ([(go ev) (make-eval/mod-path "modules/mm01.ss")])
(go the-dispatch) (go the-dispatch)
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
`(file "modules/mm01.ss"))]) `(file "modules/mm01.ss"))])
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7)))))))) (check-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7))))))))
(make-test-case (test-case
"compose stuff-url and unstuff-url and recover the serial" "compose stuff-url and unstuff-url and recover the serial"
(let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")]) (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
(go the-dispatch) (go the-dispatch)
@ -81,4 +81,4 @@
uri0 `(file "modules/mm00.ss"))] uri0 `(file "modules/mm00.ss"))]
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) [k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
uri0 `(file "modules/mm00.ss"))]) uri0 `(file "modules/mm00.ss"))])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))))) (check-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))))))

11
collects/web-server/prototype-web-server/tests/suite.ss
View File

@ -1,7 +1,7 @@
(module suite mzscheme (module suite mzscheme
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1)) (require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1)) (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"persistent-close-tests.ss" "persistent-close-tests.ss"
"anormal-test.ss" "anormal-test.ss"
"closure-tests.ss" "closure-tests.ss"
@ -11,7 +11,7 @@
"stuff-url-tests.ss") "stuff-url-tests.ss")
(test/graphical-ui (test/graphical-ui
(make-test-suite (test-suite
"Main Tests for Prototype Web Server" "Main Tests for Prototype Web Server"
persistent-close-suite persistent-close-suite
stuff-url-suite stuff-url-suite
@ -19,5 +19,4 @@
closure-tests-suite closure-tests-suite
labels-tests-suite labels-tests-suite
lang-suite lang-suite
certify-suite certify-suite)))
)))