X-Git-Url: http://git.kpe.io/?p=ptester.git;a=blobdiff_plain;f=src.lisp;h=829e05afa8fa2a79ac35342acada0762660de217;hp=e659c90192559145b41b5cb64993e28e99845515;hb=d2bcc9b14efeda90589d94bb44ad773cb3771917;hpb=ef0d5d2330ef7f0da67d02d96c2941fd8ed29398

diff --git a/src.lisp b/src.lisp
index e659c90..829e05a 100644
--- a/src.lisp
+++ b/src.lisp
@@ -27,7 +27,7 @@
 ;;;; from the original ACL 6.1 sources:
 ;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
 
-;; $Id: src.lisp,v 1.2 2003/07/20 18:56:28 kevin Exp $
+;; $Id$
 
 (defpackage #:ptester
   (:use #:cl)
@@ -458,18 +458,22 @@ discriminate on new versus known failures."
 	    (if* (eq 'single-got-multiple fail)
 	       then (format
 		     *error-output*
-		     "Reason: additional value were returned from test form.~%")
+		     "~
+Reason: additional value were returned from test form.~%")
 	     elseif predicate-failed
 	       then (format *error-output* "Reason: predicate error.~%")
 	     elseif (null (car test-results))
-	       then (format *error-output* "Reason: an error~@[ (of type `~s')~] was detected.~%"
+	       then (format *error-output* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
 			    (when condition (class-of condition)))
 	     elseif condition
 	       then (if* (not (conditionp condition))
-		       then (format *error-output* "Reason: expected but did not detect an error of type `~s'.~%"
+		       then (format *error-output* "~
+Reason: expected but did not detect an error of type `~s'.~%"
 				    condition-type)
 		     elseif (null condition-type)
-		       then (format *error-output* "Reason: detected an unexpected error of type `~s':
+		       then (format *error-output* "~
+Reason: detected an unexpected error of type `~s':
         ~a.~%"
 				    (class-of condition)
 				    condition)
@@ -477,7 +481,8 @@ discriminate on new versus known failures."
 				    then (typep condition condition-type)
 				    else (eq (class-of condition)
 					     (find-class condition-type))))
-		       then (format *error-output* "Reason: detected an incorrect condition type.~%")
+		       then (format *error-output* "~
+Reason: detected an incorrect condition type.~%")
 			    (format *error-output*
 				    "  wanted: ~s~%" condition-type)
 			    (format *error-output*
@@ -491,7 +496,8 @@ discriminate on new versus known failures."
 					 (simple-condition-format-control
 					  condition)))))
 		       then ;; format control doesn't match
-			    (format *error-output* "Reason: the format-control was incorrect.~%")
+			    (format *error-output* "~
+Reason: the format-control was incorrect.~%")
 			    (format *error-output* "  wanted: ~s~%" wanted)
 			    (format *error-output* "     got: ~s~%" got)
 		     elseif (and format-arguments
@@ -500,7 +506,8 @@ discriminate on new versus known failures."
 				       (setq wanted
 					 (simple-condition-format-arguments
 					  condition)))))
-		       then (format *error-output* "Reason: the format-arguments were incorrect.~%")
+		       then (format *error-output* "~
+Reason: the format-arguments were incorrect.~%")
 			    (format *error-output* "  wanted: ~s~%" wanted)
 			    (format *error-output* "     got: ~s~%" got)
 		       else ;; what else????
@@ -557,25 +564,27 @@ discriminate on new versus known failures."
 		     (error (c)
 		       (format
 			*error-output*
-			"~&Test ~a aborted by signalling an uncaught error:~%~a~%"
+			"~
+~&Test ~a aborted by signalling an uncaught error:~%~a~%"
 			,g-name c))))
-	 #+allegro
-	 (let ((state (sys:gsgc-switch :print)))
-	   (setf (sys:gsgc-switch :print) nil)
+	 (let ((state (gc-print-state)))
+	   (setf (gc-print-state) nil)
 	   (format t "~&**********************************~%")
 	   (format t "End ~a test~%" ,g-name)
 	   (format t "Errors detected in this test: ~s " *test-errors*)
 	   (unless (zerop *test-unexpected-failures*)
 	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
 	   (format t "~%Successes this test:~s~%" *test-successes*)
-	   (setf (sys:gsgc-switch :print) state))
-	 #-allegro
-	 (progn
-	   (format t "~&**********************************~%")
-	   (format t "End ~a test~%" ,g-name)
-	   (format t "Errors detected in this test: ~D " *test-errors*)
-	   (unless (zerop *test-unexpected-failures*)
-	     (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
-	   (format t "~%Successes this test:~D~%" *test-successes*))))))
+	   (setf (gc-print-state) state))))))
+
+(defun gc-print-state ()
+  #+cmu ext:*gc-verbose*
+  #+allegro (sys:gsgc-switch :print)
+  )
+
+(defun (setf gc-print-state) (state)
+  #+cmu (setf ext:*gc-verbose* state)
+  #+allegro (setf (sys:gsgc-switch :print) state)
+  )
 
 (provide :tester #+module-versions 1.1)