Initial attempt at free var contracts. Needs a little more work, but might

handle Robby's use cases.

svn: r13700

collects/scheme/private/contract.ss

@@ -88,29 +88,41 @@ improve method arity mismatch contract violation error messages?
      (raise-syntax-error 'define/contract
                          "no body after contract"
                          define-stx)]
-    [(_ name contract-expr expr)
+    [(_ name+arg-list contract #:freevars args . body)
-     (identifier? #'name)
+     (identifier? #'args)
-     (syntax/loc define-stx
-       (with-contract #:type definition name
-         ([name contract-expr])
-         (define name expr)))]
-    [(_ name contract-expr expr0 expr ...)
-     (identifier? #'name)
      (raise-syntax-error 'define/contract
-                         "multiple expressions after identifier and contract"
+                         "expected list of identifier/contract pairs"
-                         define-stx)]
+                         #'args)]
+    [(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body)
+     (syntax/loc define-stx
+       (define/contract name+arg-list contract #:freevars (arg ... [x c]) #:freevar x c . body))]
+    [(_ name+arg-list contract #:freevar x c . body)
+     (syntax/loc define-stx
+       (define/contract name+arg-list contract #:freevars () #:freevar x c . body))]
+    [(_ name+arg-list contract #:freevars args body0 body ...)
+     (begin
+       (when (and (identifier? #'name+arg-list)
+                  (not (null? (syntax->list #'(body ...)))))
+         (raise-syntax-error 'define/contract
+                             "multiple expressions after identifier and contract"
+                             #'(body ...)))
+       (let-values ([(name body-expr)
+                     (if (identifier? #'name+arg-list)
+                         (values #'name+arg-list #'body0)
+                         (normalize-definition
+                          (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
+                                                             #'body0 #'(body ...)))
+                          #'lambda #t #t))])
+         (with-syntax ([name name]
+                       [body-expr body-expr])
+           (syntax/loc define-stx
+             (with-contract #:type function name
+               ([name (verify-contract 'define/contract contract)])
+               #:freevars args
+               (define name body-expr))))))]
     [(_ name+arg-list contract body0 body ...)
-     (let-values ([(name lam-expr)
+     (syntax/loc define-stx
-                   (normalize-definition
+       (define/contract name+arg-list contract #:freevars () body0 body ...))]))
-                    (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
-                                                       #'body0 #'(body ...)))
-                    #'lambda #t #t)])
-       (with-syntax ([name name]
-                     [lam-expr lam-expr])
-         (syntax/loc define-stx
-           (with-contract #:type function name
-             ([name (verify-contract 'define/contract contract)])
-             (define name lam-expr)))))]))
 
 
 
@@ -221,10 +233,7 @@ improve method arity mismatch contract violation error messages?
           (syntax/loc stx
             (with-contract-helper marker blame-stx ((p c) ...) (u ...) sub ... body ...))]
          [(define-values (id ...) expr)
-          (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
+          (let*-values ([(marker-f) (syntax-e #'marker)]
-                                      (lambda (stx)
-                                        (syntax-local-introduce
-                                         (marker (syntax-local-introduce stx)))))]
                         [(used-p/cs used-us unused-p/cs unused-us)
                          (partition-ids (syntax->list #'(id ...)) 
                                         (map syntax->list (syntax->list #'((p c) ...)))
@@ -269,10 +278,7 @@ improve method arity mismatch contract violation error messages?
                        (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)])
+          (let* ([marker-f (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)))
@@ -282,15 +288,12 @@ improve method arity mismatch contract violation error messages?
               (begin #,expanded-ssp
                      (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]
          [else
-          (let*-values ([(marker-f) (let ([marker (syntax-e #'marker)])
+          (let*-values ([(marker-f) (syntax-e #'marker)])
-                                      (lambda (stx)
-                                        (syntax-local-introduce
-                                         (marker (syntax-local-introduce stx)))))])
             (quasisyntax/loc stx
               (begin #,(marker-f expanded-body0)
                      (with-contract-helper marker blame-stx ((p c) ...) (u ...) body ...))))]))]))
 
-(define-for-syntax (check-and-split-with-contract-args args)
+(define-for-syntax (check-and-split-with-contracts single-allowed? args)
   (let loop ([args args]
              [unprotected null]
              [protected null]
@@ -299,6 +302,10 @@ improve method arity mismatch contract violation error messages?
       [(null? args)
        (values unprotected protected protections)]
       [(identifier? (car args))
+       (unless single-allowed?
+         (raise-syntax-error 'with-contract
+                           "expected (identifier contract)"
+                           (car args)))
        (loop (cdr args)
              (cons (car args) unprotected)
              protected
@@ -316,21 +323,72 @@ improve method arity mismatch contract violation error messages?
                (cons (second l) protections)))]
       [else
        (raise-syntax-error 'with-contract
-                           "expected an identifier or (identifier contract)"
+                           (format "expected ~a(identifier contract)"
+                                   (if single-allowed? "an identifier or " ""))
                            (car args))])))
 
+(define-for-syntax (make-free-var-transformer fv ctc pos-blame neg-blame)
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! id arg)
+        (raise-syntax-error 'with-contract
+                            "cannot set! a contracted variable"
+                            stx
+                            (syntax id))]
+       [(f arg ...)
+        (quasisyntax/loc stx
+          ((let ([f (-contract #,ctc
+                               #,fv
+                               #,pos-blame
+                               #,neg-blame
+                               #,(id->contract-src-info fv))])
+             f) arg ...))]
+       [ident
+        (identifier? (syntax ident))
+        (quasisyntax/loc stx
+          (let ([ident (-contract #,ctc
+                                  #,fv
+                                  #,pos-blame
+                                  #,neg-blame
+                                  #,(id->contract-src-info fv))])
+            ident))]))))
+
 (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 blame (arg ...) body0 . body)
+    [(_ #: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 ...) body0 . body)
      (and (identifier? #'blame)
           (identifier? #'type))
-     (let*-values ([(marker) (make-syntax-introducer)]
+     (let*-values ([(marker) (let ([marker (make-syntax-introducer)])
+                               (λ (x)
+                                 (syntax-local-introduce
+                                  (marker (syntax-local-introduce x)))))]
+                   [(no-need free-vars free-ctcs)
+                    (check-and-split-with-contracts #f (syntax->list #'(fv ...)))]
                    [(unprotected protected protections)
-                    (check-and-split-with-contract-args (syntax->list #'(arg ...)))])
+                    (check-and-split-with-contracts #t (syntax->list #'(arg ...)))])
        (begin
          (let ([dupd-id (check-duplicate-identifier (append unprotected protected))])
            (when dupd-id
@@ -338,35 +396,47 @@ improve method arity mismatch contract violation error messages?
                                  "identifier appears twice in exports"
                                  dupd-id)))
          (with-syntax ([blame-stx #''(type blame)]
+                       [blame-id (car (generate-temporaries (list #t)))]
+                       [(free-var ...) free-vars]
+                       [(free-var-id ...) (map marker free-vars)]
+                       [(free-ctc-id ...) (map (λ (i)
+                                                 (marker (a:mangle-id stx "with-contract-contract-id" i)))
+                                               free-vars)]
+                       [(free-ctc ...) (map (lambda (c)
+					      (if (a:known-good-contract? c)
+						  c
+						  #`(coerce-contract 'with-contract #,c)))
+					    free-ctcs)]
                        [((p c) ...) (map list protected protections)]
                        [(u ...) unprotected])
            (quasisyntax/loc stx
-             (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
+             (begin
-               (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body))))))]
+               (define-values (free-ctc-id ...)
-    [(_ #:type type blame (arg ...) body0 body ...)
+                 (values free-ctc ...))
-     (raise-syntax-error 'with-contract
+               (define blame-id
-                         "expected identifier for blame"
+                 (current-contract-region))
-                         #'blame)]
+               (define-syntaxes (free-var-id ...)
+                 (values (make-free-var-transformer
+                          (quote-syntax free-var)
+                          (quote-syntax free-ctc-id)
+                          (quote-syntax blame-id)
+                          (quote-syntax blame-stx)) ...))
+               (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
+                 (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body)))))))]
+    [(_ #: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 ...) body0 . body)
+     (syntax/loc stx
+       (with-contract #:type type blame (arg ...) #:freevars () body0 . body))]
     [(_ #:type type blame (arg ...))
-     (identifier? #'blame)
      (raise-syntax-error 'with-contract
                          "empty body"
                          stx)]
     [(_ #:type type blame bad-args etc ...)
-     (identifier? #'blame)
      (raise-syntax-error 'with-contract
                          "expected list of identifier and/or (identifier contract)"
                          #'bad-args)]
-    [(_ #:type type args etc ...)
-     (not (identifier? #'args))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for blame"
-                         #'args)]
-    [(_ #:type type etc ...)
-     (not (identifier? #'type))
-     (raise-syntax-error 'with-contract
-                         "expected identifier for type"
-                         #'type)]
     [(_ #:type type blame)
      (raise-syntax-error 'with-contract
                          "only blame"

collects/scribblings/reference/contracts.scrbl

@@ -674,10 +674,14 @@ only used in the contract for the sub-struct's maker, and the selector
 or mutators for the super-struct are not provided.}
 
 @defform/subs[
- (with-contract blame-id (wc-export ...) body ...+)
+ (with-contract blame-id (wc-export ...) free-var-list body ...+)
  ([wc-export
    id
-   (id contract-expr)])]{
+   (id 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]
@@ -691,11 +695,12 @@ contracts paired with exported @scheme[id]s.  Contracts broken
 within the @scheme[with-contract] @scheme[body] will use the
 @scheme[blame-id] for their negative position.}
 
-@defform*[[(define/contract id contract-expr init-value-expr)
+@defform*[[(define/contract id contract-expr free-var-list init-value-expr)
- (define/contract (head args) contract-expr body ...+)]]{
+ (define/contract (head args) contract-expr free-var-list body ...+)]]{
 Works like @scheme[define], except that the contract
 @scheme[contract-expr] is attached to the bound value.  For the
 definition of @scheme[head] and @scheme[args], see @scheme[define].
+For the definition of @scheme[free-var-list], see @scheme[with-contract].
 
 The @scheme[define/contract] form treats the individual definition as
 a contract region. The definition itself is responsible for positive