Silence two style warnings from the test harness.
[sbcl.git] / 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
7 (in-package :test-util)
8
9 (defvar *test-count* 0)
10 (defvar *test-file* nil)
11 (defvar *failures* nil)
12 (defvar *break-on-failure* nil)
13 (defvar *break-on-expected-failure* nil)
14
15 (defun log-msg (&rest args)
16   (format *trace-output* "~&::: ")
17   (apply #'format *trace-output* args)
18   (terpri *trace-output*)
19   (force-output *trace-output*))
20
21 (defmacro with-test ((&key fails-on broken-on skipped-on name) &body body)
22   (let ((block-name (gensym)))
23     `(progn
24        (start-test)
25        (cond
26          ((broken-p ,broken-on)
27           (fail-test :skipped-broken ',name "Test broken on this platform"))
28          ((skipped-p ,skipped-on)
29           (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
30          (t
31           (block ,block-name
32             (handler-bind ((error (lambda (error)
33                                     (if (expected-failure-p ,fails-on)
34                                         (fail-test :expected-failure ',name error)
35                                         (fail-test :unexpected-failure ',name error))
36                                     (return-from ,block-name))))
37               (progn
38                 (log-msg "Running ~S" ',name)
39                 ,@body
40                 (if (expected-failure-p ,fails-on)
41                     (fail-test :unexpected-success ',name nil)
42                     (log-msg "Success ~S" ',name))))))))))
43
44 (defun report-test-status ()
45   (with-standard-io-syntax
46       (with-open-file (stream "test-status.lisp-expr"
47                               :direction :output
48                               :if-exists :supersede)
49         (format stream "~s~%" *failures*))))
50
51 (defun start-test ()
52   (unless (eq *test-file* *load-pathname*)
53     (setf *test-file* *load-pathname*)
54     (setf *test-count* 0))
55   (incf *test-count*))
56
57 (defun really-invoke-debugger (condition)
58   (with-simple-restart (continue "Continue")
59     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
60       (enable-debugger)
61       (invoke-debugger condition))))
62
63 (defun fail-test (type test-name condition)
64   (if (stringp condition)
65       (log-msg "~@<~A ~S ~:_~A~:>"
66                type test-name condition)
67       (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
68                type test-name condition condition))
69   (push (list type *test-file* (or test-name *test-count*))
70         *failures*)
71   (unless (stringp condition)
72     (when (or (and *break-on-failure*
73                    (not (eq type :expected-failure)))
74               *break-on-expected-failure*)
75       (really-invoke-debugger condition))))
76
77 (defun expected-failure-p (fails-on)
78   (sb-impl::featurep fails-on))
79
80 (defun broken-p (broken-on)
81   (sb-impl::featurep broken-on))
82
83 (defun skipped-p (skipped-on)
84   (sb-impl::featurep skipped-on))
85
86 (defun test-env ()
87   (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
88         (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))
89               (posix-environ))))