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