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                                   (sb-thread:thread-emphemeral-p thread))
  77                         (setf any-leftover thread)
  78                         (ignore-errors (sb-thread:terminate-thread thread))))
  79                     (when any-leftover
  80                       (fail-test :leftover-thread ',name any-leftover)
  81                       (return-from ,block-name)))
  82                   (if (expected-failure-p ,fails-on)
  83                       (fail-test :unexpected-success ',name nil)
  84                       (log-msg "Success ~S" ',name)))))))))))
  85
  86 (defun report-test-status ()
  87   (with-standard-io-syntax
  88       (with-open-file (stream "test-status.lisp-expr"
  89                               :direction :output
  90                               :if-exists :supersede)
  91         (format stream "~s~%" *failures*))))
  92
  93 (defun start-test ()
  94   (unless (eq *test-file* *load-pathname*)
  95     (setf *test-file* *load-pathname*)
  96     (setf *test-count* 0))
  97   (incf *test-count*))
  98
  99 (defun really-invoke-debugger (condition)
 100   (with-simple-restart (continue "Continue")
 101     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
 102       (enable-debugger)
 103       (invoke-debugger condition))))
 104
 105 (defun fail-test (type test-name condition)
 106   (if (stringp condition)
 107       (log-msg "~@<~A ~S ~:_~A~:>"
 108                type test-name condition)
 109       (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
 110                type test-name condition condition))
 111   (push (list type *test-file* (or test-name *test-count*))
 112         *failures*)
 113   (unless (stringp condition)
 114     (when (or (and *break-on-failure*
 115                    (not (eq type :expected-failure)))
 116               *break-on-expected-failure*)
 117       (really-invoke-debugger condition))))
 118
 119 (defun expected-failure-p (fails-on)
 120   (sb-impl::featurep fails-on))
 121
 122 (defun broken-p (broken-on)
 123   (sb-impl::featurep broken-on))
 124
 125 (defun skipped-p (skipped-on)
 126   (sb-impl::featurep skipped-on))
 127
 128 (defun test-env ()
 129   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
 130         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
 131               (posix-environ))))