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

Test that contract profiler instrumentation always has complete blame info.

Browse Source
This commit is contained in:
Vincent St-Amour 2015-12-14 13:08:06 -06:00
parent bd77a0102c
commit bf1ba809ae
1 changed files with 14 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,18 +12,27 @@
(only-in racket/contract/private/blame (only-in racket/contract/private/blame
blame-positive blame-positive
blame-negative blame-negative
blame?)) blame?)
(only-in racket/contract/combinator
blame-missing-party?))
(provide pos-blame? neg-blame? named-blame?) (provide pos-blame? neg-blame? named-blame?)
(define (named-blame? who) (define (named-blame? who)
(define mark-info (define mark-info
(continuation-mark-set-first (continuation-mark-set-first
(current-continuation-marks) (current-continuation-marks)
contract-continuation-mark-key)) contract-continuation-mark-key))
(define complete-blame
(or (not mark-info)
(pair? mark-info) ; missing party is provided
(not (blame-missing-party? mark-info)))) ; no missing party
(define (get-party selector) (define (get-party selector)
(and mark-info (and mark-info
(if (pair? mark-info)
(or (selector (car mark-info)) (or (selector (car mark-info))
(cdr mark-info)))) (cdr mark-info))
(selector mark-info))))
(and mark-info (and mark-info
complete-blame
(let ([pos (get-party blame-positive)] (let ([pos (get-party blame-positive)]
[neg (get-party blame-negative)]) [neg (get-party blame-negative)])
(or (equal? pos who) (or (equal? pos who)
@ -100,3 +109,5 @@
(eval '(require 'prof3)) (eval '(require 'prof3))
(eval '(f #:x 11))) (eval '(f #:x 11)))
11)) 11))
;; TODO add struct/dc tests