From 770aab6700fb29dd8502004f7b47f006ed8859ed Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 17 Feb 2009 23:38:46 +0000
Subject: [PATCH] Move first-order checks for free-var ctcs to before the body
 of the with-contract expansion.

svn: r13713
---
 collects/scheme/private/contract.ss | 23 +++++++++++++----------
 1 file changed, 13 insertions(+), 10 deletions(-)

diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index f3e2731138..00e7b49274 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -329,10 +329,19 @@ improve method arity mismatch contract violation error messages?
                        [(marked-u ...) (map marker unprotected)])
            (quasisyntax/loc stx
              (begin
-               (define-values (free-ctc-id ...)
-                 (values (verify-contract 'with-contract free-ctc) ...))
+               (define-values (free-ctc-id ... ctc-id ...)
+                 (values (verify-contract 'with-contract free-ctc) ...
+                         (verify-contract 'with-contract ctc) ...))
                (define blame-id
                  (current-contract-region))
+               (define-values ()
+                 (begin (-contract free-ctc-id
+                                   free-var
+                                   blame-id
+                                   'cant-happen
+                                   free-src-info)
+                        ...
+                        (values)))
                (define-syntaxes (free-var-id ...)
                  (values (make-free-var-transformer
                           (quote-syntax free-var)
@@ -341,19 +350,13 @@ improve method arity mismatch contract violation error messages?
                           (quote-syntax blame-stx)) ...))
                (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
                  (with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body)))
-               (define-values (ctc-id ...)
-                 (values (verify-contract 'with-contract ctc) ...))
                (define-values ()
                  (begin (-contract ctc-id
                                    marked-p
                                    blame-stx
                                    'cant-happen
-                                   src-info) ...
-                        (-contract free-ctc-id
-                                   free-var
-                                   blame-id
-                                   'cant-happen
-                                   free-src-info) ...
+                                   src-info)
+                        ...
                         (values)))
                (define-syntaxes (u ... p ...)
                  (values (make-rename-transformer #'marked-u) ...