tests/run-tests.lisp

   1 (load "test-util.lisp")
   2
   3 (defpackage :run-tests
   4     (:use :cl :test-util :sb-ext))
   5
   6 (load "assertoid.lisp")
   7
   8 (in-package run-tests)
   9
  10 (load "colorize.lisp")
  11
  12 (defvar *test-evaluator-mode* :compile)
  13 (defvar *all-failures* nil)
  14 (defvar *break-on-error* nil)
  15 (defvar *report-skipped-tests* nil)
  16 (defvar *explicit-test-files* nil)
  17
  18 (defun run-all ()
  19   (loop :with remainder = (rest *posix-argv*)
  20      :while remainder
  21      :for arg = (pop remainder)
  22      :do (cond
  23            ((string= arg "--evaluator-mode")
  24             (let ((mode (pop remainder)))
  25               (cond
  26                 ((string= mode "interpret")
  27                  (setf *test-evaluator-mode* :interpret))
  28                 ((string= mode "compile")
  29                  (setf *test-evaluator-mode* :compile))
  30                 (t
  31                  (error "~@<Invalid evaluator mode: ~A. Must be one ~
  32                            of interpret, compile.~@:>"
  33                         mode)))))
  34            ((string= arg "--break-on-failure")
  35             (setf *break-on-error* t)
  36             (setf test-util:*break-on-failure* t))
  37            ((string= arg "--break-on-expected-failure")
  38             (setf test-util:*break-on-expected-failure* t))
  39            ((string= arg "--report-skipped-tests")
  40             (setf *report-skipped-tests* t))
  41            ((string= arg "--no-color"))
  42            (t
  43             (push (truename (parse-namestring arg)) *explicit-test-files*))))
  44   (setf *explicit-test-files* (nreverse *explicit-test-files*))
  45   (pure-runner (pure-load-files) #'load-test)
  46   (pure-runner (pure-cload-files) #'cload-test)
  47   (impure-runner (impure-load-files) #'load-test)
  48   (impure-runner (impure-cload-files) #'cload-test)
  49   #-win32 (impure-runner (sh-files) #'sh-test)
  50   (report)
  51   (sb-ext:exit :code (if (unexpected-failures)
  52                          1
  53                          104)))
  54
  55 (defun report ()
  56   (terpri)
  57   (format t "Finished running tests.~%")
  58   (let ((skipcount 0)
  59         (*print-pretty* nil))
  60     (cond (*all-failures*
  61            (format t "Status:~%")
  62            (dolist (fail (reverse *all-failures*))
  63              (cond ((eq (car fail) :unhandled-error)
  64                     (output-colored-text (car fail)
  65                                           " Unhandled Error")
  66                     (format t " ~a~%"
  67                             (enough-namestring (second fail))))
  68                    ((eq (car fail) :invalid-exit-status)
  69                     (output-colored-text (car fail)
  70                                           " Invalid exit status:")
  71                     (format t " ~a~%"
  72                             (enough-namestring (second fail))))
  73                    ((eq (car fail) :skipped-disabled)
  74                     (when *report-skipped-tests*
  75                       (format t " ~20a ~a / ~a~%"
  76                               "Skipped (irrelevant):"
  77                               (enough-namestring (second fail))
  78                               (third fail)))
  79                     (incf skipcount))
  80                    (t
  81                     (output-colored-text
  82                      (first fail)
  83                      (ecase (first fail)
  84                        (:expected-failure " Expected failure:")
  85                        (:unexpected-failure " Failure:")
  86                        (:leftover-thread " Leftover thread (broken):")
  87                        (:unexpected-success " Unexpected success:")
  88                        (:skipped-broken " Skipped (broken):")
  89                        (:skipped-disabled " Skipped (irrelevant):")))
  90                     (format t " ~a / ~a~%"
  91                             (enough-namestring (second fail))
  92                             (third fail)))))
  93            (when (> skipcount 0)
  94              (format t " (~a tests skipped for this combination of platform and features)~%"
  95                      skipcount)))
  96           (t
  97            (format t "All tests succeeded~%")))))
  98
  99 (defun pure-runner (files test-fun)
 100   (when files
 101     (format t "// Running pure tests (~a)~%" test-fun)
 102     (let ((*package* (find-package :cl-user))
 103           (*failures* nil))
 104       (setup-cl-user)
 105       (dolist (file files)
 106         (format t "// Running ~a in ~a evaluator mode~%"
 107                 file *test-evaluator-mode*)
 108         (restart-case
 109             (handler-bind ((error (make-error-handler file)))
 110               (let* ((sb-ext:*evaluator-mode* *test-evaluator-mode*)
 111                      (*features*
 112                        (if (eq sb-ext:*evaluator-mode* :interpret)
 113                            (cons :interpreter *features*)
 114                            *features*)))
 115                 (eval (funcall test-fun file))))
 116           (skip-file ())))
 117       (append-failures))))
 118
 119 (defun run-in-child-sbcl (load-forms forms)
 120   ;; We used to fork() for POSIX platforms, and use this for Windows.
 121   ;; However, it seems better to use the same solution everywhere.
 122   (process-exit-code
 123    (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
 124      (sb-ext:run-program
 125       (first *POSIX-ARGV*)
 126       (append
 127        (list "--core" SB-INT:*CORE-STRING*
 128              "--noinform"
 129              "--no-sysinit"
 130              "--no-userinit"
 131              "--noprint"
 132              "--disable-debugger")
 133        (loop for form in (append load-forms forms)
 134              collect "--eval"
 135              collect (write-to-string form)))
 136       :output sb-sys:*stdout*
 137       :input #-win32 devnull #+win32 sb-sys:*stdin*))))
 138
 139 (defun clear-test-status ()
 140   (with-open-file (stream "test-status.lisp-expr"
 141                           :direction :output
 142                           :if-exists :supersede)
 143     (write-line "NIL" stream)))
 144
 145 (defun run-impure-in-child-sbcl (test-file test-code)
 146   (clear-test-status)
 147   (run-in-child-sbcl
 148    `((load "test-util")
 149      (load "assertoid")
 150      (defpackage :run-tests
 151        (:use :cl :test-util :sb-ext)))
 152
 153    `((in-package :cl-user)
 154      (use-package :test-util)
 155      (use-package :assertoid)
 156      (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
 157      (setf test-util:*break-on-expected-failure*
 158            ,test-util:*break-on-expected-failure*)
 159      (let* ((file ,test-file)
 160             (sb-ext:*evaluator-mode* ,*test-evaluator-mode*)
 161             (*features*
 162              (if (eq sb-ext:*evaluator-mode* :interpret)
 163                  (cons :interpreter *features*)
 164                  *features*))
 165             (*break-on-error* ,run-tests::*break-on-error*))
 166        (declare (special *break-on-error*))
 167        (format t "// Running ~a in ~a evaluator mode~%"
 168                file sb-ext:*evaluator-mode*)
 169        (restart-case
 170            (handler-bind
 171                ((error (lambda (condition)
 172                          (push (list :unhandled-error file)
 173                                test-util::*failures*)
 174                          (cond (*break-on-error*
 175                                 (test-util:really-invoke-debugger condition))
 176                                (t
 177                                 (format *error-output* "~&Unhandled ~a: ~a~%"
 178                                         (type-of condition) condition)
 179                                 (sb-debug:print-backtrace)))
 180                          (invoke-restart 'skip-file))))
 181              ,test-code)
 182          (skip-file ()
 183            (format t ">>>~a<<<~%" test-util::*failures*)))
 184        (test-util:report-test-status)
 185        (sb-ext:exit :code 104)))))
 186
 187 (defun impure-runner (files test-fun)
 188   (when files
 189     (format t "// Running impure tests (~a)~%" test-fun)
 190     (let ((*package* (find-package :cl-user)))
 191       (setup-cl-user)
 192       (dolist (file files)
 193         (force-output)
 194         (let ((exit-code (run-impure-in-child-sbcl file
 195                                                    (funcall test-fun file))))
 196           (if (= exit-code 104)
 197               (with-open-file (stream "test-status.lisp-expr"
 198                                       :direction :input
 199                                       :if-does-not-exist :error)
 200                 (append-failures (read stream)))
 201               (push (list :invalid-exit-status file)
 202                     *all-failures*)))))))
 203
 204 (defun make-error-handler (file)
 205   (lambda (condition)
 206     (push (list :unhandled-error file) *failures*)
 207     (cond (*break-on-error*
 208            (test-util:really-invoke-debugger condition))
 209           (t
 210            (format *error-output* "~&Unhandled ~a: ~a~%"
 211                    (type-of condition) condition)
 212            (sb-debug:print-backtrace)))
 213     (invoke-restart 'skip-file)))
 214
 215 (defun append-failures (&optional (failures *failures*))
 216   (setf *all-failures* (append failures *all-failures*)))
 217
 218 (defun unexpected-failures ()
 219   (remove-if (lambda (x)
 220                (or (eq (car x) :expected-failure)
 221                    (eq (car x) :unexpected-success)
 222                    (eq (car x) :skipped-broken)
 223                    (eq (car x) :skipped-disabled)))
 224              *all-failures*))
 225
 226 (defun setup-cl-user ()
 227   (use-package :test-util)
 228   (use-package :assertoid))
 229
 230 (defun load-test (file)
 231   `(load ,file :external-format :utf-8))
 232
 233 (defun cload-test (file)
 234   `(let ((compile-name (compile-file-pathname ,file)))
 235      (unwind-protect
 236           (progn
 237             (compile-file ,file)
 238             (load compile-name))
 239        (ignore-errors
 240          (delete-file compile-name)))))
 241
 242 (defun sh-test (file)
 243   ;; What? No SB-POSIX:EXECV?
 244   (clear-test-status)
 245   `(progn
 246      (sb-posix:setenv "TEST_SBCL_EVALUATOR_MODE"
 247                       (string-downcase ,*test-evaluator-mode*)
 248                       1)
 249      (let ((process (sb-ext:run-program "/bin/sh"
 250                                         (list (native-namestring ,file))
 251                                         :output *error-output*)))
 252        (let ((*failures* nil))
 253          (test-util:report-test-status))
 254        (sb-ext:exit :code (process-exit-code process)))))
 255
 256 (defun filter-test-files (wild-mask)
 257   (if *explicit-test-files*
 258       (loop for file in *explicit-test-files*
 259             when (pathname-match-p file wild-mask)
 260             collect file)
 261       (directory wild-mask)))
 262
 263 (defun pure-load-files ()
 264   (filter-test-files "*.pure.lisp"))
 265
 266 (defun pure-cload-files ()
 267   (filter-test-files "*.pure-cload.lisp"))
 268
 269 (defun impure-load-files ()
 270   (filter-test-files "*.impure.lisp"))
 271
 272 (defun impure-cload-files ()
 273   (filter-test-files "*.impure-cload.lisp"))
 274
 275 (defun sh-files ()
 276   (filter-test-files "*.test.sh"))