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