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

generalized and/c

Browse Source 
svn: r3422
This commit is contained in:
Robby Findler 2006-06-20 20:49:18 +00:00
parent 3fbf9212fe
commit 6cd4b0009b
2 changed files with 29 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/mzlib/private/contract-guts.ss
View File

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

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

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