~ chicken-r7rs (master) 4f58c169b05696945d43b41cde7d6fcbf3f2bbfc

commit 4f58c169b05696945d43b41cde7d6fcbf3f2bbfc
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu May 30 09:05:40 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Thu May 30 09:05:40 2013 +0000

    Basic with-exception-handler & guard tests

diff --git a/tests/run.scm b/tests/run.scm
index bf739af..ccb0a2b 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -15,6 +15,26 @@
     ((_ . body) (handle-exceptions e e . body))))
 
 (test-group "exceptions"
+ (test "with-exception-handler (escape)"
+  'exception
+  (call-with-current-continuation
+   (lambda (k)
+    (with-exception-handler
+     (lambda (e) (k 'exception))
+     (lambda () (+ 1 (raise 'an-error)))))))
+ (test-error "with-exception-handler (return)"
+  (with-exception-handler
+   (lambda (e) 'ignore)
+   (lambda () (+ 1 (raise 'an-error)))))
+ (test-error "with-exception-handler (raise)"
+  (with-exception-handler
+   (lambda (e) 'ignore)
+   (lambda () (+ 1 (raise 'an-error)))))
+ (test "with-exception-handler (raise-continuable)"
+  65
+  (with-exception-handler
+   (lambda (e) 42)
+   (lambda () (+ (raise-continuable "should be a number") 23))))
  (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"))))
@@ -22,4 +42,18 @@
  (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")))))
+ (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))
+ (test-error "guard (no match)"
+  (guard (condition ((assq 'c condition))) (raise '((a . 42)))))
+ (test "guard (match)"
+  '(b . 23)
+  (guard (condition ((assq 'b condition))) (raise '((b . 23)))))
+ (test "guard (=>)"
+  42
+  (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))
+ (test "guard (multiple)"
+  '(b . 23)
+  (guard (condition
+          ((assq 'a condition) => cdr)
+          ((assq 'b condition)))
+    (raise '((b . 23))))))