diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index b711c42992..2211802533 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -58,6 +58,11 @@ (test-flat-contract '(and/c real? positive?) 1 0) (test-flat-contract '(and/c real? (not/c positive?)) 0 1) (test-flat-contract '(and/c real? (not/c negative?)) 0 -1) + + (test-flat-contract '(and/c (flat-named-contract 'Real real?) negative?) -1 0) + (test-flat-contract '(and/c (flat-named-contract 'Real real?) positive?) 1 0) + (test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c positive?)) 0 1) + (test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c negative?)) 0 -1) (test-flat-contract #t #t "x") (test-flat-contract #f #f "x") diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index cd80deca1c..d2322bb92b 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -56,6 +56,7 @@ (flat-named-contract 'mumble (and/c frotz/c (not/c bazzle/c))))) + (test-name 'Real (flat-named-contract 'Real real?)) (test-name '(-> integer? integer?) (-> integer? integer?)) diff --git a/racket/collects/racket/contract/private/basic-opters.rkt b/racket/collects/racket/contract/private/basic-opters.rkt index 4814d07419..5a4b5e90db 100644 --- a/racket/collects/racket/contract/private/basic-opters.rkt +++ b/racket/collects/racket/contract/private/basic-opters.rkt @@ -34,11 +34,11 @@ ;; ;; flat-contract helper ;; -(define-for-syntax (opt/flat-ctc opt/info pred checker) +(define-for-syntax (opt/flat-ctc opt/info pred checker name) (syntax-case pred (null? number? integer? boolean? string? pair? not) ;; Better way of doing this? [pred - (let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) + (let* ((lift-vars (generate-temporaries (syntax (pred error-check the-name)))) (lift-pred (car lift-vars))) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) @@ -56,22 +56,25 @@ #:lifts (interleave-lifts lift-vars - (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] - [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]))) + (list #'pred + (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] + [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]) + (or name #'(object-name lift-pred)))) #:superlifts null #:partials null #:flat (syntax (lift-pred val)) #:opt #f #:stronger-ribs null #:chaperone #t - #:name #'(object-name lift-pred))))])) + #:name (list-ref lift-vars 2))))])) ;; ;; flat-contract and flat-named-contract ;; (define/opter (flat-contract opt/i opt/info stx) (syntax-case stx (flat-contract) - [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)])) + [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract #f)])) (define/opter (flat-named-contract opt/i opt/info stx) (syntax-case stx (flat-named-contract) - [(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)])) + [(flat-named-contract name pred) + (opt/flat-ctc opt/info #'pred 'check-flat-named-contract #'name)])) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index c5374ef753..e23557d351 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -311,11 +311,13 @@ (set! consc-anyany p) (set! list/c-empty mt)) (define between/c-inf+inf #f) +(define renamed-between/c #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) +(define (set-some-basic-misc-contracts! b r-b b/c-s? b/c-s-l b/c-s-h) (set! between/c-inf+inf b) + (set! renamed-between/c r-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)) @@ -339,7 +341,9 @@ [(chaperone-of? x real?) (unless between/c-inf+inf (error 'coerce-contract/f::between/c-inf+inf "too soon!")) - between/c-inf+inf] + (if (name-default? name) + between/c-inf+inf + (renamed-between/c -inf.0 +inf.0 name))] [else (make-predicate-contract (if (name-default? name) (or (object-name x) '???) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 82ca98f8f9..44cf222240 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -178,10 +178,12 @@ (λ (ctc) (define n (between/c-s-low ctc)) (define m (between/c-s-high ctc)) - (define name (if (real-in-s? ctc) 'real-in 'between/c)) + (define name (if (renamed-between/c? ctc) (renamed-between/c-name ctc) 'between/c)) (cond [(and (= n -inf.0) (= m +inf.0)) - 'real?] + (if (renamed-between/c? ctc) + (renamed-between/c-name ctc) + 'real?)] [(= n -inf.0) (if (= m 0) `(and/c real? (not/c positive?)) `(<=/c ,m))] [(= m +inf.0) (if (= n 0) `(and/c real? (not/c negative?)) `(>=/c ,n))] [(= n m) `(=/c ,n)] @@ -189,7 +191,7 @@ #:stronger between/c-stronger #:first-order between/c-first-order #:generate between/c-generate)) -(define-struct (real-in-s between/c-s) ()) +(define-struct (renamed-between/c between/c-s) (name)) (define (maybe-neg n) (rand-choice [1/2 n] [else (- n)])) @@ -294,6 +296,7 @@ arg1 arg2))) (set-some-basic-misc-contracts! (between/c -inf.0 +inf.0) + renamed-between/c between/c-s? between/c-s-low between/c-s-high) @@ -304,7 +307,7 @@ (define/final-prop (real-in start end) (check-two-args 'real-in start end real? real?) - (make-real-in-s start end)) + (make-renamed-between/c start end 'real-in)) (define/final-prop (not/c f) (let* ([ctc (coerce-flat-contract 'not/c f)]