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

V4 progress

Browse Source 
svn: r7799
This commit is contained in:
Jay McCarthy 2007-11-21 05:02:18 +00:00
parent ee790a9d44
commit 27e9d4640f
9 changed files with 401 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/tests/dispatchers/dispatch-lang-test.ss
View File

@ -1,6 +1,6 @@
(module dispatch-lang-test mzscheme (module dispatch-lang-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "dispatch.ss" "web-server" "dispatchers") (lib "dispatch.ss" "web-server" "dispatchers")
@ -10,6 +10,9 @@
"../util.ss") "../util.ss")
(provide dispatch-lang-tests) (provide dispatch-lang-tests)
; XXX Sxpath broken
(define sxpath (lambda _ (lambda _ (error 'sxpath))))
(define (mkd p) (define (mkd p)
(lang:make #:url->path (lambda _ (values p (list p))) (lang:make #:url->path (lambda _ (values p (list p)))
#:make-servlet-namespace #:make-servlet-namespace

6
collects/web-server/tests/dispatchers/dispatch-passwords-test.ss
View File

@ -4,6 +4,7 @@
(lib "file.ss") (lib "file.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "list.ss") (lib "list.ss")
(lib "serialize.ss")
(lib "request-structs.ss" "web-server" "private") (lib "request-structs.ss" "web-server" "private")
(lib "dispatch.ss" "web-server" "dispatchers") (lib "dispatch.ss" "web-server" "dispatchers")
(prefix passwords: (lib "dispatch-passwords.ss" "web-server" "dispatchers")) (prefix passwords: (lib "dispatch-passwords.ss" "web-server" "dispatchers"))
@ -52,8 +53,9 @@
exn:dispatcher? exn:dispatcher?
(lambda () (runt #t #t))) (lambda () (runt #t #t)))
(test-equal? "not authorized" (test-equal? "not authorized"
(runt #t #f) (let ([v (runt #t #f)])
`(WWW-Authenticate . " Basic realm=\"secret stuff\"")) (list (header-field v) (header-value v)))
(list #"WWW-Authenticate" #" Basic realm=\"secret stuff\""))
(test-exn "does not apply" (test-exn "does not apply"
exn:dispatcher? exn:dispatcher?
(lambda () (lambda ()

5
collects/web-server/tests/dispatchers/dispatch-servlets-test.ss
View File

@ -1,6 +1,6 @@
(module dispatch-servlets-test mzscheme (module dispatch-servlets-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "request-structs.ss" "web-server" "private") (lib "request-structs.ss" "web-server" "private")
@ -11,6 +11,9 @@
"../util.ss") "../util.ss")
(provide dispatch-servlets-tests) (provide dispatch-servlets-tests)
; XXX Sxpath broken
(define sxpath (lambda _ (lambda _ (error 'sxpath))))
(current-server-custodian (current-custodian)) (current-server-custodian (current-custodian))
(define (mkd p) (define (mkd p)

16
collects/web-server/tests/lang-test.ss
View File

@ -222,7 +222,7 @@
(hash-table-get the-table (car key-pair) (lambda () #f)))))]) (hash-table-get the-table (car key-pair) (lambda () #f)))))])
(table-01-eval (table-01-eval
'(module m06 (lib "lang.ss" "web-server") '(module m06 (lib "lang.ss" "web-server")
(require table01) (require 'table01)
(provide start) (provide start)
(define (gn which) (define (gn which)
@ -236,7 +236,7 @@
(let ([result (+ (gn "first") (gn "second"))]) (let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s~n" result)])
result))))) result)))))
(table-01-eval '(require m06)) (table-01-eval '(require 'm06))
(let* ([first-key (table-01-eval '(dispatch-start start 'foo))] (let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
[second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))] [second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
[third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))]) [third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
@ -391,12 +391,12 @@
(printf "result = ~s~n" result) (printf "result = ~s~n" result)
result))))]) result))))])
(nta-eval '(module m09 (lib "lang.ss" "web-server") (nta-eval '(module m09 (lib "lang.ss" "web-server")
(require nta) (require 'nta)
(provide start) (provide start)
(define (start ignore) (define (start ignore)
(non-tail-apply (lambda (x) (let/cc k (k x))) 7)))) (non-tail-apply (lambda (x) (let/cc k (k x))) 7))))
(nta-eval '(require m09)) (nta-eval '(require 'm09))
(check-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start start 'foo))))))) (lambda () (nta-eval '(dispatch-start start 'foo)))))))
@ -444,13 +444,13 @@
(apply f args))))]) (apply f args))))])
(ta-eval '(module m12 (lib "lang.ss" "web-server") (ta-eval '(module m12 (lib "lang.ss" "web-server")
(require ta) (require 'ta)
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ initial (+ initial
(tail-apply (lambda (x) (let/cc k (k x))) 1))))) (tail-apply (lambda (x) (let/cc k (k x))) 1)))))
(ta-eval '(require m12)) (ta-eval '(require 'm12))
(check = 2 (ta-eval '(dispatch-start start 1))))) (check = 2 (ta-eval '(dispatch-start start 1)))))
@ -483,7 +483,7 @@
(apply f args))))]) (apply f args))))])
(ta-eval '(module m14 (lib "lang.ss" "web-server") (ta-eval '(module m14 (lib "lang.ss" "web-server")
(require ta) (require 'ta)
(provide start) (provide start)
(define (start ignore) (define (start ignore)
(+ 1 (tail-apply (+ 1 (tail-apply
@ -493,7 +493,7 @@
(lambda (k) (lambda (k)
(let ([ignore (printf "n = ~s~n" n)]) (let ([ignore (printf "n = ~s~n" n)])
k))))) 7))))) k))))) 7)))))
(ta-eval '(require m14)) (ta-eval '(require 'm14))
(let ([k0 (ta-eval '(dispatch-start start 'foo))]) (let ([k0 (ta-eval '(dispatch-start start 'foo))])
(check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2)))) (check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2))))

242
collects/web-server/tests/lang/anormal-test.ss
View File

@ -1,13 +1,13 @@
(module anormal-test mzscheme #lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "anormal.ss" "web-server" "lang") (lib "anormal.ss" "web-server" "lang")
(lib "util.ss" "web-server" "lang")) (lib "util.ss" "web-server" "lang"))
(provide anormal-tests) (provide anormal-tests)
(define (empty-env var) (define (empty-env var)
(error "empty environment")) (error "empty environment"))
(define (extend env vars vals) (define (extend env vars vals)
(lambda (var0) (lambda (var0)
(let loop ([vars vars] (let loop ([vars vars]
[vals vals]) [vals vals])
@ -17,24 +17,19 @@
(car vals)] (car vals)]
[else (loop (cdr vars) (cdr vals))])))) [else (loop (cdr vars) (cdr vals))]))))
;; alpha=/env: environment target-expr target-expr -> boolean ;; alpha=/env: environment target-expr target-expr -> boolean
;; are two target expressions alpha-equivalent? ;; are two target expressions alpha-equivalent?
(define (alpha=/env env1 env2 expr1 expr2) (define (alpha=/env env1 env2 expr1 expr2)
(syntax-case expr1 (if #%app) (syntax-case expr1 (if #%plain-app)
[(if tst1 csq1)
(syntax-case expr2 (if)
[(if tst2 csq2) (and (alpha=/env env1 env2 #'tst1 #'tst2)
(alpha=/env env1 env2 #'csq1 #'csq2))]
[_else #f])]
[(if tst1 csq1 alt1) [(if tst1 csq1 alt1)
(syntax-case expr2 (if) (syntax-case expr2 (if)
[(if tst2 csq2 alt2) (and (alpha=/env env1 env2 #'tst1 #'tst2) [(if tst2 csq2 alt2) (and (alpha=/env env1 env2 #'tst1 #'tst2)
(alpha=/env env1 env2 #'csq1 #'csq2) (alpha=/env env1 env2 #'csq1 #'csq2)
(alpha=/env env1 env2 #'alt1 #'alt2))] (alpha=/env env1 env2 #'alt1 #'alt2))]
[_else #f])] [_else #f])]
[(#%app rator1 rands1 ...) [(#%plain-app rator1 rands1 ...)
(syntax-case expr2 (#%app) (syntax-case expr2 (#%plain-app)
[(#%app rator2 rands2 ...) [(#%plain-app rator2 rands2 ...)
(and (alpha=/env env1 env2 #'rator1 #'rator2) (and (alpha=/env env1 env2 #'rator1 #'rator2)
(let loop ([rs1 (syntax->list #'(rands1 ...))] (let loop ([rs1 (syntax->list #'(rands1 ...))]
[rs2 (syntax->list #'(rands2 ...))]) [rs2 (syntax->list #'(rands2 ...))])
@ -42,36 +37,31 @@
(null? rs2)) (null? rs2))
(and (alpha=/env env1 env2 (car rs1) (car rs2)) (and (alpha=/env env1 env2 (car rs1) (car rs2))
(loop (cdr rs1) (cdr rs2))))))] (loop (cdr rs1) (cdr rs2))))))]
[_else #f])] [_else
(raise-syntax-error 'alpha=/env "Dropped through on #%plain-app:" expr2)
#f])]
[_else (w-alpha=/env env1 env2 expr1 expr2)])) [_else (w-alpha=/env env1 env2 expr1 expr2)]))
;; w-alpha=/env: env target-expr target-expr -> boolean ;; w-alpha=/env: env target-expr target-expr -> boolean
;; are two target vars or vals alpha-equivalent? ;; are two target vars or vals alpha-equivalent?
(define (w-alpha=/env env1 env2 expr1 expr2) (define (w-alpha=/env env1 env2 expr1 expr2)
(syntax-case expr1 (#%top #%datum lambda quote) (syntax-case expr1 (#%top #%plain-lambda quote)
[(#%top . var1) [(#%top . var1)
(syntax-case expr2 (#%top) (syntax-case expr2 (#%top)
[(#%top . var2) [(#%top . var2)
(eqv? (syntax-object->datum #'var1) (eqv? (syntax->datum #'var1)
(syntax-object->datum #'var2))] (syntax->datum #'var2))]
[_else #f])]
[(#%datum . datum1)
(syntax-case expr2 (#%datum)
[(#%datum . datum2)
(let ([dat1 (syntax-object->datum #'datum1)]
[dat2 (syntax-object->datum #'datum2)])
(eqv? dat1 dat2))]
[_else #f])] [_else #f])]
[(quote datum1) [(quote datum1)
(syntax-case expr2 (quote) (syntax-case expr2 (quote)
[(quote datum2) [(quote datum2)
(let ([dat1 (syntax-object->datum #'datum1)] (let ([dat1 (syntax->datum #'datum1)]
[dat2 (syntax-object->datum #'datum2)]) [dat2 (syntax->datum #'datum2)])
(equal? dat1 dat2))] (equal? dat1 dat2))]
[_else #f])] [_else #f])]
[(lambda formals1 body1) [(#%plain-lambda formals1 body1)
(syntax-case expr2 (lambda) (syntax-case expr2 (#%plain-lambda)
[(lambda formals2 body2) [(#%plain-lambda formals2 body2)
(let ([syms (map gensym (syntax->symbols (formals-list #'formals1)))]) (let ([syms (map gensym (syntax->symbols (formals-list #'formals1)))])
(and (= (length syms) (length (formals-list #'formals2))) (and (= (length syms) (length (formals-list #'formals2)))
(alpha=/env (alpha=/env
@ -79,35 +69,37 @@
(extend env2 (syntax->symbols (formals-list #'formals2)) syms) (extend env2 (syntax->symbols (formals-list #'formals2)) syms)
#'body1 #'body2)))] #'body1 #'body2)))]
[_else #f])] [_else #f])]
[x1 (symbol? (syntax-object->datum #'x1)) [x1 (symbol? (syntax->datum #'x1))
(syntax-case expr2 () (syntax-case expr2 ()
[x2 (symbol? (syntax-object->datum #'x2)) [x2 (symbol? (syntax->datum #'x2))
(or (module-identifier=? #'x1 #'x2) (or (free-identifier=? #'x1 #'x2)
(eqv? (env1 (syntax-object->datum #'x1)) (eqv? (env1 (syntax->datum #'x1))
(env2 (syntax-object->datum #'x2))))] (env2 (syntax->datum #'x2))))]
[_else #f])] [_else #f])]
[_else #f])) [_else
(raise-syntax-error 'alpha= "Dropped through:" expr1)
#f]))
;; convert syntax into a list of symbols ;; convert syntax into a list of symbols
(define (syntax->symbols stx) (define (syntax->symbols stx)
(syntax-case stx () (syntax-case stx ()
[(vars ...) [(vars ...)
(map (map
(lambda (s) (lambda (s)
(syntax-object->datum s)) (syntax->datum s))
(syntax->list #'(vars ...)))])) (syntax->list #'(vars ...)))]))
;; alph=: target-expr target-expr -> boolean ;; alph=: target-expr target-expr -> boolean
;; are two target expressions alpha-equivalent? ;; are two target expressions alpha-equivalent?
(define (alpha= expr1 expr2) (define (alpha= expr1 expr2)
(define r (alpha=/env empty-env empty-env expr1 expr2)) (define r (alpha=/env empty-env empty-env expr1 expr2))
(unless r (unless r
(error 'alpha= "Not alpha=:\t~S~n\t~S~n" (syntax-object->datum expr1) (syntax-object->datum expr2))) (error 'alpha= "Not alpha=:\t~S~n\t~S~n" (syntax->datum expr1) (syntax->datum expr2)))
r) r)
(define normalize-term (make-anormal-term (lambda _ (error 'anormal "No elim-letrec given.")))) (define normalize-term (make-anormal-term (lambda _ (error 'anormal "No elim-letrec given."))))
(define anormal-tests (define anormal-tests
(test-suite (test-suite
"Anormalization" "Anormalization"
(test-suite (test-suite
@ -115,92 +107,81 @@
(test-case (test-case
"Top level identifier" "Top level identifier"
(check alpha= (normalize-term (expand (syntax car))) (check alpha= (normalize-term (expand-syntax (syntax car)))
(expand (syntax car)))) (expand-syntax (syntax car))))
(test-case (test-case
"Simple arithmetic expression" "Simple arithmetic expression"
(check alpha= (normalize-term (expand (syntax (+ 1 1)))) (check alpha= (normalize-term (expand-syntax (syntax (+ 1 1))))
(expand (syntax (+ 1 1))))) (expand-syntax (syntax (+ 1 1)))))
(test-case (test-case
"lambda-expression with constant body" "lambda-expression with constant body"
(check alpha= (normalize-term (expand (syntax (lambda (x) 3)))) (check alpha= (normalize-term (expand-syntax (syntax (lambda (x) 3))))
(expand (syntax (lambda (x) 3))))) (expand-syntax (syntax (lambda (x) 3)))))
(test-case (test-case
"lambda-expression with var-ref body" "lambda-expression with var-ref body"
(check alpha= (normalize-term (expand (syntax (lambda (x) x)))) (check alpha= (normalize-term (expand-syntax (syntax (lambda (x) x))))
(expand (syntax (lambda (x) x))))) (expand-syntax (syntax (lambda (x) x)))))
(test-case (test-case
"lambda-expression/constant-body/multiple formals" "lambda-expression/constant-body/multiple formals"
(check alpha= (normalize-term (expand (syntax (lambda (x y z) 3)))) (check alpha= (normalize-term (expand-syntax (syntax (lambda (x y z) 3))))
(expand (syntax (lambda (x y z) 3))))) (expand-syntax (syntax (lambda (x y z) 3)))))
(test-case
"one-armed-if"
(check alpha= (normalize-term (expand (syntax (if #t 1))))
(expand (syntax (if #t 1 (void))))))
(test-case (test-case
"two-armed-if" "two-armed-if"
(check alpha= (normalize-term (expand (syntax (if #t 1 2)))) (check alpha= (normalize-term (expand-syntax (syntax (if #t 1 2))))
(expand (syntax (if #t 1 2))))) (expand-syntax (syntax (if #t 1 2)))))
(test-case (test-case
"let/var-ref in body" "let/var-ref in body"
(check alpha= (normalize-term (expand (syntax (let ([x 1]) x)))) (check alpha= (normalize-term (expand-syntax (syntax (let ([x 1]) x))))
(expand (syntax ((lambda (x) x) 1))))) (expand-syntax (syntax ((lambda (x) x) 1)))))
(test-case (test-case
"call to void" "call to void"
(check alpha= (normalize-term (expand (syntax (void)))) (check alpha= (normalize-term (expand-syntax (syntax (void))))
(expand (syntax (void))))) (expand-syntax (syntax (void)))))
(test-case (test-case
"primitive application/multiple arguments" "primitive application/multiple arguments"
(check alpha= (normalize-term (expand (syntax (+ 1 2 3)))) (check alpha= (normalize-term (expand-syntax (syntax (+ 1 2 3))))
(expand (syntax (+ 1 2 3))))) (expand-syntax (syntax (+ 1 2 3)))))
(test-case (test-case
"empty-list" "empty-list"
(check alpha= (normalize-term (expand (syntax ()))) (check alpha= (normalize-term (expand-syntax (syntax ())))
(expand (syntax ())))) (expand-syntax (syntax ()))))
(test-case (test-case
"quoted list of constants" "quoted list of constants"
(check alpha= (normalize-term (expand (syntax '(1 2 3)))) (check alpha= (normalize-term (expand-syntax (syntax '(1 2 3))))
(expand (syntax '(1 2 3)))))) (expand-syntax (syntax '(1 2 3))))))
(test-suite (test-suite
"Inductive Cases" "Inductive Cases"
(test-case (test-case
"nested primitive applications with multiple arguments" "nested primitive applications with multiple arguments"
(check alpha= (normalize-term (expand (syntax (* (+ 1 2) 3)))) (check alpha= (normalize-term (expand-syntax (syntax (* (+ 1 2) 3))))
(expand (syntax ((lambda (x) (* x 3)) (+ 1 2)))))) (expand-syntax (syntax ((lambda (x) (* x 3)) (+ 1 2))))))
(test-case
"one-armed if with prim-app in test posn"
(check alpha= (normalize-term (expand (syntax (if (+ 1 2) 3))))
(expand (syntax ((lambda (x) (if x 3 (void))) (+ 1 2))))))
(test-case (test-case
"two-armed if with prim-app in test posn" "two-armed if with prim-app in test posn"
(check alpha= (normalize-term (expand (syntax (if (+ 1 2) 3 4)))) (check alpha= (normalize-term (expand-syntax (syntax (if (+ 1 2) 3 4))))
(expand (syntax ((lambda (x) (if x 3 4)) (+ 1 2)))))) (expand-syntax (syntax ((lambda (x) (if x 3 4)) (+ 1 2))))))
(test-case (test-case
"nested single argument primitive applications" "nested single argument primitive applications"
(check alpha= (normalize-term (expand (syntax (* (+ 1))))) (check alpha= (normalize-term (expand-syntax (syntax (* (+ 1)))))
(expand (syntax ((lambda (x0) (* x0)) (+ 1)))))) (expand-syntax (syntax ((lambda (x0) (* x0)) (+ 1))))))
(test-case (test-case
"deeply nested primitive applications" "deeply nested primitive applications"
(check alpha= (normalize-term (expand (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6))))) (check alpha= (normalize-term (expand-syntax (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6)))))
(expand (syntax ((lambda (x0) (expand-syntax (syntax ((lambda (x0)
((lambda (x1) ((lambda (x1)
((lambda (x2) ((lambda (x2)
((lambda (x3) (* x2 x3)) ((lambda (x3) (* x2 x3))
@ -211,8 +192,8 @@
(test-case (test-case
"deeply nested primitive applications" "deeply nested primitive applications"
(check alpha= (normalize-term (expand (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4))))))) (check alpha= (normalize-term (expand-syntax (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4)))))))
(expand (syntax ((lambda (x0) (expand-syntax (syntax ((lambda (x0)
((lambda (x1) ((lambda (x1)
((lambda (x2) ((lambda (x2)
((lambda (x3) ((lambda (x3)
@ -224,41 +205,41 @@
(test-case (test-case
"if nested in test position" "if nested in test position"
(check alpha= (normalize-term (expand (syntax (if (if #t #f #t) #t #t)))) (check alpha= (normalize-term (expand-syntax (syntax (if (if #t #f #t) #t #t))))
(expand (syntax ((lambda (x) (if x #t #t)) (if #t #f #t)))))) (expand-syntax (syntax ((lambda (x) (if x #t #t)) (if #t #f #t))))))
(test-case (test-case
"procedure/body has nested if" "procedure/body has nested if"
(check alpha= (normalize-term (expand (syntax (lambda (x) (if (if x 1 2) 3 4))))) (check alpha= (normalize-term (expand-syntax (syntax (lambda (x) (if (if x 1 2) 3 4)))))
(expand (syntax (lambda (x) (expand-syntax (syntax (lambda (x)
((lambda (y0) (if y0 3 4)) ((lambda (y0) (if y0 3 4))
(if x 1 2))))))) (if x 1 2)))))))
(test-case (test-case
"constant 0-arg procedure application" "constant 0-arg procedure application"
(check alpha= (normalize-term (expand (syntax ((lambda () 3))))) (check alpha= (normalize-term (expand-syntax (syntax ((lambda () 3)))))
(expand (syntax ((lambda () 3)))))) (expand-syntax (syntax ((lambda () 3))))))
(test-case (test-case
"if with function application in test" "if with function application in test"
(check alpha= (normalize-term (expand (syntax (if ((lambda () 7)) 1 2)))) (check alpha= (normalize-term (expand-syntax (syntax (if ((lambda () 7)) 1 2))))
(expand (syntax ((lambda (x) (if x 1 2)) (expand-syntax (syntax ((lambda (x) (if x 1 2))
((lambda () 7))))))) ((lambda () 7)))))))
(test-case (test-case
"if with lambda-expression in consequent and alternative" "if with lambda-expression in consequent and alternative"
(check alpha= (normalize-term (expand (syntax ((if #t (lambda () 1) (lambda () 2)))))) (check alpha= (normalize-term (expand-syntax (syntax ((if #t (lambda () 1) (lambda () 2))))))
(expand (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2))))))) (expand-syntax (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2)))))))
(test-case (test-case
"call/cc with value argument" "call/cc with value argument"
(check alpha= (normalize-term (expand (syntax (call/cc (lambda (x) x))))) (check alpha= (normalize-term (expand-syntax (syntax (call/cc (lambda (x) x)))))
(expand (syntax (call/cc (lambda (x) x)))))) (expand-syntax (syntax (call/cc (lambda (x) x))))))
(test-case (test-case
"call/cc with complex expression in argument" "call/cc with complex expression in argument"
(check alpha= (normalize-term (expand (syntax (call/cc (f (g 7)))))) (check alpha= (normalize-term (expand-syntax (syntax (call/cc (f (g 7))))))
(expand (syntax ((lambda (x0) (expand-syntax (syntax ((lambda (x0)
((lambda (x1) (call/cc x1)) ((lambda (x1) (call/cc x1))
(f x0))) (f x0)))
(g 7))))))) (g 7)))))))
@ -268,25 +249,25 @@
(test-case (test-case
"multiple body expressions in lambda" "multiple body expressions in lambda"
(check alpha= (normalize-term (expand (syntax (lambda (x y z) 3 4)))) (check alpha= (normalize-term (expand-syntax (syntax (lambda (x y z) 3 4))))
(expand (syntax (lambda (x y z) (expand-syntax (syntax (lambda (x y z)
(call-with-values (lambda () 3) (call-with-values (lambda () 3)
(lambda throw-away 4))))))) (lambda throw-away 4)))))))
(test-case (test-case
"zero-or-more argument lambda" "zero-or-more argument lambda"
(check alpha= (normalize-term (expand (syntax (lambda x x)))) (check alpha= (normalize-term (expand-syntax (syntax (lambda x x))))
(expand (syntax (lambda x x))))) (expand-syntax (syntax (lambda x x)))))
(test-case (test-case
"multi-valued let-values" "multi-valued let-values"
(check alpha= (normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y))))) (check alpha= (normalize-term (expand-syntax (syntax (let-values ([(x y) (values 1 2)]) (+ x y)))))
(expand (syntax (call-with-values (lambda () (values 1 2)) (expand-syntax (syntax (call-with-values (lambda () (values 1 2))
(lambda (x y) (+ x y))))))) (lambda (x y) (+ x y)))))))
(test-case (test-case
"let/multiple clauses before body" "let/multiple clauses before body"
(check alpha= (normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y))))) (check alpha= (normalize-term (expand-syntax (syntax (let ([x 1] [y 2]) (+ x y)))))
(expand (syntax ((lambda (x) (expand-syntax (syntax ((lambda (x)
((lambda (y) ((lambda (y)
(+ x y)) (+ x y))
2)) 2))
@ -297,18 +278,18 @@
(test-case (test-case
"empty begin" "empty begin"
(check alpha= (normalize-term (expand (syntax (begin)))) (check alpha= (normalize-term (expand-syntax (syntax (begin))))
(syntax (#%app (#%top . void))))) (expand-syntax (syntax (void)))))
(test-case (test-case
"begin with one expression" "begin with one expression"
(check alpha= (normalize-term (expand (syntax (begin 1)))) (check alpha= (normalize-term (expand-syntax (syntax (begin 1))))
(syntax (#%datum . 1)))) (expand-syntax (syntax (quote 1)))))
(test-case (test-case
"begin with multiple expressions" "begin with multiple expressions"
(check alpha= (normalize-term (expand (syntax (begin 1 2 3)))) (check alpha= (normalize-term (expand-syntax (syntax (begin 1 2 3))))
(normalize-term (expand (syntax (call-with-values (normalize-term (expand-syntax (syntax (call-with-values
(lambda () 1) (lambda () 1)
(lambda throw-away (lambda throw-away
(call-with-values (call-with-values
@ -323,7 +304,7 @@
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (the-exn) #f)]) (lambda (the-exn) #f)])
(normalize-term (normalize-term
(expand (expand-syntax
(syntax (syntax
(cond (cond
[(null? l) 1] [(null? l) 1]
@ -332,9 +313,12 @@
(* (car l) (cdr l))]))))) (* (car l) (cdr l))])))))
#t))) #t)))
(test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y))))))) (test-not-exn "define-struct"
(test-not-exn "quote-syntax: #f" (lambda () (parameterize ([transformer? #f]) (lambda () (normalize-term (expand-syntax (syntax (define-struct posn (x y)))))))
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!)))))) (test-not-exn "quote-syntax: #f"
(test-not-exn "quote-syntax: #t" (lambda () (parameterize ([transformer? #t]) (lambda () (parameterize ([transformer? #f])
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!)))))) (normalize-term (expand-syntax (syntax #'provide/contract-id-set-a-date-day!))))))
)))) (test-not-exn "quote-syntax: #t"
(lambda () (parameterize ([transformer? #t])
(normalize-term (expand-syntax (syntax #'provide/contract-id-set-a-date-day!))))))
)))

12
collects/web-server/tests/lang/web-param-test.ss
View File

@ -1,14 +1,14 @@
(module web-param-test mzscheme #lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"../util.ss") "../util.ss")
(provide web-param-tests) (provide web-param-tests)
(define the-dispatch (define the-dispatch
`(lambda (k*v) `(lambda (k*v)
(lambda (k*v) (lambda (k*v)
((car k*v) k*v)))) ((car k*v) k*v))))
(define web-param-tests (define web-param-tests
(test-suite (test-suite
"Web Parameters" "Web Parameters"
@ -44,4 +44,4 @@
(send/suspend (lambda (k) k)) (send/suspend (lambda (k) k))
(+ (first) (second))))))]) (+ (first) (second))))))])
(let ([first-key (meval '(dispatch-start start #f))]) (let ([first-key (meval '(dispatch-start start #f))])
(check = 3 (meval `(dispatch ,the-dispatch (list ,first-key #f))))))))))) (check = 3 (meval `(dispatch ,the-dispatch (list ,first-key #f))))))))))

2
collects/web-server/tests/run
View File

@ -13,4 +13,4 @@ if [ "x${MODE}" == "xgraphical" ] ; then
PROG=mred PROG=mred
fi fi
${PROG} -mvt ${FILE} -e "(begin (require (planet \"${MODE}-ui.ss\" (\"schematics\" \"schemeunit.plt\" 2))) (test/${MODE}-ui ${T}))" ${PROG} -e "(begin (require \"${FILE}\") (require (planet \"${MODE}-ui.ss\" (\"schematics\" \"schemeunit.plt\" 2))) (test/${MODE}-ui ${T}))"

8
collects/web-server/tests/servlet-env-test.ss
View File

@ -1,8 +1,8 @@
(module servlet-env-test mzscheme (module servlet-env-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
ssax:xml->sxml) ssax:xml->sxml)
(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "pretty.ss") (lib "pretty.ss")
@ -10,7 +10,7 @@
(lib "servlet-env.ss" "web-server")) (lib "servlet-env.ss" "web-server"))
(provide servlet-env-tests) (provide servlet-env-tests)
(define (call u bs) #;(define (call u bs)
(define sx (ssax:xml->sxml (get-pure-port (string->url u)) empty)) (define sx (ssax:xml->sxml (get-pure-port (string->url u)) empty))
(pretty-print sx) (pretty-print sx)
sx) sx)
@ -19,6 +19,8 @@
(test-suite (test-suite
"Servlet Environment" "Servlet Environment"
; XXX At least just check whether the server can be started by the servlet-env guts
; XXX Broken ; XXX Broken
#;(test-not-exn "Add two numbers" #;(test-not-exn "Add two numbers"
(lambda () (lambda ()

8
collects/web-server/tests/util.ss
View File

@ -1,6 +1,6 @@
(module util mzscheme (module util mzscheme
(require (lib "connection-manager.ss" "web-server" "private") (require (lib "connection-manager.ss" "web-server" "private")
(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
ssax:xml->sxml) ssax:xml->sxml)
(lib "request-structs.ss" "web-server" "private") (lib "request-structs.ss" "web-server" "private")
(lib "web-server-structs.ss" "web-server" "private") (lib "web-server-structs.ss" "web-server" "private")
@ -19,7 +19,9 @@
(define (call d u bs) (define (call d u bs)
(htxml (collect d (make-request 'get (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1")))) (htxml (collect d (make-request 'get (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1"))))
(define (htxml bs) (define (htxml bs)
(define sx (ssax:xml->sxml (open-input-bytes (second (regexp-match #"^.+\r\n\r\n(.+)$" bs))) empty)) ; XXX SSAX is broken
#;(define sx (ssax:xml->sxml (open-input-bytes (second (regexp-match #"^.+\r\n\r\n(.+)$" bs))) empty))
(define sx empty)
(pretty-print sx) (pretty-print sx)
sx) sx)
@ -54,7 +56,7 @@
(eval '(require (lib "abort-resume.ss" "web-server" "lang") (eval '(require (lib "abort-resume.ss" "web-server" "lang")
(lib "serialize.ss"))) (lib "serialize.ss")))
(eval '(module m-id . rest)) (eval '(module m-id . rest))
(eval '(require m-id))) (eval '(require 'm-id)))
(lambda (s-expr) (lambda (s-expr)
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])