tests/test-util.lisp

   1 (defpackage :test-util
   2   (:use :cl :sb-ext)
   3   (:export #:with-test #:report-test-status #:*failures*
   4            #:really-invoke-debugger
   5            #:*break-on-failure* #:*break-on-expected-failure*))
   6
   7 (in-package :test-util)
   8
   9 (defvar *test-count* 0)
  10 (defvar *test-file* nil)
  11 (defvar *failures* nil)
  12 (defvar *break-on-failure* nil)
  13 (defvar *break-on-expected-failure* nil)
  14
  15 (defmacro with-test ((&key fails-on name) &body body)
  16   `(handler-case (progn
  17                    (start-test)
  18                    ,@body
  19                    (when (expected-failure-p ,fails-on)
  20                      (fail-test :unexpected-success ',name nil)))
  21     (error (error)
  22      (if (expected-failure-p ,fails-on)
  23          (fail-test :expected-failure ',name error)
  24          (fail-test :unexpected-failure ',name error)))))
  25
  26 (defun report-test-status ()
  27   (with-standard-io-syntax
  28       (with-open-file (stream "test-status.lisp-expr"
  29                               :direction :output
  30                               :if-exists :supersede)
  31         (format stream "~s~%" *failures*))))
  32
  33 (defun start-test ()
  34   (unless (eq *test-file* *load-pathname*)
  35     (setf *test-file* *load-pathname*)
  36     (setf *test-count* 0))
  37   (incf *test-count*))
  38
  39 (defun fail-test (type test-name condition)
  40   (push (list type *test-file* (or test-name *test-count*))
  41         *failures*)
  42   (when (or (and *break-on-failure*
  43                  (not (eq type :expected-failure)))
  44             *break-on-expected-failure*)
  45     (really-invoke-debugger condition)))
  46
  47 (defun expected-failure-p (fails-on)
  48   (sb-impl::featurep fails-on))
  49
  50 (defun really-invoke-debugger (condition)
  51   (with-simple-restart (continue "Continue")
  52     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
  53       (enable-debugger)
  54       (invoke-debugger condition))))