lisp-unit.lisp

   1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 #|
   4
   5   Copyright (c) 2004-2005, Christopher K. Riesbeck
   6   Copyright (c) 2009-2016, Thomas M. Hermann
   7
   8   Permission is hereby granted, free of charge, to any person obtaining
   9   a copy of this software and associated documentation files (the "Software"),
  10   to deal in the Software without restriction, including without limitation
  11   the rights to use, copy, modify, merge, publish, distribute, sublicense,
  12   and/or sell copies of the Software, and to permit persons to whom the
  13   Software is furnished to do so, subject to the following conditions:
  14
  15   The above copyright notice and this permission notice shall be included
  16   in all copies or substantial portions of the Software.
  17
  18   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  19   OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  20   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  21   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
  22   OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  23   ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  24   OTHER DEALINGS IN THE SOFTWARE.
  25
  26   How to use
  27   ----------
  28
  29   1. Read the documentation at:
  30      https://github.com/OdonataResearchLLC/lisp-unit/wiki
  31
  32   2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  33   examples. If you want, start your test file with (REMOVE-TESTS :ALL)
  34   to clear any previously defined tests.
  35
  36   3. Load this file.
  37
  38   4. (use-package :lisp-unit)
  39
  40   5. Load your code file and your file of tests.
  41
  42   6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
  43   simply (RUN-TESTS :ALL) to run all defined tests.
  44
  45   A summary of how many tests passed and failed will be printed.
  46
  47   NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
  48   functions or even macros does not require reloading any tests.
  49
  50 |#
  51
  52 ;;; Packages
  53
  54 (in-package :cl-user)
  55
  56 (defpackage :lisp-unit
  57   (:use :common-lisp)
  58   ;; Print parameters
  59   (:export :*print-summary*
  60            :*print-failures*
  61            :*print-errors*
  62            :*summarize-results*)
  63   ;; Forms for assertions
  64   (:export :assert-eq
  65            :assert-eql
  66            :assert-equal
  67            :assert-equalp
  68            :assert-equality
  69            :assert-prints
  70            :assert-expands
  71            :assert-true
  72            :assert-test
  73            :assert-false
  74            :assert-nil
  75            :assert-error)
  76   ;; Functions for managing tests
  77   (:export :define-test
  78            :list-tests
  79            :test-code
  80            :test-documentation
  81            :remove-tests
  82            :run-tests
  83            :use-debugger
  84            :check-code)
  85   ;; Functions for managing tags
  86   (:export :list-tags
  87            :tagged-tests
  88            :remove-tags
  89            :run-tags)
  90   ;; Functions for reporting test results
  91   (:export :test-names
  92            :failed-tests
  93            :error-tests
  94            :missing-tests
  95            :print-failures
  96            :print-errors
  97            :summarize-results)
  98   ;; Functions for test results
  99   (:export :reduce-test-results-dbs)
 100   ;; Functions for extensibility via signals
 101   (:export :signal-results
 102            :test-run-complete
 103            :results)
 104   ;; Utility predicates
 105   (:export :logically-equal :set-equal))
 106
 107 (in-package :lisp-unit)
 108
 109 ;;; Global counters
 110
 111 (defparameter *pass* 0
 112   "The passed assertion results.")
 113
 114 (defparameter *fail* ()
 115   "The failed assertion results.")
 116
 117 (defun reset-counters ()
 118   "Reset the counters to empty lists."
 119   (setf *pass* 0 *fail* ()))
 120
 121 ;;; Global options
 122
 123 (defparameter *print-summary* nil
 124   "Print a summary of the pass, fail, and error count if non-nil.")
 125
 126 (defparameter *print-failures* nil
 127   "Print failure messages if non-NIL.")
 128
 129 (defparameter *print-errors* nil
 130   "Print error messages if non-NIL.")
 131
 132 (defparameter *summarize-results* t
 133   "Summarize all of the unit test results.")
 134
 135 (defparameter *use-debugger* nil
 136   "If not NIL, enter the debugger when an error is encountered in an
 137 assertion.")
 138
 139 (defun use-debugger (&optional (flag t))
 140   "Use the debugger when testing, or not."
 141   (setq *use-debugger* flag))
 142
 143 (defun use-debugger-p (condition)
 144   "Debug or ignore errors."
 145   (cond
 146    ((eq :ask *use-debugger*)
 147     (y-or-n-p "~A -- debug?" condition))
 148    (*use-debugger*)))
 149
 150 (defparameter *signal-results* nil
 151   "Signal the result if non NIL.")
 152
 153 (defun signal-results (&optional (flag t))
 154   "Signal the results for extensibility."
 155   (setq *signal-results* flag))
 156
 157 (defparameter *check-code* nil
 158   "Check the code when the test is defined if not NIL.")
 159
 160 (defun check-code (&optional (flag t))
 161   "Check the code when the test is defined."
 162   (setq *check-code* flag))
 163
 164 ;;; Global unit test database
 165
 166 (defparameter *test-db* (make-hash-table :test #'eq)
 167   "The unit test database is simply a hash table.")
 168
 169 (defun null-tests-warning-report (null-tests-warning stream)
 170   "Write the null-tests-warning to the stream."
 171   (format stream "No tests defined for package ~A."
 172           (tests-package-name null-tests-warning)))
 173
 174 (define-condition null-tests-warning (simple-warning)
 175   ((name
 176     :type string
 177     :initarg :name
 178     :reader tests-package-name))
 179   (:report null-tests-warning-report))
 180
 181 (defun package-table (package &optional create)
 182   (let ((packobj (find-package package)))
 183     (cond
 184      ((gethash packobj *test-db*))
 185      (create
 186       (setf (gethash packobj *test-db*) (make-hash-table)))
 187      (t (warn 'null-tests-warning :name (package-name package))))))
 188
 189 (defmacro with-package-table ((table
 190                                &optional (package *package*) create)
 191                               &body body)
 192   "Execute the body only if the package table exists."
 193   (let ((gtable (gensym "TABLE-")))
 194     `(let* ((,gtable (package-table ,package ,create))
 195             (,table ,gtable))
 196        (when (hash-table-p ,gtable) ,@body))))
 197
 198 ;;; Global tags database
 199
 200 (defparameter *tag-db* (make-hash-table :test #'eq)
 201   "The tag database is simply a hash table.")
 202
 203 (defun null-tags-warning-report (null-tags-warning stream)
 204   "Write the null-tags-warning to the stream."
 205   (format stream "No tags defined for package ~A."
 206           (tags-package-name null-tags-warning)))
 207
 208 (define-condition null-tags-warning (simple-warning)
 209   ((name
 210     :type string
 211     :initarg :name
 212     :reader tags-package-name))
 213   (:report null-tags-warning-report))
 214
 215 (defun package-tags (package &optional create)
 216   "Return the tags DB for the package."
 217   (let ((packobj (find-package package)))
 218     (cond
 219      ((gethash packobj *tag-db*))
 220      (create
 221       (setf (gethash packobj *tag-db*) (make-hash-table)))
 222      (t (warn 'null-tags-warning :name (package-name package))))))
 223
 224 (defmacro with-package-tags ((table
 225                               &optional (package *package*) create)
 226                              &body body)
 227   "Execute the body only if the package tags exists."
 228   (let ((gtable (gensym "TABLE-")))
 229     `(let* ((,gtable (package-tags ,package ,create))
 230             (,table ,gtable))
 231        (when (hash-table-p ,gtable) ,@body))))
 232
 233 ;;; Unit test definition
 234
 235 (defclass unit-test ()
 236   ((doc
 237     :type string
 238     :initarg :doc
 239     :reader doc)
 240    (code
 241     :type list
 242     :initarg :code
 243     :reader code))
 244   (:default-initargs :doc "" :code ())
 245   (:documentation
 246    "Organize the unit test documentation and code."))
 247
 248 ;;; NOTE: Shamelessly taken from PG's analyze-body
 249 (defun parse-body (body &optional doc tag)
 250   "Separate the components of the body."
 251   (let ((item (first body)))
 252     (cond
 253      ((and (listp item) (eq :tag (first item)))
 254       (parse-body (rest body) doc (nconc (rest item) tag)))
 255      ((and (stringp item) (not doc) (rest body))
 256       (if tag
 257           (values doc tag (rest body))
 258           (parse-body (rest body) item tag)))
 259      (t (values doc tag body)))))
 260
 261 (defun test-name-error-report (test-name-error stream)
 262   "Write the test-name-error to the stream."
 263   (format stream "Test name ~S is not of type ~A."
 264           (type-error-datum test-name-error)
 265           (type-error-expected-type test-name-error)))
 266
 267 (define-condition test-name-error (type-error)
 268   ()
 269   (:default-initargs :expected-type 'symbol)
 270   (:report test-name-error-report)
 271   (:documentation
 272    "The test name error is a type error."))
 273
 274 (defun valid-test-name (name)
 275   "Signal a type-error if the test name is not a symbol."
 276   (if (symbolp name)
 277       name
 278       (error 'test-name-error :datum name)))
 279
 280 (defun test-package (name)
 281   "Return the package for storing the test."
 282   (multiple-value-bind (symbol status)
 283       (find-symbol (symbol-name name))
 284     (declare (ignore symbol))
 285     (ecase status
 286       ((:internal :external nil)
 287        (symbol-package name))
 288       (:inherited *package*))))
 289
 290 (defmacro define-test (name &body body)
 291   "Store the test in the test database."
 292   (let ((qname (gensym "NAME-")))
 293     (multiple-value-bind (doc tag code) (parse-body body)
 294       `(let* ((,qname (valid-test-name ',name))
 295               (doc (or ,doc (symbol-name ,qname)))
 296               (package (test-package ,qname)))
 297          ,(when *check-code* `(lambda () ,@code))
 298          (setf
 299           ;; Unit test
 300           (gethash ,qname (package-table package t))
 301           (make-instance 'unit-test :doc doc :code ',code))
 302          ;; Tags
 303          (loop
 304           for tag in ',tag do
 305           (pushnew ,qname (gethash tag (package-tags package t))))
 306          ;; Return the name of the test
 307          ,qname))))
 308
 309 ;;; Manage tests
 310
 311 (defun list-tests (&optional (package *package*))
 312   "Return a list of the tests in package."
 313   (with-package-table (table package)
 314     (loop for test-name being each hash-key in table
 315           collect test-name)))
 316
 317 (defun test-documentation (name &optional (package *package*))
 318   "Return the documentation for the test."
 319   (with-package-table (table package)
 320     (let ((unit-test (gethash name table)))
 321       (if (null unit-test)
 322           (warn "No test ~A in package ~A."
 323                 name (package-name package))
 324           (doc unit-test)))))
 325
 326 (defun test-code (name &optional (package *package*))
 327   "Returns the code stored for the test name."
 328   (with-package-table (table package)
 329     (let ((unit-test (gethash name table)))
 330       (if (null unit-test)
 331           (warn "No test ~A in package ~A."
 332                 name (package-name package))
 333           (code unit-test)))))
 334
 335 (defun remove-tests (&optional (names :all) (package *package*))
 336   "Remove individual tests or entire sets."
 337   (if (eq :all names)
 338       (if (null package)
 339           (clrhash *test-db*)
 340           (progn
 341             (remhash (find-package package) *test-db*)
 342             (remhash (find-package package) *tag-db*)))
 343       (progn
 344         ;; Remove tests
 345         (with-package-table (table package)
 346           (loop for name in names
 347                 unless (remhash name table) do
 348                 (warn "No test ~A in package ~A to remove."
 349                       name (package-name package))))
 350         ;; Remove tests from tags
 351         (with-package-tags (tags package)
 352           (loop for tag being each hash-key in tags
 353                 using (hash-value tagged-tests)
 354                 do
 355                 (setf
 356                  (gethash tag tags)
 357                  (set-difference tagged-tests names)))))))
 358
 359 ;;; Manage tags
 360
 361 (defun %tests-from-all-tags (&optional (package *package*))
 362   "Return all of the tests that have been tagged."
 363   (with-package-tags (table package)
 364     (loop for tests being each hash-value in table
 365           nconc (copy-list tests) into all-tests
 366           finally (return (delete-duplicates all-tests)))))
 367
 368 (defun %tests-from-tags (tags &optional (package *package*))
 369   "Return the tests associated with the tags."
 370   (with-package-tags (table package)
 371     (loop for tag in tags
 372           as tests = (gethash tag table)
 373           if (null tests) do (warn "No tests tagged with ~S." tag)
 374           else nconc (copy-list tests) into all-tests
 375           finally (return (delete-duplicates all-tests)))))
 376
 377 (defun list-tags (&optional (package *package*))
 378   "Return a list of the tags in package."
 379   (with-package-tags (table package)
 380     (loop for tag being each hash-key in table collect tag)))
 381
 382 (defun tagged-tests (&optional (tags :all) (package *package*))
 383   "Return a list of the tests associated with the tags."
 384   (if (eq :all tags)
 385       (%tests-from-all-tags package)
 386       (%tests-from-tags tags package)))
 387
 388 (defun remove-tags (&optional (tags :all) (package *package*))
 389   "Remove individual tags or entire sets."
 390   (if (eq :all tags)
 391       (if (null package)
 392           (clrhash *tag-db*)
 393           (remhash (find-package package) *tag-db*))
 394       (with-package-tags (tag-table package)
 395         (loop for tag in tags
 396               unless (remhash tag tag-table) do
 397               (warn "No tag ~A in package ~A to remove."
 398                     tag (package-name package))))))
 399
 400 ;;; Assert macros
 401
 402 (defmacro assert-eq (expected form &rest extras)
 403   "Assert whether expected and form are EQ."
 404   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 405
 406 (defmacro assert-eql (expected form &rest extras)
 407   "Assert whether expected and form are EQL."
 408   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 409
 410 (defmacro assert-equal (expected form &rest extras)
 411   "Assert whether expected and form are EQUAL."
 412   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 413
 414 (defmacro assert-equalp (expected form &rest extras)
 415   "Assert whether expected and form are EQUALP."
 416   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 417
 418 (defmacro assert-error (condition form &rest extras)
 419   "Assert whether form signals condition."
 420   `(expand-assert :error ,form (expand-error-form ,form)
 421                   ,condition ,extras))
 422
 423 (defmacro assert-expands (expansion form &rest extras)
 424   "Assert whether form expands to expansion."
 425   `(expand-assert :macro ,form
 426                   (expand-macro-form ,form nil)
 427                   ',expansion ,extras))
 428
 429 (defmacro assert-equality (test expected form &rest extras)
 430   "Assert whether expected and form are equal according to test."
 431   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 432
 433 (defmacro assert-prints (output form &rest extras)
 434   "Assert whether printing the form generates the output."
 435   `(expand-assert :output ,form (expand-output-form ,form)
 436                   ,output ,extras))
 437
 438 (defmacro assert-nil (form &rest extras)
 439   "Assert whether the form is false."
 440   (if (atom form)
 441       `(expand-assert :result ,form ,form nil ,extras)
 442       `(expand-t-or-f nil ,form ,extras)))
 443
 444 (defmacro assert-false (form &rest extras)
 445   "Assert whether the form is false."
 446   (if (atom form)
 447       `(expand-assert :result ,form ,form nil ,extras)
 448       `(expand-t-or-f nil ,form ,extras)))
 449
 450 (defmacro assert-true (form &rest extras)
 451   "Assert whether the form is true."
 452   (if (atom form)
 453       `(expand-assert :result ,form ,form t ,extras)
 454       `(expand-t-or-f t ,form ,extras)))
 455
 456 (defmacro expand-t-or-f (t-or-f form extras)
 457   "Expand the true/false assertions to report the arguments."
 458   (let ((fname (gensym))
 459         (args (gensym)))
 460     `(let ((,fname #',(car form))
 461            (,args (list ,@(cdr form))))
 462        (internal-assert
 463         :result ',form
 464         (lambda () (apply ,fname ,args)) ; Evaluate the form
 465         (lambda () ,t-or-f)
 466         ;; Concatenate the args with the extras
 467         (lambda ()
 468           (nconc
 469            (mapcan #'list ',(cdr form) ,args)
 470            (funcall (expand-extras ,extras))))
 471         #'eql))))
 472
 473 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 474   "Expand the assertion to the internal format."
 475   `(internal-assert ,type ',form
 476                     (lambda () ,body)
 477                     (lambda () ,expected)
 478                     (expand-extras ,extras)
 479                     ,test))
 480
 481 (defmacro expand-error-form (form)
 482   "Wrap the error assertion in HANDLER-CASE."
 483   `(handler-case ,form
 484      (condition (error) error)))
 485
 486 (defmacro expand-output-form (form)
 487   "Capture the output of the form in a string."
 488   (let ((out (gensym)))
 489     `(let* ((,out (make-string-output-stream))
 490             (*standard-output*
 491              (make-broadcast-stream *standard-output* ,out)))
 492        ,form
 493        (get-output-stream-string ,out))))
 494
 495 (defmacro expand-macro-form (form env)
 496   "Expand the macro form once."
 497   `(let ((*gensym-counter* 1))
 498      (macroexpand-1 ',form ,env)))
 499
 500 (defmacro expand-extras (extras)
 501   "Expand extra forms."
 502   `(lambda ()
 503      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 504
 505 (defgeneric assert-result (type test expected actual)
 506   (:documentation
 507    "Return the result of the assertion."))
 508
 509 (defgeneric record-failure (type form actual expected extras test)
 510   (:documentation
 511    "Record the details of the failure."))
 512
 513 (defclass failure-result ()
 514   ((form
 515     :initarg :form
 516     :reader form)
 517    (actual
 518     :type list
 519     :initarg :actual
 520     :reader actual)
 521    (expected
 522     :type list
 523     :initarg :expected
 524     :reader expected)
 525    (extras
 526     :type list
 527     :initarg :extras
 528     :reader extras)
 529    (test
 530     :type function
 531     :initarg :test
 532     :reader test))
 533   (:documentation
 534    "Failure details of the assertion."))
 535
 536 (defun %record-failure (class form actual expected extras test)
 537   "Return an instance of the failure result."
 538   (make-instance class
 539                  :form form
 540                  :actual actual
 541                  :expected expected
 542                  :extras extras
 543                  :test test))
 544
 545 (defclass equal-result (failure-result)
 546   ()
 547   (:documentation
 548    "Result of a failed equal assertion."))
 549
 550 (defmethod assert-result ((type (eql :equal)) test expected actual)
 551   "Return the result of an equal assertion."
 552   (and
 553    (<= (length expected) (length actual))
 554    (every test expected actual)))
 555
 556 (defmethod record-failure ((type (eql :equal))
 557                            form actual expected extras test)
 558   "Return an instance of an equal failure result."
 559   (%record-failure 'equal-result form actual expected extras test))
 560
 561 (defclass error-result (failure-result)
 562   ()
 563   (:documentation
 564    "Result of a failed error assertion."))
 565
 566 (defmethod assert-result ((type (eql :error)) test expected actual)
 567   "Return the result of an error assertion."
 568   (declare (ignore test))
 569   (or
 570    (eql (car actual) (car expected))
 571    (typep (car actual) (car expected))))
 572
 573 (defmethod record-failure ((type (eql :error))
 574                            form actual expected extras test)
 575   "Return an instance of an error failure result."
 576   (%record-failure 'error-result form actual expected extras test))
 577
 578 (defclass macro-result (failure-result)
 579   ()
 580   (:documentation
 581    "Result of a failed macro expansion assertion."))
 582
 583 (defun %expansion-equal (form1 form2)
 584   "Descend into the forms checking for equality."
 585   (let ((item1 (first form1))
 586         (item2 (first form2)))
 587     (cond
 588      ((and (null item1) (null item2)))
 589      ((and (listp item1) (listp item2))
 590       (and
 591        (%expansion-equal item1 item2)
 592        (%expansion-equal (rest form1) (rest form2))))
 593      ((and (symbolp item1) (symbolp item2))
 594       (and
 595        (string= (symbol-name item1) (symbol-name item2))
 596        (%expansion-equal (rest form1) (rest form2))))
 597      (t (and
 598          (equal item1 item2)
 599          (%expansion-equal (rest form1) (rest form2)))))))
 600
 601 (defmethod assert-result ((type (eql  :macro)) test expected actual)
 602   "Return the result of a macro assertion."
 603   (declare (ignore test))
 604   (%expansion-equal (first expected) (first actual)))
 605
 606 (defmethod record-failure ((type (eql :macro))
 607                            form actual expected extras test)
 608   "Return an instance of a macro failure result."
 609   (%record-failure 'macro-result form actual expected extras test))
 610
 611 (defclass boolean-result (failure-result)
 612   ()
 613   (:documentation
 614    "Result of a failed boolean assertion."))
 615
 616 (defmethod assert-result ((type (eql :result)) test expected actual)
 617   "Return the result of a result assertion."
 618   (declare (ignore test))
 619   (logically-equal (car actual) (car expected)))
 620
 621 (defmethod record-failure ((type (eql :result))
 622                            form actual expected extras test)
 623   "Return an instance of a boolean failure result."
 624   (%record-failure 'boolean-result form actual expected extras test))
 625
 626 (defclass output-result (failure-result)
 627   ()
 628   (:documentation
 629    "Result of a failed output assertion."))
 630
 631 (defmethod assert-result ((type (eql :output)) test expected actual)
 632   "Return the result of an output assertion."
 633   (declare (ignore test))
 634   (string=
 635    (string-trim '(#\newline #\return #\space) (car actual))
 636    (car expected)))
 637
 638 (defmethod record-failure ((type (eql :output))
 639                            form actual expected extras test)
 640   "Return an instance of an output failure result."
 641   (%record-failure 'output-result form actual expected extras test))
 642
 643 (defun internal-assert
 644        (type form code-thunk expected-thunk extras test)
 645   "Perform the assertion and record the results."
 646   (let* ((actual (multiple-value-list (funcall code-thunk)))
 647          (expected (multiple-value-list (funcall expected-thunk)))
 648          (result (assert-result type test expected actual)))
 649     (if result
 650         (incf *pass*)
 651         (push
 652          (record-failure
 653           type form actual expected
 654           (when extras (funcall extras)) test)
 655          *fail*))
 656     ;; Return the result
 657     result))
 658
 659 ;;; Unit test results
 660
 661 (defclass test-result ()
 662   ((name
 663     :type symbol
 664     :initarg :name
 665     :reader name)
 666    (pass
 667     :type fixnum
 668     :initarg :pass
 669     :reader pass)
 670    (fail
 671     :type list
 672     :initarg :fail
 673     :reader fail)
 674    (exerr
 675     :initarg :exerr
 676     :reader exerr)
 677    (run-time
 678     :initarg :run-time
 679     :reader run-time
 680     :documentation
 681     "Test run time measured in internal time units"))
 682   (:default-initargs :exerr nil)
 683   (:documentation
 684    "Store the results of the unit test."))
 685
 686 (defun print-summary (test-result &optional
 687                       (stream *standard-output*))
 688   "Print a summary of the test result."
 689   (format stream "~&~A: ~S assertions passed, ~S failed"
 690           (name test-result)
 691           (pass test-result)
 692           (length (fail test-result)))
 693   (if (exerr test-result)
 694       (format stream ", and an execution error.")
 695       (write-char #\. stream))
 696   (terpri stream)
 697   (terpri stream))
 698
 699 (defun run-code (code)
 700   "Run the code to test the assertions."
 701   (funcall (coerce `(lambda () ,@code) 'function)))
 702
 703 (defun run-test-thunk (name code)
 704   (let ((*pass* 0)
 705         (*fail* ())
 706         (start (get-internal-run-time)))
 707     (handler-bind
 708         ((error
 709           (lambda (condition)
 710             (if (use-debugger-p condition)
 711                 condition
 712                 (return-from run-test-thunk
 713                   (make-instance
 714                    'test-result
 715                    :name name
 716                    :pass *pass*
 717                    :fail *fail*
 718                    :run-time (- (get-internal-run-time) start)
 719                    :exerr condition))))))
 720       (run-code code))
 721     ;; Return the result count
 722     (make-instance
 723      'test-result
 724      :name name
 725      :pass *pass*
 726      :fail *fail*
 727      :run-time (- (get-internal-run-time) start))))
 728
 729 ;;; Test results database
 730
 731 (defclass test-results-db ()
 732   ((database
 733     :type hash-table
 734     :initform (make-hash-table :test #'eq)
 735     :reader database)
 736    (pass
 737     :type fixnum
 738     :initform 0
 739     :accessor pass)
 740    (fail
 741     :type fixnum
 742     :initform 0
 743     :accessor fail)
 744    (exerr
 745     :type fixnum
 746     :initform 0
 747     :accessor exerr)
 748    (failed-tests
 749     :type list
 750     :initform ()
 751     :accessor failed-tests)
 752    (error-tests
 753     :type list
 754     :initform ()
 755     :accessor error-tests)
 756    (missing-tests
 757     :type list
 758     :initform ()
 759     :accessor missing-tests))
 760   (:documentation
 761    "Store the results of the tests for further evaluation."))
 762
 763 (defmethod print-object ((object test-results-db) stream)
 764   "Print the summary counts with the object."
 765   (let ((pass (pass object))
 766         (fail (fail object))
 767         (exerr (exerr object)))
 768     (format
 769      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 770      (class-name (class-of object))
 771      (+ pass fail) pass fail exerr)))
 772
 773 (defun test-names (test-results-db)
 774   "Return a list of the test names in the database."
 775   (loop for name being each hash-key in (database test-results-db)
 776         collect name))
 777
 778 (defun record-result (test-name code results)
 779   "Run the test code and record the result."
 780   (let ((result (run-test-thunk test-name code)))
 781     ;; Store the result
 782     (setf (gethash test-name (database results)) result)
 783     ;; Count passed tests
 784     (when (plusp (pass result))
 785       (incf (pass results) (pass result)))
 786     ;; Count failed tests and record the name
 787     (when (fail result)
 788       (incf (fail results) (length (fail result)))
 789       (push test-name (failed-tests results)))
 790     ;; Count errors and record the name
 791     (when (exerr result)
 792       (incf (exerr results))
 793       (push test-name (error-tests results)))
 794     ;; Running output
 795     (when *print-failures* (print-failures result))
 796     (when *print-errors* (print-errors result))
 797     (when (or *print-summary* *print-failures* *print-errors*)
 798       (print-summary result))))
 799
 800 (defun summarize-results (results &optional
 801                           (stream *standard-output*))
 802   "Print a summary of all results to the stream."
 803   (let ((pass (pass results))
 804         (fail (fail results)))
 805     (format stream "~&Unit Test Summary~%")
 806     (format stream " | ~D assertions total~%" (+ pass fail))
 807     (format stream " | ~D passed~%" pass)
 808     (format stream " | ~D failed~%" fail)
 809     (format stream " | ~D execution errors~%" (exerr results))
 810     (format stream " | ~D missing tests~2%"
 811             (length (missing-tests results)))))
 812
 813 (defun default-db-merge-function (results new-results)
 814   "Signal an error by default if a merge is required."
 815   (lambda (key value1 value2)
 816     (error
 817      "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
 818 two values, ~A and ~A"
 819      results new-results key value1 value2)))
 820
 821 (defun nappend-test-results-db (results new-results &key merge)
 822   "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
 823 between RESULTS and NEW-RESULTS are handled by the function MERGE.
 824
 825 The lambda list for the MERGE functions is
 826
 827   (key results-value new-results-value)
 828
 829 where:
 830   KEY is the key which appears in RESULTS and NEW-RESULTS.
 831   RESULTS-VALUE is the value appearing RESULTS.
 832   NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
 833
 834 If MERGE is NIL, then an error is signalled when a conflict occurs.
 835 "
 836   (check-type results test-results-db)
 837   (check-type new-results test-results-db)
 838   (check-type merge (or null function))
 839   (loop
 840    with results-db = (database results)
 841    with new-results-db = (database new-results)
 842    with merge =
 843    (or merge (default-db-merge-function results new-results))
 844    ;; Merge test databases
 845    for key being each hash-key in new-results-db
 846    using (hash-value new-results-value)
 847    do
 848    (multiple-value-bind (results-value presentp)
 849        (gethash key results-db)
 850      (setf
 851       (gethash key results-db)
 852       (if presentp
 853           (funcall merge key results-value new-results-value)
 854           new-results-value)))
 855    finally
 856    ;; Update counters
 857    (incf (pass results) (pass new-results))
 858    (incf (fail results) (fail new-results))
 859    (incf (exerr results) (exerr new-results))
 860    ;; Merge failures, errors, and missing test details
 861    (setf
 862     ;; Failures
 863     (failed-tests results)
 864     (append (failed-tests results) (failed-tests new-results))
 865     ;; Errors
 866     (error-tests results)
 867     (append (error-tests results) (error-tests new-results))
 868     ;; Missing tests
 869     (missing-tests results)
 870     (append (missing-tests results) (missing-tests new-results))))
 871    ;; Return the merged results
 872    results)
 873
 874 (defun reduce-test-results-dbs (all-results &key merge)
 875   "Return a new instance of TEST-RESULTS-DB which contains all of the
 876 results in the sequence RESULTS. Any conflicts are handled by the
 877 function MERGE.
 878
 879 The lambda list for the MERGE function is
 880
 881   (key value-1 value-2)
 882
 883 where:
 884   KEY is the key which appears at least twice in the sequence RESULTS.
 885   VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
 886
 887 If MERGE is NIL, then an error is signalled when a conflict occurs."
 888   (loop
 889    with accumulated-test-results-db = (make-instance 'test-results-db)
 890    for new-results in all-results do
 891    (nappend-test-results-db
 892     accumulated-test-results-db new-results :merge merge)
 893    finally (return accumulated-test-results-db)))
 894
 895 ;;; Run the tests
 896
 897 (define-condition test-run-complete ()
 898   ((results
 899     :type 'test-results-db
 900     :initarg :results
 901     :reader results))
 902   (:documentation
 903    "Signaled when a test run is finished."))
 904
 905 (defun %run-all-thunks (&optional (package *package*))
 906   "Run all of the test thunks in the package."
 907   (with-package-table (table package)
 908     (loop
 909      with results = (make-instance 'test-results-db)
 910      for test-name being each hash-key in table
 911      using (hash-value unit-test)
 912      if unit-test do
 913      (record-result test-name (code unit-test) results)
 914      else do
 915      (push test-name (missing-tests results))
 916      ;; Summarize and return the test results
 917      finally
 918      (when *signal-results*
 919        (signal 'test-run-complete :results results))
 920      (when *summarize-results*
 921        (summarize-results results))
 922      (return results))))
 923
 924 (defun %run-thunks (test-names &optional (package *package*))
 925   "Run the list of test thunks in the package."
 926   (with-package-table (table package)
 927     (loop
 928      with results = (make-instance 'test-results-db)
 929      for test-name in test-names
 930      as unit-test = (gethash test-name table)
 931      if unit-test do
 932      (record-result test-name (code unit-test) results)
 933      else do
 934      (push test-name (missing-tests results))
 935      finally
 936      (when *signal-results*
 937        (signal 'test-run-complete :results results))
 938      (when *summarize-results*
 939        (summarize-results results))
 940      (return results))))
 941
 942 (defun run-tests (&optional (test-names :all) (package *package*))
 943   "Run the specified tests in package."
 944   (reset-counters)
 945   (if (eq :all test-names)
 946       (%run-all-thunks package)
 947       (%run-thunks test-names package)))
 948
 949 (defun run-tags (&optional (tags :all) (package *package*))
 950   "Run the tests associated with the specified tags in package."
 951   (reset-counters)
 952   (%run-thunks (tagged-tests tags package) package))
 953
 954 ;;; Print failures
 955
 956 (defgeneric print-failures (result &optional stream)
 957   (:documentation
 958    "Report the results of the failed assertion."))
 959
 960 (defmethod print-failures :around ((result failure-result) &optional
 961                                    (stream *standard-output*))
 962   "Failure header and footer output."
 963   (format stream "~& | Failed Form: ~S" (form result))
 964   (call-next-method)
 965   (when (extras result)
 966     (format stream "~{~& | ~S => ~S~}~%" (extras result)))
 967   (format stream "~& |~%"))
 968
 969 (defmethod print-failures ((result failure-result) &optional
 970                            (stream *standard-output*))
 971   (format stream "~& | Expected ~{~S~^; ~} " (expected result))
 972   (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 973
 974 (defmethod print-failures ((result error-result) &optional
 975                            (stream *standard-output*))
 976   (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 977           (expected result))
 978   (format stream " ~{~S~^; ~}" (actual result)))
 979
 980 (defmethod print-failures ((result macro-result) &optional
 981                            (stream *standard-output*))
 982   (format stream "~& | Should have expanded to ~{~S~^; ~} "
 983           (expected result))
 984   (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 985
 986 (defmethod print-failures ((result output-result) &optional
 987                            (stream *standard-output*))
 988   (format stream "~& | Should have printed ~{~S~^; ~} "
 989           (expected result))
 990   (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
 991           (actual result)))
 992
 993 (defmethod print-failures ((result test-result) &optional
 994                            (stream *standard-output*))
 995   "Print the failed assertions in the unit test."
 996   (loop for fail in (fail result) do
 997         (print-failures fail stream)))
 998
 999 (defmethod print-failures ((results test-results-db) &optional
1000                            (stream *standard-output*))
1001   "Print all of the failure tests."
1002   (loop with db = (database results)
1003         for test in (failed-tests results)
1004         as result = (gethash test db)
1005         do
1006         (print-failures result stream)
1007         (print-summary result stream)))
1008
1009 ;;; Print errors
1010
1011 (defgeneric print-errors (result &optional stream)
1012   (:documentation
1013    "Print the error condition."))
1014
1015 (defmethod print-errors ((result test-result) &optional
1016                          (stream *standard-output*))
1017   "Print the error condition."
1018   (let ((exerr (exerr result))
1019         (*print-escape* nil))
1020     (when exerr
1021       (format stream "~& | Execution error:~% | ~W" exerr)
1022       (format stream "~& |~%"))))
1023
1024 (defmethod print-errors ((results test-results-db) &optional
1025                          (stream *standard-output*))
1026   "Print all of the error tests."
1027   (loop with db = (database results)
1028         for test in (error-tests results)
1029         as result = (gethash test db)
1030         do
1031         (print-errors result stream)
1032         (print-summary result stream)))
1033
1034 ;;; Useful equality predicates for tests
1035
1036 (defun logically-equal (x y)
1037   "Return true if x and y are both false or both true."
1038   (eql (not x) (not y)))
1039
1040 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
1041   "Return true if every element of list1 is an element of list2 and
1042 vice versa."
1043   (declare (ignore key test))
1044   (and
1045    (listp list1)
1046    (listp list2)
1047    (apply #'subsetp list1 list2 initargs)
1048    (apply #'subsetp list2 list1 initargs)))
1049
1050 (pushnew :lisp-unit common-lisp:*features*)