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) (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(with-syntax ([neg-blame-id #`(if #,(current-contract-region) (let ([neg-blame-id (cond
#,(current-contract-region) [(current-contract-region) => values]
(module-source-as-symbol #'#,id))] [else #`(module-source-as-symbol #'#,id)])])
[pos-blame-id #`(quote #,(syntax-e pos-blame-id))] (with-syntax ([neg-blame-id neg-blame-id]
[contract-id contract-id] [pos-blame-id #`(quote #,(syntax-e pos-blame-id))]
[id id]) [contract-id contract-id]
(syntax-case stx (set!) [id id])
[(set! id arg) (syntax-case stx (set!)
(raise-syntax-error 'with-contract [(set! id arg)
"cannot set! a with-contract variable" (raise-syntax-error 'with-contract
stx "cannot set! a with-contract variable"
(syntax id))] stx
[(f arg ...) (syntax id))]
(syntax/loc stx [(f arg ...)
((-contract contract-id (syntax/loc stx
id ((-contract contract-id
pos-blame-id id
neg-blame-id pos-blame-id
(quote-syntax f)) neg-blame-id
arg ...))] (quote-syntax f))
[ident arg ...))]
(identifier? (syntax ident)) [ident
(syntax/loc stx (identifier? (syntax ident))
(-contract contract-id (syntax/loc stx
id (-contract contract-id
pos-blame-id id
neg-blame-id pos-blame-id
(quote-syntax ident)))]))))) neg-blame-id
(quote-syntax ident)))]))))))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(let ([introducer (make-syntax-introducer)]) (let ([introducer (make-syntax-introducer)])
(syntax-case stx () (syntax-case stx ()