From eb7c6653f32fcc2e71ad16e9fa393787227ca104 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 23 Jan 2015 22:25:57 -0600 Subject: [PATCH] make the contract random generator sometimes generate inexact/exact variants of numbers when the exact/inexact one was originally present in the contract --- .../tests/racket/contract-rand-test.rkt | 5 +++++ racket/collects/racket/contract/private/guts.rkt | 15 ++++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-test/tests/racket/contract-rand-test.rkt index dbfe9e104f..e1dd4e986b 100644 --- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -26,7 +26,12 @@ (check-not-exn (λ () (test-contract-generation natural-number/c))) ;; test =, eq?, and equal? contract random generators +(check-not-exn (λ () (test-contract-generation 1/2))) +(check-not-exn (λ () (test-contract-generation 1/3))) (check-not-exn (λ () (test-contract-generation 0))) +(check-not-exn (λ () (test-contract-generation 1))) +(check-not-exn (λ () (test-contract-generation 1.0))) +(check-not-exn (λ () (test-contract-generation (expt 10 200)))) (check-not-exn (λ () (test-contract-generation +nan.0))) (check-not-exn (λ () (test-contract-generation 'x))) (check-not-exn (λ () (test-contract-generation "x"))) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index be8228ec1b..d89ca065b6 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -445,7 +445,20 @@ #:generate (λ (ctc) (define v (=-contract-val ctc)) - (λ (fuel) (λ () v))))) + (λ (fuel) + (λ () + (case (random 5) + [(0) (cond + [(exact? v) + (define iv (exact->inexact v)) + (if (= iv v) iv v)] + [(and (inexact? v) + (not (memv v '(+inf.0 -inf.0 +inf.f -inf.f + nan.0 nan.f)))) + (define ev (inexact->exact v)) + (if (= ev v) ev v)] + [else v])] + [else v])))))) (define-struct regexp/c (reg name) #:property prop:custom-write contract-custom-write-property-proc