From 106c19a461417784805f1378b2171360165c3c2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 3 Feb 2006 04:07:25 +0000 Subject: [PATCH] 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) svn: r2100 --- collects/mzlib/private/contract.ss | 8 +-- collects/tests/mzscheme/contract-test.ss | 82 ++++++++++++++++-------- 2 files changed, 60 insertions(+), 30 deletions(-) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 233cf8e1fa..d229eb48ba 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -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)))])))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 7b393295ba..0272e46239 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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))