diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 15f476b2fb..acae98e8bd 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -214,7 +214,8 @@ improve method arity mismatch contract violation error messages? [(_ marker blame-stx ((p c) ...) (u ...) body0 body ...) (let ([expanded-body0 (local-expand #'body0 (syntax-local-context) - (kernel-form-identifier-list))]) + (cons #'splicing-syntax-parameterize + (kernel-form-identifier-list)))]) (syntax-case expanded-body0 (begin define-values) [(begin sub ...) (syntax/loc stx @@ -267,6 +268,19 @@ improve method arity mismatch contract violation error messages? u-def ... p/c-def ... (with-contract-helper marker blame-stx #,unused-p/cs #,unused-us body ...)))))] + [(splicing-syntax-parameterize bindings . ssp-body) + (let* ([marker-f (let ([marker (syntax-e #'marker)]) + (lambda (stx) + (syntax-local-introduce + (marker (syntax-local-introduce stx)))))] + [expanded-ssp (local-expand (quasisyntax/loc expanded-body0 + (splicing-syntax-parameterize bindings . + #,(marker-f #'ssp-body))) + (syntax-local-context) + (kernel-form-identifier-list))]) + (quasisyntax/loc stx + (begin #,expanded-ssp + (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))] [else (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)]) (lambda (stx) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index fef049973d..2e4c85d6f9 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2476,7 +2476,53 @@ (define (evenp n) (if (zero? n) #t (oddp (zero? n))))) (oddp 5))) - + + (test/spec-passed + 'with-contract5 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (if (y n) 0 3))) + (x 4))) + + (test/spec-failed + 'with-contract6 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (y n))) + (x 4)) + "(region region1)") + + (test/spec-failed + 'with-contract7 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) #t)) + (define (x n) (if (y #t) 4 0))) + (x 4)) + "(region region1)") + + (test/spec-failed + 'with-contract8 + '(let () + (with-contract region1 + ([x (-> number? number?)]) + (with-contract region2 + ([y (-> number? boolean?)]) + (define (y n) 3)) + (define (x n) (if (y n) 4 0))) + (x 4)) + "(region region2)") ; ;