diff --git a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt index c4ddb65b5d..ec265ffe51 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt @@ -17,7 +17,19 @@ (test/spec-passed '->d1 '((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))) - + + (test/spec-passed/result + '->d1a + '(and (value-contract (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg)) + #t) + #t) + + (test/spec-passed/result + '->d1b + '(and (value-blame (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg)) + #t) + #t) + (test/spec-passed '->d2 '((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1)) diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index b98417602f..bb9b7c0d7f 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -250,6 +250,12 @@ integer?) (lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg)) + (test/spec-passed/result + 'contract-arrow1c + '(and (value-contract (contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg)) + #t) + #t) + (test/pos-blame 'contract-arrow2 '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)) @@ -286,6 +292,12 @@ (test/neg-blame 'contract-arrow-any3 '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) + + (test/spec-passed/result + 'contract-arrow-any4 + '(and (value-contract (contract (-> integer? any) (lambda (x) x) 'pos 'neg)) + #t) + #t) (test/spec-passed 'contract-arrow-all-anys1 @@ -484,6 +496,11 @@ (struct s ()) ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11)) 'pos 'neg)) + (test/spec-passed/result + 'predicate/c15 + '(and (value-contract (contract predicate/c boolean? 'pos 'neg)) + #t) + #t) (test/spec-passed/result '->void.1 diff --git a/pkgs/racket-test/tests/racket/contract/evt.rkt b/pkgs/racket-test/tests/racket/contract/evt.rkt index 0d624301d9..f351f8d2e4 100644 --- a/pkgs/racket-test/tests/racket/contract/evt.rkt +++ b/pkgs/racket-test/tests/racket/contract/evt.rkt @@ -11,6 +11,12 @@ 'evt/c-first-order-2 '(contract (evt/c) always-evt 'pos 'neg)) + (test/spec-passed/result + 'evt/c-first-order-3 + '(and (value-contract (contract (evt/c) always-evt 'pos 'neg)) + #t) + #t) + (test/pos-blame 'evt/c-higher-order-1 '(let ([evt (contract (evt/c symbol?) diff --git a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt index ca5f93fe63..3d102eb163 100644 --- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt +++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt @@ -15,6 +15,28 @@ 'pos 'neg))) + (test/spec-passed/result + 'struct/c1a + '(let () + (define-struct s (a)) + (and (value-contract (contract (struct/c s (or/c number? (-> void?))) ; want non-flat + (make-s 1) + 'pos + 'neg)) + #t)) + #t) + + (test/spec-passed/result + 'struct/c1b + '(let () + (define-struct s (a)) + (and (value-blame (contract (struct/c s (or/c number? (-> void?))) ; want non-flat + (make-s 1) + 'pos + 'neg)) + #t)) + #t) + (test/pos-blame 'struct/c2 '(let () @@ -240,6 +262,32 @@ (s 1 #f) 'pos 'neg))) + + (test/spec-passed/result + 'struct/dc-1a + '(let () + (struct s (a b)) + (and (value-contract (contract (struct/dc s + [a () (or/c number? (-> void?))] ; want non-flat + [b (a) boolean?]) + (s 1 #f) + 'pos + 'neg)) + #t)) + #t) + + (test/spec-passed/result + 'struct/dc-1b + '(let () + (struct s (a b)) + (and (value-blame (contract (struct/dc s + [a () (or/c number? (-> void?))] ; want non-flat + [b (a) boolean?]) + (s 1 #f) + 'pos + 'neg)) + #t)) + #t) (test/spec-passed 'struct/dc-1a diff --git a/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt b/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt index 3506540185..6a3960412d 100644 --- a/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt +++ b/pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt @@ -68,4 +68,21 @@ (test/pos-blame 'unconstrained-domain->11 '((contract (unconstrained-domain-> number? number?) (λ () 1) 'pos 'neg))) + + (test/spec-passed/result + 'unconstrained-domain->12 + '(and (value-contract (contract (unconstrained-domain-> number?) + (lambda (x) 1) + 'pos + 'neg)) + #t) + #t) + (test/spec-passed/result + 'unconstrained-domain->13 + '(and (value-blame (contract (unconstrained-domain-> number?) + (lambda (x) 1) + 'pos + 'neg)) + #t) + #t) ) diff --git a/racket/collects/racket/contract/private/arr-d.rkt b/racket/collects/racket/contract/private/arr-d.rkt index 4888bcfac1..b37559c6f4 100644 --- a/racket/collects/racket/contract/private/arr-d.rkt +++ b/racket/collects/racket/contract/private/arr-d.rkt @@ -412,7 +412,8 @@ dom-blame neg-party) (loop (cdr args) (cdr non-kwd-ctcs)))])))))))) - impersonator-prop:contracted ->d-stct))))) + impersonator-prop:contracted ->d-stct + impersonator-prop:blame (blame-add-missing-party blame neg-party)))))) (define (build-values-string desc dep-pre-args) (cond diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 72d2ed469c..572e068f3e 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -766,7 +766,10 @@ '(expected: "~s" given: "~e") (contract-name evt-ctc) val)) - (chaperone-evt val (generator (cons blame neg-party)))))) + (chaperone-evt val + (generator (cons blame neg-party)) + impersonator-prop:contracted evt-ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))) ;; evt/c-first-order : Contract -> Any -> Boolean ;; First order check for evt/c diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 54e5c750df..a124c0ec30 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -464,9 +464,11 @@ (if (and (equal? (procedure-arity val) 1) (let-values ([(a b) (procedure-keywords val)]) (null? b))) - (chaperone-procedure val exact-proc) + (chaperone-procedure val exact-proc + impersonator-prop:contracted ctc + impersonator-prop:blame blame) (if (procedure-arity-includes? val 1) - (handle-non-exact-procedure val 1 blame exact-proc) + (handle-non-exact-procedure val 1 blame exact-proc ctc) (raise-flat-arrow-err blame val 1)))) (raise-flat-arrow-err blame val 1))))) #:lifts null @@ -567,6 +569,7 @@ (cons (optres-name optres-rng) rng-names))]))]) (values (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) (blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) @@ -608,8 +611,9 @@ (chaperone-procedure val exact-proc impersonator-prop:application-mark (cons opt->/c-cm-key cont-mark-value) + impersonator-prop:contracted ctc impersonator-prop:blame blame) - (handle-non-exact-procedure val dom-len blame exact-proc)))) + (handle-non-exact-procedure val dom-len blame exact-proc ctc)))) (append lifts-doms lifts-rngs) (append superlifts-doms superlifts-rngs) (append partials-doms partials-rngs) @@ -668,6 +672,7 @@ (values (with-syntax ((blame (opt/info-blame opt/info)) (val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) @@ -680,6 +685,7 @@ [(dom-arg ...) (values next-dom ...)] [args (bad-number-of-arguments blame val args dom-len)]) + impersonator-prop:contracted ctc impersonator-prop:blame blame))) (if all-anys? #`(if (procedure-arity-exactly/no-kwds val #,(length doms)) @@ -739,7 +745,7 @@ (define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t)) -(define (handle-non-exact-procedure val dom-len blame exact-proc) +(define (handle-non-exact-procedure val dom-len blame exact-proc ctc) (check-procedure val #f dom-len 0 '() '() blame #f) (chaperone-procedure val @@ -755,7 +761,9 @@ (cond [(null? (cdr kwds)) '()] [else (cons " " (loop (cdr kwds)))])))))) - exact-proc))) + exact-proc) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)) (define (raise-flat-arrow-err blame val n) (raise-blame-error blame val diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index 524bdd4e64..e6c42ee715 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -314,7 +314,11 @@ [dep-args '()]) (cond [(null? subcontracts) - (define (app* f v l) (if (null? l) v (apply f v l))) + (define (app* f v l) + (if (null? l) + v + (apply f v (append l (list impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party)))))) (app* chaperone-struct (app* impersonate-struct v @@ -1439,7 +1443,9 @@ #,(opt/info-val opt/info) #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here stronger-prop-desc - (vector free-var ...))) + (vector free-var ...) + impersonator-prop:contracted #,(opt/info-contract opt/info) + impersonator-prop:blame #,(opt/info-blame opt/info))) (struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name))))) #:lifts s-lifts diff --git a/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt b/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt index 886cc37e9e..f4d0b5b171 100644 --- a/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt +++ b/racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt @@ -88,6 +88,7 @@ neg-party projs) impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) impersonator-prop:application-mark (cons tail-contract-key (list* neg-party blame-party-info range-contracts)))))))