* Make sure that tests return a boolean value.

test-suite/ChangeLog

@@ -1,3 +1,17 @@
+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.

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)

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)

test-suite/tests/common-list.test

@@ -50,7 +50,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;

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))

test-suite/tests/eval.test

@@ -49,7 +49,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;

test-suite/tests/gc.test

@@ -49,7 +49,7 @@
 
 
 (define (documented? object)
-  (object-documentation object))
+  (not (not (object-documentation object))))
 
 
 ;;;

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)))))

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) )
+	     (and (memq proc1 (hook->list x))
-		  (memq proc2 (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

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
 

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?"
-
+    (documented? append!))
-  (pass-if "documented?" (object-documentation 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?"
-
+    (documented? list-ref))
-  (pass-if "documented?" (object-documentation list-ref))
 
   (with-test-prefix "argument error"
     
@@ -519,9 +520,8 @@
 
 (with-test-prefix "list-set!"
 
-  ;; Is documentation available?
+  (pass-if "documented?"
-
+    (documented? list-set!))
-  (pass-if "documented?" (object-documentation list-set!))
 
   (with-test-prefix "argument error"
     
@@ -594,9 +594,8 @@
 
 (with-test-prefix "list-cdr-set!"
 
-  ;; Is documentation available?
+  (pass-if "documented?"
-
+    (documented? list-cdr-set!))
-  (pass-if "documented?" (object-documentation list-cdr-set!))
 
   (with-test-prefix "argument error"
     

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)

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)))))