diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 715a055..85e6c68 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -2434,7 +2434,7 @@ add struct contracts for immutable structs? union and/c not/f - >=/c <=/c /c + =/c >=/c <=/c /c integer-in real-in natural-number? @@ -2625,6 +2625,10 @@ add struct contracts for immutable structs? (and (box? x) (printable? (unbox x)))))))) + (define (=/c x) + (flat-named-contract + (format "(=/c ~a)" x) + (lambda (y) (and (number? y) (= y x))))) (define (>=/c x) (flat-named-contract (format "(>=/c ~a)" x) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 523c0dd..69c3d36 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2193,6 +2193,15 @@ 'pos 'neg)]) (for-each (lambda (x) (x 1)) ctc))) + + (test/spec-passed/result + 'immutable20 + '(let ([ctc (contract (list-immutable/c number?) + (list-immutable 1) + 'pos + 'neg)]) + (immutable? ctc)) + #t) (test/pos-blame 'vector-immutable1 @@ -2276,6 +2285,14 @@ 'pos 'neg) (vector->immutable-vector (vector 1 #t))) + + (test/spec-passed/result + 'vector-immutable12 + '(immutable? (contract (vector-immutable/c number? boolean?) + (vector->immutable-vector (vector 1 #t)) + 'pos + 'neg)) + #t) (test/pos-blame 'box-immutable1 @@ -2316,12 +2333,20 @@ ((unbox ctc) 1))) (test/spec-passed/result - 'vector-immutable6 + 'box-immutable6 '(contract (box-immutable/c boolean?) (box-immutable #t) 'pos 'neg) (box-immutable #t)) + + (test/spec-passed/result + 'box-immutable7 + '(immutable? (contract (box-immutable/c boolean?) + (box-immutable #t) + 'pos + 'neg)) + #t) (test/spec-passed @@ -2374,6 +2399,7 @@ (test-flat-contract '(and/c number? integer?) 1 3/2) (test-flat-contract '(not/f integer?) #t 1) + (test-flat-contract '(=/c 2) 2 3) (test-flat-contract '(>=/c 5) 5 0) (test-flat-contract '(<=/c 5) 5 10) (test-flat-contract '( integer? integer?))" (and/c number? (-> integer? integer?))) (test-name "(not/f integer?)" (not/f integer?)) + (test-name "(=/c 5)" (=/c 5)) (test-name "(>=/c 5)" (>=/c 5)) (test-name "(<=/c 5)" (<=/c 5)) (test-name "(