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

fix promise/c in the case of multiple values coming out of the promise

Browse Source 
closes #1821
This commit is contained in:
Robby Findler 2017-09-29 07:11:24 -05:00
parent e5a14c4f9d
commit 39dea70732
2 changed files with 54 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
pkgs/racket-test/tests/racket/contract/promise.rkt
View File

@ -78,4 +78,34 @@
'pos
'neg))
#t)
#t))
#t)
(test/pos-blame
'promise/c8
'(force
(contract (promise/c number?)
(delay (values 2 3))
'pos 'neg)))
(test/pos-blame
'promise/c9
'(force
(contract (promise/c number?)
(delay (values))
'pos 'neg)))
(test/pos-blame
'promise/c10
'(force
(contract (promise/c number?)
(delay (values 1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8 9))
'pos 'neg)))
)

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

@ -355,7 +355,8 @@
(define c/i-procedure (if chap? chaperone-procedure impersonate-procedure))
(define ctc-proc (get/build-late-neg-projection (promise-base-ctc-ctc ctc)))
(λ (blame)
(define p-app (ctc-proc (blame-add-context blame "the promise from")))
(define promise-blame (blame-add-context blame "the promise from"))
(define p-app (ctc-proc promise-blame))
(λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(if (promise? val)
@ -366,9 +367,27 @@
(c/i-procedure
proc
(λ (promise)
(values (λ (val) (with-contract-continuation-mark
blame+neg-party
(p-app val neg-party)))
(values (case-lambda
[(val) (with-contract-continuation-mark
blame+neg-party
(p-app val neg-party))]
[()
(raise-blame-error
promise-blame #:missing-party neg-party val
'("received 0 values" expected: "1 value"))]
[reses
(define length-reses (length reses))
(raise-blame-error
promise-blame #:missing-party neg-party val
'("received ~a values~a~a" expected: "1 value")
length-reses
(if (<= length-reses 10)
":"
", the first 10 of which are:")
(apply string-append
(for/list ([v (in-list reses)]
[_ (in-range 10)])
(format "\n ~e" v))))])
promise))))
impersonator-prop:contracted ctc
impersonator-prop:blame blame)