From 2d152bac79e8a447d92ca8c5a05a78aef27da020 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 15 Jun 2011 14:20:35 -0400
Subject: [PATCH] Added types and tests for raising and handling exceptions

---
 .../tests/typed-scheme/succeed/exceptions.rkt | 45 +++++++++++++++
 collects/typed-scheme/base-env/base-env.rkt   | 57 ++++++++++++-------
 collects/typed-scheme/types/abbrev.rkt        |  4 ++
 3 files changed, 86 insertions(+), 20 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/exceptions.rkt

diff --git a/collects/tests/typed-scheme/succeed/exceptions.rkt b/collects/tests/typed-scheme/succeed/exceptions.rkt
new file mode 100644
index 0000000000..c1f9561086
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/exceptions.rkt
@@ -0,0 +1,45 @@
+#lang typed/racket
+
+(: abort (Parameter (Any -> Nothing)))
+
+(define abort (make-parameter (lambda (x) (error 'abort))))
+
+(define-syntax (with-abort stx)
+ (syntax-case stx ()
+  ((_ body ...)
+   #'(call/cc (lambda: ((k : (Any -> Nothing)))
+      (parameterize ((abort k))
+        body ...))))))
+
+(call-with-exception-handler 
+ (lambda (v) (displayln v) ((abort) v))
+ (lambda ()
+  (with-abort 2)
+  (with-abort (raise 3))
+  (with-abort (error 'foo))
+  (with-abort (error 'foo "Seven"))
+  (with-abort (error 'foo "Seven ~a" 5))
+  (with-abort (raise-user-error 'foo))
+  (with-abort (raise-user-error 'foo "Seven"))
+  (with-abort (raise-user-error 'foo "Seven ~a" 5))
+  (with-abort (raise-type-error 'slash "foo" 1))
+  (with-abort (raise-type-error 'slash "foo" 1 #\a #\c))
+
+  (with-abort (raise-mismatch-error 'er "foo" 2))
+
+  (with-abort (raise-syntax-error #f "stx-err"))
+  (with-abort (raise-syntax-error #f "stx-err" 45))
+  (with-abort (raise-syntax-error #f "stx-err" 4 5))
+  (with-abort (raise-syntax-error #f "stx-err" 4 5 (list #'stx)))
+  
+  (void)
+  ))
+
+(parameterize ((uncaught-exception-handler (lambda (x) ((abort) x)))
+               (error-escape-handler (lambda () (void)))
+               (error-display-handler (lambda: ((s : String) (e : Any)) (void)))
+               (error-print-width 4)
+               (error-print-context-length 10)
+               (error-value->string-handler (lambda: ((v : Any) (n : Natural)) "str"))
+               (error-print-source-location 'yes))
+ (void))
diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt
index 6d8ae062f1..de204d6a65 100644
--- a/collects/typed-scheme/base-env/base-env.rkt
+++ b/collects/typed-scheme/base-env/base-env.rkt
@@ -30,20 +30,44 @@
           make-Ephemeron
           make-HeterogenousVector))
 
+;Section 9.2
+
 [raise (Univ . -> . (Un))]
-[raise-syntax-error (cl->*
-                     (-> (Un (-val #f) -Symbol)
-                               -String
-                               (Un))
-                     (-> (Un (-val #f) -Symbol)
-                               -String
-                               Univ
-                               (Un))
-                     (-> (Un (-val #f) -Symbol)
-                               -String
-                               Univ
-                               Univ
-                               (Un)))]
+
+[error
+ (make-Function (list
+                 (make-arr (list Sym -String) (Un) #:rest Univ)
+                 (make-arr (list -String) (Un) #:rest Univ)
+                 (make-arr (list Sym) (Un))))]
+
+
+[raise-user-error
+ (make-Function (list
+                 (make-arr (list Sym -String) (Un) #:rest Univ)
+                 (make-arr (list -String) (Un) #:rest Univ)
+                 (make-arr (list Sym) (Un))))]
+
+;raise-type-error (in index)
+[raise-mismatch-error (-> Sym -String Univ (Un))]
+;raise-arity-error
+
+[raise-syntax-error (->opt (-opt Sym) -String [Univ Univ (-lst (-Syntax Univ))] (Un))]
+
+
+[call-with-exception-handler (-poly (a) (-> (-> Univ a) (-> a) a))]
+[uncaught-exception-handler (-Param (-> Univ ManyUniv) (-> Univ ManyUniv))]
+
+[error-escape-handler (-Param (-> ManyUniv) (-> ManyUniv))]
+[error-display-handler (-Param (-> -String Univ ManyUniv) (-> -String Univ ManyUniv))]
+[error-value->string-handler (-Param (-> Univ -Nat -String) (-> Univ -Nat -String))]
+[error-print-context-length (-Param -Nat -Nat)]
+[error-print-width (-Param -Nat -Nat)]
+[error-print-source-location (-Param Univ B)]
+
+
+
+
+
 
 [car   (-poly (a b)
               (cl->*
@@ -372,13 +396,6 @@
 [remq*   (-poly (a) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
 [remv*   (-poly (a) (cl-> [((-lst a) (-lst a)) (-lst a)]))]
 
-(error
- (make-Function (list
-                 (make-arr (list Sym -String) (Un) #:rest Univ)
-                 (make-arr (list -String) (Un) #:rest Univ)
-                 (make-arr (list Sym) (Un)))))
-[error-display-handler  (-Param (-polydots (a) (-String Univ . -> . Univ))
-                                (-polydots (a) (-String Univ . -> . Univ)))]
 
 [namespace-variable-value (Sym [Univ (-opt (-> Univ)) -Namespace] . ->opt . Univ)]
 
diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt
index ea10eec7d4..eea6c029f4 100644
--- a/collects/typed-scheme/types/abbrev.rkt
+++ b/collects/typed-scheme/types/abbrev.rkt
@@ -162,6 +162,10 @@
 (define Univ (make-Univ))
 (define Err (make-Error))
 
+;A Type that corresponds to the any contract for the
+;return type of functions
+(define ManyUniv Univ) 
+
 (define -Port (*Un -Output-Port -Input-Port))
 
 (define -SomeSystemPath (*Un -Path -OtherSystemPath))