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