From 6b4113afc5a0010eef2e9edae2cbd5f6b690be41 Mon Sep 17 00:00:00 2001
From: Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
Date: Wed, 28 Feb 2001 11:25:40 +0000
Subject: [PATCH] * Provide and use new convenience macros to test for
 exceptions.

---
 test-suite/lib.scm                 |  58 +++++++++-
 test-suite/tests/alist.test        | 137 ++++++++--------------
 test-suite/tests/environments.test |  82 +++++--------
 test-suite/tests/eval.test         |  66 ++++-------
 test-suite/tests/hooks.test        | 111 +++++++-----------
 test-suite/tests/list.test         | 180 +++++++++--------------------
 test-suite/tests/ports.test        |   5 +-
 test-suite/tests/reader.test       |  37 +++---
 test-suite/tests/strings.test      |  17 +--
 test-suite/tests/weaks.test        |  71 ++++--------
 10 files changed, 292 insertions(+), 472 deletions(-)

diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 471ce5ace..867b8eb7a 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -16,12 +16,18 @@
 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 ;;;; Boston, MA 02111-1307 USA
 
-(define-module (test-suite lib))
+(define-module (test-suite lib)
+  :use-module (ice-9 regex))
 
 (export
 
+ ;; Exceptions which are commonly being tested for.
+ exception:out-of-range exception:wrong-type-arg
+
  ;; Reporting passes and failures.
- run-test pass-if expect-fail
+ run-test
+ pass-if expect-fail
+ pass-if-exception expect-fail-exception
 
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
@@ -67,7 +73,9 @@
 ;;;; environment.  All other exceptions thrown by THUNK are considered as
 ;;;; errors.
 ;;;;
-;;;; For convenience, the following macros are provided:
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
 ;;;; * (pass-if name body) is a short form for 
 ;;;;   (run-test name #t (lambda () body))
 ;;;; * (expect-fail name body) is a short form for 
@@ -76,7 +84,24 @@
 ;;;; For example:  
 ;;;;
 ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
-
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;;   body causes the given exception to be thrown.  If no exception is
+;;;;   thrown, the test fails.  If some other exception is thrown, is is an
+;;;;   error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;;   the execution of body causes the given exception to be thrown.  If no
+;;;;   exception is thrown, the test fails expectedly.  If some other
+;;;;   exception is thrown, it is an error.
 
 
 ;;;; TEST NAMES
@@ -194,6 +219,12 @@
 ;;;; MISCELLANEOUS
 ;;;;
 
+;;; Define some exceptions which are commonly being tested for.
+(define exception:out-of-range
+  (cons 'out-of-range "^Argument .*out of range"))
+(define exception:wrong-type-arg
+  (cons 'wrong-type-arg "^Wrong type argument"))
+
 ;;; Display all parameters to the default output port, followed by a newline.
 (define (display-line . objs)
   (for-each display objs)
@@ -247,6 +278,25 @@
 (defmacro expect-fail (name body . rest)
   `(run-test ,name #f (lambda () ,body ,@rest)))
 
+;;; A helper function to implement the macros that test for exceptions.
+(define (run-test-exception name exception expect-pass thunk)
+  (run-test name expect-pass
+    (lambda ()
+      (catch (car exception)
+	(lambda () (thunk) #f)
+	(lambda (key proc message . rest) 
+	  (if (not (string-match (cdr exception) message))
+	      (apply throw key proc message rest)
+	      #t))))))
+
+;;; A short form for tests that expect a certain exception to be thrown.
+(defmacro pass-if-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(defmacro expect-fail-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+
 
 ;;;; TEST NAMES
 ;;;;
diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test
index a984ba82a..796d3b193 100644
--- a/test-suite/tests/alist.test
+++ b/test-suite/tests/alist.test
@@ -104,25 +104,18 @@
 	     (and (pair? x)
 		  (eq? (car x) 'c)
 		  (eq? (cdr x) 'd))))
-  (pass-if "assq deformed"
-	   (catch 'wrong-type-arg
-		  (lambda ()
-		    (assq 'x deformed))
-		  (lambda (key . args)
-		    #t)))
+  (pass-if-exception "assq deformed"
+    exception:wrong-type-arg
+    (assq 'x deformed))
   (pass-if-not "assq not" (assq 'r a))
   (pass-if "assv"
 	   (let ((x (assv 'a a)))
 	     (and (pair? x)
 		  (eq? (car x) 'a)
 		  (eq? (cdr x) 'b))))
-  (pass-if "assv deformed"
-	   (catch 'wrong-type-arg
-		  (lambda ()
-		    (assv 'x deformed)
-		    #f)
-		  (lambda (key . args)
-		    #t)))
+  (pass-if-exception "assv deformed"
+    exception:wrong-type-arg
+    (assv 'x deformed))
   (pass-if-not "assv not" (assq "this" b))
 
   (pass-if "assoc"
@@ -130,13 +123,9 @@
 	     (and (pair? x)
 		  (string=? (car x) "this")
 		  (string=? (cdr x) "is"))))
-  (pass-if "assoc deformed"
-	   (catch 'wrong-type-arg
-		  (lambda ()
-		    (assoc 'x deformed)
-		    #f)
-		  (lambda (key . args)
-		    #t)))
+  (pass-if-exception "assoc deformed"
+    exception:wrong-type-arg
+    (assoc 'x deformed))
   (pass-if-not "assoc not" (assoc "this isn't" b)))
 
 
@@ -168,32 +157,20 @@
 
   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 
 
-    (pass-if "assv-ref deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assv-ref deformed 'sloppy)
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (pass-if-exception "assv-ref deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assv-ref deformed 'sloppy))
 
-    (pass-if "assoc-ref deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assoc-ref deformed 'sloppy)
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (pass-if-exception "assoc-ref deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assoc-ref deformed 'sloppy))
 
-    (pass-if "assq-ref deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assq-ref deformed 'sloppy)
-	  #f)
-	(lambda (key . args)
-	  #t)))))
+    (pass-if-exception "assq-ref deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assq-ref deformed 'sloppy))))
 
 
 ;;; Setters
@@ -241,32 +218,20 @@
 
   (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 
 
-    (pass-if "assq-set! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assq-set! deformed 'cold '(very cold))
-	  #f)
-	(lambda (key . args)
-	  #t)))   
+    (pass-if-exception "assq-set! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assq-set! deformed 'cold '(very cold)))   
 
-    (pass-if "assv-set! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assv-set! deformed 'canada 'Canada)
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (pass-if-exception "assv-set! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assv-set! deformed 'canada 'Canada))
 
-    (pass-if "assoc-set! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
-	  (assoc-set! deformed 'canada '(Iceland hence the name))
-	  #f)
-	(lambda (key . args)
-	  #t)))))
+    (pass-if-exception "assoc-set! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+      (assoc-set! deformed 'canada '(Iceland hence the name)))))
 
 ;;; Removers
 
@@ -288,29 +253,17 @@
 
   (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) 
 
-    (pass-if "assq-remove! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
-	  (assq-remove! deformed 'puddle)
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (pass-if-exception "assq-remove! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+      (assq-remove! deformed 'puddle))
 
-    (pass-if "assv-remove! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
-	  (assv-remove! deformed 'splashing)
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (pass-if-exception "assv-remove! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+      (assv-remove! deformed 'splashing))
 
-    (pass-if "assoc-remove! deformed"
-      (catch 'wrong-type-arg
-	(lambda ()
-	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
-	  (assoc-remove! deformed 'fun)
-	  #f)
-	(lambda (key . args)
-	  #t)))))
+    (pass-if-exception "assoc-remove! deformed"
+      exception:wrong-type-arg
+      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+      (assoc-remove! deformed 'fun))))
diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test
index 647b1594e..895850d16 100644
--- a/test-suite/tests/environments.test
+++ b/test-suite/tests/environments.test
@@ -47,6 +47,8 @@
 ;;; miscellaneous
 ;;;
 
+(define exception:unbound-symbol
+  (cons 'misc-error "^Symbol .* not bound in environment"))
 
 (define (documented? object)
   (not (not (object-documentation object))))
@@ -173,37 +175,21 @@
 	  (environment-define env 'a #f)
 	  (not (eq? (environment-cell env 'a #t) cell)))))
 
-    (pass-if "reference an undefined symbol"
-      (catch #t
-	(lambda ()
-	  (environment-ref (make-leaf-environment) 'a)
-	  #f)
-	(lambda args
-	  #t)))
+    (pass-if-exception "reference an unbound symbol"
+      exception:unbound-symbol
+      (environment-ref (make-leaf-environment) 'a))
 
-    (pass-if "set! an undefined symbol"
-      (catch #t
-	(lambda ()
-	  (environment-set! (make-leaf-environment) 'a)
-	  #f)
-	(lambda args
-	  #t)))
+    (pass-if-exception "set! an unbound symbol"
+      exception:unbound-symbol
+      (environment-set! (make-leaf-environment) 'a #f))
 
-    (pass-if "get a readable cell for an undefined symbol"
-      (catch #t
-	(lambda ()
-	  (environment-cell (make-leaf-environment) 'a #f)
-	  #f)
-	(lambda args
-	  #t)))
+    (pass-if-exception "get a readable cell for an unbound symbol"
+      exception:unbound-symbol
+      (environment-cell (make-leaf-environment) 'a #f))
 
-    (pass-if "get a writable cell for an undefined symbol"
-      (catch #t
-	(lambda ()
-	  (environment-cell (make-leaf-environment) 'a #t)
-	  #f)
-	(lambda args
-	  #t))))
+    (pass-if-exception "get a writable cell for an unbound symbol"
+      exception:unbound-symbol
+      (environment-cell (make-leaf-environment) 'a #t)))
 
 
   (with-test-prefix "undefine"
@@ -621,37 +607,21 @@
 	   (imported (make-leaf-environment))
 	   (env (make-eval-environment local imported)))
 
-      (pass-if "reference an undefined symbol"
-	(catch #t
-	  (lambda ()
-	    (environment-ref env 'b)
-	    #f)
-	  (lambda args
-	    #t)))
+      (pass-if-exception "reference an unbound symbol"
+	exception:unbound-symbol
+	(environment-ref env 'b))
 
-      (pass-if "set! an undefined symbol"
-	(catch #t
-	  (lambda ()
-	    (environment-set! env 'b)
-	    #f)
-	  (lambda args
-	    #t)))
+      (pass-if-exception "set! an unbound symbol"
+	exception:unbound-symbol
+	(environment-set! env 'b #f))
 
-      (pass-if "get a readable cell for an undefined symbol"
-	(catch #t
-	  (lambda ()
-	    (environment-cell env 'b #f)
-	    #f)
-	  (lambda args
-	    #t)))
+      (pass-if-exception "get a readable cell for an unbound symbol"
+	exception:unbound-symbol
+	(environment-cell env 'b #f))
 
-      (pass-if "get a writable cell for an undefined symbol"
-	(catch #t
-	  (lambda ()
-	    (environment-cell env 'b #t)
-	    #f)
-	  (lambda args
-	    #t)))))
+      (pass-if-exception "get a writable cell for an unbound symbol"
+	exception:unbound-symbol
+	(environment-cell env 'b #t))))
 
   (with-test-prefix "eval-environment-set-local!"
 
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 552f3eb19..c06542f06 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -47,7 +47,6 @@
 ;;; miscellaneous
 ;;;
 
-
 (define (documented? object)
   (not (not (object-documentation object))))
 
@@ -64,24 +63,17 @@
     ;; Macros are accepted as function parameters.
     ;; Functions that 'apply' macros are rewritten!!!
 
-    (expect-fail "macro as argument"
+    (expect-fail-exception "macro as argument"
+      exception:wrong-type-arg
       (let ((f (lambda (p a b) (p a b))))
-	(catch 'wrong-type-arg
-	  (lambda ()
-	    (f and #t #t)
-	    #f)
-	  (lambda (key . args)
-	    #t))))
+	(f and #t #t)))
 
-    (expect-fail "application of macro"
-      (let ((f (lambda (p a b) (p a b))))
-	(catch 'wrong-type-arg
-	  (lambda ()
-            (let ((foo (procedure-source f)))
-	      (f and #t #t)
-	      (equal? (procedure-source f) foo)))
-	  (lambda (key . args)
-	    #t))))
+    (expect-fail-exception "passing macro as parameter"
+      exception:wrong-type-arg
+      (let* ((f (lambda (p a b) (p a b)))
+	     (foo (procedure-source f)))
+	(f and #t #t)
+	(equal? (procedure-source f) foo)))
 
     ))
 
@@ -103,35 +95,19 @@
 
     (with-test-prefix "different length lists"
 
-      (pass-if "first list empty"
-	(catch 'out-of-range
-	  (lambda ()
-	    (map + '() '(1))
-	    #f)
-	  (lambda (key . args)
-	    #t)))
+      (pass-if-exception "first list empty"
+	exception:out-of-range
+	(map + '() '(1)))
 
-      (pass-if "second list empty"
-	(catch 'out-of-range
-	  (lambda ()
-	    (map + '(1) '())
-	    #f)
-	  (lambda (key . args)
-	    #t)))
+      (pass-if-exception "second list empty"
+	exception:out-of-range
+	(map + '(1) '()))
 
-      (pass-if "first list shorter"
-	(catch 'out-of-range
-	  (lambda ()
-	    (map + '(1) '(2 3))
-	    #f)
-	  (lambda (key . args)
-	    #t)))
+      (pass-if-exception "first list shorter"
+	exception:out-of-range
+	(map + '(1) '(2 3)))
 
-      (pass-if "second list shorter"
-	(catch 'out-of-range
-	  (lambda ()
-	    (map + '(1 2) '(3))
-	    #f)
-	  (lambda (key . args)
-	    #t)))
+      (pass-if-exception "second list shorter"
+	exception:out-of-range
+	(map + '(1 2) '(3)))
     )))
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index c4f3ec608..1f309e5f2 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -40,51 +40,32 @@
 ;;;; whether to permit this exception to apply to your modifications.
 ;;;; If you do not wish that, delete this exception notice.  
 
-;;; {Description} 
 ;;;
-;;; A test suite for hooks. I maybe should've split off some of the
-;;; stuff (like with alists), but this is small enough that it
-;;; probably isn't worth the hassle. A little note: in some places it
-;;; catches all errors when it probably shouldn't, since there's only
-;;; one error we consider correct. This is mostly because the
-;;; add-hook! error in released guiles isn't really accurate
-;;; This should be changed once a released version returns
-;;; wrong-type-arg from add-hook!
+;;; miscellaneous
+;;;
 
-;; {Utility stuff}
-;; Evaluate form inside a catch; if it throws an error, return true
-;; This is good for checking that errors are not ignored 
+;; FIXME:  Maybe a standard wrong-num-arg exception should be thrown instead
+;; of a misc-error?  If so, the tests should be changed to expect failure.
+(define exception:wrong-num-hook-args
+  (cons 'misc-error "Hook .* requires .* arguments"))
 
-(define-macro (catch-error-returning-true error . form)
-  `(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t)))
+;;;
+;;; {The tests}
+;;;
 
-;; Evaluate form inside a catch; if it throws an error, return false
-;; Good for making sure that errors don't occur
-
-(define-macro (catch-error-returning-false error . form)
-  `(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
-
-;; pass-if-not: syntactic sugar
-
-(define-macro (pass-if-not string form)
-  `(pass-if ,string (not ,form)))
-
-;; {The tests}
- (let  ((proc1 (lambda (x) (+ x 1)))
+(let  ((proc1 (lambda (x) (+ x 1)))
        (proc2 (lambda (x) (- x 1)))
        (bad-proc (lambda (x y) #t)))
   (with-test-prefix "hooks"
    (pass-if "make-hook"
-	    (catch-error-returning-false 
-	     #t
-	     (define x (make-hook 1))))
+     (make-hook 1)
+     #t)
 
    (pass-if "add-hook!"
-	    (catch-error-returning-false 
-	     #t
-	     (let ((x (make-hook 1)))
-	       (add-hook! x proc1)
-	       (add-hook! x proc2))))
+     (let ((x (make-hook 1)))
+       (add-hook! x proc1)
+       (add-hook! x proc2)
+       #t))
 
    (with-test-prefix "add-hook!"
 		     (pass-if "append"
@@ -93,34 +74,30 @@
 				(add-hook! x proc2 #t)
 				(eq? (cadr (hook->list x))
 				     proc2)))
-		     (pass-if "illegal proc"
-			      (catch-error-returning-true 
-			       #t 
-			       (let ((x (make-hook 1)))
-				 (add-hook! x bad-proc))))
-		     (pass-if "illegal hook"
-			      (catch-error-returning-true
-			       'wrong-type-arg
-			       (add-hook! '(foo) proc1))))
+		     (pass-if-exception "illegal proc"
+		       exception:wrong-type-arg
+		       (let ((x (make-hook 1)))
+			 (add-hook! x bad-proc)))
+		     (pass-if-exception "illegal hook"
+		       exception:wrong-type-arg
+		       (add-hook! '(foo) proc1)))
    (pass-if "run-hook"
 	    (let ((x (make-hook 1)))
-	      (catch-error-returning-false #t
-					   (add-hook! x proc1)
-					   (add-hook! x proc2)
-					   (run-hook x 1))))
+	      (add-hook! x proc1)
+	      (add-hook! x proc2)
+	      (run-hook x 1)
+	      #t))
   (with-test-prefix "run-hook"
-		    (pass-if "bad hook"
-				 (catch-error-returning-true
-				  #t
-				  (let ((x (cons 'a 'b)))
-				    (run-hook x 1))))
-		    (pass-if "too many args"
-				 (let ((x (make-hook 1)))
-				   (catch-error-returning-true
-				    #t
-				    (add-hook! x proc1)
-				    (add-hook! x proc2)
-				    (run-hook x 1 2))))
+		    (pass-if-exception "bad hook"
+		      exception:wrong-type-arg
+		      (let ((x (cons 'a 'b)))
+			(run-hook x 1)))
+		    (pass-if-exception "too many args"
+		      exception:wrong-num-hook-args
+		      (let ((x (make-hook 1)))
+			(add-hook! x proc1)
+			(add-hook! x proc2)
+			(run-hook x 1 2)))
 
 		    (pass-if 
 		     "destructive procs"
@@ -146,10 +123,9 @@
 		    ; Maybe it should error, but this is probably
 		    ; more convienient
 		    (pass-if "empty hook"
-			     (catch-error-returning-false
-			      #t
-			      (let ((x (make-hook 1)))
-				(remove-hook! x proc1)))))
+		      (let ((x (make-hook 1)))
+			(remove-hook! x proc1)
+			#t)))
   (pass-if "hook->list"
 	   (let ((x (make-hook 1)))
 	     (add-hook! x proc1)
@@ -168,7 +144,6 @@
 			     (let ((x (make-hook 1)))
 			       (reset-hook! x)
 			       #t))
-		    (pass-if "bad hook"
-			     (catch-error-returning-true
-			      #t
-			      (reset-hook! '(a b)))))))
+		    (pass-if-exception "bad hook"
+                      exception:wrong-type-arg
+		      (reset-hook! '(a b))))))
diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test
index 22e898879..746eeb8ad 100644
--- a/test-suite/tests/list.test
+++ b/test-suite/tests/list.test
@@ -375,29 +375,17 @@
 
   (with-test-prefix "wrong argument"
 
-    (expect-fail "improper list and empty list"
-      (catch 'wrong-type-arg
-	(lambda () 
-	  (append! (cons 1 2) '())
-	  #f)
-	(lambda (key . args) 
-	  #t)))
+    (expect-fail-exception "improper list and empty list"
+      exception:wrong-type-arg
+      (append! (cons 1 2) '()))
 
-    (expect-fail "improper list and list"
-      (catch 'wrong-type-arg
-	(lambda () 
-	  (append! (cons 1 2) (list 3 4))
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (expect-fail-exception "improper list and list"
+      exception:wrong-type-arg
+      (append! (cons 1 2) (list 3 4)))
 
-    (expect-fail "list, improper list and list"
-      (catch 'wrong-type-arg
-	(lambda () 
-	  (append! (list 1 2) (cons 3 4) (list 5 6))
-	  #f)
-	(lambda (key . args)
-	  #t)))
+    (expect-fail-exception "list, improper list and list"
+      exception:wrong-type-arg
+      (append! (list 1 2) (cons 3 4) (list 5 6)))
 
     (expect-fail "circular list and empty list"
       (let ((foo (list 1 2 3)))
@@ -473,47 +461,27 @@
 
       (with-test-prefix "empty list"
 
-	(pass-if "index 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-ref '() 0)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index 0"
+	  exception:out-of-range
+	  (list-ref '() 0))
 
-	(pass-if "index > 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-ref '() 1)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > 0"
+	  exception:out-of-range
+	  (list-ref '() 1))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-ref '() -1)
-	      #f)
-	    (lambda (key . args)
-	      #t))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-ref '() -1)))
 
       (with-test-prefix "non-empty list"
 
-	(pass-if "index > length"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-ref '(1) 1)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > length"
+	  exception:out-of-range
+	  (list-ref '(1) 1))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-ref '(1) -1)
-	      #f)
-	    (lambda (key . args)
-	      #t)))))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-ref '(1) -1))))))
 
 
 ;;; list-set!
@@ -541,47 +509,27 @@
 
       (with-test-prefix "empty list"
 
-	(pass-if "index 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-set! (list) 0 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index 0"
+	  exception:out-of-range
+	  (list-set! (list) 0 #t))
 
-	(pass-if "index > 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-set! (list) 1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > 0"
+	  exception:out-of-range
+	  (list-set! (list) 1 #t))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-set! (list) -1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-set! (list) -1 #t)))
 
       (with-test-prefix "non-empty list"
 
-	(pass-if "index > length"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-set! (list 1) 1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > length"
+	  exception:out-of-range
+	  (list-set! (list 1) 1 #t))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-set! (list 1) -1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-set! (list 1) -1 #t))))))
 
 
 ;;; list-cdr-ref
@@ -615,47 +563,27 @@
 
       (with-test-prefix "empty list"
 
-	(pass-if "index 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-cdr-set! (list) 0 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index 0"
+	  exception:out-of-range
+	  (list-cdr-set! (list) 0 #t))
 
-	(pass-if "index > 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-cdr-set! (list) 1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > 0"
+	  exception:out-of-range
+	  (list-cdr-set! (list) 1 #t))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-cdr-set! (list) -1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-cdr-set! (list) -1 #t)))
 
       (with-test-prefix "non-empty list"
 
-	(pass-if "index > length"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-cdr-set! (list 1) 1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))
+	(pass-if-exception "index > length"
+	  exception:out-of-range
+	  (list-cdr-set! (list 1) 1 #t))
 
-	(pass-if "index < 0"
-	  (catch 'out-of-range
-	    (lambda ()
-	      (list-cdr-set! (list 1) -1 #t)
-	      #f)
-	    (lambda (key . args)
-	      #t)))))))
+	(pass-if-exception "index < 0"
+	  exception:out-of-range
+	  (list-cdr-set! (list 1) -1 #t))))))
 
 
 ;;; list-head
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index dbdca077c..5429b20f7 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -427,7 +427,8 @@
 		  (call-with-input-string "foo" (lambda (p) p))
 		(lambda ()
 		  (close-port (current-input-port))
-		  (pass-if name
-			   (signals-error? 'wrong-type-arg (procedure))))))
+		  (pass-if-exception name
+		    exception:wrong-type-arg
+		    (procedure)))))
 	    (list read read-char read-line)
 	    '("read" "read-char" "read-line")))
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 97c89c5a7..41e8566c5 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,25 +1,22 @@
 ;;;; reader.test --- test the Guile parser -*- scheme -*-
 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
 
-(define (try-to-read string)
-  (pass-if (call-with-output-string (lambda (port)
-				      (display "Try to read " port)
-				      (write string port)))
-	   (not (signals-error? 
-		 'signal
-		 (call-with-input-string string 
-					 (lambda (p) (read p)))))))
+(define (read-string s)
+  (with-input-from-string s (lambda () (read))))
 
-(try-to-read "0")
-(try-to-read "1++i")
-(try-to-read "1+i+i")
-(try-to-read "1+e10000i")
+(with-test-prefix "reading"
+  (pass-if "0"
+    (equal? (read-string "0") 0))
+  (pass-if "1++i"
+    (equal? (read-string "1++i") '1++i))
+  (pass-if "1+i+i"
+    (equal? (read-string "1+i+i") '1+i+i))
+  (pass-if "1+e10000i"
+    (equal? (read-string "1+e10000i") '1+e10000i)))
 
-(pass-if "radix passed to number->string can't be zero"
-	 (signals-error?
-	  'out-of-range
-	  (number->string 10 0)))
-(pass-if "radix passed to number->string can't be one either"
-	 (signals-error?
-	  'out-of-range
-	  (number->string 10 1)))
+(pass-if-exception "radix passed to number->string can't be zero"
+  exception:out-of-range
+  (number->string 10 0))
+(pass-if-exception "radix passed to number->string can't be one either"
+  exception:out-of-range
+  (number->string 10 1))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index ffd3fab35..5645f1fbb 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -21,19 +21,14 @@
 (use-modules (test-suite lib))
 
 
-(pass-if "string=? does not accept symbols"
-  (catch 'wrong-type-arg
-    (lambda ()
-      (string=? 'a 'b)
-      #f)
-    (lambda args
-      #t)))
+(pass-if-exception "string=? does not accept symbols"
+  exception:wrong-type-arg
+  (string=? 'a 'b))
 
 (pass-if "string<? respects string length"
 	 (not (string<? "foo\0" "foo")))
 (pass-if "string-ci<? respects string length"
 	 (not (string-ci<? "foo\0" "foo")))
-(pass-if "substring-move! checks start and end correctly"
-	 (signals-error?
-	  'out-of-range
-	  (substring-move! "sample" 3 0 "test" 3)))
+(pass-if-exception "substring-move! checks start and end correctly"
+  exception:out-of-range
+  (substring-move! "sample" 3 0 "test" 3))
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index c7f0947cd..b5be62da5 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -58,20 +58,6 @@
 ;;; other reasons why they might not work as tested here, so if you
 ;;; haven't done anything to weaks, don't sweat it :)
 
-;;; Utility stuff (maybe these should go in lib? They're pretty useful
-;;; at keeping the code size down)
-
-;; Evaluate form inside a catch; if it throws, return false
-
-(define-macro (catch-error-returning-false error . form)
-  `(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
-
-(define-macro (catch-error-returning-true error . form)
-  `(catch ,error (lambda () (begin ,@form #f)) (lambda args #t)))
-
-(define-macro (pass-if-not string form)
-  `(pass-if ,string (not ,form)))
-
 ;;; Creation functions 
 
 
@@ -79,12 +65,11 @@
  "weak-creation"
  (with-test-prefix "make-weak-vector"
   (pass-if "normal"
-	   (catch-error-returning-false #t
-	   (define x (make-weak-vector 10 #f))))
-  (pass-if "bad size"
-	   (catch-error-returning-true 
-	    'wrong-type-arg
-	    (define x (make-weak-vector 'foo)))))
+    (make-weak-vector 10 #f)
+    #t)
+  (pass-if-exception "bad size"
+    exception:wrong-type-arg
+    (make-weak-vector 'foo)))
 
  (with-test-prefix "list->weak-vector"
 		   (pass-if "create"
@@ -97,42 +82,32 @@
 				   (eq? (vector-ref wv 4) 'e)
 				   (eq? (vector-ref wv 5) 'f)
 				   (eq? (vector-ref wv 6) 'g))))
-		   (pass-if "bad-args"
-			    (catch-error-returning-true 
-			     'wrong-type-arg
-			     (define x (list->weak-vector 32)))))
+		   (pass-if-exception "bad-args"
+		     exception:wrong-type-arg
+		     (list->weak-vector 32)))
 
  (with-test-prefix "make-weak-key-hash-table"
 		   (pass-if "create"
-			    (catch-error-returning-false 
-			     #t
-			     (define x (make-weak-key-hash-table 17))))
-		   (pass-if "bad-args"
-			    (catch-error-returning-true 
-			     'wrong-type-arg
-			     (define x 
-			       (make-weak-key-hash-table '(bad arg))))))
+		     (make-weak-key-hash-table 17)
+		     #t)
+		   (pass-if-exception "bad-args"
+		     exception:wrong-type-arg
+		     (make-weak-key-hash-table '(bad arg))))
  (with-test-prefix "make-weak-value-hash-table"
 		   (pass-if "create"
-			    (catch-error-returning-false 
-			     #t
-			     (define x (make-weak-value-hash-table 17))))
-		   (pass-if "bad-args"
-			    (catch-error-returning-true 
-			     'wrong-type-arg
-			     (define x 
-			       (make-weak-value-hash-table '(bad arg))))))
+		     (make-weak-value-hash-table 17)
+		     #t)
+		   (pass-if-exception "bad-args"
+		     exception:wrong-type-arg
+		     (make-weak-value-hash-table '(bad arg))))
 
  (with-test-prefix "make-doubly-weak-hash-table"
 		   (pass-if "create"
-			    (catch-error-returning-false 
-			     #t
-			     (define x (make-doubly-weak-hash-table 17))))
-		   (pass-if "bad-args"
-			    (catch-error-returning-true 
-			     'wrong-type-arg
-			     (define x 
-			       (make-doubly-weak-hash-table '(bad arg)))))))
+		     (make-doubly-weak-hash-table 17)
+		     #t)
+		   (pass-if-exception "bad-args"
+		     exception:wrong-type-arg
+		     (make-doubly-weak-hash-table '(bad arg)))))