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