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

fix stronger for ->* when there are #:pre and #:post conditions specified

Browse Source
This commit is contained in:
Robby Findler 2013-07-11 06:22:31 -05:00
parent 402ddcbf1e
commit ad86a72143
2 changed files with 16 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -43,6 +43,13 @@
(let ([c (contract-eval '(->i () () any))]) (let ([c (contract-eval '(->i () () any))])
(test #t (contract-eval 'contract-stronger?) c c)) (test #t (contract-eval 'contract-stronger?) c c))
(ctest #f contract-stronger?
(->* () #:pre (zero? (random 10)) any)
(->* () #:pre (zero? (random 10)) any))
(ctest #f contract-stronger?
(->* () integer? #:post (zero? (random 10)))
(->* () integer? #:post (zero? (random 10))))
(ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
(ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
(ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))

10
racket/lib/collects/racket/contract/private/arrow.rkt
View File

@ -571,7 +571,15 @@
(andmap contract-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this)) (andmap contract-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this))
(= (length (base->-rngs/c that)) (length (base->-rngs/c this))) (= (length (base->-rngs/c that)) (length (base->-rngs/c this)))
(andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that)))) (andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that))
;; these procs might be based on state; only
;; allow stronger to be true when #:pre and
;; #:post aren't specified at all
(not (base->-pre this))
(not (base->-pre that))
(not (base->-post this))
(not (base->-post that))))
(define (->-generate ctc) (define (->-generate ctc)
(let ([doms-l (length (base->-doms/c ctc))]) (let ([doms-l (length (base->-doms/c ctc))])