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