diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index 865e98b710..6f0f719b55 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -261,6 +261,12 @@ (test/pos-blame 'contract-arrow4 '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)) + + (test/pos-blame + 'contract-arrow5 + '(let () + (struct s (x)) + ((contract (-> s? integer?) s-x 'pos 'neg) (s #f)))) (test/neg-blame 'contract-arrow-arity1 diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt index 9d669c32f3..a59db9f020 100644 --- a/pkgs/racket-test/tests/racket/contract/prof.rkt +++ b/pkgs/racket-test/tests/racket/contract/prof.rkt @@ -50,6 +50,12 @@ 'contract-marks2 '((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1)) + (test/spec-passed + 'contract-marks2b + '(let () + (struct s (x)) + ((contract (-> any/c pos-blame?) s-x 'pos 'neg) (s 1)))) + (test/spec-passed 'contract-marks3 '(contract (vector/c pos-blame?) (vector 1) 'pos 'neg)) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 29c8a62c34..cad1d22315 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -177,19 +177,15 @@ [args (arrow:bad-number-of-results blame val rng-len args #:missing-party neg-party)])))) - (define (wrap-call-with-values-and-range-checking stx assume-result-values? do-tail-check?) + (define (wrap-call-with-values-and-range-checking stx assume-result-values?) (if rngs (if assume-result-values? - (if do-tail-check? - #`(let-values ([(rng-x ...) #,stx]) - (with-contract-continuation-mark - (cons blame neg-party) - (let () - post ... - (values (rng-late-neg-projs rng-x neg-party) ...)))) - - #`(let-values ([(rng-x ...) #,stx]) - (values (rng-late-neg-projs rng-x neg-party) ...))) + #`(let-values ([(rng-x ...) #,stx]) + (with-contract-continuation-mark + (cons blame neg-party) + (let () + post ... + (values (rng-late-neg-projs rng-x neg-party) ...)))) #`(call-with-values (λ () #,stx) #,rng-checker)) @@ -318,8 +314,7 @@ [else (wrap-call-with-values-and-range-checking the-call - assume-result-values? - do-tail-check?)])) + assume-result-values?)])) (define (mk-return assume-result-values? do-tail-check?) (if do-tail-check? (if rngs