Dealing with syntax by punting

svn: r6663

collects/web-server/lang/anormal.ss

@@ -64,15 +64,9 @@
             (syntax/loc stx 
               (define-values (v ...) ve)))]
          [(define-syntaxes (v ...) ve)
-          (parameterize ([transformer? #t])
+          stx]
-            (with-syntax ([ve (anormal-term #'ve)])
-              (syntax/loc stx 
-                (define-syntaxes (v ...) ve))))]
          [(define-values-for-syntax (v ...) ve)
-          (parameterize ([transformer? #t])
+          stx]
-            (with-syntax ([ve (anormal-term #'ve)])
-              (syntax/loc stx 
-                (define-values-for-syntax (v ...) ve))))]
          [(set! v ve)
           (anormal
            (compose ctxt

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])
+          (values stx
-            (let-values ([(nve defs) (defun #'ve)])
+                  empty)]
-              (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
-                      defs)))]
          [(define-values-for-syntax (v ...) ve)
-          (parameterize ([transformer? #t])
+          (values stx
-            (let-values ([(nve defs) (defun #'ve)])
+                  empty)]
-              (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))

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])
+       stx]
-         (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
-           (syntax/loc stx
-             (define-values (v ...) ve))))]
       [(define-values-for-syntax (v ...) ve)
-       (parameterize ([transformer? #t])
+       stx]
-         (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)))]
@@ -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)

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])
+        stx]
-          (with-syntax ([ve ((elim-letrec ids) #'ve)])
-            (syntax/loc stx
-              (define-syntaxes (v ...) ve))))]
        [(define-values-for-syntax (v ...) ve)       
-        (parameterize ([transformer? #t])
+        stx]
-          (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)

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)])

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)))))))))))
+           (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?])])))))))
+     
+     )))

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

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)))))))))))
+      (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!))))))
+      ))))

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?]))))))))
+     )))