From 2677cbf1a40c373c9fffacd4c0df1d2d002cab7b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 16 Sep 2010 14:29:42 -0400
Subject: [PATCH] Cleanups to first-order checking for box/vector/hash
 contracts.

 * We no longer capture a contination when we have blame information.
 * We perform first-order checks more eagerly in the mutable case.
---
 collects/racket/contract/private/box.rkt    |  48 ++++----
 collects/racket/contract/private/hash.rkt   |  78 +++++++------
 collects/racket/contract/private/vector.rkt | 117 ++++++++++----------
 collects/tests/racket/contract-test.rktl    |   4 +-
 4 files changed, 123 insertions(+), 124 deletions(-)

diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt
index 4096af3616..e19567bf58 100644
--- a/collects/racket/contract/private/box.rkt
+++ b/collects/racket/contract/private/box.rkt
@@ -11,32 +11,31 @@
 
 (define-struct box/c (content immutable))
 
-(define (box/c-first-order ctc)
+(define (check-box/c ctc)
   (let ([elem-ctc (box/c-content ctc)]
         [immutable (box/c-immutable ctc)]
         [flat? (flat-box/c? ctc)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (box? val)
+        (fail "expected a box, got ~a" val))
+      (case immutable
+        [(#t)
+         (unless (immutable? val)
+           (fail "expected an immutable box, got ~a" val))]
+        [(#f)
+         (when (immutable? val)
+           (fail "expected a mutable box, got ~a" val))]
+        [(dont-care) (void)])
+      (when first-order?
+        (unless (contract-first-order-passes? elem-ctc (unbox val))
+          (fail "expected <~s>, got ~v" (contract-name elem-ctc) val)))
+      #t)))
+
+(define (box/c-first-order ctc)
+  (let ([check (check-box/c ctc)])
+    (λ (val)
       (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (box? val)
-          (fail "expected a box, got ~a" val))
-        (case immutable
-          [(#t)
-           (unless (immutable? val)
-             (fail "expected an immutable box, got ~a" val))]
-          [(#f)
-           (when (immutable? val)
-             (fail "expected a mutable box, got ~a" val))]
-          [(dont-care) (void)])
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (begin (((contract-projection elem-ctc) blame) (unbox val))
-                     (void))
-              (unless (contract-first-order-passes? elem-ctc (unbox val))
-                (fail))))))))
+        (check val (λ _ (return #f)) #t)))))
 
 (define (box/c-name ctc)
   (let ([elem-name (contract-name (box/c-content ctc))]
@@ -64,7 +63,8 @@
    (λ (ctc)
      (λ (blame)
        (λ (val)
-         ((box/c-first-order ctc) val #:blame blame)
+         ((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (((contract-projection (box/c-content ctc)) blame) (unbox val))
          val)))))
 
 (define (ho-projection box-wrapper)
@@ -75,7 +75,7 @@
         (let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
               [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
           (λ (val)
-            ((box/c-first-order ctc) val #:blame blame)
+            ((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
             (if (immutable? val)
                 (box-immutable (pos-elem-proj (unbox val)))
                 (box-wrapper val
diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt
index bf9a4ef915..2710e063ff 100644
--- a/collects/racket/contract/private/hash.rkt
+++ b/collects/racket/contract/private/hash.rkt
@@ -74,41 +74,39 @@
       [else
        (make-proxy-hash/c dom-ctc rng-ctc immutable)])))
 
-(define (hash/c-first-order ctc) 
+(define (check-hash/c ctc) 
   (let ([dom-ctc (hash/c-dom ctc)]
         [rng-ctc (hash/c-rng ctc)]
         [immutable (hash/c-immutable ctc)]
         [flat? (flat-hash/c? ctc)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (hash? val)
+        (fail "expected a hash, got ~a" val))
+      (when (and (not flat?)
+                 (not (flat-contract? dom-ctc))
+                 (not (hash-equal? val)))
+        (fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
+      (case immutable
+        [(#t) 
+         (unless (immutable? val) 
+           (fail "expected an immutable hash, got ~a" val))]
+        [(#f)
+         (when (immutable? val)
+           (fail "expected an mutable hash, got ~a" val))]
+        [(dont-care) (void)])
+      (when first-order?
+        (for ([(k v) (in-hash val)])
+          (unless (contract-first-order-passes? dom-ctc k)
+            (fail "expected <~s> for key, got ~v" (contract-name dom-ctc) k))
+          (unless (contract-first-order-passes? rng-ctc v)
+            (fail "expected <~s> for value, got ~v" (contract-name rng-ctc) v))))
+        #t)))
+
+(define (hash/c-first-order ctc)
+  (let ([check (check-hash/c ctc)])
+    (λ (val)
       (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (hash? val)
-          (fail "expected a hash, got ~a" val))
-        (when (and (not flat?)
-                   (not (flat-contract? dom-ctc))
-                   (not (hash-equal? val)))
-          (fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
-        (case immutable
-          [(#t) 
-           (unless (immutable? val) 
-             (fail "expected an immutable hash, got ~a" val))]
-          [(#f)
-           (when (immutable? val)
-             (fail "expected an mutable hash, got ~a" val))]
-          [(dont-care) (void)])
-        (when (or flat? (immutable? val))
-          (for ([(k v) (in-hash val)])
-            (if blame
-                (begin (((contract-projection dom-ctc) blame) k)
-                       (((contract-projection rng-ctc) blame) v)
-                       (void))
-                (unless (and (contract-first-order-passes? dom-ctc k)
-                             (contract-first-order-passes? rng-ctc v))
-                  (fail)))))
-        #t))))
+        (check val (λ _ (return #f)) #t)))))
 
 (define (hash/c-name ctc)
   (apply 
@@ -135,12 +133,16 @@
   (build-flat-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
-   
    #:projection
    (λ (ctc)
      (λ (blame)
        (λ (val)
-         ((hash/c-first-order ctc) val #:blame blame)
+         ((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (let ([dom-proj ((contract-projection (hash/c-dom ctc)) blame)]
+               [rng-proj ((contract-projection (hash/c-rng ctc)) blame)])
+           (for ([(k v) (in-hash val)])
+             (dom-proj k)
+             (rng-proj v)))
          val)))))
 
 (define (ho-projection hash-wrapper)
@@ -154,7 +156,7 @@
               [pos-rng-proj (rng-proc blame)]
               [neg-rng-proj (rng-proc (blame-swap blame))])
           (λ (val)
-            ((hash/c-first-order ctc) val #:blame blame)
+            ((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
             
             (if (immutable? val)
                 (let ([hash-maker
@@ -182,22 +184,16 @@
 
 (define-struct (chaperone-hash/c hash/c) ()
   #:omit-define-syntaxes
-
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
-   
-   #:projection
-   (ho-projection chaperone-hash)))
+   #:projection (ho-projection chaperone-hash)))
 
 (define-struct (proxy-hash/c hash/c) ()
   #:omit-define-syntaxes
-
   #:property prop:contract
   (build-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
-   
-   #:projection
-   (ho-projection proxy-hash)))
+   #:projection (ho-projection proxy-hash)))
diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt
index 3e4b26119d..01f4ef95a3 100644
--- a/collects/racket/contract/private/vector.rkt
+++ b/collects/racket/contract/private/vector.rkt
@@ -22,35 +22,33 @@
                 (list '#:immutable immutable)
                 null)))))
 
-(define (vectorof-first-order c) 
+(define (check-vectorof c) 
   (let ([elem-ctc (vectorof-elem c)]
         [immutable (vectorof-immutable c)]
         [flat? (flat-vectorof? c)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (vector? val)
+        (fail "expected a vector, got ~a" val))
+      (cond
+        [(eq? immutable #t)
+         (unless (immutable? val)
+           (fail "expected an immutable vector, got ~a" val))]
+        [(eq? immutable #f)
+         (when (immutable? val)
+           (fail "expected an mutable vector, got ~a" val))]
+        [else (void)])
+      (when first-order?
+        (for ([e (in-vector val)]
+              [n (in-naturals)])
+          (unless (contract-first-order-passes? elem-ctc e)
+            (fail "expected <~s> for element ~v, got ~v" (contract-name elem-ctc) n e))))
+      #t)))
+
+(define (vectorof-first-order ctc)
+  (let ([check (check-vectorof ctc)])
+    (λ (val)
       (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (vector? val)
-          (fail "expected a vector, got ~a" val))
-        (cond
-          [(eq? immutable #t)
-           (unless (immutable? val)
-             (fail "expected an immutable vector, got ~a" val))]
-          [(eq? immutable #f)
-           (when (immutable? val)
-             (fail "expected an mutable vector, got ~a" val))]
-          [else (void)])
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (let ([elem-proj ((contract-projection elem-ctc) blame)])
-                (for ([e (in-vector val)])
-                  (elem-proj e)))
-              (for ([e (in-vector val)])
-                (unless (contract-first-order-passes? elem-ctc e)
-                  (fail)))))
-        #t))))
+        (check val (λ _ (return #f)) #t)))))
 
 (define-struct (flat-vectorof vectorof) ()
   #:property prop:flat-contract
@@ -61,7 +59,11 @@
    (λ (ctc) 
      (λ (blame) 
        (λ (val)
-         ((vectorof-first-order ctc) val #:blame blame)
+         ((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
+         (let* ([elem-ctc (vectorof-elem ctc)]
+                [p ((contract-projection elem-ctc) blame)])
+           (for ([e (in-vector val)])
+             (p e)))
          val)))))
 
 (define (vectorof-ho-projection vector-wrapper)
@@ -72,7 +74,7 @@
          (let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
                [elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
            (λ (val)
-             ((vectorof-first-order ctc) val #:blame blame)
+             ((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
              (if (immutable? val)
                  (apply vector-immutable
                         (for/list ([e (in-vector val)])
@@ -166,40 +168,38 @@
                 (list '#:immutable immutable)
                 null)))))
 
-(define (vector/c-first-order c) 
+(define (check-vector/c c) 
   (let ([elem-ctcs (vector/c-elems c)]
         [immutable (vector/c-immutable c)]
         [flat? (flat-vector/c? c)])
-    (λ (val #:blame [blame #f])
-      (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (vector? val)
-          (fail "expected a vector, got ~a" val))
-        (cond
-          [(eq? immutable #t)
-           (unless (immutable? val)
-             (fail "expected an immutable vector, got ~a" val))]
-          [(eq? immutable #f)
-           (when (immutable? val)
-             (fail "expected an mutable vector, got ~a" val))]
-          [else (void)])
-        (let ([elem-count (length elem-ctcs)])
+    (λ (val fail [first-order? #f])
+      (unless (vector? val)
+        (fail "expected a vector, got ~a" val))
+      (cond
+        [(eq? immutable #t)
+         (unless (immutable? val)
+           (fail "expected an immutable vector, got ~a" val))]
+        [(eq? immutable #f)
+         (when (immutable? val)
+           (fail "expected an mutable vector, got ~a" val))]
+        [else (void)])
+      (let ([elem-count (length elem-ctcs)])
           (unless (= (vector-length val) elem-count)
             (fail "expected a vector of ~a element~a, got ~a"
                   elem-count (if (= elem-count 1) "" "s") val)))
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (for ([e (in-vector val)]
-                    [c (in-list elem-ctcs)])
-                (((contract-projection c) blame) e))
-              (for ([e (in-vector val)]
-                    [c (in-list elem-ctcs)])
-                (unless (contract-first-order-passes? c e)
-                  (fail)))))
-        #t))))
+      (when first-order?
+        (for ([e (in-vector val)]
+              [n (in-naturals)]
+              [c (in-list elem-ctcs)])
+          (unless (contract-first-order-passes? c e)
+            (fail "expected <~s> for element ~v, got ~v" (contract-name c) n val))))
+      #t)))
+
+(define (vector/c-first-order ctc)
+  (let ([check (check-vector/c ctc)])
+    (λ (val)
+      (let/ec return
+        (check val (λ _ (return #f)) #t)))))
 
 (define-struct (flat-vector/c vector/c) ()
   #:property prop:flat-contract
@@ -210,7 +210,10 @@
    (λ (ctc) 
      (λ (blame) 
        (λ (val)
-         ((vector/c-first-order ctc) val #:blame blame)
+         ((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (for ([e (in-vector val)]
+               [c (in-list (vector/c-elems ctc))])
+           (((contract-projection c) blame) e))
          val)))))
 
 (define (vector/c-ho-projection vector-wrapper)
@@ -223,7 +226,7 @@
                [elem-neg-projs (apply vector-immutable
                                       (map (λ (c) ((contract-projection c) (blame-swap blame))) elem-ctcs))])
            (λ (val)
-             ((vector/c-first-order ctc) val #:blame blame)
+             ((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
              (if (immutable? val)
                  (apply vector-immutable
                         (for/list ([e (in-vector val)]
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 43d7d497f1..e7a599cbeb 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -9629,12 +9629,12 @@ so that propagation occurs.
   
   (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash))
   (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f)
-  (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
+  (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
                                                                      (hash-set! ht 'x 1)
                                                                      ht))
   (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t)
          (let ([ht (make-hash)]) (hash-set! ht 'x 1) ht))
-  (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
+  (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
                                                                      (hash-set! ht 1 #f)
                                                                      ht))
   (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t)