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

add box/c stronger

Browse Source
This commit is contained in:
Robby Findler 2014-09-23 12:52:51 -05:00
parent 5da7104829
commit ac9b1cd05b
2 changed files with 32 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -183,6 +183,16 @@
(ctest #t contract-stronger? (vector/c (<=/c 2) #:immutable #t) (vector/c (<=/c 3) #:immutable #t))
(ctest #f contract-stronger? (vector/c (<=/c 3) #:immutable #t) (vector/c (<=/c 2) #:immutable #t))
(ctest #t contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3)))
(ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 2)))
(ctest #f contract-stronger? (box/c (<=/c 2)) (box/c (<=/c 3)))
(ctest #t contract-stronger? (box/c (<=/c 2) #:immutable #t) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-stronger? (box/c (<=/c 3) #:immutable #t) (box/c (<=/c 2) #:immutable #t))
(ctest #t contract-stronger? (box/c (<=/c 3) #:immutable #t) (box/c (<=/c 3)))
(ctest #t contract-stronger? (box/c (<=/c 3) #:immutable #f) (box/c (<=/c 3)))
(ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #f))
(contract-eval
`(let ()
(define x (flat-rec-contract x (or/c (cons/c x '()) '())))

22
racket/collects/racket/contract/private/box.rkt
View File

@ -85,12 +85,32 @@
(define (add-box-context blame)
(blame-add-context blame "the content of"))
(define (box/c-stronger this that)
(define this-content (base-box/c-content this))
(define this-immutable (base-box/c-immutable this))
(cond
[(base-box/c? that)
(define that-content (base-box/c-content that))
(define that-immutable (base-box/c-immutable that))
(cond
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(contract-stronger? this-content that-content)]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (contract-stronger? this-content that-content)
(contract-stronger? that-content this-content))]
[else #f])]
[else #f]))
(define-struct (flat-box/c base-box/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:val-first-projection
(λ (ctc)
(define content-ctc (get/build-val-first-projection (base-box/c-content ctc)))
@ -155,6 +175,7 @@
(build-chaperone-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:val-first-projection (ho-val-first-projection chaperone-box)
#:projection (ho-projection chaperone-box)))
@ -164,6 +185,7 @@
(build-contract-property
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:val-first-projection (ho-val-first-projection impersonate-box)
#:projection (ho-projection impersonate-box)))