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