restore the contract profile marks
commit bea67c0
dropped a bit too much of the contract wrapper
This commit is contained in:
parent
f7298cdb29
commit
10c934aec0
|
@ -262,6 +262,12 @@
|
||||||
'contract-arrow4
|
'contract-arrow4
|
||||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1))
|
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'contract-arrow5
|
||||||
|
'(let ()
|
||||||
|
(struct s (x))
|
||||||
|
((contract (-> s? integer?) s-x 'pos 'neg) (s #f))))
|
||||||
|
|
||||||
(test/neg-blame
|
(test/neg-blame
|
||||||
'contract-arrow-arity1
|
'contract-arrow-arity1
|
||||||
'((contract (-> number? number? number?)
|
'((contract (-> number? number? number?)
|
||||||
|
|
|
@ -50,6 +50,12 @@
|
||||||
'contract-marks2
|
'contract-marks2
|
||||||
'((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
|
'((contract (-> any/c pos-blame?) (λ (x) x) 'pos 'neg) 1))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'contract-marks2b
|
||||||
|
'(let ()
|
||||||
|
(struct s (x))
|
||||||
|
((contract (-> any/c pos-blame?) s-x 'pos 'neg) (s 1))))
|
||||||
|
|
||||||
(test/spec-passed
|
(test/spec-passed
|
||||||
'contract-marks3
|
'contract-marks3
|
||||||
'(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
|
'(contract (vector/c pos-blame?) (vector 1) 'pos 'neg))
|
||||||
|
|
|
@ -177,19 +177,15 @@
|
||||||
[args
|
[args
|
||||||
(arrow:bad-number-of-results blame val rng-len args
|
(arrow:bad-number-of-results blame val rng-len args
|
||||||
#:missing-party neg-party)]))))
|
#:missing-party neg-party)]))))
|
||||||
(define (wrap-call-with-values-and-range-checking stx assume-result-values? do-tail-check?)
|
(define (wrap-call-with-values-and-range-checking stx assume-result-values?)
|
||||||
(if rngs
|
(if rngs
|
||||||
(if assume-result-values?
|
(if assume-result-values?
|
||||||
(if do-tail-check?
|
|
||||||
#`(let-values ([(rng-x ...) #,stx])
|
#`(let-values ([(rng-x ...) #,stx])
|
||||||
(with-contract-continuation-mark
|
(with-contract-continuation-mark
|
||||||
(cons blame neg-party)
|
(cons blame neg-party)
|
||||||
(let ()
|
(let ()
|
||||||
post ...
|
post ...
|
||||||
(values (rng-late-neg-projs rng-x neg-party) ...))))
|
(values (rng-late-neg-projs rng-x neg-party) ...))))
|
||||||
|
|
||||||
#`(let-values ([(rng-x ...) #,stx])
|
|
||||||
(values (rng-late-neg-projs rng-x neg-party) ...)))
|
|
||||||
#`(call-with-values
|
#`(call-with-values
|
||||||
(λ () #,stx)
|
(λ () #,stx)
|
||||||
#,rng-checker))
|
#,rng-checker))
|
||||||
|
@ -318,8 +314,7 @@
|
||||||
[else
|
[else
|
||||||
(wrap-call-with-values-and-range-checking
|
(wrap-call-with-values-and-range-checking
|
||||||
the-call
|
the-call
|
||||||
assume-result-values?
|
assume-result-values?)]))
|
||||||
do-tail-check?)]))
|
|
||||||
(define (mk-return assume-result-values? do-tail-check?)
|
(define (mk-return assume-result-values? do-tail-check?)
|
||||||
(if do-tail-check?
|
(if do-tail-check?
|
||||||
(if rngs
|
(if rngs
|
||||||
|
|
Loading…
Reference in New Issue
Block a user