;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
-;; the GNU Lesser General Public License as published by
+;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the Franz
;; preamble to the LGPL found in
;; http://opensource.franz.com/preamble.html.
#:test-no-error
#:test-warning
#:test-no-warning
-
+
#:with-tests
))
(defmacro if* (&rest args)
(do ((xx (reverse args) (cdr xx))
- (state :init)
- (elseseen nil)
- (totalcol nil)
- (lookat nil nil)
- (col nil))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
((null xx)
- (cond ((eq state :compl)
- `(cond ,@totalcol))
- (t (error "if*: illegal form ~s" args))))
+ (cond ((eq state :compl)
+ `(cond ,@totalcol))
+ (t (error "if*: illegal form ~s" args))))
(cond ((and (symbolp (car xx))
- (member (symbol-name (car xx))
- if*-keyword-list
- :test #'string-equal))
- (setq lookat (symbol-name (car xx)))))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
(cond ((eq state :init)
- (cond (lookat (cond ((string-equal lookat "thenret")
- (setq col nil
- state :then))
- (t (error
- "if*: bad keyword ~a" lookat))))
- (t (setq state :col
- col nil)
- (push (car xx) col))))
- ((eq state :col)
- (cond (lookat
- (cond ((string-equal lookat "else")
- (cond (elseseen
- (error
- "if*: multiples elses")))
- (setq elseseen t)
- (setq state :init)
- (push `(t ,@col) totalcol))
- ((string-equal lookat "then")
- (setq state :then))
- (t (error "if*: bad keyword ~s"
- lookat))))
- (t (push (car xx) col))))
- ((eq state :then)
- (cond (lookat
- (error
- "if*: keyword ~s at the wrong place " (car xx)))
- (t (setq state :compl)
- (push `(,(car xx) ,@col) totalcol))))
- ((eq state :compl)
- (cond ((not (string-equal lookat "elseif"))
- (error "if*: missing elseif clause ")))
- (setq state :init)))))
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t ,@col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) ,@col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
(defvar *break-on-test-failures* nil
(defmacro test-values-errorset (form &optional announce catch-breaks)
;; internal macro
(let ((g-announce (gensym))
- (g-catch-breaks (gensym)))
+ (g-catch-breaks (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks))
+ (,g-catch-breaks ,catch-breaks))
(handler-case (cons t (multiple-value-list ,form))
- (condition (condition)
- (if* (and (null ,g-catch-breaks)
- (typep condition 'simple-break))
- then (break condition)
- elseif ,g-announce
- then (format *error-output* "~&Condition type: ~a~%"
- (class-of condition))
- (format *error-output* "~&Message: ~a~%" condition))
- condition)))))
+ (condition (condition)
+ (if* (and (null ,g-catch-breaks)
+ (typep condition 'simple-break))
+ then (break condition)
+ elseif ,g-announce
+ then (format *error-output* "~&Condition type: ~a~%"
+ (class-of condition))
+ (format *error-output* "~&Message: ~a~%" condition))
+ condition)))))
(defmacro test-values (form &optional announce catch-breaks)
;; internal macro
else `(cons t (multiple-value-list ,form))))
(defmacro test (expected-value test-form
- &key (test #'eql test-given)
- (multiple-values nil multiple-values-given)
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given)
+ &key (test #'eql test-given)
+ (multiple-values nil multiple-values-given)
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
;;;;;;;;;; internal, undocumented keywords:
;;;; Note about these keywords: if they were documented, we'd have a
;;;; Specifically, errorset breaks it, and I don't see any way around
;;;; that. `errorset' is used by the old test.cl module (eg,
;;;; test-equal-errorset).
- errorset
- reported-form
- (wanted-message nil wanted-message-given)
- (got-message nil got-message-given))
+ errorset
+ reported-form
+ (wanted-message nil wanted-message-given)
+ (got-message nil got-message-given))
"Perform a single test. `expected-value' is the reference value for the
test. `test-form' is a form that will produce the value to be compared to
the expected-value. If the values are not the same, then an error is
(defmethod conditionp ((thing t)) nil)
(defmacro test-error (form &key announce
- catch-breaks
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given)
- (condition-type ''simple-error)
- (include-subtypes nil include-subtypes-given)
- (format-control nil format-control-given)
- (format-arguments nil format-arguments-given))
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
+ (condition-type ''simple-error)
+ (include-subtypes nil include-subtypes-given)
+ (format-control nil format-control-given)
+ (format-arguments nil format-arguments-given))
"Test that `form' signals an error. The order of evaluation of the
arguments is keywords first, then test form.
`format-control' and `format-arguments' can be used to check the error
message itself."
(let ((g-announce (gensym))
- (g-catch-breaks (gensym))
- (g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-condition-type (gensym))
- (g-include-subtypes (gensym))
- (g-format-control (gensym))
- (g-format-arguments (gensym))
- (g-c (gensym)))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-condition-type (gensym))
+ (g-include-subtypes (gensym))
+ (g-format-control (gensym))
+ (g-format-arguments (gensym))
+ (g-c (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks)
- ,@(when fail-info-given `((,g-fail-info ,fail-info)))
- ,@(when known-failure-given `((,g-known-failure ,known-failure)))
- (,g-condition-type ,condition-type)
- ,@(when include-subtypes-given
- `((,g-include-subtypes ,include-subtypes)))
- ,@(when format-control-given
- `((,g-format-control ,format-control)))
- ,@(when format-arguments-given
- `((,g-format-arguments ,format-arguments)))
- (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-condition-type ,condition-type)
+ ,@(when include-subtypes-given
+ `((,g-include-subtypes ,include-subtypes)))
+ ,@(when format-control-given
+ `((,g-format-control ,format-control)))
+ ,@(when format-arguments-given
+ `((,g-format-arguments ,format-arguments)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
(test-check
- :predicate #'eq
- :expected-result t
- :test-results
- (test-values (and (conditionp ,g-c)
- ,@(if* include-subtypes-given
- then `((if* ,g-include-subtypes
- then (typep ,g-c ,g-condition-type)
- else (eq (class-of ,g-c)
- (find-class
- ,g-condition-type))))
- else `((eq (class-of ,g-c)
- (find-class ,g-condition-type))))
- ,@(when format-control-given
- `((or
- (null ,g-format-control)
- (string=
- (concatenate 'simple-string
- "~1@<" ,g-format-control "~:@>")
- (simple-condition-format-control ,g-c)))))
- ,@(when format-arguments-given
- `((or
- (null ,g-format-arguments)
- (equal
- ,g-format-arguments
- (simple-condition-format-arguments ,g-c))))))
- t)
- :test-form ',form
- ,@(when fail-info-given `(:fail-info ,g-fail-info))
- ,@(when known-failure-given `(:known-failure ,g-known-failure))
- :condition-type ,g-condition-type
- :condition ,g-c
- ,@(when include-subtypes-given
- `(:include-subtypes ,g-include-subtypes))
- ,@(when format-control-given
- `(:format-control ,g-format-control))
- ,@(when format-arguments-given
- `(:format-arguments ,g-format-arguments))))))
+ :predicate #'eq
+ :expected-result t
+ :test-results
+ (test-values (and (conditionp ,g-c)
+ ,@(if* include-subtypes-given
+ then `((if* ,g-include-subtypes
+ then (typep ,g-c ,g-condition-type)
+ else (eq (class-of ,g-c)
+ (find-class
+ ,g-condition-type))))
+ else `((eq (class-of ,g-c)
+ (find-class ,g-condition-type))))
+ ,@(when format-control-given
+ `((or
+ (null ,g-format-control)
+ (string=
+ (concatenate 'simple-string
+ "~1@<" ,g-format-control "~:@>")
+ (simple-condition-format-control ,g-c)))))
+ ,@(when format-arguments-given
+ `((or
+ (null ,g-format-arguments)
+ (equal
+ ,g-format-arguments
+ (simple-condition-format-arguments ,g-c))))))
+ t)
+ :test-form ',form
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))
+ :condition-type ,g-condition-type
+ :condition ,g-c
+ ,@(when include-subtypes-given
+ `(:include-subtypes ,g-include-subtypes))
+ ,@(when format-control-given
+ `(:format-control ,g-format-control))
+ ,@(when format-arguments-given
+ `(:format-arguments ,g-format-arguments))))))
(defmacro test-no-error (form &key announce
- catch-breaks
- (fail-info nil fail-info-given)
- (known-failure nil known-failure-given))
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given))
"Test that `form' does not signal an error. The order of evaluation of
the arguments is keywords first, then test form.
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-announce (gensym))
- (g-catch-breaks (gensym))
- (g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-c (gensym)))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-c (gensym)))
`(let* ((,g-announce ,announce)
- (,g-catch-breaks ,catch-breaks)
- ,@(when fail-info-given `((,g-fail-info ,fail-info)))
- ,@(when known-failure-given `((,g-known-failure ,known-failure)))
- (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
(test-check
- :predicate #'eq
- :expected-result t
- :test-results (test-values (not (conditionp ,g-c)))
- :test-form ',form
- :condition ,g-c
- ,@(when fail-info-given `(:fail-info ,g-fail-info))
- ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
+ :predicate #'eq
+ :expected-result t
+ :test-results (test-values (not (conditionp ,g-c)))
+ :test-form ',form
+ :condition ,g-c
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
(defvar *warn-cookie* (cons nil nil))
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-value (gensym)))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
`(let* ((,g-fail-info ,fail-info)
- (,g-known-failure ,known-failure)
- (,g-value (test-values-errorset ,form nil t)))
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
(test
- *warn-cookie*
- (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
- then *warn-cookie*
- else ;; test produced no warning
- nil)
- :test #'eq
- :reported-form ,form ;; quoted by test macro
- :wanted-message "a warning"
- :got-message "no warning"
- :fail-info ,g-fail-info
- :known-failure ,g-known-failure))))
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then *warn-cookie*
+ else ;; test produced no warning
+ nil)
+ :test #'eq
+ :reported-form ,form ;; quoted by test macro
+ :wanted-message "a warning"
+ :got-message "no warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
(defmacro test-no-warning (form &key fail-info known-failure)
"Test that `form' does not signal a warning. The order of evaluation of
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
(let ((g-fail-info (gensym))
- (g-known-failure (gensym))
- (g-value (gensym)))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
`(let* ((,g-fail-info ,fail-info)
- (,g-known-failure ,known-failure)
- (,g-value (test-values-errorset ,form nil t)))
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
(test
- *warn-cookie*
- (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
- then nil ;; test produced warning
- else *warn-cookie*)
- :test #'eq
- :reported-form ',form
- :wanted-message "no warning"
- :got-message "a warning"
- :fail-info ,g-fail-info
- :known-failure ,g-known-failure))))
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then nil ;; test produced warning
+ else *warn-cookie*)
+ :test #'eq
+ :reported-form ',form
+ :wanted-message "no warning"
+ :got-message "a warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
(defvar *announce-test* nil) ;; if true announce each test that was done
(defun test-check (&key (predicate #'eql)
- expected-result test-results test-form
- multiple-values fail-info known-failure
- wanted-message got-message condition-type condition
- include-subtypes format-control format-arguments
- &aux fail predicate-failed got wanted)
+ expected-result test-results test-form
+ multiple-values fail-info known-failure
+ wanted-message got-message condition-type condition
+ include-subtypes format-control format-arguments
+ &aux fail predicate-failed got wanted)
;; for debugging large/complex test sets:
(when *announce-test*
(format t "Just did test ~s~%" test-form)
(force-output))
-
+
;; this is an internal function
(flet ((check (expected-result result)
- (let* ((results
- (multiple-value-list
- (errorset (funcall predicate expected-result result))))
- (failed (null (car results))))
- (if failed
- (progn
- (setq predicate-failed t)
- nil)
- (cadr results)))))
+ (let* ((results
+ (multiple-value-list
+ (errorset (funcall predicate expected-result result))))
+ (failed (null (car results))))
+ (if failed
+ (progn
+ (setq predicate-failed t)
+ nil)
+ (cadr results)))))
(when (conditionp test-results)
(setq condition test-results)
(setq test-results nil))
(setq fail t))
(if* (and (not fail) (not multiple-values))
then ;; should be a single result
- ;; expected-result is the single result wanted
- (when (not (and (cdr test-results)
- (check expected-result (cadr test-results))))
- (setq fail t))
- (when (and (not fail) (cddr test-results))
- (setq fail 'single-got-multiple))
+ ;; expected-result is the single result wanted
+ (when (not (and (cdr test-results)
+ (check expected-result (cadr test-results))))
+ (setq fail t))
+ (when (and (not fail) (cddr test-results))
+ (setq fail 'single-got-multiple))
else ;; multiple results wanted
- ;; expected-result is a list of results, each of which
- ;; should be checked against the corresponding test-results
- ;; using the predicate
- (do ((got (cdr test-results) (cdr got))
- (want expected-result (cdr want)))
- ((or (null got) (null want))
- (when (not (and (null want) (null got)))
- (setq fail t)))
- (when (not (check (car got) (car want)))
- (return (setq fail t)))))
+ ;; expected-result is a list of results, each of which
+ ;; should be checked against the corresponding test-results
+ ;; using the predicate
+ (do ((got (cdr test-results) (cdr got))
+ (want expected-result (cdr want)))
+ ((or (null got) (null want))
+ (when (not (and (null want) (null got)))
+ (setq fail t)))
+ (when (not (check (car got) (car want)))
+ (return (setq fail t)))))
(if* fail
then (when (not known-failure)
- (format *error-output*
- "~& * * * UNEXPECTED TEST FAILURE * * *~%")
- (incf *test-unexpected-failures*))
- (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
- known-failure test-form)
- (if* (eq 'single-got-multiple fail)
- then (format
- *error-output*
- "~
+ (format *error-output*
+ "~& * * * UNEXPECTED TEST FAILURE * * *~%")
+ (incf *test-unexpected-failures*))
+ (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
+ known-failure test-form)
+ (if* (eq 'single-got-multiple fail)
+ then (format
+ *error-output*
+ "~
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* "~
+ 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.~%"
- (when condition (class-of condition)))
- elseif condition
- then (if* (not (conditionp condition))
- then (format *error-output* "~
+ (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'.~%"
- condition-type)
- elseif (null condition-type)
- then (format *error-output* "~
+ condition-type)
+ elseif (null condition-type)
+ then (format *error-output* "~
Reason: detected an unexpected error of type `~s':
~a.~%"
- (class-of condition)
- condition)
- elseif (not (if* include-subtypes
- then (typep condition condition-type)
- else (eq (class-of condition)
- (find-class condition-type))))
- then (format *error-output* "~
+ (class-of condition)
+ condition)
+ elseif (not (if* include-subtypes
+ then (typep condition condition-type)
+ else (eq (class-of condition)
+ (find-class condition-type))))
+ then (format *error-output* "~
Reason: detected an incorrect condition type.~%")
- (format *error-output*
- " wanted: ~s~%" condition-type)
- (format *error-output*
- " got: ~s~%" (class-of condition))
- elseif (and format-control
- (not (string=
- (setq got
- (concatenate 'simple-string
- "~1@<" format-control "~:@>"))
- (setq wanted
- (simple-condition-format-control
- condition)))))
- then ;; format control doesn't match
- (format *error-output* "~
+ (format *error-output*
+ " wanted: ~s~%" condition-type)
+ (format *error-output*
+ " got: ~s~%" (class-of condition))
+ elseif (and format-control
+ (not (string=
+ (setq got
+ (concatenate 'simple-string
+ "~1@<" format-control "~:@>"))
+ (setq wanted
+ (simple-condition-format-control
+ condition)))))
+ then ;; format control doesn't match
+ (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
- (not (equal
- (setq got format-arguments)
- (setq wanted
- (simple-condition-format-arguments
- condition)))))
- then (format *error-output* "~
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ elseif (and format-arguments
+ (not (equal
+ (setq got format-arguments)
+ (setq wanted
+ (simple-condition-format-arguments
+ condition)))))
+ 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 "internal-error"))
- else (let ((*print-length* 50)
- (*print-level* 10))
- (if* wanted-message
- then (format *error-output*
- " wanted: ~a~%" wanted-message)
- else (if* (not multiple-values)
- then (format *error-output*
- " wanted: ~s~%"
- expected-result)
- else (format
- *error-output*
- " wanted values: ~{~s~^, ~}~%"
- expected-result)))
- (if* got-message
- then (format *error-output*
- " got: ~a~%" got-message)
- else (if* (not multiple-values)
- then (format *error-output* " got: ~s~%"
- (second test-results))
- else (format
- *error-output*
- " got values: ~{~s~^, ~}~%"
- (cdr test-results))))))
- (when fail-info
- (format *error-output* "Additional info: ~a~%" fail-info))
- (incf *test-errors*)
- (when *break-on-test-failures*
- (break "~a is non-nil." '*break-on-test-failures*))
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ else ;; what else????
+ (error "internal-error"))
+ else (let ((*print-length* 50)
+ (*print-level* 10))
+ (if* wanted-message
+ then (format *error-output*
+ " wanted: ~a~%" wanted-message)
+ else (if* (not multiple-values)
+ then (format *error-output*
+ " wanted: ~s~%"
+ expected-result)
+ else (format
+ *error-output*
+ " wanted values: ~{~s~^, ~}~%"
+ expected-result)))
+ (if* got-message
+ then (format *error-output*
+ " got: ~a~%" got-message)
+ else (if* (not multiple-values)
+ then (format *error-output* " got: ~s~%"
+ (second test-results))
+ else (format
+ *error-output*
+ " got values: ~{~s~^, ~}~%"
+ (cdr test-results))))))
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (incf *test-errors*)
+ (when *break-on-test-failures*
+ (break "~a is non-nil." '*break-on-test-failures*))
else (when known-failure
- (format *error-output*
- "~&Expected test failure for ~s did not occur.~%"
- test-form)
- (when fail-info
- (format *error-output* "Additional info: ~a~%" fail-info))
- (setq fail t))
- (incf *test-successes*))
+ (format *error-output*
+ "~&Expected test failure for ~s did not occur.~%"
+ test-form)
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (setq fail t))
+ (incf *test-successes*))
(not fail)))
(defmacro with-tests ((&key (name "unnamed")) &body body)
(let ((g-name (gensym)))
`(flet ((doit () ,@body))
(let ((,g-name ,name)
- (*test-errors* 0)
- (*test-successes* 0)
- (*test-unexpected-failures* 0))
- (format *error-output* "Begin ~a test~%" ,g-name)
- (if* *break-on-test-failures*
- then (doit)
- else (handler-case (doit)
- (error (c)
- (format
- *error-output*
- "~
+ (*test-errors* 0)
+ (*test-successes* 0)
+ (*test-unexpected-failures* 0))
+ (format *error-output* "Begin ~a test~%" ,g-name)
+ (if* *break-on-test-failures*
+ then (doit)
+ else (handler-case (doit)
+ (error (c)
+ (format
+ *error-output*
+ "~
~&Test ~a aborted by signalling an uncaught error:~%~a~%"
- ,g-name c))))
- (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 (gc-print-state) state))))))
+ ,g-name c))))
+ (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 (gc-print-state) state))))))
(defun gc-print-state ()
#+cmu ext:*gc-verbose*
projects / ptester.git / commitdiff