From 7dacfaea85b9bb66fe9ae5b5fcdb547c61f00a43 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sat, 27 Feb 2010 01:05:03 +0000
Subject: [PATCH] Add with-contract for expression positions.

svn: r18372
---
 collects/scheme/contract/regions.ss           | 262 ++++++++++--------
 .../scribblings/reference/contracts.scrbl     |  24 +-
 collects/tests/mzscheme/contract-test.ss      |  58 +++-
 3 files changed, 207 insertions(+), 137 deletions(-)

diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss
index 758e2ca916..2d5c6726b2 100644
--- a/collects/scheme/contract/regions.ss
+++ b/collects/scheme/contract/regions.ss
@@ -9,8 +9,11 @@
                      scheme/struct-info
                      syntax/define
                      syntax/kerncase
+                     syntax/parse
+                     unstable/syntax
                      (prefix-in a: "private/helpers.ss"))
          scheme/splicing
+         scheme/stxparam
          "private/arrow.ss"
          "private/base.ss"
          "private/guts.ss")
@@ -87,7 +90,7 @@
                        [body-expr body-expr]
                        [type (if (identifier? #'name+arg-list) 'definition 'function)])
            (syntax/loc define-stx
-             (with-contract #:type type name
+             (with-contract #:region type name
                ([name contract])
                #:freevars args
                (define name body-expr))))))]
@@ -337,7 +340,7 @@
                    (values super-fields ... non-auto-name ...))
                  (define blame-id
                    (current-contract-region))
-                 (with-contract #:type struct struct-name
+                 (with-contract #:region struct struct-name
                                 ctc-bindings
                                 (define-struct/derived orig name (field ...)
                                   kwds ...
@@ -404,28 +407,6 @@
                     (quote #,id)
                     (quote-syntax #,id)))]))))
 
-(define-for-syntax (check-and-split-with-contracts args)
-  (let loop ([args args]
-             [protected null]
-             [protections null])
-    (cond
-      [(null? args)
-       (values protected protections)]
-      [(let ([lst (syntax->list (car args))])
-         (and (list? lst)
-              (= (length lst) 2)
-              (identifier? (first lst))
-              lst))
-       =>
-       (lambda (l)
-         (loop (cdr args)
-               (cons (first l) protected)
-               (cons (second l) protections)))]
-      [else
-       (raise-syntax-error 'with-contract
-                           "expected (identifier contract)"
-                           (car args))])))
-
 (define-syntax (with-contract-helper stx)
   (syntax-case stx ()
     [(_ ())
@@ -467,39 +448,110 @@
                    (with-contract-helper (p ...) body ...)))]))]))
 
 (define-syntax (with-contract stx)
-  (when (eq? (syntax-local-context) 'expression)
-    (raise-syntax-error 'with-contract
-                        "used in expression context"
-                        stx))
-  (syntax-case stx ()
-    [(_ #:type type etc ...)
-     (not (identifier? #'type))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for type"
-                         #'type)]
-    [(_ #:type type args etc ...)
-     (not (identifier? #'args))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for blame"
-                         #'args)]
-    [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
-     (identifier? #'x)
-     (syntax/loc stx
-       (with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))]
-    [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
-     (raise-syntax-error 'with-contract
-                         "use of #:freevar with non-identifier"
-                         #'x)]
-    [(_ #:type type blame (arg ...) #:freevars (fv ...) . body)
-     (and (identifier? #'blame)
-          (identifier? #'type))
+  (define-splicing-syntax-class region-clause
+    #:description "contract region type"
+    [pattern (~seq #:region region:id)])
+  (define-splicing-syntax-class fv-clause
+    #:description "a free variable clause"
+    #:attributes ([var 1] [ctc 1])
+    [pattern (~seq #:freevars ([var:id ctc:expr] ...))]
+    [pattern (~seq #:freevar v:id c:expr)
+             #:with (var ...) (list #'v)
+             #:with (ctc ...) (list #'c)])
+  (define-splicing-syntax-class fvs
+    #:description "a sequence of free variable clauses"
+    #:attributes ([var 1] [ctc 1])
+    [pattern (~seq f:fv-clause ...)
+             #:with (var ...) #'(f.var ... ...)
+             #:with (ctc ...) #'(f.ctc ... ...)
+             #:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
+             (format "duplicate imported name ~a" 
+                     (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
+  (define-syntax-class export-clause
+    #:description "a name/contract pair"
+    [pattern (var:id ctc:expr)])
+  (define-syntax-class exports-clause
+    #:attributes ([var 1] [ctc 1])
+    #:description "a sequence of name/contract pairs"
+    [pattern (ec:export-clause ...)
+             #:with (var ...) #'(ec.var ...)
+             #:with (ctc ...) #'(ec.ctc ...)
+             #:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
+             (format "duplicate exported name ~a" 
+                     (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
+  (define-splicing-syntax-class result-clause
+    #:description "a results clause"
+    [pattern (~seq #:result ctc:expr)])
+  (syntax-parse stx
+    [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:result-clause fv:fvs . body)
+     (if (not (eq? (syntax-local-context) 'expression))
+         (quasisyntax/loc stx (#%expression #,stx))
+         (let*-values ([(intdef) (syntax-local-make-definition-context)]
+                       [(ctx) (list (gensym 'intdef))]
+                       [(cid-marker) (make-syntax-introducer)]
+                       [(free-vars free-ctcs)
+                        (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)])
+               (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)]
+                         [(free-var ...) free-vars]
+                         [(free-var-id ...) (add-context #`#,free-vars)]
+                         [(free-ctc-id ...) (map cid-marker free-vars)]
+                         [(free-ctc ...) (map (λ (c v)
+                                                (syntax-property c 'inferred-name v))
+                                              free-ctcs
+                                              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)))])
+               (quasisyntax/loc stx
+                 (let ()
+                   (define-values (free-ctc-id ...)
+                     (values (verify-contract 'with-contract free-ctc) ...))
+                   (define blame-id
+                     (current-contract-region))
+                   (define-values ()
+                     (begin (contract free-ctc-id
+                                      free-var
+                                      blame-id
+                                      'cant-happen
+                                      (quote free-var)
+                                      (quote-syntax free-var))
+                            ...
+                            (values)))
+                   (define-syntaxes (free-var-id ...)
+                     (values (make-contracted-id-transformer
+                              (quote-syntax free-var)
+                              (quote-syntax free-ctc-id)
+                              (quote-syntax blame-id)
+                              (quote-syntax blame-stx)) ...))
+                   new-stx))))))]
+    [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id ec:exports-clause fv:fvs . body)
+     (when (memq (syntax-local-context) '(expression module-begin))
+       (raise-syntax-error 'with-contract
+                           "not used in definition context"
+                           stx))
      (let*-values ([(intdef) (syntax-local-make-definition-context)]
                    [(ctx) (list (gensym 'intdef))]
                    [(cid-marker) (make-syntax-introducer)]
                    [(free-vars free-ctcs)
-                    (check-and-split-with-contracts (syntax->list #'(fv ...)))]
+                    (values (syntax->list #'(fv.var ...))
+                            (syntax->list #'(fv.ctc ...)))]
                    [(protected protections)
-                    (check-and-split-with-contracts (syntax->list #'(arg ...)))])
+                    (values (syntax->list #'(ec.var ...))
+                            (syntax->list #'(ec.ctc ...)))])
        (define (add-context stx)
          (let ([ctx-added-stx (local-expand #`(quote #,stx)
                                             ctx
@@ -507,20 +559,11 @@
                                             intdef)])
            (syntax-case ctx-added-stx ()
              [(_ expr) #'expr])))
-       (when (eq? (syntax-local-context) 'expression)
-         (raise-syntax-error 'with-contract
-                             "cannot use in an expression context"
-                             stx))
-       (let ([dupd-id (check-duplicate-identifier protected)])
-         (when dupd-id
-           (raise-syntax-error 'with-contract
-                               "identifier appears twice in exports"
-                               dupd-id)))
        (syntax-local-bind-syntaxes protected #f intdef)
        (syntax-local-bind-syntaxes free-vars #f intdef)
        (internal-definition-context-seal intdef)
-       (with-syntax ([blame-stx #''(type blame)]
-                     [blame-id (car (generate-temporaries (list #t)))]
+       (with-syntax ([blame-stx #''(region blame)]
+                     [blame-id (generate-temporary)]
                      [(free-var ...) free-vars]
                      [(free-var-id ...) (add-context #`#,free-vars)]
                      [(free-ctc-id ...) (map cid-marker free-vars)]
@@ -539,58 +582,41 @@
                                                 ([current-contract-region (λ (stx) #'blame-stx)])
                                                 . body))])
            (quasisyntax/loc stx
-           (begin
-             (define-values (free-ctc-id ...)
-               (values (verify-contract 'with-contract free-ctc) ...))
-             (define blame-id
-               (current-contract-region))
-             (define-values ()
-               (begin (contract free-ctc-id
-                                free-var
-                                blame-id
-                                'cant-happen
-                                (quote free-var)
-                                (quote-syntax free-var))
-                      ...
-                      (values)))
-             (define-syntaxes (free-var-id ...)
-               (values (make-contracted-id-transformer
-                        (quote-syntax free-var)
-                        (quote-syntax free-ctc-id)
-                        (quote-syntax blame-id)
-                        (quote-syntax blame-stx)) ...))
-             (with-contract-helper (marked-p ...) new-stx)
-             (define-values (ctc-id ...)
-               (values (verify-contract 'with-contract ctc) ...))
-             (define-values ()
-               (begin (contract ctc-id
-                                marked-p
-                                blame-stx
-                                'cant-happen
-                                (quote marked-p)
-                                (quote-syntax marked-p))
-                      ...
-                      (values)))
-             (define-syntaxes (p ...)
-               (values (make-contracted-id-transformer
-                        (quote-syntax marked-p)
-                        (quote-syntax ctc-id)
-                        (quote-syntax blame-stx)
-                        (quote-syntax blame-id)) ...)))))))]
-    [(_ #:type type blame (arg ...) #:freevar x c . body)
-     (syntax/loc stx
-       (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]
-    [(_ #:type type blame (arg ...) . body)
-     (syntax/loc stx
-       (with-contract #:type type blame (arg ...) #:freevars () . body))]
-    [(_ #:type type blame bad-args etc ...)
-     (raise-syntax-error 'with-contract
-                         "expected list of identifier and/or (identifier contract)"
-                         #'bad-args)]
-    [(_ #:type type blame)
-     (raise-syntax-error 'with-contract
-                         "only blame"
-                         stx)]
-    [(_ etc ...)
-     (syntax/loc stx
-       (with-contract #:type region etc ...))]))
+             (begin
+               (define-values (free-ctc-id ...)
+                 (values (verify-contract 'with-contract free-ctc) ...))
+               (define blame-id
+                 (current-contract-region))
+               (define-values ()
+                 (begin (contract free-ctc-id
+                                  free-var
+                                  blame-id
+                                  'cant-happen
+                                  (quote free-var)
+                                  (quote-syntax free-var))
+                        ...
+                        (values)))
+               (define-syntaxes (free-var-id ...)
+                 (values (make-contracted-id-transformer
+                          (quote-syntax free-var)
+                          (quote-syntax free-ctc-id)
+                          (quote-syntax blame-id)
+                          (quote-syntax blame-stx)) ...))
+               (with-contract-helper (marked-p ...) new-stx)
+               (define-values (ctc-id ...)
+                 (values (verify-contract 'with-contract ctc) ...))
+               (define-values ()
+                 (begin (contract ctc-id
+                                  marked-p
+                                  blame-stx
+                                  'cant-happen
+                                  (quote marked-p)
+                                  (quote-syntax marked-p))
+                        ...
+                        (values)))
+               (define-syntaxes (p ...)
+                 (values (make-contracted-id-transformer
+                          (quote-syntax marked-p)
+                          (quote-syntax ctc-id)
+                          (quote-syntax blame-stx)
+                          (quote-syntax blame-id)) ...)))))))]))
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 680fabdca4..4ba6ce07ef 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -743,20 +743,28 @@ expression to new contracts that hide the values they accept and
 ensure that the exported functions are treated parametrically.
 }
 
-@defform/subs[
- (with-contract blame-id (wc-export ...) free-var-list body ...+)
+@defform*/subs[
+ (with-contract blame-id (wc-export ...) free-var-list ... body ...+)
+ (with-contract blame-id result-spec free-var-list ... body ...+)
  ([wc-export
    (id contract-expr)]
+  [result-spec
+   (code:line #:result contract-expr)]
   [free-var-list
-   code:blank
    (code:line #:freevars ([id contract-expr] ...))
    (code:line #:freevar id contract-expr)])]{
-Generates a local contract boundary.  The @scheme[contract-expr]
-form cannot appear in expression position.  The @scheme[body] of the
-form allows definition/expression interleaving like a @scheme[module]
-body.  All names defined within the @scheme[with-contract] form are
+Generates a local contract boundary.
+
+The first @scheme[with-contract] form cannot appear in expression position.
+All names defined within the first @scheme[with-contract] form are
 visible externally, but those names listed in the @scheme[wc-export]
-list are protected with the corresponding contract.
+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 @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 49a9525ae4..2d35de9984 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -2878,7 +2878,7 @@
 ;                                                                                  
 
   (test/spec-passed
-   'with-contract1
+   'with-contract-def-1
    '(let ()
       (with-contract odd-even
         ([oddp (-> number? boolean?)]
@@ -2890,7 +2890,7 @@
       (oddp 5)))
   
   (test/spec-failed
-   'with-contract2
+   'with-contract-def-2
    '(let ()
       (with-contract odd-even
         ([oddp (-> number? boolean?)]
@@ -2903,7 +2903,7 @@
    "top-level")
   
   (test/spec-failed
-   'with-contract3
+   'with-contract-def-3
    '(let ()
       (with-contract odd-even
         ([oddp (-> number? boolean?)]
@@ -2920,7 +2920,7 @@
   ;; call odd? with a boolean, even though its contract in
   ;; the odd-even contract says it only takes numbers.
   (test/spec-passed
-   'with-contract4
+   'with-contract-def-4
    '(let ()
       (with-contract odd-even
         ([oddp (-> number? boolean?)]
@@ -2935,7 +2935,7 @@
       (oddp 5)))
   
   (test/spec-passed
-   'with-contract5
+   'with-contract-def-5
    '(let ()
       (with-contract region1
         ([x (-> number? number?)])
@@ -2946,7 +2946,7 @@
       (x 4)))
   
   (test/spec-failed
-   'with-contract6
+   'with-contract-def-6
    '(let ()
       (with-contract region1
         ([x (-> number? number?)])
@@ -2958,7 +2958,7 @@
    "(region region1)")
   
   (test/spec-failed
-   'with-contract7
+   'with-contract-def-7
    '(let ()
       (with-contract region1
         ([x (-> number? number?)])
@@ -2970,7 +2970,7 @@
    "(region region1)")
   
   (test/spec-failed
-   'with-contract8
+   'with-contract-def-8
    '(let ()
       (with-contract region1
         ([x (-> number? number?)])
@@ -2983,14 +2983,14 @@
   
   ;; make sure uncontracted exports make it out
   (test/spec-passed
-   'with-contract9
+   'with-contract-def-9
    '(let ()
       (with-contract region1 ()
         (define f 3))
       f))
   
   (test/spec-failed
-   'with-contract10
+   'with-contract-def-10
    '(let ()
       (with-contract r
         ([x number?])
@@ -3001,7 +3001,7 @@
    "(region r)")
   
   (test/spec-failed
-   'with-contract11
+   'with-contract-def-11
    '(let ()
       (with-contract r
         ([x number?])
@@ -3009,6 +3009,42 @@
       (set! x #f)
       x)
    "top-level")
+  
+  (test/spec-passed
+   'with-contract-exp-1
+   '(with-contract r
+      #:result number?
+      3))
+  
+  (test/spec-failed
+   'with-contract-exp-2
+   '(with-contract r
+      #:result number?
+      "foo")
+   "(region r)")
+  
+  (test/spec-passed
+   'with-contract-exp-3
+   '((with-contract r
+      #:result (-> number? number?)
+      (λ (x) 5))
+     3))
+  
+  (test/spec-failed
+   'with-contract-exp-4
+   '((with-contract r
+      #:result (-> number? number?)
+      (λ (x) (zero? x)))
+     3)
+   "(region r)")
+  
+  (test/spec-failed
+   'with-contract-exp-5
+   '((with-contract r
+      #:result (-> number? number?)
+      (λ (x) 5))
+     #t)
+   "top-level")
 
 ;                                                                                                                         
 ;