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

* Just use new marks instead of name mangling for the ctc-ids

Browse Source 
* Set the 'inferred-name property appropriately.

svn: r13802
This commit is contained in:
Stevie Strickland 2009-02-23 14:36:28 +00:00
parent ce79598a4a
commit 93d6a5fc7c
1 changed files with 33 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -386,21 +386,20 @@ improve method arity mismatch contract violation error messages?
(syntax id))]
[(f arg ...)
(quasisyntax/loc stx
((let ([f (-contract contract-stx
#,id
pos-blame-id
neg-blame-id
#,(id->contract-src-info id))])
f) arg ...))]
((-contract contract-stx
#,id
pos-blame-id
neg-blame-id
#,(id->contract-src-info id))
arg ...))]
[ident
(identifier? (syntax ident))
(quasisyntax/loc stx
(let ([ident (-contract contract-stx
#,id
pos-blame-id
neg-blame-id
#,(id->contract-src-info id))])
ident))])))))
(-contract contract-stx
#,id
pos-blame-id
neg-blame-id
#,(id->contract-src-info id)))])))))
(define-syntax (with-contract-helper stx)
@ -500,21 +499,20 @@ improve method arity mismatch contract violation error messages?
(syntax id))]
[(f arg ...)
(quasisyntax/loc stx
((let ([f (-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv))])
f) arg ...))]
((-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv))
arg ...))]
[ident
(identifier? (syntax ident))
(quasisyntax/loc stx
(let ([ident (-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv))])
ident))]))))
(-contract #,ctc
#,fv
#,pos-blame
#,neg-blame
#,(id->contract-src-info fv)))]))))
(define-syntax (with-contract stx)
(when (eq? (syntax-local-context) 'expression)
@ -544,6 +542,7 @@ improve method arity mismatch contract violation error messages?
(and (identifier? #'blame)
(identifier? #'type))
(let*-values ([(marker) (make-syntax-introducer)]
[(cid-marker) (make-syntax-introducer)]
[(no-need free-vars free-ctcs)
(check-and-split-with-contracts #f (syntax->list #'(fv ...)))]
[(unprotected protected protections)
@ -558,15 +557,17 @@ improve method arity mismatch contract violation error messages?
[blame-id (car (generate-temporaries (list #t)))]
[(free-var ...) free-vars]
[(free-var-id ...) (map marker free-vars)]
[(free-ctc-id ...) (map (λ (i)
(marker (a:mangle-id stx "with-contract-contract-id" i)))
free-vars)]
[(free-ctc ...) free-ctcs]
[(free-ctc-id ...) (map cid-marker free-vars)]
[(free-ctc ...) (map (λ (c v)
(syntax-property c 'inferred-name v))
free-ctcs
free-vars)]
[(free-src-info ...) (map id->contract-src-info free-vars)]
[(ctc-id ...) (map (λ (i)
(marker (a:mangle-id stx "with-contract-contract-id" i)))
protected)]
[(ctc ...) (map marker protections)]
[(ctc-id ...) (map cid-marker protected)]
[(ctc ...) (map (λ (c v)
(marker (syntax-property c 'inferred-name v)))
protections
protected)]
[(p ...) protected]
[(marked-p ...) (map marker protected)]
[(src-info ...) (map (compose id->contract-src-info marker) protected)]