From 9cec27f49beb29a02ef8646958da56df7d86ee3c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 14 Jun 2007 20:25:46 +0000 Subject: [PATCH] Dealing with syntax by punting svn: r6663 --- collects/web-server/lang/anormal.ss | 10 ++---- collects/web-server/lang/defun.ss | 12 +++---- collects/web-server/lang/elim-callcc.ss | 13 +++----- collects/web-server/lang/elim-letrec.ss | 11 ++----- collects/web-server/lang/util.ss | 8 ++--- collects/web-server/tests/lang-test.ss | 32 ++++++++++++++++++- .../web-server/tests/lang/all-lang-tests.ss | 2 ++ .../web-server/tests/lang/anormal-test.ss | 7 +++- collects/web-server/tests/lang/defun-test.ss | 25 +++++++++++++++ 9 files changed, 81 insertions(+), 39 deletions(-) create mode 100644 collects/web-server/tests/lang/defun-test.ss diff --git a/collects/web-server/lang/anormal.ss b/collects/web-server/lang/anormal.ss index 2482d346f3..76925f51d0 100644 --- a/collects/web-server/lang/anormal.ss +++ b/collects/web-server/lang/anormal.ss @@ -64,15 +64,9 @@ (syntax/loc stx (define-values (v ...) ve)))] [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve))))] + stx] [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve))))] + stx] [(set! v ve) (anormal (compose ctxt diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss index a9bbfd2ec1..30f7d2c6b2 100644 --- a/collects/web-server/lang/defun.ss +++ b/collects/web-server/lang/defun.ss @@ -33,15 +33,11 @@ (values (quasisyntax/loc stx (define-values (v ...) #,nve)) defs))] [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve)) - defs)))] + (values stx + empty)] [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve)) - defs)))] + (values stx + empty)] [(set! v ve) (let-values ([(nve defs) (defun #'ve)]) (values (quasisyntax/loc stx (set! v #,nve)) diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index 63c3e82926..7127c6fc05 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -1,6 +1,7 @@ (module elim-callcc mzscheme (require-for-template mzscheme "../lang/abort-resume.ss") + (require-for-syntax "../lang/abort-resume.ss") (require (lib "kerncase.ss" "syntax") "util.ss") (provide elim-callcc) @@ -42,15 +43,9 @@ (syntax/loc stx (define-values (v ...) ve)))] [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) - (syntax/loc stx - (define-values (v ...) ve))))] + stx] [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve))))] + stx] [(set! v ve) (with-syntax ([ve (elim-callcc #'ve)]) (syntax/loc stx (set! v ve)))] @@ -158,7 +153,7 @@ [(#%app w rest ...) (markit (quasisyntax/loc stx - (with-continuation-mark safe-call? '(#f #,stx) + (with-continuation-mark safe-call? '(#f stx) (#%app #,(mark-lambda-as-safe (elim-callcc #'w)) #,@(map (lambda (an-expr) diff --git a/collects/web-server/lang/elim-letrec.ss b/collects/web-server/lang/elim-letrec.ss index 05bbdd55d3..2d12007b0b 100644 --- a/collects/web-server/lang/elim-letrec.ss +++ b/collects/web-server/lang/elim-letrec.ss @@ -1,6 +1,7 @@ (module elim-letrec mzscheme (require-for-template mzscheme "../lang/abort-resume.ss") + (require-for-syntax "../lang/abort-resume.ss") (require (lib "kerncase.ss" "syntax") (lib "etc.ss") (lib "list.ss") @@ -28,15 +29,9 @@ (syntax/loc stx (define-values (v ...) ve)))] [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve))))] + stx] [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve))))] + stx] [(set! v ve) (with-syntax ([ve ((elim-letrec ids) #'ve)]) (if (bound-identifier-member? #'id ids) diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index aae05e3f29..88e41f8098 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -103,10 +103,10 @@ stx (syntax-case stx () ((mb forms ...) - (with-syntax ([(pmb rfs body ...) + (with-syntax ([(pmb rfs0 body ...) (local-expand (quasisyntax/loc stx (#%plain-module-begin - #,(syntax-local-introduce #'(require-for-syntax mzscheme)) + #,(syntax-local-introduce #'(require-for-syntax mzscheme)) forms ...)) 'module-begin empty)]) @@ -116,7 +116,7 @@ (datum->syntax-object stx (base-labeling)))]) (let ([new-defs (apply append (map transform (syntax->list #'(body ...))))]) (quasisyntax/loc stx - (pmb rfs + (pmb rfs0 #,@new-defs)))))))))) (define (bound-identifier-member? id ids) @@ -147,7 +147,7 @@ (parameterize ([transformer? #t]) (with-syntax ([ve (template #'ve)]) (syntax/loc stx - (define-values (v ...) ve))))] + (define-syntaxes (v ...) ve))))] [(define-values-for-syntax (v ...) ve) (parameterize ([transformer? #t]) (with-syntax ([ve (template #'ve)]) diff --git a/collects/web-server/tests/lang-test.ss b/collects/web-server/tests/lang-test.ss index 612b1ac6c2..36c60d0adf 100644 --- a/collects/web-server/tests/lang-test.ss +++ b/collects/web-server/tests/lang-test.ss @@ -497,4 +497,34 @@ (let ([k0 (ta-eval '(dispatch-start start 'foo))]) (check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2)))) - (check = 0 (ta-eval `(dispatch ,the-dispatch (list ,k0 -1))))))))))) \ No newline at end of file + (check = 0 (ta-eval `(dispatch ,the-dispatch (list ,k0 -1)))))))) + + (test-suite + "Weird Cases" + + (test-case + "provide/contract: simple" + (check-not-exn + (lambda () + (make-module-eval + (module data (lib "lang.ss" "web-server") + (require (lib "contract.ss")) + + (define x 1) + (provide/contract + [x integer?])))))) + + + (test-case + "provide/contract: struct" + (check-not-exn + (lambda () + (make-module-eval + (module data (lib "lang.ss" "web-server") + (require (lib "contract.ss")) + + (define-struct posn (x y)) + (provide/contract + [struct posn ([x integer?] [y integer?])]))))))) + + ))) \ No newline at end of file diff --git a/collects/web-server/tests/lang/all-lang-tests.ss b/collects/web-server/tests/lang/all-lang-tests.ss index 6b1ff43d8f..df12ff4a17 100644 --- a/collects/web-server/tests/lang/all-lang-tests.ss +++ b/collects/web-server/tests/lang/all-lang-tests.ss @@ -1,6 +1,7 @@ (module all-lang-tests mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) "anormal-test.ss" + "defun-test.ss" "file-box-test.ss" "labels-test.ss" "stuff-url-test.ss" @@ -11,6 +12,7 @@ (test-suite "Web Language" anormal-tests + defun-tests file-box-tests labels-tests stuff-url-tests diff --git a/collects/web-server/tests/lang/anormal-test.ss b/collects/web-server/tests/lang/anormal-test.ss index bad5db2377..789c529a2b 100644 --- a/collects/web-server/tests/lang/anormal-test.ss +++ b/collects/web-server/tests/lang/anormal-test.ss @@ -332,4 +332,9 @@ (* (car l) (cdr l))]))))) #t))) - (test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y))))))))))) \ No newline at end of file + (test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y))))))) + (test-not-exn "quote-syntax: #f" (lambda () (parameterize ([transformer? #f]) + (normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!)))))) + (test-not-exn "quote-syntax: #t" (lambda () (parameterize ([transformer? #t]) + (normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!)))))) + )))) \ No newline at end of file diff --git a/collects/web-server/tests/lang/defun-test.ss b/collects/web-server/tests/lang/defun-test.ss new file mode 100644 index 0000000000..42384cf7fd --- /dev/null +++ b/collects/web-server/tests/lang/defun-test.ss @@ -0,0 +1,25 @@ +(module defun-test mzscheme + (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (lib "defun.ss" "web-server" "lang") + (lib "util.ss" "web-server" "lang")) + (provide defun-tests) + + (define-syntax vwrap + (syntax-rules () + [(_ e) + (call-with-values + (lambda () e) + (lambda x x))])) + + (define defun-tests + (test-suite + "Defunctionalization" + + (test-not-exn "define-struct" (lambda () (vwrap (defun (expand (syntax (define-struct posn (x y)))))))) + (test-not-exn "quote-syntax" (lambda () (vwrap (defun (expand (syntax #'provide/contract-id-set-a-date-day!)))))) + #;(test-not-exn "provide/contract" (lambda () (vwrap (defun (expand (syntax (module t mzscheme + (require (lib "contract.ss")) + (define x 1) + (provide/contract + [x integer?])))))))) + ))) \ No newline at end of file