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

Eliminating session and set! hairiness; Fixing anormalization bug re multiple values and begin0

Browse Source 
svn: r6363
This commit is contained in:
Jay McCarthy 2007-05-28 22:03:20 +00:00
parent 9eecc33370
commit 72eefe8b26
16 changed files with 479 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -11,10 +11,8 @@
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "dispatch.ss" "web-server" "dispatchers") (lib "dispatch.ss" "web-server" "dispatchers")
(lib "session.ss" "web-server" "prototype-web-server" "private") (lib "session.ss" "web-server" "prototype-web-server" "private")
(only (lib "abort-resume.ss" "web-server" "prototype-web-server" "private")
run-start)
(only "private/web.ss" (only "private/web.ss"
start-servlet) initialize-servlet)
(lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api") (lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api")
"private/utils.ss") "private/utils.ss")
@ -68,7 +66,7 @@
;; dispatch : connection request -> void ;; dispatch : connection request -> void
(define (dispatch conn req) (define (dispatch conn req)
(adjust-connection-timeout! conn timeouts-servlet-connection) (adjust-connection-timeout! conn timeouts-servlet-connection)
;; more here - make timeouts proportional to size of bindings ;; XXX - make timeouts proportional to size of bindings
(myprint "servlet-content-producer~n") (myprint "servlet-content-producer~n")
(let ([meth (request-method req)]) (let ([meth (request-method req)])
(if (eq? meth 'head) (if (eq? meth 'head)
@ -112,7 +110,8 @@
(let ([module-name `(file ,(path->string a-path))]) (let ([module-name `(file ,(path->string a-path))])
(myprint "dynamic-require ...~n") (myprint "dynamic-require ...~n")
(let ([start (dynamic-require module-name 'start)]) (let ([start (dynamic-require module-name 'start)])
(run-start start-servlet start)))) (set-session-servlet! ses
(initialize-servlet start)))))
(myprint "resume-session~n") (myprint "resume-session~n")
(resume-session (session-id ses) (resume-session (session-id ses)
conn req))) conn req)))
@ -127,19 +126,19 @@
(map path/param-path (map path/param-path
(url-path u))) (url-path u)))
(define ans (define ans
(let loop ([rp (abstract-url req)] (let loop ([rp (abstract-url req)]
[sp (abstract-url ses)]) [sp (abstract-url ses)])
(match sp (match sp
[(list) [(list)
#t] #t]
[(list-rest s sp) [(list-rest s sp)
(match rp (match rp
[(list) [(list)
#f] #f]
[(list-rest r rp) [(list-rest r rp)
(if (string=? s r) (if (string=? s r)
(loop rp sp) (loop rp sp)
#f)])]))) #f)])])))
(myprint "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans) (myprint "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans)
ans) ans)
@ -158,9 +157,9 @@
conn conn
(responders-servlet (request-uri req) the-exn) (responders-servlet (request-uri req) the-exn)
(request-method req)))]) (request-method req)))])
(myprint "session-handler ~S~n" (session-handler ses)) (myprint "session-handler ~S~n" (session-servlet ses))
(output-response conn (output-response conn
((session-handler ses) req)))) ((session-servlet ses) req))))
(begin-session conn req)))] (begin-session conn req)))]
[else [else
(myprint "resume-session: Unknown ses~n") (myprint "resume-session: Unknown ses~n")

11
collects/web-server/prototype-web-server/lang.ss
View File

@ -6,17 +6,24 @@
"lang/elim-letrec.ss" "lang/elim-letrec.ss"
"lang/anormal.ss" "lang/anormal.ss"
"lang/elim-callcc.ss" "lang/elim-callcc.ss"
"lang/defun.ss") "lang/defun.ss"
"lang/mark-lambda.ss")
(require "lang-api.ss") (require "lang-api.ss")
(provide (rename lang-module-begin #%module-begin)) (provide (rename lang-module-begin #%module-begin))
(provide (all-from "lang-api.ss")) (provide (all-from "lang-api.ss"))
; XXX We could optimize this process by marking user-provided lambdas and only defunctionalizing those.
(define-syntax lang-module-begin (define-syntax lang-module-begin
(make-lang-module-begin (make-lang-module-begin
make-labeling make-labeling
(make-module-case/new-defs (make-module-case/new-defs
(make-define-case/new-defs (make-define-case/new-defs
(compose #;(lambda (stx) (values stx empty)) (compose #;(lambda (stx) (values stx empty))
#;(lambda (stx)
(parameterize ([defun? marked-lambda?])
(defun stx)))
defun defun
elim-callcc elim-callcc
(make-anormal-term elim-letrec-term))))))) (make-anormal-term elim-letrec-term)
#;mark-lambda))))))

25
collects/web-server/prototype-web-server/lang/anormal.ss
View File

@ -1,11 +1,8 @@
(module anormal mzscheme (module anormal mzscheme
(require-for-template mzscheme) (require-for-template mzscheme)
(require (lib "kerncase.ss" "syntax") (require (lib "kerncase.ss" "syntax")
#;(lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "toplevel.ss" "syntax")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "stx.ss" "syntax")
"util.ss") "util.ss")
(provide make-anormal-term) (provide make-anormal-term)
@ -43,20 +40,25 @@
[(begin lbe) [(begin lbe)
(anormal ctxt (syntax/loc stx lbe))] (anormal ctxt (syntax/loc stx lbe))]
[(begin fbe be ...) [(begin fbe be ...)
; XXX Am I a bug?
(anormal ctxt (anormal ctxt
(syntax/loc stx (syntax/loc stx
(let-values ([(throw-away) fbe]) (#%app call-with-values
(begin be ...))))] (lambda () fbe)
(lambda throw-away
(begin be ...)))))]
[(begin0) [(begin0)
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))] (anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
[(begin0 lbe) [(begin0 lbe)
(anormal ctxt (syntax/loc stx lbe))] (anormal ctxt (syntax/loc stx lbe))]
[(begin0 fbe be ...) [(begin0 fbe be ...)
(anormal ctxt (let-values ([(save ref-to-save) (generate-formal 'save)])
(syntax/loc stx (anormal ctxt
(let-values ([(save) fbe]) (quasisyntax/loc stx
(begin be ... save))))] (#%app call-with-values
(lambda () fbe)
(lambda #,save
(begin be ...
(#%app apply values #,ref-to-save)))))))]
[(define-values (v ...) ve) [(define-values (v ...) ve)
(with-syntax ([ve (anormal-term #'ve)]) (with-syntax ([ve (anormal-term #'ve)])
(syntax/loc stx (syntax/loc stx
@ -129,7 +131,8 @@
[(letrec-syntaxes+values ([(sv ...) se] ...) [(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...) ([(vv ...) ve] ...)
be ...) be ...)
(raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)] (anormal ctxt
(elim-letrec-term stx))]
[(with-continuation-mark ke me be) [(with-continuation-mark ke me be)
(anormal (anormal
(compose ctxt (compose ctxt

51
collects/web-server/prototype-web-server/lang/defun.ss
View File

@ -6,12 +6,15 @@
"util.ss" "util.ss"
"freevars.ss" "freevars.ss"
"../private/closure.ss") "../private/closure.ss")
(provide defun) (provide defun
defun?)
; make-new-clouse-label : (syntax -> syntax) syntax -> syntax ; make-new-clouse-label : (syntax -> syntax) syntax -> syntax
(define (make-new-closure-label labeling stx) (define (make-new-closure-label labeling stx)
(labeling stx)) (labeling stx))
(define defun? (make-parameter (lambda _ #t)))
; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3]) ; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3])
; defunctionalizes the first syntax, returning the second and the lifted lambdas [3] ; defunctionalizes the first syntax, returning the second and the lifted lambdas [3]
(define (defun stx) (define (defun stx)
@ -61,29 +64,35 @@
[(lambda formals be ...) [(lambda formals be ...)
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nbe ...) nbes]) (with-syntax ([(nbe ...) nbes])
(let ([fvars (free-vars stx)]) (if ((defun?) stx)
(let-values ([(make-CLOSURE new-defs) (let ([fvars (free-vars stx)])
(make-closure-definition-syntax (let-values ([(make-CLOSURE new-defs)
(make-new-closure-label (current-code-labeling) stx) (make-closure-definition-syntax
fvars (make-new-closure-label (current-code-labeling) stx)
(syntax/loc stx (lambda formals nbe ...)))]) fvars
(values (if (empty? fvars) (syntax/loc stx (lambda formals nbe ...)))])
(quasisyntax/loc stx (#,make-CLOSURE)) (values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) (quasisyntax/loc stx (#,make-CLOSURE))
(append be-defs new-defs))))))] (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(append be-defs new-defs))))
(values (quasisyntax/loc stx (lambda formals nbe ...))
be-defs))))]
[(case-lambda [formals be ...] ...) [(case-lambda [formals be ...] ...)
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))]) (let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
(with-syntax ([((nbe ...) ...) nbes]) (with-syntax ([((nbe ...) ...) nbes])
(let ([fvars (free-vars stx)]) (if ((defun?) stx)
(let-values ([(make-CLOSURE new-defs) (let ([fvars (free-vars stx)])
(make-closure-definition-syntax (let-values ([(make-CLOSURE new-defs)
(make-new-closure-label (current-code-labeling) stx) (make-closure-definition-syntax
fvars (make-new-closure-label (current-code-labeling) stx)
(syntax/loc stx (case-lambda [formals nbe ...] ...)))]) fvars
(values (if (empty? fvars) (syntax/loc stx (case-lambda [formals nbe ...] ...)))])
(quasisyntax/loc stx (#,make-CLOSURE)) (values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) (quasisyntax/loc stx (#,make-CLOSURE))
(append be-defs new-defs))))))] (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(append be-defs new-defs))))
(values (quasisyntax/loc stx (case-lambda [formals nbe ...] ...))
be-defs))))]
[(if te ce ae) [(if te ce ae)
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))]) (let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
(values (quasisyntax/loc stx (if #,@es)) (values (quasisyntax/loc stx (if #,@es))

112
collects/web-server/prototype-web-server/lang/mark-lambda.ss Normal file
View File

@ -0,0 +1,112 @@
(module mark-lambda mzscheme
(require-for-template mzscheme)
(require (lib "kerncase.ss" "syntax")
"util.ss")
(provide mark-lambda
marked-lambda?)
(define lambda-key 'marked-lambda)
(define (marked-lambda? stx)
(kernel-syntax-case stx #f
[(lambda formals be ...)
(syntax-property stx lambda-key)]
[(case-lambda [formals be ...] ...)
(syntax-property stx lambda-key)]
[_ #f]))
(define (mark-lambda stx)
(recertify
stx
(kernel-syntax-case
stx #f
[(begin be ...)
(with-syntax ([(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(begin be ...)))]
[(begin0 be ...)
(with-syntax ([(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(begin0 be ...)))]
[(define-values (v ...) ve)
(with-syntax ([ve (mark-lambda #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
(with-syntax ([ve (mark-lambda #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-values-for-syntax (v ...) ve)
(with-syntax ([ve (mark-lambda #'ve)])
(syntax/loc stx
(define-values-for-syntax (v ...) ve)))]
[(set! v ve)
(with-syntax ([ve (mark-lambda #'ve)])
(syntax/loc stx
(set! v ve)))]
[(let-values ([(v ...) ve] ...) be ...)
(with-syntax ([(ve ...) (map mark-lambda (syntax->list #'(ve ...)))]
[(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(let-values ([(v ...) ve] ...) be ...)))]
[(letrec-values ([(v ...) ve] ...) be ...)
(with-syntax ([(ve ...) (map mark-lambda (syntax->list #'(ve ...)))]
[(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(letrec-values ([(v ...) ve] ...) be ...)))]
[(lambda formals be ...)
(syntax-property
(with-syntax ([(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(lambda formals be ...)))
lambda-key #t)]
[(case-lambda [formals be ...] ...)
(syntax-property
(with-syntax ([((be ...) ...) (map mark-lambda (syntax->list #'((be ...) ...)))])
(syntax/loc stx
(case-lambda [formals be ...] ...)))
lambda-key #t)]
[(if te ce ae)
(with-syntax ([te (mark-lambda #'te)]
[ce (mark-lambda #'ce)]
[ae (mark-lambda #'ae)])
(syntax/loc stx
(if te ce ae)))]
[(if te ce)
(mark-lambda (syntax/loc stx (if te ce (#%app void))))]
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(with-syntax ([(se ...) (map mark-lambda (syntax->list #'(se ...)))]
[(ve ...) (map mark-lambda (syntax->list #'(ve ...)))]
[(be ...) (map mark-lambda (syntax->list #'(be ...)))])
(syntax/loc stx
(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)))]
[(with-continuation-mark ke me be)
(with-syntax ([ke (mark-lambda #'ke)]
[me (mark-lambda #'me)]
[be (mark-lambda #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%expression . d)
stx]
[(#%app e ...)
(with-syntax ([(e ...) (map mark-lambda (syntax->list #'(e ...)))])
(syntax/loc stx
(#%app e ...)))]
[(#%top . v)
stx]
[(#%datum . d)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
stx]
[_
(raise-syntax-error 'kerncase "Dropped through:" stx)]))))

2
collects/web-server/prototype-web-server/lang/util.ss
View File

@ -2,7 +2,7 @@
(require-for-template mzscheme) (require-for-template mzscheme)
(require (lib "kerncase.ss" "syntax") (require (lib "kerncase.ss" "syntax")
(lib "list.ss")) (lib "list.ss"))
(provide (all-defined)) (provide (all-defined-except template))
(define (recertify old-expr expr) (define (recertify old-expr expr)
(syntax-recertify expr old-expr (current-code-inspector) #f)) (syntax-recertify expr old-expr (current-code-inspector) #f))

38
collects/web-server/prototype-web-server/private/abort-resume.ss
View File

@ -17,11 +17,9 @@
current-saved-continuation-marks-and current-saved-continuation-marks-and
;; "SERVLET" INTERFACE ;; "SERVLET" INTERFACE
start-interaction
send/suspend send/suspend
;; "CLIENT" INTERFACE ;; "CLIENT" INTERFACE
run-start
dispatch-start dispatch-start
dispatch) dispatch)
@ -74,7 +72,7 @@
[(list-rest f fs) [(list-rest f fs)
(match f (match f
[(vector #f #f) [(vector #f #f)
(error 'resume "Empty frame!")] (error 'resume "Empty frame")]
[(vector f #f) [(vector f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val))) (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
f)] f)]
@ -121,23 +119,6 @@
;; ********************************************************************** ;; **********************************************************************
;; ********************************************************************** ;; **********************************************************************
;; "SERVLET" INTERFACE ;; "SERVLET" INTERFACE
(define decode-continuation
(lambda (k-val)
(error "interactive module not initialized: decode")))
(define (start-continuation val)
(error "interactive module not initialized: start"))
;; start-interaction: (request -> continuation) -> request
;; register the decode proc and start the interaction with the current-continuation
(define (start-interaction decode)
(set! decode-continuation decode)
((lambda (k0)
(abort (lambda () (set! start-continuation k0))))
(let ([current-marks
(reverse
(continuation-mark-set->list* (current-continuation-marks) (list the-cont-key the-save-cm-key)))])
(lambda x (abort (lambda () (resume current-marks x)))))))
(define-closure kont x (wcs current-marks) (define-closure kont x (wcs current-marks)
(abort (lambda () (abort (lambda ()
@ -161,24 +142,19 @@
;; ********************************************************************** ;; **********************************************************************
;; "CLIENT" INTERFACE ;; "CLIENT" INTERFACE
(define (run-start harness start) ;; dispatch-start: (request -> response) request -> reponse
;; pass the initial request to the starting interaction point
(define (dispatch-start start req0)
(abort/cc (abort/cc
(lambda () (lambda ()
(with-continuation-mark safe-call? '(#t start) (with-continuation-mark safe-call? '(#t start)
(start (start
(with-continuation-mark the-cont-key start (with-continuation-mark the-cont-key start
(harness))))))) req0))))))
;; dispatch-start: request -> reponse ;; dispatch: (request -> (request -> response)) request -> response
;; pass the initial request to the starting interaction point
(define (dispatch-start req0)
(abort/cc
(lambda ()
(start-continuation req0))))
;; dispatch: request -> response
;; lookup the continuation for this request and invoke it ;; lookup the continuation for this request and invoke it
(define (dispatch req) (define (dispatch decode-continuation req)
(abort/cc (abort/cc
(lambda () (lambda ()
(cond (cond

36
collects/web-server/prototype-web-server/private/session.ss
View File

@ -5,18 +5,17 @@
(lib "response.ss" "web-server")) (lib "response.ss" "web-server"))
(provide current-session) (provide current-session)
(define-struct session (id cust namespace handler url mod-path)) (define-struct session (id cust namespace servlet url mod-path))
(provide/contract (provide/contract
[struct session ([id number?] [struct session ([id number?]
[cust custodian?] [cust custodian?]
[namespace namespace?] [namespace namespace?]
[handler (request? . -> . response?)] [servlet (request? . -> . response?)]
[url url?] [url url?]
[mod-path path?])] [mod-path path?])]
[lookup-session (number? . -> . (union session? boolean?))] [lookup-session (number? . -> . (union session? boolean?))]
[new-session (custodian? namespace? url? path? . -> . session?)] [new-session (custodian? namespace? url? path? . -> . session?)])
[start-session ((request? . -> . response?) . -> . any)])
(define current-session (make-parameter #f)) (define current-session (make-parameter #f))
@ -31,25 +30,16 @@
;; new-session: namespace path -> session ;; new-session: namespace path -> session
(define (new-session cust ns uri mod-path) (define (new-session cust ns uri mod-path)
(let ([new-id (new-session-id)]) (let* ([new-id (new-session-id)]
(make-session [ses (make-session
new-id new-id
cust cust
ns ns
(lambda (req) (error "session not initialized")) (lambda (req) (error "session not initialized"))
(encode-session uri new-id) (encode-session uri new-id)
mod-path))) mod-path)])
(hash-table-put! the-session-table new-id ses)
;; start-session: (request -> response) -> void ses))
;; register the session handler.
(define (start-session handler)
(let ([ses (current-session)])
(let ([params (current-parameterization)])
(set-session-handler!
ses
(lambda (req)
(call-with-parameterization params (lambda () (handler req))))))
(hash-table-put! the-session-table (session-id ses) ses)))
;; lookup-session: number -> (union session #f) ;; lookup-session: number -> (union session #f)
(define (lookup-session ses-id) (define (lookup-session ses-id)

37
collects/web-server/prototype-web-server/private/web.ss
View File

@ -8,21 +8,30 @@
"session.ss" "session.ss"
"stuff-url.ss") "stuff-url.ss")
(provide send/suspend/hidden (provide
send/suspend/url ;; Server Interface
extract-proc/url embed-proc/url initialize-servlet
start-servlet)
;; start-servlet: -> request ;; Servlet Interface
;; set the initial interaction point for the servlet send/suspend/hidden
(define (start-servlet) send/suspend/url
#;(printf "start-session~n") extract-proc/url
(start-session dispatch) embed-proc/url)
#;(printf "start-interaction~n")
(start-interaction ;; initial-servlet : (request -> response) -> (request -> response?)
(lambda (req) (define (initialize-servlet start)
(or (request->continuation req) (let ([params (current-parameterization)])
(lambda (req) (dispatch-start req)))))) (lambda (req0)
(call-with-parameterization
params
(lambda ()
(dispatch
(lambda (req1)
(or (request->continuation req1)
; Try to decode a continuation from the request,
; or, use the start procedure to initialize a session
(lambda (req2) (dispatch-start start req2))))
req0))))))
;; send/suspend/hidden: (url input-field -> response) -> request ;; send/suspend/hidden: (url input-field -> response) -> request
;; like send/suspend except the continuation is encoded in a hidden field ;; like send/suspend except the continuation is encoded in a hidden field

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

@ -1,6 +1,7 @@
(module anormal-test mzscheme (module anormal-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"../lang/anormal.ss") "../lang/anormal.ss"
"../lang/util.ss")
(provide anormal-tests) (provide anormal-tests)
(define (empty-env var) (define (empty-env var)
@ -68,14 +69,14 @@
[dat2 (syntax-object->datum #'datum2)]) [dat2 (syntax-object->datum #'datum2)])
(equal? dat1 dat2))] (equal? dat1 dat2))]
[_else #f])] [_else #f])]
[(lambda (formals1 ...) body1) [(lambda formals1 body1)
(syntax-case expr2 (lambda) (syntax-case expr2 (lambda)
[(lambda (formals2 ...) body2) [(lambda formals2 body2)
(let ([syms (map gensym (syntax->symbols #'(formals1 ...)))]) (let ([syms (map gensym (syntax->symbols (formals-list #'formals1)))])
(and (= (length syms) (length (syntax->list #'(formals2 ...)))) (and (= (length syms) (length (formals-list #'formals2)))
(alpha=/env (alpha=/env
(extend env1 (syntax->symbols #'(formals1 ...)) syms) (extend env1 (syntax->symbols (formals-list #'formals1)) syms)
(extend env2 (syntax->symbols #'(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-object->datum #'x1))
@ -197,7 +198,7 @@
(expand (syntax ())))) (expand (syntax ()))))
(test-case (test-case
"qoted list of constants" "quoted list of constants"
(check 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))))))
@ -329,9 +330,13 @@
(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 (begin 1 2 3))))
(normalize-term (expand (syntax (let ([throw-away 1]) (normalize-term (expand (syntax (call-with-values
(let ([throw-away 2]) (lambda () 1)
3))))))) (lambda throw-away
(call-with-values
(lambda () 2)
(lambda throw-away
3)))))))))
(test-case (test-case
"cond expression" "cond expression"

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

@ -3,11 +3,6 @@
"util.ss") "util.ss")
(provide certify-suite) (provide certify-suite)
(define the-dispatch
`(lambda (k*v)
(lambda (k*v)
((car k*v) k*v))))
(define certify-suite (define certify-suite
(test-suite (test-suite
"Test the certification process" "Test the certification process"
@ -17,41 +12,38 @@
(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 ([(test-m01.1)
(make-module-eval (make-module-eval
(module m01.1 (lib "lang.ss" "web-server" "prototype-web-server") (module m01.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
`(,@(list 1 2 initial)))))]) `(,@(list 1 2 initial)))))])
(go the-dispatch) (check equal? (list 1 2 3) (test-m01.1 '(dispatch-start start 3)))
(check equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3))) (check equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start start 'foo)))))
(check equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(test-case (test-case
"recertify context test (1)" "recertify context test (1)"
(let-values ([(go test-m01.2) (let-values ([(test-m01.2)
(make-module-eval (make-module-eval
(module m01.1 (lib "lang.ss" "web-server" "prototype-web-server") (module m01.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
`(foo ,@(list 1 2 3)))))]) `(foo ,@(list 1 2 3)))))])
(go the-dispatch)
(check-true #t))) (check-true #t)))
(test-case (test-case
"recertify context test (2)" "recertify context test (2)"
(let-values ([(go test-m01.3) (let-values ([(test-m01.3)
(make-module-eval (make-module-eval
(module m01.3 (lib "lang.ss" "web-server" "prototype-web-server") (module m01.3 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start n) (define (start n)
`(n ,@(list 1 2 3)))))]) `(n ,@(list 1 2 3)))))])
(go the-dispatch)
(check-true #t))) (check-true #t)))
(test-case (test-case
"recertify context test (3)" "recertify context test (3)"
(let-values ([(go test-m01.4) (let-values ([(test-m01.4)
(make-module-eval (make-module-eval
(module m1 (lib "lang.ss" "web-server" "prototype-web-server") (module m1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -59,5 +51,4 @@
(define (bar n) (define (bar n)
`(n ,@(list 1 2 3))) `(n ,@(list 1 2 3)))
(bar 7))))]) (bar 7))))])
(go the-dispatch)
(check-true #t))))))) (check-true #t)))))))

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

@ -31,120 +31,134 @@
(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 ([(test-m00.4)
(make-module-eval (make-module-eval
(module m00.4 (lib "lang.ss" "web-server" "prototype-web-server") (module m00.4 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
(let ([f (let ([m 7]) m)]) (let ([f (let ([m 7]) m)])
(+ f initial)))))]) (+ f initial)))))])
(go the-dispatch) (check = 8 (test-m00.4 '(dispatch-start start 1)))))
(check = 8 (test-m00.4 '(dispatch-start 1)))))
(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 ([(test-m00.3)
(make-module-eval (make-module-eval
(module m00.3 (lib "lang.ss" "web-server" "prototype-web-server") (module m00.3 (lib "lang.ss" "web-server" "prototype-web-server")
(define (foo x) 'foo) (define (foo x) 'foo)
(provide start) (provide start)
(define (start initial) (define (start initial)
(foo initial))))]) (foo initial))))])
(go the-dispatch) (check eqv? 'foo (test-m00.3 '(dispatch-start start 7)))))
(check eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(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 ([(test-m00)
(make-module-eval (make-module-eval
(module m00 (lib "lang.ss" "web-server" "prototype-web-server") (module m00 (lib "lang.ss" "web-server" "prototype-web-server")
(define (id x) x) (define (id x) x)
(provide start) (provide start)
(define (start initial) (define (start initial)
(id initial))))]) (id initial))))])
(go the-dispatch) (check = 7 (test-m00 '(dispatch-start start 7)))
(check = 7 (test-m00 '(dispatch-start 7))) (check eqv? 'foo (test-m00 '(dispatch-start start 'foo)))))
(check eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
(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 ([(test-m00.1)
(make-module-eval (make-module-eval
(module m00.1 (lib "lang.ss" "web-server" "prototype-web-server") (module m00.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ 1 initial))))]) (+ 1 initial))))])
(go the-dispatch) (check = 2 (test-m00.1 '(dispatch-start start 1)))))
(check = 2 (test-m00.1 '(dispatch-start 1)))))
(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 ([(test-m00.2)
(make-module-eval (make-module-eval
(module m00.2 (lib "lang.ss" "web-server" "prototype-web-server") (module m00.2 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ (+ 1 1) initial))))]) (+ (+ 1 1) initial))))])
(go the-dispatch) (check = 14 (test-m00.2 '(dispatch-start start 12)))
(check = 14 (test-m00.2 '(dispatch-start 12))) (check = 20 (test-m00.2 '(dispatch-start start 18)))))
(check = 20 (test-m00.2 '(dispatch-start 18)))))
(test-case (test-case
"start-interaction in third position" "start-interaction in third position"
(let-values ([(go test-m01) (let-values ([(test-m01)
(make-module-eval (make-module-eval
(module m01 (lib "lang.ss" "web-server" "prototype-web-server") (module m01 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ (* 1 2) (* 3 4) initial))))]) (+ (* 1 2) (* 3 4) initial))))])
(go the-dispatch) (check = 14 (test-m01 '(dispatch-start start 0)))
(check = 14 (test-m01 '(dispatch-start 0))) (check = 20 (test-m01 '(dispatch-start start 6))))))
(check = 20 (test-m01 '(dispatch-start 6)))))
;; start-interaction may be called mutitple times (test-suite
;; each call overwrites the previous interaction "Tests involving multiple values"
;; continuation with the latest one. (test-case
; XXX We have taken this power away. "begin with intermediate multiple values"
#;(test-case (let-values ([(test)
"start-interaction called twice, dispatch-start will invoke different continuations" (make-module-eval
(let ([test-m02 (module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(make-module-eval (provide start)
(module m02 (lib "lang.ss" "web-server" "prototype-web-server") (define (start x)
(define (id x) x) (begin (printf "Before~n")
(+ (start-interaction id) (values 1 x)
(start-interaction id))))]) (printf "After~n")
x))))])
(check = 3 (test `(dispatch-start start 3)))))
(check-true (void? (test-m02 '(dispatch-start 1)))) (test-case
(check = 3 (test-m02 '(dispatch-start 2))) "begin0 with intermediate multiple values"
(check = 0 (test-m02 '(dispatch-start -1)))))) (let-values ([(test)
(make-module-eval
(module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start x)
(begin0 x
(printf "Before~n")
(values 1 x)
(printf "After~n")))))])
(check = 3 (test `(dispatch-start start 3)))))
(test-case
"begin0 with multiple values"
(let-values ([(test)
(make-module-eval
(module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start x)
(let-values ([(_ ans)
(begin0 (values 1 x)
(printf "Before~n")
x
(printf "After~n"))])
ans))))])
(check = 3 (test `(dispatch-start start 3))))))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING CALL/CC
(test-suite (test-suite
"Tests Involving call/cc" "Tests Involving call/cc"
(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 ([(test-m03)
(make-module-eval (make-module-eval
(module m03 (lib "lang.ss" "web-server" "prototype-web-server") (module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
(define (start x) (define (start x)
(let/cc k (let/cc k
(+ 2 4 (k 3) 6 8)))))]) (+ 2 4 (k 3) 6 8)))))])
(go the-dispatch) (check = 3 (test-m03 '(dispatch-start start 'foo)))
(check = 3 (test-m03 '(dispatch-start 'foo))) (check = 3 (test-m03 '(dispatch-start 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
(test-case (test-case
"non-tail-recursive 'escaping' continuation" "non-tail-recursive 'escaping' continuation"
(let-values ([(go test-m04) (let-values ([(test-m04)
(make-module-eval (make-module-eval
(module m04 (lib "lang.ss" "web-server" "prototype-web-server") (module m04 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -156,9 +170,8 @@
[else [else
(* (car ln) (* (car ln)
(start (cdr ln)))])))))]) (start (cdr ln)))])))))])
(go the-dispatch) (check = 0 (test-m04 '(dispatch-start 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)))) (check = 120 (test-m04 '(dispatch-start 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
@ -166,7 +179,7 @@
;; as expected. ;; as expected.
(test-case (test-case
"tail-recursive escaping continuation" "tail-recursive escaping continuation"
(let-values ([(go test-m05) (let-values ([(test-m05)
(make-module-eval (make-module-eval
(module m05 (lib "lang.ss" "web-server" "prototype-web-server") (module m05 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -182,9 +195,8 @@
[else [else
(* (car ln) (* (car ln)
(mult/escape escape (cdr ln)))]))))]) (mult/escape escape (cdr ln)))]))))])
(go the-dispatch) (check = 0 (test-m05 '(dispatch-start start (list 1 2 3 0 4 5 6))))
(check = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6)))) (check = 120 (test-m05 '(dispatch-start start (list 1 2 3 4 5)))))))
(check = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
@ -192,53 +204,52 @@
(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 (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 (module table01 mzscheme
(module table01 mzscheme (provide store-k
(provide store-k lookup-k)
lookup-k)
(define the-table (make-hash-table)) (define the-table (make-hash-table))
(define (store-k k) (define (store-k k)
(let ([key (string->symbol (symbol->string (gensym 'key)))]) (let ([key (string->symbol (symbol->string (gensym 'key)))])
(hash-table-put! the-table key k) (hash-table-put! the-table key k)
key)) key))
(define (lookup-k key-pair) (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 (table-01-eval
'(module m06 (lib "lang.ss" "web-server" "prototype-web-server") '(module m06 (lib "lang.ss" "web-server" "prototype-web-server")
(require table01) (require table01)
(provide start) (provide start)
(define (gn which) (define (gn which)
(cadr (cadr
(send/suspend (send/suspend
(lambda (k) (lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)]) (let ([ignore (printf "Please send the ~a number.~n" which)])
(store-k k)))))) (store-k k))))))
(define (start ignore) (define (start ignore)
(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 'foo))] (let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
[second-key (table-01-eval `(dispatch '(,first-key 1)))] [second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
[third-key (table-01-eval `(dispatch '(,first-key -7)))]) [third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
(check = 3 (table-01-eval `(dispatch '(,second-key 2)))) (check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2))))
(check = 4 (table-01-eval `(dispatch '(,second-key 3)))) (check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch '(,second-key -1))))) (check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
(check = -7 (table-01-eval `(dispatch '(,third-key 0)))) (check = -7 (table-01-eval `(dispatch lookup-k '(,third-key 0))))
(check-true (zero? (table-01-eval `(dispatch '(,third-key 7)))))))) (check-true (zero? (table-01-eval `(dispatch lookup-k '(,third-key 7))))))))
(test-case (test-case
"curried with send/suspend and serializaztion" "curried with send/suspend and serializaztion"
(let-values ([(go test-m06.1) (let-values ([(test-m06.1)
(make-module-eval (make-module-eval
(module m06.1 (lib "lang.ss" "web-server" "prototype-web-server") (module m06.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -253,25 +264,21 @@
(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)))))])
(go the-dispatch) (let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))] [second-key (test-m06.1 `(dispatch ,the-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 ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
[third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))]) (check = 3 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 2))))
(check = 3 (test-m06.1 `(dispatch (list ,second-key 2)))) (check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
(check = 4 (test-m06.1 `(dispatch (list ,second-key 3)))) (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
(check-true (zero? (test-m06.1 `(dispatch (list ,second-key -1))))) (check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
(check = -7 (test-m06.1 `(dispatch (list ,third-key 0)))) (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
(check-true (zero? (test-m06.1 `(dispatch (list ,third-key 7)))))))))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING LETREC
(test-suite (test-suite
"Tests Involving letrec" "Tests Involving letrec"
(test-case (test-case
"mutually recursive even? and odd?" "mutually recursive even? and odd?"
(let-values ([(go test-m07) (let-values ([(test-m07)
(make-module-eval (make-module-eval
(module m07 (lib "lang.ss" "web-server" "prototype-web-server") (module m07 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -283,15 +290,14 @@
(and (not (zero? n)) (and (not (zero? n))
(even? (sub1 n))))]) (even? (sub1 n))))])
(even? initial)))))]) (even? initial)))))])
(go the-dispatch) (check-true (test-m07 '(dispatch-start start 0)))
(check-true (test-m07 '(dispatch-start 0))) (check-true (test-m07 '(dispatch-start start 16)))
(check-true (test-m07 '(dispatch-start 16))) (check-false (test-m07 '(dispatch-start start 1)))
(check-false (test-m07 '(dispatch-start 1))) (check-false (test-m07 '(dispatch-start start 7)))))
(check-false (test-m07 '(dispatch-start 7)))))
(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 ([(test-m08)
(make-module-eval (make-module-eval
(module m08 (lib "lang.ss" "web-server" "prototype-web-server") (module m08 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -310,51 +316,46 @@
(let ([result (g (gn "third"))]) (let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)]) (let ([ignore (printf "The answer is: ~s~n" result)])
result))))))]) result))))))])
(go the-dispatch) (let* ([k0 (test-m08 '(serialize (dispatch-start start 'foo)))]
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))] [k1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))] [k2 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2))))])
[k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))]) (check = 6 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))
(check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))) (check = 9 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 6))))
(check = 9 (test-m08 `(dispatch (list (deserialize ',k2) 6)))) (let* ([k1.1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) -1))))]
(let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))] [k2.1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k1.1) -2))))])
[k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))]) (check-true (zero? (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2.1) 3)))))
(check-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3))))) (check = 6 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 3)))))))))
(check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))))))))
;; ****************************************
;; ****************************************
;; TEST UNSAFE CONTEXT CONDITION
(test-suite (test-suite
"Unsafe Context Condition Tests" "Unsafe Context Condition Tests"
; XXX Bizarre (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 ([(nta-eval)
(make-module-eval (make-module-eval
(module nta mzscheme (module nta mzscheme
(provide non-tail-apply) (provide non-tail-apply)
(define (non-tail-apply f . args) (define (non-tail-apply f . args)
(let ([result (apply f args)]) (let ([result (apply f args)])
(printf "result = ~s~n" result) (printf "result = ~s~n" result)
result))))]) result))))])
(nta-eval '(module m09 (lib "lang.ss" "web-server" "prototype-web-server") (nta-eval '(module m09 (lib "lang.ss" "web-server" "prototype-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 'foo))))))) (lambda () (nta-eval '(dispatch-start start 'foo)))))))
(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 ([(m10-eval)
(make-module-eval (make-module-eval
(module m10 (lib "lang.ss" "web-server" "prototype-web-server") (module m10 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -364,13 +365,12 @@
result)) result))
(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) (check = 7 (m10-eval '(dispatch-start start 'foo)))))
(check = 7 (m10-eval '(dispatch-start 'foo)))))
(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 ([(m11-eval)
(make-module-eval (make-module-eval
(module m11 (lib "lang.ss" "web-server" "prototype-web-server") (module m11 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -378,39 +378,37 @@
(map (map
(lambda (x) (let/cc k k)) (lambda (x) (let/cc k k))
(list 1 2 3)))))]) (list 1 2 3)))))])
(go the-dispatch)
(check-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (m11-eval '(dispatch-start 'foo))))))) (lambda () (m11-eval '(dispatch-start 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 (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
(make-module-eval (make-module-eval
(module ta mzscheme (module ta mzscheme
(provide tail-apply) (provide tail-apply)
(define (tail-apply f . args) (define (tail-apply f . args)
(apply f args))))]) (apply f args))))])
(ta-eval '(module m12 (lib "lang.ss" "web-server" "prototype-web-server") (ta-eval '(module m12 (lib "lang.ss" "web-server" "prototype-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 1))))) (check = 2 (ta-eval '(dispatch-start start 1)))))
(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 ([(m13-eval)
(make-module-eval (make-module-eval
(module m11 (lib "lang.ss" "web-server" "prototype-web-server") (module m11 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -421,35 +419,33 @@
(let ([ignore (printf "n = ~s~n" n)]) (let ([ignore (printf "n = ~s~n" n)])
k)))) k))))
(list 1 2 3)))))]) (list 1 2 3)))))])
(go the-dispatch)
(check-true (catch-unsafe-context-exn (check-true (catch-unsafe-context-exn
(lambda () (m13-eval '(dispatch-start 'foo))))))) (lambda () (m13-eval '(dispatch-start start 'foo)))))))
; XXX Weird (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 ([(ta-eval)
(make-module-eval (make-module-eval
(module ta mzscheme (module ta mzscheme
(provide tail-apply) (provide tail-apply)
(define (tail-apply f . args) (define (tail-apply f . args)
(apply f args))))]) (apply f args))))])
(ta-eval '(module m14 (lib "lang.ss" "web-server" "prototype-web-server") (ta-eval '(module m14 (lib "lang.ss" "web-server" "prototype-web-server")
(require ta) (require ta)
(provide start) (provide start)
(define (start ignore) (define (start ignore)
(+ 1 (tail-apply (+ 1 (tail-apply
(lambda (n) (lambda (n)
(cadr (cadr
(send/suspend (send/suspend
(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 'foo))]) (let ([k0 (ta-eval '(dispatch-start start 'foo))])
(check = 3 (ta-eval `(dispatch (list ,k0 2)))) (check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2))))
(check = 0 (ta-eval `(dispatch (list ,k0 -1))))))))))) (check = 0 (ta-eval `(dispatch ,the-dispatch (list ,k0 -1)))))))))))

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

@ -20,7 +20,7 @@
(test-case (test-case
"web-parameterize does not overwrite with multiple parameters" "web-parameterize does not overwrite with multiple parameters"
(let-values ([(go meval) (let-values ([(meval)
(make-module-eval (make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server") (module m (lib "lang.ss" "web-server" "prototype-web-server")
(define first (make-web-parameter #f)) (define first (make-web-parameter #f))
@ -30,13 +30,12 @@
(web-parameterize ([first 1] (web-parameterize ([first 1]
[second 2]) [second 2])
(+ (first) (second))))))]) (+ (first) (second))))))])
(go the-dispatch) (check = 3 (meval '(dispatch-start start #f)))))
(check = 3 (meval '(dispatch-start #f)))))
(test-case (test-case
"web-parameterize does not overwrite with multiple parameters across send/suspend" "web-parameterize does not overwrite with multiple parameters across send/suspend"
(let-values ([(go meval) (let-values ([(meval)
(make-module-eval (make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server") (module m (lib "lang.ss" "web-server" "prototype-web-server")
(provide start) (provide start)
@ -47,6 +46,5 @@
[second 2]) [second 2])
(send/suspend (lambda (k) k)) (send/suspend (lambda (k) k))
(+ (first) (second))))))]) (+ (first) (second))))))])
(go the-dispatch) (let ([first-key (meval '(dispatch-start start #f))])
(let ([first-key (meval '(dispatch-start #f))]) (check = 3 (meval `(dispatch ,the-dispatch (list ,first-key #f)))))))))))
(check = 3 (meval `(dispatch (list ,first-key #f)))))))))))

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

@ -8,7 +8,7 @@
(define persistent-close-suite (define persistent-close-suite
(test-suite (test-suite
"tests for persistent-close.ss" "Tests for persistent-close.ss"
(test-case (test-case
"file-vector references" "file-vector references"

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

@ -57,32 +57,29 @@
(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 m00)]) (let-values ([(ev) (make-eval/mod-path m00)])
(go the-dispatch) (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo)))
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
m00)] m00)]
[k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) [k1 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))
m00)] m00)]
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) [k2 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2))))
m00)]) m00)])
(check-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))) (check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))))))
(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 m01)]) (let-values ([(ev) (make-eval/mod-path m01)])
(go the-dispatch) (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo)))
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
m01)]) m01)])
(check-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7)))))))) (check-true (= 7 (ev `(dispatch ,the-dispatch (list (deserialize ',k0) 7))))))))
(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 m00)]) (let-values ([(ev) (make-eval/mod-path m00)])
(go the-dispatch) (let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start start 'foo)))
(let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo)))
uri0 m00)] uri0 m00)]
[k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) [k1 (stuff-unstuff (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))
uri0 m00)] uri0 m00)]
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) [k2 (stuff-unstuff (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2))))
uri0 m00)]) uri0 m00)])
(check-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))))) (check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3)))))))))))

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

@ -2,15 +2,6 @@
(provide make-module-eval (provide make-module-eval
make-eval/mod-path) make-eval/mod-path)
(define (go ns)
(lambda (dispatch-sexpr)
(parameterize ([current-namespace ns])
(eval `(run-start
(lambda ()
(start-interaction
,dispatch-sexpr))
start)))))
(define-syntax (make-module-eval m-expr) (define-syntax (make-module-eval m-expr)
(syntax-case m-expr (module) (syntax-case m-expr (module)
[(_ (module m-id . rest)) [(_ (module m-id . rest))
@ -21,11 +12,9 @@
(eval '(module m-id . rest)) (eval '(module m-id . rest))
(eval '(require m-id))) (eval '(require m-id)))
(values (lambda (s-expr)
(go ns) (parameterize ([current-namespace ns])
(lambda (s-expr) (eval s-expr))))]
(parameterize ([current-namespace ns])
(eval s-expr)))))]
[else [else
(raise-syntax-error #f "make-module-evel: dropped through" m-expr)])) (raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))
@ -35,7 +24,6 @@
(eval `(require (lib "abort-resume.ss" "web-server" "prototype-web-server" "private") (eval `(require (lib "abort-resume.ss" "web-server" "prototype-web-server" "private")
(lib "serialize.ss") (lib "serialize.ss")
,pth))) ,pth)))
(values (go ns) (lambda (expr)
(lambda (expr) (parameterize ([current-namespace ns])
(parameterize ([current-namespace ns]) (eval expr))))))
(eval expr)))))))