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 (defun log-msg (&rest args)
  16   (format *trace-output* "~&::: ")
  17   (apply #'format *trace-output* args)
  18   (terpri *trace-output*)
  19   (force-output *trace-output*))
  20
  21 (defmacro with-test ((&key fails-on broken-on skipped-on name) &body body)
  22   (let ((block-name (gensym)))
  23     `(cond
  24        ((broken-p ,broken-on)
  25         (fail-test :skipped-broken ',name "Test broken on this platform"))
  26        ((skipped-p ,skipped-on)
  27         (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
  28        (t
  29         (block ,block-name
  30           (handler-bind ((error (lambda (error)
  31                                   (if (expected-failure-p ,fails-on)
  32                                       (fail-test :expected-failure ',name error)
  33                                       (fail-test :unexpected-failure ',name error))
  34                                   (return-from ,block-name))))
  35             (progn
  36               (log-msg "Running ~S" ',name)
  37               (start-test)
  38               ,@body
  39               (if (expected-failure-p ,fails-on)
  40                   (fail-test :unexpected-success ',name nil)
  41                   (log-msg "Success ~S" ',name)))))))))
  42
  43 (defun report-test-status ()
  44   (with-standard-io-syntax
  45       (with-open-file (stream "test-status.lisp-expr"
  46                               :direction :output
  47                               :if-exists :supersede)
  48         (format stream "~s~%" *failures*))))
  49
  50 (defun start-test ()
  51   (unless (eq *test-file* *load-pathname*)
  52     (setf *test-file* *load-pathname*)
  53     (setf *test-count* 0))
  54   (incf *test-count*))
  55
  56 (defun fail-test (type test-name condition)
  57   (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
  58            type test-name condition condition)
  59   (push (list type *test-file* (or test-name *test-count*))
  60         *failures*)
  61   (when (or (and *break-on-failure*
  62                  (not (eq type :expected-failure)))
  63             *break-on-expected-failure*)
  64     (really-invoke-debugger condition)))
  65
  66 (defun expected-failure-p (fails-on)
  67   (sb-impl::featurep fails-on))
  68
  69 (defun broken-p (broken-on)
  70   (sb-impl::featurep broken-on))
  71
  72 (defun skipped-p (skipped-on)
  73   (sb-impl::featurep skipped-on))
  74
  75 (defun really-invoke-debugger (condition)
  76   (with-simple-restart (continue "Continue")
  77     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
  78       (enable-debugger)
  79       (invoke-debugger condition))))
  80
  81 (defun test-env ()
  82   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
  83         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
  84               (posix-environ))))