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

fix random contract generation for </c and >/c when they get +inf.0 or -inf.0

Browse Source
This commit is contained in:
Robby Findler 2018-06-07 08:48:26 -05:00
parent c6dd371ed6
commit aabd0e4603
2 changed files with 35 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test/tests/racket/contract/random-generate.rkt
View File

@ -59,8 +59,10 @@
(check-not-exn (λ () (test-contract-generation (<=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (>/c 0))))
(check-not-exn (λ () (test-contract-generation (>/c 0.0))))
(check-not-exn (λ () (test-contract-generation (>/c -inf.0))))
(check-not-exn (λ () (test-contract-generation (</c 0))))
(check-not-exn (λ () (test-contract-generation (</c 0.0))))
(check-not-exn (λ () (test-contract-generation (</c +inf.0))))
(check-not-exn (λ () (test-contract-generation (=/c 0))))
(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))

40
racket/collects/racket/contract/private/misc.rkt
View File

@ -257,13 +257,39 @@
#:generate
(λ (ctc)
(define x (</>-ctc-x ctc))
(λ (fuel)
(λ ()
(rand-choice
[1/10 (-/+ +inf.0)]
[1/10 (-/+ x 0.01)]
[4/10 (-/+ x (random))]
[else (-/+ x (random 4294967087))]))))
(cond
[(and (= x +inf.0) (equal? name '</c))
(λ (fuel)
(λ ()
(rand-choice
[1/10 -inf.0]
[2/10 (random)]
[2/10 (- (random))]
[2/10 (random 4294967087)]
[2/10 (- (random 4294967087))]
[else 0])))]
[(and (= x -inf.0) (equal? name '</c))
(λ (fuel) #f)]
[(and (= x +inf.0) (equal? name '>/c))
(λ (fuel) #f)]
[(and (= x -inf.0) (equal? name '>/c))
(λ (fuel)
(λ ()
(rand-choice
[1/10 +inf.0]
[2/10 (random)]
[2/10 (- (random))]
[2/10 (random 4294967087)]
[2/10 (- (random 4294967087))]
[else 0])))]
[else
(λ (fuel)
(λ ()
(rand-choice
[1/10 (-/+ +inf.0)]
[1/10 (-/+ x 0.01)]
[4/10 (-/+ x (random))]
[else (-/+ x (random 4294967087))])))]))
#:stronger </>-ctc-stronger
#:equivalent </>-ctc-equivalent))