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

Fixing certification tests

Browse Source 
svn: r6294
This commit is contained in:
Jay McCarthy 2007-05-25 15:36:49 +00:00
parent 0b74eca282
commit ec228f9092
11 changed files with 1036 additions and 973 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,6 @@
(module lang mzscheme (module lang mzscheme
(require-for-syntax (lib "etc.ss") (require-for-syntax (lib "etc.ss")
(lib "list.ss")
"labels.ss" "labels.ss"
"lang/util.ss" "lang/util.ss"
"lang/elim-letrec.ss" "lang/elim-letrec.ss"

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

@ -34,133 +34,135 @@
(anormal id stx)) (anormal id stx))
(define (anormal ctxt stx) (define (anormal ctxt stx)
(kernel-syntax-case (recertify
stx #f stx
[(begin) (kernel-syntax-case
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))] stx #f
[(begin lbe) [(begin)
(anormal ctxt (syntax/loc stx lbe))] (anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
[(begin fbe be ...) [(begin lbe)
; XXX Am I a bug? (anormal ctxt (syntax/loc stx lbe))]
(anormal ctxt [(begin fbe be ...)
(syntax/loc stx ; XXX Am I a bug?
(let-values ([(throw-away) fbe]) (anormal ctxt
(begin be ...))))] (syntax/loc stx
[(begin0) (let-values ([(throw-away) fbe])
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))] (begin be ...))))]
[(begin0 lbe) [(begin0)
(anormal ctxt (syntax/loc stx lbe))] (anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
[(begin0 fbe be ...) [(begin0 lbe)
(anormal ctxt (anormal ctxt (syntax/loc stx lbe))]
(syntax/loc stx [(begin0 fbe be ...)
(let-values ([(save) fbe]) (anormal ctxt
(begin be ... save))))] (syntax/loc stx
[(define-values (v ...) ve) (let-values ([(save) fbe])
(with-syntax ([ve (anormal-term #'ve)]) (begin be ... save))))]
(syntax/loc stx [(define-values (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (anormal-term #'ve)])
[(define-syntaxes (v ...) ve) (syntax/loc stx
(with-syntax ([ve (anormal-term #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-syntaxes (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (anormal-term #'ve)])
[(define-values-for-syntax (v ...) ve) (syntax/loc stx
(with-syntax ([ve (anormal-term #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-values-for-syntax (v ...) ve)
(define-values-for-syntax (v ...) ve)))] (with-syntax ([ve (anormal-term #'ve)])
[(set! v ve) (syntax/loc stx
(anormal (define-values-for-syntax (v ...) ve)))]
(compose ctxt [(set! v ve)
(lambda (val) (anormal
(quasisyntax/loc stx (set! v #,val)))) (compose ctxt
#'ve)] (lambda (val)
[(let-values () be) (quasisyntax/loc stx (set! v #,val))))
(anormal ctxt (syntax/loc stx be))] #'ve)]
[(let-values ([(v) ve]) be) [(let-values () be)
(anormal ctxt (anormal ctxt (syntax/loc stx be))]
(syntax/loc stx [(let-values ([(v) ve]) be)
(#%app (lambda (v) be) (anormal ctxt
ve)))] (syntax/loc stx
[(let-values ([(v ...) ve]) be) (#%app (lambda (v) be)
(anormal ctxt ve)))]
(syntax/loc stx [(let-values ([(v ...) ve]) be)
(#%app call-with-values (anormal ctxt
(lambda () ve) (syntax/loc stx
(lambda (v ...) be))))] (#%app call-with-values
[(let-values ([(fv ...) fve] [(v ...) ve] ...) be) (lambda () ve)
(anormal ctxt (lambda (v ...) be))))]
(syntax/loc stx [(let-values ([(fv ...) fve] [(v ...) ve] ...) be)
(let-values ([(fv ...) fve]) (anormal ctxt
(let-values ([(v ...) ve] ...) (syntax/loc stx
be))))] (let-values ([(fv ...) fve])
[(let-values ([(v ...) ve] ...) be ...) (let-values ([(v ...) ve] ...)
(anormal ctxt be))))]
(syntax/loc stx [(let-values ([(v ...) ve] ...) be ...)
(let-values ([(v ...) ve] ...) (anormal ctxt
(begin be ...))))] (syntax/loc stx
[(letrec-values ([(v ...) ve] ...) be ...) (let-values ([(v ...) ve] ...)
(anormal ctxt (begin be ...))))]
(elim-letrec-term stx))] [(letrec-values ([(v ...) ve] ...) be ...)
[(lambda formals be ...) (anormal ctxt
(with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) (elim-letrec-term stx))]
(ctxt (syntax/loc stx (lambda formals nbe))))] [(lambda formals be ...)
[(case-lambda [formals be] ...) (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))])
(with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))]) (ctxt (syntax/loc stx (lambda formals nbe))))]
(ctxt (syntax/loc stx (case-lambda [formals be] ...))))] [(case-lambda [formals be] ...)
[(case-lambda [formals be ...] ...) (with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
(anormal ctxt (ctxt (syntax/loc stx (case-lambda [formals be] ...))))]
(syntax/loc stx (case-lambda [formals (begin be ...)] ...)))] [(case-lambda [formals be ...] ...)
[(if te ce ae) (anormal ctxt
(anormal (syntax/loc stx (case-lambda [formals (begin be ...)] ...)))]
(compose ctxt [(if te ce ae)
(lambda (val) (anormal
(quasisyntax/loc stx (compose ctxt
(if #,val (lambda (val)
#,(anormal-term #'ce) (quasisyntax/loc stx
#,(anormal-term #'ae))))) (if #,val
#'te)] #,(anormal-term #'ce)
[(if te ce) #,(anormal-term #'ae)))))
(anormal ctxt (syntax/loc stx (if te ce (#%app void))))] #'te)]
[(quote datum) [(if te ce)
(ctxt stx)] (anormal ctxt (syntax/loc stx (if te ce (#%app void))))]
[(quote-syntax datum) [(quote datum)
(ctxt stx)] (ctxt stx)]
[(letrec-syntaxes+values ([(sv ...) se] ...) [(quote-syntax datum)
([(vv ...) ve] ...) (ctxt stx)]
be ...) [(letrec-syntaxes+values ([(sv ...) se] ...)
(raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)] ([(vv ...) ve] ...)
[(with-continuation-mark ke me be) be ...)
(anormal (raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)]
(compose ctxt [(with-continuation-mark ke me be)
(lambda (kev) (anormal
(anormal (compose ctxt
(lambda (mev) (lambda (kev)
(quasisyntax/loc stx (anormal
(with-continuation-mark #,kev #,mev (lambda (mev)
#,(anormal-term #'be)))) (quasisyntax/loc stx
#'me))) (with-continuation-mark #,kev #,mev
#'ke)] #,(anormal-term #'be))))
[(#%expression . d) #'me)))
(ctxt stx)] #'ke)]
[(#%app fe e ...) [(#%expression . d)
(anormal (ctxt stx)]
(lambda (val0) [(#%app fe e ...)
(anormal* (anormal
(compose ctxt (lambda (val0)
(lambda (rest-vals) (anormal*
(quasisyntax/loc stx (compose ctxt
(#%app #,val0 #,@rest-vals)))) (lambda (rest-vals)
(syntax->list #'(e ...)))) (quasisyntax/loc stx
#'fe)] (#%app #,val0 #,@rest-vals))))
[(#%top . v) (syntax->list #'(e ...))))
(ctxt stx)] #'fe)]
[(#%datum . d) [(#%top . v)
(ctxt stx)] (ctxt stx)]
[(#%variable-reference . v) [(#%datum . d)
(ctxt stx)] (ctxt stx)]
[id (identifier? #'id) [(#%variable-reference . v)
(ctxt #'id)] (ctxt stx)]
[_ [id (identifier? #'id)
(raise-syntax-error 'anormal "Dropped through:" stx)])) (ctxt #'id)]
[_
(raise-syntax-error 'anormal "Dropped through:" stx)])))
;; anormal*: ((listof w) -> target-expr) (listof source-expr) -> target-expr ;; anormal*: ((listof w) -> target-expr) (listof source-expr) -> target-expr
;; normalize an expression given as a context and list of sub-expressions ;; normalize an expression given as a context and list of sub-expressions

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

@ -15,123 +15,126 @@
; 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)
(kernel-syntax-case (recertify/new-defs
stx #f stx
[(begin be ...) (lambda ()
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) (kernel-syntax-case
(values (quasisyntax/loc stx (begin #,@nbes)) stx #f
defs))] [(begin be ...)
[(begin0 be ...) (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) (values (quasisyntax/loc stx (begin #,@nbes))
(values (quasisyntax/loc stx (begin0 #,@nbes)) defs))]
defs))] [(begin0 be ...)
[(define-values (v ...) ve) (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(let-values ([(nve defs) (defun #'ve)]) (values (quasisyntax/loc stx (begin0 #,@nbes))
(values (quasisyntax/loc stx (define-values (v ...) #,nve)) defs))]
defs))] [(define-values (v ...) ve)
[(define-syntaxes (v ...) ve) (let-values ([(nve defs) (defun #'ve)])
(let-values ([(nve defs) (defun #'ve)]) (values (quasisyntax/loc stx (define-values (v ...) #,nve))
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve)) defs))]
defs))] [(define-syntaxes (v ...) ve)
[(define-values-for-syntax (v ...) ve) (let-values ([(nve defs) (defun #'ve)])
(let-values ([(nve defs) (defun #'ve)]) (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve)) defs))]
defs))] [(define-values-for-syntax (v ...) ve)
[(set! v ve) (let-values ([(nve defs) (defun #'ve)])
(let-values ([(nve defs) (defun #'ve)]) (values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
(values (quasisyntax/loc stx (set! v #,nve)) defs))]
defs))] [(set! v ve)
[(let-values ([(v ...) ve] ...) be ...) (let-values ([(nve defs) (defun #'ve)])
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] (values (quasisyntax/loc stx (set! v #,nve))
[(nbes be-defs) (defun* (syntax->list #'(be ...)))]) defs))]
(with-syntax ([(nve ...) nves] [(let-values ([(v ...) ve] ...) be ...)
[(nbe ...) nbes]) (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
(values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...)) [(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(append ve-defs be-defs))))] (with-syntax ([(nve ...) nves]
[(letrec-values ([(v ...) ve] ...) be ...) [(nbe ...) nbes])
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] (values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))
[(nbes be-defs) (defun* (syntax->list #'(be ...)))]) (append ve-defs be-defs))))]
(with-syntax ([(nve ...) nves] [(letrec-values ([(v ...) ve] ...) be ...)
[(nbe ...) nbes]) (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
(values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...)) [(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(append ve-defs be-defs))))] (with-syntax ([(nve ...) nves]
[(lambda formals be ...) [(nbe ...) nbes])
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) (values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))
(with-syntax ([(nbe ...) nbes]) (append ve-defs be-defs))))]
(let ([fvars (free-vars stx)]) [(lambda formals be ...)
(let-values ([(make-CLOSURE new-defs) (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(make-closure-definition-syntax (with-syntax ([(nbe ...) nbes])
(make-new-closure-label (current-code-labeling) stx) (let ([fvars (free-vars stx)])
fvars (let-values ([(make-CLOSURE new-defs)
(syntax/loc stx (lambda formals nbe ...)))]) (make-closure-definition-syntax
(values (if (empty? fvars) (make-new-closure-label (current-code-labeling) stx)
(quasisyntax/loc stx (#,make-CLOSURE)) fvars
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) (syntax/loc stx (lambda formals nbe ...)))])
(append be-defs new-defs))))))] (values (if (empty? fvars)
[(case-lambda [formals be ...] ...) (quasisyntax/loc stx (#,make-CLOSURE))
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))]) (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(with-syntax ([((nbe ...) ...) nbes]) (append be-defs new-defs))))))]
(let ([fvars (free-vars stx)]) [(case-lambda [formals be ...] ...)
(let-values ([(make-CLOSURE new-defs) (let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
(make-closure-definition-syntax (with-syntax ([((nbe ...) ...) nbes])
(make-new-closure-label (current-code-labeling) stx) (let ([fvars (free-vars stx)])
fvars (let-values ([(make-CLOSURE new-defs)
(syntax/loc stx (case-lambda [formals nbe ...] ...)))]) (make-closure-definition-syntax
(values (if (empty? fvars) (make-new-closure-label (current-code-labeling) stx)
(quasisyntax/loc stx (#,make-CLOSURE)) fvars
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) (syntax/loc stx (case-lambda [formals nbe ...] ...)))])
(append be-defs new-defs))))))] (values (if (empty? fvars)
[(if te ce ae) (quasisyntax/loc stx (#,make-CLOSURE))
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))]) (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(values (quasisyntax/loc stx (if #,@es)) (append be-defs new-defs))))))]
defs))] [(if te ce ae)
[(if te ce) (let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
(defun (quasisyntax/loc stx (if te ce (#%app void))))] (values (quasisyntax/loc stx (if #,@es))
[(quote datum) defs))]
(values stx [(if te ce)
empty)] (defun (quasisyntax/loc stx (if te ce (#%app void))))]
[(quote-syntax datum) [(quote datum)
(values stx
empty)]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
[(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nse ...) nses]
[(nve ...) nves]
[(nbe ...) nbes])
(values (syntax/loc stx
(letrec-syntaxes+values ([(sv ...) nse] ...)
([(vv ...) nve] ...)
nbe ...))
(append se-defs ve-defs be-defs))))]
[(with-continuation-mark ke me be)
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
defs))]
[(#%expression . d)
(values stx
empty)]
[(#%app e ...)
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
(values (quasisyntax/loc stx (#%app #,@es))
defs))]
[(#%top . v)
(values stx
empty)]
[(#%datum . d)
(values stx
empty)]
[(#%variable-reference . v)
(values stx
empty)]
[id (identifier? #'id)
(values stx (values stx
empty)] empty)]
[_ [(quote-syntax datum)
(raise-syntax-error 'defun "Dropped through:" stx)])) (values stx
empty)]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
[(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nse ...) nses]
[(nve ...) nves]
[(nbe ...) nbes])
(values (syntax/loc stx
(letrec-syntaxes+values ([(sv ...) nse] ...)
([(vv ...) nve] ...)
nbe ...))
(append se-defs ve-defs be-defs))))]
[(with-continuation-mark ke me be)
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
defs))]
[(#%expression . d)
(values stx
empty)]
[(#%app e ...)
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
(values (quasisyntax/loc stx (#%app #,@es))
defs))]
[(#%top . v)
(values stx
empty)]
[(#%datum . d)
(values stx
empty)]
[(#%variable-reference . v)
(values stx
empty)]
[id (identifier? #'id)
(values stx
empty)]
[_
(raise-syntax-error 'defun "Dropped through:" stx)]))))
; lift defun to list of syntaxes ; lift defun to list of syntaxes
(define (lift-defun defun) (define (lift-defun defun)

308
collects/web-server/prototype-web-server/lang/elim-callcc.ss
View File

@ -10,161 +10,165 @@
;; mark-lambda-as-safe: w -> w ;; mark-lambda-as-safe: w -> w
;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark ;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark
(define (mark-lambda-as-safe w) (define (mark-lambda-as-safe w)
(syntax-case w (lambda case-lambda) (recertify
[(lambda formals be ...) w
(syntax/loc w (syntax-case w (lambda case-lambda)
(lambda formals [(lambda formals be ...)
(with-continuation-mark safe-call? '(#t (lambda formals)) (syntax/loc w
be ...)))] (lambda formals
[(case-lambda [formals be ...] ...) (with-continuation-mark safe-call? '(#t (lambda formals))
(syntax/loc w be ...)))]
(case-lambda [formals [(case-lambda [formals be ...] ...)
(with-continuation-mark safe-call? '(#t (case-lambda formals ...)) (syntax/loc w
be ...)] ...))] (case-lambda [formals
[_else w])) (with-continuation-mark safe-call? '(#t (case-lambda formals ...))
be ...)] ...))]
[_else w])))
(define (elim-callcc stx) (define (elim-callcc stx)
(elim-callcc/mark id stx)) (elim-callcc/mark id stx))
(define (elim-callcc/mark markit stx) (define (elim-callcc/mark markit stx)
(kernel-syntax-case* (recertify
stx #f (call/cc call-with-values) stx
[(begin be ...) (kernel-syntax-case*
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] stx #f (call/cc call-with-values)
[(begin0 be ...) [(begin be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(define-values (v ...) ve) [(begin0 be ...)
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
(syntax/loc stx [(define-values (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
[(define-syntaxes (v ...) ve) (syntax/loc stx
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-syntaxes (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
[(define-values-for-syntax (v ...) ve) (syntax/loc stx
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-values-for-syntax (v ...) ve)
(define-values-for-syntax (v ...) ve)))] (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
[(set! v ve) (syntax/loc stx
(with-syntax ([ve (elim-callcc #'ve)]) (define-values-for-syntax (v ...) ve)))]
(syntax/loc stx (set! v ve)))] [(set! v ve)
[(let-values ([(v ...) ve] ...) be ...) (with-syntax ([ve (elim-callcc #'ve)])
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] (syntax/loc stx (set! v ve)))]
[(letrec-values ([(v ...) ve] ...) be ...) [(let-values ([(v ...) ve] ...) be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(lambda formals be) [(letrec-values ([(v ...) ve] ...) be ...)
(with-syntax ([be (elim-callcc #'be)]) (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
(syntax/loc stx [(lambda formals be)
(lambda formals be)))] (with-syntax ([be (elim-callcc #'be)])
[(case-lambda [formals be] ...) (syntax/loc stx
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))]) (lambda formals be)))]
(syntax/loc stx [(case-lambda [formals be] ...)
(case-lambda [formals be] ...)))] (with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
[(if te ce ae) (syntax/loc stx
(with-syntax ([te (elim-callcc #'te)] (case-lambda [formals be] ...)))]
[ce (elim-callcc #'ce)] [(if te ce ae)
[ae (elim-callcc #'ae)]) (with-syntax ([te (elim-callcc #'te)]
(markit (syntax/loc stx (if te ce ae))))] [ce (elim-callcc #'ce)]
[(if te ce) [ae (elim-callcc #'ae)])
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] (markit (syntax/loc stx (if te ce ae))))]
[(quote datum) [(if te ce)
stx] (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(quote-syntax datum) [(quote datum)
stx] stx]
[(letrec-syntaxes+values ([(sv ...) se] ...) [(quote-syntax datum)
([(vv ...) ve] ...) stx]
be ...) [(letrec-syntaxes+values ([(sv ...) se] ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] ([(vv ...) ve] ...)
[(with-continuation-mark ke me be) be ...)
(let* ([ke-prime (elim-callcc #'ke)] (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[me-prime (elim-callcc #'me)] [(with-continuation-mark ke me be)
[be-prime (elim-callcc #'be)]) (let* ([ke-prime (elim-callcc #'ke)]
(markit [me-prime (elim-callcc #'me)]
(quasisyntax/loc stx [be-prime (elim-callcc #'be)])
(with-continuation-mark #,ke-prime #,me-prime (markit
(with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime) (quasisyntax/loc stx
#,be-prime)))))] (with-continuation-mark #,ke-prime #,me-prime
[(#%expression . d) (with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime)
stx] #,be-prime)))))]
[(#%app call/cc w) [(#%expression . d)
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)] stx]
[(x ref-to-x) (generate-formal 'x)]) [(#%app call/cc w)
(markit (let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
(quasisyntax/loc stx [(x ref-to-x) (generate-formal 'x)])
(#%app #,(elim-callcc #'w) (markit
(#%app (lambda (#,cm) (quasisyntax/loc stx
(lambda #,x (#%app #,(elim-callcc #'w)
(#%app abort (#%app (lambda (#,cm)
(lambda () (#%app resume #,ref-to-cm #,ref-to-x))))) (lambda #,x
(#%app activation-record-list))))))] (#%app abort
[(#%app call-with-values (lambda () prod) cons) (lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
(let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))]) (#%app activation-record-list))))))]
(markit [(#%app call-with-values (lambda () prod) cons)
(quasisyntax/loc stx (let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
(#%app call-with-values (markit
#,(mark-lambda-as-safe (quasisyntax/loc stx
(quasisyntax/loc stx (#%app call-with-values
(lambda () #,(mark-lambda-as-safe
#,(elim-callcc/mark (quasisyntax/loc stx
(lambda (x) (lambda ()
(quasisyntax/loc stx #,(elim-callcc/mark
(with-continuation-mark the-cont-key #,cons-prime #,x))) (lambda (x)
#'prod)))) (quasisyntax/loc stx
#,cons-prime))))] (with-continuation-mark the-cont-key #,cons-prime #,x)))
[(#%app w (#%app . stuff)) #'prod))))
(with-syntax ([e #'(#%app . stuff)]) #,cons-prime))))]
(syntax-case #'w (lambda case-lambda) [(#%app w (#%app . stuff))
[(lambda formals body) (with-syntax ([e #'(#%app . stuff)])
(let ([w-prime (datum->syntax-object #f (gensym 'l))]) (syntax-case #'w (lambda case-lambda)
(quasisyntax/loc stx [(lambda formals body)
(let-values ([(#,w-prime) #,(elim-callcc #'w)]) (let ([w-prime (datum->syntax-object #f (gensym 'l))])
#,(markit
(quasisyntax/loc stx
(#%app #,w-prime
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,w-prime #,x)))
#'e)))))))]
[(case-lambda [formals body] ...)
(let ([w-prime (datum->syntax-object #f (gensym 'cl))])
(quasisyntax/loc stx
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
#,(markit
(quasisyntax/loc stx
(#%app #,w-prime
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,w-prime #,x)))
#'e)))))))]
[_else
(let ([w-prime (elim-callcc #'w)])
(markit
(quasisyntax/loc stx (quasisyntax/loc stx
(#%app #,w-prime (let-values ([(#,w-prime) #,(elim-callcc #'w)])
#,(elim-callcc/mark #,(markit
(lambda (x) (quasisyntax/loc stx
#`(with-continuation-mark the-cont-key #,w-prime #,x)) (#%app #,w-prime
#'e)))))]))] #,(elim-callcc/mark
[(#%app w rest ...) (lambda (x)
(markit (quasisyntax/loc stx
(quasisyntax/loc stx (with-continuation-mark the-cont-key #,w-prime #,x)))
(with-continuation-mark safe-call? '(#f #,stx) #'e)))))))]
(#%app #,(mark-lambda-as-safe (elim-callcc #'w)) [(case-lambda [formals body] ...)
#,@(map (let ([w-prime (datum->syntax-object #f (gensym 'cl))])
(lambda (an-expr) (quasisyntax/loc stx
(mark-lambda-as-safe (let-values ([(#,w-prime) #,(elim-callcc #'w)])
(elim-callcc #,(markit
an-expr))) (quasisyntax/loc stx
(syntax->list #'(rest ...)))))))] (#%app #,w-prime
[(#%top . v) #,(elim-callcc/mark
stx] (lambda (x)
[(#%datum . d) (quasisyntax/loc stx
stx] (with-continuation-mark the-cont-key #,w-prime #,x)))
[(#%variable-reference . v) #'e)))))))]
stx] [_else
[id (identifier? #'id) (let ([w-prime (elim-callcc #'w)])
stx] (markit
[_ (quasisyntax/loc stx
(raise-syntax-error 'elim-callcc "Dropped through:" stx)]))) (#%app #,w-prime
#,(elim-callcc/mark
(lambda (x)
#`(with-continuation-mark the-cont-key #,w-prime #,x))
#'e)))))]))]
[(#%app w rest ...)
(markit
(quasisyntax/loc stx
(with-continuation-mark safe-call? '(#f #,stx)
(#%app #,(mark-lambda-as-safe (elim-callcc #'w))
#,@(map
(lambda (an-expr)
(mark-lambda-as-safe
(elim-callcc
an-expr)))
(syntax->list #'(rest ...)))))))]
[(#%top . v)
stx]
[(#%datum . d)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
stx]
[_
(raise-syntax-error 'elim-callcc "Dropped through:" stx)]))))

244
collects/web-server/prototype-web-server/lang/elim-letrec.ss
View File

@ -11,127 +11,129 @@
; Eliminates letrec-values from syntax[2] and correctly handles references to ; Eliminates letrec-values from syntax[2] and correctly handles references to
; letrec-bound variables [3] therein. ; letrec-bound variables [3] therein.
(define ((elim-letrec ids) stx) (define ((elim-letrec ids) stx)
(kernel-syntax-case (recertify
stx #f stx
[(begin be ...) (kernel-syntax-case
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) stx #f
(syntax/loc stx [(begin be ...)
(begin be ...)))] (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
[(begin0 be ...) (syntax/loc stx
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) (begin be ...)))]
(syntax/loc stx [(begin0 be ...)
(begin0 be ...)))] (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
[(define-values (v ...) ve) (syntax/loc stx
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (begin0 be ...)))]
(syntax/loc stx [(define-values (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve ((elim-letrec ids) #'ve)])
[(define-syntaxes (v ...) ve) (syntax/loc stx
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-syntaxes (v ...) ve)
(define-syntaxes (v ...) ve)))] (with-syntax ([ve ((elim-letrec ids) #'ve)])
[(define-values-for-syntax (v ...) ve) (syntax/loc stx
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (define-syntaxes (v ...) ve)))]
(syntax/loc stx [(define-values-for-syntax (v ...) ve)
(define-values-for-syntax (v ...) ve)))] (with-syntax ([ve ((elim-letrec ids) #'ve)])
[(set! v ve) (syntax/loc stx
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (define-values-for-syntax (v ...) ve)))]
(if (bound-identifier-member? #'id ids) [(set! v ve)
(syntax/loc stx (#%app set-box! id ve)) (with-syntax ([ve ((elim-letrec ids) #'ve)])
(syntax/loc stx (set! id ve))))]
[(let-values ([(v ...) ve] ...) be ...)
(with-syntax ([(ve ...) (map (elim-letrec ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(let-values ([(v ...) ve] ...) be ...)))]
[(letrec-values ([(v ...) ve] ...) be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))])
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
[((nv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((v ...) ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(syntax/loc stx
(let-values ([(v ...)
(#%app values nv-box ...)] ...)
(begin (#%app call-with-values
(lambda () ve)
(lambda (nv ...)
(#%app set-box! v nv) ...))
...
be ...)))))]
[(lambda formals be ...)
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(lambda formals be ...)))]
[(case-lambda [formals be ...] ...)
(with-syntax ([((be ...) ...) (map (elim-letrec ids) (syntax->list #'((be ...) ...)))])
(syntax/loc stx
(case-lambda [formals be ...] ...)))]
[(if te ce ae)
(with-syntax ([te ((elim-letrec ids) #'te)]
[ce ((elim-letrec ids) #'ce)]
[ae ((elim-letrec ids) #'ae)])
(syntax/loc stx
(if te ce ae)))]
[(if te ce)
((elim-letrec ids)
(syntax/loc stx
(if te ce (#%app (#%top . void)))))]
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
(with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
[((nvv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((vv ...) ...)))]
[(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(syntax/loc stx
(let-values ([(vv ...)
(#%app values nvv-box ...)] ...)
; This is okay, because we've already expanded the syntax.
(let-syntaxes
([(sv ...) se] ...)
(begin (#%app call-with-values
(lambda () ve)
(lambda (nvv ...)
(#%app set-box! vv nvv) ...))
...
be ...))))))]
[(with-continuation-mark ke me be)
(with-syntax ([ke ((elim-letrec ids) #'ke)]
[me ((elim-letrec ids) #'me)]
[be ((elim-letrec ids) #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%expression . d)
stx]
[(#%app e ...)
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
(syntax/loc stx
(#%app e ...)))]
[(#%top . v)
stx]
[(#%datum . d)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
(if (bound-identifier-member? #'id ids) (if (bound-identifier-member? #'id ids)
(syntax/loc stx (#%app unbox id)) (syntax/loc stx (#%app set-box! id ve))
#'id)] (syntax/loc stx (set! id ve))))]
[_ [(let-values ([(v ...) ve] ...) be ...)
(raise-syntax-error 'elim-letrec "Dropped through:" stx)])) (with-syntax ([(ve ...) (map (elim-letrec ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(let-values ([(v ...) ve] ...) be ...)))]
[(letrec-values ([(v ...) ve] ...) be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))])
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
[((nv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((v ...) ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(syntax/loc stx
(let-values ([(v ...)
(#%app values nv-box ...)] ...)
(begin (#%app call-with-values
(lambda () ve)
(lambda (nv ...)
(#%app set-box! v nv) ...))
...
be ...)))))]
[(lambda formals be ...)
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(lambda formals be ...)))]
[(case-lambda [formals be ...] ...)
(with-syntax ([((be ...) ...) (map (elim-letrec ids) (syntax->list #'((be ...) ...)))])
(syntax/loc stx
(case-lambda [formals be ...] ...)))]
[(if te ce ae)
(with-syntax ([te ((elim-letrec ids) #'te)]
[ce ((elim-letrec ids) #'ce)]
[ae ((elim-letrec ids) #'ae)])
(syntax/loc stx
(if te ce ae)))]
[(if te ce)
((elim-letrec ids)
(syntax/loc stx
(if te ce (#%app (#%top . void)))))]
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
(with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
[((nvv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((vv ...) ...)))]
[(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(syntax/loc stx
(let-values ([(vv ...)
(#%app values nvv-box ...)] ...)
; This is okay, because we've already expanded the syntax.
(let-syntaxes
([(sv ...) se] ...)
(begin (#%app call-with-values
(lambda () ve)
(lambda (nvv ...)
(#%app set-box! vv nvv) ...))
...
be ...))))))]
[(with-continuation-mark ke me be)
(with-syntax ([ke ((elim-letrec ids) #'ke)]
[me ((elim-letrec ids) #'me)]
[be ((elim-letrec ids) #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%expression . d)
stx]
[(#%app e ...)
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
(syntax/loc stx
(#%app e ...)))]
[(#%top . v)
stx]
[(#%datum . d)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
(if (bound-identifier-member? #'id ids)
(syntax/loc stx (#%app unbox id))
#'id)]
[_
(raise-syntax-error 'elim-letrec "Dropped through:" stx)])))
(define elim-letrec-term (elim-letrec empty))) (define elim-letrec-term (elim-letrec empty)))

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

@ -4,6 +4,21 @@
(lib "list.ss")) (lib "list.ss"))
(provide (all-defined)) (provide (all-defined))
(define (recertify old-expr expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
(define (recertify* old-expr exprs)
(map (lambda (expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
exprs))
(define (recertify/new-defs old-expr thunk)
(call-with-values
thunk
(lambda (expr new-defs)
(values (recertify old-expr expr)
(recertify* old-expr new-defs)))))
(define current-code-labeling (define current-code-labeling
(make-parameter (make-parameter
(lambda (stx) (lambda (stx)
@ -27,70 +42,78 @@
(list* #'rv (syntax->list #'(v ...)))])) (list* #'rv (syntax->list #'(v ...)))]))
(define ((make-define-case inner) stx) (define ((make-define-case inner) stx)
(syntax-case stx (define-values define-syntaxes define-values-for-syntax) (recertify
[(define-values (v ...) ve) stx
(with-syntax ([ve (inner #'ve)]) (syntax-case stx (define-values define-syntaxes define-values-for-syntax)
(syntax/loc stx [(define-values (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (inner #'ve)])
[(define-syntaxes (v ...) ve) (syntax/loc stx
(with-syntax ([ve (inner #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-syntaxes (v ...) ve)
(define-syntaxes (v ...) ve)))] (with-syntax ([ve (inner #'ve)])
[(define-values-for-syntax (v ...) ve) (syntax/loc stx
(with-syntax ([ve (inner #'ve)]) (define-syntaxes (v ...) ve)))]
(syntax/loc stx [(define-values-for-syntax (v ...) ve)
(define-values-for-syntax (v ...) ve)))] (with-syntax ([ve (inner #'ve)])
[_ (syntax/loc stx
(raise-syntax-error 'define-case "Dropped through:" stx)])) (define-values-for-syntax (v ...) ve)))]
[_
(raise-syntax-error 'define-case "Dropped through:" stx)])))
(define ((make-define-case/new-defs inner) stx) (define ((make-define-case/new-defs inner) stx)
(let-values ([(nstx defs) (inner stx)]) (let-values ([(nstx defs) (inner stx)])
(append defs (list nstx)))) (append defs (list nstx))))
(define ((make-module-case/new-defs inner) stx) (define ((make-module-case/new-defs inner) stx)
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? (recertify*
[(require spec ...) stx
(list stx)] (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
[(provide spec ...) [(require spec ...)
(list stx)] (list stx)]
[(require-for-syntax spec ...) [(provide spec ...)
(list stx)] (list stx)]
[(require-for-template spec ...) [(require-for-syntax spec ...)
(list stx)] (list stx)]
[_ [(require-for-template spec ...)
(inner stx)])) (list stx)]
[_
(inner stx)])))
(define ((make-module-case inner) stx) (define ((make-module-case inner) stx)
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? (recertify
[(require spec ...) stx
stx] (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
[(provide spec ...) [(require spec ...)
stx] stx]
[(require-for-syntax spec ...) [(provide spec ...)
stx] stx]
[(require-for-template spec ...) [(require-for-syntax spec ...)
stx] stx]
[_ [(require-for-template spec ...)
(inner stx)])) stx]
[_
(inner stx)])))
(define ((make-lang-module-begin make-labeling transform) stx) (define ((make-lang-module-begin make-labeling transform) stx)
(syntax-case stx () (recertify
((mb forms ...) stx
(with-syntax ([(pmb rfs body ...) (syntax-case stx ()
(local-expand (quasisyntax/loc stx ((mb forms ...)
(#%plain-module-begin (with-syntax ([(pmb rfs body ...)
#,(syntax-local-introduce #'(require-for-syntax mzscheme)) (local-expand (quasisyntax/loc stx
forms ...)) (#%plain-module-begin
'module-begin #,(syntax-local-introduce #'(require-for-syntax mzscheme))
empty)]) forms ...))
(let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))]) 'module-begin
(parameterize ([current-code-labeling empty)])
(lambda (stx) (let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))])
(datum->syntax-object stx (base-labeling)))]) (parameterize ([current-code-labeling
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))]) (lambda (stx)
(quasisyntax/loc stx (datum->syntax-object stx (base-labeling)))])
(pmb rfs (let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
#,@new-defs))))))))) (quasisyntax/loc stx
(pmb rfs
#,@new-defs))))))))))
(define (bound-identifier-member? id ids) (define (bound-identifier-member? id ids)
(ormap (ormap
@ -100,91 +123,93 @@
;; Kernel Case Template ;; Kernel Case Template
(define (template stx) (define (template stx)
(kernel-syntax-case (recertify
stx #f stx
[(begin be ...) (kernel-syntax-case
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) stx #f
(syntax/loc stx [(begin be ...)
(begin be ...)))] (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
[(begin0 be ...) (syntax/loc stx
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) (begin be ...)))]
(syntax/loc stx [(begin0 be ...)
(begin0 be ...)))] (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
[(define-values (v ...) ve) (syntax/loc stx
(with-syntax ([ve (template #'ve)]) (begin0 be ...)))]
(syntax/loc stx [(define-values (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (template #'ve)])
[(define-syntaxes (v ...) ve) (syntax/loc stx
(with-syntax ([ve (template #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-syntaxes (v ...) ve)
(define-values (v ...) ve)))] (with-syntax ([ve (template #'ve)])
[(define-values-for-syntax (v ...) ve) (syntax/loc stx
(with-syntax ([ve (template #'ve)]) (define-values (v ...) ve)))]
(syntax/loc stx [(define-values-for-syntax (v ...) ve)
(define-values-for-syntax (v ...) ve)))] (with-syntax ([ve (template #'ve)])
[(set! v ve) (syntax/loc stx
(with-syntax ([ve (template #'ve)]) (define-values-for-syntax (v ...) ve)))]
(syntax/loc stx [(set! v ve)
(set! v ve)))] (with-syntax ([ve (template #'ve)])
[(let-values ([(v ...) ve] ...) be ...) (syntax/loc stx
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] (set! v ve)))]
[(be ...) (map template (syntax->list #'(be ...)))]) [(let-values ([(v ...) ve] ...) be ...)
(syntax/loc stx (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
(let-values ([(v ...) ve] ...) be ...)))] [(be ...) (map template (syntax->list #'(be ...)))])
[(letrec-values ([(v ...) ve] ...) be ...) (syntax/loc stx
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] (let-values ([(v ...) ve] ...) be ...)))]
[(be ...) (map template (syntax->list #'(be ...)))]) [(letrec-values ([(v ...) ve] ...) be ...)
(syntax/loc stx (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
(letrec-values ([(v ...) ve] ...) be ...)))] [(be ...) (map template (syntax->list #'(be ...)))])
[(lambda formals be ...) (syntax/loc stx
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) (letrec-values ([(v ...) ve] ...) be ...)))]
(syntax/loc stx [(lambda formals be ...)
(lambda formals be ...)))] (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
[(case-lambda [formals be ...] ...) (syntax/loc stx
(with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))]) (lambda formals be ...)))]
(syntax/loc stx [(case-lambda [formals be ...] ...)
(case-lambda [formals be ...] ...)))] (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
[(if te ce ae) (syntax/loc stx
(with-syntax ([te (template #'te)] (case-lambda [formals be ...] ...)))]
[ce (template #'ce)] [(if te ce ae)
[ae (template #'ae)]) (with-syntax ([te (template #'te)]
(syntax/loc stx [ce (template #'ce)]
(if te ce ae)))] [ae (template #'ae)])
[(if te ce) (syntax/loc stx
(template (syntax/loc stx (if te ce (#%app void))))] (if te ce ae)))]
[(quote datum) [(if te ce)
stx] (template (syntax/loc stx (if te ce (#%app void))))]
[(quote-syntax datum) [(quote datum)
stx] stx]
[(letrec-syntaxes+values ([(sv ...) se] ...) [(quote-syntax datum)
([(vv ...) ve] ...) stx]
be ...) [(letrec-syntaxes+values ([(sv ...) se] ...)
(with-syntax ([(se ...) (map template (syntax->list #'(se ...)))] ([(vv ...) ve] ...)
[(ve ...) (map template (syntax->list #'(ve ...)))] be ...)
[(be ...) (map template (syntax->list #'(be ...)))]) (with-syntax ([(se ...) (map template (syntax->list #'(se ...)))]
(syntax/loc stx [(ve ...) (map template (syntax->list #'(ve ...)))]
(letrec-syntaxes+values ([(sv ...) se] ...) [(be ...) (map template (syntax->list #'(be ...)))])
([(vv ...) ve] ...) (syntax/loc stx
be ...)))] (letrec-syntaxes+values ([(sv ...) se] ...)
[(with-continuation-mark ke me be) ([(vv ...) ve] ...)
(with-syntax ([ke (template #'ke)] be ...)))]
[me (template #'me)] [(with-continuation-mark ke me be)
[be (template #'be)]) (with-syntax ([ke (template #'ke)]
(syntax/loc stx [me (template #'me)]
(with-continuation-mark ke me be)))] [be (template #'be)])
[(#%expression . d) (syntax/loc stx
stx] (with-continuation-mark ke me be)))]
[(#%app e ...) [(#%expression . d)
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))]) stx]
(syntax/loc stx [(#%app e ...)
(#%app e ...)))] (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
[(#%top . v) (syntax/loc stx
stx] (#%app e ...)))]
[(#%datum . d) [(#%top . v)
stx] stx]
[(#%variable-reference . v) [(#%datum . d)
stx] stx]
[id (identifier? #'id) [(#%variable-reference . v)
stx] stx]
[_ [id (identifier? #'id)
(raise-syntax-error 'kerncase "Dropped through:" stx)]))) stx]
[_
(raise-syntax-error 'kerncase "Dropped through:" stx)]))))

58
collects/web-server/prototype-web-server/tests/certify-tests.ss Normal file
View File

@ -0,0 +1,58 @@
(module certify-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"language-tester.ss")
(provide certify-suite)
(define certify-suite
(make-test-suite
"Test the certification process"
(make-test-suite
"Splicing tests"
(make-test-case
"quasi-quote with splicing: need to recertify context for qq-append"
(let-values ([(go test-m01.1)
(make-module-eval
(module m01.1 "../lang.ss"
(provide start)
(define (start initial)
`(,@(list 1 2 initial)))))])
(go)
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(make-test-case
"recertify context test (1)"
(let-values ([(go test-m01.2)
(make-module-eval
(module m01.1 "../lang.ss"
(provide start)
(define (start initial)
`(foo ,@(list 1 2 3)))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (2)"
(let-values ([(go test-m01.3)
(make-module-eval
(module m01.3 "../lang.ss"
(provide start)
(define (start n)
`(n ,@(list 1 2 3)))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (3)"
(let-values ([(go test-m01.4)
(make-module-eval
(module m1 "../lang.ss"
(provide start)
(define (start initial)
(define (bar n)
`(n ,@(list 1 2 3)))
(bar 7))))])
(go)
(assert-true #t)))))))

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

@ -27,36 +27,36 @@
(make-test-case (make-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 ([(go test-m00.4)
(make-module-eval (make-module-eval
(module m00.4 "../lang.ss" (module m00.4 "../lang.ss"
(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) (go)
(assert = 8 (test-m00.4 '(dispatch-start 1))))) (assert = 8 (test-m00.4 '(dispatch-start 1)))))
(make-test-case (make-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 ([(go test-m00.3)
(make-module-eval (make-module-eval
(module m00.3 "../lang.ss" (module m00.3 "../lang.ss"
(define (foo x) 'foo) (define (foo x) 'foo)
(provide start) (provide start)
(define (start initial) (define (start initial)
(foo initial))))]) (foo initial))))])
(go) (go)
(assert eqv? 'foo (test-m00.3 '(dispatch-start 7))))) (assert eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(make-test-case (make-test-case
"identity interaction, dispatch-start called multiple times" "identity interaction, dispatch-start called multiple times"
(let-values ([(go test-m00) (let-values ([(go test-m00)
(make-module-eval (make-module-eval
(module m00 "../lang.ss" (module m00 "../lang.ss"
(define (id x) x) (define (id x) x)
(provide start) (provide start)
(define (start initial) (define (start initial)
(id initial))))]) (id initial))))])
(go) (go)
(assert = 7 (test-m00 '(dispatch-start 7))) (assert = 7 (test-m00 '(dispatch-start 7)))
(assert eqv? 'foo (test-m00 '(dispatch-start 'foo))))) (assert eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
@ -64,22 +64,22 @@
(make-test-case (make-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 ([(go test-m00.1)
(make-module-eval (make-module-eval
(module m00.1 "../lang.ss" (module m00.1 "../lang.ss"
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ 1 initial))))]) (+ 1 initial))))])
(go) (go)
(assert = 2 (test-m00.1 '(dispatch-start 1))))) (assert = 2 (test-m00.1 '(dispatch-start 1)))))
(make-test-case (make-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 ([(go test-m00.2)
(make-module-eval (make-module-eval
(module m00.2 "../lang.ss" (module m00.2 "../lang.ss"
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ (+ 1 1) initial))))]) (+ (+ 1 1) initial))))])
(go) (go)
(assert = 14 (test-m00.2 '(dispatch-start 12))) (assert = 14 (test-m00.2 '(dispatch-start 12)))
(assert = 20 (test-m00.2 '(dispatch-start 18))))) (assert = 20 (test-m00.2 '(dispatch-start 18)))))
@ -87,57 +87,15 @@
(make-test-case (make-test-case
"start-interaction in third position" "start-interaction in third position"
(let-values ([(go test-m01) (let-values ([(go test-m01)
(make-module-eval (make-module-eval
(module m01 "../lang.ss" (module m01 "../lang.ss"
(provide start) (provide start)
(define (start initial) (define (start initial)
(+ (* 1 2) (* 3 4) initial))))]) (+ (* 1 2) (* 3 4) initial))))])
(go) (go)
(assert = 14 (test-m01 '(dispatch-start 0))) (assert = 14 (test-m01 '(dispatch-start 0)))
(assert = 20 (test-m01 '(dispatch-start 6))))) (assert = 20 (test-m01 '(dispatch-start 6)))))
(make-test-case
"quasi-quote with splicing: need to recertify context for qq-append"
(let-values ([(go test-m01.1)
(make-module-eval
(module m01.1 "../lang.ss"
(provide start)
(define (start initial)
`(,@(list 1 2 initial)))))])
(go)
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(make-test-case
"recertify context test (1)"
(let-values ([(go test-m01.2)
(make-module-eval
(module m01.1 "../lang.ss"
`(foo ,@(list 1 2 3))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (2)"
(let-values ([(go test-m01.3)
(make-module-eval
(module m01.3 "../lang.ss"
(lambda (n)
`(n ,@(list 1 2 3)))))])
(go)
(assert-true #t)))
(make-test-case
"recertify context test (3)"
(let-values ([(go test-m01.4)
(make-module-eval
(module m1 "../lang.ss"
(define (bar n)
`(n ,@(list 1 2 3)))
(bar 7)))])
(go)
(assert-true #t)))
;; start-interaction may be called mutitple times ;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction ;; each call overwrites the previous interaction
;; continuation with the latest one. ;; continuation with the latest one.
@ -166,12 +124,12 @@
(make-test-case (make-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 ([(go test-m03)
(make-module-eval (make-module-eval
(module m03 "../lang.ss" (module m03 "../lang.ss"
(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) (go)
(assert = 3 (test-m03 '(dispatch-start 'foo))) (assert = 3 (test-m03 '(dispatch-start 'foo)))
(assert = 3 (test-m03 '(dispatch-start 7))))) (assert = 3 (test-m03 '(dispatch-start 7)))))
@ -182,17 +140,17 @@
(make-test-case (make-test-case
"non-tail-recursive 'escaping' continuation" "non-tail-recursive 'escaping' continuation"
(let-values ([(go test-m04) (let-values ([(go test-m04)
(make-module-eval (make-module-eval
(module m04 "../lang.ss" (module m04 "../lang.ss"
(provide start) (provide start)
(define (start ln) (define (start ln)
(let/cc k (let/cc k
(cond (cond
[(null? ln) 1] [(null? ln) 1]
[(zero? (car ln)) (k 0)] [(zero? (car ln)) (k 0)]
[else [else
(* (car ln) (* (car ln)
(start (cdr ln)))])))))]) (start (cdr ln)))])))))])
(go) (go)
(assert = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9)))) (assert = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9))))
(assert = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5)))))) (assert = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5))))))
@ -204,21 +162,21 @@
(make-test-case (make-test-case
"tail-recursive escaping continuation" "tail-recursive escaping continuation"
(let-values ([(go test-m05) (let-values ([(go test-m05)
(make-module-eval (make-module-eval
(module m05 "../lang.ss" (module m05 "../lang.ss"
(provide start) (provide start)
(define (start ln) (define (start ln)
(let/cc escape (let/cc escape
(mult/escape escape ln))) (mult/escape escape ln)))
(define (mult/escape escape ln) (define (mult/escape escape ln)
(cond (cond
[(null? ln) 1] [(null? ln) 1]
[(zero? (car ln)) (escape 0)] [(zero? (car ln)) (escape 0)]
[else [else
(* (car ln) (* (car ln)
(mult/escape escape (cdr ln)))]))))]) (mult/escape escape (cdr ln)))]))))])
(go) (go)
(assert = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6)))) (assert = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6))))
(assert = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5))))))) (assert = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
@ -231,65 +189,65 @@
; XXX This doesn't work, because we don't allow a different dispatcher ; XXX This doesn't work, because we don't allow a different dispatcher
#;(make-test-case #;(make-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 "../lang.ss" '(module m06 "../lang.ss"
(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 'foo))]
[second-key (table-01-eval `(dispatch '(,first-key 1)))] [second-key (table-01-eval `(dispatch '(,first-key 1)))]
[third-key (table-01-eval `(dispatch '(,first-key -7)))]) [third-key (table-01-eval `(dispatch '(,first-key -7)))])
(assert = 3 (table-01-eval `(dispatch '(,second-key 2)))) (assert = 3 (table-01-eval `(dispatch '(,second-key 2))))
(assert = 4 (table-01-eval `(dispatch '(,second-key 3)))) (assert = 4 (table-01-eval `(dispatch '(,second-key 3))))
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1))))) (assert-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
(assert = -7 (table-01-eval `(dispatch '(,third-key 0)))) (assert = -7 (table-01-eval `(dispatch '(,third-key 0))))
(assert-true (zero? (table-01-eval `(dispatch '(,third-key 7)))))))) (assert-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
(make-test-case (make-test-case
"curried with send/suspend and serializaztion" "curried with send/suspend and serializaztion"
(let-values ([(go test-m06.1) (let-values ([(go 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)
(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)])
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)))))])
(go) (go)
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))] (let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))] [second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
@ -310,17 +268,17 @@
(make-test-case (make-test-case
"mutually recursive even? and odd?" "mutually recursive even? and odd?"
(let-values ([(go test-m07) (let-values ([(go test-m07)
(make-module-eval (make-module-eval
(module m07 "../lang.ss" (module m07 "../lang.ss"
(provide start) (provide start)
(define (start initial) (define (start initial)
(letrec ([even? (lambda (n) (letrec ([even? (lambda (n)
(or (zero? n) (or (zero? n)
(odd? (sub1 n))))] (odd? (sub1 n))))]
[odd? (lambda (n) [odd? (lambda (n)
(and (not (zero? n)) (and (not (zero? n))
(even? (sub1 n))))]) (even? (sub1 n))))])
(even? initial)))))]) (even? initial)))))])
(go) (go)
(assert-true (test-m07 '(dispatch-start 0))) (assert-true (test-m07 '(dispatch-start 0)))
(assert-true (test-m07 '(dispatch-start 16))) (assert-true (test-m07 '(dispatch-start 16)))
@ -330,24 +288,24 @@
(make-test-case (make-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 ([(go test-m08)
(make-module-eval (make-module-eval
(module m08 "../lang.ss" (module m08 "../lang.ss"
(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)])
k))))) k)))))
(define (start ignore) (define (start ignore)
(letrec ([f (let ([n (gn "first")]) (letrec ([f (let ([n (gn "first")])
(lambda (m) (+ n m)))] (lambda (m) (+ n m)))]
[g (let ([n (gn "second")]) [g (let ([n (gn "second")])
(lambda (m) (+ n (f m))))]) (lambda (m) (+ n (f m))))])
(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) (go)
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))] (let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))] [k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
@ -367,41 +325,41 @@
; XXX Bizarre ; XXX Bizarre
#;(make-test-case #;(make-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 ([(go 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 "../lang.ss" (nta-eval '(module m09 "../lang.ss"
(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))
(assert-true (catch-unsafe-context-exn (assert-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start 'foo))))))) (lambda () (nta-eval '(dispatch-start 'foo)))))))
(make-test-case (make-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 ([(go m10-eval)
(make-module-eval (make-module-eval
(module m10 "../lang.ss" (module m10 "../lang.ss"
(provide start) (provide start)
(define (nta f arg) (define (nta f arg)
(let ([result (f arg)]) (let ([result (f arg)])
(printf "result = ~s~n" result) (printf "result = ~s~n" result)
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) (go)
(assert = 7 (m10-eval '(dispatch-start 'foo))))) (assert = 7 (m10-eval '(dispatch-start 'foo)))))
@ -409,13 +367,13 @@
"attempt continuation capture from standard call to map" "attempt continuation capture from standard call to map"
(let-values ([(go m11-eval) (let-values ([(go m11-eval)
(make-module-eval (make-module-eval
(module m11 "../lang.ss" (module m11 "../lang.ss"
(provide start) (provide start)
(define (start ignore) (define (start ignore)
(map (map
(lambda (x) (let/cc k k)) (lambda (x) (let/cc k k))
(list 1 2 3)))))]) (list 1 2 3)))))])
(go) (go)
(assert-true (catch-unsafe-context-exn (assert-true (catch-unsafe-context-exn
(lambda () (m11-eval '(dispatch-start 'foo))))))) (lambda () (m11-eval '(dispatch-start 'foo)))))))
@ -424,70 +382,70 @@
;; should be just fine. ;; should be just fine.
; XXX Weird ; XXX Weird
#;(make-test-case #;(make-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 "../lang.ss" (ta-eval '(module m12 "../lang.ss"
(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))
(assert = 2 (ta-eval '(dispatch-start 1))))) (assert = 2 (ta-eval '(dispatch-start 1)))))
(make-test-case (make-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 ([(go m13-eval)
(make-module-eval (make-module-eval
(module m11 "../lang.ss" (module m11 "../lang.ss"
(provide start) (provide start)
(define (start initial) (define (start initial)
(map (map
(lambda (n) (send/suspend (lambda (n) (send/suspend
(lambda (k) (lambda (k)
(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) (go)
(assert-true (catch-unsafe-context-exn (assert-true (catch-unsafe-context-exn
(lambda () (m13-eval '(dispatch-start 'foo))))))) (lambda () (m13-eval '(dispatch-start 'foo)))))))
; XXX Weird ; XXX Weird
#;(make-test-case #;(make-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 ([(go 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 "../lang.ss" (ta-eval '(module m14 "../lang.ss"
(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 'foo))])
(assert = 3 (ta-eval `(dispatch (list ,k0 2)))) (assert = 3 (ta-eval `(dispatch (list ,k0 2))))
(assert = 0 (ta-eval `(dispatch (list ,k0 -1))))))))))) (assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))

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

@ -2,27 +2,30 @@
(provide make-module-eval (provide make-module-eval
make-eval/mod-path) make-eval/mod-path)
(define (go ns)
(lambda ()
(parameterize ([current-namespace ns])
(eval '(abort/cc
(with-continuation-mark safe-call? '(#t start)
(start
(with-continuation-mark the-cont-key start
(start-interaction
(lambda (k*v)
(lambda (k*v)
((car k*v) k*v))))))))))))
(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))
#'(let ([ns (make-namespace)]) #'(let ([ns (make-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(eval '(require "../abort-resume.ss" (eval '(require (lib "abort-resume.ss" "web-server" "prototype-web-server")
(lib "serialize.ss"))) (lib "serialize.ss")))
(eval '(module m-id . rest)) (eval '(module m-id . rest))
(eval '(require m-id))) (eval '(require m-id)))
(values (values
(lambda () (go ns)
(parameterize ([current-namespace ns])
(eval '(abort/cc
(with-continuation-mark safe-call? '(#t start)
(start
(with-continuation-mark the-cont-key start
(start-interaction
(lambda (k*v)
(lambda (k*v)
((car k*v) k*v)))))))))))
(lambda (s-expr) (lambda (s-expr)
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(eval s-expr)))))] (eval s-expr)))))]
@ -32,9 +35,10 @@
(define (make-eval/mod-path pth) (define (make-eval/mod-path pth)
(let ([ns (make-namespace)]) (let ([ns (make-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(eval `(require (lib "client.ss" "web-server" "prototype-web-server") (eval `(require (lib "abort-resume.ss" "web-server" "prototype-web-server")
(lib "serialize.ss") (lib "serialize.ss")
(file ,pth)))) (file ,pth))))
(lambda (expr) (values (go ns)
(parameterize ([current-namespace ns]) (lambda (expr)
(eval expr)))))) (parameterize ([current-namespace ns])
(eval expr)))))))

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

@ -48,29 +48,32 @@
(make-test-case (make-test-case
"compose url-parts and recover-serial (1)" "compose url-parts and recover-serial (1)"
(let* ([ev (make-eval/mod-path "modules/mm00.ss")] (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) (go)
`(file "modules/mm00.ss"))] (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
[k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) `(file "modules/mm00.ss"))]
`(file "modules/mm00.ss"))] [k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) `(file "modules/mm00.ss"))]
`(file "modules/mm00.ss"))]) [k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))) `(file "modules/mm00.ss"))])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))
(make-test-case (make-test-case
"compose url-parts and recover-serial (2)" "compose url-parts and recover-serial (2)"
(let* ([ev (make-eval/mod-path "modules/mm01.ss")] (let-values ([(go ev) (make-eval/mod-path "modules/mm01.ss")])
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) (go)
`(file "modules/mm01.ss"))]) (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7))))))) `(file "modules/mm01.ss"))])
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7))))))))
(make-test-case (make-test-case
"compose stuff-url and unstuff-url and recover the serial" "compose stuff-url and unstuff-url and recover the serial"
(let* ([ev (make-eval/mod-path "modules/mm00.ss")] (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
[k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo))) (go)
uri0 `(file "modules/mm00.ss"))] (let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo)))
[k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) uri0 `(file "modules/mm00.ss"))]
uri0 `(file "modules/mm00.ss"))] [k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) uri0 `(file "modules/mm00.ss"))]
uri0 `(file "modules/mm00.ss"))]) [k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))))) uri0 `(file "modules/mm00.ss"))])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))))))

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

@ -1,11 +1,13 @@
(module suite mzscheme (module suite mzscheme
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1)) (require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1))
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"persistent-close-tests.ss" "persistent-close-tests.ss"
"test-normalizer.ss" "test-normalizer.ss"
"closure-tests.ss" "closure-tests.ss"
"labels-tests.ss" "labels-tests.ss"
"lang-tests.ss" "lang-tests.ss"
"certify-tests.ss"
"stuff-url-tests.ss") "stuff-url-tests.ss")
(test/graphical-ui (test/graphical-ui
@ -17,4 +19,5 @@
closure-tests-suite closure-tests-suite
labels-tests-suite labels-tests-suite
lang-suite lang-suite
certify-suite
))) )))