diff --git a/collects/web-server/lang/anormal.ss b/collects/web-server/lang/anormal.ss index 8fe5453fc0..d13413ab65 100644 --- a/collects/web-server/lang/anormal.ss +++ b/collects/web-server/lang/anormal.ss @@ -141,12 +141,10 @@ (ctxt stx)] [id (identifier? #'id) (ctxt #'id)] - ; XXX Shouldn't be here [(letrec-syntaxes+values ([(sv ...) se] ...) ([(vv ...) ve] ...) be ...) - (anormal ctxt - (elim-letrec-term stx))] + (anormal ctxt (elim-letrec-term stx))] [(#%expression d) (anormal (ccompose ctxt diff --git a/collects/web-server/lang/elim-letrec.ss b/collects/web-server/lang/elim-letrec.ss index 7da956d41c..07d2949e2f 100644 --- a/collects/web-server/lang/elim-letrec.ss +++ b/collects/web-server/lang/elim-letrec.ss @@ -88,32 +88,12 @@ (if (bound-identifier-member? #'id ids) (syntax/loc stx (#%plain-app unbox id)) #'id)] - ; XXX These two cases shouldn't be here. [(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 (#%plain-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 ...) - (#%plain-app values nvv-box ...)] ...) - ; This is okay, because we've already expanded the syntax. - (let-syntaxes - ([(sv ...) se] ...) - (begin (#%plain-app call-with-values - (#%plain-lambda () ve) - (#%plain-lambda (nvv ...) - (#%plain-app set-box! vv nvv) ...)) - ... - be ...))))))] + ((elim-letrec ids) + (syntax/loc stx + (letrec-values ([(vv ...) ve] ...) be ...)))] [(#%expression d) (quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))] [_ diff --git a/collects/web-server/lang/freevars.ss b/collects/web-server/lang/freevars.ss index 7cacf69afb..34b18b3abe 100644 --- a/collects/web-server/lang/freevars.ss +++ b/collects/web-server/lang/freevars.ss @@ -72,15 +72,10 @@ [else #;(printf "Not including id ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg) empty]))] - ; XXX Shouldn't be here [(letrec-syntaxes+values ([(sv ...) se] ...) ([(vv ...) ve] ...) be ...) - (set-diff (union* (free-vars* (syntax->list #'(se ...))) - (free-vars* (syntax->list #'(ve ...))) - (free-vars* (syntax->list #'(be ...)))) - (append (apply append (map syntax->list (syntax->list #'((sv ...) ...)))) - (apply append (map syntax->list (syntax->list #'((vv ...) ...))))))] + (free-vars #'(letrec-values ([(vv ...) ve] ...) be ...))] [(#%expression d) (free-vars #'d)] [_ diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index af0c87f6b8..411bd7d06f 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -3,7 +3,7 @@ syntax/kerncase mzlib/pretty mzlib/list) -(provide (except-out (all-defined-out) template)) +(provide (all-defined-out)) (define transformer? (make-parameter #f)) @@ -55,19 +55,9 @@ (list (quasisyntax/loc stx (define-values (v ...) #,nve)))))] [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (let-values ([(nve defs) (inner #'ve)]) - (append - defs - (list (quasisyntax/loc stx - (define-syntaxes (v ...) #,nve))))))] + (list stx)] [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (let-values ([(nve defs) (inner #'ve)]) - (append - defs - (list (quasisyntax/loc stx - (define-values-for-syntax (v ...) #,nve))))))] + (list stx)] [(#%require spec ...) (list stx)] [expr @@ -107,68 +97,3 @@ (lambda (an-id) (bound-identifier=? id an-id)) ids)) - -;; Kernel Case Template -(define (template stx) - (recertify - stx - (kernel-syntax-case - stx (transformer?) - [(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 ...)))] - [(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 ...)))] - [(#%plain-lambda formals be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (#%plain-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)))] - [(quote datum) - stx] - [(quote-syntax datum) - stx] - [(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)))] - [(#%plain-app e ...) - (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))]) - (syntax/loc stx - (#%plain-app e ...)))] - [(#%top . v) - stx] - [(#%variable-reference . v) - stx] - [id (identifier? #'id) - stx] - [_ - (raise-syntax-error 'kerncase "Dropped through:" stx)]))) diff --git a/collects/web-server/tests/lang-test.ss b/collects/web-server/tests/lang-test.ss index e99e3cfbe0..7d69d314ee 100644 --- a/collects/web-server/tests/lang-test.ss +++ b/collects/web-server/tests/lang-test.ss @@ -272,7 +272,34 @@ (check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3)))) (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1))))) (check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0)))) - (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7))))))))) + (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))) + + (test-case + "curried with send/suspend and serializaztion (keyword args)" + + (let-values ([(test-m06.2) + (make-module-eval + (module m06.2 (lib "lang.ss" "web-server") + (provide start) + (define (gn #:page which) + (cadr + (send/suspend + (lambda (k) + (let ([ignore (printf "Please send the ~a number.~n" which)]) + k))))) + + (define (start ignore) + (let ([result (+ (gn #:page "first") (gn #:page "second"))]) + (let ([ignore (printf "The answer is: ~s~n" result)]) + result)))))]) + (let* ([first-key (test-m06.2 '(dispatch-start start 'foo))] + [second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))] + [third-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))]) + (check = 3 (test-m06.2 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2)))))) + (check = 4 (test-m06.2 `(dispatch ,the-dispatch (list ,second-key 3)))) + (check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,second-key -1))))) + (check = -7 (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 0)))) + (check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 7))))))))) (test-suite "Test the certification process" diff --git a/collects/web-server/tests/lang/anormal-test.ss b/collects/web-server/tests/lang/anormal-test.ss index 1ddc86e260..f2f9c4f52d 100644 --- a/collects/web-server/tests/lang/anormal-test.ss +++ b/collects/web-server/tests/lang/anormal-test.ss @@ -45,7 +45,7 @@ ;; w-alpha=/env: env target-expr target-expr -> boolean ;; are two target vars or vals alpha-equivalent? (define (w-alpha=/env env1 env2 expr1 expr2) - (syntax-case expr1 (#%top #%plain-lambda quote) + (syntax-case expr1 (#%top #%plain-lambda quote #%expression) [(#%top . var1) (syntax-case expr2 (#%top) [(#%top . var2) @@ -69,6 +69,11 @@ (extend env2 (syntax->symbols (formals-list #'formals2)) syms) #'body1 #'body2)))] [_else #f])] + [(#%expression e1) + (syntax-case expr2 (#%expression) + [(#%expression e2) + (w-alpha=/env env1 env2 #'e1 #'e2)] + [_else #f])] [x1 (symbol? (syntax->datum #'x1)) (syntax-case expr2 () [x2 (symbol? (syntax->datum #'x2))