From 80f7b65db7cf9f31390f43caedd650ca645fb49f Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 7 Nov 2012 17:04:49 -0500
Subject: [PATCH] Apply Any wrappers for default-continuation-prompt-tag in TR

original commit: 42b07475e95542ec77b47e216e8711573e0820a1
---
 .../typed-racket/fail/control-test-3.rkt      | 29 +++++++++++++++
 .../typed-racket/base-env/base-contracted.rkt | 37 +++++++++++++++++++
 collects/typed-racket/base-env/base-env.rkt   |  3 +-
 collects/typed-racket/base-env/prims.rkt      |  7 ++++
 collects/typed-racket/private/with-types.rkt  |  3 +-
 collects/typed-racket/typed-racket.rkt        |  2 +
 collects/typed/racket.rkt                     |  3 +-
 collects/typed/racket/base.rkt                |  4 +-
 collects/typed/scheme/base.rkt                |  4 +-
 9 files changed, 86 insertions(+), 6 deletions(-)
 create mode 100644 collects/tests/typed-racket/fail/control-test-3.rkt
 create mode 100644 collects/typed-racket/base-env/base-contracted.rkt

diff --git a/collects/tests/typed-racket/fail/control-test-3.rkt b/collects/tests/typed-racket/fail/control-test-3.rkt
new file mode 100644
index 00000000..e42acf88
--- /dev/null
+++ b/collects/tests/typed-racket/fail/control-test-3.rkt
@@ -0,0 +1,29 @@
+#;
+(exn-pred exn:fail:contract?)
+#lang racket/load
+
+;; check typed-untyped interaction with default tag
+
+(module untyped racket
+  (provide call-f)
+
+  (define (call-f f)
+    (call-with-continuation-prompt
+     (λ () (f 0))
+     (default-continuation-prompt-tag)
+     ;; this application should fail due to the any wrapping
+     ;; for the TR function that's aborted here
+     (λ (x) (x "string")))))
+
+(module typed typed/racket
+  (require/typed 'untyped
+                 [call-f ((Integer -> Integer) -> Integer)])
+
+  (call-f
+   (λ: ([x : Integer])
+     ;; this abort should wrap with an Any wrapper
+     (abort-current-continuation
+      (default-continuation-prompt-tag)
+      (λ (x) x)))))
+
+(require 'typed)
\ No newline at end of file
diff --git a/collects/typed-racket/base-env/base-contracted.rkt b/collects/typed-racket/base-env/base-contracted.rkt
new file mode 100644
index 00000000..5121da4d
--- /dev/null
+++ b/collects/typed-racket/base-env/base-contracted.rkt
@@ -0,0 +1,37 @@
+#lang racket/base
+
+;; This file provides Typed Racket bindings for values that need
+;; contract protection, even in typed code.
+
+(require "../utils/utils.rkt"
+         (env init-envs)
+         (types abbrev union)
+         (utils any-wrap)
+         (only-in (rep type-rep)
+                  make-Prompt-Tag))
+
+;; this submodule defines the contracted versions
+(module contracted racket/base
+  (require racket/contract
+           (rename-in
+            racket/base
+            [default-continuation-prompt-tag -default-continuation-prompt-tag])
+           "../utils/utils.rkt"
+           (utils any-wrap))
+
+  (provide default-continuation-prompt-tag)
+
+  ;; default tag should use Any wrappers
+  (define default-continuation-prompt-tag
+    (contract (-> (prompt-tag/c any-wrap/c #:call/cc any-wrap/c))
+              -default-continuation-prompt-tag
+              'typed 'untyped)))
+
+(require (for-template (submod "." contracted))
+         (submod "." contracted))
+
+(provide default-continuation-prompt-tag)
+
+;; set up the type environment
+(define-initial-env initialize-contracted
+  [default-continuation-prompt-tag (-> (make-Prompt-Tag Univ (-> ManyUniv Univ)))])
diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt
index a56904f3..49d84fb5 100644
--- a/collects/typed-racket/base-env/base-env.rkt
+++ b/collects/typed-racket/base-env/base-env.rkt
@@ -2028,8 +2028,7 @@
  (-polydots (a b d e c)
    (->... (list (make-Prompt-Tag b (->... '() (c c) d))) (c c) e))]
 [make-continuation-prompt-tag (-poly (a b) (->opt [Sym] (make-Prompt-Tag a b)))]
-;; TODO: requires special handling of abort-current-continuation
-;[default-continuation-prompt-tag (-> (make-Prompt-Tag Univ (-> ManyUniv Univ)))]
+;; default-continuation-prompt-tag is defined in "base-contracted.rkt"
 [call-with-current-continuation (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
 [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
 [call-with-composable-continuation
diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt
index 794b8075..d5e045fb 100644
--- a/collects/typed-racket/base-env/prims.rkt
+++ b/collects/typed-racket/base-env/prims.rkt
@@ -16,12 +16,17 @@ This file defines two sorts of primitives. All of them are provided into any mod
    in order to protect the declarations, they are wrapped in `#%app void' so that local-expand of the module body
    will not expand them on the first pass of the macro expander (when the stop list is ignored)
 
+3. contracted versions of built-in racket values such as parameters and prompt tags
+   that are defined in "base-contracted.rkt"
+
 |#
 
 
 (provide (except-out (all-defined-out) dtsi* dtsi/exec* let-internal: define-for-variants define-for*-variants 
                      with-handlers: for/annotation for*/annotation define-for/sum:-variants base-for/flvector: base-for/vector
                      -lambda -define)
+         ;; provide the contracted bindings as primitives
+         (all-from-out "base-contracted.rkt")
          :
          (rename-out [define-typed-struct define-struct:]
                      [lambda: λ:]
@@ -37,6 +42,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
          "colon.rkt"
          "../typecheck/internal-forms.rkt"
          (rename-in racket/contract/base [-> c->] [case-> c:case->])
+         ;; contracted bindings to replace built-in ones
+         (except-in "base-contracted.rkt" initialize-contracted)
          "base-types.rkt"
          "base-types-extra.rkt"
          racket/flonum ; for for/flvector and for*/flvector
diff --git a/collects/typed-racket/private/with-types.rkt b/collects/typed-racket/private/with-types.rkt
index c7f41c62..f89657c9 100644
--- a/collects/typed-racket/private/with-types.rkt
+++ b/collects/typed-racket/private/with-types.rkt
@@ -2,7 +2,8 @@
 
 (require racket/require racket/promise
          (for-template
-          (except-in racket/base for for* with-handlers lambda λ define)
+          (except-in racket/base for for* with-handlers lambda λ define
+                     default-continuation-prompt-tag)
           "../base-env/prims.rkt"
           (prefix-in c: (combine-in racket/contract/region racket/contract/base)))
          "../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers λ lambda define)
diff --git a/collects/typed-racket/typed-racket.rkt b/collects/typed-racket/typed-racket.rkt
index 40f8d49b..9d9569f9 100644
--- a/collects/typed-racket/typed-racket.rkt
+++ b/collects/typed-racket/typed-racket.rkt
@@ -28,6 +28,8 @@
     (do-time "Finshed base-env-numeric")
     ((dynamic-require 'typed-racket/base-env/base-special-env 'initialize-special))
     (do-time "Finished base-special-env")
+    ((dynamic-require 'typed-racket/base-env/base-contracted 'initialize-contracted))
+    (do-time "Finished base-contracted")
     (dynamic-require '(submod typed-racket/base-env/base-types #%type-decl) #f)
     (do-time "Finished base-types")
     (set! initialized #t))
diff --git a/collects/typed/racket.rkt b/collects/typed/racket.rkt
index 85047c7b..eeeddc35 100644
--- a/collects/typed/racket.rkt
+++ b/collects/typed/racket.rkt
@@ -1,6 +1,7 @@
 #lang typed-racket/minimal
 
-(require typed/racket/base racket/require (subtract-in racket typed/racket/base racket/contract)
+(require typed/racket/base racket/require
+         (subtract-in racket typed/racket/base racket/contract)
 	 (for-syntax racket/base))
 (provide (all-from-out typed/racket/base racket)
 	 (for-syntax (all-from-out racket/base)))
diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt
index 31edd0df..8bdbbd79 100644
--- a/collects/typed/racket/base.rkt
+++ b/collects/typed/racket/base.rkt
@@ -1,6 +1,8 @@
 #lang typed-racket/minimal
 
-(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers define λ lambda define-struct for for*))
+(providing (libs (except racket/base #%module-begin #%top-interaction
+                         with-handlers default-continuation-prompt-tag
+                         define λ lambda define-struct for for*))
 	   (basics #%module-begin #%top-interaction))
 
 (require typed-racket/base-env/extra-procs
diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt
index f038bdb8..6e06753a 100644
--- a/collects/typed/scheme/base.rkt
+++ b/collects/typed/scheme/base.rkt
@@ -1,6 +1,8 @@
 #lang typed-racket/minimal
 
-(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers define λ lambda define-struct for for*))
+(providing (libs (except scheme/base #%module-begin #%top-interaction
+                         with-handlers default-continuation-prompt-tag
+                         define λ lambda define-struct for for*))
 	   (basics #%module-begin #%top-interaction))
 
 (require typed-racket/base-env/extra-procs