V4 progress
svn: r7799
This commit is contained in:
Jay McCarthy
parent
ee790a9d44
commit
27e9d4640f
|
|
@ -1,6 +1,6 @@
|
|||
(module dispatch-lang-test mzscheme
|
||||
(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 "list.ss")
|
||||
(lib "dispatch.ss" "web-server" "dispatchers")
|
||||
|
|
@ -10,6 +10,9 @@
|
|||
"../util.ss")
|
||||
(provide dispatch-lang-tests)
|
||||
|
||||
; XXX Sxpath broken
|
||||
(define sxpath (lambda _ (lambda _ (error 'sxpath))))
|
||||
|
||||
(define (mkd p)
|
||||
(lang:make #:url->path (lambda _ (values p (list p)))
|
||||
#:make-servlet-namespace
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(lib "file.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "list.ss")
|
||||
(lib "serialize.ss")
|
||||
(lib "request-structs.ss" "web-server" "private")
|
||||
(lib "dispatch.ss" "web-server" "dispatchers")
|
||||
(prefix passwords: (lib "dispatch-passwords.ss" "web-server" "dispatchers"))
|
||||
|
|
@ -52,8 +53,9 @@
|
|||
exn:dispatcher?
|
||||
(lambda () (runt #t #t)))
|
||||
(test-equal? "not authorized"
|
||||
(runt #t #f)
|
||||
`(WWW-Authenticate . " Basic realm=\"secret stuff\""))
|
||||
(let ([v (runt #t #f)])
|
||||
(list (header-field v) (header-value v)))
|
||||
(list #"WWW-Authenticate" #" Basic realm=\"secret stuff\""))
|
||||
(test-exn "does not apply"
|
||||
exn:dispatcher?
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module dispatch-servlets-test mzscheme
|
||||
(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 "list.ss")
|
||||
(lib "request-structs.ss" "web-server" "private")
|
||||
|
|
@ -11,6 +11,9 @@
|
|||
"../util.ss")
|
||||
(provide dispatch-servlets-tests)
|
||||
|
||||
; XXX Sxpath broken
|
||||
(define sxpath (lambda _ (lambda _ (error 'sxpath))))
|
||||
|
||||
(current-server-custodian (current-custodian))
|
||||
|
||||
(define (mkd p)
|
||||
|
|
|
|||
|
|
@ -222,7 +222,7 @@
|
|||
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
|
||||
(table-01-eval
|
||||
'(module m06 (lib "lang.ss" "web-server")
|
||||
(require table01)
|
||||
(require 'table01)
|
||||
(provide start)
|
||||
|
||||
(define (gn which)
|
||||
|
|
@ -236,7 +236,7 @@
|
|||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))
|
||||
(table-01-eval '(require m06))
|
||||
(table-01-eval '(require 'm06))
|
||||
(let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
|
||||
[second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
|
||||
[third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
|
||||
|
|
@ -391,12 +391,12 @@
|
|||
(printf "result = ~s~n" result)
|
||||
result))))])
|
||||
(nta-eval '(module m09 (lib "lang.ss" "web-server")
|
||||
(require nta)
|
||||
(require 'nta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(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
|
||||
(lambda () (nta-eval '(dispatch-start start 'foo)))))))
|
||||
|
|
@ -444,13 +444,13 @@
|
|||
(apply f args))))])
|
||||
|
||||
(ta-eval '(module m12 (lib "lang.ss" "web-server")
|
||||
(require ta)
|
||||
(require 'ta)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ initial
|
||||
(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)))))
|
||||
|
||||
|
|
@ -483,7 +483,7 @@
|
|||
(apply f args))))])
|
||||
|
||||
(ta-eval '(module m14 (lib "lang.ss" "web-server")
|
||||
(require ta)
|
||||
(require 'ta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(+ 1 (tail-apply
|
||||
|
|
@ -493,7 +493,7 @@
|
|||
(lambda (k)
|
||||
(let ([ignore (printf "n = ~s~n" n)])
|
||||
k))))) 7)))))
|
||||
(ta-eval '(require m14))
|
||||
(ta-eval '(require 'm14))
|
||||
|
||||
(let ([k0 (ta-eval '(dispatch-start start 'foo))])
|
||||
(check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2))))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
(module anormal-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
#lang scheme/base
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "anormal.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"))
|
||||
|
||||
(define (extend env vars vals)
|
||||
(define (extend env vars vals)
|
||||
(lambda (var0)
|
||||
(let loop ([vars vars]
|
||||
[vals vals])
|
||||
|
|
@ -17,24 +17,19 @@
|
|||
(car vals)]
|
||||
[else (loop (cdr vars) (cdr vals))]))))
|
||||
|
||||
;; alpha=/env: environment target-expr target-expr -> boolean
|
||||
;; are two target expressions alpha-equivalent?
|
||||
(define (alpha=/env env1 env2 expr1 expr2)
|
||||
(syntax-case expr1 (if #%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])]
|
||||
;; alpha=/env: environment target-expr target-expr -> boolean
|
||||
;; are two target expressions alpha-equivalent?
|
||||
(define (alpha=/env env1 env2 expr1 expr2)
|
||||
(syntax-case expr1 (if #%plain-app)
|
||||
[(if tst1 csq1 alt1)
|
||||
(syntax-case expr2 (if)
|
||||
[(if tst2 csq2 alt2) (and (alpha=/env env1 env2 #'tst1 #'tst2)
|
||||
(alpha=/env env1 env2 #'csq1 #'csq2)
|
||||
(alpha=/env env1 env2 #'alt1 #'alt2))]
|
||||
[_else #f])]
|
||||
[(#%app rator1 rands1 ...)
|
||||
(syntax-case expr2 (#%app)
|
||||
[(#%app rator2 rands2 ...)
|
||||
[(#%plain-app rator1 rands1 ...)
|
||||
(syntax-case expr2 (#%plain-app)
|
||||
[(#%plain-app rator2 rands2 ...)
|
||||
(and (alpha=/env env1 env2 #'rator1 #'rator2)
|
||||
(let loop ([rs1 (syntax->list #'(rands1 ...))]
|
||||
[rs2 (syntax->list #'(rands2 ...))])
|
||||
|
|
@ -42,36 +37,31 @@
|
|||
(null? rs2))
|
||||
(and (alpha=/env env1 env2 (car rs1) (car 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)]))
|
||||
|
||||
;; w-alpha=/env: env target-expr target-expr -> boolean
|
||||
;; are two target vars or vals alpha-equivalent?
|
||||
(define (w-alpha=/env env1 env2 expr1 expr2)
|
||||
(syntax-case expr1 (#%top #%datum lambda quote)
|
||||
;; w-alpha=/env: env target-expr target-expr -> boolean
|
||||
;; are two target vars or vals alpha-equivalent?
|
||||
(define (w-alpha=/env env1 env2 expr1 expr2)
|
||||
(syntax-case expr1 (#%top #%plain-lambda quote)
|
||||
[(#%top . var1)
|
||||
(syntax-case expr2 (#%top)
|
||||
[(#%top . var2)
|
||||
(eqv? (syntax-object->datum #'var1)
|
||||
(syntax-object->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))]
|
||||
(eqv? (syntax->datum #'var1)
|
||||
(syntax->datum #'var2))]
|
||||
[_else #f])]
|
||||
[(quote datum1)
|
||||
(syntax-case expr2 (quote)
|
||||
[(quote datum2)
|
||||
(let ([dat1 (syntax-object->datum #'datum1)]
|
||||
[dat2 (syntax-object->datum #'datum2)])
|
||||
(let ([dat1 (syntax->datum #'datum1)]
|
||||
[dat2 (syntax->datum #'datum2)])
|
||||
(equal? dat1 dat2))]
|
||||
[_else #f])]
|
||||
[(lambda formals1 body1)
|
||||
(syntax-case expr2 (lambda)
|
||||
[(lambda formals2 body2)
|
||||
[(#%plain-lambda formals1 body1)
|
||||
(syntax-case expr2 (#%plain-lambda)
|
||||
[(#%plain-lambda formals2 body2)
|
||||
(let ([syms (map gensym (syntax->symbols (formals-list #'formals1)))])
|
||||
(and (= (length syms) (length (formals-list #'formals2)))
|
||||
(alpha=/env
|
||||
|
|
@ -79,35 +69,37 @@
|
|||
(extend env2 (syntax->symbols (formals-list #'formals2)) syms)
|
||||
#'body1 #'body2)))]
|
||||
[_else #f])]
|
||||
[x1 (symbol? (syntax-object->datum #'x1))
|
||||
[x1 (symbol? (syntax->datum #'x1))
|
||||
(syntax-case expr2 ()
|
||||
[x2 (symbol? (syntax-object->datum #'x2))
|
||||
(or (module-identifier=? #'x1 #'x2)
|
||||
(eqv? (env1 (syntax-object->datum #'x1))
|
||||
(env2 (syntax-object->datum #'x2))))]
|
||||
[x2 (symbol? (syntax->datum #'x2))
|
||||
(or (free-identifier=? #'x1 #'x2)
|
||||
(eqv? (env1 (syntax->datum #'x1))
|
||||
(env2 (syntax->datum #'x2))))]
|
||||
[_else #f])]
|
||||
[_else #f]))
|
||||
[_else
|
||||
(raise-syntax-error 'alpha= "Dropped through:" expr1)
|
||||
#f]))
|
||||
|
||||
;; convert syntax into a list of symbols
|
||||
(define (syntax->symbols stx)
|
||||
;; convert syntax into a list of symbols
|
||||
(define (syntax->symbols stx)
|
||||
(syntax-case stx ()
|
||||
[(vars ...)
|
||||
(map
|
||||
(lambda (s)
|
||||
(syntax-object->datum s))
|
||||
(syntax->datum s))
|
||||
(syntax->list #'(vars ...)))]))
|
||||
|
||||
;; alph=: target-expr target-expr -> boolean
|
||||
;; are two target expressions alpha-equivalent?
|
||||
(define (alpha= expr1 expr2)
|
||||
;; alph=: target-expr target-expr -> boolean
|
||||
;; are two target expressions alpha-equivalent?
|
||||
(define (alpha= expr1 expr2)
|
||||
(define r (alpha=/env empty-env empty-env expr1 expr2))
|
||||
(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)
|
||||
|
||||
(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
|
||||
"Anormalization"
|
||||
(test-suite
|
||||
|
|
@ -115,92 +107,81 @@
|
|||
|
||||
(test-case
|
||||
"Top level identifier"
|
||||
(check alpha= (normalize-term (expand (syntax car)))
|
||||
(expand (syntax car))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax car)))
|
||||
(expand-syntax (syntax car))))
|
||||
|
||||
(test-case
|
||||
"Simple arithmetic expression"
|
||||
(check alpha= (normalize-term (expand (syntax (+ 1 1))))
|
||||
(expand (syntax (+ 1 1)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (+ 1 1))))
|
||||
(expand-syntax (syntax (+ 1 1)))))
|
||||
|
||||
(test-case
|
||||
"lambda-expression with constant body"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda (x) 3))))
|
||||
(expand (syntax (lambda (x) 3)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda (x) 3))))
|
||||
(expand-syntax (syntax (lambda (x) 3)))))
|
||||
|
||||
(test-case
|
||||
"lambda-expression with var-ref body"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda (x) x))))
|
||||
(expand (syntax (lambda (x) x)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda (x) x))))
|
||||
(expand-syntax (syntax (lambda (x) x)))))
|
||||
|
||||
(test-case
|
||||
"lambda-expression/constant-body/multiple formals"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda (x y z) 3))))
|
||||
(expand (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))))))
|
||||
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda (x y z) 3))))
|
||||
(expand-syntax (syntax (lambda (x y z) 3)))))
|
||||
|
||||
(test-case
|
||||
"two-armed-if"
|
||||
(check alpha= (normalize-term (expand (syntax (if #t 1 2))))
|
||||
(expand (syntax (if #t 1 2)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (if #t 1 2))))
|
||||
(expand-syntax (syntax (if #t 1 2)))))
|
||||
|
||||
(test-case
|
||||
"let/var-ref in body"
|
||||
(check alpha= (normalize-term (expand (syntax (let ([x 1]) x))))
|
||||
(expand (syntax ((lambda (x) x) 1)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (let ([x 1]) x))))
|
||||
(expand-syntax (syntax ((lambda (x) x) 1)))))
|
||||
|
||||
(test-case
|
||||
"call to void"
|
||||
(check alpha= (normalize-term (expand (syntax (void))))
|
||||
(expand (syntax (void)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (void))))
|
||||
(expand-syntax (syntax (void)))))
|
||||
|
||||
(test-case
|
||||
"primitive application/multiple arguments"
|
||||
(check alpha= (normalize-term (expand (syntax (+ 1 2 3))))
|
||||
(expand (syntax (+ 1 2 3)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (+ 1 2 3))))
|
||||
(expand-syntax (syntax (+ 1 2 3)))))
|
||||
|
||||
(test-case
|
||||
"empty-list"
|
||||
(check alpha= (normalize-term (expand (syntax ())))
|
||||
(expand (syntax ()))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax ())))
|
||||
(expand-syntax (syntax ()))))
|
||||
|
||||
(test-case
|
||||
"quoted list of constants"
|
||||
(check alpha= (normalize-term (expand (syntax '(1 2 3))))
|
||||
(expand (syntax '(1 2 3))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax '(1 2 3))))
|
||||
(expand-syntax (syntax '(1 2 3))))))
|
||||
|
||||
(test-suite
|
||||
"Inductive Cases"
|
||||
|
||||
(test-case
|
||||
"nested primitive applications with multiple arguments"
|
||||
(check alpha= (normalize-term (expand (syntax (* (+ 1 2) 3))))
|
||||
(expand (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))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (* (+ 1 2) 3))))
|
||||
(expand-syntax (syntax ((lambda (x) (* x 3)) (+ 1 2))))))
|
||||
|
||||
(test-case
|
||||
"two-armed if with prim-app in test posn"
|
||||
(check alpha= (normalize-term (expand (syntax (if (+ 1 2) 3 4))))
|
||||
(expand (syntax ((lambda (x) (if x 3 4)) (+ 1 2))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (if (+ 1 2) 3 4))))
|
||||
(expand-syntax (syntax ((lambda (x) (if x 3 4)) (+ 1 2))))))
|
||||
|
||||
(test-case
|
||||
"nested single argument primitive applications"
|
||||
(check alpha= (normalize-term (expand (syntax (* (+ 1)))))
|
||||
(expand (syntax ((lambda (x0) (* x0)) (+ 1))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (* (+ 1)))))
|
||||
(expand-syntax (syntax ((lambda (x0) (* x0)) (+ 1))))))
|
||||
|
||||
(test-case
|
||||
"deeply nested primitive applications"
|
||||
(check alpha= (normalize-term (expand (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6)))))
|
||||
(expand (syntax ((lambda (x0)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6)))))
|
||||
(expand-syntax (syntax ((lambda (x0)
|
||||
((lambda (x1)
|
||||
((lambda (x2)
|
||||
((lambda (x3) (* x2 x3))
|
||||
|
|
@ -211,8 +192,8 @@
|
|||
|
||||
(test-case
|
||||
"deeply nested primitive applications"
|
||||
(check alpha= (normalize-term (expand (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4)))))))
|
||||
(expand (syntax ((lambda (x0)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4)))))))
|
||||
(expand-syntax (syntax ((lambda (x0)
|
||||
((lambda (x1)
|
||||
((lambda (x2)
|
||||
((lambda (x3)
|
||||
|
|
@ -224,41 +205,41 @@
|
|||
|
||||
(test-case
|
||||
"if nested in test position"
|
||||
(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))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (if (if #t #f #t) #t #t))))
|
||||
(expand-syntax (syntax ((lambda (x) (if x #t #t)) (if #t #f #t))))))
|
||||
|
||||
(test-case
|
||||
"procedure/body has nested if"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda (x) (if (if x 1 2) 3 4)))))
|
||||
(expand (syntax (lambda (x)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda (x) (if (if x 1 2) 3 4)))))
|
||||
(expand-syntax (syntax (lambda (x)
|
||||
((lambda (y0) (if y0 3 4))
|
||||
(if x 1 2)))))))
|
||||
|
||||
(test-case
|
||||
"constant 0-arg procedure application"
|
||||
(check alpha= (normalize-term (expand (syntax ((lambda () 3)))))
|
||||
(expand (syntax ((lambda () 3))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax ((lambda () 3)))))
|
||||
(expand-syntax (syntax ((lambda () 3))))))
|
||||
|
||||
(test-case
|
||||
"if with function application in test"
|
||||
(check alpha= (normalize-term (expand (syntax (if ((lambda () 7)) 1 2))))
|
||||
(expand (syntax ((lambda (x) (if x 1 2))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (if ((lambda () 7)) 1 2))))
|
||||
(expand-syntax (syntax ((lambda (x) (if x 1 2))
|
||||
((lambda () 7)))))))
|
||||
|
||||
(test-case
|
||||
"if with lambda-expression in consequent and alternative"
|
||||
(check alpha= (normalize-term (expand (syntax ((if #t (lambda () 1) (lambda () 2))))))
|
||||
(expand (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2)))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax ((if #t (lambda () 1) (lambda () 2))))))
|
||||
(expand-syntax (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2)))))))
|
||||
|
||||
(test-case
|
||||
"call/cc with value argument"
|
||||
(check alpha= (normalize-term (expand (syntax (call/cc (lambda (x) x)))))
|
||||
(expand (syntax (call/cc (lambda (x) x))))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (call/cc (lambda (x) x)))))
|
||||
(expand-syntax (syntax (call/cc (lambda (x) x))))))
|
||||
|
||||
(test-case
|
||||
"call/cc with complex expression in argument"
|
||||
(check alpha= (normalize-term (expand (syntax (call/cc (f (g 7))))))
|
||||
(expand (syntax ((lambda (x0)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (call/cc (f (g 7))))))
|
||||
(expand-syntax (syntax ((lambda (x0)
|
||||
((lambda (x1) (call/cc x1))
|
||||
(f x0)))
|
||||
(g 7)))))))
|
||||
|
|
@ -268,25 +249,25 @@
|
|||
|
||||
(test-case
|
||||
"multiple body expressions in lambda"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda (x y z) 3 4))))
|
||||
(expand (syntax (lambda (x y z)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda (x y z) 3 4))))
|
||||
(expand-syntax (syntax (lambda (x y z)
|
||||
(call-with-values (lambda () 3)
|
||||
(lambda throw-away 4)))))))
|
||||
|
||||
(test-case
|
||||
"zero-or-more argument lambda"
|
||||
(check alpha= (normalize-term (expand (syntax (lambda x x))))
|
||||
(expand (syntax (lambda x x)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (lambda x x))))
|
||||
(expand-syntax (syntax (lambda x x)))))
|
||||
|
||||
(test-case
|
||||
"multi-valued let-values"
|
||||
(check alpha= (normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y)))))
|
||||
(expand (syntax (call-with-values (lambda () (values 1 2))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (let-values ([(x y) (values 1 2)]) (+ x y)))))
|
||||
(expand-syntax (syntax (call-with-values (lambda () (values 1 2))
|
||||
(lambda (x y) (+ x y)))))))
|
||||
(test-case
|
||||
"let/multiple clauses before body"
|
||||
(check alpha= (normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y)))))
|
||||
(expand (syntax ((lambda (x)
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (let ([x 1] [y 2]) (+ x y)))))
|
||||
(expand-syntax (syntax ((lambda (x)
|
||||
((lambda (y)
|
||||
(+ x y))
|
||||
2))
|
||||
|
|
@ -297,18 +278,18 @@
|
|||
|
||||
(test-case
|
||||
"empty begin"
|
||||
(check alpha= (normalize-term (expand (syntax (begin))))
|
||||
(syntax (#%app (#%top . void)))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (begin))))
|
||||
(expand-syntax (syntax (void)))))
|
||||
|
||||
(test-case
|
||||
"begin with one expression"
|
||||
(check alpha= (normalize-term (expand (syntax (begin 1))))
|
||||
(syntax (#%datum . 1))))
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (begin 1))))
|
||||
(expand-syntax (syntax (quote 1)))))
|
||||
|
||||
(test-case
|
||||
"begin with multiple expressions"
|
||||
(check alpha= (normalize-term (expand (syntax (begin 1 2 3))))
|
||||
(normalize-term (expand (syntax (call-with-values
|
||||
(check alpha= (normalize-term (expand-syntax (syntax (begin 1 2 3))))
|
||||
(normalize-term (expand-syntax (syntax (call-with-values
|
||||
(lambda () 1)
|
||||
(lambda throw-away
|
||||
(call-with-values
|
||||
|
|
@ -323,7 +304,7 @@
|
|||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (the-exn) #f)])
|
||||
(normalize-term
|
||||
(expand
|
||||
(expand-syntax
|
||||
(syntax
|
||||
(cond
|
||||
[(null? l) 1]
|
||||
|
|
@ -332,9 +313,12 @@
|
|||
(* (car l) (cdr l))])))))
|
||||
#t)))
|
||||
|
||||
(test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y)))))))
|
||||
(test-not-exn "quote-syntax: #f" (lambda () (parameterize ([transformer? #f])
|
||||
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!))))))
|
||||
(test-not-exn "quote-syntax: #t" (lambda () (parameterize ([transformer? #t])
|
||||
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!))))))
|
||||
))))
|
||||
(test-not-exn "define-struct"
|
||||
(lambda () (normalize-term (expand-syntax (syntax (define-struct posn (x y)))))))
|
||||
(test-not-exn "quote-syntax: #f"
|
||||
(lambda () (parameterize ([transformer? #f])
|
||||
(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!))))))
|
||||
)))
|
||||
|
|
@ -1,14 +1,14 @@
|
|||
(module web-param-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
#lang scheme/base
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
"../util.ss")
|
||||
(provide web-param-tests)
|
||||
(provide web-param-tests)
|
||||
|
||||
(define the-dispatch
|
||||
(define the-dispatch
|
||||
`(lambda (k*v)
|
||||
(lambda (k*v)
|
||||
((car k*v) k*v))))
|
||||
|
||||
(define web-param-tests
|
||||
(define web-param-tests
|
||||
(test-suite
|
||||
"Web Parameters"
|
||||
|
||||
|
|
@ -44,4 +44,4 @@
|
|||
(send/suspend (lambda (k) k))
|
||||
(+ (first) (second))))))])
|
||||
(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))))))))))
|
||||
|
|
@ -13,4 +13,4 @@ if [ "x${MODE}" == "xgraphical" ] ; then
|
|||
PROG=mred
|
||||
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}))"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
(module servlet-env-test mzscheme
|
||||
(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)
|
||||
(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
|
||||
#;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "pretty.ss")
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
(lib "servlet-env.ss" "web-server"))
|
||||
(provide servlet-env-tests)
|
||||
|
||||
(define (call u bs)
|
||||
#;(define (call u bs)
|
||||
(define sx (ssax:xml->sxml (get-pure-port (string->url u)) empty))
|
||||
(pretty-print sx)
|
||||
sx)
|
||||
|
|
@ -19,6 +19,8 @@
|
|||
(test-suite
|
||||
"Servlet Environment"
|
||||
|
||||
; XXX At least just check whether the server can be started by the servlet-env guts
|
||||
|
||||
; XXX Broken
|
||||
#;(test-not-exn "Add two numbers"
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module util mzscheme
|
||||
(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)
|
||||
(lib "request-structs.ss" "web-server" "private")
|
||||
(lib "web-server-structs.ss" "web-server" "private")
|
||||
|
|
@ -19,7 +19,9 @@
|
|||
(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"))))
|
||||
(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)
|
||||
sx)
|
||||
|
||||
|
|
@ -54,7 +56,7 @@
|
|||
(eval '(require (lib "abort-resume.ss" "web-server" "lang")
|
||||
(lib "serialize.ss")))
|
||||
(eval '(module m-id . rest))
|
||||
(eval '(require m-id)))
|
||||
(eval '(require 'm-id)))
|
||||
|
||||
(lambda (s-expr)
|
||||
(parameterize ([current-namespace ns])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user