From 1943083cf921d86dfc6b40ecbb5af855ede66ded Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sun, 15 Feb 2009 21:59:22 +0000
Subject: [PATCH] Fix nested with-contracts by checking explicitly for ssps. 
 Apparently painting the bindings causes the ssp to later fail when you try to
 access the parameter.  Not sure if this is a bug or not, will talk to
 Matthew.

svn: r13621
---
 collects/scheme/private/contract.ss      | 16 +++++++-
 collects/tests/mzscheme/contract-test.ss | 48 +++++++++++++++++++++++-
 2 files changed, 62 insertions(+), 2 deletions(-)

diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 15f476b2fb..acae98e8bd 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -214,7 +214,8 @@ improve method arity mismatch contract violation error messages?
     [(_ marker blame-stx ((p c) ...) (u ...) body0 body ...)
      (let ([expanded-body0 (local-expand #'body0
                                          (syntax-local-context)
-                                         (kernel-form-identifier-list))])
+                                         (cons #'splicing-syntax-parameterize
+                                               (kernel-form-identifier-list)))])
        (syntax-case expanded-body0 (begin define-values)
          [(begin sub ...)
           (syntax/loc stx
@@ -267,6 +268,19 @@ improve method arity mismatch contract violation error messages?
                        u-def ... p/c-def ...
                        (with-contract-helper marker blame-stx #,unused-p/cs #,unused-us
                                              body ...)))))]
+         [(splicing-syntax-parameterize bindings . ssp-body)
+          (let* ([marker-f (let ([marker (syntax-e #'marker)])
+                             (lambda (stx)
+                               (syntax-local-introduce
+                                (marker (syntax-local-introduce stx)))))]
+                 [expanded-ssp (local-expand (quasisyntax/loc expanded-body0
+                                               (splicing-syntax-parameterize bindings .
+                                                 #,(marker-f #'ssp-body)))
+                                             (syntax-local-context)
+                                             (kernel-form-identifier-list))])
+            (quasisyntax/loc stx
+              (begin #,expanded-ssp
+                     (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]
          [else
           (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
                                       (lambda (stx)
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index fef049973d..2e4c85d6f9 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -2476,7 +2476,53 @@
         (define (evenp n)
           (if (zero? n) #t (oddp (zero? n)))))
       (oddp 5)))
-
+  
+  (test/spec-passed
+   'with-contract5
+   '(let ()
+      (with-contract region1
+        ([x (-> number? number?)])
+        (with-contract region2
+          ([y (-> number? boolean?)])
+          (define (y n) #t))
+        (define (x n) (if (y n) 0 3)))
+      (x 4)))
+  
+  (test/spec-failed
+   'with-contract6
+   '(let ()
+      (with-contract region1
+        ([x (-> number? number?)])
+        (with-contract region2
+          ([y (-> number? boolean?)])
+          (define (y n) #t))
+        (define (x n) (y n)))
+      (x 4))
+   "(region region1)")
+  
+  (test/spec-failed
+   'with-contract7
+   '(let ()
+      (with-contract region1
+        ([x (-> number? number?)])
+        (with-contract region2
+          ([y (-> number? boolean?)])
+          (define (y n) #t))
+        (define (x n) (if (y #t) 4 0)))
+      (x 4))
+   "(region region1)")
+  
+  (test/spec-failed
+   'with-contract8
+   '(let ()
+      (with-contract region1
+        ([x (-> number? number?)])
+        (with-contract region2
+          ([y (-> number? boolean?)])
+          (define (y n) 3))
+        (define (x n) (if (y n) 4 0)))
+      (x 4))
+   "(region region2)")
 
 ;                                                                                                                         
 ;