From 6cd4b0009b782b23317a5ff7b19def7da05e5f96 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 20 Jun 2006 20:49:18 +0000
Subject: [PATCH] generalized and/c

svn: r3422
---
 collects/mzlib/private/contract-guts.ss  |  9 +-------
 collects/tests/mzscheme/contract-test.ss | 28 ++++++++++++++++++++++++
 2 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss
index f1416a49b9..79150114ba 100644
--- a/collects/mzlib/private/contract-guts.ss
+++ b/collects/mzlib/private/contract-guts.ss
@@ -405,16 +405,9 @@
 			    (cdr preds)))]))])
 	 (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
       [else
-       (let* ([non-flats (filter (λ (x) 
-                                   (and (not (procedure? x))
-                                        (not (flat-contract? x))))
-                                 fs)]
-              [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
+       (let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
               [pos-contract/procs (map contract-pos-proc contracts)]
               [neg-contract/procs (map contract-neg-proc contracts)])
-         (unless (or (null? non-flats)
-                     (null? (cdr non-flats)))
-           (error 'and/c "expected at most one non-flat contract as argument"))
 	 (make-pair-proj-contract
           (apply build-compound-type-name 'and/c contracts)
           (lambda (blame src-info orig-str)
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index d9a86d32bb..e96cfe5035 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -532,6 +532,33 @@
               'pos
               'neg))
   
+  (test/spec-passed
+   'and/c1
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   'and/c2
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) x)
+               'pos
+               'neg)
+     200))
+  
+  (test/pos-blame
+   'and/c3
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) 200)
+               'pos
+               'neg)
+     1))
+  
   (test/spec-passed
    '->r1
    '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
@@ -3958,6 +3985,7 @@
   (test-name '(and/c number? integer?) (and/c (flat-contract number?)
                                               (flat-contract integer?)))
   (test-name '(and/c number? (-> integer? integer?)) (and/c number? (-> integer? integer?)))
+  (test-name '(and/c (-> boolean? boolean?) (-> integer? integer?)) (and/c (-> boolean? boolean?) (-> integer? integer?)))
 
   (test-name '(not/c integer?) (not/c integer?))
   (test-name '(=/c 5) (=/c 5))