From 1119702903dd615b7c148fa0c6b6bad930d6f705 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Sat, 14 Jul 2007 15:13:17 +0000
Subject: [PATCH] Fixing error with freevars and eliminating code duplication

svn: r6915
---
 collects/web-server/lang/elim-callcc.ss | 29 ++++++++++++++-----------
 collects/web-server/lang/freevars.ss    |  8 +++++--
 collects/web-server/tests/lang-test.ss  | 12 +++++++++-
 3 files changed, 33 insertions(+), 16 deletions(-)

diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss
index 7127c6fc05..bd16091c1c 100644
--- a/collects/web-server/lang/elim-callcc.ss
+++ b/collects/web-server/lang/elim-callcc.ss
@@ -80,6 +80,7 @@
        (let* ([ke-prime (elim-callcc #'ke)]
               [me-prime (elim-callcc #'me)]
               [be-prime (elim-callcc #'be)])
+         ; XXX Could be dangerous to evaluate ke-prime and me-prime twice
          (markit 
           (quasisyntax/loc stx
             (with-continuation-mark #,ke-prime #,me-prime
@@ -101,19 +102,21 @@
                                      (lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
                           (#%app activation-record-list))))))]
       [(#%app call-with-values (lambda () prod) cons)
-       (let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
-         (markit
-          (quasisyntax/loc stx
-            (#%app call-with-values 
-                   #,(mark-lambda-as-safe
-                      (quasisyntax/loc stx
-                        (lambda ()
-                          #,(elim-callcc/mark
-                             (lambda (x)
-                               (quasisyntax/loc stx
-                                 (with-continuation-mark the-cont-key #,cons-prime #,x)))
-                             #'prod))))
-                   #,cons-prime))))]
+       (let ([cons-prime (datum->syntax-object #f (gensym 'cons))])
+         (quasisyntax/loc stx
+           (let-values ([(#,cons-prime) #,(mark-lambda-as-safe (elim-callcc #'cons))])
+             #,(markit
+                (quasisyntax/loc stx
+                  (#%app call-with-values 
+                         #,(mark-lambda-as-safe
+                            (quasisyntax/loc stx
+                              (lambda ()
+                                #,(elim-callcc/mark
+                                   (lambda (x)
+                                     (quasisyntax/loc stx
+                                       (with-continuation-mark the-cont-key #,cons-prime #,x)))
+                                   #'prod))))
+                         #,cons-prime))))))]
       [(#%app w (#%app . stuff))
        (with-syntax ([e #'(#%app . stuff)])
          (syntax-case #'w (lambda case-lambda)
diff --git a/collects/web-server/lang/freevars.ss b/collects/web-server/lang/freevars.ss
index ccd956e56c..1d0b8055a1 100644
--- a/collects/web-server/lang/freevars.ss
+++ b/collects/web-server/lang/freevars.ss
@@ -29,7 +29,8 @@
          (set-diff (free-vars #'ve)
                    (syntax->list #'(v ...))))]
       [(set! v ve)
-       (free-vars #'ve)]
+       (union (free-vars #'v)
+              (free-vars #'ve))]
       [(let-values ([(v ...) ve] ...) be ...)
        (union (free-vars* (syntax->list #'(ve ...)))
               (set-diff (free-vars* (syntax->list #'(be ...)))
@@ -84,9 +85,12 @@
       [id (identifier? #'id)
           (let ([i-bdg (identifier-binding #'id)])
             (cond
-              [(eqv? 'lexical (identifier-binding #'id))
+              [(eqv? 'lexical i-bdg)
+               (list #'id)]
+              [(not i-bdg)
                (list #'id)]
               [else 
+               #;(printf "Not including id ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg)
                empty]))]
       [_
        (raise-syntax-error 'freevars "Dropped through:" stx)]))  
diff --git a/collects/web-server/tests/lang-test.ss b/collects/web-server/tests/lang-test.ss
index 36c60d0adf..cefc6929b9 100644
--- a/collects/web-server/tests/lang-test.ss
+++ b/collects/web-server/tests/lang-test.ss
@@ -525,6 +525,16 @@
              
              (define-struct posn (x y))
              (provide/contract
-              [struct posn ([x integer?] [y integer?])])))))))
+              [struct posn ([x integer?] [y integer?])]))))))
+      
+      (test-case
+       "define-values error"
+       (check-not-exn
+        (lambda ()
+          (make-module-eval
+           (module test (lib "lang.ss" "web-server")
+             (define (show-user)
+               (define-values (point i) (values #t 1))
+               i)))))))
      
      )))
\ No newline at end of file