diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index 5ad8a521f3..13177dc58c 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -322,6 +322,24 @@ ([p (in-list (cdr projs))]) (λ (v) (p (proj v)))))))) +(define (first-order-and-proj ctc) + (λ (blame) + (λ (val) + (let loop ([predicates (first-order-and/c-predicates ctc)] + [ctcs (base-and/c-ctcs ctc)]) + (cond + [(null? predicates) val] + [else + (if ((car predicates) val) + (loop (cdr predicates) (cdr ctcs)) + (raise-blame-error + blame + val + "expected <~s>, given ~a, which isn't ~s" + (contract-name ctc) + val + (contract-name (car ctcs))))]))))) + (define (and-stronger? this that) (and (base-and/c? that) (let ([this-ctcs (base-and/c-ctcs this)] @@ -332,6 +350,13 @@ that-ctcs))))) (define-struct base-and/c (ctcs)) +(define-struct (first-order-and/c base-and/c) (predicates) + #:property prop:flat-contract + (build-flat-contract-property + #:projection first-order-and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger?)) (define-struct (chaperone-and/c base-and/c) () #:property prop:chaperone-contract (build-chaperone-contract-property @@ -347,15 +372,14 @@ #:first-order and-first-order #:stronger and-stronger?)) + (define/subexpression-pos-prop (and/c . raw-fs) (let ([contracts (coerce-contracts 'and/c raw-fs)]) (cond [(null? contracts) any/c] [(andmap flat-contract? contracts) (let ([preds (map flat-contract-predicate contracts)]) - (flat-named-contract - (apply build-compound-type-name 'and/c contracts) - (λ (x) (for/and ([pred (in-list preds)]) (pred x)))))] + (make-first-order-and/c contracts preds))] [(andmap chaperone-contract? contracts) (make-chaperone-and/c contracts)] [else (make-impersonator-and/c contracts)]))) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index d4dbef0ea0..8e66ca0861 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -3533,6 +3533,18 @@ (reverse x)) '(3 1 2 4)) + (test/spec-passed/result + 'and/c-isnt + '(and (regexp-match #rx"isn't even?" + (with-handlers ((exn:fail? exn-message)) + (contract (and/c integer? even? positive?) + -3 + 'pos + 'neg) + "not the error!")) + #t) + #t) + (test/spec-passed 'contract-flat1 '(contract not #f 'pos 'neg))