diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index ccb1991c26..dec48b2016 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -49,7 +49,8 @@ (except-out (all-from-out "private/misc.rkt") check-between/c check-unary-between/c - random-any/c) + random-any/c + maybe-warn-about-val-first) symbols or/c first-or/c one-of/c flat-rec-contract provide/contract diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index b97fae4a79..ba5eddfa20 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -193,6 +193,7 @@ #:val-first-projection (λ (ctc) (define blame-accepting-proj (arr->i-late-neg-proj ctc c-or-i-procedure)) + (maybe-warn-about-val-first ctc) (λ (blame) (define val+neg-party-accepting-proj (blame-accepting-proj blame)) (λ (val) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 046750d58b..f8c0e94f40 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -1152,6 +1152,7 @@ (define (make-property build-X-property chaperone-or-impersonate-procedure) (define val-first-proj (λ (->stct) + (maybe-warn-about-val-first ->stct) (->-proj chaperone-or-impersonate-procedure ->stct (base->-min-arity ->stct) (base->-doms ->stct) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 5d6bdc6726..7cd5432198 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -68,7 +68,9 @@ random-any/c rename-contract - if/c) + if/c + + maybe-warn-about-val-first) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -2108,15 +2110,18 @@ x))))) (define warn-about-val-first? (make-parameter #t)) +(define (maybe-warn-about-val-first ctc) + (when (warn-about-val-first?) + (log-racket/contract-warning + "building val-first-projection of contract ~s for~a" + ctc + (build-context)))) + (define (get/build-val-first-projection ctc) (cond [(contract-struct-val-first-projection ctc) => values] [else - (when (warn-about-val-first?) - (log-racket/contract-warning - "building val-first-projection of contract ~s for~a" - ctc - (build-context))) + (maybe-warn-about-val-first ctc) (late-neg-projection->val-first-projection (get/build-late-neg-projection ctc))])) (define (late-neg-projection->val-first-projection lnp)