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

Pull out the querying of current-contract-region (even though it doesn't

Browse Source 
work), as we shouldn't be forming the if clause (here a cond) in the syntax
(as it should be evaluated at expansion time).

svn: r11642
This commit is contained in:
Stevie Strickland 2008-09-11 13:51:03 +00:00
parent 0d90b5274c
commit 8cbc41042e
1 changed files with 30 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/scheme/private/contract.ss
View File

@ -142,35 +142,36 @@ improve method arity mismatch contract violation error messages?
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer
(lambda (stx)
(with-syntax ([neg-blame-id #`(if #,(current-contract-region)
#,(current-contract-region)
(module-source-as-symbol #'#,id))]
[pos-blame-id #`(quote #,(syntax-e pos-blame-id))]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'with-contract
"cannot set! a with-contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax f))
arg ...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax ident)))])))))
(let ([neg-blame-id (cond
[(current-contract-region) => values]
[else #`(module-source-as-symbol #'#,id)])])
(with-syntax ([neg-blame-id neg-blame-id]
[pos-blame-id #`(quote #,(syntax-e pos-blame-id))]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
[(set! id arg)
(raise-syntax-error 'with-contract
"cannot set! a with-contract variable"
stx
(syntax id))]
[(f arg ...)
(syntax/loc stx
((-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax f))
arg ...))]
[ident
(identifier? (syntax ident))
(syntax/loc stx
(-contract contract-id
id
pos-blame-id
neg-blame-id
(quote-syntax ident)))]))))))
(define-syntax (with-contract stx)
(let ([introducer (make-syntax-introducer)])
(syntax-case stx ()