Add the ability to contract more than one value returned from a with-contract

block in expression position.

svn: r18456

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 ...)

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

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))
 
 ;                                                                                                                         
 ;