* Make sure that tests return a boolean value.

13 files changed, 48 insertions, 29 deletions

diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index e37c2f5b8..55dc1dd64 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,5 +1,19 @@
 2001-02-27  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
+	* lib.scm (pass-if):  Tests shall return a boolean value.
+
+	* tests/bit-operations.test (documented?), tests/common-list.test
+	(documented?), tests/environments.test (documented?),
+	tests/eval.test (documented?), tests/gc.test (documented?),
+	tests/numbers.test (documented?), tests/guardians.test,
+	tests/hooks.test, tests/interp.test, tests/weaks.test:  Make sure
+	that tests return a boolean value.
+
+	* tests/list.test (documented?):  New function, replace all checks
+	for documentation with calls to this function.
+
+2001-02-27  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
 	* lib.scm (data-file):  Remove from export list.
 
 2001-02-22  Thien-Thi Nguyen  <ttn@revel.glug.org>
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index e0669eb63..471ce5ace 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -241,7 +241,7 @@
 
 ;;; A short form for tests that are expected to pass, taken from Greg.
 (defmacro pass-if (name body . rest)
-  `(run-test ,name #t (lambda () (not (not (begin ,body ,@rest))))))
+  `(run-test ,name #t (lambda () ,body ,@rest)))
 
 ;;; A short form for tests that are expected to fail, taken from Greg.
 (defmacro expect-fail (name body . rest)
diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test
index 469d63073..46c9fe1b8 100644
--- a/test-suite/tests/bit-operations.test
+++ b/test-suite/tests/bit-operations.test
@@ -55,7 +55,7 @@
    arg-sets))
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 (define fixnum-bit 30)
 (define fixnum-min most-negative-fixnum)
diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test
index 349ba9e4f..6e404f7a8 100644
--- a/test-suite/tests/common-list.test
+++ b/test-suite/tests/common-list.test
@@ -50,7 +50,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;
diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test
index 908ec5ab7..647b1594e 100644
--- a/test-suite/tests/environments.test
+++ b/test-suite/tests/environments.test
@@ -49,7 +49,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 (define (folder sym val res)
   (cons (cons sym val) res))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index ba6a4ef7e..552f3eb19 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -49,7 +49,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index c997320e3..7afeb4226 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -49,7 +49,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;
diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test
index 4d8eac678..8d5a6eb2b 100644
--- a/test-suite/tests/guardians.test
+++ b/test-suite/tests/guardians.test
@@ -59,7 +59,7 @@
 	     (else (set! seen-something-else #t)))
 	    (loop)))))
   (pass-if "g3-garbage saved" seen-g3-garbage)
-  (pass-if "g2-saved" seen-g2)
+  (pass-if "g2-saved" (procedure? seen-g2))
   (pass-if "nothing else saved" (not seen-something-else))
   (pass-if "g2-garbage saved" (and (procedure? seen-g2)
 				   (equal? (seen-g2) '(g2-garbage)))))
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index 21a357122..c4f3ec608 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -154,8 +154,9 @@
 	   (let ((x (make-hook 1)))
 	     (add-hook! x proc1)
 	     (add-hook! x proc2)
-	     (and (memq proc1 (hook->list x) )
-		  (memq proc2 (hook->list x)))))
+	     (and (memq proc1 (hook->list x))
+		  (memq proc2 (hook->list x))
+		  #t)))
   (pass-if "reset-hook!"
 	   (let ((x (make-hook 1)))
 	     (add-hook! x proc1)
@@ -165,7 +166,8 @@
   (with-test-prefix "reset-hook!"
 		    (pass-if "empty hook"
 			     (let ((x (make-hook 1)))
-			       (reset-hook! x)))
+			       (reset-hook! x)
+			       #t))
 		    (pass-if "bad hook"
 			     (catch-error-returning-true
 			      #t
diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test
index fb6e4d6f0..ac346b256 100644
--- a/test-suite/tests/interp.test
+++ b/test-suite/tests/interp.test
@@ -22,14 +22,14 @@
 			 (or arg (and (procedure? foo)
 				      (foo 99))))))
 	   (define bar (foo #f))
-	   (foo #f)))
+	   (= (foo #f) 99)))
 
 (pass-if "Internal defines 2"
 	 (letrec ((foo 77)
 		  (bar #f)
 		  (retfoo (lambda () foo)))
 	   (define baz (retfoo))
-	   (retfoo)))
+	   (= (retfoo) 77)))
 
 ;; Test that evaluation of closure bodies works as it should
 
diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test
index 734c50629..22e898879 100644
--- a/test-suite/tests/list.test
+++ b/test-suite/tests/list.test
@@ -47,6 +47,9 @@
 ;;; miscellaneous
 ;;;
 
+(define (documented? object)
+  (not (not (object-documentation object))))
+
 ;;
 ;; This unique tag is reserved for the unroll and diff-unrolled functions.
 ;;
@@ -161,9 +164,8 @@
 
 (with-test-prefix "append!"
 
-  ;; Is documentation available?
-
-  (pass-if "documented?" (object-documentation append!))
+  (pass-if "documented?"
+    (documented? append!))
 
   ;; Is the handling of empty lists as arguments correct?
 
@@ -453,9 +455,8 @@
 
 (with-test-prefix "list-ref"
 
-  ;; Is documentation available?
-
-  (pass-if "documented?" (object-documentation list-ref))
+  (pass-if "documented?"
+    (documented? list-ref))
 
   (with-test-prefix "argument error"
     
@@ -519,9 +520,8 @@
 
 (with-test-prefix "list-set!"
 
-  ;; Is documentation available?
-
-  (pass-if "documented?" (object-documentation list-set!))
+  (pass-if "documented?"
+    (documented? list-set!))
 
   (with-test-prefix "argument error"
     
@@ -594,9 +594,8 @@
 
 (with-test-prefix "list-cdr-set!"
 
-  ;; Is documentation available?
-
-  (pass-if "documented?" (object-documentation list-cdr-set!))
+  (pass-if "documented?"
+    (documented? list-cdr-set!))
 
   (with-test-prefix "argument error"
     
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 6a53e5d1a..3fc369aef 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -48,7 +48,7 @@
 ;;;
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 (define fixnum-bit 30)
 (define fixnum-min most-negative-fixnum)
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index c85bcf976..c7f0947cd 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -184,7 +184,8 @@
 	      (gc)
 	      (and (hashq-ref x test-key)
 		   (hashq-ref y test-key)
-		   (hashq-ref z test-key))))
+		   (hashq-ref z test-key)
+		   #t)))
    (pass-if "weak-key dies"
 	    (begin
 	      (hashq-set! x "this" "is")
@@ -199,7 +200,8 @@
 		   (not (hashq-ref x "of"))
 		   (not (hashq-ref x "emergency"))
 		   (not (hashq-ref x "key")))
-	       (hashq-ref x test-key))))
+	       (hashq-ref x test-key)
+	       #t)))
 
    (pass-if "weak-value dies"
 	    (begin
@@ -214,7 +216,8 @@
 		       (not (hashq-ref y "of"))
 		       (not (hashq-ref y "emergency"))
 		       (not (hashq-ref y "value")))
-		   (hashq-ref y test-key))))
+		   (hashq-ref y test-key)
+		   #t)))
    (pass-if "doubly-weak dies"
 	    (begin
 	      (hashq-set! z "this" "is")
@@ -228,4 +231,5 @@
 		       (not (hashq-ref z "of"))
 		       (not (hashq-ref z "emergency"))
 		       (not (hashq-ref z "all")))
-		   (hashq-ref z test-key))))))
+		   (hashq-ref z test-key)
+		   #t)))))