From 6aab2f1445cadc45239266fc73c37e7aceee0718 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 12 Mar 2013 18:04:47 -0400 Subject: [PATCH] Look for defines and handle them directly. Since keyword definitions expand into multiple defines, and inserting the contract and external id definitions at the wrong point will cause those to break, we handle define manually. Hat-tip to Vincent for the idea. Doing this means that we can't put a single splicing-syntax-parameterize around the entire body, since it'll expand defines before we reach them, so instead we add them around the expanded code. --- collects/racket/contract/region.rkt | 42 ++++++++++++++++++----------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/collects/racket/contract/region.rkt b/collects/racket/contract/region.rkt index d5285a5425..e7b770173d 100644 --- a/collects/racket/contract/region.rkt +++ b/collects/racket/contract/region.rkt @@ -537,10 +537,14 @@ (identifier? (syntax ident)) (syntax/loc stx int-id)]))))) +(define-syntax-rule (add-blame-region blame . body) + (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame)]) + . body)) + #| with-contract-helper takes syntax of the form: - (with-contract-helper ((p b e e-expr c c-expr) ...) body) + (with-contract-helper ((p b e e-expr c c-expr) ...) blame . body) where p = internal id (transformer binding) @@ -549,7 +553,8 @@ e-expr = initialization value for bare external id c = contract id c-expr = initialization value for contract id - body = the body of the with-contract form + blame = blame syntax for the contract region that's being defined + body = the body expressions of the with-contract form Every time a contracted value is defined (that is, a define that defines a value with identifier p), we change it to @@ -561,16 +566,16 @@ |# (define-syntax (with-contract-helper stx) (syntax-case stx () - [(_ ()) + [(_ () blame) #'(begin)] - [(_ ((p0 . rest0) (p . rest) ...)) + [(_ ((p0 . rest0) (p . rest) ...) blame) (raise-syntax-error 'with-contract "no definition found for identifier" #'p0)] - [(_ id-info body0 body ...) + [(_ id-info blame body0 body ...) (let ([expanded-body0 (local-expand #'body0 (syntax-local-context) - (kernel-form-identifier-list))]) + (cons #'define (kernel-form-identifier-list)))]) (define (split-ids to-filter to-match) (partition (λ (pair1) (memf (λ (pair2) (bound-identifier=? (car pair1) pair2)) to-match)) @@ -594,24 +599,29 @@ (begin (#,head new-ids #,expr) (define-values (c ...) (values c-expr ...)) (define-values (e ...) (values e-expr ...))))))))) - (syntax-case expanded-body0 (begin define-values define-syntaxes) + (syntax-case expanded-body0 (begin define define-values define-syntaxes) [(begin sub ...) (syntax/loc stx - (with-contract-helper id-info sub ... body ...))] + (with-contract-helper id-info blame sub ... body ...))] + [(define rest ...) + (let-values ([(def-id body-stx) (normalize-definition expanded-body0 #'lambda #t #t)]) + (with-syntax ([(unused-ps def) (rewrite-define #'define-values (list def-id) body-stx)]) + (syntax/loc stx + (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))] [(define-syntaxes (id ...) expr) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([(unused-ps def) (rewrite-define #'define-syntaxes ids #'expr)]) - (syntax/loc stx - (begin def (with-contract-helper unused-ps body ...)))))] + (syntax/loc stx + (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))] [(define-values (id ...) expr) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([(unused-ps def) (rewrite-define #'define-values ids #'expr)]) (syntax/loc stx - (begin def (with-contract-helper unused-ps body ...)))))] + (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))] [else (quasisyntax/loc stx - (begin #,expanded-body0 - (with-contract-helper id-info body ...)))]))])) + (begin (add-blame-region blame #,expanded-body0) + (with-contract-helper id-info blame body ...)))]))])) (define-syntax (with-contract stx) (define-splicing-syntax-class region-clause @@ -743,9 +753,7 @@ [(true-p ...) (map tid-marker protected)] [(ext-id ...) (map eid-marker protected)] [(marked-p ...) (add-context #`#,protected)]) - (with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize - ([current-contract-region (λ (stx) #'blame-stx)]) - . body))]) + (with-syntax ([new-stx (add-context #'body)]) (syntax/loc stx (begin (define-values (free-ctc-id ...) @@ -781,6 +789,8 @@ ctc-id (verify-contract 'with-contract ctc)) ...) + blame-stx + . new-stx) (define-syntaxes (p ...) (values (make-external-contracted-id-transformer