Coverage report: /home/ellis/comp/core/lib/rt/util.lisp

KindCoveredAll%
expression76127 59.8
branch48 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; rt/util.lisp --- Test Utilities
2
 
3
 ;;
4
 
5
 ;;; Commentary:
6
 
7
 ;; some of these are taken from the TEST-UTIL package of SBCL
8
 ;; (tests/test-util.lisp)
9
 
10
 ;;; Code:
11
 (in-package :rt)
12
 
13
 ;;; tmp
14
 (defmacro with-tmp-directory ((&optional (name (string (gensym "tmp")))
15
                                          (defaults *default-tmp-directory*))
16
                               &body body)
17
   `(let ((*tmp* (directory-path (merge-pathnames ,name ,defaults))))
18
      (ensure-directories-exist *tmp*)
19
      (unwind-protect (progn ,@body)
20
        (sb-ext:delete-directory *tmp* :recursive t))))
21
 
22
 (defmacro with-tmp-file ((stream-var &key (name (string (gensym "tmp")))
23
                                           type
24
                                           (directory *default-tmp-directory*)
25
                                           (direction :output)
26
                                           (if-exists :supersede)
27
                                           (element-type ''character))
28
                          &body body)
29
   `(let ((*tmp* (make-pathname :name ,name :type ,type :directory ,(namestring directory))))
30
      (with-open-file (,stream-var *tmp* :direction ,direction :element-type ,element-type
31
                                   :if-exists ,if-exists)
32
        (unwind-protect (progn ,@body)
33
          (delete-file *tmp*)))))
34
 
35
 (eval-when (:compile-toplevel :load-toplevel :execute)
36
   (defun make-test (&rest slots)
37
     (apply #'make-instance 'test slots))
38
   (defun make-suite (&rest slots)
39
     (apply #'make-instance 'test-suite slots)))
40
 
41
 ;; TODO 2023-09-04: optimize
42
 ;;(declaim (inline do-tests))
43
 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))
44
   (if (pathnamep output)
45
       (with-open-file (stream output :direction :output)
46
         (do-suite (ensure-suite suite) :stream stream :force force))
47
       (do-suite (ensure-suite suite) :stream output :force force)))
48
 
49
 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))
50
 
51
 ;; TODO
52
 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
53
   (declare (ignore suite force))
54
   (sb-thread:with-mutex (*test-output-mutex*)
55
     (let ((stream (make-synonym-stream output)))
56
       (let ((*standard-output* stream)
57
             (*error-output* stream))
58
         (nyi!)))))
59
 
60
 (defun reset-tests ()
61
   (setq *testing* nil
62
         *test-suite* nil
63
         *fx* nil
64
         *test-suite-list* nil
65
         *test-input* nil
66
         *test-output* nil))
67
 
68
 ;; this assumes that *test-suite* is re-initialized correctly to the
69
 ;; correct test-suite object.
70
 (defun continue-testing ()
71
   (if-let ((test *testing*))
72
     (throw '%in-test test)
73
     (do-suite *test-suite*)))
74
 
75
 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
76
 ;; place is changed - it returns place. This is functionally sound but
77
 ;; means that if we want to do something else in the event that place
78
 ;; is unchanged, we run into some friction,
79
 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
80
 (defun spush (item lst &key (test #'equal))
81
   "Substituting `push'"
82
   (declare (type function test))
83
   (cond
84
     ((null lst) (push item lst))
85
     ((list lst)
86
      (if-let ((found (member item lst
87
                              :test test)))
88
        (progn
89
          (rplaca found item)
90
          lst)
91
        (push item lst)))
92
     #|(or nil '(t (cons item lst)))|#))
93
 
94
 ;; FIX 2023-08-31: spush, replace with `add-test' method.
95
 ;; (declaim (inline normalize-test-name))
96
 (defun normalize-test-name (a)
97
   "Return the normalized `test-suite-designator' of A."
98
   (etypecase a
99
     (string (string-upcase a))
100
     (symbol (symbol-name a))
101
     (test-object (normalize-test-name (name a)))
102
     (t (format nil "~A" a))))
103
 
104
 (defun test-name= (a b)
105
   "Return t if A and B are similar `test-suite-designator's."
106
   (let ((a (normalize-test-name a))
107
         (b (normalize-test-name b)))
108
     (string= a b)))
109
 
110
 (declaim (inline assert-suite ensure-suite))
111
 (defun ensure-suite (name)
112
   (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
113
     (car ok)
114
     (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
115
 
116
 (defun check-suite-designator (suite) (check-type suite test-suite-designator))
117
 
118
 (defun assert-suite (name)
119
   (check-suite-designator name)
120
   (assert (ensure-suite name)))