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

.

Browse Source 
original commit: 9f5607cbe061edfbe2bcba2fec33303f6cbc25d4
This commit is contained in:
Robby Findler 2004-06-21 03:43:24 +00:00
parent 4828f4378a
commit af2420010d
2 changed files with 33 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mzlib/contract.ss
View File

@ -2434,7 +2434,7 @@ add struct contracts for immutable structs?
union union
and/c and/c
not/f not/f
>=/c <=/c </c >/c =/c >=/c <=/c </c >/c
integer-in integer-in
real-in real-in
natural-number? natural-number?
@ -2625,6 +2625,10 @@ add struct contracts for immutable structs?
(and (box? x) (and (box? x)
(printable? (unbox x)))))))) (printable? (unbox x))))))))
(define (=/c x)
(flat-named-contract
(format "(=/c ~a)" x)
(lambda (y) (and (number? y) (= y x)))))
(define (>=/c x) (define (>=/c x)
(flat-named-contract (flat-named-contract
(format "(>=/c ~a)" x) (format "(>=/c ~a)" x)

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

@ -2194,6 +2194,15 @@
'neg)]) 'neg)])
(for-each (lambda (x) (x 1)) ctc))) (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 (test/pos-blame
'vector-immutable1 'vector-immutable1
'(contract (vector-immutableof (boolean? . -> . boolean?)) '(contract (vector-immutableof (boolean? . -> . boolean?))
@ -2277,6 +2286,14 @@
'neg) 'neg)
(vector->immutable-vector (vector 1 #t))) (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 (test/pos-blame
'box-immutable1 'box-immutable1
'(contract (box-immutable/c (number? . -> . boolean?)) '(contract (box-immutable/c (number? . -> . boolean?))
@ -2316,13 +2333,21 @@
((unbox ctc) 1))) ((unbox ctc) 1)))
(test/spec-passed/result (test/spec-passed/result
'vector-immutable6 'box-immutable6
'(contract (box-immutable/c boolean?) '(contract (box-immutable/c boolean?)
(box-immutable #t) (box-immutable #t)
'pos 'pos
'neg) 'neg)
(box-immutable #t)) (box-immutable #t))
(test/spec-passed/result
'box-immutable7
'(immutable? (contract (box-immutable/c boolean?)
(box-immutable #t)
'pos
'neg))
#t)
(test/spec-passed (test/spec-passed
'anaphoric1 'anaphoric1
@ -2374,6 +2399,7 @@
(test-flat-contract '(and/c number? integer?) 1 3/2) (test-flat-contract '(and/c number? integer?) 1 3/2)
(test-flat-contract '(not/f integer?) #t 1) (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 0)
(test-flat-contract '(<=/c 5) 5 10) (test-flat-contract '(<=/c 5) 5 10)
(test-flat-contract '(</c 5) 0 5) (test-flat-contract '(</c 5) 0 5)
@ -2524,6 +2550,7 @@
(test-name "(and/c number? (-> integer? integer?))" (and/c number? (-> integer? integer?))) (test-name "(and/c number? (-> integer? integer?))" (and/c number? (-> integer? integer?)))
(test-name "(not/f integer?)" (not/f 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 "(<=/c 5)" (<=/c 5)) (test-name "(<=/c 5)" (<=/c 5))
(test-name "(</c 5)" (</c 5)) (test-name "(</c 5)" (</c 5))