From a0c32ff288f0928efd0016a75319872b593d5fd2 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 4 Dec 2012 14:02:55 -0500
Subject: [PATCH] Fix call/comp's type

original commit: 3f2d4663a87939a02223b6620407e25b0507aa4a
---
 .../tests/typed-racket/succeed/call-comp.rkt    | 17 +++++++++++++++++
 .../tests/typed-racket/succeed/prompt-tag.rkt   |  3 ++-
 collects/typed-racket/base-env/base-env.rkt     | 10 +++++++---
 3 files changed, 26 insertions(+), 4 deletions(-)
 create mode 100644 collects/tests/typed-racket/succeed/call-comp.rkt

diff --git a/collects/tests/typed-racket/succeed/call-comp.rkt b/collects/tests/typed-racket/succeed/call-comp.rkt
new file mode 100644
index 00000000..0befd402
--- /dev/null
+++ b/collects/tests/typed-racket/succeed/call-comp.rkt
@@ -0,0 +1,17 @@
+#lang typed/racket
+
+(require racket/control)
+
+(: tag (Prompt-Tagof Integer (Integer -> Integer)))
+(define tag (make-continuation-prompt-tag))
+
+(call-with-continuation-prompt
+ (λ ()
+    (+ 1
+       ((inst call-with-composable-continuation Integer (Integer -> Integer)
+              Integer)
+        (lambda: ([k : (Integer -> Integer)]) (k 1))
+        tag)))
+ tag
+ (λ: ([x : Integer]) (+ 1 x)))
+
diff --git a/collects/tests/typed-racket/succeed/prompt-tag.rkt b/collects/tests/typed-racket/succeed/prompt-tag.rkt
index 6ed43a7a..128b9919 100644
--- a/collects/tests/typed-racket/succeed/prompt-tag.rkt
+++ b/collects/tests/typed-racket/succeed/prompt-tag.rkt
@@ -14,7 +14,8 @@
 
 ;; Test call/comp & abort
 (call-with-continuation-prompt
- (λ () (+ 1 (call-with-composable-continuation
+ (λ () (+ 1 ((inst call-with-composable-continuation
+                   Integer ((Integer -> Integer) -> Integer) Integer)
              (λ: ([k : (Integer -> Integer)])
                (abort-current-continuation pt2 k))
              pt2)))
diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt
index 31b639f9..90b7f308 100644
--- a/collects/typed-racket/base-env/base-env.rkt
+++ b/collects/typed-racket/base-env/base-env.rkt
@@ -2036,9 +2036,13 @@
 [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
 [call-with-composable-continuation
  (-polydots (b c a)
-   (cl->*
-    (-> (->... '() (a a) b) (make-Prompt-Tagof b c)
-        (make-ValuesDots '() a 'a))))]
+   (-> ;; takes a continuation and should return the same
+       ;; type as the continuation's input type
+       (-> (->... '() (a a) b) (make-ValuesDots '() a 'a))
+       (make-Prompt-Tagof b c)
+       ;; the continuation's input is the same as the
+       ;; return type here
+       (make-ValuesDots '() a 'a)))]
 [call-with-escape-continuation
  (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
 [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]