From 8ae58f12449d7c675f0fc233cddf4d2151f031fc Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 3 Aug 2009 21:15:44 +0000 Subject: [PATCH] Primarily this is a change so that the negative party entering into with-contract based contracts is the syntactic context of the with-contract expression. Also, there's some code cleanup. svn: r15665 --- collects/scheme/private/contract.ss | 102 ++++++++--------------- collects/tests/mzscheme/contract-test.ss | 13 ++- 2 files changed, 47 insertions(+), 68 deletions(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 26ea0a4ce4..f08c8b0eb1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -373,49 +373,46 @@ improve method arity mismatch contract violation error messages? (define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) -(define-for-syntax (make-with-contract-transformer contract-stx id pos-blame-id) +(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-id neg-blame-id) (make-set!-transformer (lambda (stx) - (with-syntax ([neg-blame-id #'(current-contract-region)] - [pos-blame-id pos-blame-id] - [contract-stx contract-stx]) - (syntax-case stx (set!) - [(set! id arg) - (raise-syntax-error 'with-contract - "cannot set! a with-contract variable" - stx - (syntax id))] - [(f arg ...) - (quasisyntax/loc stx - ((-contract contract-stx - #,id - pos-blame-id - neg-blame-id - #,(id->contract-src-info id)) - arg ...))] - [ident - (identifier? (syntax ident)) - (quasisyntax/loc stx - (-contract contract-stx - #,id - pos-blame-id - neg-blame-id - #,(id->contract-src-info id)))]))))) + (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 + ((-contract #,contract-stx + #,id + #,pos-blame-id + #,neg-blame-id + #,(id->contract-src-info id)) + arg ...))] + [ident + (identifier? (syntax ident)) + (quasisyntax/loc stx + (-contract #,contract-stx + #,id + #,pos-blame-id + #,neg-blame-id + #,(id->contract-src-info id)))])))) (define-syntax (with-contract-helper stx) (syntax-case stx () - [(_ blame-stx () ()) + [(_ () ()) (begin #'(define-values () (values)))] - [(_ blame-stx (p0 p ...) (u ...)) + [(_ (p0 p ...) (u ...)) (raise-syntax-error 'with-contract "no definition found for identifier" #'p0)] - [(_ blame-stx () (u0 u ...)) + [(_ () (u0 u ...)) (raise-syntax-error 'with-contract "no definition found for identifier" #'u0)] - [(_ blame-stx (p ...) (u ...) body0 body ...) + [(_ (p ...) (u ...) body0 body ...) (let ([expanded-body0 (local-expand #'body0 (syntax-local-context) (kernel-form-identifier-list))]) @@ -428,7 +425,7 @@ improve method arity mismatch contract violation error messages? (syntax-case expanded-body0 (begin define-values define-syntaxes) [(begin sub ...) (syntax/loc stx - (with-contract-helper blame-stx (p ...) (u ...) sub ... body ...))] + (with-contract-helper (p ...) (u ...) sub ... body ...))] [(define-syntaxes (id ...) expr) (let ([ids (syntax->list #'(id ...))]) (for ([i1 (syntax->list #'(p ...))]) @@ -442,18 +439,18 @@ improve method arity mismatch contract violation error messages? [unused-us (filter-ids (syntax->list #'(u ...)) ids)]) (with-syntax () (syntax/loc stx - (begin def (with-contract-helper blame-stx (p ...) unused-us body ...))))))] + (begin def (with-contract-helper (p ...) unused-us body ...))))))] [(define-values (id ...) expr) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([def expanded-body0] [unused-ps (filter-ids (syntax->list #'(p ...)) ids)] [unused-us (filter-ids (syntax->list #'(u ...)) ids)]) (syntax/loc stx - (begin def (with-contract-helper blame-stx unused-ps unused-us body ...)))))] + (begin def (with-contract-helper unused-ps unused-us body ...)))))] [else (quasisyntax/loc stx (begin #,expanded-body0 - (with-contract-helper blame-stx (p ...) (u ...) body ...)))]))])) + (with-contract-helper (p ...) (u ...) body ...)))]))])) (define-for-syntax (check-and-split-with-contracts single-allowed? args) (let loop ([args args] @@ -489,32 +486,6 @@ improve method arity mismatch contract violation error messages? (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 - ((-contract #,ctc - #,fv - #,pos-blame - #,neg-blame - #,(id->contract-src-info fv)) - arg ...))] - [ident - (identifier? (syntax ident)) - (quasisyntax/loc stx - (-contract #,ctc - #,fv - #,pos-blame - #,neg-blame - #,(id->contract-src-info fv)))])))) - (define-syntax (with-contract stx) (when (eq? (syntax-local-context) 'expression) (raise-syntax-error 'with-contract @@ -589,13 +560,13 @@ improve method arity mismatch contract violation error messages? ... (values))) (define-syntaxes (free-var-id ...) - (values (make-free-var-transformer + (values (make-contracted-id-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 blame-stx (marked-p ...) (marked-u ...) . #,(marker #'body))) + (with-contract-helper (marked-p ...) (marked-u ...) . #,(marker #'body))) (define-values (ctc-id ...) (values (verify-contract 'with-contract ctc) ...)) (define-values () @@ -608,10 +579,11 @@ improve method arity mismatch contract violation error messages? (values))) (define-syntaxes (u ... p ...) (values (make-rename-transformer #'marked-u) ... - (make-with-contract-transformer - (quote-syntax ctc-id) + (make-contracted-id-transformer (quote-syntax marked-p) - (quote-syntax blame-stx)) ...)))))))] + (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))] diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index b300833cca..34cec4aee4 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2399,6 +2399,13 @@ (if b (f m) (f #t))) (g #t 3))) + ;; For some of the following tests, it may not be clear + ;; why the blame is what it is. The contract(s) entered + ;; into via with-contract are between the contracting + ;; region and its context. If the context allows the + ;; value to flow into other regions without contracts + ;; that protect it from misuses in those regions, it's + ;; the context's fault. (test/spec-failed 'define/contract12 '(let () @@ -2409,7 +2416,7 @@ (-> boolean? number? number?) (if b (f m) (f #t))) (g #f 3)) - "(function g)") + "top-level") (test/spec-failed 'define/contract13 @@ -2436,7 +2443,7 @@ (require 'foo-dc14) (foo-dc14 #t))) (eval '(require 'bar-dc14))) - "'bar-dc14") + "'foo-dc14") (test/spec-failed 'define/contract15 @@ -2449,7 +2456,7 @@ (+ n 1)))) (eval '(require 'foo-dc15)) (eval '(foo-dc15 #t))) - "top-level") + "'foo-dc15") ;; Let's see how units + define/contract interact