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

create the blame+neg-party pair only once, not once for the domain

Browse Source 
and once for the range
This commit is contained in:
Robby Findler 2015-08-23 23:14:31 -05:00
parent 49c4d9272f
commit b7f500fc26
1 changed files with 29 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -252,40 +252,42 @@
(define let-values-clause (define let-values-clause
#`[#,(reverse args-vars) #`[#,(reverse args-vars)
(with-continuation-mark contract-continuation-mark-key (with-continuation-mark contract-continuation-mark-key
(cons blame neg-party) blame+neg-party
(values #,@(reverse args-expressions)))]) (values #,@(reverse args-expressions)))])
(define the-clause (define the-clause
(if rngs (if rngs
#`[#,the-args #`[#,the-args
pre-check ... (let ([blame+neg-party (cons blame neg-party)])
(define-values (failed res-x ...) pre-check ...
(call-with-values (define-values (failed res-x ...)
(λ () (let-values (#,let-values-clause) (call-with-values
#,full-call)) (λ () (let-values (#,let-values-clause)
(case-lambda #,full-call))
[(res-x ...) (case-lambda
(values #f res-x ...)] [(res-x ...)
[args (values #f res-x ...)]
(values args #,@(map (λ (x) #'#f) [args
(syntax->list #'(res-x ...))))]))) (values args #,@(map (λ (x) #'#f)
(with-continuation-mark contract-continuation-mark-key (syntax->list #'(res-x ...))))])))
(cons blame neg-party) (with-continuation-mark contract-continuation-mark-key
(cond blame+neg-party
[failed (cond
(wrong-number-of-results-blame [failed
blame neg-party f (wrong-number-of-results-blame
failed blame neg-party f
#,(length failed
(syntax->list #,(length
#'(res-x ...))))] (syntax->list
[else #'(res-x ...))))]
post-check ... [else
(values ((rb res-x) neg-party) ...)]))] post-check ...
(values ((rb res-x) neg-party) ...)])))]
#`[#,the-args #`[#,the-args
pre-check ... pre-check ...
(let-values (#,let-values-clause) (let ([blame+neg-party (cons blame neg-party)])
#,full-call)])) (let-values (#,let-values-clause)
#,full-call))]))
(cons the-clause (cons the-clause
(cond (cond
[(null? optional-args) '()] [(null? optional-args) '()]