lisp-unit.lisp

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