If we're using known-good-contract here, we won't always have an identifier

for the contract, so use the contract in that case.  Also rename to
contract-stx in make-with-contract-transformer so its name isn't misleading.

svn: r13269
This commit is contained in:
Stevie Strickland 2009-01-23 20:34:59 +00:00
parent 9361e782ef
commit 72d551082d

View File

@ -134,12 +134,12 @@ improve method arity mismatch contract violation error messages?
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) (define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (define-for-syntax (make-with-contract-transformer contract-stx id pos-blame-id)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(with-syntax ([neg-blame-id #'(current-contract-region)] (with-syntax ([neg-blame-id #'(current-contract-region)]
[pos-blame-id pos-blame-id] [pos-blame-id pos-blame-id]
[contract-id contract-id] [contract-stx contract-stx]
[id id]) [id id])
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! id arg) [(set! id arg)
@ -149,7 +149,7 @@ improve method arity mismatch contract violation error messages?
(syntax id))] (syntax id))]
[(f arg ...) [(f arg ...)
(syntax/loc stx (syntax/loc stx
((-contract contract-id ((-contract contract-stx
id id
pos-blame-id pos-blame-id
neg-blame-id neg-blame-id
@ -158,7 +158,7 @@ improve method arity mismatch contract violation error messages?
[ident [ident
(identifier? (syntax ident)) (identifier? (syntax ident))
(syntax/loc stx (syntax/loc stx
(-contract contract-id (-contract contract-stx
id id
pos-blame-id pos-blame-id
neg-blame-id neg-blame-id
@ -245,7 +245,7 @@ improve method arity mismatch contract violation error messages?
[always-defined [always-defined
(list #`(define-syntaxes (#,p) (list #`(define-syntaxes (#,p)
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax #,contract-id) (quote-syntax #,(if contract-id contract-id c))
(quote-syntax #,(marker-f p)) (quote-syntax #,(marker-f p))
(quote-syntax blame-stx))) (quote-syntax blame-stx)))
#`(define-values () #`(define-values ()