Added types and tests for raising and handling exceptions

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))

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)
+[error
-                               -String
+ (make-Function (list
-                               (Un))
+                 (make-arr (list Sym -String) (Un) #:rest Univ)
-                     (-> (Un (-val #f) -Symbol)
+                 (make-arr (list -String) (Un) #:rest Univ)
-                               -String
+                 (make-arr (list Sym) (Un))))]
-                               Univ
+
-                               (Un))
+
-                     (-> (Un (-val #f) -Symbol)
+[raise-user-error
-                               -String
+ (make-Function (list
-                               Univ
+                 (make-arr (list Sym -String) (Un) #:rest Univ)
-                               Univ
+                 (make-arr (list -String) (Un) #:rest Univ)
-                               (Un)))]
+                 (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)]
 

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))