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   ;; Utility predicates
  94   (:export :logically-equal :set-equal))
  95
  96 (in-package :lisp-unit)
  97
  98 ;;; Global counters
  99
 100 (defparameter *pass* ()
 101   "The passed assertion results.")
 102
 103 (defparameter *fail* ()
 104   "The failed assertion results.")
 105
 106 (defun reset-counters ()
 107   "Reset the counters to empty lists."
 108   (setf *pass* () *fail* ()))
 109
 110 ;;; Global options
 111
 112 (defparameter *print-summary* nil
 113   "Print a summary of the pass, fail, and error count if non-nil.")
 114
 115 (defparameter *print-failures* nil
 116   "Print failure messages if non-NIL.")
 117
 118 (defparameter *print-errors* nil
 119   "Print error messages if non-NIL.")
 120
 121 (defparameter *use-debugger* nil
 122   "If not NIL, enter the debugger when an error is encountered in an
 123 assertion.")
 124
 125 (defun use-debugger-p (condition)
 126   "Debug or ignore errors."
 127   (cond
 128    ((eq :ask *use-debugger*)
 129     (y-or-n-p "~A -- debug?" condition))
 130    (*use-debugger*)))
 131
 132 (defun use-debugger (&optional (flag t))
 133   "Use the debugger when testing, or not."
 134   (setq *use-debugger* flag))
 135
 136 ;;; Global unit test database
 137
 138 (defparameter *test-db* (make-hash-table :test #'eq)
 139   "The unit test database is simply a hash table.")
 140
 141 (defun package-table (package &optional create)
 142   (cond
 143    ((gethash (find-package package) *test-db*))
 144    (create
 145     (setf (gethash package *test-db*) (make-hash-table)))
 146    (t (warn "No tests defined for package: ~S" package))))
 147
 148 ;;; Global tags database
 149
 150 (defparameter *tag-db* (make-hash-table :test #'eq)
 151   "The tag database is simply a hash table.")
 152
 153 (defun package-tags (package &optional create)
 154   "Return the tags DB for the package."
 155   (cond
 156    ((gethash (find-package package) *tag-db*))
 157    (create
 158     (setf (gethash package *tag-db*) (make-hash-table)))
 159    (t (warn "No tags defined for package: ~S" package))))
 160
 161 ;;; Unit test definition
 162
 163 (defclass unit-test ()
 164   ((doc
 165     :type string
 166     :initarg :doc
 167     :reader doc)
 168    (code
 169     :type list
 170     :initarg :code
 171     :reader code))
 172   (:default-initargs :doc "" :code ())
 173   (:documentation
 174    "Organize the unit test documentation and code."))
 175
 176 ;;; NOTE: Shamelessly taken from PG's analyze-body
 177 (defun parse-body (body &optional doc tag)
 178   "Separate the components of the body."
 179   (let ((item (first body)))
 180     (cond
 181      ((and (listp item) (eq :tag (first item)))
 182       (parse-body (rest body) doc (nconc (rest item) tag)))
 183      ((and (stringp item) (not doc) (rest body))
 184       (if tag
 185           (values doc tag (rest body))
 186           (parse-body (rest body) doc tag)))
 187      (t (values doc tag body)))))
 188
 189 (defmacro define-test (name &body body)
 190   "Store the test in the test database."
 191   (let ((qname (gensym "NAME-")))
 192     (multiple-value-bind (doc tag code) (parse-body body)
 193       `(let* ((,qname ',name)
 194               (doc (or ,doc (string ,qname))))
 195          (setf
 196           ;; Unit test
 197           (gethash ,qname (package-table *package* t))
 198           (make-instance 'unit-test :doc doc :code ',code))
 199          ;; Tags
 200          (loop for tag in ',tag do
 201                (pushnew
 202                 ,qname (gethash tag (package-tags *package* t))))
 203          ;; Return the name of the test
 204          ,qname))))
 205
 206 ;;; Manage tests
 207
 208 (defun list-tests (&optional (package *package*))
 209   "Return a list of the tests in package."
 210   (let ((table (package-table package)))
 211     (when table
 212       (loop for test-name being each hash-key in table
 213             collect test-name))))
 214
 215 (defun test-documentation (name &optional (package *package*))
 216   "Return the documentation for the test."
 217   (let ((unit-test (gethash name (package-table package))))
 218     (if (null unit-test)
 219         (warn "No code defined for test ~A in package ~S."
 220               name package)
 221         (doc unit-test))))
 222
 223 (defun test-code (name &optional (package *package*))
 224   "Returns the code stored for the test name."
 225   (let ((unit-test (gethash name (package-table package))))
 226     (if (null unit-test)
 227         (warn "No code defined for test ~A in package ~S."
 228               name package)
 229         (code unit-test))))
 230
 231 (defun remove-tests (names &optional (package *package*))
 232   "Remove individual tests or entire sets."
 233   (if (eq :all names)
 234       (if (null package)
 235           (clrhash *test-db*)
 236           (progn
 237             (remhash (find-package package) *test-db*)
 238             (remhash (find-package package) *tag-db*)))
 239       (let ((table (package-table package)))
 240         (unless (null table)
 241           ;; Remove tests
 242           (loop for name in names
 243                 always (remhash name table)
 244                 collect name into removed
 245                 finally (return removed))
 246           ;; Remove tests from tags
 247           (loop with tags = (package-tags package)
 248                 for tag being each hash-key in tags
 249                 using (hash-value tagged-tests)
 250                 do
 251                 (setf
 252                  (gethash tag tags)
 253                  (set-difference tagged-tests names)))))))
 254
 255 ;;; Manage tags
 256
 257 (defun %tests-from-all-tags (&optional (package *package*))
 258   "Return all of the tests that have been tagged."
 259   (loop for tests being each hash-value in (package-tags package)
 260         nconc (copy-list tests) into all-tests
 261         finally (return (delete-duplicates all-tests))))
 262
 263 (defun %tests-from-tags (tags &optional (package *package*))
 264   "Return the tests associated with the tags."
 265   (loop with table = (package-tags package)
 266         for tag in tags
 267         as tests = (gethash tag table)
 268         if (null tests) do (warn "No tests tagged with ~S." tag)
 269         else nconc (copy-list tests) into all-tests
 270         finally (return (delete-duplicates all-tests))))
 271
 272 (defun list-tags (&optional (package *package*))
 273   "Return a list of the tags in package."
 274   (let ((tags (package-tags package)))
 275     (when tags
 276       (loop for tag being each hash-key in tags collect tag))))
 277
 278 (defun tagged-tests (tags &optional (package *package*))
 279   "Return a list of the tests associated with the tags."
 280   (if (eq :all tags)
 281       (%tests-from-all-tags package)
 282       (%tests-from-tags tags package)))
 283
 284 (defun remove-tags (tags &optional (package *package*))
 285   "Remove individual tags or entire sets."
 286   (if (eq :all tags)
 287       (if (null package)
 288           (clrhash *tag-db*)
 289           (remhash (find-package package) *tag-db*))
 290       (let ((table (package-tags package)))
 291         (unless (null table)
 292           (loop for tag in tags
 293                 always (remhash tag table)
 294                 collect tag into removed
 295                 finally (return removed))))))
 296
 297 ;;; Assert macros
 298
 299 (defmacro assert-eq (expected form &rest extras)
 300   "Assert whether expected and form are EQ."
 301   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 302
 303 (defmacro assert-eql (expected form &rest extras)
 304   "Assert whether expected and form are EQL."
 305   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 306
 307 (defmacro assert-equal (expected form &rest extras)
 308   "Assert whether expected and form are EQUAL."
 309   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 310
 311 (defmacro assert-equalp (expected form &rest extras)
 312   "Assert whether expected and form are EQUALP."
 313   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 314
 315 (defmacro assert-error (condition form &rest extras)
 316   "Assert whether form signals condition."
 317   `(expand-assert :error ,form (expand-error-form ,form)
 318                   ,condition ,extras))
 319
 320 (defmacro assert-expands (expansion form &rest extras)
 321   "Assert whether form expands to expansion."
 322   `(expand-assert :macro ,form
 323                   (expand-macro-form ,form nil)
 324                   ,expansion ,extras))
 325
 326 (defmacro assert-false (form &rest extras)
 327   "Assert whether the form is false."
 328   `(expand-assert :result ,form ,form nil ,extras))
 329
 330 (defmacro assert-equality (test expected form &rest extras)
 331   "Assert whether expected and form are equal according to test."
 332   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 333
 334 (defmacro assert-prints (output form &rest extras)
 335   "Assert whether printing the form generates the output."
 336   `(expand-assert :output ,form (expand-output-form ,form)
 337                   ,output ,extras))
 338
 339 (defmacro assert-true (form &rest extras)
 340   "Assert whether the form is true."
 341   `(expand-assert :result ,form ,form t ,extras))
 342
 343 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 344   "Expand the assertion to the internal format."
 345   `(internal-assert ,type ',form
 346                     (lambda () ,body)
 347                     (lambda () ,expected)
 348                     (expand-extras ,extras)
 349                     ,test))
 350
 351 (defmacro expand-error-form (form)
 352   "Wrap the error assertion in HANDLER-CASE."
 353   `(handler-case ,form
 354      (condition (error) error)))
 355
 356 (defmacro expand-output-form (form)
 357   "Capture the output of the form in a string."
 358   (let ((out (gensym)))
 359     `(let* ((,out (make-string-output-stream))
 360             (*standard-output*
 361              (make-broadcast-stream *standard-output* ,out)))
 362        ,form
 363        (get-output-stream-string ,out))))
 364
 365 (defmacro expand-macro-form (form env)
 366   "Expand the macro form once."
 367   `(macroexpand-1 ',form ,env))
 368
 369 (defmacro expand-extras (extras)
 370   "Expand extra forms."
 371   `(lambda ()
 372      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 373
 374 (defclass assert-result ()
 375   ((form
 376     :initarg :form
 377     :reader form)
 378    (actual
 379     :type list
 380     :initarg :actual
 381     :reader actual)
 382    (expected
 383     :type list
 384     :initarg :expected
 385     :reader expected)
 386    (extras
 387     :type list
 388     :initarg :extras
 389     :reader extras)
 390    (test
 391     :type function
 392     :initarg :test
 393     :reader test)
 394    (passed
 395     :type boolean
 396     :reader passed))
 397   (:documentation
 398    "Result of the assertion."))
 399
 400 (defmethod initialize-instance :after ((self assert-result)
 401                                        &rest initargs)
 402   "Evaluate the actual and expected forms"
 403   (with-slots (actual expected) self
 404     (setf
 405      actual (multiple-value-list (funcall actual))
 406      expected (multiple-value-list (funcall expected))))
 407   ;; Generate extras
 408   (when (slot-boundp self 'extras)
 409     (setf
 410      (slot-value self 'extras)
 411      (funcall (slot-value self 'extras)))))
 412
 413 (defclass equal-result (assert-result)
 414   ()
 415   (:documentation
 416    "Result of an equal assertion type."))
 417
 418 (defmethod initialize-instance :after ((self equal-result)
 419                                        &rest initargs)
 420   "Return the result of the equality assertion."
 421   (with-slots (actual expected test passed) self
 422     (setf
 423      passed
 424      (and
 425       (<= (length expected) (length actual))
 426       (every test expected actual)))))
 427
 428 (defclass error-result (assert-result)
 429   ()
 430   (:documentation
 431    "Result of an error assertion type."))
 432
 433 (defmethod initialize-instance :after ((self error-result)
 434                                        &rest initargs)
 435   "Evaluate the result."
 436   (with-slots (actual expected passed) self
 437     (setf
 438      passed
 439      (or
 440       (eql (car actual) (car expected))
 441       (typep (car actual) (car expected))))))
 442
 443 (defclass macro-result (assert-result)
 444   ()
 445   (:documentation
 446    "Result of a macro assertion type."))
 447
 448 (defmethod initialize-instance :after ((self macro-result)
 449                                        &rest initargs)
 450   "Return the result of the macro expansion."
 451   (with-slots (actual expected passed) self
 452     (setf passed (equal (car actual) (car expected)))))
 453
 454 (defclass boolean-result (assert-result)
 455   ()
 456   (:documentation
 457    "Result of a result assertion type."))
 458
 459 (defmethod initialize-instance :after ((self boolean-result)
 460                                        &rest initargs)
 461   "Return the result of the assertion."
 462   (with-slots (actual expected passed) self
 463     (setf passed (logically-equal (car actual) (car expected)))))
 464
 465 (defclass output-result (assert-result)
 466   ()
 467   (:documentation
 468    "Result of an output assertion type."))
 469
 470 (defmethod initialize-instance :after ((self output-result)
 471                                        &rest initargs)
 472   "Return the result of the printed output."
 473   (with-slots (actual expected passed) self
 474     (setf
 475      passed
 476      (string=
 477       (string-trim '(#\newline #\return #\space) (car actual))
 478       (car expected)))))
 479
 480 (defun assert-class (type)
 481   "Return the class name for the assertion type."
 482   (ecase type
 483     (:equal 'equal-result)
 484     (:error 'error-result)
 485     (:macro 'macro-result)
 486     (:result 'boolean-result)
 487     (:output 'output-result)))
 488
 489 (defun internal-assert
 490        (type form code-thunk expected-thunk extras test)
 491   "Perform the assertion and record the results."
 492   (let ((result
 493          (make-instance (assert-class type)
 494                         :form form
 495                         :actual code-thunk
 496                         :expected expected-thunk
 497                         :extras extras
 498                         :test test)))
 499     (if (passed result)
 500         (push result *pass*)
 501         (push result *fail*))
 502     ;; Return the result
 503     (passed result)))
 504
 505 ;;; Unit test results
 506
 507 (defclass test-result ()
 508   ((name
 509     :type symbol
 510     :initarg :name
 511     :reader name)
 512    (pass
 513     :type list
 514     :initarg :pass
 515     :reader pass)
 516    (fail
 517     :type list
 518     :initarg :fail
 519     :reader fail)
 520    (exerr
 521     :type condition
 522     :initarg :exerr
 523     :reader exerr))
 524   (:default-initargs :exerr nil)
 525   (:documentation
 526    "Store the results of the unit test."))
 527
 528 (defun print-summary (test-result)
 529   "Print a summary of the test result."
 530   (format t "~&~A: ~S assertions passed, ~S failed"
 531           (name test-result)
 532           (length (pass test-result))
 533           (length (fail test-result)))
 534   (if (exerr test-result)
 535       (format t ", and an execution error.")
 536       (write-char #\.))
 537   (terpri)
 538   (terpri))
 539
 540 (defun run-code (code)
 541   "Run the code to test the assertions."
 542   (funcall (coerce `(lambda () ,@code) 'function)))
 543
 544 (defun run-test-thunk (name code)
 545   (let ((*pass* ())
 546         (*fail* ()))
 547     (handler-bind
 548         ((error
 549           (lambda (condition)
 550             (if (use-debugger-p condition)
 551                 condition
 552                 (return-from run-test-thunk
 553                   (make-instance
 554                    'test-result
 555                    :name name
 556                    :pass *pass*
 557                    :fail *fail*
 558                    :exerr condition))))))
 559       (run-code code))
 560     ;; Return the result count
 561     (make-instance 'test-result
 562                    :name name
 563                    :pass *pass*
 564                    :fail *fail*)))
 565
 566 ;;; Test results database
 567
 568 (defclass test-results-db ()
 569   ((database
 570     :type hash-table
 571     :initform (make-hash-table :test #'eq)
 572     :reader database)
 573    (pass
 574     :type fixnum
 575     :initform 0
 576     :accessor pass)
 577    (fail
 578     :type fixnum
 579     :initform 0
 580     :accessor fail)
 581    (exerr
 582     :type fixnum
 583     :initform 0
 584     :accessor exerr)
 585    (failed-tests
 586     :type list
 587     :initform ()
 588     :accessor failed-tests)
 589    (error-tests
 590     :type list
 591     :initform ()
 592     :accessor error-tests)
 593    (missing-tests
 594     :type list
 595     :initform ()
 596     :accessor missing-tests))
 597   (:documentation
 598    "Store the results of the tests for further evaluation."))
 599
 600 (defmethod print-object ((object test-results-db) stream)
 601   "Print the summary counts with the object."
 602   (let ((pass (pass object))
 603         (fail (fail object))
 604         (exerr (exerr object)))
 605     (format
 606      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 607      (class-name (class-of object))
 608      (+ pass fail) pass fail exerr)))
 609
 610 (defun test-names (test-results-db)
 611   "Return a list of the test names in the database."
 612   (loop for name being each hash-key in (database test-results-db)
 613         collect name))
 614
 615 (defun record-result (test-name code results)
 616   "Run the test code and record the result."
 617   (let ((result (run-test-thunk test-name code)))
 618     ;; Store the result
 619     (setf (gethash test-name (database results)) result)
 620     ;; Count passed tests
 621     (when (pass result)
 622       (incf (pass results) (length (pass result))))
 623     ;; Count failed tests and record the name
 624     (when (fail result)
 625       (incf (fail results) (length (fail result)))
 626       (push test-name (failed-tests results)))
 627     ;; Count errors and record the name
 628     (when (exerr result)
 629       (incf (exerr results))
 630       (push test-name (error-tests results)))
 631     ;; Running output
 632     (when *print-failures* (print-failures result))
 633     (when *print-errors* (print-errors result))
 634     (when (or *print-summary* *print-failures* *print-errors*)
 635       (print-summary result))))
 636
 637 (defun summarize-results (results)
 638   "Print a summary of all results."
 639   (let ((pass (pass results))
 640         (fail (fail results)))
 641     (format t "~&Unit Test Summary~%")
 642     (format t " | ~D assertions total~%" (+ pass fail))
 643     (format t " | ~D passed~%" pass)
 644     (format t " | ~D failed~%" fail)
 645     (format t " | ~D execution errors~%" (exerr results))
 646     (format t " | ~D missing tests~2%"
 647             (length (missing-tests results)))))
 648
 649 ;;; Run the tests
 650
 651 (defun %run-all-thunks (&optional (package *package*))
 652   "Run all of the test thunks in the package."
 653   (loop
 654    with results = (make-instance 'test-results-db)
 655    for test-name being each hash-key in (package-table package)
 656    using (hash-value unit-test)
 657    if unit-test do
 658    (record-result test-name (code unit-test) results)
 659    else do
 660    (push test-name (missing-tests results))
 661    ;; Summarize and return the test results
 662    finally
 663    (summarize-results results)
 664    (return results)))
 665
 666 (defun %run-thunks (test-names &optional (package *package*))
 667   "Run the list of test thunks in the package."
 668   (loop
 669    with table = (package-table package)
 670    and results = (make-instance 'test-results-db)
 671    for test-name in test-names
 672    as unit-test = (gethash test-name table)
 673    if unit-test do
 674    (record-result test-name (code unit-test) results)
 675    else do
 676    (push test-name (missing-tests results))
 677    finally
 678    (summarize-results results)
 679    (return results)))
 680
 681 (defun run-tests (test-names &optional (package *package*))
 682   "Run the specified tests in package."
 683   (reset-counters)
 684   (if (eq :all test-names)
 685       (%run-all-thunks package)
 686       (%run-thunks test-names package)))
 687
 688 (defun run-tags (tags &optional (package *package*))
 689   "Run the tests associated with the specified tags in package."
 690   (reset-counters)
 691   (%run-thunks (tagged-tests tags package) package))
 692
 693 ;;; Print failures
 694
 695 (defgeneric print-failures (result)
 696   (:documentation
 697    "Report the results of the failed assertion."))
 698
 699 (defmethod print-failures :around ((result assert-result))
 700   "Failure header and footer output."
 701   (format t "~& | Failed Form: ~S" (form result))
 702   (call-next-method)
 703   (when (extras result)
 704     (format t "~{~& | ~S => ~S~}~%" (extras result)))
 705   (format t "~& |~%")
 706   (class-name (class-of result)))
 707
 708 (defmethod print-failures ((result assert-result))
 709   (format t "~& | Expected ~{~S~^; ~} " (expected result))
 710   (format t "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 711
 712 (defmethod print-failures ((result error-result))
 713   (format t "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 714           (expected result))
 715   (format t " ~{~S~^; ~}" (actual result)))
 716
 717 (defmethod print-failures ((result macro-result))
 718   (format t "~& | Should have expanded to ~{~S~^; ~} "
 719           (expected result))
 720   (format t "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 721
 722 (defmethod print-failures ((result output-result))
 723   (format t "~& | Should have printed ~{~S~^; ~} "
 724           (expected result))
 725   (format t "~<~%~:;but saw ~{~S~^; ~}~>"
 726           (actual result)))
 727
 728 (defmethod print-failures ((result test-result))
 729   "Print the failed assertions in the unit test."
 730   (loop for fail in (fail result) do
 731         (print-failures fail)))
 732
 733 (defmethod print-failures ((results test-results-db))
 734   "Print all of the failure tests."
 735   (loop with db = (database results)
 736         for test in (failed-tests results)
 737         as result = (gethash test db)
 738         do
 739         (print-failures result)
 740         (print-summary result)))
 741
 742 ;;; Print errors
 743
 744 (defgeneric print-errors (result)
 745   (:documentation
 746    "Print the error condition."))
 747
 748 (defmethod print-errors ((result test-result))
 749   "Print the error condition."
 750   (let ((exerr (exerr result))
 751         (*print-escape* nil))
 752     (when exerr
 753       (format t "~& | Execution error:~% | ~W" exerr)
 754       (format t "~& |~%"))))
 755
 756 (defmethod print-errors ((results test-results-db))
 757   "Print all of the error tests."
 758   (loop with db = (database results)
 759         for test in (error-tests results)
 760         as result = (gethash test db)
 761         do
 762         (print-errors result)
 763         (print-summary result)))
 764
 765 ;;; Useful equality predicates for tests
 766
 767 (defun logically-equal (x y)
 768   "Return true if x and y are both false or both true."
 769   (eql (not x) (not y)))
 770
 771 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
 772   "Return true if every element of list1 is an element of list2 and
 773 vice versa."
 774   (declare (ignore key test))
 775   (and
 776    (listp list1)
 777    (listp list2)
 778    (apply #'subsetp list1 list2 initargs)
 779    (apply #'subsetp list2 list1 initargs)))
 780
 781 (pushnew :lisp-unit common-lisp:*features*)