suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Look for defines and handle them directly.

Browse Source 
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.
This commit is contained in:
Stevie Strickland 2013-03-12 18:04:47 -04:00
parent 50c2c54950
commit 6aab2f1445
1 changed files with 26 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/racket/contract/region.rkt
View File

@ -537,10 +537,14 @@
(identifier? (syntax ident)) (identifier? (syntax ident))
(syntax/loc stx int-id)]))))) (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 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 where
p = internal id (transformer binding) p = internal id (transformer binding)
@ -549,7 +553,8 @@
e-expr = initialization value for bare external id e-expr = initialization value for bare external id
c = contract id c = contract id
c-expr = initialization value for 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 Every time a contracted value is defined (that is, a define
that defines a value with identifier p), we change it to that defines a value with identifier p), we change it to
@ -561,16 +566,16 @@
|# |#
(define-syntax (with-contract-helper stx) (define-syntax (with-contract-helper stx)
(syntax-case stx () (syntax-case stx ()
[(_ ()) [(_ () blame)
#'(begin)] #'(begin)]
[(_ ((p0 . rest0) (p . rest) ...)) [(_ ((p0 . rest0) (p . rest) ...) blame)
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"no definition found for identifier" "no definition found for identifier"
#'p0)] #'p0)]
[(_ id-info body0 body ...) [(_ id-info blame body0 body ...)
(let ([expanded-body0 (local-expand #'body0 (let ([expanded-body0 (local-expand #'body0
(syntax-local-context) (syntax-local-context)
(kernel-form-identifier-list))]) (cons #'define (kernel-form-identifier-list)))])
(define (split-ids to-filter to-match) (define (split-ids to-filter to-match)
(partition (λ (pair1) (partition (λ (pair1)
(memf (λ (pair2) (bound-identifier=? (car pair1) pair2)) to-match)) (memf (λ (pair2) (bound-identifier=? (car pair1) pair2)) to-match))
@ -594,24 +599,29 @@
(begin (#,head new-ids #,expr) (begin (#,head new-ids #,expr)
(define-values (c ...) (values c-expr ...)) (define-values (c ...) (values c-expr ...))
(define-values (e ...) (values e-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 ...) [(begin sub ...)
(syntax/loc stx (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) [(define-syntaxes (id ...) expr)
(let ([ids (syntax->list #'(id ...))]) (let ([ids (syntax->list #'(id ...))])
(with-syntax ([(unused-ps def) (rewrite-define #'define-syntaxes ids #'expr)]) (with-syntax ([(unused-ps def) (rewrite-define #'define-syntaxes ids #'expr)])
(syntax/loc stx (syntax/loc stx
(begin def (with-contract-helper unused-ps body ...)))))] (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))]
[(define-values (id ...) expr) [(define-values (id ...) expr)
(let ([ids (syntax->list #'(id ...))]) (let ([ids (syntax->list #'(id ...))])
(with-syntax ([(unused-ps def) (rewrite-define #'define-values ids #'expr)]) (with-syntax ([(unused-ps def) (rewrite-define #'define-values ids #'expr)])
(syntax/loc stx (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 [else
(quasisyntax/loc stx (quasisyntax/loc stx
(begin #,expanded-body0 (begin (add-blame-region blame #,expanded-body0)
(with-contract-helper id-info body ...)))]))])) (with-contract-helper id-info blame body ...)))]))]))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(define-splicing-syntax-class region-clause (define-splicing-syntax-class region-clause
@ -743,9 +753,7 @@
[(true-p ...) (map tid-marker protected)] [(true-p ...) (map tid-marker protected)]
[(ext-id ...) (map eid-marker protected)] [(ext-id ...) (map eid-marker protected)]
[(marked-p ...) (add-context #`#,protected)]) [(marked-p ...) (add-context #`#,protected)])
(with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize (with-syntax ([new-stx (add-context #'body)])
([current-contract-region (λ (stx) #'blame-stx)])
. body))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
@ -781,6 +789,8 @@
ctc-id ctc-id
(verify-contract 'with-contract ctc)) (verify-contract 'with-contract ctc))
...) ...)
blame-stx
.
new-stx) new-stx)
(define-syntaxes (p ...) (define-syntaxes (p ...)
(values (make-external-contracted-id-transformer (values (make-external-contracted-id-transformer