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