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

fix contract random generation for -> when the range is 'any'

Browse Source
This commit is contained in:
Robby Findler 2014-07-29 09:37:05 -05:00
parent a3c7c557ea
commit 7472058fd9
2 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
View File

@ -84,6 +84,10 @@
(check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0))) (check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
(check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1))) (check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1)))
(check-not-exn (λ () ((test-contract-generation (-> integer? any)) 1)))
(check-not-exn (λ () ((test-contract-generation (-> integer? (-> integer? any))) 1)))
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? any) integer?))
(λ (i) (values 1 2 3)))))
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +))) (check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
(check-not-exn (check-not-exn
(λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11))) (λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11)))

21
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -723,11 +723,13 @@
(set! dom-exers (cons exer dom-exers)) (set! dom-exers (cons exer dom-exers))
(set! addl-available (append ctcs addl-available))) (set! addl-available (append ctcs addl-available)))
(define rngs-gens (define rngs-gens
(with-definitely-available-contracts (if (base->-rngs ctc)
addl-available (with-definitely-available-contracts
(λ () addl-available
(for/list ([c (in-list (base->-rngs ctc))]) (λ ()
(generate/choose c fuel))))) (for/list ([c (in-list (base->-rngs ctc))])
(generate/choose c fuel))))
'()))
(cond (cond
[(for/and ([rng-gen (in-list rngs-gens)]) [(for/and ([rng-gen (in-list rngs-gens)])
rng-gen) rng-gen)
@ -787,10 +789,11 @@
(for/list ([gen (in-list gens)]) (for/list ([gen (in-list gens)])
(gen)))) (gen))))
(λ results (λ results
(for ([res-ctc (in-list rng-ctcs)] (when rng-ctcs
[result (in-list results)]) (for ([res-ctc (in-list rng-ctcs)]
(env-stash env res-ctc result))))) [result (in-list results)])
(base->-rngs ctc))] (env-stash env res-ctc result))))))
(or rng-ctcs '()))]
[else [else
(values void '())]))] (values void '())]))]
[else [else