Mercurial > core / lisp/lib/rt/util.lisp

 ;;; rt/util.lisp --- Test Utilities
 
 ;;
 
 ;;; Commentary:
 
 ;; some of these are taken from the TEST-UTIL package of SBCL
 ;; (tests/test-util.lisp)
 
 ;;; Code:
 (in-package :rt)
 
 ;;; tmp
 (defmacro with-tmp-directory ((&optional (name (string (gensym "tmp")))
                                          (defaults *default-tmp-directory*))
                               &body body)
   `(let ((*tmp* (directory-path (merge-pathnames ,name ,defaults))))
      (ensure-directories-exist *tmp*)
      (unwind-protect (progn ,@body)
        (sb-ext:delete-directory *tmp* :recursive t))))
 
 (defmacro with-tmp-file ((stream-var &key (name (string (gensym "tmp")))
                                           type
                                           (directory *default-tmp-directory*)
                                           (direction :output)
                                           (if-exists :supersede)
                                           (element-type ''character))
                          &body body)
   `(let ((*tmp* (make-pathname :name ,name :type ,type :directory ,(namestring directory))))
      (with-open-file (,stream-var *tmp* :direction ,direction :element-type ,element-type
                                   :if-exists ,if-exists)
        (unwind-protect (progn ,@body)
          (delete-file *tmp*)))))
 
 ;;; random
 (defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
 
 (defun random-elt (seq)
   (elt seq (random (length seq))))
 
 (defun random-ref (vec)
   (aref vec (random (length vec))))
 
 (defun random-char ()
   (random-ref *simple-charset*))
 
 (defun random-chars (dim)
   (let ((r (make-array dim :element-type 'character)))
     (dotimes (i (array-total-size r) r)
       (setf (row-major-aref r i) (random-char)))))
 
 (defun random-byte () (random 255))
 
 (defun random-bytes (dim)
   (let ((r (make-array dim :element-type 'octet)))
     (dotimes (i (array-total-size r) r)
       (setf (row-major-aref r i) (random-byte)))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-test (&rest slots)
     (apply #'make-instance 'test slots))
   (defun make-suite (&rest slots)
     (apply #'make-instance 'test-suite slots)))
 
 ;; TODO 2023-09-04: optimize
 ;;(declaim (inline do-tests))
 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))
   (if (pathnamep output)
       (with-open-file (stream output :direction :output)
         (do-suite (ensure-suite suite) :stream stream :force force))
       (do-suite (ensure-suite suite) :stream output :force force)))
 
 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))
 
 ;; TODO
 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
   (declare (ignore suite force))
   (sb-thread:with-mutex (*test-output-mutex*)
     (let ((stream (make-synonym-stream output)))
       (let ((*standard-output* stream)
             (*error-output* stream))
         (nyi!)))))
 
 (defun reset-tests ()
   (setq *testing* nil
         *test-suite* nil
         *test-suite-list* nil
         *test-input* nil))
 
 ;; this assumes that *test-suite* is re-initialized correctly to the
 ;; correct test-suite object.
 (defun continue-testing ()
   (if-let ((test *testing*))
     (throw '%in-test test)
     (do-suite *test-suite*)))
 
 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
 ;; place is changed - it returns place. This is functionally sound but
 ;; means that if we want to do something else in the event that place
 ;; is unchanged, we run into some friction,
 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
 (defun spush (item lst &key (test #'equal))
   "Substituting `push'"
   (declare (type function test))
   (cond
     ((null lst) (push item lst))
     ((list lst)
      (if-let ((found (member item lst
                              :test test)))
        (progn
          (rplaca found item)
          lst)
        (push item lst)))
     #|(or nil '(t (cons item lst)))|#))
 
 ;; FIX 2023-08-31: spush, replace with `add-test' method.
 ;; (declaim (inline normalize-test-name))
 (defun normalize-test-name (a)
   "Return the normalized `test-suite-designator' of A."
   (etypecase a
     (string (string-upcase a))
     (symbol (symbol-name a))
     (test-object (normalize-test-name (test-name a)))
     (t (format nil "~A" a))))
 
 (defun test-name= (a b)
   "Return t if A and B are similar `test-suite-designator's."
   (let ((a (normalize-test-name a))
         (b (normalize-test-name b)))
     (string= a b)))
 
 ;; (declaim (inline assert-suite ensure-suite))
 (defun ensure-suite (name)
   (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
     (car ok)
     (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
 
 (defun check-suite-designator (suite) (check-type suite test-suite-designator))
 
 (defun assert-suite (name)
   (check-suite-designator name)
   (assert (ensure-suite name)))
 
 (declaim (inline test-opt-key-p test-opt-valid-p))
 (defun test-opt-key-p (k)
   "Test if K is a `test-opt-key'."
   (member k '(:profile :save :stream)))
 
 (defun test-opt-valid-p (f)
   "Test if F is a valid `test-opt' form. If so, return F else nil."
   (when (test-opt-key-p (car f))
     f))