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 *all-failures* nil)
  13 (defvar *break-on-error* nil)
  14 (defvar *report-skipped-tests* nil)
  15 (defvar *explicit-test-files* nil)
  16
  17 (load "test-funs")
  18
  19 (defun run-all ()
  20   (loop :with remainder = (rest *posix-argv*)
  21      :while remainder
  22      :for arg = (pop remainder)
  23      :do (cond
  24            ((string= arg "--evaluator-mode")
  25             (let ((mode (pop remainder)))
  26               (cond
  27                 ((string= mode "interpret")
  28                  (setf *test-evaluator-mode* :interpret))
  29                 ((string= mode "compile")
  30                  (setf *test-evaluator-mode* :compile))
  31                 (t
  32                  (error "~@<Invalid evaluator mode: ~A. Must be one ~
  33                            of interpret, compile.~@:>"
  34                         mode)))))
  35            ((string= arg "--break-on-failure")
  36             (setf *break-on-error* t)
  37             (setf test-util:*break-on-failure* t))
  38            ((string= arg "--break-on-expected-failure")
  39             (setf test-util:*break-on-expected-failure* t))
  40            ((string= arg "--report-skipped-tests")
  41             (setf *report-skipped-tests* t))
  42            ((string= arg "--no-color"))
  43            (t
  44             (push (truename (parse-namestring arg)) *explicit-test-files*))))
  45   (setf *explicit-test-files* (nreverse *explicit-test-files*))
  46   (pure-runner (pure-load-files) 'load-test)
  47   (pure-runner (pure-cload-files) 'cload-test)
  48   (impure-runner (impure-load-files) 'load-test)
  49   (impure-runner (impure-cload-files) 'cload-test)
  50   #-win32 (impure-runner (sh-files) 'sh-test)
  51   (report)
  52   (sb-ext:exit :code (if (unexpected-failures)
  53                          1
  54                          104)))
  55
  56 (defun report ()
  57   (terpri)
  58   (format t "Finished running tests.~%")
  59   (let ((skipcount 0)
  60         (*print-pretty* nil))
  61     (cond (*all-failures*
  62            (format t "Status:~%")
  63            (dolist (fail (reverse *all-failures*))
  64              (cond ((eq (car fail) :unhandled-error)
  65                     (output-colored-text (car fail)
  66                                           " Unhandled Error")
  67                     (format t " ~a~%"
  68                             (enough-namestring (second fail))))
  69                    ((eq (car fail) :invalid-exit-status)
  70                     (output-colored-text (car fail)
  71                                           " Invalid exit status:")
  72                     (format t " ~a~%"
  73                             (enough-namestring (second fail))))
  74                    ((eq (car fail) :skipped-disabled)
  75                     (when *report-skipped-tests*
  76                       (format t " ~20a ~a / ~a~%"
  77                               "Skipped (irrelevant):"
  78                               (enough-namestring (second fail))
  79                               (third fail)))
  80                     (incf skipcount))
  81                    (t
  82                     (output-colored-text
  83                      (first fail)
  84                      (ecase (first fail)
  85                        (:expected-failure " Expected failure:")
  86                        (:unexpected-failure " Failure:")
  87                        (:leftover-thread " Leftover thread (broken):")
  88                        (:unexpected-success " Unexpected success:")
  89                        (:skipped-broken " Skipped (broken):")
  90                        (:skipped-disabled " Skipped (irrelevant):")))
  91                     (format t " ~a / ~a~%"
  92                             (enough-namestring (second fail))
  93                             (third fail)))))
  94            (when (> skipcount 0)
  95              (format t " (~a tests skipped for this combination of platform and features)~%"
  96                      skipcount)))
  97           (t
  98            (format t "All tests succeeded~%")))))
  99
 100 (defun pure-runner (files test-fun)
 101   (when files
 102     (format t "// Running pure tests (~a)~%" test-fun)
 103     (let ((*package* (find-package :cl-user))
 104           (*failures* nil))
 105       (setup-cl-user)
 106       (dolist (file files)
 107         (format t "// Running ~a in ~a evaluator mode~%"
 108                 file *test-evaluator-mode*)
 109         (restart-case
 110             (handler-bind ((error (make-error-handler file)))
 111               (let* ((sb-ext:*evaluator-mode* *test-evaluator-mode*)
 112                      (*features*
 113                        (if (eq sb-ext:*evaluator-mode* :interpret)
 114                            (cons :interpreter *features*)
 115                            *features*)))
 116                 (funcall test-fun file)))
 117           (skip-file ())))
 118       (append-failures))))
 119
 120 (defun run-in-child-sbcl (load eval)
 121   (process-exit-code
 122    (sb-ext:run-program
 123     (first *POSIX-ARGV*)
 124     (list "--core" SB-INT:*CORE-STRING*
 125            "--noinform"
 126            "--no-sysinit"
 127            "--no-userinit"
 128            "--noprint"
 129            "--disable-debugger"
 130            "--load" load
 131            "--eval" (write-to-string eval
 132                                      :right-margin 1000))
 133     :output t
 134     :input t)))
 135
 136 (defun run-impure-in-child-sbcl (test-file test-fun)
 137   (clear-test-status)
 138   (run-in-child-sbcl
 139    "impure-runner"
 140    `(run-tests::run
 141      ,(enough-namestring test-file)
 142      ',test-fun
 143      ,*break-on-failure*
 144      ,*break-on-expected-failure*
 145      ,*break-on-error*
 146      ,(eq *test-evaluator-mode* :interpret))))
 147
 148 (defun impure-runner (files test-fun)
 149   (when files
 150     (format t "// Running impure tests (~a)~%" test-fun)
 151     (dolist (file files)
 152       (force-output)
 153       (let ((exit-code (run-impure-in-child-sbcl file test-fun)))
 154         (if (= exit-code 104)
 155             (with-open-file (stream "test-status.lisp-expr"
 156                                     :direction :input
 157                                     :if-does-not-exist :error)
 158               (append-failures (read stream)))
 159             (push (list :invalid-exit-status file)
 160                   *all-failures*))))))
 161
 162 (defun make-error-handler (file)
 163   (lambda (condition)
 164     (push (list :unhandled-error file) *failures*)
 165     (cond (*break-on-error*
 166            (test-util:really-invoke-debugger condition))
 167           (t
 168            (format *error-output* "~&Unhandled ~a: ~a~%"
 169                    (type-of condition) condition)
 170            (sb-debug:print-backtrace)))
 171     (invoke-restart 'skip-file)))
 172
 173 (defun append-failures (&optional (failures *failures*))
 174   (setf *all-failures* (append failures *all-failures*)))
 175
 176 (defun unexpected-failures ()
 177   (remove-if (lambda (x)
 178                (or (eq (car x) :expected-failure)
 179                    (eq (car x) :unexpected-success)
 180                    (eq (car x) :skipped-broken)
 181                    (eq (car x) :skipped-disabled)))
 182              *all-failures*))
 183
 184 (defun setup-cl-user ()
 185   (use-package :test-util)
 186   (use-package :assertoid))
 187
 188 (defun filter-test-files (wild-mask)
 189   (if *explicit-test-files*
 190       (loop for file in *explicit-test-files*
 191             when (pathname-match-p file wild-mask)
 192             collect file)
 193       (directory wild-mask)))
 194
 195 (defun pure-load-files ()
 196   (filter-test-files "*.pure.lisp"))
 197
 198 (defun pure-cload-files ()
 199   (filter-test-files "*.pure-cload.lisp"))
 200
 201 (defun impure-load-files ()
 202   (filter-test-files "*.impure.lisp"))
 203
 204 (defun impure-cload-files ()
 205   (filter-test-files "*.impure-cload.lisp"))
 206
 207 (defun sh-files ()
 208   (filter-test-files "*.test.sh"))