use more specific exceptions0.9.1

1 files changed, 20 insertions, 6 deletions

diff --git a/tests/run.scm b/tests/run.scm
index bdc08c2..a6a9f29 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -22,7 +22,7 @@
  | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  |#
 
-(import r7rs test (chicken gc) (srfi 259))
+(import r7rs test (chicken condition) (chicken gc) (srfi 259))
 
 (test-begin "SRFI 259")
 
@@ -40,10 +40,11 @@
     (test "tagged procedure is callable" 110 (tagged 10))
     (test "var has changed" 110 var)
     (test-assert "not tag-baz?" (not (tag-baz? tagged)))
-    (test-assert "get-tag-baz raises an exception"
-                 (handle-exceptions exn #t
-                   (get-tag-baz tagged)
-                   #f))
+    (test "get-tag-baz raises an exception"
+          'assertion
+          (condition-case (begin (get-tag-baz tagged) 'success)
+                          ((exn assertion) 'assertion)
+                          (exn () 'error)))
     (test-group "tagged again"
       (let ((tagged-again (tag-foo 'quux tagged)))
         (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again))
@@ -74,12 +75,25 @@
     (test "get-tag-foo" 'foo (get-tag-foo tagged))
     (test "get-tag-baz" 'baz (get-tag-baz tagged))))
 
+(define-syntax raises-type-error
+  (syntax-rules ()
+    ((raises-type-error name expr)
+     (test name
+           'type
+           (condition-case (begin expr 'success)
+                           ((exn type) 'type)
+                           (var () (display (condition->list var)) 'error))))))
+
 (test-group "predicates on other objects"
   (test-assert "integers are not tagged" (not (tag-foo? 0)))
+  (raises-type-error "integers are not tagged" (tag-foo 'data 0))
   (test-assert "strings are not tagged" (not (tag-foo? "hello")))
+  (raises-type-error "strings are not tagged" (tag-foo 'data "hello"))
   (test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4))))
+  (raises-type-error "bytevectors are not tagged" (tag-foo 'data #u8(1 2 3 4)))
   (test-assert "vectors are not tagged" (not (tag-foo? #(call/cc))))
+  (raises-type-error "vectors are not tagged" (tag-foo 'data #(call/cc)))
   (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
-  (test-assert "non-tagged procedures are not tagged" (not (tag-foo? call/cc))))
+  (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))
 
 (test-end "SRFI 259")