From 39dea7073295305f6cd2915e874dad5a9bbea540 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 29 Sep 2017 07:11:24 -0500
Subject: [PATCH] fix promise/c in the case of multiple values coming out of
 the promise

closes #1821
---
 .../tests/racket/contract/promise.rkt         | 32 ++++++++++++++++++-
 .../collects/racket/contract/private/misc.rkt | 27 +++++++++++++---
 2 files changed, 54 insertions(+), 5 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/promise.rkt b/pkgs/racket-test/tests/racket/contract/promise.rkt
index 000b0ebe01..89ad00f0ab 100644
--- a/pkgs/racket-test/tests/racket/contract/promise.rkt
+++ b/pkgs/racket-test/tests/racket/contract/promise.rkt
@@ -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)))
+  )
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 358f74d783..09535a42d8 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -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)