1.0.23.21: Stack allocated conses for MIPS.
[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 (defmacro with-test ((&key fails-on name) &body body)
16   (let ((block-name (gensym)))
17     `(block ,block-name
18        (handler-bind ((error (lambda (error)
19                                (if (expected-failure-p ,fails-on)
20                                    (fail-test :expected-failure ',name error)
21                                    (fail-test :unexpected-failure ',name error))
22                                (return-from ,block-name))))
23          (progn
24            (start-test)
25            ,@body
26            (when (expected-failure-p ,fails-on)
27              (fail-test :unexpected-success ',name nil)))))))
28
29 (defun report-test-status ()
30   (with-standard-io-syntax
31       (with-open-file (stream "test-status.lisp-expr"
32                               :direction :output
33                               :if-exists :supersede)
34         (format stream "~s~%" *failures*))))
35
36 (defun start-test ()
37   (unless (eq *test-file* *load-pathname*)
38     (setf *test-file* *load-pathname*)
39     (setf *test-count* 0))
40   (incf *test-count*))
41
42 (defun fail-test (type test-name condition)
43   (push (list type *test-file* (or test-name *test-count*))
44         *failures*)
45   (when (or (and *break-on-failure*
46                  (not (eq type :expected-failure)))
47             *break-on-expected-failure*)
48     (really-invoke-debugger condition)))
49
50 (defun expected-failure-p (fails-on)
51   (sb-impl::featurep fails-on))
52
53 (defun really-invoke-debugger (condition)
54   (with-simple-restart (continue "Continue")
55     (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
56       (enable-debugger)
57       (invoke-debugger condition))))