diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 6dcdfa0d95..e825c6e0fa 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -466,8 +466,13 @@ (define-splicing-syntax-class result-clause #:description "a results clause" [pattern (~seq #:result ctc:expr)]) + (define-splicing-syntax-class rcs + #:attributes ([ctc 1]) + #:description "a non-empty sequence of result clauses" + [pattern (~seq rc:result-clause ...+) + #:with (ctc ...) #'(rc.ctc ...)]) (syntax-parse stx - [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:result-clause fv:fvs . body) + [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:rcs fv:fvs . body) (if (not (eq? (syntax-local-context) 'expression)) (quasisyntax/loc stx (#%expression #,stx)) (let*-values ([(intdef) (syntax-local-make-definition-context)] @@ -477,16 +482,14 @@ (values (syntax->list #'(fv.var ...)) (syntax->list #'(fv.ctc ...)))]) (define (add-context stx) - (let ([ctx-added-stx (local-expand #`(quote #,stx) - ctx - (list #'quote) - intdef)]) + (let ([ctx-added-stx (local-expand #`(quote #,stx) ctx (list #'quote) intdef)]) (syntax-case ctx-added-stx () [(_ expr) #'expr]))) (syntax-local-bind-syntaxes free-vars #f intdef) (internal-definition-context-seal intdef) (with-syntax ([blame-stx #''(region blame)] [blame-id (generate-temporary)] + [(res ...) (generate-temporaries #'(rc.ctc ...))] [(free-var ...) free-vars] [(free-var-id ...) (add-context #`#,free-vars)] [(free-ctc-id ...) (map cid-marker free-vars)] @@ -496,10 +499,11 @@ free-vars)]) (with-syntax ([new-stx (add-context #'(syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) - (contract (verify-contract 'with-contract rc.ctc) - (let () . body) - blame-stx - blame-id)))]) + (let-values ([(res ...) (let () . body)]) + (values (contract (verify-contract 'with-contract rc.ctc) + res + blame-stx + blame-id) ...))))]) (quasisyntax/loc stx (let () (define-values (free-ctc-id ...) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 157ebe8031..3f6ed3ca43 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -745,7 +745,7 @@ ensure that the exported functions are treated parametrically. @defform*/subs[ [(with-contract blame-id (wc-export ...) free-var-list ... body ...+) - (with-contract blame-id result-spec free-var-list ... body ...+)] + (with-contract blame-id result-spec ...+ free-var-list ... body ...+)] ([wc-export (id contract-expr)] [result-spec @@ -762,9 +762,10 @@ list are protected with the corresponding contract. The @scheme[body] of the form allows definition/expression interleaving if its context does. The second @scheme[with-contract] form must appear in expression position. -The result of the final @scheme[body] expression is contracted with -the contract listed in the @scheme[result-spec]. The sequence of @scheme[body] -forms is treated as for @scheme[let]. +The final @scheme[body] expression should return the same number of values +as the number of @scheme[result-spec]s, and each returned value is contracted +with the contract listed in its respective @scheme[result-spec]. +The sequence of @scheme[body] forms is treated as for @scheme[let]. The @scheme[blame-id] is used for the positive positions of contracts paired with exported @scheme[id]s. Contracts broken diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 81e3558b10..b5c0374b3f 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -3045,6 +3045,32 @@ (λ (x) 5)) #t) "top-level") + + (test/spec-passed + 'with-contract-exp-values-1 + '(let-values ([(x y) (with-contract r + #:result number? + #:result string? + (values 3 "foo"))]) + 1)) + + (test/spec-failed + 'with-contract-exp-values-2 + '(let-values ([(x y) (with-contract r + #:result number? + #:result string? + (values "bar" "foo"))]) + 1) + "(region r)") + + (test/spec-passed + 'with-contract-exp-values-3 + '(let-values ([(x y) (with-contract r + #:result number? + #:result string? + (define (f) (values 3 "foo")) + (f))]) + 1)) ; ;