;;;; 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: src.lisp,v 1.4 2003/08/23 12:56:29 kevin Exp $
(defpackage #:ptester
(:use #:cl)
(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)
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*
(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
(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????
(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)