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) (unless (or (contract? x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x 1))) (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) args)
(let-values ([(contract fc/predicates) (let-values ([(contract fc/predicates)
(let loop ([contract #f] (let loop ([contract #f]
@ -807,7 +807,7 @@ add struct contracts for immutable structs?
(not (contract? arg))) (not (contract? arg)))
(loop contract (cons arg fc/predicates) (cdr args))] (loop contract (cons arg fc/predicates) (cdr args))]
[contract [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 contract
arg)] arg)]
[else (loop arg fc/predicates (cdr args))]))]))]) [else (loop arg fc/predicates (cdr args))]))]))])
@ -820,7 +820,7 @@ add struct contracts for immutable structs?
[contract [contract
(let ([c-proc (contract-proc contract)]) (let ([c-proc (contract-proc contract)])
(make-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) (lambda (pos neg src-info orig-str)
(let ([partial-contract (c-proc pos neg src-info orig-str)]) (let ([partial-contract (c-proc pos neg src-info orig-str)])
(lambda (val) (lambda (val)
@ -831,7 +831,7 @@ add struct contracts for immutable structs?
(partial-contract val)]))))))] (partial-contract val)]))))))]
[else [else
(build-flat-contract (build-flat-contract
(apply build-compound-type-name 'union flat-contracts) (apply build-compound-type-name 'or/c flat-contracts)
(lambda (x) (lambda (x)
(ormap (lambda (pred) (pred x)) predicates)))])))) (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)))) (cf (lambda (x%) 'going-to-be-bad))))
(test/pos-blame (test/pos-blame
'union1 'or/c1
'(contract (union false/c) #t 'pos 'neg)) '(contract (or/c false/c) #t 'pos 'neg))
(test/spec-passed (test/spec-passed
'union2 'or/c2
'(contract (union false/c) #f 'pos 'neg)) '(contract (or/c false/c) #f 'pos 'neg))
(test/spec-passed (test/spec-passed
'union3 'or/c3
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
(test/neg-blame (test/neg-blame
'union4 'or/c4
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)) '((contract (or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f))
(test/pos-blame (test/pos-blame
'union5 'or/c5
'((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)) '((contract (or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1))
(test/spec-passed (test/spec-passed
'union6 'or/c6
'(contract (union false/c (-> integer? integer?)) #f 'pos 'neg)) '(contract (or/c false/c (-> integer? integer?)) #f 'pos 'neg))
(test/spec-passed (test/spec-passed
'union7 'or/c7
'((contract (union false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) '((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 (test/spec-passed
'define/contract1 'define/contract1
'(let () '(let ()
@ -3121,12 +3151,12 @@
;; ;; ;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test #t flat-contract? (union)) (test #t flat-contract? (or/c))
(test #t flat-contract? (union integer? (lambda (x) (> x 0)))) (test #t flat-contract? (or/c integer? (lambda (x) (> x 0))))
(test #t flat-contract? (union (flat-contract integer?) (test #t flat-contract? (or/c (flat-contract integer?)
(flat-contract boolean?))) (flat-contract boolean?)))
(test-flat-contract '(union (flat-contract integer?) char?) #\a #t) (test-flat-contract '(or/c (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?) 1 #t)
(test #t flat-contract? (and/c)) (test #t flat-contract? (and/c))
(test #t flat-contract? (and/c number? integer?)) (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 '(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-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)]) [even2 (cons/c number? even1)])
even1) even1)
'(1 2 3 4) '(1 2 3 4)
@ -3297,13 +3327,13 @@
(test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?)) (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
(case-> (-> integer? integer?) (-> integer? integer? integer?))) (case-> (-> integer? integer?) (-> integer? integer? integer?)))
(test-name '(union) (union)) (test-name '(or/c) (or/c))
(test-name '(union integer? gt0?) (union integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
(test-name '(union integer? boolean?) (test-name '(or/c integer? boolean?)
(union (flat-contract integer?) (or/c (flat-contract integer?)
(flat-contract boolean?))) (flat-contract boolean?)))
(test-name '(union (-> (>=/c 5) (>=/c 5)) boolean?) (test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(union (-> (>=/c 5) (>=/c 5)) boolean?)) (or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name 'any/c (and/c)) (test-name 'any/c (and/c))
(test-name '(and/c any/c) (and/c any/c)) (test-name '(and/c any/c) (and/c any/c))