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

Move first-order checks for free-var ctcs to before the body of the

Browse Source 
with-contract expansion.

svn: r13713
This commit is contained in:
Stevie Strickland 2009-02-17 23:38:46 +00:00
parent 76853279c3
commit 770aab6700
1 changed files with 13 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -329,10 +329,19 @@ improve method arity mismatch contract violation error messages?
[(marked-u ...) (map marker unprotected)]) [(marked-u ...) (map marker unprotected)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define-values (free-ctc-id ...) (define-values (free-ctc-id ... ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...
(verify-contract 'with-contract ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values ()
(begin (-contract free-ctc-id
free-var
blame-id
'cant-happen
free-src-info)
...
(values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
(values (make-free-var-transformer (values (make-free-var-transformer
(quote-syntax free-var) (quote-syntax free-var)
@ -341,19 +350,13 @@ improve method arity mismatch contract violation error messages?
(quote-syntax blame-stx)) ...)) (quote-syntax blame-stx)) ...))
(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) (splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
(with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body))) (with-contract-helper blame-stx (marked-p ... marked-u ...) . #,(marker #'body)))
(define-values (ctc-id ...)
(values (verify-contract 'with-contract ctc) ...))
(define-values () (define-values ()
(begin (-contract ctc-id (begin (-contract ctc-id
marked-p marked-p
blame-stx blame-stx
'cant-happen 'cant-happen
src-info) ... src-info)
(-contract free-ctc-id ...
free-var
blame-id
'cant-happen
free-src-info) ...
(values))) (values)))
(define-syntaxes (u ... p ...) (define-syntaxes (u ... p ...)
(values (make-rename-transformer #'marked-u) ... (values (make-rename-transformer #'marked-u) ...