From 64a68db15d0389fd27442d87e12f0ee959d5036b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Feb 2009 18:18:53 +0000 Subject: [PATCH] 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 | 182 ++++++++++++------ .../scribblings/reference/contracts.scrbl | 13 +- 2 files changed, 135 insertions(+), 60 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 185513882b..6b1805c2e7 100644 --- a/collects/scheme/private/contract.ss +++ b/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) - (identifier? #'name) - (syntax/loc define-stx - (with-contract #:type definition name - ([name contract-expr]) - (define name expr)))] - [(_ name contract-expr expr0 expr ...) - (identifier? #'name) + [(_ name+arg-list contract #:freevars args . body) + (identifier? #'args) (raise-syntax-error 'define/contract - "multiple expressions after identifier and contract" - define-stx)] + "expected list of identifier/contract pairs" + #'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) - (normalize-definition - (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)))))])) + (syntax/loc define-stx + (define/contract name+arg-list contract #:freevars () body0 body ...))])) @@ -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)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))] + (let*-values ([(marker-f) (syntax-e #'marker)] [(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)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))] + (let* ([marker-f (syntax-e #'marker)] [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)]) - (lambda (stx) - (syntax-local-introduce - (marker (syntax-local-introduce stx)))))]) + (let*-values ([(marker-f) (syntax-e #'marker)]) (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)]) - (with-contract-helper #,marker blame-stx ((p c) ...) (u ...) body0 . body))))))] - [(_ #:type type blame (arg ...) body0 body ...) - (raise-syntax-error 'with-contract - "expected identifier for blame" - #'blame)] + (begin + (define-values (free-ctc-id ...) + (values free-ctc ...)) + (define blame-id + (current-contract-region)) + (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" diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index c254ba9cbf..acfdd3fca9 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/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) - (define/contract (head args) contract-expr body ...+)]]{ +@defform*[[(define/contract id contract-expr free-var-list init-value-expr) + (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