~ chicken-r7rs (master) 07faeff8e5fb5c4f1df8dbaaa5b58292a570cd78

commit 07faeff8e5fb5c4f1df8dbaaa5b58292a570cd78
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Wed May 29 11:40:22 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Wed May 29 11:40:22 2013 +0000

    Add/alias R7RS exception procedures

diff --git a/r7rs.scm b/r7rs.scm
index d974271..ccd77a9 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,6 +1,16 @@
 (module r7rs
 
-()
+(
+ ;; Exceptions
+ raise
+ raise-continuable
+ error-object?
+ error-object-message
+ error-object-irritants
+ read-error?
+ file-error?
+ ; TODO guard
+ )
 
 (import chicken scheme)
 (use srfi-13)
@@ -23,4 +33,30 @@
              #t)
             (else (old-hook char port))))))
 
+;;;
+;;; 6.11. Exceptions
+;;;
+
+(define raise abort)
+(define raise-continuable signal)
+(define error-object? condition?)
+(define error-object-message (condition-property-accessor 'exn 'message))
+(define error-object-irritants (condition-property-accessor 'exn 'arguments))
+
+(define-values (read-error? file-error?)
+  (let ((exn?    (condition-predicate 'exn))
+        (i/o?    (condition-predicate 'i/o))
+        (file?   (condition-predicate 'file))
+        (syntax? (condition-predicate 'syntax)))
+    (values
+     ;; read-error?
+     (lambda (obj)
+       (and (exn? obj)
+            (or (i/o? obj) ; XXX Not fine-grained enough.
+                (syntax? obj))))
+     ;; file-error?
+     (lambda (obj)
+       (and (exn? obj)
+            (file? obj))))))
+
 )
diff --git a/tests/run.scm b/tests/run.scm
index d15d114..bf739af 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -9,3 +9,17 @@
  (test #t (read-from-string "#true"))
  (test #f (read-from-string "#false"))
  (test-error (read-from-string "#faux")))
+
+(define-syntax catch
+  (syntax-rules ()
+    ((_ . body) (handle-exceptions e e . body))))
+
+(test-group "exceptions"
+ (test "error-object? (#f)" #f (error-object? 'no))
+ (test "error-object? (#t)" #t (error-object? (catch (car '()))))
+ (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
+ (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))
+ (test "read-error? (#f)" #f (read-error? (catch (car '()))))
+ (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))
+ (test "file-error? (#f)" #f (file-error? (catch (car '()))))
+ (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo")))))