From ec228f909236990149de79b11cfe9b5e994dc799 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 May 2007 15:36:49 +0000 Subject: [PATCH] Fixing certification tests svn: r6294 --- .../web-server/prototype-web-server/lang.ss | 1 + .../prototype-web-server/lang/anormal.ss | 256 ++++----- .../prototype-web-server/lang/defun.ss | 233 ++++---- .../prototype-web-server/lang/elim-callcc.ss | 308 ++++++----- .../prototype-web-server/lang/elim-letrec.ss | 244 ++++---- .../prototype-web-server/lang/util.ss | 309 ++++++----- .../tests/certify-tests.ss | 58 ++ .../prototype-web-server/tests/lang-tests.ss | 520 ++++++++---------- .../tests/language-tester.ss | 34 +- .../tests/stuff-url-tests.ss | 43 +- .../prototype-web-server/tests/suite.ss | 3 + 11 files changed, 1036 insertions(+), 973 deletions(-) create mode 100644 collects/web-server/prototype-web-server/tests/certify-tests.ss diff --git a/collects/web-server/prototype-web-server/lang.ss b/collects/web-server/prototype-web-server/lang.ss index 381534512f..4e4c0458fb 100644 --- a/collects/web-server/prototype-web-server/lang.ss +++ b/collects/web-server/prototype-web-server/lang.ss @@ -1,5 +1,6 @@ (module lang mzscheme (require-for-syntax (lib "etc.ss") + (lib "list.ss") "labels.ss" "lang/util.ss" "lang/elim-letrec.ss" diff --git a/collects/web-server/prototype-web-server/lang/anormal.ss b/collects/web-server/prototype-web-server/lang/anormal.ss index 8e72e81e31..da41cc01b8 100644 --- a/collects/web-server/prototype-web-server/lang/anormal.ss +++ b/collects/web-server/prototype-web-server/lang/anormal.ss @@ -34,133 +34,135 @@ (anormal id stx)) (define (anormal ctxt stx) - (kernel-syntax-case - stx #f - [(begin) - (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] - [(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 ...))))] - [(begin0) - (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] - [(begin0 lbe) - (anormal ctxt (syntax/loc stx lbe))] - [(begin0 fbe be ...) - (anormal ctxt - (syntax/loc stx - (let-values ([(save) fbe]) - (begin be ... save))))] - [(define-values (v ...) ve) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-values-for-syntax (v ...) ve) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve)))] - [(set! v ve) - (anormal - (compose ctxt - (lambda (val) - (quasisyntax/loc stx (set! v #,val)))) - #'ve)] - [(let-values () be) - (anormal ctxt (syntax/loc stx be))] - [(let-values ([(v) ve]) be) - (anormal ctxt - (syntax/loc stx - (#%app (lambda (v) be) - ve)))] - [(let-values ([(v ...) ve]) be) - (anormal ctxt - (syntax/loc stx - (#%app call-with-values - (lambda () ve) - (lambda (v ...) be))))] - [(let-values ([(fv ...) fve] [(v ...) ve] ...) be) - (anormal ctxt - (syntax/loc stx - (let-values ([(fv ...) fve]) - (let-values ([(v ...) ve] ...) - be))))] - [(let-values ([(v ...) ve] ...) be ...) - (anormal ctxt - (syntax/loc stx - (let-values ([(v ...) ve] ...) - (begin be ...))))] - [(letrec-values ([(v ...) ve] ...) be ...) - (anormal ctxt - (elim-letrec-term stx))] - [(lambda formals be ...) - (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) - (ctxt (syntax/loc stx (lambda formals nbe))))] - [(case-lambda [formals be] ...) - (with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))]) - (ctxt (syntax/loc stx (case-lambda [formals be] ...))))] - [(case-lambda [formals be ...] ...) - (anormal ctxt - (syntax/loc stx (case-lambda [formals (begin be ...)] ...)))] - [(if te ce ae) - (anormal - (compose ctxt - (lambda (val) - (quasisyntax/loc stx - (if #,val - #,(anormal-term #'ce) - #,(anormal-term #'ae))))) - #'te)] - [(if te ce) - (anormal ctxt (syntax/loc stx (if te ce (#%app void))))] - [(quote datum) - (ctxt stx)] - [(quote-syntax datum) - (ctxt stx)] - [(letrec-syntaxes+values ([(sv ...) se] ...) - ([(vv ...) ve] ...) - be ...) - (raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)] - [(with-continuation-mark ke me be) - (anormal - (compose ctxt - (lambda (kev) - (anormal - (lambda (mev) - (quasisyntax/loc stx - (with-continuation-mark #,kev #,mev - #,(anormal-term #'be)))) - #'me))) - #'ke)] - [(#%expression . d) - (ctxt stx)] - [(#%app fe e ...) - (anormal - (lambda (val0) - (anormal* - (compose ctxt - (lambda (rest-vals) - (quasisyntax/loc stx - (#%app #,val0 #,@rest-vals)))) - (syntax->list #'(e ...)))) - #'fe)] - [(#%top . v) - (ctxt stx)] - [(#%datum . d) - (ctxt stx)] - [(#%variable-reference . v) - (ctxt stx)] - [id (identifier? #'id) - (ctxt #'id)] - [_ - (raise-syntax-error 'anormal "Dropped through:" stx)])) + (recertify + stx + (kernel-syntax-case + stx #f + [(begin) + (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] + [(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 ...))))] + [(begin0) + (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] + [(begin0 lbe) + (anormal ctxt (syntax/loc stx lbe))] + [(begin0 fbe be ...) + (anormal ctxt + (syntax/loc stx + (let-values ([(save) fbe]) + (begin be ... save))))] + [(define-values (v ...) ve) + (with-syntax ([ve (anormal-term #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (with-syntax ([ve (anormal-term #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-values-for-syntax (v ...) ve) + (with-syntax ([ve (anormal-term #'ve)]) + (syntax/loc stx + (define-values-for-syntax (v ...) ve)))] + [(set! v ve) + (anormal + (compose ctxt + (lambda (val) + (quasisyntax/loc stx (set! v #,val)))) + #'ve)] + [(let-values () be) + (anormal ctxt (syntax/loc stx be))] + [(let-values ([(v) ve]) be) + (anormal ctxt + (syntax/loc stx + (#%app (lambda (v) be) + ve)))] + [(let-values ([(v ...) ve]) be) + (anormal ctxt + (syntax/loc stx + (#%app call-with-values + (lambda () ve) + (lambda (v ...) be))))] + [(let-values ([(fv ...) fve] [(v ...) ve] ...) be) + (anormal ctxt + (syntax/loc stx + (let-values ([(fv ...) fve]) + (let-values ([(v ...) ve] ...) + be))))] + [(let-values ([(v ...) ve] ...) be ...) + (anormal ctxt + (syntax/loc stx + (let-values ([(v ...) ve] ...) + (begin be ...))))] + [(letrec-values ([(v ...) ve] ...) be ...) + (anormal ctxt + (elim-letrec-term stx))] + [(lambda formals be ...) + (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) + (ctxt (syntax/loc stx (lambda formals nbe))))] + [(case-lambda [formals be] ...) + (with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))]) + (ctxt (syntax/loc stx (case-lambda [formals be] ...))))] + [(case-lambda [formals be ...] ...) + (anormal ctxt + (syntax/loc stx (case-lambda [formals (begin be ...)] ...)))] + [(if te ce ae) + (anormal + (compose ctxt + (lambda (val) + (quasisyntax/loc stx + (if #,val + #,(anormal-term #'ce) + #,(anormal-term #'ae))))) + #'te)] + [(if te ce) + (anormal ctxt (syntax/loc stx (if te ce (#%app void))))] + [(quote datum) + (ctxt stx)] + [(quote-syntax datum) + (ctxt stx)] + [(letrec-syntaxes+values ([(sv ...) se] ...) + ([(vv ...) ve] ...) + be ...) + (raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)] + [(with-continuation-mark ke me be) + (anormal + (compose ctxt + (lambda (kev) + (anormal + (lambda (mev) + (quasisyntax/loc stx + (with-continuation-mark #,kev #,mev + #,(anormal-term #'be)))) + #'me))) + #'ke)] + [(#%expression . d) + (ctxt stx)] + [(#%app fe e ...) + (anormal + (lambda (val0) + (anormal* + (compose ctxt + (lambda (rest-vals) + (quasisyntax/loc stx + (#%app #,val0 #,@rest-vals)))) + (syntax->list #'(e ...)))) + #'fe)] + [(#%top . v) + (ctxt stx)] + [(#%datum . d) + (ctxt stx)] + [(#%variable-reference . v) + (ctxt stx)] + [id (identifier? #'id) + (ctxt #'id)] + [_ + (raise-syntax-error 'anormal "Dropped through:" stx)]))) ;; anormal*: ((listof w) -> target-expr) (listof source-expr) -> target-expr ;; normalize an expression given as a context and list of sub-expressions diff --git a/collects/web-server/prototype-web-server/lang/defun.ss b/collects/web-server/prototype-web-server/lang/defun.ss index 2e3d4682c3..760ae84bf3 100644 --- a/collects/web-server/prototype-web-server/lang/defun.ss +++ b/collects/web-server/prototype-web-server/lang/defun.ss @@ -15,123 +15,126 @@ ; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3]) ; defunctionalizes the first syntax, returning the second and the lifted lambdas [3] (define (defun stx) - (kernel-syntax-case - stx #f - [(begin be ...) - (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) - (values (quasisyntax/loc stx (begin #,@nbes)) - defs))] - [(begin0 be ...) - (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) - (values (quasisyntax/loc stx (begin0 #,@nbes)) - defs))] - [(define-values (v ...) ve) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (define-values (v ...) #,nve)) - defs))] - [(define-syntaxes (v ...) ve) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve)) - defs))] - [(define-values-for-syntax (v ...) ve) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve)) - defs))] - [(set! v ve) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (set! v #,nve)) - defs))] - [(let-values ([(v ...) ve] ...) be ...) - (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] - [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nve ...) nves] - [(nbe ...) nbes]) - (values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...)) - (append ve-defs be-defs))))] - [(letrec-values ([(v ...) ve] ...) be ...) - (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] - [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nve ...) nves] - [(nbe ...) nbes]) - (values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...)) - (append ve-defs be-defs))))] - [(lambda formals be ...) - (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nbe ...) nbes]) - (let ([fvars (free-vars stx)]) - (let-values ([(make-CLOSURE new-defs) - (make-closure-definition-syntax - (make-new-closure-label (current-code-labeling) stx) - fvars - (syntax/loc stx (lambda formals nbe ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) - (append be-defs new-defs))))))] - [(case-lambda [formals be ...] ...) - (let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))]) - (with-syntax ([((nbe ...) ...) nbes]) - (let ([fvars (free-vars stx)]) - (let-values ([(make-CLOSURE new-defs) - (make-closure-definition-syntax - (make-new-closure-label (current-code-labeling) stx) - fvars - (syntax/loc stx (case-lambda [formals nbe ...] ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) - (append be-defs new-defs))))))] - [(if te ce ae) - (let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))]) - (values (quasisyntax/loc stx (if #,@es)) - defs))] - [(if te ce) - (defun (quasisyntax/loc stx (if te ce (#%app void))))] - [(quote datum) - (values stx - empty)] - [(quote-syntax 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) + (recertify/new-defs + stx + (lambda () + (kernel-syntax-case + stx #f + [(begin be ...) + (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) + (values (quasisyntax/loc stx (begin #,@nbes)) + defs))] + [(begin0 be ...) + (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) + (values (quasisyntax/loc stx (begin0 #,@nbes)) + defs))] + [(define-values (v ...) ve) + (let-values ([(nve defs) (defun #'ve)]) + (values (quasisyntax/loc stx (define-values (v ...) #,nve)) + defs))] + [(define-syntaxes (v ...) ve) + (let-values ([(nve defs) (defun #'ve)]) + (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve)) + defs))] + [(define-values-for-syntax (v ...) ve) + (let-values ([(nve defs) (defun #'ve)]) + (values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve)) + defs))] + [(set! v ve) + (let-values ([(nve defs) (defun #'ve)]) + (values (quasisyntax/loc stx (set! v #,nve)) + defs))] + [(let-values ([(v ...) ve] ...) be ...) + (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] + [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nve ...) nves] + [(nbe ...) nbes]) + (values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...)) + (append ve-defs be-defs))))] + [(letrec-values ([(v ...) ve] ...) be ...) + (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] + [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nve ...) nves] + [(nbe ...) nbes]) + (values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...)) + (append ve-defs be-defs))))] + [(lambda formals be ...) + (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nbe ...) nbes]) + (let ([fvars (free-vars stx)]) + (let-values ([(make-CLOSURE new-defs) + (make-closure-definition-syntax + (make-new-closure-label (current-code-labeling) stx) + fvars + (syntax/loc stx (lambda formals nbe ...)))]) + (values (if (empty? fvars) + (quasisyntax/loc stx (#,make-CLOSURE)) + (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) + (append be-defs new-defs))))))] + [(case-lambda [formals be ...] ...) + (let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))]) + (with-syntax ([((nbe ...) ...) nbes]) + (let ([fvars (free-vars stx)]) + (let-values ([(make-CLOSURE new-defs) + (make-closure-definition-syntax + (make-new-closure-label (current-code-labeling) stx) + fvars + (syntax/loc stx (case-lambda [formals nbe ...] ...)))]) + (values (if (empty? fvars) + (quasisyntax/loc stx (#,make-CLOSURE)) + (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) + (append be-defs new-defs))))))] + [(if te ce ae) + (let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))]) + (values (quasisyntax/loc stx (if #,@es)) + defs))] + [(if te ce) + (defun (quasisyntax/loc stx (if te ce (#%app void))))] + [(quote datum) (values stx empty)] - [_ - (raise-syntax-error 'defun "Dropped through:" stx)])) + [(quote-syntax 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 + empty)] + [_ + (raise-syntax-error 'defun "Dropped through:" stx)])))) ; lift defun to list of syntaxes (define (lift-defun defun) diff --git a/collects/web-server/prototype-web-server/lang/elim-callcc.ss b/collects/web-server/prototype-web-server/lang/elim-callcc.ss index b43670ebaa..ac2f106af4 100644 --- a/collects/web-server/prototype-web-server/lang/elim-callcc.ss +++ b/collects/web-server/prototype-web-server/lang/elim-callcc.ss @@ -10,161 +10,165 @@ ;; mark-lambda-as-safe: w -> w ;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark (define (mark-lambda-as-safe w) - (syntax-case w (lambda case-lambda) - [(lambda formals be ...) - (syntax/loc w - (lambda formals - (with-continuation-mark safe-call? '(#t (lambda formals)) - be ...)))] - [(case-lambda [formals be ...] ...) - (syntax/loc w - (case-lambda [formals - (with-continuation-mark safe-call? '(#t (case-lambda formals ...)) - be ...)] ...))] - [_else w])) + (recertify + w + (syntax-case w (lambda case-lambda) + [(lambda formals be ...) + (syntax/loc w + (lambda formals + (with-continuation-mark safe-call? '(#t (lambda formals)) + be ...)))] + [(case-lambda [formals be ...] ...) + (syntax/loc w + (case-lambda [formals + (with-continuation-mark safe-call? '(#t (case-lambda formals ...)) + be ...)] ...))] + [_else w]))) (define (elim-callcc stx) (elim-callcc/mark id stx)) (define (elim-callcc/mark markit stx) - (kernel-syntax-case* - stx #f (call/cc call-with-values) - [(begin be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(begin0 be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(define-values (v ...) ve) - (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-values-for-syntax (v ...) ve) - (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve)))] - [(set! v ve) - (with-syntax ([ve (elim-callcc #'ve)]) - (syntax/loc stx (set! v ve)))] - [(let-values ([(v ...) ve] ...) be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(letrec-values ([(v ...) ve] ...) be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(lambda formals be) - (with-syntax ([be (elim-callcc #'be)]) - (syntax/loc stx - (lambda formals be)))] - [(case-lambda [formals be] ...) - (with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))]) - (syntax/loc stx - (case-lambda [formals be] ...)))] - [(if te ce ae) - (with-syntax ([te (elim-callcc #'te)] - [ce (elim-callcc #'ce)] - [ae (elim-callcc #'ae)]) - (markit (syntax/loc stx (if te ce ae))))] - [(if te ce) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(quote datum) - stx] - [(quote-syntax datum) - stx] - [(letrec-syntaxes+values ([(sv ...) se] ...) - ([(vv ...) ve] ...) - be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] - [(with-continuation-mark ke me be) - (let* ([ke-prime (elim-callcc #'ke)] - [me-prime (elim-callcc #'me)] - [be-prime (elim-callcc #'be)]) - (markit - (quasisyntax/loc stx - (with-continuation-mark #,ke-prime #,me-prime - (with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime) - #,be-prime)))))] - [(#%expression . d) - stx] - [(#%app call/cc w) - (let-values ([(cm ref-to-cm) (generate-formal 'current-marks)] - [(x ref-to-x) (generate-formal 'x)]) - (markit - (quasisyntax/loc stx - (#%app #,(elim-callcc #'w) - (#%app (lambda (#,cm) - (lambda #,x - (#%app abort - (lambda () (#%app resume #,ref-to-cm #,ref-to-x))))) - (#%app activation-record-list))))))] - [(#%app call-with-values (lambda () prod) cons) - (let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))]) - (markit - (quasisyntax/loc stx - (#%app call-with-values - #,(mark-lambda-as-safe - (quasisyntax/loc stx - (lambda () - #,(elim-callcc/mark - (lambda (x) - (quasisyntax/loc stx - (with-continuation-mark the-cont-key #,cons-prime #,x))) - #'prod)))) - #,cons-prime))))] - [(#%app w (#%app . stuff)) - (with-syntax ([e #'(#%app . stuff)]) - (syntax-case #'w (lambda case-lambda) - [(lambda formals body) - (let ([w-prime (datum->syntax-object #f (gensym 'l))]) - (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)))))))] - [(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 + (recertify + stx + (kernel-syntax-case* + stx #f (call/cc call-with-values) + [(begin be ...) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(begin0 be ...) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(define-values (v ...) ve) + (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-values-for-syntax (v ...) ve) + (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) + (syntax/loc stx + (define-values-for-syntax (v ...) ve)))] + [(set! v ve) + (with-syntax ([ve (elim-callcc #'ve)]) + (syntax/loc stx (set! v ve)))] + [(let-values ([(v ...) ve] ...) be ...) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(letrec-values ([(v ...) ve] ...) be ...) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(lambda formals be) + (with-syntax ([be (elim-callcc #'be)]) + (syntax/loc stx + (lambda formals be)))] + [(case-lambda [formals be] ...) + (with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))]) + (syntax/loc stx + (case-lambda [formals be] ...)))] + [(if te ce ae) + (with-syntax ([te (elim-callcc #'te)] + [ce (elim-callcc #'ce)] + [ae (elim-callcc #'ae)]) + (markit (syntax/loc stx (if te ce ae))))] + [(if te ce) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(quote datum) + stx] + [(quote-syntax datum) + stx] + [(letrec-syntaxes+values ([(sv ...) se] ...) + ([(vv ...) ve] ...) + be ...) + (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + [(with-continuation-mark ke me be) + (let* ([ke-prime (elim-callcc #'ke)] + [me-prime (elim-callcc #'me)] + [be-prime (elim-callcc #'be)]) + (markit + (quasisyntax/loc stx + (with-continuation-mark #,ke-prime #,me-prime + (with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime) + #,be-prime)))))] + [(#%expression . d) + stx] + [(#%app call/cc w) + (let-values ([(cm ref-to-cm) (generate-formal 'current-marks)] + [(x ref-to-x) (generate-formal 'x)]) + (markit + (quasisyntax/loc stx + (#%app #,(elim-callcc #'w) + (#%app (lambda (#,cm) + (lambda #,x + (#%app abort + (lambda () (#%app resume #,ref-to-cm #,ref-to-x))))) + (#%app activation-record-list))))))] + [(#%app call-with-values (lambda () prod) cons) + (let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))]) + (markit + (quasisyntax/loc stx + (#%app call-with-values + #,(mark-lambda-as-safe + (quasisyntax/loc stx + (lambda () + #,(elim-callcc/mark + (lambda (x) + (quasisyntax/loc stx + (with-continuation-mark the-cont-key #,cons-prime #,x))) + #'prod)))) + #,cons-prime))))] + [(#%app w (#%app . stuff)) + (with-syntax ([e #'(#%app . stuff)]) + (syntax-case #'w (lambda case-lambda) + [(lambda formals body) + (let ([w-prime (datum->syntax-object #f (gensym 'l))]) (quasisyntax/loc 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)]))) \ No newline at end of file + (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)))))))] + [(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 + (#%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)])))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/lang/elim-letrec.ss b/collects/web-server/prototype-web-server/lang/elim-letrec.ss index 031d0d2c0b..a97f9d5d46 100644 --- a/collects/web-server/prototype-web-server/lang/elim-letrec.ss +++ b/collects/web-server/prototype-web-server/lang/elim-letrec.ss @@ -11,127 +11,129 @@ ; Eliminates letrec-values from syntax[2] and correctly handles references to ; letrec-bound variables [3] therein. (define ((elim-letrec ids) stx) - (kernel-syntax-case - stx #f - [(begin be ...) - (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) - (syntax/loc stx - (begin be ...)))] - [(begin0 be ...) - (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) - (syntax/loc stx - (begin0 be ...)))] - [(define-values (v ...) ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve)))] - [(define-values-for-syntax (v ...) ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve)))] - [(set! v ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (if (bound-identifier-member? #'id ids) - (syntax/loc stx (#%app set-box! id 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) + (recertify + stx + (kernel-syntax-case + stx #f + [(begin be ...) + (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin be ...)))] + [(begin0 be ...) + (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin0 be ...)))] + [(define-values (v ...) ve) + (with-syntax ([ve ((elim-letrec ids) #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (with-syntax ([ve ((elim-letrec ids) #'ve)]) + (syntax/loc stx + (define-syntaxes (v ...) ve)))] + [(define-values-for-syntax (v ...) ve) + (with-syntax ([ve ((elim-letrec ids) #'ve)]) + (syntax/loc stx + (define-values-for-syntax (v ...) ve)))] + [(set! v ve) + (with-syntax ([ve ((elim-letrec ids) #'ve)]) (if (bound-identifier-member? #'id ids) - (syntax/loc stx (#%app unbox id)) - #'id)] - [_ - (raise-syntax-error 'elim-letrec "Dropped through:" stx)])) + (syntax/loc stx (#%app set-box! id 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) + (syntax/loc stx (#%app unbox id)) + #'id)] + [_ + (raise-syntax-error 'elim-letrec "Dropped through:" stx)]))) (define elim-letrec-term (elim-letrec empty))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/lang/util.ss b/collects/web-server/prototype-web-server/lang/util.ss index b7b5a80542..61255c8455 100644 --- a/collects/web-server/prototype-web-server/lang/util.ss +++ b/collects/web-server/prototype-web-server/lang/util.ss @@ -4,6 +4,21 @@ (lib "list.ss")) (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 (make-parameter (lambda (stx) @@ -27,70 +42,78 @@ (list* #'rv (syntax->list #'(v ...)))])) (define ((make-define-case inner) stx) - (syntax-case stx (define-values define-syntaxes define-values-for-syntax) - [(define-values (v ...) ve) - (with-syntax ([ve (inner #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (with-syntax ([ve (inner #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve)))] - [(define-values-for-syntax (v ...) ve) - (with-syntax ([ve (inner #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve)))] - [_ - (raise-syntax-error 'define-case "Dropped through:" stx)])) + (recertify + stx + (syntax-case stx (define-values define-syntaxes define-values-for-syntax) + [(define-values (v ...) ve) + (with-syntax ([ve (inner #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (with-syntax ([ve (inner #'ve)]) + (syntax/loc stx + (define-syntaxes (v ...) ve)))] + [(define-values-for-syntax (v ...) ve) + (with-syntax ([ve (inner #'ve)]) + (syntax/loc stx + (define-values-for-syntax (v ...) ve)))] + [_ + (raise-syntax-error 'define-case "Dropped through:" stx)]))) (define ((make-define-case/new-defs inner) stx) (let-values ([(nstx defs) (inner stx)]) (append defs (list nstx)))) (define ((make-module-case/new-defs inner) stx) - (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? - [(require spec ...) - (list stx)] - [(provide spec ...) - (list stx)] - [(require-for-syntax spec ...) - (list stx)] - [(require-for-template spec ...) - (list stx)] - [_ - (inner stx)])) + (recertify* + stx + (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? + [(require spec ...) + (list stx)] + [(provide spec ...) + (list stx)] + [(require-for-syntax spec ...) + (list stx)] + [(require-for-template spec ...) + (list stx)] + [_ + (inner stx)]))) (define ((make-module-case inner) stx) - (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? - [(require spec ...) - stx] - [(provide spec ...) - stx] - [(require-for-syntax spec ...) - stx] - [(require-for-template spec ...) - stx] - [_ - (inner stx)])) + (recertify + stx + (syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=? + [(require spec ...) + stx] + [(provide spec ...) + stx] + [(require-for-syntax spec ...) + stx] + [(require-for-template spec ...) + stx] + [_ + (inner stx)]))) (define ((make-lang-module-begin make-labeling transform) stx) - (syntax-case stx () - ((mb forms ...) - (with-syntax ([(pmb rfs body ...) - (local-expand (quasisyntax/loc stx - (#%plain-module-begin - #,(syntax-local-introduce #'(require-for-syntax mzscheme)) - forms ...)) - 'module-begin - empty)]) - (let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))]) - (parameterize ([current-code-labeling - (lambda (stx) - (datum->syntax-object stx (base-labeling)))]) - (let ([new-defs (apply append (map transform (syntax->list #'(body ...))))]) - (quasisyntax/loc stx - (pmb rfs - #,@new-defs))))))))) + (recertify + stx + (syntax-case stx () + ((mb forms ...) + (with-syntax ([(pmb rfs body ...) + (local-expand (quasisyntax/loc stx + (#%plain-module-begin + #,(syntax-local-introduce #'(require-for-syntax mzscheme)) + forms ...)) + 'module-begin + empty)]) + (let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))]) + (parameterize ([current-code-labeling + (lambda (stx) + (datum->syntax-object stx (base-labeling)))]) + (let ([new-defs (apply append (map transform (syntax->list #'(body ...))))]) + (quasisyntax/loc stx + (pmb rfs + #,@new-defs)))))))))) (define (bound-identifier-member? id ids) (ormap @@ -100,91 +123,93 @@ ;; Kernel Case Template (define (template stx) - (kernel-syntax-case - stx #f - [(begin be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (begin be ...)))] - [(begin0 be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (begin0 be ...)))] - [(define-values (v ...) ve) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-values-for-syntax (v ...) ve) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve)))] - [(set! v ve) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (set! v ve)))] - [(let-values ([(v ...) ve] ...) be ...) - (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] - [(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (let-values ([(v ...) ve] ...) be ...)))] - [(letrec-values ([(v ...) ve] ...) be ...) - (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] - [(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (letrec-values ([(v ...) ve] ...) be ...)))] - [(lambda formals be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (lambda formals be ...)))] - [(case-lambda [formals be ...] ...) - (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))]) - (syntax/loc stx - (case-lambda [formals be ...] ...)))] - [(if te ce ae) - (with-syntax ([te (template #'te)] - [ce (template #'ce)] - [ae (template #'ae)]) - (syntax/loc stx - (if te ce ae)))] - [(if te ce) - (template (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 template (syntax->list #'(se ...)))] - [(ve ...) (map template (syntax->list #'(ve ...)))] - [(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (letrec-syntaxes+values ([(sv ...) se] ...) - ([(vv ...) ve] ...) - be ...)))] - [(with-continuation-mark ke me be) - (with-syntax ([ke (template #'ke)] - [me (template #'me)] - [be (template #'be)]) - (syntax/loc stx - (with-continuation-mark ke me be)))] - [(#%expression . d) - stx] - [(#%app e ...) - (with-syntax ([(e ...) (map template (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)]))) \ No newline at end of file + (recertify + stx + (kernel-syntax-case + stx #f + [(begin be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin be ...)))] + [(begin0 be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin0 be ...)))] + [(define-values (v ...) ve) + (with-syntax ([ve (template #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (with-syntax ([ve (template #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-values-for-syntax (v ...) ve) + (with-syntax ([ve (template #'ve)]) + (syntax/loc stx + (define-values-for-syntax (v ...) ve)))] + [(set! v ve) + (with-syntax ([ve (template #'ve)]) + (syntax/loc stx + (set! v ve)))] + [(let-values ([(v ...) ve] ...) be ...) + (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] + [(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (let-values ([(v ...) ve] ...) be ...)))] + [(letrec-values ([(v ...) ve] ...) be ...) + (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] + [(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (letrec-values ([(v ...) ve] ...) be ...)))] + [(lambda formals be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (lambda formals be ...)))] + [(case-lambda [formals be ...] ...) + (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))]) + (syntax/loc stx + (case-lambda [formals be ...] ...)))] + [(if te ce ae) + (with-syntax ([te (template #'te)] + [ce (template #'ce)] + [ae (template #'ae)]) + (syntax/loc stx + (if te ce ae)))] + [(if te ce) + (template (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 template (syntax->list #'(se ...)))] + [(ve ...) (map template (syntax->list #'(ve ...)))] + [(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (letrec-syntaxes+values ([(sv ...) se] ...) + ([(vv ...) ve] ...) + be ...)))] + [(with-continuation-mark ke me be) + (with-syntax ([ke (template #'ke)] + [me (template #'me)] + [be (template #'be)]) + (syntax/loc stx + (with-continuation-mark ke me be)))] + [(#%expression . d) + stx] + [(#%app e ...) + (with-syntax ([(e ...) (map template (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)])))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/certify-tests.ss b/collects/web-server/prototype-web-server/tests/certify-tests.ss new file mode 100644 index 0000000000..7f751bacf2 --- /dev/null +++ b/collects/web-server/prototype-web-server/tests/certify-tests.ss @@ -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))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/lang-tests.ss b/collects/web-server/prototype-web-server/tests/lang-tests.ss index 3a38bde616..37744bb821 100644 --- a/collects/web-server/prototype-web-server/tests/lang-tests.ss +++ b/collects/web-server/prototype-web-server/tests/lang-tests.ss @@ -27,36 +27,36 @@ (make-test-case "Function application with single argument in tail position" (let-values ([(go test-m00.4) - (make-module-eval - (module m00.4 "../lang.ss" - (provide start) - (define (start initial) - (let ([f (let ([m 7]) m)]) - (+ f initial)))))]) + (make-module-eval + (module m00.4 "../lang.ss" + (provide start) + (define (start initial) + (let ([f (let ([m 7]) m)]) + (+ f initial)))))]) (go) (assert = 8 (test-m00.4 '(dispatch-start 1))))) (make-test-case "start-interaction in argument position of a function call" (let-values ([(go test-m00.3) - (make-module-eval - (module m00.3 "../lang.ss" - (define (foo x) 'foo) - (provide start) - (define (start initial) - (foo initial))))]) + (make-module-eval + (module m00.3 "../lang.ss" + (define (foo x) 'foo) + (provide start) + (define (start initial) + (foo initial))))]) (go) (assert eqv? 'foo (test-m00.3 '(dispatch-start 7))))) (make-test-case "identity interaction, dispatch-start called multiple times" (let-values ([(go test-m00) - (make-module-eval - (module m00 "../lang.ss" - (define (id x) x) - (provide start) - (define (start initial) - (id initial))))]) + (make-module-eval + (module m00 "../lang.ss" + (define (id x) x) + (provide start) + (define (start initial) + (id initial))))]) (go) (assert = 7 (test-m00 '(dispatch-start 7))) (assert eqv? 'foo (test-m00 '(dispatch-start 'foo))))) @@ -64,22 +64,22 @@ (make-test-case "start-interaction in argument position of a primitive" (let-values ([(go test-m00.1) - (make-module-eval - (module m00.1 "../lang.ss" - (provide start) - (define (start initial) - (+ 1 initial))))]) + (make-module-eval + (module m00.1 "../lang.ss" + (provide start) + (define (start initial) + (+ 1 initial))))]) (go) (assert = 2 (test-m00.1 '(dispatch-start 1))))) (make-test-case "dispatch-start called multiple times for s-i in non-trivial context" (let-values ([(go test-m00.2) - (make-module-eval - (module m00.2 "../lang.ss" - (provide start) - (define (start initial) - (+ (+ 1 1) initial))))]) + (make-module-eval + (module m00.2 "../lang.ss" + (provide start) + (define (start initial) + (+ (+ 1 1) initial))))]) (go) (assert = 14 (test-m00.2 '(dispatch-start 12))) (assert = 20 (test-m00.2 '(dispatch-start 18))))) @@ -87,56 +87,14 @@ (make-test-case "start-interaction in third position" (let-values ([(go test-m01) - (make-module-eval - (module m01 "../lang.ss" - (provide start) - (define (start initial) - (+ (* 1 2) (* 3 4) initial))))]) + (make-module-eval + (module m01 "../lang.ss" + (provide start) + (define (start initial) + (+ (* 1 2) (* 3 4) initial))))]) (go) (assert = 14 (test-m01 '(dispatch-start 0))) - (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))) + (assert = 20 (test-m01 '(dispatch-start 6))))) ;; start-interaction may be called mutitple times ;; each call overwrites the previous interaction @@ -166,12 +124,12 @@ (make-test-case "continuation invoked in non-trivial context from within proc" (let-values ([(go test-m03) - (make-module-eval - (module m03 "../lang.ss" - (provide start) - (define (start x) - (let/cc k - (+ 2 4 (k 3) 6 8)))))]) + (make-module-eval + (module m03 "../lang.ss" + (provide start) + (define (start x) + (let/cc k + (+ 2 4 (k 3) 6 8)))))]) (go) (assert = 3 (test-m03 '(dispatch-start 'foo))) (assert = 3 (test-m03 '(dispatch-start 7))))) @@ -182,17 +140,17 @@ (make-test-case "non-tail-recursive 'escaping' continuation" (let-values ([(go test-m04) - (make-module-eval - (module m04 "../lang.ss" - (provide start) - (define (start ln) - (let/cc k - (cond - [(null? ln) 1] - [(zero? (car ln)) (k 0)] - [else - (* (car ln) - (start (cdr ln)))])))))]) + (make-module-eval + (module m04 "../lang.ss" + (provide start) + (define (start ln) + (let/cc k + (cond + [(null? ln) 1] + [(zero? (car ln)) (k 0)] + [else + (* (car ln) + (start (cdr ln)))])))))]) (go) (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)))))) @@ -204,21 +162,21 @@ (make-test-case "tail-recursive escaping continuation" (let-values ([(go test-m05) - (make-module-eval - (module m05 "../lang.ss" - (provide start) - - (define (start ln) - (let/cc escape - (mult/escape escape ln))) - - (define (mult/escape escape ln) - (cond - [(null? ln) 1] - [(zero? (car ln)) (escape 0)] - [else - (* (car ln) - (mult/escape escape (cdr ln)))]))))]) + (make-module-eval + (module m05 "../lang.ss" + (provide start) + + (define (start ln) + (let/cc escape + (mult/escape escape ln))) + + (define (mult/escape escape ln) + (cond + [(null? ln) 1] + [(zero? (car ln)) (escape 0)] + [else + (* (car ln) + (mult/escape escape (cdr ln)))]))))]) (go) (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))))))) @@ -231,65 +189,65 @@ ; XXX This doesn't work, because we don't allow a different dispatcher #;(make-test-case - "curried add with send/suspend" - (let ([table-01-eval - (make-module-eval - (module table01 mzscheme - (provide store-k - lookup-k) - - (define the-table (make-hash-table)) - - (define (store-k k) - (let ([key (string->symbol (symbol->string (gensym 'key)))]) - (hash-table-put! the-table key k) - key)) - (define (lookup-k key-pair) - (hash-table-get the-table (car key-pair) (lambda () #f)))))]) - (table-01-eval - '(module m06 "../lang.ss" - (require table01) - (provide start) - - (define (gn which) - (cadr - (send/suspend - (lambda (k) - (let ([ignore (printf "Please send the ~a number.~n" which)]) - (store-k k)))))) - - (define (start ignore) - (let ([result (+ (gn "first") (gn "second"))]) - (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)))]) - (assert = 3 (table-01-eval `(dispatch '(,second-key 2)))) - (assert = 4 (table-01-eval `(dispatch '(,second-key 3)))) - (assert-true (zero? (table-01-eval `(dispatch '(,second-key -1))))) - (assert = -7 (table-01-eval `(dispatch '(,third-key 0)))) - (assert-true (zero? (table-01-eval `(dispatch '(,third-key 7)))))))) + "curried add with send/suspend" + (let ([table-01-eval + (make-module-eval + (module table01 mzscheme + (provide store-k + lookup-k) + + (define the-table (make-hash-table)) + + (define (store-k k) + (let ([key (string->symbol (symbol->string (gensym 'key)))]) + (hash-table-put! the-table key k) + key)) + (define (lookup-k key-pair) + (hash-table-get the-table (car key-pair) (lambda () #f)))))]) + (table-01-eval + '(module m06 "../lang.ss" + (require table01) + (provide start) + + (define (gn which) + (cadr + (send/suspend + (lambda (k) + (let ([ignore (printf "Please send the ~a number.~n" which)]) + (store-k k)))))) + + (define (start ignore) + (let ([result (+ (gn "first") (gn "second"))]) + (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)))]) + (assert = 3 (table-01-eval `(dispatch '(,second-key 2)))) + (assert = 4 (table-01-eval `(dispatch '(,second-key 3)))) + (assert-true (zero? (table-01-eval `(dispatch '(,second-key -1))))) + (assert = -7 (table-01-eval `(dispatch '(,third-key 0)))) + (assert-true (zero? (table-01-eval `(dispatch '(,third-key 7)))))))) (make-test-case "curried with send/suspend and serializaztion" (let-values ([(go test-m06.1) - (make-module-eval - (module m06.1 (lib "lang.ss" "web-server" "prototype-web-server") - (provide start) - (define (gn which) - (cadr - (send/suspend - (lambda (k) - (let ([ignore (printf "Please send the ~a number.~n" which)]) - k))))) - - (define (start ignore) - (let ([result (+ (gn "first") (gn "second"))]) - (let ([ignore (printf "The answer is: ~s~n" result)]) - result)))))]) + (make-module-eval + (module m06.1 (lib "lang.ss" "web-server" "prototype-web-server") + (provide start) + (define (gn which) + (cadr + (send/suspend + (lambda (k) + (let ([ignore (printf "Please send the ~a number.~n" which)]) + k))))) + + (define (start ignore) + (let ([result (+ (gn "first") (gn "second"))]) + (let ([ignore (printf "The answer is: ~s~n" result)]) + result)))))]) (go) (let* ([first-key (test-m06.1 '(dispatch-start 'foo))] [second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))] @@ -310,17 +268,17 @@ (make-test-case "mutually recursive even? and odd?" (let-values ([(go test-m07) - (make-module-eval - (module m07 "../lang.ss" - (provide start) - (define (start initial) - (letrec ([even? (lambda (n) - (or (zero? n) - (odd? (sub1 n))))] - [odd? (lambda (n) - (and (not (zero? n)) - (even? (sub1 n))))]) - (even? initial)))))]) + (make-module-eval + (module m07 "../lang.ss" + (provide start) + (define (start initial) + (letrec ([even? (lambda (n) + (or (zero? n) + (odd? (sub1 n))))] + [odd? (lambda (n) + (and (not (zero? n)) + (even? (sub1 n))))]) + (even? initial)))))]) (go) (assert-true (test-m07 '(dispatch-start 0))) (assert-true (test-m07 '(dispatch-start 16))) @@ -330,24 +288,24 @@ (make-test-case "send/suspend on rhs of letrec binding forms" (let-values ([(go test-m08) - (make-module-eval - (module m08 "../lang.ss" - (provide start) - (define (gn which) - (cadr - (send/suspend - (lambda (k) - (let ([ignore (printf "Please send the ~a number.~n" which)]) - k))))) - - (define (start ignore) - (letrec ([f (let ([n (gn "first")]) - (lambda (m) (+ n m)))] - [g (let ([n (gn "second")]) - (lambda (m) (+ n (f m))))]) - (let ([result (g (gn "third"))]) - (let ([ignore (printf "The answer is: ~s~n" result)]) - result))))))]) + (make-module-eval + (module m08 "../lang.ss" + (provide start) + (define (gn which) + (cadr + (send/suspend + (lambda (k) + (let ([ignore (printf "Please send the ~a number.~n" which)]) + k))))) + + (define (start ignore) + (letrec ([f (let ([n (gn "first")]) + (lambda (m) (+ n m)))] + [g (let ([n (gn "second")]) + (lambda (m) (+ n (f m))))]) + (let ([result (g (gn "third"))]) + (let ([ignore (printf "The answer is: ~s~n" result)]) + result))))))]) (go) (let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))] [k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))] @@ -367,41 +325,41 @@ ; XXX Bizarre #;(make-test-case - "simple attempt to capture a continuation from an unsafe context" - - (let-values ([(go nta-eval) - (make-module-eval - (module nta mzscheme - (provide non-tail-apply) - - (define (non-tail-apply f . args) - (let ([result (apply f args)]) - (printf "result = ~s~n" result) - result))))]) - (nta-eval '(module m09 "../lang.ss" - (require nta) - (provide start) - (define (start ignore) - (non-tail-apply (lambda (x) (let/cc k (k x))) 7)))) + "simple attempt to capture a continuation from an unsafe context" - (nta-eval '(require m09)) - - (assert-true (catch-unsafe-context-exn - (lambda () (nta-eval '(dispatch-start 'foo))))))) + (let-values ([(go nta-eval) + (make-module-eval + (module nta mzscheme + (provide non-tail-apply) + + (define (non-tail-apply f . args) + (let ([result (apply f args)]) + (printf "result = ~s~n" result) + result))))]) + (nta-eval '(module m09 "../lang.ss" + (require nta) + (provide start) + (define (start ignore) + (non-tail-apply (lambda (x) (let/cc k (k x))) 7)))) + + (nta-eval '(require m09)) + + (assert-true (catch-unsafe-context-exn + (lambda () (nta-eval '(dispatch-start 'foo))))))) (make-test-case "sanity-check: capture continuation from safe version of context" (let-values ([(go m10-eval) - (make-module-eval - (module m10 "../lang.ss" - (provide start) - (define (nta f arg) - (let ([result (f arg)]) - (printf "result = ~s~n" result) - result)) - (define (start ignore) - (nta (lambda (x) (let/cc k (k x))) 7))))]) + (make-module-eval + (module m10 "../lang.ss" + (provide start) + (define (nta f arg) + (let ([result (f arg)]) + (printf "result = ~s~n" result) + result)) + (define (start ignore) + (nta (lambda (x) (let/cc k (k x))) 7))))]) (go) (assert = 7 (m10-eval '(dispatch-start 'foo))))) @@ -409,13 +367,13 @@ "attempt continuation capture from standard call to map" (let-values ([(go m11-eval) - (make-module-eval - (module m11 "../lang.ss" - (provide start) - (define (start ignore) - (map - (lambda (x) (let/cc k k)) - (list 1 2 3)))))]) + (make-module-eval + (module m11 "../lang.ss" + (provide start) + (define (start ignore) + (map + (lambda (x) (let/cc k k)) + (list 1 2 3)))))]) (go) (assert-true (catch-unsafe-context-exn (lambda () (m11-eval '(dispatch-start 'foo))))))) @@ -424,70 +382,70 @@ ;; should be just fine. ; XXX Weird #;(make-test-case - "continuation capture from tail position of untranslated procedure" - - (let ([ta-eval - (make-module-eval - (module ta mzscheme - (provide tail-apply) - - (define (tail-apply f . args) - (apply f args))))]) + "continuation capture from tail position of untranslated procedure" - (ta-eval '(module m12 "../lang.ss" - (require ta) - (provide start) - (define (start initial) - (+ initial - (tail-apply (lambda (x) (let/cc k (k x))) 1))))) - - (ta-eval '(require m12)) - - (assert = 2 (ta-eval '(dispatch-start 1))))) + (let ([ta-eval + (make-module-eval + (module ta mzscheme + (provide tail-apply) + + (define (tail-apply f . args) + (apply f args))))]) + + (ta-eval '(module m12 "../lang.ss" + (require ta) + (provide start) + (define (start initial) + (+ initial + (tail-apply (lambda (x) (let/cc k (k x))) 1))))) + + (ta-eval '(require m12)) + + (assert = 2 (ta-eval '(dispatch-start 1))))) (make-test-case "attempt send/suspend from standard call to map" (let-values ([(go m13-eval) - (make-module-eval - (module m11 "../lang.ss" - (provide start) - (define (start initial) - (map - (lambda (n) (send/suspend - (lambda (k) - (let ([ignore (printf "n = ~s~n" n)]) - k)))) - (list 1 2 3)))))]) + (make-module-eval + (module m11 "../lang.ss" + (provide start) + (define (start initial) + (map + (lambda (n) (send/suspend + (lambda (k) + (let ([ignore (printf "n = ~s~n" n)]) + k)))) + (list 1 2 3)))))]) (go) (assert-true (catch-unsafe-context-exn (lambda () (m13-eval '(dispatch-start 'foo))))))) ; XXX Weird #;(make-test-case - "attempt send/suspend from tail position of untranslated procedure" - - (let-values ([(go ta-eval) - (make-module-eval - (module ta mzscheme - (provide tail-apply) - - (define (tail-apply f . args) - (apply f args))))]) + "attempt send/suspend from tail position of untranslated procedure" - (ta-eval '(module m14 "../lang.ss" - (require ta) - (provide start) - (define (start ignore) - (+ 1 (tail-apply - (lambda (n) - (cadr - (send/suspend - (lambda (k) - (let ([ignore (printf "n = ~s~n" n)]) - k))))) 7))))) - (ta-eval '(require m14)) - - (let ([k0 (ta-eval '(dispatch-start 'foo))]) - (assert = 3 (ta-eval `(dispatch (list ,k0 2)))) - (assert = 0 (ta-eval `(dispatch (list ,k0 -1))))))))))) \ No newline at end of file + (let-values ([(go ta-eval) + (make-module-eval + (module ta mzscheme + (provide tail-apply) + + (define (tail-apply f . args) + (apply f args))))]) + + (ta-eval '(module m14 "../lang.ss" + (require ta) + (provide start) + (define (start ignore) + (+ 1 (tail-apply + (lambda (n) + (cadr + (send/suspend + (lambda (k) + (let ([ignore (printf "n = ~s~n" n)]) + k))))) 7))))) + (ta-eval '(require m14)) + + (let ([k0 (ta-eval '(dispatch-start 'foo))]) + (assert = 3 (ta-eval `(dispatch (list ,k0 2)))) + (assert = 0 (ta-eval `(dispatch (list ,k0 -1))))))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/language-tester.ss b/collects/web-server/prototype-web-server/tests/language-tester.ss index 4cd4c8017c..42bdae1cda 100644 --- a/collects/web-server/prototype-web-server/tests/language-tester.ss +++ b/collects/web-server/prototype-web-server/tests/language-tester.ss @@ -2,27 +2,30 @@ (provide make-module-eval 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) (syntax-case m-expr (module) [(_ (module m-id . rest)) #'(let ([ns (make-namespace)]) (parameterize ([current-namespace ns]) - (eval '(require "../abort-resume.ss" + (eval '(require (lib "abort-resume.ss" "web-server" "prototype-web-server") (lib "serialize.ss"))) (eval '(module m-id . rest)) (eval '(require m-id))) (values - (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))))))))))) + (go ns) (lambda (s-expr) (parameterize ([current-namespace ns]) (eval s-expr)))))] @@ -32,9 +35,10 @@ (define (make-eval/mod-path pth) (let ([ns (make-namespace)]) (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") (file ,pth)))) - (lambda (expr) - (parameterize ([current-namespace ns]) - (eval expr)))))) \ No newline at end of file + (values (go ns) + (lambda (expr) + (parameterize ([current-namespace ns]) + (eval expr))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss b/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss index 31f04cc3be..41d34c5465 100644 --- a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss +++ b/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss @@ -48,29 +48,32 @@ (make-test-case "compose url-parts and recover-serial (1)" - (let* ([ev (make-eval/mod-path "modules/mm00.ss")] - [k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) - `(file "modules/mm00.ss"))] - [k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) - `(file "modules/mm00.ss"))] - [k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) - `(file "modules/mm00.ss"))]) - (assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))) + (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")]) + (go) + (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) + `(file "modules/mm00.ss"))] + [k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) + `(file "modules/mm00.ss"))] + [k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) + `(file "modules/mm00.ss"))]) + (assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))) (make-test-case "compose url-parts and recover-serial (2)" - (let* ([ev (make-eval/mod-path "modules/mm01.ss")] - [k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) - `(file "modules/mm01.ss"))]) - (assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7))))))) + (let-values ([(go ev) (make-eval/mod-path "modules/mm01.ss")]) + (go) + (let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) + `(file "modules/mm01.ss"))]) + (assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7)))))))) (make-test-case "compose stuff-url and unstuff-url and recover the serial" - (let* ([ev (make-eval/mod-path "modules/mm00.ss")] - [k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo))) - uri0 `(file "modules/mm00.ss"))] - [k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) - uri0 `(file "modules/mm00.ss"))] - [k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) - uri0 `(file "modules/mm00.ss"))]) - (assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))))) \ No newline at end of file + (let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")]) + (go) + (let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo))) + uri0 `(file "modules/mm00.ss"))] + [k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1)))) + uri0 `(file "modules/mm00.ss"))] + [k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2)))) + uri0 `(file "modules/mm00.ss"))]) + (assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/suite.ss b/collects/web-server/prototype-web-server/tests/suite.ss index ef14ce2ffa..c0a8213061 100644 --- a/collects/web-server/prototype-web-server/tests/suite.ss +++ b/collects/web-server/prototype-web-server/tests/suite.ss @@ -1,11 +1,13 @@ (module suite mzscheme (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)) "persistent-close-tests.ss" "test-normalizer.ss" "closure-tests.ss" "labels-tests.ss" "lang-tests.ss" + "certify-tests.ss" "stuff-url-tests.ss") (test/graphical-ui @@ -17,4 +19,5 @@ closure-tests-suite labels-tests-suite lang-suite + certify-suite ))) \ No newline at end of file