From 61da010d5f61abda44f375523955e260544a08f2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 2 Dec 2009 17:09:07 +0000 Subject: [PATCH] PR 10636 svn: r17163 --- collects/scheme/contract/private/guts.ss | 10 ++++++++-- collects/tests/mzscheme/contract-test.ss | 6 ++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index 96e85aac05..cf5e50b4f6 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -66,9 +66,14 @@ (define-values (flat-prop flat-pred? flat-get) (make-struct-type-property 'contract-flat)) -(define-values (first-order-prop first-order-pred? first-order-get) +(define-values (first-order-prop first-order-pred? raw-first-order-get) (make-struct-type-property 'contract-first-order)) +(define (first-order-get stct) + (cond + [(flat-pred? stct) (flat-get stct)] + [else (raw-first-order-get stct)])) + (define (contract-first-order-passes? c v) (let ([ctc (coerce-contract 'contract-first-order-passes? c)]) (cond @@ -404,7 +409,8 @@ #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))) #:property first-order-prop (λ (ctc) - (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))]) + (let ([tests (map (λ (x) ((first-order-get x) x)) + (and/c-ctcs ctc))]) (λ (x) (andmap (λ (f) (f x)) tests)))) #:property stronger-prop diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 3de105d6a2..2769651825 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2060,6 +2060,12 @@ x) '(2)) + (test/spec-passed + 'or/c-hmm + (let ([funny/c (or/c (and/c procedure? (-> any)) (listof (-> number?)))]) + (contract (-> funny/c any) void 'pos 'neg))) + + ; ;