diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 7cd5432198..890649d25d 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -2147,13 +2147,6 @@ (λ (x) (val+np-acceptor x #f)))) -(define (build-context) - (apply - string-append - (for/list ([i (in-list (continuation-mark-set->context - (current-continuation-marks)))]) - (format "\n ~s" i)))) - (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-named-contract name pre-contract [generate #f]) (cond diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index 61c90bf389..ea451a3e3b 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -50,7 +50,9 @@ prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info - (struct-out arrow-contract-info)) + (struct-out arrow-contract-info) + + build-context) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -253,6 +255,8 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-logger racket/contract) + (define ((build-property mk default-name proc-name first-order?) #:name [get-name #f] #:first-order [get-first-order #f] @@ -272,7 +276,14 @@ (string-append "expected either the #:get-projection, #:val-first-project, or #:late-neg-projection" " to not be #f, but all three were #f"))) - + + (unless get-late-neg-projection + (unless first-order? + (log-racket/contract-warning + "no late-neg-projection passed to ~s~a" + proc-name + (build-context)))) + (mk (or get-name (λ (c) default-name)) (or get-first-order get-any?) get-projection @@ -289,6 +300,13 @@ [else get-late-neg-projection]) list-contract?)) +(define (build-context) + (apply + string-append + (for/list ([i (in-list (continuation-mark-set->context + (current-continuation-marks)))]) + (format "\n ~s" i)))) + (define build-contract-property (procedure-rename (build-property make-contract-property 'anonymous-contract 'build-contract-property #f) @@ -410,7 +428,7 @@ #:exercise (lambda (c) (make-flat-contract-exercise c)) #:list-contract? (λ (c) (make-flat-contract-list-contract? c)))) -(define ((build-contract mk default-name) +(define ((build-contract mk default-name proc-name) #:name [name #f] #:first-order [first-order #f] #:projection [projection #f] @@ -421,6 +439,12 @@ #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (ctc) #f)]) + (unless late-neg-projection + (log-racket/contract-warning + "no late-neg-projection passed to ~s~a" + proc-name + (build-context))) + (mk (or name default-name) (or first-order any?) projection val-first-projection late-neg-projection @@ -447,17 +471,21 @@ (define make-contract (procedure-rename - (build-contract make-make-contract 'anonymous-contract) + (build-contract make-make-contract 'anonymous-contract 'make-contract) 'make-contract)) (define make-chaperone-contract (procedure-rename - (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract) + (build-contract make-make-chaperone-contract + 'anonymous-chaperone-contract + 'make-chaperone-contract) 'make-chaperone-contract)) (define make-flat-contract (procedure-rename - (build-contract make-make-flat-contract 'anonymous-flat-contract) + (build-contract make-make-flat-contract + 'anonymous-flat-contract + 'make-flat-contract) 'make-flat-contract)) ;; property should be bound to a function that accepts the contract and