cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

more testing improvements

Browse source
This commit is contained in:
Helmut Merz 2024-05-22 09:19:32 +02:00
parent 8436ed3742
commit 8efb63534e
1 changed files with 14 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
testing.lisp
View file

@ -14,28 +14,28 @@
(defclass test-suite () (defclass test-suite ()
((name :reader name :initform "test" :initarg :name) ((name :reader name :initform "test" :initarg :name)
(result :accessor result :initform nil) (errors :accessor errors :initform nil)
(ok :accessor ok :initform t))) (result :accessor result :initform nil)))
(defun test-suite (&optional (name "test")) (defun test-suite (&optional (name "test"))
(make-instance 'test-suite :name name)) (make-instance 'test-suite :name name))
(defun show-result () (defun show-result ()
(format t "=== ~a Tests ===~%" (name *test-suite*) ) (let ((suite *test-suite*))
(dolist (res (reverse (result *test-suite*))) (format t "=== ~a Tests ===~%" (name suite) )
(dolist (res (reverse (result suite)))
(let ((tst (reverse res))) (let ((tst (reverse res)))
(format t "~a: ~a~%" (string-downcase (car tst)) (cdr tst)))) (format t "~a: ~a~%" (car tst) (cdr tst))))
(if (not (ok *test-suite*)) (if (errors suite)
(format t "*****~%")) (format t "*** errors: ~a~%" (reverse (errors suite)))))
(values)) (values))
(defun == (have wanted) (defun == (have wanted)
(let ((is-ok (equalp have wanted))) (let ((suite *test-suite*)
(if (not is-ok) (is-ok (equalp have wanted)))
(progn (push is-ok (car (result suite)))
(push (format nil "~a!=~a" have wanted) (car (result *test-suite*))) (unless is-ok
(setf (ok *test-suite*) nil)) (push (format nil "~a!=~a" have wanted) (errors suite)))))
(push is-ok (car (result *test-suite*))))))
(defmacro deftest (name args &body body) (defmacro deftest (name args &body body)
`(defun ,name ,args `(defun ,name ,args