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