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

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

@ -11,10 +11,8 @@
(lib "plt-match.ss")
(lib "dispatch.ss" "web-server" "dispatchers")
(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"
start-servlet)
initialize-servlet)
(lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api")
"private/utils.ss")
@ -68,7 +66,7 @@
;; dispatch : connection request -> void
(define (dispatch conn req)
(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")
(let ([meth (request-method req)])
(if (eq? meth 'head)
@ -112,7 +110,8 @@
(let ([module-name `(file ,(path->string a-path))])
(myprint "dynamic-require ...~n")
(let ([start (dynamic-require module-name 'start)])
(run-start start-servlet start))))
(set-session-servlet! ses
(initialize-servlet start)))))
(myprint "resume-session~n")
(resume-session (session-id ses)
conn req)))
@ -158,9 +157,9 @@
conn
(responders-servlet (request-uri req) the-exn)
(request-method req)))])
(myprint "session-handler ~S~n" (session-handler ses))
(myprint "session-handler ~S~n" (session-servlet ses))
(output-response conn
((session-handler ses) req))))
((session-servlet ses) req))))
(begin-session conn req)))]
[else
(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/anormal.ss"
"lang/elim-callcc.ss"
"lang/defun.ss")
"lang/defun.ss"
"lang/mark-lambda.ss")
(require "lang-api.ss")
(provide (rename lang-module-begin #%module-begin))
(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
(make-lang-module-begin
make-labeling
(make-module-case/new-defs
(make-define-case/new-defs
(compose #;(lambda (stx) (values stx empty))
#;(lambda (stx)
(parameterize ([defun? marked-lambda?])
(defun stx)))
defun
elim-callcc
(make-anormal-term elim-letrec-term)))))))
(make-anormal-term elim-letrec-term)
#;mark-lambda))))))

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

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

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

@ -6,12 +6,15 @@
"util.ss"
"freevars.ss"
"../private/closure.ss")
(provide defun)
(provide defun
defun?)
; make-new-clouse-label : (syntax -> syntax) syntax -> syntax
(define (make-new-closure-label labeling stx)
(labeling stx))
(define defun? (make-parameter (lambda _ #t)))
; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3])
; defunctionalizes the first syntax, returning the second and the lifted lambdas [3]
(define (defun stx)
@ -61,6 +64,7 @@
[(lambda formals be ...)
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nbe ...) nbes])
(if ((defun?) stx)
(let ([fvars (free-vars stx)])
(let-values ([(make-CLOSURE new-defs)
(make-closure-definition-syntax
@ -70,10 +74,13 @@
(values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE))
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(append be-defs new-defs))))))]
(append be-defs new-defs))))
(values (quasisyntax/loc stx (lambda formals nbe ...))
be-defs))))]
[(case-lambda [formals be ...] ...)
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
(with-syntax ([((nbe ...) ...) nbes])
(if ((defun?) stx)
(let ([fvars (free-vars stx)])
(let-values ([(make-CLOSURE new-defs)
(make-closure-definition-syntax
@ -83,7 +90,9 @@
(values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE))
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(append be-defs new-defs))))))]
(append be-defs new-defs))))
(values (quasisyntax/loc stx (case-lambda [formals nbe ...] ...))
be-defs))))]
[(if te ce ae)
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
(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 (lib "kerncase.ss" "syntax")
(lib "list.ss"))
(provide (all-defined))
(provide (all-defined-except template))
(define (recertify old-expr expr)
(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
;; "SERVLET" INTERFACE
start-interaction
send/suspend
;; "CLIENT" INTERFACE
run-start
dispatch-start
dispatch)
@ -74,7 +72,7 @@
[(list-rest f fs)
(match f
[(vector #f #f)
(error 'resume "Empty frame!")]
(error 'resume "Empty frame")]
[(vector f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
f)]
@ -121,23 +119,6 @@
;; **********************************************************************
;; **********************************************************************
;; "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)
(abort (lambda ()
@ -161,24 +142,19 @@
;; **********************************************************************
;; "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
(lambda ()
(with-continuation-mark safe-call? '(#t start)
(start
(with-continuation-mark the-cont-key start
(harness)))))))
req0))))))
;; dispatch-start: request -> reponse
;; pass the initial request to the starting interaction point
(define (dispatch-start req0)
(abort/cc
(lambda ()
(start-continuation req0))))
;; dispatch: request -> response
;; dispatch: (request -> (request -> response)) request -> response
;; lookup the continuation for this request and invoke it
(define (dispatch req)
(define (dispatch decode-continuation req)
(abort/cc
(lambda ()
(cond

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

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

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

@ -8,21 +8,30 @@
"session.ss"
"stuff-url.ss")
(provide send/suspend/hidden
send/suspend/url
extract-proc/url embed-proc/url
start-servlet)
(provide
;; Server Interface
initialize-servlet
;; start-servlet: -> request
;; set the initial interaction point for the servlet
(define (start-servlet)
#;(printf "start-session~n")
(start-session dispatch)
#;(printf "start-interaction~n")
(start-interaction
(lambda (req)
(or (request->continuation req)
(lambda (req) (dispatch-start req))))))
;; Servlet Interface
send/suspend/hidden
send/suspend/url
extract-proc/url
embed-proc/url)
;; initial-servlet : (request -> response) -> (request -> response?)
(define (initialize-servlet start)
(let ([params (current-parameterization)])
(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
;; 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
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"../lang/anormal.ss")
"../lang/anormal.ss"
"../lang/util.ss")
(provide anormal-tests)
(define (empty-env var)
@ -68,14 +69,14 @@
[dat2 (syntax-object->datum #'datum2)])
(equal? dat1 dat2))]
[_else #f])]
[(lambda (formals1 ...) body1)
[(lambda formals1 body1)
(syntax-case expr2 (lambda)
[(lambda (formals2 ...) body2)
(let ([syms (map gensym (syntax->symbols #'(formals1 ...)))])
(and (= (length syms) (length (syntax->list #'(formals2 ...))))
[(lambda formals2 body2)
(let ([syms (map gensym (syntax->symbols (formals-list #'formals1)))])
(and (= (length syms) (length (formals-list #'formals2)))
(alpha=/env
(extend env1 (syntax->symbols #'(formals1 ...)) syms)
(extend env2 (syntax->symbols #'(formals2 ...)) syms)
(extend env1 (syntax->symbols (formals-list #'formals1)) syms)
(extend env2 (syntax->symbols (formals-list #'formals2)) syms)
#'body1 #'body2)))]
[_else #f])]
[x1 (symbol? (syntax-object->datum #'x1))
@ -197,7 +198,7 @@
(expand (syntax ()))))
(test-case
"qoted list of constants"
"quoted list of constants"
(check alpha= (normalize-term (expand (syntax '(1 2 3))))
(expand (syntax '(1 2 3))))))
@ -329,9 +330,13 @@
(test-case
"begin with multiple expressions"
(check alpha= (normalize-term (expand (syntax (begin 1 2 3))))
(normalize-term (expand (syntax (let ([throw-away 1])
(let ([throw-away 2])
3)))))))
(normalize-term (expand (syntax (call-with-values
(lambda () 1)
(lambda throw-away
(call-with-values
(lambda () 2)
(lambda throw-away
3)))))))))
(test-case
"cond expression"

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

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

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

@ -31,120 +31,134 @@
(test-case
"Function application with single argument in tail position"
(let-values ([(go test-m00.4)
(let-values ([(test-m00.4)
(make-module-eval
(module m00.4 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start initial)
(let ([f (let ([m 7]) m)])
(+ f initial)))))])
(go the-dispatch)
(check = 8 (test-m00.4 '(dispatch-start 1)))))
(check = 8 (test-m00.4 '(dispatch-start start 1)))))
(test-case
"start-interaction in argument position of a function call"
(let-values ([(go test-m00.3)
(let-values ([(test-m00.3)
(make-module-eval
(module m00.3 (lib "lang.ss" "web-server" "prototype-web-server")
(define (foo x) 'foo)
(provide start)
(define (start initial)
(foo initial))))])
(go the-dispatch)
(check eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(check eqv? 'foo (test-m00.3 '(dispatch-start start 7)))))
(test-case
"identity interaction, dispatch-start called multiple times"
(let-values ([(go test-m00)
(let-values ([(test-m00)
(make-module-eval
(module m00 (lib "lang.ss" "web-server" "prototype-web-server")
(define (id x) x)
(provide start)
(define (start initial)
(id initial))))])
(go the-dispatch)
(check = 7 (test-m00 '(dispatch-start 7)))
(check eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
(check = 7 (test-m00 '(dispatch-start start 7)))
(check eqv? 'foo (test-m00 '(dispatch-start start 'foo)))))
(test-case
"start-interaction in argument position of a primitive"
(let-values ([(go test-m00.1)
(let-values ([(test-m00.1)
(make-module-eval
(module m00.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start initial)
(+ 1 initial))))])
(go the-dispatch)
(check = 2 (test-m00.1 '(dispatch-start 1)))))
(check = 2 (test-m00.1 '(dispatch-start start 1)))))
(test-case
"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
(module m00.2 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start initial)
(+ (+ 1 1) initial))))])
(go the-dispatch)
(check = 14 (test-m00.2 '(dispatch-start 12)))
(check = 20 (test-m00.2 '(dispatch-start 18)))))
(check = 14 (test-m00.2 '(dispatch-start start 12)))
(check = 20 (test-m00.2 '(dispatch-start start 18)))))
(test-case
"start-interaction in third position"
(let-values ([(go test-m01)
(let-values ([(test-m01)
(make-module-eval
(module m01 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start initial)
(+ (* 1 2) (* 3 4) initial))))])
(go the-dispatch)
(check = 14 (test-m01 '(dispatch-start 0)))
(check = 20 (test-m01 '(dispatch-start 6)))))
(check = 14 (test-m01 '(dispatch-start start 0)))
(check = 20 (test-m01 '(dispatch-start start 6))))))
;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction
;; continuation with the latest one.
; XXX We have taken this power away.
#;(test-case
"start-interaction called twice, dispatch-start will invoke different continuations"
(let ([test-m02
(test-suite
"Tests involving multiple values"
(test-case
"begin with intermediate multiple values"
(let-values ([(test)
(make-module-eval
(module m02 (lib "lang.ss" "web-server" "prototype-web-server")
(define (id x) x)
(+ (start-interaction id)
(start-interaction id))))])
(module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start x)
(begin (printf "Before~n")
(values 1 x)
(printf "After~n")
x))))])
(check = 3 (test `(dispatch-start start 3)))))
(check-true (void? (test-m02 '(dispatch-start 1))))
(check = 3 (test-m02 '(dispatch-start 2)))
(check = 0 (test-m02 '(dispatch-start -1))))))
(test-case
"begin0 with intermediate multiple values"
(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
"Tests Involving call/cc"
(test-case
"continuation invoked in non-trivial context from within proc"
(let-values ([(go test-m03)
(let-values ([(test-m03)
(make-module-eval
(module m03 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
(define (start x)
(let/cc k
(+ 2 4 (k 3) 6 8)))))])
(go the-dispatch)
(check = 3 (test-m03 '(dispatch-start 'foo)))
(check = 3 (test-m03 '(dispatch-start 7)))))
(check = 3 (test-m03 '(dispatch-start start 'foo)))
(check = 3 (test-m03 '(dispatch-start start 7)))))
;; in the following test, if you modify
;; resume to print the "stack" you will
;; see that this is not tail recursive
(test-case
"non-tail-recursive 'escaping' continuation"
(let-values ([(go test-m04)
(let-values ([(test-m04)
(make-module-eval
(module m04 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -156,9 +170,8 @@
[else
(* (car ln)
(start (cdr ln)))])))))])
(go the-dispatch)
(check = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9))))
(check = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5))))))
(check = 0 (test-m04 '(dispatch-start 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))))))
;; this version captures the continuation
;; outside the recursion and should be tail
@ -166,7 +179,7 @@
;; as expected.
(test-case
"tail-recursive escaping continuation"
(let-values ([(go test-m05)
(let-values ([(test-m05)
(make-module-eval
(module m05 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -182,9 +195,8 @@
[else
(* (car ln)
(mult/escape escape (cdr ln)))]))))])
(go the-dispatch)
(check = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6))))
(check = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
(check = 0 (test-m05 '(dispatch-start start (list 1 2 3 0 4 5 6))))
(check = 120 (test-m05 '(dispatch-start start (list 1 2 3 4 5)))))))
;; ****************************************
;; ****************************************
@ -192,8 +204,7 @@
(test-suite
"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"
(let ([table-01-eval
(make-module-eval
@ -226,19 +237,19 @@
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))
(table-01-eval '(require m06))
(let* ([first-key (table-01-eval '(dispatch-start 'foo))]
[second-key (table-01-eval `(dispatch '(,first-key 1)))]
[third-key (table-01-eval `(dispatch '(,first-key -7)))])
(check = 3 (table-01-eval `(dispatch '(,second-key 2))))
(check = 4 (table-01-eval `(dispatch '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
(check = -7 (table-01-eval `(dispatch '(,third-key 0))))
(check-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
(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)))])
(check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2))))
(check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
(check = -7 (table-01-eval `(dispatch lookup-k '(,third-key 0))))
(check-true (zero? (table-01-eval `(dispatch lookup-k '(,third-key 7))))))))
(test-case
"curried with send/suspend and serializaztion"
(let-values ([(go test-m06.1)
(let-values ([(test-m06.1)
(make-module-eval
(module m06.1 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -253,25 +264,21 @@
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))])
(go the-dispatch)
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))])
(check = 3 (test-m06.1 `(dispatch (list ,second-key 2))))
(check = 4 (test-m06.1 `(dispatch (list ,second-key 3))))
(check-true (zero? (test-m06.1 `(dispatch (list ,second-key -1)))))
(check = -7 (test-m06.1 `(dispatch (list ,third-key 0))))
(check-true (zero? (test-m06.1 `(dispatch (list ,third-key 7)))))))))
(let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
[second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
(check = 3 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 2))))
(check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
(check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING LETREC
(test-suite
"Tests Involving letrec"
(test-case
"mutually recursive even? and odd?"
(let-values ([(go test-m07)
(let-values ([(test-m07)
(make-module-eval
(module m07 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -283,15 +290,14 @@
(and (not (zero? n))
(even? (sub1 n))))])
(even? initial)))))])
(go the-dispatch)
(check-true (test-m07 '(dispatch-start 0)))
(check-true (test-m07 '(dispatch-start 16)))
(check-false (test-m07 '(dispatch-start 1)))
(check-false (test-m07 '(dispatch-start 7)))))
(check-true (test-m07 '(dispatch-start start 0)))
(check-true (test-m07 '(dispatch-start start 16)))
(check-false (test-m07 '(dispatch-start start 1)))
(check-false (test-m07 '(dispatch-start start 7)))))
(test-case
"send/suspend on rhs of letrec binding forms"
(let-values ([(go test-m08)
(let-values ([(test-m08)
(make-module-eval
(module m08 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -310,28 +316,23 @@
(let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result))))))])
(go the-dispatch)
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
[k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))])
(check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))
(check = 9 (test-m08 `(dispatch (list (deserialize ',k2) 6))))
(let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))]
[k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))])
(check-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3)))))
(check = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3)))))))))
(let* ([k0 (test-m08 '(serialize (dispatch-start start 'foo)))]
[k1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))]
[k2 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2))))])
(check = 6 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))
(check = 9 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 6))))
(let* ([k1.1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) -1))))]
[k2.1 (test-m08 `(serialize (dispatch ,the-dispatch (list (deserialize ',k1.1) -2))))])
(check-true (zero? (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2.1) 3)))))
(check = 6 (test-m08 `(dispatch ,the-dispatch (list (deserialize ',k2) 3)))))))))
;; ****************************************
;; ****************************************
;; TEST UNSAFE CONTEXT CONDITION
(test-suite
"Unsafe Context Condition Tests"
; XXX Bizarre
#;(test-case
(test-case
"simple attempt to capture a continuation from an unsafe context"
(let-values ([(go nta-eval)
(let-values ([(nta-eval)
(make-module-eval
(module nta mzscheme
(provide non-tail-apply)
@ -349,12 +350,12 @@
(nta-eval '(require m09))
(check-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start 'foo)))))))
(lambda () (nta-eval '(dispatch-start start 'foo)))))))
(test-case
"sanity-check: capture continuation from safe version of context"
(let-values ([(go m10-eval)
(let-values ([(m10-eval)
(make-module-eval
(module m10 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -364,13 +365,12 @@
result))
(define (start ignore)
(nta (lambda (x) (let/cc k (k x))) 7))))])
(go the-dispatch)
(check = 7 (m10-eval '(dispatch-start 'foo)))))
(check = 7 (m10-eval '(dispatch-start start 'foo)))))
(test-case
"attempt continuation capture from standard call to map"
(let-values ([(go m11-eval)
(let-values ([(m11-eval)
(make-module-eval
(module m11 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -378,14 +378,12 @@
(map
(lambda (x) (let/cc k k))
(list 1 2 3)))))])
(go the-dispatch)
(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
;; should be just fine.
; XXX Weird
#;(test-case
(test-case
"continuation capture from tail position of untranslated procedure"
(let ([ta-eval
@ -405,12 +403,12 @@
(ta-eval '(require m12))
(check = 2 (ta-eval '(dispatch-start 1)))))
(check = 2 (ta-eval '(dispatch-start start 1)))))
(test-case
"attempt send/suspend from standard call to map"
(let-values ([(go m13-eval)
(let-values ([(m13-eval)
(make-module-eval
(module m11 (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -421,15 +419,13 @@
(let ([ignore (printf "n = ~s~n" n)])
k))))
(list 1 2 3)))))])
(go the-dispatch)
(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"
(let-values ([(go ta-eval)
(let-values ([(ta-eval)
(make-module-eval
(module ta mzscheme
(provide tail-apply)
@ -450,6 +446,6 @@
k))))) 7)))))
(ta-eval '(require m14))
(let ([k0 (ta-eval '(dispatch-start 'foo))])
(check = 3 (ta-eval `(dispatch (list ,k0 2))))
(check = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))
(let ([k0 (ta-eval '(dispatch-start start 'foo))])
(check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2))))
(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
"web-parameterize does not overwrite with multiple parameters"
(let-values ([(go meval)
(let-values ([(meval)
(make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server")
(define first (make-web-parameter #f))
@ -30,13 +30,12 @@
(web-parameterize ([first 1]
[second 2])
(+ (first) (second))))))])
(go the-dispatch)
(check = 3 (meval '(dispatch-start #f)))))
(check = 3 (meval '(dispatch-start start #f)))))
(test-case
"web-parameterize does not overwrite with multiple parameters across send/suspend"
(let-values ([(go meval)
(let-values ([(meval)
(make-module-eval
(module m (lib "lang.ss" "web-server" "prototype-web-server")
(provide start)
@ -47,6 +46,5 @@
[second 2])
(send/suspend (lambda (k) k))
(+ (first) (second))))))])
(go the-dispatch)
(let ([first-key (meval '(dispatch-start #f))])
(check = 3 (meval `(dispatch (list ,first-key #f)))))))))))
(let ([first-key (meval '(dispatch-start start #f))])
(check = 3 (meval `(dispatch ,the-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
(test-suite
"tests for persistent-close.ss"
"Tests for persistent-close.ss"
(test-case
"file-vector references"

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

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

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

@ -2,15 +2,6 @@
(provide make-module-eval
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)
(syntax-case m-expr (module)
[(_ (module m-id . rest))
@ -21,11 +12,9 @@
(eval '(module m-id . rest))
(eval '(require m-id)))
(values
(go ns)
(lambda (s-expr)
(parameterize ([current-namespace ns])
(eval s-expr)))))]
(eval s-expr))))]
[else
(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")
(lib "serialize.ss")
,pth)))
(values (go ns)
(lambda (expr)
(parameterize ([current-namespace ns])
(eval expr)))))))
(eval expr))))))