From 249f3db1b569bf37fe26f44bd7d979f2a4f495aa Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 11 Sep 2008 22:43:19 +0000
Subject: [PATCH] Add identifier checking and contract verification where
 appropriate.

svn: r11658
---
 collects/scheme/private/contract.ss | 31 +++++++++++++++--------------
 1 file changed, 16 insertions(+), 15 deletions(-)

diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 5702043f1a..894bab994f 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -34,6 +34,19 @@ improve method arity mismatch contract violation error messages?
          (for-syntax (prefix-in a: "contract-helpers.ss")))
 
 
+;; These are useful for all below.
+
+(define-syntax (verify-contract stx)
+  (syntax-case stx ()
+    [(_ x) (a:known-good-contract? #'x) #'x]
+    [(_ x) #'(verify-contract/proc x)]))
+
+(define (verify-contract/proc x)
+  (unless (or (contract? x)
+              (and (procedure? x)
+                   (procedure-arity-includes? x 1)))
+    (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
+  x)
 
 ;                                                                                                    
 ;                                                                                                    
@@ -60,7 +73,7 @@ improve method arity mismatch contract violation error messages?
     [(_ name contract-expr expr0 expr ...)
      (identifier? (syntax name))
      #'(with-contract name
-         ([name contract-expr])
+         ([name (verify-contract contract-expr)])
          (define name expr0 expr ...))]
     [(_ name+arg-list contract body0 body ...)
      (let-values ([(name lam-expr)
@@ -141,6 +154,7 @@ improve method arity mismatch contract violation error messages?
       [(let ([lst (syntax->list (car args))])
          (and (list? lst)
               (= (length lst) 2)
+              (identifier? (first lst))
               lst))
        =>
        (lambda (l)
@@ -175,7 +189,7 @@ improve method arity mismatch contract violation error messages?
                  (begin-with-definitions
                    body0 body ...
                    (values unprotected-id ... protected-id ...))))
-             (define contract-id contract-expr) ...
+             (define contract-id (verify-contract contract-expr)) ...
              (define-syntax protected-id
                (make-with-contract-transformer 
                 (quote-syntax contract-id)
@@ -766,19 +780,6 @@ improve method arity mismatch contract violation error messages?
           (begin
             bodies ...))))]))
 
-(define-syntax (verify-contract stx)
-  (syntax-case stx ()
-    [(_ x) (a:known-good-contract? #'x) #'x]
-    [(_ x) #'(verify-contract/proc x)]))
-
-(define (verify-contract/proc x)
-  (unless (or (contract? x)
-              (and (procedure? x)
-                   (procedure-arity-includes? x 1)))
-    (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
-  x)
-
-
 (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
   (let-values ([(struct:struct-name _make _pred _get _set)
                 (make-struct-type struct-name