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

Updating tests for new translator

Browse Source 
svn: r6290
This commit is contained in:
Jay McCarthy 2007-05-25 05:16:20 +00:00
parent e63138ef10
commit 6bbdfcac71
7 changed files with 205 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/web-server/prototype-web-server/tests/interaction-tests.ss
View File

@ -136,5 +136,4 @@
(= 4 (dispatch `(,second-key 3)))
(zero? (dispatch `(,second-key -1)))
(= -7 (dispatch `(,third-key 0)))
(zero? (dispatch `(,third-key 7)))))
(zero? (dispatch `(,third-key 7)))))

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

@ -109,8 +109,4 @@
(make-test-case
"Check for race condition on delete-tag-list!"
(assert-false (delete-tag-list!-race? 256)))
)))
(assert-false (delete-tag-list!-race? 256))))))

19
collects/web-server/prototype-web-server/tests/language-tester.ss
View File

@ -7,14 +7,25 @@
[(_ (module m-id . rest))
#'(let ([ns (make-namespace)])
(parameterize ([current-namespace ns])
(eval '(require "../client.ss"
(eval '(require "../abort-resume.ss"
(lib "serialize.ss")))
(eval '(module m-id . rest))
(eval '(require m-id)))
(lambda (s-expr)
(parameterize ([current-namespace ns])
(eval s-expr))))]
(values
(lambda ()
(parameterize ([current-namespace ns])
(eval '(abort/cc
(with-continuation-mark safe-call? '(#t start)
(start
(with-continuation-mark the-cont-key start
(start-interaction
(lambda (k*v)
(lambda (k*v)
((car k*v) k*v)))))))))))
(lambda (s-expr)
(parameterize ([current-namespace ns])
(eval s-expr)))))]
[else
(raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))

15
collects/web-server/prototype-web-server/tests/modules/mm00.ss
View File

@ -1,4 +1,5 @@
(module mm00 (lib "persistent-interaction.ss" "web-server" "prototype-web-server")
(module mm00 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (gn which)
(cadr
@ -7,9 +8,9 @@
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let* ([ignore (start-interaction car)]
[ans (+ (gn "first")
(gn "second")
(gn "third"))])
(printf "The answer is: ~s~n" ans)
ans))
(define (start initial)
(let ([ans (+ (gn "first")
(gn "second")
(gn "third"))])
(printf "The answer is: ~s~n" ans)
ans)))

6
collects/web-server/prototype-web-server/tests/modules/mm01.ss
View File

@ -1,5 +1,5 @@
(module mm01 (lib "persistent-interaction.ss" "web-server" "prototype-web-server")
(module mm01 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (gn which)
(cadr
(send/suspend
@ -7,5 +7,5 @@
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(define (start initial)
(gn "first")))

320
collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss
View File

@ -26,125 +26,134 @@
(make-test-case
"Function application with single argument in tail position"
(let ([test-m00.4
(let-values ([(go test-m00.4)
(make-module-eval
(module m00.4 "../persistent-interaction.ss"
(define (id x) x)
(let ([f (let ([m 7]) m)])
(+ f (start-interaction id)))))])
(module m00.4 "../lang.ss"
(provide start)
(define (start initial)
(let ([f (let ([m 7]) m)])
(+ f initial)))))])
(go)
(assert = 8 (test-m00.4 '(dispatch-start 1)))))
(make-test-case
"start-interaction in argument position of a function call"
(let ([test-m00.3
(let-values ([(go test-m00.3)
(make-module-eval
(module m00.3 "../persistent-interaction.ss"
(define (id x) x)
(module m00.3 "../lang.ss"
(define (foo x) 'foo)
(foo (start-interaction id))))])
(provide start)
(define (start initial)
(foo initial))))])
(go)
(assert eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(make-test-case
"identity interaction, dispatch-start called multiple times"
(let ([test-m00
(let-values ([(go test-m00)
(make-module-eval
(module m00 "../persistent-interaction.ss"
(module m00 "../lang.ss"
(define (id x) x)
(id (start-interaction id))))])
(provide start)
(define (start initial)
(id initial))))])
(go)
(assert = 7 (test-m00 '(dispatch-start 7)))
(assert eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
(make-test-case
"start-interaction in argument position of a primitive"
(let ([test-m00.1
(let-values ([(go test-m00.1)
(make-module-eval
(module m00.1 "../persistent-interaction.ss"
(define (id x) x)
(+ 1 (start-interaction id))))])
(module m00.1 "../lang.ss"
(provide start)
(define (start initial)
(+ 1 initial))))])
(go)
(assert = 2 (test-m00.1 '(dispatch-start 1)))))
(make-test-case
"dispatch-start called multiple times for s-i in non-trivial context"
(let ([test-m00.2
(let-values ([(go test-m00.2)
(make-module-eval
(module m00.2 "../persistent-interaction.ss"
(define (id x) x)
(+ (+ 1 1) (start-interaction id))))])
(module m00.2 "../lang.ss"
(provide start)
(define (start initial)
(+ (+ 1 1) initial))))])
(go)
(assert = 14 (test-m00.2 '(dispatch-start 12)))
(assert = 20 (test-m00.2 '(dispatch-start 18)))))
(make-test-case
"start-interaction in third position"
(let ([test-m01
(let-values ([(go test-m01)
(make-module-eval
(module m01 "../persistent-interaction.ss"
(define (id x) x)
(+ (* 1 2) (* 3 4) (start-interaction id))))])
(module m01 "../lang.ss"
(provide start)
(define (start initial)
(+ (* 1 2) (* 3 4) initial))))])
(go)
(assert = 14 (test-m01 '(dispatch-start 0)))
(assert = 20 (test-m01 '(dispatch-start 6)))))
(make-test-case
"quasi-quote with splicing: need to recertify context for qq-append"
(let ([test-m01.1
(let-values ([(go test-m01.1)
(make-module-eval
(module m01.1 "../persistent-interaction.ss"
(define (id x) x)
`(,@(list 1 2 (start-interaction id)))))])
(module m01.1 "../lang.ss"
(provide start)
(define (start initial)
`(,@(list 1 2 initial)))))])
(go)
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(make-test-case
"recertify context test (1)"
(let ([test-m01.2
(let-values ([(go test-m01.2)
(make-module-eval
(module m01.1 "../persistent-interaction.ss"
(module m01.1 "../lang.ss"
`(foo ,@(list 1 2 3))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (2)"
(let ([test-m01.3
(let-values ([(go test-m01.3)
(make-module-eval
(module m01.3 "../persistent-interaction.ss"
(module m01.3 "../lang.ss"
(lambda (n)
`(n ,@(list 1 2 3)))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (3)"
(let ([test-m01.4
(let-values ([(go test-m01.4)
(make-module-eval
(module m1 "../persistent-interaction.ss"
(module m1 "../lang.ss"
(define (bar n)
`(n ,@(list 1 2 3)))
(bar 7)))])
(go)
(assert-true #t)))
;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction
;; continuation with the latest one.
(make-test-case
"start-interaction called twice, dispatch-start will invoke different continuations"
(let ([test-m02
(make-module-eval
(module m02 "../persistent-interaction.ss"
(define (id x) x)
(+ (start-interaction id)
(start-interaction id))))])
(assert-true (void? (test-m02 '(dispatch-start 1))))
(assert = 3 (test-m02 '(dispatch-start 2)))
(assert = 0 (test-m02 '(dispatch-start -1))))))
; XXX We have taken this power away.
#;(make-test-case
"start-interaction called twice, dispatch-start will invoke different continuations"
(let ([test-m02
(make-module-eval
(module m02 "../persistent-interaction.ss"
(define (id x) x)
(+ (start-interaction id)
(start-interaction id))))])
(assert-true (void? (test-m02 '(dispatch-start 1))))
(assert = 3 (test-m02 '(dispatch-start 2)))
(assert = 0 (test-m02 '(dispatch-start -1))))))
@ -156,14 +165,14 @@
(make-test-case
"continuation invoked in non-trivial context from within proc"
(let ([test-m03
(let-values ([(go test-m03)
(make-module-eval
(module m03 "../persistent-interaction.ss"
(define (f x)
(module m03 "../lang.ss"
(provide start)
(define (start x)
(let/cc k
(+ 2 4 (k 3) 6 8)))
(f (start-interaction (lambda (x) x)))))])
(+ 2 4 (k 3) 6 8)))))])
(go)
(assert = 3 (test-m03 '(dispatch-start 'foo)))
(assert = 3 (test-m03 '(dispatch-start 7)))))
@ -172,20 +181,19 @@
;; see that this is not tail recursive
(make-test-case
"non-tail-recursive 'escaping' continuation"
(let ([test-m04
(let-values ([(go test-m04)
(make-module-eval
(module m04 "../persistent-interaction.ss"
(define (mult ln)
(module m04 "../lang.ss"
(provide start)
(define (start ln)
(let/cc k
(cond
[(null? ln) 1]
[(zero? (car ln)) (k 0)]
[else
(* (car ln)
(mult (cdr ln)))])))
(mult (start-interaction (lambda (x) x)))))])
(start (cdr ln)))])))))])
(go)
(assert = 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))))))
@ -195,12 +203,12 @@
;; as expected.
(make-test-case
"tail-recursive escaping continuation"
(let ([test-m05
(let-values ([(go test-m05)
(make-module-eval
(module m05 "../persistent-interaction.ss"
(provide mult)
(module m05 "../lang.ss"
(provide start)
(define (mult ln)
(define (start ln)
(let/cc escape
(mult/escape escape ln)))
@ -210,10 +218,8 @@
[(zero? (car ln)) (escape 0)]
[else
(* (car ln)
(mult/escape escape (cdr ln)))]))
(mult (start-interaction (lambda (x) x)))))])
(mult/escape escape (cdr ln)))]))))])
(go)
(assert = 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)))))))
@ -223,7 +229,8 @@
(make-test-suite
"Tests Involving send/suspend"
(make-test-case
; XXX This doesn't work, because we don't allow a different dispatcher
#;(make-test-case
"curried add with send/suspend"
(let ([table-01-eval
(make-module-eval
@ -238,11 +245,11 @@
(hash-table-put! the-table key k)
key))
(define (lookup-k key-pair)
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
(table-01-eval
'(module m06 "../persistent-interaction.ss"
'(module m06 "../lang.ss"
(require table01)
(provide start)
(define (gn which)
(cadr
@ -251,18 +258,14 @@
(let ([ignore (printf "Please send the ~a number.~n" which)])
(store-k k))))))
(let ([ignore (start-interaction lookup-k)])
(define (start ignore)
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))
(table-01-eval '(require m06))
result)))))
(table-01-eval '(require m06))
(let* ([first-key (table-01-eval '(dispatch-start 'foo))]
[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))))
(assert = 4 (table-01-eval `(dispatch '(,second-key 3))))
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
@ -272,11 +275,10 @@
(make-test-case
"curried with send/suspend and serializaztion"
(let ([test-m06.1
(let-values ([(go test-m06.1)
(make-module-eval
(module m06.1 (lib "persistent-interaction.ss" "web-server" "prototype-web-server")
(define (id x) x)
(module m06.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (gn which)
(cadr
(send/suspend
@ -284,11 +286,11 @@
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(define (start ignore)
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))])
result)))))])
(go)
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))])
@ -297,10 +299,7 @@
(assert = 4 (test-m06.1 `(dispatch (list ,second-key 3))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,second-key -1)))))
(assert = -7 (test-m06.1 `(dispatch (list ,third-key 0))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,third-key 7)))))))))
)
(assert-true (zero? (test-m06.1 `(dispatch (list ,third-key 7))))))))))
;; ****************************************
;; ****************************************
@ -310,19 +309,19 @@
(make-test-case
"mutually recursive even? and odd?"
(let ([test-m07
(let-values ([(go test-m07)
(make-module-eval
(module m07 "../persistent-interaction.ss"
(define (id x) x)
(letrec ([even? (lambda (n)
(or (zero? n)
(odd? (sub1 n))))]
[odd? (lambda (n)
(and (not (zero? n))
(even? (sub1 n))))])
(even? (start-interaction id)))))])
(module m07 "../lang.ss"
(provide start)
(define (start initial)
(letrec ([even? (lambda (n)
(or (zero? n)
(odd? (sub1 n))))]
[odd? (lambda (n)
(and (not (zero? n))
(even? (sub1 n))))])
(even? initial)))))])
(go)
(assert-true (test-m07 '(dispatch-start 0)))
(assert-true (test-m07 '(dispatch-start 16)))
(assert-false (test-m07 '(dispatch-start 1)))
@ -330,11 +329,10 @@
(make-test-case
"send/suspend on rhs of letrec binding forms"
(let ([test-m08
(let-values ([(go test-m08)
(make-module-eval
(module m08 "../persistent-interaction.ss"
(define (id x) x)
(module m08 "../lang.ss"
(provide start)
(define (gn which)
(cadr
(send/suspend
@ -342,7 +340,7 @@
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(define (start ignore)
(letrec ([f (let ([n (gn "first")])
(lambda (m) (+ n m)))]
[g (let ([n (gn "second")])
@ -350,6 +348,7 @@
(let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result))))))])
(go)
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
[k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))])
@ -358,8 +357,7 @@
(let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))]
[k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))])
(assert-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3)))))
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))))))
)
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))))))))
;; ****************************************
;; ****************************************
@ -367,10 +365,11 @@
(make-test-suite
"Unsafe Context Condition Tests"
(make-test-case
; XXX Bizarre
#;(make-test-case
"simple attempt to capture a continuation from an unsafe context"
(let ([nta-eval
(let-values ([(go nta-eval)
(make-module-eval
(module nta mzscheme
(provide non-tail-apply)
@ -379,55 +378,52 @@
(let ([result (apply f args)])
(printf "result = ~s~n" result)
result))))])
(nta-eval '(module m09 "../persistent-interaction.ss"
(nta-eval '(module m09 "../lang.ss"
(require nta)
(define (id x) x)
(let ([ignore (start-interaction id)])
(provide start)
(define (start ignore)
(non-tail-apply (lambda (x) (let/cc k (k x))) 7))))
(nta-eval '(require m09))
(assert-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start 'foo)))))))
(make-test-case
"sanity-check: capture continuation from safe version of context"
(let ([m10-eval
(let-values ([(go m10-eval)
(make-module-eval
(module m10 "../persistent-interaction.ss"
(define (id x) x)
(module m10 "../lang.ss"
(provide start)
(define (nta f arg)
(let ([result (f arg)])
(printf "result = ~s~n" result)
result))
(let ([ignore (start-interaction id)])
(nta (lambda (x) (let/cc k (k x))) 7))))])
(define (start ignore)
(nta (lambda (x) (let/cc k (k x))) 7))))])
(go)
(assert = 7 (m10-eval '(dispatch-start 'foo)))))
(make-test-case
"attempt continuation capture from standard call to map"
(let ([m11-eval
(let-values ([(go m11-eval)
(make-module-eval
(module m11 "../persistent-interaction.ss"
(define (id x) x)
(let ([ignore (start-interaction id)])
(module m11 "../lang.ss"
(provide start)
(define (start ignore)
(map
(lambda (x) (let/cc k k))
(list 1 2 3)))))])
(list 1 2 3)))))])
(go)
(assert-true (catch-unsafe-context-exn
(lambda () (m11-eval '(dispatch-start 'foo)))))))
;; if the continuation-capture is attempted in tail position then we
;; should be just fine.
(make-test-case
; XXX Weird
#;(make-test-case
"continuation capture from tail position of untranslated procedure"
(let ([ta-eval
@ -438,12 +434,12 @@
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m12 "../persistent-interaction.ss"
(ta-eval '(module m12 "../lang.ss"
(require ta)
(define (id x) x)
(+ (start-interaction id)
(tail-apply (lambda (x) (let/cc k (k x))) 1))))
(provide start)
(define (start initial)
(+ initial
(tail-apply (lambda (x) (let/cc k (k x))) 1)))))
(ta-eval '(require m12))
@ -452,37 +448,37 @@
(make-test-case
"attempt send/suspend from standard call to map"
(let ([m13-eval
(let-values ([(go m13-eval)
(make-module-eval
(module m11 "../persistent-interaction.ss"
(define (id x) x)
(let ([ignore (start-interaction car)])
(module m11 "../lang.ss"
(provide start)
(define (start initial)
(map
(lambda (n) (send/suspend
(lambda (k)
(let ([ignore (printf "n = ~s~n" n)])
k))))
(list 1 2 3)))))])
(go)
(assert-true (catch-unsafe-context-exn
(lambda () (m13-eval '(dispatch-start 'foo)))))))
(make-test-case
; XXX Weird
#;(make-test-case
"attempt send/suspend from tail position of untranslated procedure"
(let ([ta-eval
(let-values ([(go ta-eval)
(make-module-eval
(module ta mzscheme
(provide tail-apply)
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m14 "../persistent-interaction.ss"
(ta-eval '(module m14 "../lang.ss"
(require ta)
(let ([ignore (start-interaction car)])
(provide start)
(define (start ignore)
(+ 1 (tail-apply
(lambda (n)
(cadr
@ -494,8 +490,4 @@
(let ([k0 (ta-eval '(dispatch-start 'foo))])
(assert = 3 (ta-eval `(dispatch (list ,k0 2))))
(assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))
))))
(assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))

34
collects/web-server/prototype-web-server/tests/test-normalizer.ss
View File

@ -1,6 +1,6 @@
(module test-normalizer mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"../normalizer.ss")
"../lang/anormal.ss")
(provide test-normalizer-suite)
(define (empty-env var)
@ -101,6 +101,8 @@
(define (alpha= expr1 expr2)
(alpha=/env empty-env empty-env expr1 expr2))
(define normalize-term (make-anormal-term (lambda _ (error 'anormal "No elim-letrec given."))))
(define-syntax (check-unsupported-lambda stx)
(syntax-case stx ()
[(_ expr)
@ -111,6 +113,14 @@
#t))])
expr)]))
(define-syntax (check-supported stx)
(syntax-case stx ()
[(_ expr)
#'(with-handlers ([(lambda (x) #t)
(lambda (the-exn) #f)])
expr
#t)]))
(define-syntax (check-unsupported-let stx)
(syntax-case stx ()
[(_ expr)
@ -158,7 +168,7 @@
(make-test-case
"one-armed-if"
(assert alpha= (normalize-term (expand (syntax (if #t 1))))
(expand (syntax (if #t 1)))))
(expand (syntax (if #t 1 (void))))))
(make-test-case
@ -202,7 +212,7 @@
(make-test-case
"one-armed if with prim-app in test posn"
(assert alpha= (normalize-term (expand (syntax (if (+ 1 2) 3))))
(expand (syntax ((lambda (x) (if x 3)) (+ 1 2))))))
(expand (syntax ((lambda (x) (if x 3 (void))) (+ 1 2))))))
(make-test-case
"two-armed if with prim-app in test posn"
@ -283,26 +293,24 @@
(make-test-suite
"Check that certain errors are raised"
; this is supported now
#;(make-test-case
; XXX Turn these tests into checking versions
(make-test-case
"multiple body expressions in lambda"
(assert-true (check-unsupported-lambda
(assert-true (check-supported
(normalize-term (expand (syntax (lambda (x y z) 3 4)))))))
(make-test-case
"zero-or-more argument lambda"
(assert-true (check-unsupported-lambda
(assert-true (check-supported
(normalize-term (expand (syntax (lambda x x)))))))
; this is supported now
#; (make-test-case
(make-test-case
"multi-valued let-values"
(assert-true (check-unsupported-let
(assert-true (check-supported
(normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y))))))))
; this is supported now
#; (make-test-case
(make-test-case
"let/multiple clauses before body"
(assert-true (check-unsupported-let
(assert-true (check-supported
(normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y)))))))))
(make-test-suite