suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PR 10636

Browse Source 
svn: r17163
This commit is contained in:
Robby Findler 2009-12-02 17:09:07 +00:00
parent ac1f4171fa
commit 61da010d5f
2 changed files with 14 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/scheme/contract/private/guts.ss
View File

@ -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

6
collects/tests/mzscheme/contract-test.ss
View File

@ -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)))
;
;