Transformer environment

svn: r6662

collects/web-server/lang/anormal.ss

@@ -34,7 +34,7 @@
       (recertify
        stx
        (kernel-syntax-case
-           stx #f 
+           stx (transformer?)
          [(begin)
           (anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
          [(begin lbe)
@@ -64,13 +64,15 @@
             (syntax/loc stx 
               (define-values (v ...) ve)))]
          [(define-syntaxes (v ...) ve)
+          (parameterize ([transformer? #t])
             (with-syntax ([ve (anormal-term #'ve)])
               (syntax/loc stx 
-              (define-values (v ...) ve)))]
+                (define-syntaxes (v ...) ve))))]
          [(define-values-for-syntax (v ...) ve)
+          (parameterize ([transformer? #t])
             (with-syntax ([ve (anormal-term #'ve)])
               (syntax/loc stx 
-              (define-values-for-syntax (v ...) ve)))]
+                (define-values-for-syntax (v ...) ve))))]
          [(set! v ve)
           (anormal
            (compose ctxt

collects/web-server/lang/defun.ss

@@ -19,7 +19,7 @@
      stx
      (lambda ()
        (kernel-syntax-case
-           stx #f 
+           stx (transformer?)
          [(begin be ...)
           (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
             (values (quasisyntax/loc stx (begin #,@nbes))
@@ -33,13 +33,15 @@
             (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))]
+                      defs)))]
          [(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))]
+                      defs)))]
          [(set! v ve)
           (let-values ([(nve defs) (defun #'ve)])
             (values (quasisyntax/loc stx (set! v #,nve))

collects/web-server/lang/elim-callcc.ss

@@ -32,7 +32,7 @@
     (recertify
      stx
      (kernel-syntax-case*
-      stx #f (call/cc call-with-values)
+      stx (transformer?) (call/cc call-with-values)
       [(begin be ...)
        (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
       [(begin0 be ...)
@@ -42,13 +42,15 @@
          (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)))]
+             (define-values (v ...) ve))))]
       [(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)))]
+             (define-values-for-syntax (v ...) ve))))]
       [(set! v ve)
        (with-syntax ([ve (elim-callcc #'ve)])
          (syntax/loc stx (set! v ve)))]

collects/web-server/lang/elim-letrec.ss

@@ -14,7 +14,7 @@
     (recertify
      stx
      (kernel-syntax-case
-         stx #f
+         stx (transformer?)
        [(begin be ...)
         (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
           (syntax/loc stx
@@ -28,13 +28,15 @@
           (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)))]
+              (define-syntaxes (v ...) ve))))]
        [(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)))]
+              (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/freevars.ss

@@ -12,7 +12,7 @@
   ;; Find the free variables in an expression
   (define (free-vars stx)  
     (kernel-syntax-case 
-        stx #f 
+        stx (transformer?)
       [(begin be ...)
        (free-vars* (syntax->list #'(be ...)))]
       [(begin0 be ...)
@@ -21,11 +21,13 @@
        (set-diff (free-vars #'ve)
                  (syntax->list #'(v ...)))]
       [(define-syntaxes (v ...) ve)
+       (parameterize ([transformer? #t])
          (set-diff (free-vars #'ve)
-                 (syntax->list #'(v ...)))]
+                   (syntax->list #'(v ...))))]
       [(define-values-for-syntax (v ...) ve)
+       (parameterize ([transformer? #t])
          (set-diff (free-vars #'ve)
-                 (syntax->list #'(v ...)))]
+                   (syntax->list #'(v ...))))]
       [(set! v ve)
        (free-vars #'ve)]
       [(let-values ([(v ...) ve] ...) be ...)

collects/web-server/lang/util.ss

@@ -4,6 +4,8 @@
            (lib "list.ss"))
   (provide (all-defined-except template))
   
+  (define transformer? (make-parameter #f))
+  
   (define (recertify old-expr expr)
     (syntax-recertify expr old-expr (current-code-inspector) #f))
   
@@ -50,13 +52,15 @@
           (syntax/loc stx
             (define-values (v ...) ve)))]
        [(define-syntaxes (v ...) ve)
+        (parameterize ([transformer? #t])
           (with-syntax ([ve (inner #'ve)])
             (syntax/loc stx
-            (define-syntaxes (v ...) ve)))]      
+              (define-syntaxes (v ...) ve))))]      
        [(define-values-for-syntax (v ...) ve)
+        (parameterize ([transformer? #t])
           (with-syntax ([ve (inner #'ve)])
             (syntax/loc stx
-            (define-values-for-syntax (v ...) ve)))]
+              (define-values-for-syntax (v ...) ve))))]
        [_
         (raise-syntax-error 'define-case "Dropped through:" stx)])))
   
@@ -126,7 +130,7 @@
     (recertify
      stx
      (kernel-syntax-case 
-         stx #f 
+         stx (transformer?)
        [(begin be ...)
         (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
           (syntax/loc stx
@@ -140,13 +144,15 @@
           (syntax/loc stx
             (define-values (v ...) ve)))]
        [(define-syntaxes (v ...) ve)
+        (parameterize ([transformer? #t])
           (with-syntax ([ve (template #'ve)])
             (syntax/loc stx
-            (define-values (v ...) ve)))]
+              (define-values (v ...) ve))))]
        [(define-values-for-syntax (v ...) ve)
+        (parameterize ([transformer? #t])
           (with-syntax ([ve (template #'ve)])
             (syntax/loc stx 
-            (define-values-for-syntax (v ...) ve)))]
+              (define-values-for-syntax (v ...) ve))))]
        [(set! v ve)
         (with-syntax ([ve (template #'ve)])
           (syntax/loc stx

collects/web-server/tests/lang/anormal-test.ss

@@ -330,4 +330,6 @@
                 [(zero? (car l)) (k 0)]
                 [else
                  (* (car l) (cdr l))])))))
-         #t)))))))
+         #t)))
+      
+      (test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y)))))))))))