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

Add missing instrumentation to misc.rkt.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-08 17:13:36 -06:00
parent 72418fba03
commit e5738b8ee6
2 changed files with 119 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -286,4 +286,74 @@
3)
3)
(test/spec-passed/result
'contract-marks32
'(car (contract (listof pos-blame?) (list 3) 'pos 'neg))
3)
(test/spec-passed/result
'contract-marks33
'((car (contract (listof (-> neg-blame? pos-blame?)) (list (lambda (x) 3)) 'pos 'neg)) 2)
3)
(test/spec-passed/result
'contract-marks34
'(begin
(require racket/promise)
(force (contract (promise/c pos-blame?) (delay 3) 'pos 'neg)))
3)
(test/spec-passed/result
'contract-marks35
'(let ()
(define/contract tag
(prompt-tag/c (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level))))
(make-continuation-prompt-tag))
(call-with-continuation-prompt
(lambda ()
(number->string
(call-with-composable-continuation
(lambda (k)
(abort-current-continuation tag k)))))
tag
(lambda (k) 3)))
3)
(test/spec-passed/result
'contract-marks36
'(let ()
(define/contract mark-key
(continuation-mark-key/c (-> (λ _ (named-blame? 'top-level))
(λ _ (named-blame? 'top-level))))
(make-continuation-mark-key))
(with-continuation-mark
mark-key
(lambda (s) (append s '(truffle fudge ganache)))
(let ([mark-value (continuation-mark-set-first
(current-continuation-marks) mark-key)])
(mark-value '(chocolate-bar)))))
'(chocolate-bar truffle fudge ganache))
(test/spec-passed/result
'contract-marks37
'(let ()
(define/contract my-evt
(evt/c (λ _ (named-blame? 'top-level)))
always-evt)
(sync my-evt)
3)
3)
(test/spec-passed/result
'contract-marks38
'(let ()
(define/contract chan
(channel/c (λ _ (named-blame? 'top-level)))
(make-channel))
(thread (λ () (channel-get chan)))
(channel-put chan 'not-a-string)
3)
3)
)

74
racket/collects/racket/contract/private/misc.rkt
View File

@ -1283,7 +1283,10 @@
(c/i-procedure
proc
(λ (promise)
(values (λ (val) (p-app val neg-party)) promise)))))
(values (λ (val) (with-contract-continuation-mark
(cons blame neg-party)
(p-app val neg-party)))
promise)))))
(raise-blame-error
blame #:missing-party neg-party
val
@ -1520,11 +1523,14 @@
(define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped)))
(define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame)))
(define (make-proj projs neg-party)
(define blame+neg-party (cons blame neg-party))
(λ vs
(apply values
(for/list ([proj (in-list projs)]
[v (in-list vs)])
(proj v neg-party)))))
(with-contract-continuation-mark
blame+neg-party
(apply values
(for/list ([proj (in-list projs)]
[v (in-list vs)])
(proj v neg-party))))))
(λ (val neg-party)
;; now do the actual wrapping
(cond
@ -1604,11 +1610,16 @@
(define proj1 (ho-proj blame))
(define proj2 (ho-proj (blame-swap blame)))
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(cond
[(continuation-mark-key? val)
(proxy val
(λ (v) (proj1 v neg-party))
(λ (v) (proj2 v neg-party))
(λ (v) (with-contract-continuation-mark
blame+neg-party
(proj1 v neg-party)))
(λ (v) (with-contract-continuation-mark
blame+neg-party
(proj2 v neg-party)))
impersonator-prop:contracted ctc
impersonator-prop:blame blame)]
[else
@ -1665,21 +1676,23 @@
(define ctcs (chaperone-evt/c-ctcs evt-ctc))
(define projs (map contract-projection ctcs))
(λ (blame)
(define ((checker val) . args)
(define expected-num (length ctcs))
(unless (= (length args) expected-num)
(raise-blame-error
blame val
`(expected: "event that produces ~a values"
given: "event that produces ~a values")
expected-num
(length args)))
(apply
values
(for/list ([proj projs] [val args])
((proj blame) val))))
(define (generator evt)
(values evt (checker evt)))
(define ((checker val blame+neg-party) . args)
(with-contract-continuation-mark
blame+neg-party
(define expected-num (length ctcs))
(unless (= (length args) expected-num)
(raise-blame-error
blame val
`(expected: "event that produces ~a values"
given: "event that produces ~a values")
expected-num
(length args)))
(apply
values
(for/list ([proj projs] [val args])
((proj blame) val)))))
(define ((generator blame+neg-party) evt)
(values evt (checker evt blame+neg-party)))
(λ (val neg-party)
(unless (contract-first-order-passes? evt-ctc val)
(raise-blame-error
@ -1687,7 +1700,7 @@
'(expected: "~s" given: "~e")
(contract-name evt-ctc)
val))
(chaperone-evt val generator))))
(chaperone-evt val (generator (cons blame neg-party))))))
;; evt/c-first-order : Contract -> Any -> Boolean
;; First order check for evt/c
@ -1733,8 +1746,19 @@
(λ (blame)
(define pos-proj (ho-proj blame))
(define neg-proj (ho-proj (blame-swap blame)))
(define (proj1 neg-party) (λ (ch) (values ch (λ (v) (pos-proj v neg-party)))))
(define (proj2 neg-party) (λ (ch v) (neg-proj v neg-party)))
(define (proj1 neg-party)
(define blame+neg-party (cons blame neg-party))
(λ (ch)
(values ch (λ (v)
(with-contract-continuation-mark
blame+neg-party
(pos-proj v neg-party))))))
(define (proj2 neg-party)
(define blame+neg-party (cons blame neg-party))
(λ (ch v)
(with-contract-continuation-mark
blame+neg-party
(neg-proj v neg-party))))
(λ (val neg-party)
(cond
[(channel? val)