diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 0edacb0257..9ec9181454 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -797,13 +797,22 @@ inspect the entire tree. @history[#:changed "6.0.1.6" @elem{Added @racket[#:inv].}] } -@defproc[(parameter/c [in contract?] [out contract? in]) +@defproc[(parameter/c [in contract?] + [out contract? in] + [#:impersonator? impersonator? any/c #t]) contract?]{ Produces a contract on parameters whose values must match @racket[_out]. When the value in the contracted parameter is set, it must match @racket[_in]. + If @racket[impersonator?] is a true value, then + @racket[parameter/c] always returns an @tech{impersonator + contract}. If it is @racket[#f], then the result will be a + @tech{chaperone contract} when both @racket[in] and + @racket[out] are @tech{chaperone contracts}, and an @tech{ + impersonator contract} otherwise. + @examples[#:eval (contract-eval) #:once (define/contract current-snack (parameter/c string?) diff --git a/pkgs/racket-test/tests/racket/contract/parameter.rkt b/pkgs/racket-test/tests/racket/contract/parameter.rkt index b70b0f15cf..a96ab1e63d 100644 --- a/pkgs/racket-test/tests/racket/contract/parameter.rkt +++ b/pkgs/racket-test/tests/racket/contract/parameter.rkt @@ -80,12 +80,26 @@ 'parameter/c11 '(chaperone-contract? (parameter/c integer?)) + #f) + + (test/spec-passed/result + 'parameter/c11b + '(chaperone-contract? + (parameter/c integer? + #:impersonator? #f)) #t) (test/spec-passed/result 'parameter/c12 '(chaperone-contract? (parameter/c (-> integer? integer?))) + #f) + + (test/spec-passed/result + 'parameter/c12b + '(chaperone-contract? + (parameter/c (-> integer? integer?) + #:impersonator? #f)) #t) (test/spec-passed/result @@ -111,7 +125,15 @@ (test/spec-passed/result 'parameter/c16 + '(chaperone-contract? + (parameter/c integer? + (-> integer? integer?) + #:impersonator? #f)) + #t) + + (test/spec-passed/result + 'parameter/c16b '(chaperone-contract? (parameter/c integer? (-> integer? integer?))) - #t)) + #f)) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index eeb5fb0619..b346c3737e 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -464,23 +464,21 @@ ;; (parameter/c in/out-ctc) ;; (parameter/c in-ctc out-ctc) -(define/subexpression-pos-prop parameter/c - (case-lambda - [(in-ctc) - (define ctc (coerce-contract 'parameter/c in-ctc)) - (cond - [(chaperone-contract? ctc) - (chaperone-parameter/c ctc #f)] - [else - (impersonator-parameter/c ctc #f)])] - [(in-ctc out-ctc) - (define in (coerce-contract 'parameter/c in-ctc)) - (define out (coerce-contract 'parameter/c out-ctc)) - (cond - [(and (chaperone-contract? in) (chaperone-contract? out)) - (chaperone-parameter/c in out)] - [else - (impersonator-parameter/c in out)])])) +(define unsupplied (gensym)) +(define/subexpression-pos-prop (parameter/c in [out unsupplied] #:impersonator? [impersonator? #t]) + (define ctc (coerce-contract 'parameter/c in)) + (define in-ctc (coerce-contract 'parameter/c in)) + (define out-ctc/f + (if (equal? out unsupplied) + #f + (coerce-contract 'parameter/c out))) + (cond + [(and (not impersonator?) + (chaperone-contract? in-ctc) + (or (not out-ctc/f) (chaperone-contract? out-ctc/f))) + (chaperone-parameter/c in-ctc out-ctc/f)] + [else + (impersonator-parameter/c in-ctc out-ctc/f)])) (define (parameter/c-lnp ctc) (define in-proc (get/build-late-neg-projection (base-parameter/c-in ctc)))