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

More cons lifting.

Browse Source 
Could not lift all of those completely.
This commit is contained in:
Vincent St-Amour 2016-01-26 17:10:04 -06:00
parent 5dc368585f
commit 870b8d4137
2 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -67,17 +67,17 @@
post post/desc))))
(define (check-pre-cond pre blame neg-party val)
(define (check-pre-cond pre blame neg-party blame+neg-party val)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(unless (pre)
(raise-blame-error (blame-swap blame)
#:missing-party neg-party
val "#:pre condition"))))
(define (check-post-cond post blame neg-party val)
(define (check-post-cond post blame neg-party blame+neg-party val)
(with-contract-continuation-mark
(cons blame neg-party)
blame+neg-party
(unless (post)
(raise-blame-error blame
#:missing-party neg-party
@ -140,14 +140,14 @@
(with-syntax ([(pre ...)
(cond
[pre
(list #`(check-pre-cond #,pre blame neg-party val))]
(list #`(check-pre-cond #,pre blame neg-party blame+neg-party val))]
[pre/desc
(list #`(check-pre-cond/desc #,pre/desc blame neg-party val))]
[else null])]
[(post ...)
(cond
[post
(list #`(check-post-cond #,post blame neg-party val))]
(list #`(check-post-cond #,post blame neg-party blame+neg-party val))]
[post/desc
(list #`(check-post-cond/desc #,post/desc blame neg-party val))]
[else null])])

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

@ -256,11 +256,11 @@
[(the-call ...) #`(f #,@(reverse normal-arg-vars) kwd-arg-exps ...)]
[(pre-check ...)
(if pre
(list #`(check-pre-cond #,pre blame neg-party f))
(list #`(check-pre-cond #,pre blame neg-party (cons blame neg-party) f))
(list))]
[(post-check ...)
(if post
(list #`(check-post-cond #,post blame neg-party f))
(list #`(check-post-cond #,post blame neg-party (cons blame neg-party) f))
(list))]
[(restb) (generate-temporaries '(rest-args))])
(define (make-body-proc range-checking?)
@ -451,14 +451,14 @@
(cons ((car rbs) (car regular-args) neg-party)
(loop (cdr regular-args) (cdr rbs)))]))))
(define complete-blame (blame-add-missing-party blame neg-party))
(when pre (check-pre-cond pre blame neg-party f))
(when pre (check-pre-cond pre blame neg-party complete-blame f))
(cond
[rngs
(define results (call-with-values mk-call list))
(define rng-len (length rngs))
(unless (= (length results) rng-len)
(arrow:bad-number-of-results complete-blame f rng-len results))
(when post (check-post-cond post blame neg-party f))
(when post (check-post-cond post blame neg-party complete-blame f))
(apply
values
(for/list ([result (in-list results)]