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            #:make-kill-thread #:make-join-thread))
   7
   8 (in-package :test-util)
   9
  10 (defvar *test-count* 0)
  11 (defvar *test-file* nil)
  12 (defvar *failures* nil)
  13 (defvar *break-on-failure* nil)
  14 (defvar *break-on-expected-failure* nil)
  15
  16 (defvar *threads-to-kill*)
  17 (defvar *threads-to-join*)
  18
  19 #+sb-thread
  20 (defun make-kill-thread (&rest args)
  21   (let ((thread (apply #'sb-thread:make-thread args)))
  22     (when (boundp '*threads-to-kill*)
  23       (push thread *threads-to-kill*))
  24     thread))
  25
  26 #+sb-thread
  27 (defun make-join-thread (&rest args)
  28   (let ((thread (apply #'sb-thread:make-thread args)))
  29     (when (boundp '*threads-to-join*)
  30       (push thread *threads-to-join*))
  31     thread))
  32
  33 (defun log-msg (&rest args)
  34   (format *trace-output* "~&::: ")
  35   (apply #'format *trace-output* args)
  36   (terpri *trace-output*)
  37   (force-output *trace-output*))
  38
  39 (defmacro with-test ((&key fails-on broken-on skipped-on name)
  40                      &body body)
  41   (let ((block-name (gensym))
  42         (threads    (gensym "THREADS")))
  43     `(progn
  44        (start-test)
  45        (cond
  46          ((broken-p ,broken-on)
  47           (fail-test :skipped-broken ',name "Test broken on this platform"))
  48          ((skipped-p ,skipped-on)
  49           (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
  50          (t
  51           (let (#+sb-thread (,threads (sb-thread:list-all-threads))
  52                 (*threads-to-join* nil)
  53                 (*threads-to-kill* nil))
  54             (block ,block-name
  55               (handler-bind ((error (lambda (error)
  56                                       (if (expected-failure-p ,fails-on)
  57                                           (fail-test :expected-failure ',name error)
  58                                           (fail-test :unexpected-failure ',name error))
  59                                       (return-from ,block-name))))
  60                 (progn
  61                   (log-msg "Running ~S" ',name)
  62                   ,@body
  63                   #+sb-thread
  64                   (let ((any-leftover nil))
  65                     (dolist (thread *threads-to-join*)
  66                       (ignore-errors (sb-thread:join-thread thread)))
  67                     (dolist (thread *threads-to-kill*)
  68                       (ignore-errors (sb-thread:terminate-thread thread)))
  69                     (setf ,threads (union (union *threads-to-kill*
  70                                                  *threads-to-join*)
  71                                           ,threads))
  72                     (dolist (thread (sb-thread:list-all-threads))
  73                       (unless (or (not (sb-thread:thread-alive-p thread))
  74                                   (eql thread sb-thread:*current-thread*)
  75                                   (member thread ,threads))
  76                         (setf any-leftover thread)
  77                         (ignore-errors (sb-thread:terminate-thread thread))))
  78                     (when any-leftover
  79                       (fail-test :leftover-thread ',name any-leftover)
  80                       (return-from ,block-name)))
  81                   (if (expected-failure-p ,fails-on)
  82                       (fail-test :unexpected-success ',name nil)
  83                       (log-msg "Success ~S" ',name)))))))))))
  84
  85 (defun report-test-status ()
  86   (with-standard-io-syntax
  87       (with-open-file (stream "test-status.lisp-expr"
  88                               :direction :output
  89                               :if-exists :supersede)
  90         (format stream "~s~%" *failures*))))
  91
  92 (defun start-test ()
  93   (unless (eq *test-file* *load-pathname*)
  94     (setf *test-file* *load-pathname*)
  95     (setf *test-count* 0))
  96   (incf *test-count*))
  97
  98 (defun really-invoke-debugger (condition)
  99   (with-simple-restart (continue "Continue")
 100     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
 101       (enable-debugger)
 102       (invoke-debugger condition))))
 103
 104 (defun fail-test (type test-name condition)
 105   (if (stringp condition)
 106       (log-msg "~@<~A ~S ~:_~A~:>"
 107                type test-name condition)
 108       (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
 109                type test-name condition condition))
 110   (push (list type *test-file* (or test-name *test-count*))
 111         *failures*)
 112   (unless (stringp condition)
 113     (when (or (and *break-on-failure*
 114                    (not (eq type :expected-failure)))
 115               *break-on-expected-failure*)
 116       (really-invoke-debugger condition))))
 117
 118 (defun expected-failure-p (fails-on)
 119   (sb-impl::featurep fails-on))
 120
 121 (defun broken-p (broken-on)
 122   (sb-impl::featurep broken-on))
 123
 124 (defun skipped-p (skipped-on)
 125   (sb-impl::featurep skipped-on))
 126
 127 (defun test-env ()
 128   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
 129         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
 130               (posix-environ))))