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

Fix more missing parties in contract instrumentation.

Browse Source
This commit is contained in:
Vincent St-Amour 2015-12-15 14:31:38 -06:00
parent d0d6d719af
commit 3dc49139cf
3 changed files with 24 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -196,4 +196,18 @@
[x pos-blame?] [x pos-blame?]
[y (x) #:depends-on-state pos-blame?])) [y (x) #:depends-on-state pos-blame?]))
(λ (x) x) 'pos 'neg) (λ (x) x) 'pos 'neg)
(posn 1 2))))) (posn 1 2))))
(test/spec-passed
'provide/contract21
'(let ()
((contract (case-> (-> any/c any/c pos-blame?))
(λ (x y) x) 'pos 'neg)
1 2)))
(test/spec-passed
'provide/contract22
'(let ()
((contract (case-> (-> neg-blame? any/c))
(λ (x) x) 'pos 'neg)
1))))

9
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -2,6 +2,7 @@
(require (for-syntax racket/base (require (for-syntax racket/base
syntax/name) syntax/name)
(only-in racket/list last)
racket/stxparam racket/stxparam
"guts.rkt" "guts.rkt"
"blame.rkt" "blame.rkt"
@ -148,7 +149,9 @@
(make-keyword-procedure (make-keyword-procedure
(raise-no-keywords-error f blame neg-party) (raise-no-keywords-error f blame neg-party)
(λ args (λ args
(with-contract-continuation-mark blame (apply the-case-lam args))))) (with-contract-continuation-mark
(cons blame neg-party)
(apply the-case-lam args)))))
(define same-rngs (same-range-projections range-projections)) (define same-rngs (same-range-projections range-projections))
(if same-rngs (if same-rngs
(wrapper (wrapper
@ -206,7 +209,9 @@
(let* ([p (f rng-blame)] (let* ([p (f rng-blame)]
[new (lambda args [new (lambda args
(with-contract-continuation-mark (with-contract-continuation-mark
blame (apply p args)))]) ;; last arg is missing party
(cons blame (last args))
(apply p args)))])
(set! memo (cons (cons f new) memo)) (set! memo (cons (cons f new) memo))
new)))) new))))
rng-late-neg-ctcs))) rng-late-neg-ctcs)))

2
racket/collects/racket/contract/private/guts.rkt
View File

@ -607,6 +607,8 @@
(define-syntax-rule (with-contract-continuation-mark payload code) (define-syntax-rule (with-contract-continuation-mark payload code)
(begin (begin
;; ;; When debugging a missing blame party error, turn this on, then run
;; ;; the contract test suite. It should find the problematic combinator.
;; (unless (or (pair? payload) (not (blame-missing-party? payload))) ;; (unless (or (pair? payload) (not (blame-missing-party? payload)))
;; (error "internal error: missing blame party" payload)) ;; (error "internal error: missing blame party" payload))
(with-continuation-mark contract-continuation-mark-key payload code))) (with-continuation-mark contract-continuation-mark-key payload code)))