1.1--- a/emacs/lib/scrum.el Fri Aug 30 21:29:55 2024 -0400
1.2+++ b/emacs/lib/scrum.el Sat Aug 31 22:34:56 2024 -0400
1.3@@ -57,7 +57,9 @@
1.4 (defgroup scrum nil
1.5 "CC Scrum Framework.")
1.6
1.7-(defvar scrum-properties '("SPRINT" "RELEASE" "TASKID"))
1.8+(defvar scrum-properties '("SPRINT" "EPIC" "RELEASE" "TASKID" "PROJECT" "COMMIT" "GOAL"))
1.9+
1.10+(defvar scrum-tags '("demo" "mvp" "release" "major-release" "ua" "qa"))
1.11
1.12 (provide 'scrum)
1.13 ;;; scrum.el ends here
2.1--- a/lisp/lib/rt/err.lisp Fri Aug 30 21:29:55 2024 -0400
2.2+++ b/lisp/lib/rt/err.lisp Sat Aug 31 22:34:56 2024 -0400
2.3@@ -6,4 +6,14 @@
2.4
2.5 (in-package :rt)
2.6
2.7-(deferror test-error () ())
2.8+(define-condition test-condition () ())
2.9+
2.10+(define-condition test-failed (test-condition error)
2.11+ ((reason :accessor fail-reason :initarg :reason :initform "unknown")
2.12+ (name :accessor fail-name :initarg :name)
2.13+ (form :accessor fail-form :initarg :form))
2.14+ (:documentation "Signaled when a test fails.")
2.15+ (:report (lambda (c s)
2.16+ (format s "The following expression failed: ~S~%~A."
2.17+ (fail-form c)
2.18+ (fail-reason c)))))
3.1--- a/lisp/lib/rt/fuzz.lisp Fri Aug 30 21:29:55 2024 -0400
3.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3@@ -1,51 +0,0 @@
3.4-;;; fuzz.lisp --- RT Fuzz
3.5-
3.6-;; FUZZER API
3.7-
3.8-;;; Commentary:
3.9-
3.10-;;
3.11-;; wiki: https://en.wikipedia.org/wiki/Fuzzing
3.12-
3.13-;;; Code:
3.14-(in-package :rt/fuzz)
3.15-
3.16-(defvar *default-fuzz-generator*
3.17- (lambda (state)
3.18- (random most-positive-fixnum state)))
3.19-
3.20-(defclass fuzzer ()
3.21- ((state :initform (make-random-state t)
3.22- :initarg :state
3.23- :accessor fuzz-state)
3.24- (generator :initform *default-fuzz-generator*
3.25- :initarg :generator
3.26- :type function
3.27- :accessor fuzz-generator))
3.28- (:documentation "An object which provides invalid, unexpected or random data as inputs to some
3.29-program."))
3.30-
3.31-(defgeneric fuzz (self &key &allow-other-keys)
3.32- (:method ((self fuzzer) &key &allow-other-keys)
3.33- (funcall (the function (fuzz-generator self)) (fuzz-state self)))
3.34- (:method ((self fuzzer) &key count)
3.35- (if count
3.36- (let ((ret))
3.37- (dotimes (i count ret)
3.38- (push (funcall (the function (fuzz-generator self)) (fuzz-state self)) ret)))
3.39- (fuzz self))))
3.40-
3.41-(defgeneric fuzz* (state generator &key &allow-other-keys)
3.42- (:method ((state list) (generator function) &key (count 1))
3.43- (let ((ret))
3.44- (dotimes (i count ret)
3.45- (push (funcall generator state) ret))))
3.46- (:method ((state vector) (generator function) &key (count 1))
3.47- (let ((ret (make-array count :fill-pointer 0)))
3.48- (dotimes (i count ret)
3.49- (setf (aref ret i) (funcall generator state)))))
3.50- (:method ((state hash-table) (generator function) &key (count 1))
3.51- (let ((ret (make-hash-table)))
3.52- (dotimes (i count ret)
3.53- (destructuring-bind (k v) (funcall generator state)
3.54- (setf (gethash k ret) v))))))
4.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/lib/rt/obj.lisp Sat Aug 31 22:34:56 2024 -0400
4.3@@ -0,0 +1,306 @@
4.4+;;; obj.lisp --- Test Objects
4.5+
4.6+;;
4.7+
4.8+;;; Code:
4.9+(in-package :rt)
4.10+
4.11+;;; Result
4.12+(deftype result-tag ()
4.13+ '(or (member :pass :fail :skip) null))
4.14+
4.15+(declaim (inline %make-test-result))
4.16+(defstruct (test-result (:constructor %make-test-result)
4.17+ (:conc-name tr-))
4.18+ (tag nil :type result-tag :read-only t)
4.19+ (form nil :type form))
4.20+
4.21+(defmethod print-object ((self test-result) stream)
4.22+ (print-unreadable-object (self stream :identity t)
4.23+ (format stream "~A ~A" (tr-tag self) (tr-form self))))
4.24+
4.25+(defun make-test-result (tag &optional form)
4.26+ (%make-test-result :tag tag :form form))
4.27+
4.28+(defmethod test-pass-p ((res test-result))
4.29+ (when (eq :pass (tr-tag res)) t))
4.30+
4.31+(defmethod test-fail-p ((res test-result))
4.32+ (when (eq :fail (tr-tag res)) t))
4.33+
4.34+(defmethod test-skip-p ((res test-result))
4.35+ (when (eq :skip (tr-tag res)) t))
4.36+
4.37+(defmethod print-object ((self test-result) stream)
4.38+ (print-unreadable-object (self stream)
4.39+ (format stream "~A ~A"
4.40+ (tr-tag self)
4.41+ (tr-form self))))
4.42+
4.43+;;; Test Object
4.44+(defclass test-object ()
4.45+ ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
4.46+ #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
4.47+ (:documentation "Super class for all test-related objects."))
4.48+
4.49+(defmethod print-object ((self test-object) stream)
4.50+ "test"
4.51+ (print-unreadable-object (self stream :type t :identity t)
4.52+ (format stream "~A"
4.53+ (test-name self))))
4.54+
4.55+;;;; Tests
4.56+(defclass test (test-object)
4.57+ ((fn :type symbol :accessor test-fn)
4.58+ (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
4.59+ (profile :type list :accessor test-profile :initform nil :initarg :profile)
4.60+ (args :type list :accessor test-args :initform nil :initarg :args)
4.61+ (declare :type list :accessor test-declare :initform nil :initarg :declare)
4.62+ (form :initarg :form :initform nil :accessor test-form)
4.63+ (doc :initarg :doc :type string :accessor test-doc)
4.64+ (lock :initarg :lock :type boolean :accessor test-lock-p)
4.65+ (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
4.66+ (results :initarg :results :type (array test-result) :accessor test-results))
4.67+ (:documentation "Test class typically made with `deftest'."))
4.68+
4.69+(defmethod initialize-instance ((self test) &key name)
4.70+ ;; (debug! "building test" name)
4.71+ (setf (test-fn self)
4.72+ (make-symbol
4.73+ (format nil "~A~A"
4.74+ name
4.75+ (gensym *test-suffix*))))
4.76+ (setf (test-lock-p self) t)
4.77+ ;; TODO 2023-09-21: we should count how many checks are in the :form
4.78+ ;; slot and infer the array dimensions.
4.79+ (setf (test-results self) (make-array 0 :element-type 'test-result))
4.80+ (call-next-method))
4.81+
4.82+(defmethod print-object ((self test) stream)
4.83+ (print-unreadable-object (self stream :type t :identity t)
4.84+ (format stream "~A :fn ~A"
4.85+ (test-name self)
4.86+ (test-fn self))))
4.87+
4.88+(defmethod push-result ((self test-result) (place test))
4.89+ (with-slots (results) place
4.90+ (push self results)))
4.91+
4.92+(defmethod pop-result ((self test))
4.93+ (pop (test-results self)))
4.94+
4.95+(defmethod eval-test ((self test))
4.96+ (eval `(progn ,@(test-form self))))
4.97+
4.98+(defmethod funcall-test ((self test) &key declare)
4.99+ (unless (functionp (test-fn self))
4.100+ (trace! (setf (symbol-function (test-fn self))
4.101+ (eval `(lambda ()
4.102+ ,(when declare `(declare ,declare))
4.103+ ,@(test-form self))))))
4.104+ (funcall (test-fn self)))
4.105+
4.106+(defmethod compile-test ((self test) &key declare &allow-other-keys)
4.107+ (with-compilation-unit (:policy '(optimize debug))
4.108+ (compile
4.109+ (test-fn self)
4.110+ `(lambda ()
4.111+ ,(when declare `(declare ,declare))
4.112+ ,@(test-form self)))))
4.113+
4.114+(defun fail! (form &optional fmt &rest args)
4.115+ (let ((reason (and fmt (apply #'format nil fmt args))))
4.116+ (with-simple-restart (ignore-fail "Continue testing.")
4.117+ (error 'test-failed :reason reason :form form))))
4.118+
4.119+(defmacro with-test-env (self &body body)
4.120+ `(catch '%in-test
4.121+ (setf (test-lock-p ,self) t)
4.122+ (let* ((*testing* ,self)
4.123+ (%test-bail nil)
4.124+ %test-result)
4.125+ (block %test-bail
4.126+ ,@body
4.127+ (setf (test-lock-p ,self) %test-bail))
4.128+ %test-result)))
4.129+
4.130+(defmethod do-test ((self test) &optional fx)
4.131+ (declare (ignorable fx))
4.132+ (with-test-env self
4.133+ (trace! "running test: " *testing*)
4.134+ (flet ((%do ()
4.135+ (if-let ((opt *compile-tests*))
4.136+ ;; RESEARCH 2023-08-31: with-compilation-unit?
4.137+ (progn
4.138+ (if (eq opt t)
4.139+ (setq opt *test-opts*)
4.140+ (setq opt (push *test-opts* opt)))
4.141+ ;; TODO 2023-09-21: handle failures here
4.142+ (funcall (compile-test self :declare opt))
4.143+ (setf %test-result (make-test-result :pass (test-fn self))))
4.144+ (progn
4.145+ (funcall-test self :declare '(optimize (debug 3) (safety 0)))
4.146+ (setf %test-result (make-test-result :pass (test-name self)))))))
4.147+ (if *catch-test-errors*
4.148+ (handler-bind
4.149+ ((error
4.150+ (lambda (c)
4.151+ (setf %test-bail t)
4.152+ (setf %test-result (make-test-result :fail c))
4.153+ (return-from %test-bail %test-result))))
4.154+ (%do))
4.155+ (%do)))))
4.156+
4.157+(defmethod do-test ((self simple-string) &optional fixture)
4.158+ (when-let ((test (find-test *test-suite* self)))
4.159+ (do-test test fixture)))
4.160+
4.161+(defmethod do-test ((self symbol) &optional fixture)
4.162+ (when-let ((test (find-test *test-suite* (symbol-name self))))
4.163+ (do-test test fixture)))
4.164+
4.165+;;;; Suites
4.166+(defclass test-suite (test-object)
4.167+ ((tests :initarg :set :initform nil :type list :accessor tests
4.168+ :documentation "test-suite tests")
4.169+ (results :initarg :results :initform nil :type list :accessor test-results
4.170+ :documentation "test-suite results")
4.171+ (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
4.172+ (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
4.173+ (:documentation "A class for collections of related `test' objects."))
4.174+
4.175+(defmethod print-object ((self test-suite) stream)
4.176+ (print-unreadable-object (self stream :type t :identity t)
4.177+ (format stream "~A [~d:~d:~d:~d]"
4.178+ (test-name self)
4.179+ (length (tests self))
4.180+ (count t (map-tests self #'test-lock-p))
4.181+ (count t (map-tests self #'test-persist-p))
4.182+ (length (test-results self)))))
4.183+
4.184+;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
4.185+
4.186+(deftype test-suite-designator ()
4.187+ "Either nil, a symbol, a string, or a `test-suite' object."
4.188+ '(or null symbol string test-suite keyword))
4.189+
4.190+(defun find-suite (name)
4.191+ (declare (test-suite-designator name))
4.192+ (find name *test-suite-list* :test #'test-name=))
4.193+
4.194+(defmethod map-tests ((self test-suite) function)
4.195+ ;; tests are stored in reverse order. run LIFO.
4.196+ (mapcar function (reverse (tests self))))
4.197+
4.198+(defmethod push-test ((self test) (place test-suite))
4.199+ (push self (tests place)))
4.200+
4.201+(defmethod pop-test ((self test-suite))
4.202+ (pop (tests self)))
4.203+
4.204+(defmethod push-result ((self test-result) (place test-suite))
4.205+ (with-slots (results) place
4.206+ (push self results)))
4.207+
4.208+(defmethod pop-result ((self test-suite))
4.209+ (pop (test-results self)))
4.210+
4.211+(defmethod find-test ((self test-suite) name &key (test #'test-name=))
4.212+ (declare (type (or string symbol) name)
4.213+ (type function test))
4.214+ (find name (tests self) :test test))
4.215+
4.216+(defmethod do-test ((self test-suite) &optional test)
4.217+ (push-result
4.218+ (if test
4.219+ (do-test
4.220+ (etypecase test
4.221+ (test test)
4.222+ (string (find-test self test))
4.223+ (symbol (find-test self (symbol-name test)))))
4.224+ (do-test (pop-test self)))
4.225+ self))
4.226+
4.227+;; HACK 2023-09-01: find better method of declaring failures from
4.228+;; within the body of `deftest'.
4.229+(defmethod do-suite ((self test-suite) &key stream force)
4.230+ (when stream (setf (test-stream self) stream))
4.231+ (with-slots (name stream) self
4.232+ (format stream "in suite ~x:~%"
4.233+ name)
4.234+ (format stream "; with ~A~A tests~%"
4.235+ (if force
4.236+ ""
4.237+ (format nil "~A/"
4.238+ (count t (tests self)
4.239+ :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))))
4.240+ (length (tests self)))
4.241+ ;; loop over each test, calling `do-test'. if locked or
4.242+ ;; persistent, test is performed. if FORCE is non-nil all tests
4.243+ ;; are performed.
4.244+ (map-tests self
4.245+ (lambda (x)
4.246+ (when (or force (test-lock-p x) (test-persist-p x))
4.247+ (let ((res (do-test x)))
4.248+ (push-result res self)
4.249+ (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
4.250+ ;; compare locked vs expected
4.251+ (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
4.252+ (fails
4.253+ ;; collect if locked test not expected
4.254+ (loop for r in (test-results self)
4.255+ unless (test-pass-p r)
4.256+ collect r)))
4.257+ (if (null locked)
4.258+ (format stream "~&No tests failed.~%")
4.259+ (progn
4.260+ ;; RESEARCH 2023-09-04: print fails ??
4.261+ (format stream "~&~A out of ~A ~
4.262+ total tests failed: ~
4.263+ ~:@(~{~<~% ~1:;~S~>~
4.264+ ~^, ~}~)."
4.265+ (length locked)
4.266+ (length (tests self))
4.267+ locked)
4.268+ (unless (null fails)
4.269+ (format stream "~&~A unexpected failures: ~
4.270+ ~:@(~{~<~% ~1:;~S~>~
4.271+ ~^, ~}~)."
4.272+ (length fails)
4.273+ fails))))
4.274+ ;; close stream
4.275+ (finish-output stream)
4.276+ ;; return values (PASS? LOCKED)
4.277+ (values (not fails) locked))))
4.278+
4.279+(defmethod do-suite ((self string) &key stream)
4.280+ (do-suite (ensure-suite self) :stream stream))
4.281+
4.282+(defmethod do-suite ((self symbol) &key stream)
4.283+ (do-suite (ensure-suite self) :stream stream))
4.284+
4.285+(defmethod do-suite ((self null) &key stream)
4.286+ (do-suite *test-suite* :stream stream))
4.287+
4.288+;;; Fixtures
4.289+;; Our fixtures are objects which can be inherited to build different fixture
4.290+;; classes. Fixtures inherit from TEST-OBJECT and have a NAME which usually
4.291+;; indicates the key used to initialize this object with MAKE-INSTANCE.
4.292+
4.293+;; You can use fixtures inside a test or use the push-fixture method on a
4.294+;; `test-suite' object to make it accessible within that suite.
4.295+
4.296+(defclass fixture (test-object) ())
4.297+
4.298+(defclass tmp-fixture (fixture)
4.299+ ((directory :initform #P"/tmp/" :type directory :initarg :directory)
4.300+ (file :initform nil :type (or null pathname string) :initarg :file))
4.301+ (:default-initargs
4.302+ :name :tmp))
4.303+
4.304+(defmethod make-fixture ((kind (eql :tmp)) &rest args)
4.305+ (apply 'make-instance 'tmp-fixture args))
4.306+
4.307+(defmacro with-fixture ((var (kind &rest args)) &body body)
4.308+ `(let ((,var (make-fixture ,kind ,@args)))
4.309+ ,@body))
5.1--- a/lisp/lib/rt/pkg.lisp Fri Aug 30 21:29:55 2024 -0400
5.2+++ b/lisp/lib/rt/pkg.lisp Sat Aug 31 22:34:56 2024 -0400
5.3@@ -1,4 +1,4 @@
5.4-;;; rt.lisp --- regression testing
5.5+;;; pkg.lisp --- regression testing packages
5.6
5.7 ;; Regression Testing framework. inspired by PCL, the original CMUCL
5.8 ;; code, and the SBCL port.
5.9@@ -96,7 +96,11 @@
5.10 :test-name
5.11 :tests
5.12 :test-form
5.13- :test-results))
5.14+ :test-results
5.15+ :*tmp*
5.16+ :*default-tmp-directory*
5.17+ :with-tmp-directory
5.18+ :with-tmp-file))
5.19
5.20 (defpackage :rt/bench
5.21 (:nicknames :bench)
5.22@@ -138,632 +142,3 @@
5.23 :fuzz*
5.24 :fuzz-generator
5.25 :fuzz-state))
5.26-
5.27-(in-package :rt)
5.28-(in-readtable :std)
5.29-
5.30-;;; Vars
5.31-(defvar *test-opts* '(optimize sb-c::instrument-consing))
5.32-(defvar *compile-tests* nil
5.33- "When nil do not compile tests. With a value of t, tests are compiled
5.34-with default optimizations else the value is used to configure
5.35-compiler optimizations.")
5.36-(defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
5.37-(defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.")
5.38-(defvar *test-suite-list* nil "List of available `test-suite' objects.")
5.39-(defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
5.40-(eval-when (:compile-toplevel :load-toplevel :execute)
5.41- (defvar *default-test-suite-name* "default"))
5.42-(declaim (type (or stream boolean string) *test-input*))
5.43-(defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
5.44-(defvar *testing* nil "Testing state var.")
5.45-
5.46-;;; Utils
5.47-
5.48-;; random
5.49-(defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
5.50-
5.51-(defun random-elt (seq)
5.52- (elt seq (random (length seq))))
5.53-
5.54-(defun random-ref (vec)
5.55- (aref vec (random (length vec))))
5.56-
5.57-(defun random-char ()
5.58- (random-ref *simple-charset*))
5.59-
5.60-(defun random-chars (dim)
5.61- (let ((r (make-array dim :element-type 'character)))
5.62- (dotimes (i (array-total-size r) r)
5.63- (setf (row-major-aref r i) (random-char)))))
5.64-
5.65-(defun random-byte () (random 255))
5.66-
5.67-(defun random-bytes (dim)
5.68- (let ((r (make-array dim :element-type 'octet)))
5.69- (dotimes (i (array-total-size r) r)
5.70- (setf (row-major-aref r i) (random-byte)))))
5.71-
5.72-(eval-when (:compile-toplevel :load-toplevel :execute)
5.73- (defun make-test (&rest slots)
5.74- (apply #'make-instance 'test slots))
5.75- (defun make-suite (&rest slots)
5.76- (apply #'make-instance 'test-suite slots)))
5.77-
5.78-;; TODO 2023-09-04: optimize
5.79-;;(declaim (inline do-tests))
5.80-(defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))
5.81- (if (pathnamep output)
5.82- (with-open-file (stream output :direction :output)
5.83- (do-suite (ensure-suite suite) :stream stream :force force))
5.84- (do-suite (ensure-suite suite) :stream output :force force)))
5.85-
5.86-(defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))
5.87-
5.88-;; TODO
5.89-(defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
5.90- (declare (ignore suite force))
5.91- (sb-thread:with-mutex (*test-output-mutex*)
5.92- (let ((stream (make-synonym-stream output)))
5.93- (let ((*standard-output* stream)
5.94- (*error-output* stream))
5.95- (nyi!)))))
5.96-
5.97-(defun reset-tests ()
5.98- (setq *testing* nil
5.99- *test-suite* nil
5.100- *test-suite-list* nil
5.101- *test-input* nil))
5.102-
5.103-;; this assumes that *test-suite* is re-initialized correctly to the
5.104-;; correct test-suite object.
5.105-(defun continue-testing ()
5.106- (if-let ((test *testing*))
5.107- (throw '%in-test test)
5.108- (do-suite *test-suite*)))
5.109-
5.110-;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
5.111-;; place is changed - it returns place. This is functionally sound but
5.112-;; means that if we want to do something else in the event that place
5.113-;; is unchanged, we run into some friction,
5.114-;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
5.115-(defun spush (item lst &key (test #'equal))
5.116- "Substituting `push'"
5.117- (declare (type function test))
5.118- (cond
5.119- ((null lst) (push item lst))
5.120- ((list lst)
5.121- (if-let ((found (member item lst
5.122- :test test)))
5.123- (progn
5.124- (rplaca found item)
5.125- lst)
5.126- (push item lst)))
5.127- #|(or nil '(t (cons item lst)))|#))
5.128-
5.129-;; FIX 2023-08-31: spush, replace with `add-test' method.
5.130-;; (declaim (inline normalize-test-name))
5.131-(defun normalize-test-name (a)
5.132- "Return the normalized `test-suite-designator' of A."
5.133- (etypecase a
5.134- (string (string-upcase a))
5.135- (symbol (symbol-name a))
5.136- (test-object (normalize-test-name (test-name a)))
5.137- (t (format nil "~A" a))))
5.138-
5.139-(defun test-name= (a b)
5.140- "Return t if A and B are similar `test-suite-designator's."
5.141- (let ((a (normalize-test-name a))
5.142- (b (normalize-test-name b)))
5.143- (string= a b)))
5.144-
5.145-;; (declaim (inline assert-suite ensure-suite))
5.146-(defun ensure-suite (name)
5.147- (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
5.148- (car ok)
5.149- (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
5.150-
5.151-(defun check-suite-designator (suite) (check-type suite test-suite-designator))
5.152-
5.153-(defun assert-suite (name)
5.154- (check-suite-designator name)
5.155- (assert (ensure-suite name)))
5.156-
5.157-(declaim (inline test-opt-key-p test-opt-valid-p))
5.158-(defun test-opt-key-p (k)
5.159- "Test if K is a `test-opt-key'."
5.160- (member k '(:profile :save :stream)))
5.161-
5.162-(defun test-opt-valid-p (f)
5.163- "Test if F is a valid `test-opt' form. If so, return F else nil."
5.164- (when (test-opt-key-p (car f))
5.165- f))
5.166-
5.167-;;; Conditions
5.168-(define-condition test-failed (error)
5.169- ((reason :accessor fail-reason :initarg :reason :initform "unknown")
5.170- (name :accessor fail-name :initarg :name)
5.171- (form :accessor fail-form :initarg :form))
5.172- (:documentation "Signaled when a test fails.")
5.173- (:report (lambda (c s)
5.174- (format s "The following expression failed: ~S~%~A."
5.175- (fail-form c)
5.176- (fail-reason c)))))
5.177-
5.178-;;; Protocol
5.179-(defgeneric eval-test (self)
5.180- (:documentation "Eval a `test'."))
5.181-
5.182-(defgeneric compile-test (self &key &allow-other-keys)
5.183- (:documentation "Compile a `test'."))
5.184-
5.185-(defgeneric locked-tests (self)
5.186- (:documentation "Return a list of locked tests in `test-suite' object SELF."))
5.187-
5.188-(defgeneric push-test (self place)
5.189- (:documentation
5.190- "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
5.191-
5.192-(defgeneric pop-test (self)
5.193- (:documentation
5.194- "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
5.195-
5.196-(defgeneric push-result (self place)
5.197- (:documentation
5.198- "Push object SELF to the value of slot ':results' in object PLACE."))
5.199-
5.200-(defgeneric pop-result (self)
5.201- (:documentation
5.202- "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
5.203-
5.204-(defgeneric push-fixture (self place)
5.205- (:documentation
5.206- "Push object SELF to the value of slot ':results' in object PLACE."))
5.207-
5.208-(defgeneric delete-test (self &key &allow-other-keys)
5.209- (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
5.210-
5.211-(defgeneric find-test (self name &key &allow-other-keys)
5.212- (:documentation "Find `test' object specified by name and optional keys."))
5.213-
5.214-(defgeneric do-test (self &optional context)
5.215- (:documentation "Run test SELF, printing results to *standard-output*. The second
5.216-argument is an optional fixture.
5.217-
5.218-SELF can also be a `test-suite', in which case the TESTS slot is
5.219-queried for the value of TEST. If TEST is not provided, pops the car
5.220-from TESTS."))
5.221-
5.222-(defgeneric do-suite (self &key &allow-other-keys)
5.223- (:documentation
5.224- "Perform actions on `test-suite' object SELF with optional keys."))
5.225-
5.226-;;;; Results
5.227-(deftype result-tag ()
5.228- '(or (member :pass :fail :skip) null))
5.229-
5.230-(declaim (inline %make-test-result))
5.231-(defstruct (test-result (:constructor %make-test-result)
5.232- (:conc-name tr-))
5.233- (tag nil :type result-tag :read-only t)
5.234- (form nil :type form))
5.235-
5.236-(defmethod print-object ((self test-result) stream)
5.237- (print-unreadable-object (self stream :identity t)
5.238- (format stream "~A ~A" (tr-tag self) (tr-form self))))
5.239-
5.240-(defun make-test-result (tag &optional form)
5.241- (%make-test-result :tag tag :form form))
5.242-
5.243-(defmethod test-pass-p ((res test-result))
5.244- (when (eq :pass (tr-tag res)) t))
5.245-
5.246-(defmethod test-fail-p ((res test-result))
5.247- (when (eq :fail (tr-tag res)) t))
5.248-
5.249-(defmethod test-skip-p ((res test-result))
5.250- (when (eq :skip (tr-tag res)) t))
5.251-
5.252-(defmethod print-object ((self test-result) stream)
5.253- (print-unreadable-object (self stream)
5.254- (format stream "~A ~A"
5.255- (tr-tag self)
5.256- (tr-form self))))
5.257-
5.258-;;; Objects
5.259-(defclass test-object ()
5.260- ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
5.261- #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
5.262- (:documentation "Super class for all test-related objects."))
5.263-
5.264-(defmethod print-object ((self test-object) stream)
5.265- "test"
5.266- (print-unreadable-object (self stream :type t :identity t)
5.267- (format stream "~A"
5.268- (test-name self))))
5.269-
5.270-;;;; Tests
5.271-;; HACK 2023-08-31: inherit sxp?
5.272-
5.273-(defclass test (test-object)
5.274- ((fn :type symbol :accessor test-fn)
5.275- (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
5.276- (profile :type list :accessor test-profile :initform nil :initarg :profile)
5.277- (args :type list :accessor test-args :initform nil :initarg :args)
5.278- (declare :type list :accessor test-declare :initform nil :initarg :declare)
5.279- (form :initarg :form :initform nil :accessor test-form)
5.280- (doc :initarg :doc :type string :accessor test-doc)
5.281- (lock :initarg :lock :type boolean :accessor test-lock-p)
5.282- (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
5.283- (results :initarg :results :type (array test-result) :accessor test-results))
5.284- (:documentation "Test class typically made with `deftest'."))
5.285-
5.286-(defmethod initialize-instance ((self test) &key name)
5.287- ;; (debug! "building test" name)
5.288- (setf (test-fn self)
5.289- (make-symbol
5.290- (format nil "~A~A"
5.291- name
5.292- (gensym *test-suffix*))))
5.293- (setf (test-lock-p self) t)
5.294- ;; TODO 2023-09-21: we should count how many checks are in the :form
5.295- ;; slot and infer the array dimensions.
5.296- (setf (test-results self) (make-array 0 :element-type 'test-result))
5.297- (call-next-method))
5.298-
5.299-(defmethod print-object ((self test) stream)
5.300- (print-unreadable-object (self stream :type t :identity t)
5.301- (format stream "~A :fn ~A"
5.302- (test-name self)
5.303- (test-fn self))))
5.304-
5.305-(defmethod push-result ((self test-result) (place test))
5.306- (with-slots (results) place
5.307- (push self results)))
5.308-
5.309-(defmethod pop-result ((self test))
5.310- (pop (test-results self)))
5.311-
5.312-(defmethod eval-test ((self test))
5.313- (eval `(progn ,@(test-form self))))
5.314-
5.315-(defmethod funcall-test ((self test) &key declare)
5.316- (unless (functionp (test-fn self))
5.317- (trace! (setf (symbol-function (test-fn self))
5.318- (eval `(lambda ()
5.319- ,(when declare `(declare ,declare))
5.320- ,@(test-form self))))))
5.321- (funcall (test-fn self)))
5.322-
5.323-(defmethod compile-test ((self test) &key declare &allow-other-keys)
5.324- (with-compilation-unit (:policy '(optimize debug))
5.325- (compile
5.326- (test-fn self)
5.327- `(lambda ()
5.328- ,(when declare `(declare ,declare))
5.329- ,@(test-form self)))))
5.330-
5.331-(defun fail! (form &optional fmt &rest args)
5.332- (let ((reason (and fmt (apply #'format nil fmt args))))
5.333- (with-simple-restart (ignore-fail "Continue testing.")
5.334- (error 'test-failed :reason reason :form form))))
5.335-
5.336-(defmacro with-test-env (self &body body)
5.337- `(catch '%in-test
5.338- (setf (test-lock-p ,self) t)
5.339- (let* ((*testing* ,self)
5.340- (%test-bail nil)
5.341- %test-result)
5.342- (block %test-bail
5.343- ,@body
5.344- (setf (test-lock-p ,self) %test-bail))
5.345- %test-result)))
5.346-
5.347-(defmethod do-test ((self test) &optional fx)
5.348- (declare (ignorable fx))
5.349- (with-test-env self
5.350- (trace! "running test: " *testing*)
5.351- (flet ((%do ()
5.352- (if-let ((opt *compile-tests*))
5.353- ;; RESEARCH 2023-08-31: with-compilation-unit?
5.354- (progn
5.355- (if (eq opt t)
5.356- (setq opt *test-opts*)
5.357- (setq opt (push *test-opts* opt)))
5.358- ;; TODO 2023-09-21: handle failures here
5.359- (funcall (compile-test self :declare opt))
5.360- (setf %test-result (make-test-result :pass (test-fn self))))
5.361- (progn
5.362- (funcall-test self :declare '(optimize (debug 3) (safety 0)))
5.363- (setf %test-result (make-test-result :pass (test-name self)))))))
5.364- (if *catch-test-errors*
5.365- (handler-bind
5.366- ((error
5.367- (lambda (c)
5.368- (setf %test-bail t)
5.369- (setf %test-result (make-test-result :fail c))
5.370- (return-from %test-bail %test-result))))
5.371- (%do))
5.372- (%do)))))
5.373-
5.374-(defmethod do-test ((self simple-string) &optional fixture)
5.375- (when-let ((test (find-test *test-suite* self)))
5.376- (do-test test fixture)))
5.377-
5.378-(defmethod do-test ((self symbol) &optional fixture)
5.379- (when-let ((test (find-test *test-suite* (symbol-name self))))
5.380- (do-test test fixture)))
5.381-
5.382-;;;; Fixtures
5.383-
5.384-;; Our fixtures are just closures - with a pandoric environment. You
5.385-;; might call it a domain-specific object protocol.
5.386-
5.387-;; You can build fixtures inside a test or use the push-fixture
5.388-;; method on a `test-suite' object.
5.389-
5.390-(deftype fixture () 'form)
5.391-
5.392-(declaim (inline %make-fixture-prototype))
5.393-(defstruct (fixture-prototype (:constructor %make-fixture-prototype)
5.394- (:conc-name fxp))
5.395- (kind :empty :type keyword)
5.396- (form nil :type form))
5.397-
5.398-(defun make-fixture-prototype (kind form)
5.399- (%make-fixture-prototype :kind kind :form form))
5.400-
5.401-(defmacro make-fixture (letargs &body ds)
5.402- (let ((letargs (let-binding-transform letargs)))
5.403- `(let (,@letargs)
5.404- (dlambda ,@ds))))
5.405-
5.406-(defmacro with-fixture ((var fx) &body body)
5.407- `(let ((,var ,fx))
5.408- ,@body))
5.409-
5.410-;;;; Suites
5.411-(defclass test-suite (test-object)
5.412- ((tests :initarg :set :initform nil :type list :accessor tests
5.413- :documentation "test-suite tests")
5.414- (results :initarg :results :initform nil :type list :accessor test-results
5.415- :documentation "test-suite results")
5.416- (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
5.417- (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
5.418- (:documentation "A class for collections of related `test' objects."))
5.419-
5.420-(defmethod print-object ((self test-suite) stream)
5.421- (print-unreadable-object (self stream :type t :identity t)
5.422- (format stream "~A [~d:~d:~d:~d]"
5.423- (test-name self)
5.424- (length (tests self))
5.425- (count t (map-tests self #'test-lock-p))
5.426- (count t (map-tests self #'test-persist-p))
5.427- (length (test-results self)))))
5.428-
5.429-;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
5.430-
5.431-(deftype test-suite-designator ()
5.432- "Either nil, a symbol, a string, or a `test-suite' object."
5.433- '(or null symbol string test-suite keyword))
5.434-
5.435-(defun find-suite (name)
5.436- (declare (test-suite-designator name))
5.437- (find name *test-suite-list* :test #'test-name=))
5.438-
5.439-(defmethod map-tests ((self test-suite) function)
5.440- ;; tests are stored in reverse order. run LIFO.
5.441- (mapcar function (reverse (tests self))))
5.442-
5.443-(defmethod push-test ((self test) (place test-suite))
5.444- (push self (tests place)))
5.445-
5.446-(defmethod pop-test ((self test-suite))
5.447- (pop (tests self)))
5.448-
5.449-(defmethod push-result ((self test-result) (place test-suite))
5.450- (with-slots (results) place
5.451- (push self results)))
5.452-
5.453-(defmethod pop-result ((self test-suite))
5.454- (pop (test-results self)))
5.455-
5.456-(defmethod find-test ((self test-suite) name &key (test #'test-name=))
5.457- (declare (type (or string symbol) name)
5.458- (type function test))
5.459- (find name (tests self) :test test))
5.460-
5.461-(defmethod do-test ((self test-suite) &optional test)
5.462- (push-result
5.463- (if test
5.464- (do-test
5.465- (etypecase test
5.466- (test test)
5.467- (string (find-test self test))
5.468- (symbol (find-test self (symbol-name test)))))
5.469- (do-test (pop-test self)))
5.470- self))
5.471-
5.472-;; HACK 2023-09-01: find better method of declaring failures from
5.473-;; within the body of `deftest'.
5.474-(defmethod do-suite ((self test-suite) &key stream force)
5.475- (when stream (setf (test-stream self) stream))
5.476- (with-slots (name stream) self
5.477- (format stream "in suite ~x:~%"
5.478- name)
5.479- (format stream "; with ~A~A tests~%"
5.480- (if force
5.481- ""
5.482- (format nil "~A/"
5.483- (count t (tests self)
5.484- :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))))
5.485- (length (tests self)))
5.486- ;; loop over each test, calling `do-test'. if locked or
5.487- ;; persistent, test is performed. if FORCE is non-nil all tests
5.488- ;; are performed.
5.489- (map-tests self
5.490- (lambda (x)
5.491- (when (or force (test-lock-p x) (test-persist-p x))
5.492- (let ((res (do-test x)))
5.493- (push-result res self)
5.494- (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
5.495- ;; compare locked vs expected
5.496- (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
5.497- (fails
5.498- ;; collect if locked test not expected
5.499- (loop for r in (test-results self)
5.500- unless (test-pass-p r)
5.501- collect r)))
5.502- (if (null locked)
5.503- (format stream "~&No tests failed.~%")
5.504- (progn
5.505- ;; RESEARCH 2023-09-04: print fails ??
5.506- (format stream "~&~A out of ~A ~
5.507- total tests failed: ~
5.508- ~:@(~{~<~% ~1:;~S~>~
5.509- ~^, ~}~)."
5.510- (length locked)
5.511- (length (tests self))
5.512- locked)
5.513- (unless (null fails)
5.514- (format stream "~&~A unexpected failures: ~
5.515- ~:@(~{~<~% ~1:;~S~>~
5.516- ~^, ~}~)."
5.517- (length fails)
5.518- fails))))
5.519- ;; close stream
5.520- (finish-output stream)
5.521- ;; return values (PASS? LOCKED)
5.522- (values (not fails) locked))))
5.523-
5.524-(defmethod do-suite ((self string) &key stream)
5.525- (do-suite (ensure-suite self) :stream stream))
5.526-
5.527-(defmethod do-suite ((self symbol) &key stream)
5.528- (do-suite (ensure-suite self) :stream stream))
5.529-
5.530-(defmethod do-suite ((self null) &key stream)
5.531- (do-suite *test-suite* :stream stream))
5.532-
5.533-;;; Checks
5.534-(eval-always
5.535- (defun %test (val &optional form)
5.536- (let ((r
5.537- (if val
5.538- (make-test-result :pass form)
5.539- (make-test-result :fail form))))
5.540- ;; (print r *standard-output*)
5.541- r)))
5.542-
5.543-(defmacro is (test &rest args)
5.544- "The DWIM Check.
5.545-
5.546-(is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
5.547-If TEST returns a truthy value, return a PASS test-result, else return
5.548-a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
5.549-
5.550-If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
5.551-and evaluated 'as-is'.
5.552-
5.553-(nyi!)
5.554-ARGS may contain the following keywords followed by a corresponding
5.555-value:
5.556-
5.557-:EXPECTED
5.558-
5.559-:TIMEOUT
5.560-
5.561-:THEN
5.562-
5.563-All other values are treated as let bindings.
5.564-"
5.565- (with-gensyms (form)
5.566- `(if ,(null args)
5.567- (if *testing*
5.568- (push-result (trace! (funcall #'rt::%test ,test ',test)) *testing*)
5.569- (trace! (funcall #'rt::%test ,test ',test)))
5.570- (macrolet ((,form (test) `(let ,,(group args 2) ,test)))
5.571- ;; TODO 2023-09-21: does this work...
5.572- (if *testing*
5.573- (push-result (trace! (funcall #'rt::%test (,form ,test) ',test) *testing*))
5.574- (trace! (funcall #'rt::%test (,form ,test) ',test)))))))
5.575-
5.576-(defmacro signals (condition-spec &body body)
5.577- "Generates a passing TEST-RESULT if body signals a condition of type
5.578-CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
5.579-is not evaluated."
5.580- (let ((block-name (gensym)))
5.581- (destructuring-bind (condition &optional reason-control &rest reason-args)
5.582- (ensure-list condition-spec)
5.583- `(block ,block-name
5.584- (handler-bind ((,condition (lambda (c)
5.585- (declare (ignore c))
5.586- ;; ok, body threw condition
5.587- ;; TODO 2023-09-05: result collectors
5.588- ;; (add-result 'test-passed
5.589- ;; :test-expr ',condition)
5.590- (return-from ,block-name (make-test-result :pass ',body)))))
5.591- (block nil
5.592- (locally (declare (sb-ext:muffle-conditions warning))
5.593- ,@body)))
5.594- (fail!
5.595- ',condition
5.596- ,@(if reason-control
5.597- `(,reason-control ,@reason-args)
5.598- `("Failed to signal a ~S" ',condition)))
5.599- (return-from ,block-name nil)))))
5.600-
5.601-;;; Macros
5.602-(defmacro deftest (name props &body body)
5.603- "Build a test with NAME, parameterized by PROPS and with a test form of BODY.
5.604-
5.605-PROPS is a plist which currently accepts the following parameters:
5.606-
5.607-:PERSIST - re-run this test even if it passes
5.608-
5.609-:ARGS - nyi
5.610-
5.611-:PROFILE - enable profiling of this test
5.612-
5.613-:SKIP - don't push this test to the current *TEST-SUITE*
5.614-
5.615-:BENCH - enable benchmarking of this test
5.616-
5.617-BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
5.618-and declarations for the test body.
5.619-"
5.620- (destructuring-bind (pr doc dec fn)
5.621- (multiple-value-bind (forms dec doc)
5.622- ;; parse body with docstring allowed
5.623- (parse-body (or body) :documentation t :whole t)
5.624- `(,props ,doc ,dec ',forms))
5.625- ;; TODO 2023-09-21: parse plist
5.626- `(let ((obj (make-test
5.627- :name ,(format nil "~A" name)
5.628- :form ,fn
5.629- ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
5.630- ,@(when-let ((v (getf pr :args))) `(:args ',v))
5.631- ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
5.632- ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
5.633- ,@(when doc `(:doc ,doc))
5.634- ,@(when dec `(:declare ,dec)))))
5.635- ,(unless (getf pr :skip) '(push-test obj *test-suite*))
5.636- obj)))
5.637-
5.638-(defmacro defsuite (suite-name &rest props)
5.639- "Define a TEST-SUITE with provided keys. The object returned can be
5.640-enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API."
5.641- (check-type suite-name (or symbol string))
5.642- `(eval-when (:compile-toplevel :load-toplevel :execute)
5.643- (let ((obj (make-suite
5.644- :name (format nil "~A" ',suite-name)
5.645- ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
5.646- (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
5.647- obj)))
5.648-
5.649-(defmacro in-suite (name)
5.650- "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol
5.651-NAME. Return the object."
5.652- (assert-suite name)
5.653- `(progn
5.654- (setq *test-suite* (ensure-suite ,name))))
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/lisp/lib/rt/proto.lisp Sat Aug 31 22:34:56 2024 -0400
6.3@@ -0,0 +1,57 @@
6.4+;;; proto.lisp --- Test Protocols
6.5+
6.6+;;
6.7+
6.8+;;; Code:
6.9+(in-package :rt)
6.10+
6.11+(defgeneric eval-test (self)
6.12+ (:documentation "Eval a `test'."))
6.13+
6.14+(defgeneric compile-test (self &key &allow-other-keys)
6.15+ (:documentation "Compile a `test'."))
6.16+
6.17+(defgeneric locked-tests (self)
6.18+ (:documentation "Return a list of locked tests in `test-suite' object SELF."))
6.19+
6.20+(defgeneric push-test (self place)
6.21+ (:documentation
6.22+ "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
6.23+
6.24+(defgeneric pop-test (self)
6.25+ (:documentation
6.26+ "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
6.27+
6.28+(defgeneric push-result (self place)
6.29+ (:documentation
6.30+ "Push object SELF to the value of slot ':results' in object PLACE."))
6.31+
6.32+(defgeneric pop-result (self)
6.33+ (:documentation
6.34+ "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
6.35+
6.36+(defgeneric push-fixture (self place)
6.37+ (:documentation
6.38+ "Push object SELF to the value of slot ':results' in object PLACE."))
6.39+
6.40+(defgeneric delete-test (self &key &allow-other-keys)
6.41+ (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
6.42+
6.43+(defgeneric find-test (self name &key &allow-other-keys)
6.44+ (:documentation "Find `test' object specified by name and optional keys."))
6.45+
6.46+(defgeneric do-test (self &optional context)
6.47+ (:documentation "Run test SELF, printing results to *standard-output*. The second
6.48+argument is an optional fixture.
6.49+
6.50+SELF can also be a `test-suite', in which case the TESTS slot is
6.51+queried for the value of TEST. If TEST is not provided, pops the car
6.52+from TESTS."))
6.53+
6.54+(defgeneric do-suite (self &key &allow-other-keys)
6.55+ (:documentation
6.56+ "Perform actions on `test-suite' object SELF with optional keys."))
6.57+
6.58+(defgeneric make-fixture (kind &rest args &key &allow-other-keys)
6.59+ (:documentation
6.60+ "Make a FIXTURE object with optional init ARGS."))
7.1--- a/lisp/lib/rt/rt.asd Fri Aug 30 21:29:55 2024 -0400
7.2+++ b/lisp/lib/rt/rt.asd Sat Aug 31 22:34:56 2024 -0400
7.3@@ -2,11 +2,17 @@
7.4 (defsystem :rt
7.5 :depends-on (:std :log :dat :sb-sprof)
7.6 :components ((:file "pkg")
7.7- (:file "bench" :depends-on ("pkg"))
7.8- (:file "tracing" :depends-on ("pkg"))
7.9- (:file "flamegraph" :depends-on ("pkg"))
7.10- (:file "cover" :depends-on ("pkg"))
7.11- (:file "fuzz" :depends-on ("pkg")))
7.12+ (:file "var" :depends-on ("pkg"))
7.13+ (:file "err" :depends-on ("pkg"))
7.14+ (:file "util" :depends-on ("err" "var"))
7.15+ (:file "proto" :depends-on ("pkg"))
7.16+ (:file "obj" :depends-on ("proto" "util"))
7.17+ (:file "rt" :depends-on ("obj"))
7.18+ (:file "bench" :depends-on ("rt"))
7.19+ (:file "tracing" :depends-on ("rt"))
7.20+ (:file "flamegraph" :depends-on ("rt"))
7.21+ (:file "cover" :depends-on ("rt"))
7.22+ (:file "fuzz" :depends-on ("rt")))
7.23 :in-order-to ((test-op (test-op "rt/tests"))))
7.24
7.25 (defsystem :rt/tests
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/lisp/lib/rt/rt.lisp Sat Aug 31 22:34:56 2024 -0400
8.3@@ -0,0 +1,129 @@
8.4+;;; rt.lisp --- Regression Testing
8.5+
8.6+;;
8.7+
8.8+;;; Code:
8.9+(in-package :rt)
8.10+
8.11+;;; Checks
8.12+(eval-always
8.13+ (defun %test (val &optional form)
8.14+ (let ((r
8.15+ (if val
8.16+ (make-test-result :pass form)
8.17+ (make-test-result :fail form))))
8.18+ ;; (print r *standard-output*)
8.19+ r)))
8.20+
8.21+(defmacro is (test &rest args)
8.22+ "The DWIM Check.
8.23+
8.24+(is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
8.25+If TEST returns a truthy value, return a PASS test-result, else return
8.26+a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
8.27+
8.28+If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
8.29+and evaluated 'as-is'.
8.30+
8.31+(nyi!)
8.32+ARGS may contain the following keywords followed by a corresponding
8.33+value:
8.34+
8.35+:EXPECTED
8.36+
8.37+:TIMEOUT
8.38+
8.39+:THEN
8.40+
8.41+All other values are treated as let bindings.
8.42+"
8.43+ (with-gensyms (form)
8.44+ `(if ,(null args)
8.45+ (if *testing*
8.46+ (push-result (trace! (funcall #'rt::%test ,test ',test)) *testing*)
8.47+ (trace! (funcall #'rt::%test ,test ',test)))
8.48+ (macrolet ((,form (test) `(let ,,(group args 2) ,test)))
8.49+ ;; TODO 2023-09-21: does this work...
8.50+ (if *testing*
8.51+ (push-result (trace! (funcall #'rt::%test (,form ,test) ',test) *testing*))
8.52+ (trace! (funcall #'rt::%test (,form ,test) ',test)))))))
8.53+
8.54+(defmacro signals (condition-spec &body body)
8.55+ "Generates a passing TEST-RESULT if body signals a condition of type
8.56+CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
8.57+is not evaluated."
8.58+ (let ((block-name (gensym)))
8.59+ (destructuring-bind (condition &optional reason-control &rest reason-args)
8.60+ (ensure-list condition-spec)
8.61+ `(block ,block-name
8.62+ (handler-bind ((,condition (lambda (c)
8.63+ (declare (ignore c))
8.64+ ;; ok, body threw condition
8.65+ ;; TODO 2023-09-05: result collectors
8.66+ ;; (add-result 'test-passed
8.67+ ;; :test-expr ',condition)
8.68+ (return-from ,block-name (make-test-result :pass ',body)))))
8.69+ (block nil
8.70+ (locally (declare (sb-ext:muffle-conditions warning))
8.71+ ,@body)))
8.72+ (fail!
8.73+ ',condition
8.74+ ,@(if reason-control
8.75+ `(,reason-control ,@reason-args)
8.76+ `("Failed to signal a ~S" ',condition)))
8.77+ (return-from ,block-name nil)))))
8.78+
8.79+;;; Macros
8.80+(defmacro deftest (name props &body body)
8.81+ "Build a test with NAME, parameterized by PROPS and with a test form of BODY.
8.82+
8.83+PROPS is a plist which currently accepts the following parameters:
8.84+
8.85+:PERSIST - re-run this test even if it passes
8.86+
8.87+:ARGS - nyi
8.88+
8.89+:PROFILE - enable profiling of this test
8.90+
8.91+:SKIP - don't push this test to the current *TEST-SUITE*
8.92+
8.93+:BENCH - enable benchmarking of this test
8.94+
8.95+BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
8.96+and declarations for the test body.
8.97+"
8.98+ (destructuring-bind (pr doc dec fn)
8.99+ (multiple-value-bind (forms dec doc)
8.100+ ;; parse body with docstring allowed
8.101+ (parse-body (or body) :documentation t :whole t)
8.102+ `(,props ,doc ,dec ',forms))
8.103+ ;; TODO 2023-09-21: parse plist
8.104+ `(let ((obj (make-test
8.105+ :name ,(format nil "~A" name)
8.106+ :form ,fn
8.107+ ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
8.108+ ,@(when-let ((v (getf pr :args))) `(:args ',v))
8.109+ ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
8.110+ ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
8.111+ ,@(when doc `(:doc ,doc))
8.112+ ,@(when dec `(:declare ,dec)))))
8.113+ ,(unless (getf pr :skip) '(push-test obj *test-suite*))
8.114+ obj)))
8.115+
8.116+(defmacro defsuite (suite-name &rest props)
8.117+ "Define a TEST-SUITE with provided keys. The object returned can be
8.118+enabled using the IN-SUITE macro, similiar to the DEFPACKAGE API."
8.119+ (check-type suite-name (or symbol string))
8.120+ `(eval-when (:compile-toplevel :load-toplevel :execute)
8.121+ (let ((obj (make-suite
8.122+ :name (format nil "~A" ',suite-name)
8.123+ ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
8.124+ (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
8.125+ obj)))
8.126+
8.127+(defmacro in-suite (name)
8.128+ "Set *TEST-SUITE* to the TEST-SUITE object referred to by symbol
8.129+NAME. Return the object."
8.130+ (assert-suite name)
8.131+ `(progn
8.132+ (setq *test-suite* (ensure-suite ,name))))
9.1--- a/lisp/lib/rt/tests.lisp Fri Aug 30 21:29:55 2024 -0400
9.2+++ b/lisp/lib/rt/tests.lisp Sat Aug 31 22:34:56 2024 -0400
9.3@@ -7,15 +7,8 @@
9.4 (in-suite :rt)
9.5
9.6 (deftest rt (:profile t :persist t)
9.7- (is (typep (make-fixture-prototype :empty nil) 'fixture-prototype))
9.8- (with-fixture (fx (make-fixture ((a 1) (b 2))
9.9- (:+ () (+ (incf a) (incf b)))
9.10- (:- () (- (decf a) (decf b)))
9.11- (t () 0)))
9.12- (is (= 5 (funcall fx :+)))
9.13- (is (= 7 (funcall fx :+)))
9.14- (is (= -1 (funcall fx :-)))
9.15- (is (= 0 (funcall fx))))
9.16+ (with-fixture (fx (:tmp :directory "/tmp/"))
9.17+ (is fx))
9.18 (signals (error t) (test-form (make-instance 'test-result))))
9.19
9.20 (deftest flamegraph (:profile t)
9.21@@ -48,3 +41,15 @@
9.22 (start-coverage)
9.23 (stop-coverage)
9.24 (coverage-report))
9.25+
9.26+(deftest tmp ()
9.27+ (is (null (with-tmp-directory ())))
9.28+ (is (null (with-tmp-file ())))
9.29+ (is (with-tmp-file (f1 :name "temporary-file")
9.30+ (is (probe-file *tmp*))
9.31+ (write-string "1 2 3 4" f1)
9.32+ (force-output f1)
9.33+ (is (= 7 (file-length f1)))))
9.34+ (is (with-tmp-directory ("foobar")
9.35+ (is (directory-path-p (probe-file *tmp*))))))
9.36+
10.1--- a/lisp/lib/rt/util.lisp Fri Aug 30 21:29:55 2024 -0400
10.2+++ b/lisp/lib/rt/util.lisp Sat Aug 31 22:34:56 2024 -0400
10.3@@ -9,3 +9,144 @@
10.4
10.5 ;;; Code:
10.6 (in-package :rt)
10.7+
10.8+;;; tmp
10.9+(defmacro with-tmp-directory ((&optional (name (string (gensym "tmp")))
10.10+ (defaults *default-tmp-directory*))
10.11+ &body body)
10.12+ `(let ((*tmp* (directory-path (merge-pathnames ,name ,defaults))))
10.13+ (ensure-directories-exist *tmp*)
10.14+ (unwind-protect (progn ,@body)
10.15+ (sb-ext:delete-directory *tmp* :recursive t))))
10.16+
10.17+(defmacro with-tmp-file ((stream-var &key (name (string (gensym "tmp")))
10.18+ type
10.19+ (directory *default-tmp-directory*)
10.20+ (direction :output)
10.21+ (if-exists :supersede)
10.22+ (element-type ''character))
10.23+ &body body)
10.24+ `(let ((*tmp* (make-pathname :name ,name :type ,type :directory ,(namestring directory))))
10.25+ (with-open-file (,stream-var *tmp* :direction ,direction :element-type ,element-type
10.26+ :if-exists ,if-exists)
10.27+ (unwind-protect (progn ,@body)
10.28+ (delete-file *tmp*)))))
10.29+
10.30+;;; random
10.31+(defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
10.32+
10.33+(defun random-elt (seq)
10.34+ (elt seq (random (length seq))))
10.35+
10.36+(defun random-ref (vec)
10.37+ (aref vec (random (length vec))))
10.38+
10.39+(defun random-char ()
10.40+ (random-ref *simple-charset*))
10.41+
10.42+(defun random-chars (dim)
10.43+ (let ((r (make-array dim :element-type 'character)))
10.44+ (dotimes (i (array-total-size r) r)
10.45+ (setf (row-major-aref r i) (random-char)))))
10.46+
10.47+(defun random-byte () (random 255))
10.48+
10.49+(defun random-bytes (dim)
10.50+ (let ((r (make-array dim :element-type 'octet)))
10.51+ (dotimes (i (array-total-size r) r)
10.52+ (setf (row-major-aref r i) (random-byte)))))
10.53+
10.54+(eval-when (:compile-toplevel :load-toplevel :execute)
10.55+ (defun make-test (&rest slots)
10.56+ (apply #'make-instance 'test slots))
10.57+ (defun make-suite (&rest slots)
10.58+ (apply #'make-instance 'test-suite slots)))
10.59+
10.60+;; TODO 2023-09-04: optimize
10.61+;;(declaim (inline do-tests))
10.62+(defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))
10.63+ (if (pathnamep output)
10.64+ (with-open-file (stream output :direction :output)
10.65+ (do-suite (ensure-suite suite) :stream stream :force force))
10.66+ (do-suite (ensure-suite suite) :stream output :force force)))
10.67+
10.68+(defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))
10.69+
10.70+;; TODO
10.71+(defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
10.72+ (declare (ignore suite force))
10.73+ (sb-thread:with-mutex (*test-output-mutex*)
10.74+ (let ((stream (make-synonym-stream output)))
10.75+ (let ((*standard-output* stream)
10.76+ (*error-output* stream))
10.77+ (nyi!)))))
10.78+
10.79+(defun reset-tests ()
10.80+ (setq *testing* nil
10.81+ *test-suite* nil
10.82+ *test-suite-list* nil
10.83+ *test-input* nil))
10.84+
10.85+;; this assumes that *test-suite* is re-initialized correctly to the
10.86+;; correct test-suite object.
10.87+(defun continue-testing ()
10.88+ (if-let ((test *testing*))
10.89+ (throw '%in-test test)
10.90+ (do-suite *test-suite*)))
10.91+
10.92+;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
10.93+;; place is changed - it returns place. This is functionally sound but
10.94+;; means that if we want to do something else in the event that place
10.95+;; is unchanged, we run into some friction,
10.96+;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
10.97+(defun spush (item lst &key (test #'equal))
10.98+ "Substituting `push'"
10.99+ (declare (type function test))
10.100+ (cond
10.101+ ((null lst) (push item lst))
10.102+ ((list lst)
10.103+ (if-let ((found (member item lst
10.104+ :test test)))
10.105+ (progn
10.106+ (rplaca found item)
10.107+ lst)
10.108+ (push item lst)))
10.109+ #|(or nil '(t (cons item lst)))|#))
10.110+
10.111+;; FIX 2023-08-31: spush, replace with `add-test' method.
10.112+;; (declaim (inline normalize-test-name))
10.113+(defun normalize-test-name (a)
10.114+ "Return the normalized `test-suite-designator' of A."
10.115+ (etypecase a
10.116+ (string (string-upcase a))
10.117+ (symbol (symbol-name a))
10.118+ (test-object (normalize-test-name (test-name a)))
10.119+ (t (format nil "~A" a))))
10.120+
10.121+(defun test-name= (a b)
10.122+ "Return t if A and B are similar `test-suite-designator's."
10.123+ (let ((a (normalize-test-name a))
10.124+ (b (normalize-test-name b)))
10.125+ (string= a b)))
10.126+
10.127+;; (declaim (inline assert-suite ensure-suite))
10.128+(defun ensure-suite (name)
10.129+ (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
10.130+ (car ok)
10.131+ (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
10.132+
10.133+(defun check-suite-designator (suite) (check-type suite test-suite-designator))
10.134+
10.135+(defun assert-suite (name)
10.136+ (check-suite-designator name)
10.137+ (assert (ensure-suite name)))
10.138+
10.139+(declaim (inline test-opt-key-p test-opt-valid-p))
10.140+(defun test-opt-key-p (k)
10.141+ "Test if K is a `test-opt-key'."
10.142+ (member k '(:profile :save :stream)))
10.143+
10.144+(defun test-opt-valid-p (f)
10.145+ "Test if F is a valid `test-opt' form. If so, return F else nil."
10.146+ (when (test-opt-key-p (car f))
10.147+ f))
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/lisp/lib/rt/var.lisp Sat Aug 31 22:34:56 2024 -0400
11.3@@ -0,0 +1,27 @@
11.4+;;; var.lisp --- Test Variables
11.5+
11.6+;;
11.7+
11.8+;;; Code:
11.9+(in-package :rt)
11.10+
11.11+;;; Vars
11.12+(defvar *test-opts* '(optimize sb-c::instrument-consing))
11.13+(defvar *compile-tests* nil
11.14+ "When nil do not compile tests. With a value of t, tests are compiled
11.15+with default optimizations else the value is used to configure
11.16+compiler optimizations.")
11.17+(defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
11.18+(defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.")
11.19+(defvar *test-suite-list* nil "List of available `test-suite' objects.")
11.20+(defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
11.21+(eval-when (:compile-toplevel :load-toplevel :execute)
11.22+ (defvar *default-test-suite-name* "default"))
11.23+(declaim (type (or stream boolean string) *test-input*))
11.24+(defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
11.25+(defvar *testing* nil "Testing state var.")
11.26+(defvar *default-tmp-directory* #P"/tmp/")
11.27+(defvar *tmp* *default-tmp-directory*)
11.28+;; TODO 2024-08-31:
11.29+(defvar *test-on-definition* nil
11.30+ "Special variable indicating whether to run tests as soon as they are defined.")
12.1--- a/lisp/lib/skel/tests.lisp Fri Aug 30 21:29:55 2024 -0400
12.2+++ b/lisp/lib/skel/tests.lisp Sat Aug 31 22:34:56 2024 -0400
12.3@@ -1,6 +1,6 @@
12.4 ;;; skel/tests.lisp --- skel tests
12.5 (defpackage :skel/tests
12.6- (:use :cl :skel :rt :log :obj :dat/sxp)
12.7+ (:use :cl :skel :rt :log :obj :dat/sxp :std/path)
12.8 (:import-from :uiop :file-exists-p))
12.9
12.10 (in-package :skel/tests)
12.11@@ -8,13 +8,7 @@
12.12 (defsuite :skel)
12.13 (in-suite :skel)
12.14
12.15-(defvar %tmp)
12.16-(defun tmp-path (ext)
12.17- (setq %tmp (format nil "/tmp/~A.~A" (gensym) ext)))
12.18-
12.19-(defun do-tmp-path (file &rest body)
12.20- (prog1 body
12.21- (when (file-exists-p file) (delete-file file))))
12.22+(defun tmp-path (ext) (make-pathname :name (namestring (tmpize-pathname (string (gensym "g")))) :type ext))
12.23
12.24 (deftest header-comments ()
12.25 "Make sure header comments are generated correctly.
12.26@@ -35,24 +29,21 @@
12.27 (deftest skelfile ()
12.28 "Ensure skelfiles are created and loaded correctly and that they signal
12.29 the appropriate restarts."
12.30- (do-tmp-path (tmp-path "sk")
12.31+ (with-tmp-file (f :type "sk")
12.32 (is (sk-write-file
12.33- (make-instance 'sk-project :name "nada" :path "test" :vc :hg) :path %tmp :if-exists :supersede))
12.34- (ignore-errors (delete-file %tmp))
12.35- (setf %tmp (tmp-path "sk"))
12.36- (is (init-skelfile %tmp))
12.37- (is (load-skelfile %tmp))
12.38- (is (build-ast (sk-read-file (make-instance 'sk-project) %tmp)))))
12.39+ (make-instance 'sk-project :name "nada" :path "test" :vc :hg) :path *tmp* :if-exists :supersede))
12.40+ (is (load-skelfile *tmp*))
12.41+ (is (build-ast (sk-read-file (make-instance 'sk-project) *tmp*)))))
12.42
12.43 (deftest skelrc ()
12.44 "Ensure skelrc files are created and loaded correctly."
12.45- (do-tmp-path (tmp-path "skrc")))
12.46+ (with-tmp-file (f :name "" :type "skelrc")))
12.47
12.48 (deftest makefile ()
12.49 "Make sure makefiles are making out ok."
12.50- (do-tmp-path (tmp-path "mk")
12.51+ (with-tmp-file (f :name "" :type "mk")
12.52 (flet ((mk (&optional path) (make-instance 'makefile :name (gensym)
12.53- :path (or path (pathname %tmp)) :description "barfood"))
12.54+ :path (or path (pathname *tmp*)) :description "barfood"))
12.55 (src (path) (list path))
12.56 (cmd (body) (make-instance 'sk-command :body body))
12.57 (rule (tr sr) (make-sk-rule tr sr nil)))
