From cb5c9f2ba67dde51c40fbe93eafec24f6131552f Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 8 Oct 2007 14:59:27 +0000
Subject: [PATCH] Bug in handling of expression syntax

svn: r7452
---
 collects/web-server/info.ss             | 4 ++--
 collects/web-server/lang/anormal.ss     | 8 ++++++--
 collects/web-server/lang/defun.ss       | 7 ++++---
 collects/web-server/lang/elim-callcc.ss | 4 ++--
 collects/web-server/lang/elim-letrec.ss | 4 ++--
 collects/web-server/lang/freevars.ss    | 6 ++++--
 6 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/collects/web-server/info.ss b/collects/web-server/info.ss
index 5a573ac941..20c009dc4b 100644
--- a/collects/web-server/info.ss
+++ b/collects/web-server/info.ss
@@ -1,7 +1,7 @@
 (module info (lib "infotab.ss" "setup")
   (define name "Web Server")  
-  ; XXX Uncomment and change doc-installer
-  #;(define post-install-collection "docs/doc-installer.ss")
+  ; Name clash
+  #;(define scribblings '(("docs/reference/reference.scrbl" (multi-page main-doc))))
   
   (define mzscheme-launcher-libraries
     (list "private/launch-text.ss"))
diff --git a/collects/web-server/lang/anormal.ss b/collects/web-server/lang/anormal.ss
index 76925f51d0..29ebd38f2c 100644
--- a/collects/web-server/lang/anormal.ss
+++ b/collects/web-server/lang/anormal.ss
@@ -140,8 +140,12 @@
                              #,(anormal-term #'be))))
                        #'me)))
            #'ke)]
-         [(#%expression . d)
-          (ctxt stx)]
+         [(#%expression d)
+          (anormal
+           (compose ctxt
+                    (lambda (d)
+                       (quasisyntax/loc stx (#%expression #,d))))
+           #'d)]
          [(#%app fe e ...)
           (anormal
            (lambda (val0)
diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss
index 30f7d2c6b2..dde76d6be3 100644
--- a/collects/web-server/lang/defun.ss
+++ b/collects/web-server/lang/defun.ss
@@ -112,9 +112,10 @@
           (let-values ([(es defs) (defun* (list #'ke #'me #'be))])
             (values (quasisyntax/loc stx (with-continuation-mark #,@es))
                     defs))]
-         [(#%expression . d)
-          (values stx 
-                  empty)]
+         [(#%expression d)
+          (let-values ([(nd d-defs) (defun #'d)])
+            (values (quasisyntax/loc stx (#%expression #,nd))
+                    d-defs))]
          [(#%app e ...)
           (let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
             (values (quasisyntax/loc stx (#%app #,@es))
diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss
index bd16091c1c..25d7f55b34 100644
--- a/collects/web-server/lang/elim-callcc.ss
+++ b/collects/web-server/lang/elim-callcc.ss
@@ -88,8 +88,8 @@
                   the-save-cm-key 
                 (#%app current-saved-continuation-marks-and #,ke-prime #,me-prime)
                 #,be-prime)))))]
-      [(#%expression . d)
-       stx]
+      [(#%expression d)
+       (markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))]
       [(#%app call/cc w)
        (let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
                     [(x ref-to-x) (generate-formal 'x)])
diff --git a/collects/web-server/lang/elim-letrec.ss b/collects/web-server/lang/elim-letrec.ss
index 2d12007b0b..cc783a6cf0 100644
--- a/collects/web-server/lang/elim-letrec.ss
+++ b/collects/web-server/lang/elim-letrec.ss
@@ -114,8 +114,8 @@
                       [be ((elim-letrec ids) #'be)])
           (syntax/loc stx
             (with-continuation-mark ke me be)))]
-       [(#%expression . d)
-        stx]
+       [(#%expression d)
+        (quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))]
        [(#%app e ...)
         (with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
           (syntax/loc stx
diff --git a/collects/web-server/lang/freevars.ss b/collects/web-server/lang/freevars.ss
index 1d0b8055a1..1904d182ce 100644
--- a/collects/web-server/lang/freevars.ss
+++ b/collects/web-server/lang/freevars.ss
@@ -67,11 +67,12 @@
                          (apply append (map syntax->list (syntax->list #'((vv ...) ...))))))]
       [(with-continuation-mark ke me be)
        (free-vars* (syntax->list #'(ke me be)))]
-      [(#%expression . d)
-       empty]
+      [(#%expression d)
+       (free-vars #'d)]
       [(#%app e ...)
        (free-vars* (syntax->list #'(e ...)))]
       [(#%top . v)
+       #;(printf "Not including top ~S in freevars~n" (syntax-object->datum #'v))
        empty]
       [(#%datum . d)
        empty]
@@ -81,6 +82,7 @@
            [(eqv? 'lexical (identifier-binding #'id))
             (list #'id)]
            [else 
+            #;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg)
             empty]))]
       [id (identifier? #'id)
           (let ([i-bdg (identifier-binding #'id)])