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

added tests for or/c ordering and and/c ordering and fixed name of the or/c contract (so it doesn't claim to be a union contract anymore)

Browse Source 
svn: r2100
This commit is contained in:
Robby Findler 2006-02-03 04:07:25 +00:00
parent 367c792141
commit 106c19a461
2 changed files with 60 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mzlib/private/contract.ss
View File

@ -792,7 +792,7 @@ add struct contracts for immutable structs?
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'union "expected procedures of arity 1 or contracts, given: ~e" x)))
(error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
args)
(let-values ([(contract fc/predicates)
(let loop ([contract #f]
@ -807,7 +807,7 @@ add struct contracts for immutable structs?
(not (contract? arg)))
(loop contract (cons arg fc/predicates) (cdr args))]
[contract
(error 'union "expected at most one non-flat contract, given ~e and ~e"
(error 'or/c "expected at most one non-flat contract, given ~e and ~e"
contract
arg)]
[else (loop arg fc/predicates (cdr args))]))]))])
@ -820,7 +820,7 @@ add struct contracts for immutable structs?
[contract
(let ([c-proc (contract-proc contract)])
(make-contract
(apply build-compound-type-name 'union contract flat-contracts)
(apply build-compound-type-name 'or/c contract flat-contracts)
(lambda (pos neg src-info orig-str)
(let ([partial-contract (c-proc pos neg src-info orig-str)])
(lambda (val)
@ -831,7 +831,7 @@ add struct contracts for immutable structs?
(partial-contract val)]))))))]
[else
(build-flat-contract
(apply build-compound-type-name 'union flat-contracts)
(apply build-compound-type-name 'or/c flat-contracts)
(lambda (x)
(ormap (lambda (pred) (pred x)) predicates)))]))))

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

@ -1222,33 +1222,63 @@
(cf (lambda (x%) 'going-to-be-bad))))
(test/pos-blame
'union1
'(contract (union false/c) #t 'pos 'neg))
'or/c1
'(contract (or/c false/c) #t 'pos 'neg))
(test/spec-passed
'union2
'(contract (union false/c) #f 'pos 'neg))
'or/c2
'(contract (or/c false/c) #f 'pos 'neg))
(test/spec-passed
'union3
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
'or/c3
'((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
(test/neg-blame
'union4
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f))
'or/c4
'((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f))
(test/pos-blame
'union5
'((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1))
'or/c5
'((contract (or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1))
(test/spec-passed
'union6
'(contract (union false/c (-> integer? integer?)) #f 'pos 'neg))
'or/c6
'(contract (or/c false/c (-> integer? integer?)) #f 'pos 'neg))
(test/spec-passed
'union7
'((contract (union false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
'or/c7
'((contract (or/c false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
(test
'(1 2)
'or/c-ordering
(let ([x '()])
(contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
'anything
'pos
'neg)
x))
(test
'(2)
'or/c-ordering2
(let ([x '()])
(contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
'anything
'pos
'neg)
x))
(test
'(1 2)
'and/c-ordering
(let ([x '()])
(contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
'anything
'pos
'neg)
x))
(test/spec-passed
'define/contract1
'(let ()
@ -3121,12 +3151,12 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test #t flat-contract? (union))
(test #t flat-contract? (union integer? (lambda (x) (> x 0))))
(test #t flat-contract? (union (flat-contract integer?)
(test #t flat-contract? (or/c))
(test #t flat-contract? (or/c integer? (lambda (x) (> x 0))))
(test #t flat-contract? (or/c (flat-contract integer?)
(flat-contract boolean?)))
(test-flat-contract '(union (flat-contract integer?) char?) #\a #t)
(test-flat-contract '(union (flat-contract integer?) char?) 1 #t)
(test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t)
(test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t)
(test #t flat-contract? (and/c))
(test #t flat-contract? (and/c number? integer?))
@ -3198,7 +3228,7 @@
(test-flat-contract '(box/c (flat-contract boolean?)) (box #t) #f)
(test-flat-contract '(flat-rec-contract sexp (cons/c sexp sexp) number?) '(1 2 . 3) '(1 . #f))
(test-flat-contract '(flat-murec-contract ([even1 (union null? (cons/c number? even2))]
(test-flat-contract '(flat-murec-contract ([even1 (or/c null? (cons/c number? even2))]
[even2 (cons/c number? even1)])
even1)
'(1 2 3 4)
@ -3297,13 +3327,13 @@
(test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
(case-> (-> integer? integer?) (-> integer? integer? integer?)))
(test-name '(union) (union))
(test-name '(union integer? gt0?) (union integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
(test-name '(union integer? boolean?)
(union (flat-contract integer?)
(test-name '(or/c) (or/c))
(test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
(test-name '(or/c integer? boolean?)
(or/c (flat-contract integer?)
(flat-contract boolean?)))
(test-name '(union (-> (>=/c 5) (>=/c 5)) boolean?)
(union (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name 'any/c (and/c))
(test-name '(and/c any/c) (and/c any/c))