diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index aa5badbcea..53e4a6808d 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -236,7 +236,7 @@ (test-name '(/c 5) (>/c 5)) (test-name '(between/c 5 6) (between/c 5 6)) - (test-name '(between/c -inf.0 +inf.0) (between/c -inf.0 +inf.0)) + (test-name 'real? (between/c -inf.0 +inf.0)) (test-name '5 (between/c 5 5)) (test-name '(integer-in 0 10) (integer-in 0 10)) (test-name '(char-in #\a #\z) (char-in #\a #\z)) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 57f196708d..5bd1ae9e9a 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -20,6 +20,8 @@ (ctest #f contract-stronger? (char-in #\a #\z) (char-in #\f #\q)) (ctest #t contract-stronger? (between/c 1 3) (between/c 0 4)) (ctest #f contract-stronger? (between/c 0 4) (between/c 1 3)) + (ctest #t contract-stronger? (between/c -inf.0 +inf.0) real?) + (ctest #t contract-stronger? real? (between/c -inf.0 +inf.0)) (ctest #t contract-stronger? (>=/c 3) (>=/c 2)) (ctest #f contract-stronger? (>=/c 2) (>=/c 3)) (ctest #f contract-stronger? (<=/c 3) (<=/c 2)) @@ -280,6 +282,7 @@ (ctest #f contract-stronger? string? "x") (ctest #t contract-stronger? 1 real?) + (ctest #t contract-stronger? 1 (between/c -10 10)) (ctest #f contract-stronger? real? 1) (ctest #t contract-stronger? 'x symbol?) diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt index 587adc2825..7eb614e7c8 100644 --- a/racket/collects/racket/contract/combinator.rkt +++ b/racket/collects/racket/contract/combinator.rkt @@ -82,8 +82,6 @@ contract-custom-write-property-proc (rename-out [contract-custom-write-property-proc custom-write-property-proc]) - set-some-basic-contracts! - blame? blame-source blame-positive diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 2e6b454020..c5374ef753 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -70,7 +70,8 @@ contract-name maybe-warn-about-val-first - set-some-basic-contracts! + set-some-basic-list-contracts! + set-some-basic-misc-contracts! contract-first-order-okay-to-give-up? contract-first-order-try-less-hard @@ -294,18 +295,30 @@ (struct name-default ()) (values (name-default) name-default?))) -;; these two definitions work around a cyclic +;; these definitions work around a cyclic ;; dependency. When we coerce a value to a contract, ;; we want to use (listof any/c) for list?, but ;; the files are not set up for that, so we just ;; bang it in here and use it only after it's been banged in. +;; ditto for: (cons/c any/c any/c), (list/c), and (between/c -inf.0 +inf.0) +;; the selectors and predicate for `between/c-s` are used +;; to get contract-stronger right for numeric constants (define listof-any #f) (define consc-anyany #f) (define list/c-empty #f) -(define (set-some-basic-contracts! l p mt) +(define (set-some-basic-list-contracts! l p mt) (set! listof-any l) (set! consc-anyany p) (set! list/c-empty mt)) +(define between/c-inf+inf #f) +(define between/c-s? #f) +(define between/c-s-low #f) +(define between/c-s-high #f) +(define (set-some-basic-misc-contracts! b b/c-s? b/c-s-l b/c-s-h) + (set! between/c-inf+inf b) + (set! between/c-s? b/c-s?) + (set! between/c-s-low b/c-s-l) + (set! between/c-s-high b/c-s-h)) (define (coerce-contract/f x [name name-default]) (define (coerce-simple-value x) @@ -323,6 +336,10 @@ (unless consc-anyany (error 'coerce-contract/f::consc-anyany "too soon!")) consc-anyany] + [(chaperone-of? x real?) + (unless between/c-inf+inf + (error 'coerce-contract/f::between/c-inf+inf "too soon!")) + between/c-inf+inf] [else (make-predicate-contract (if (name-default? name) (or (object-name x) '???) @@ -544,6 +561,8 @@ (define this-val (=-contract-val this)) (or (and (=-contract? that) (= this-val (=-contract-val that))) + (and (between/c-s? that) + (<= (between/c-s-low that) this-val (between/c-s-high that))) (and (predicate-contract? that) (predicate-contract-sane? that) ((predicate-contract-pred that) this-val)))) diff --git a/racket/collects/racket/contract/private/list.rkt b/racket/collects/racket/contract/private/list.rkt index 2af97e4dad..d17dc8320b 100644 --- a/racket/collects/racket/contract/private/list.rkt +++ b/racket/collects/racket/contract/private/list.rkt @@ -987,8 +987,8 @@ (impersonator-*list/c (car ctcs) (cdr ctcs))])) ;; this is a hack to work around cyclic linking issues; -;; see definition of set-some-basic-contracts! -(set-some-basic-contracts! +;; see definition of set-some-basic-list-contracts! +(set-some-basic-list-contracts! (listof any/c) (cons/c any/c any/c) (list/c)) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 572e068f3e..c40f9c5a38 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -179,7 +179,7 @@ (define name (if (real-in-s? ctc) 'real-in 'between/c)) (cond [(and (= n -inf.0) (= m +inf.0)) - `(,name ,n ,m)] + 'real?] [(= n -inf.0) `(<=/c ,m)] [(= m +inf.0) `(>=/c ,n)] [(= n m) `(=/c ,n)] @@ -286,6 +286,11 @@ 1 arg1 arg2))) +(set-some-basic-misc-contracts! (between/c -inf.0 +inf.0) + between/c-s? + between/c-s-low + between/c-s-high) + (define (char-in a b) (check-two-args 'char-in a b char? char?) (char-in/c a b)) diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index a124c0ec30..51e7706796 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -201,11 +201,15 @@ [that that]) (syntax (<= this that)))))) #:chaperone #t - #:name #'(if (= n m) - n - '(between/c n m)))))))] + #:name #'(between/c-opt-name n m))))))] [_ (opt/unknown opt/i opt/info stx)])) +(define (between/c-opt-name n m) + (cond + [(= n m) n] + [(and (= n -inf.0) (= m +inf.0)) 'real?] + [else `(between/c ,n ,m)])) + (define (raise-opt-between/c-error blame val lo hi) (raise-blame-error blame