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