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            :*summarize-results*)
  62   ;; Forms for assertions
  63   (:export :assert-eq
  64            :assert-eql
  65            :assert-equal
  66            :assert-equalp
  67            :assert-equality
  68            :assert-prints
  69            :assert-expands
  70            :assert-true
  71            :assert-test
  72            :assert-false
  73            :assert-error)
  74   ;; Functions for managing tests
  75   (:export :define-test
  76            :list-tests
  77            :test-code
  78            :test-documentation
  79            :remove-tests
  80            :run-tests
  81            :use-debugger
  82            :check-code)
  83   ;; Functions for managing tags
  84   (:export :list-tags
  85            :tagged-tests
  86            :remove-tags
  87            :run-tags)
  88   ;; Functions for reporting test results
  89   (:export :test-names
  90            :failed-tests
  91            :error-tests
  92            :missing-tests
  93            :print-failures
  94            :print-errors
  95            :summarize-results)
  96   ;; Functions for test results
  97   (:export :reduce-test-results-dbs)
  98   ;; Functions for extensibility via signals
  99   (:export :signal-results
 100            :test-run-complete
 101            :results)
 102   ;; Utility predicates
 103   (:export :logically-equal :set-equal))
 104
 105 (in-package :lisp-unit)
 106
 107 ;;; Global counters
 108
 109 (defparameter *pass* 0
 110   "The passed assertion results.")
 111
 112 (defparameter *fail* ()
 113   "The failed assertion results.")
 114
 115 (defun reset-counters ()
 116   "Reset the counters to empty lists."
 117   (setf *pass* 0 *fail* ()))
 118
 119 ;;; Global options
 120
 121 (defparameter *print-summary* nil
 122   "Print a summary of the pass, fail, and error count if non-nil.")
 123
 124 (defparameter *print-failures* nil
 125   "Print failure messages if non-NIL.")
 126
 127 (defparameter *print-errors* nil
 128   "Print error messages if non-NIL.")
 129
 130 (defparameter *summarize-results* t
 131   "Summarize all of the unit test results.")
 132
 133 (defparameter *use-debugger* nil
 134   "If not NIL, enter the debugger when an error is encountered in an
 135 assertion.")
 136
 137 (defun use-debugger (&optional (flag t))
 138   "Use the debugger when testing, or not."
 139   (setq *use-debugger* flag))
 140
 141 (defun use-debugger-p (condition)
 142   "Debug or ignore errors."
 143   (cond
 144    ((eq :ask *use-debugger*)
 145     (y-or-n-p "~A -- debug?" condition))
 146    (*use-debugger*)))
 147
 148 (defparameter *signal-results* nil
 149   "Signal the result if non NIL.")
 150
 151 (defun signal-results (&optional (flag t))
 152   "Signal the results for extensibility."
 153   (setq *signal-results* flag))
 154
 155 (defparameter *check-code* nil
 156   "Check the code when the test is defined if not NIL.")
 157
 158 (defun check-code (&optional (flag t))
 159   "Check the code when the test is defined."
 160   (setq *check-code* flag))
 161
 162 ;;; Global unit test database
 163
 164 (defparameter *test-db* (make-hash-table :test #'eq)
 165   "The unit test database is simply a hash table.")
 166
 167 (defun null-tests-warning-report (null-tests-warning stream)
 168   "Write the null-tests-warning to the stream."
 169   (format stream "No tests defined for package ~A."
 170           (tests-package-name null-tests-warning)))
 171
 172 (define-condition null-tests-warning (simple-warning)
 173   ((name
 174     :type string
 175     :initarg :name
 176     :reader tests-package-name))
 177   (:report null-tests-warning-report))
 178
 179 (defun package-table (package &optional create)
 180   (let ((packobj (find-package package)))
 181     (cond
 182      ((gethash packobj *test-db*))
 183      (create
 184       (setf (gethash packobj *test-db*) (make-hash-table)))
 185      (t (warn 'null-tests-warning :name (package-name package))))))
 186
 187 (defmacro with-package-table ((table
 188                                &optional (package *package*) create)
 189                               &body body)
 190   "Execute the body only if the package table exists."
 191   (let ((gtable (gensym "TABLE-")))
 192     `(let* ((,gtable (package-table ,package ,create))
 193             (,table ,gtable))
 194        (when (hash-table-p ,gtable) ,@body))))
 195
 196 ;;; Global tags database
 197
 198 (defparameter *tag-db* (make-hash-table :test #'eq)
 199   "The tag database is simply a hash table.")
 200
 201 (defun null-tags-warning-report (null-tags-warning stream)
 202   "Write the null-tags-warning to the stream."
 203   (format stream "No tags defined for package ~A."
 204           (tags-package-name null-tags-warning)))
 205
 206 (define-condition null-tags-warning (simple-warning)
 207   ((name
 208     :type string
 209     :initarg :name
 210     :reader tags-package-name))
 211   (:report null-tags-warning-report))
 212
 213 (defun package-tags (package &optional create)
 214   "Return the tags DB for the package."
 215   (let ((packobj (find-package package)))
 216     (cond
 217      ((gethash packobj *tag-db*))
 218      (create
 219       (setf (gethash packobj *tag-db*) (make-hash-table)))
 220      (t (warn 'null-tags-warning :name (package-name package))))))
 221
 222 (defmacro with-package-tags ((table
 223                               &optional (package *package*) create)
 224                              &body body)
 225   "Execute the body only if the package tags exists."
 226   (let ((gtable (gensym "TABLE-")))
 227     `(let* ((,gtable (package-tags ,package ,create))
 228             (,table ,gtable))
 229        (when (hash-table-p ,gtable) ,@body))))
 230
 231 ;;; Unit test definition
 232
 233 (defclass unit-test ()
 234   ((doc
 235     :type string
 236     :initarg :doc
 237     :reader doc)
 238    (code
 239     :type list
 240     :initarg :code
 241     :reader code))
 242   (:default-initargs :doc "" :code ())
 243   (:documentation
 244    "Organize the unit test documentation and code."))
 245
 246 ;;; NOTE: Shamelessly taken from PG's analyze-body
 247 (defun parse-body (body &optional doc tag)
 248   "Separate the components of the body."
 249   (let ((item (first body)))
 250     (cond
 251      ((and (listp item) (eq :tag (first item)))
 252       (parse-body (rest body) doc (nconc (rest item) tag)))
 253      ((and (stringp item) (not doc) (rest body))
 254       (if tag
 255           (values doc tag (rest body))
 256           (parse-body (rest body) item tag)))
 257      (t (values doc tag body)))))
 258
 259 (defun test-name-error-report (test-name-error stream)
 260   "Write the test-name-error to the stream."
 261   (format stream "Test name ~S is not of type ~A."
 262           (type-error-datum test-name-error)
 263           (type-error-expected-type test-name-error)))
 264
 265 (define-condition test-name-error (type-error)
 266   ()
 267   (:default-initargs :expected-type 'symbol)
 268   (:report test-name-error-report)
 269   (:documentation
 270    "The test name error is a type error."))
 271
 272 (defun valid-test-name (name)
 273   "Signal a type-error if the test name is not a symbol."
 274   (if (symbolp name)
 275       name
 276       (error 'test-name-error :datum name)))
 277
 278 (defun test-package (name)
 279   "Return the package for storing the test."
 280   (multiple-value-bind (symbol status)
 281       (find-symbol (symbol-name name))
 282     (declare (ignore symbol))
 283     (ecase status
 284       ((:internal :external nil)
 285        (symbol-package name))
 286       (:inherited *package*))))
 287
 288 (defmacro define-test (name &body body)
 289   "Store the test in the test database."
 290   (let ((qname (gensym "NAME-")))
 291     (multiple-value-bind (doc tag code) (parse-body body)
 292       `(let* ((,qname (valid-test-name ',name))
 293               (doc (or ,doc (symbol-name ,qname)))
 294               (package (test-package ,qname)))
 295          ,(when *check-code* `(lambda () ,@code))
 296          (setf
 297           ;; Unit test
 298           (gethash ,qname (package-table package t))
 299           (make-instance 'unit-test :doc doc :code ',code))
 300          ;; Tags
 301          (loop
 302           for tag in ',tag do
 303           (pushnew ,qname (gethash tag (package-tags package t))))
 304          ;; Return the name of the test
 305          ,qname))))
 306
 307 ;;; Manage tests
 308
 309 (defun list-tests (&optional (package *package*))
 310   "Return a list of the tests in package."
 311   (with-package-table (table package)
 312     (loop for test-name being each hash-key in table
 313           collect test-name)))
 314
 315 (defun test-documentation (name &optional (package *package*))
 316   "Return the documentation for the test."
 317   (with-package-table (table package)
 318     (let ((unit-test (gethash name table)))
 319       (if (null unit-test)
 320           (warn "No test ~A in package ~A."
 321                 name (package-name package))
 322           (doc unit-test)))))
 323
 324 (defun test-code (name &optional (package *package*))
 325   "Returns the code stored for the test name."
 326   (with-package-table (table package)
 327     (let ((unit-test (gethash name table)))
 328       (if (null unit-test)
 329           (warn "No test ~A in package ~A."
 330                 name (package-name package))
 331           (code unit-test)))))
 332
 333 (defun remove-tests (&optional (names :all) (package *package*))
 334   "Remove individual tests or entire sets."
 335   (if (eq :all names)
 336       (if (null package)
 337           (clrhash *test-db*)
 338           (progn
 339             (remhash (find-package package) *test-db*)
 340             (remhash (find-package package) *tag-db*)))
 341       (progn
 342         ;; Remove tests
 343         (with-package-table (table package)
 344           (loop for name in names
 345                 unless (remhash name table) do
 346                 (warn "No test ~A in package ~A to remove."
 347                       name (package-name package))))
 348         ;; Remove tests from tags
 349         (with-package-tags (tags package)
 350           (loop for tag being each hash-key in tags
 351                 using (hash-value tagged-tests)
 352                 do
 353                 (setf
 354                  (gethash tag tags)
 355                  (set-difference tagged-tests names)))))))
 356
 357 ;;; Manage tags
 358
 359 (defun %tests-from-all-tags (&optional (package *package*))
 360   "Return all of the tests that have been tagged."
 361   (with-package-tags (table package)
 362     (loop for tests being each hash-value in table
 363           nconc (copy-list tests) into all-tests
 364           finally (return (delete-duplicates all-tests)))))
 365
 366 (defun %tests-from-tags (tags &optional (package *package*))
 367   "Return the tests associated with the tags."
 368   (with-package-tags (table package)
 369     (loop for tag in tags
 370           as tests = (gethash tag table)
 371           if (null tests) do (warn "No tests tagged with ~S." tag)
 372           else nconc (copy-list tests) into all-tests
 373           finally (return (delete-duplicates all-tests)))))
 374
 375 (defun list-tags (&optional (package *package*))
 376   "Return a list of the tags in package."
 377   (with-package-tags (table package)
 378     (loop for tag being each hash-key in table collect tag)))
 379
 380 (defun tagged-tests (&optional (tags :all) (package *package*))
 381   "Return a list of the tests associated with the tags."
 382   (if (eq :all tags)
 383       (%tests-from-all-tags package)
 384       (%tests-from-tags tags package)))
 385
 386 (defun remove-tags (&optional (tags :all) (package *package*))
 387   "Remove individual tags or entire sets."
 388   (if (eq :all tags)
 389       (if (null package)
 390           (clrhash *tag-db*)
 391           (remhash (find-package package) *tag-db*))
 392       (with-package-tags (tag-table package)
 393         (loop for tag in tags
 394               unless (remhash tag tag-table) do
 395               (warn "No tag ~A in package ~A to remove."
 396                     tag (package-name package))))))
 397
 398 ;;; Assert macros
 399
 400 (defmacro assert-eq (expected form &rest extras)
 401   "Assert whether expected and form are EQ."
 402   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 403
 404 (defmacro assert-eql (expected form &rest extras)
 405   "Assert whether expected and form are EQL."
 406   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 407
 408 (defmacro assert-equal (expected form &rest extras)
 409   "Assert whether expected and form are EQUAL."
 410   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 411
 412 (defmacro assert-equalp (expected form &rest extras)
 413   "Assert whether expected and form are EQUALP."
 414   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 415
 416 (defmacro assert-error (condition form &rest extras)
 417   "Assert whether form signals condition."
 418   `(expand-assert :error ,form (expand-error-form ,form)
 419                   ,condition ,extras))
 420
 421 (defmacro assert-expands (expansion form &rest extras)
 422   "Assert whether form expands to expansion."
 423   `(expand-assert :macro ,form
 424                   (expand-macro-form ,form nil)
 425                   ',expansion ,extras))
 426
 427 (defmacro assert-equality (test expected form &rest extras)
 428   "Assert whether expected and form are equal according to test."
 429   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 430
 431 (defmacro assert-prints (output form &rest extras)
 432   "Assert whether printing the form generates the output."
 433   `(expand-assert :output ,form (expand-output-form ,form)
 434                   ,output ,extras))
 435
 436 (defmacro assert-nil (form &rest extras)
 437   "Assert whether the form is false."
 438   (if (atom form)
 439       `(expand-assert :result ,form ,form nil ,extras)
 440       `(expand-t-or-f nil ,form ,extras)))
 441
 442 (defmacro assert-false (form &rest extras)
 443   "Assert whether the form is false."
 444   (if (atom form)
 445       `(expand-assert :result ,form ,form nil ,extras)
 446       `(expand-t-or-f nil ,form ,extras)))
 447
 448 (defmacro assert-true (form &rest extras)
 449   "Assert whether the form is true."
 450   (if (atom form)
 451       `(expand-assert :result ,form ,form t ,extras)
 452       `(expand-t-or-f t ,form ,extras)))
 453
 454 (defmacro expand-t-or-f (t-or-f form extras)
 455   "Expand the true/false assertions to report the arguments."
 456   (let ((fname (gensym))
 457         (args (gensym)))
 458     `(let ((,fname #',(car form))
 459            (,args (list ,@(cdr form))))
 460        (internal-assert
 461         :result ',form
 462         (lambda () (apply ,fname ,args)) ; Evaluate the form
 463         (lambda () ,t-or-f)
 464         ;; Concatenate the args with the extras
 465         (lambda ()
 466           (nconc
 467            (mapcan #'list ',(cdr form) ,args)
 468            (funcall (expand-extras ,extras))))
 469         #'eql))))
 470
 471 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 472   "Expand the assertion to the internal format."
 473   `(internal-assert ,type ',form
 474                     (lambda () ,body)
 475                     (lambda () ,expected)
 476                     (expand-extras ,extras)
 477                     ,test))
 478
 479 (defmacro expand-error-form (form)
 480   "Wrap the error assertion in HANDLER-CASE."
 481   `(handler-case ,form
 482      (condition (error) error)))
 483
 484 (defmacro expand-output-form (form)
 485   "Capture the output of the form in a string."
 486   (let ((out (gensym)))
 487     `(let* ((,out (make-string-output-stream))
 488             (*standard-output*
 489              (make-broadcast-stream *standard-output* ,out)))
 490        ,form
 491        (get-output-stream-string ,out))))
 492
 493 (defmacro expand-macro-form (form env)
 494   "Expand the macro form once."
 495   `(let ((*gensym-counter* 1))
 496      (macroexpand-1 ',form ,env)))
 497
 498 (defmacro expand-extras (extras)
 499   "Expand extra forms."
 500   `(lambda ()
 501      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 502
 503 (defgeneric assert-result (type test expected actual)
 504   (:documentation
 505    "Return the result of the assertion."))
 506
 507 (defgeneric record-failure (type form actual expected extras test)
 508   (:documentation
 509    "Record the details of the failure."))
 510
 511 (defclass failure-result ()
 512   ((form
 513     :initarg :form
 514     :reader form)
 515    (actual
 516     :type list
 517     :initarg :actual
 518     :reader actual)
 519    (expected
 520     :type list
 521     :initarg :expected
 522     :reader expected)
 523    (extras
 524     :type list
 525     :initarg :extras
 526     :reader extras)
 527    (test
 528     :type function
 529     :initarg :test
 530     :reader test))
 531   (:documentation
 532    "Failure details of the assertion."))
 533
 534 (defun %record-failure (class form actual expected extras test)
 535   "Return an instance of the failure result."
 536   (make-instance class
 537                  :form form
 538                  :actual actual
 539                  :expected expected
 540                  :extras extras
 541                  :test test))
 542
 543 (defclass equal-result (failure-result)
 544   ()
 545   (:documentation
 546    "Result of a failed equal assertion."))
 547
 548 (defmethod assert-result ((type (eql :equal)) test expected actual)
 549   "Return the result of an equal assertion."
 550   (and
 551    (<= (length expected) (length actual))
 552    (every test expected actual)))
 553
 554 (defmethod record-failure ((type (eql :equal))
 555                            form actual expected extras test)
 556   "Return an instance of an equal failure result."
 557   (%record-failure 'equal-result form actual expected extras test))
 558
 559 (defclass error-result (failure-result)
 560   ()
 561   (:documentation
 562    "Result of a failed error assertion."))
 563
 564 (defmethod assert-result ((type (eql :error)) test expected actual)
 565   "Return the result of an error assertion."
 566   (declare (ignore test))
 567   (or
 568    (eql (car actual) (car expected))
 569    (typep (car actual) (car expected))))
 570
 571 (defmethod record-failure ((type (eql :error))
 572                            form actual expected extras test)
 573   "Return an instance of an error failure result."
 574   (%record-failure 'error-result form actual expected extras test))
 575
 576 (defclass macro-result (failure-result)
 577   ()
 578   (:documentation
 579    "Result of a failed macro expansion assertion."))
 580
 581 (defun %expansion-equal (form1 form2)
 582   "Descend into the forms checking for equality."
 583   (let ((item1 (first form1))
 584         (item2 (first form2)))
 585     (cond
 586      ((and (null item1) (null item2)))
 587      ((and (listp item1) (listp item2))
 588       (and
 589        (%expansion-equal item1 item2)
 590        (%expansion-equal (rest form1) (rest form2))))
 591      ((and (symbolp item1) (symbolp item2))
 592       (and
 593        (string= (symbol-name item1) (symbol-name item2))
 594        (%expansion-equal (rest form1) (rest form2))))
 595      (t (and
 596          (equal item1 item2)
 597          (%expansion-equal (rest form1) (rest form2)))))))
 598
 599 (defmethod assert-result ((type (eql  :macro)) test expected actual)
 600   "Return the result of a macro assertion."
 601   (declare (ignore test))
 602   (%expansion-equal (first expected) (first actual)))
 603
 604 (defmethod record-failure ((type (eql :macro))
 605                            form actual expected extras test)
 606   "Return an instance of a macro failure result."
 607   (%record-failure 'macro-result form actual expected extras test))
 608
 609 (defclass boolean-result (failure-result)
 610   ()
 611   (:documentation
 612    "Result of a failed boolean assertion."))
 613
 614 (defmethod assert-result ((type (eql :result)) test expected actual)
 615   "Return the result of a result assertion."
 616   (declare (ignore test))
 617   (logically-equal (car actual) (car expected)))
 618
 619 (defmethod record-failure ((type (eql :result))
 620                            form actual expected extras test)
 621   "Return an instance of a boolean failure result."
 622   (%record-failure 'boolean-result form actual expected extras test))
 623
 624 (defclass output-result (failure-result)
 625   ()
 626   (:documentation
 627    "Result of a failed output assertion."))
 628
 629 (defmethod assert-result ((type (eql :output)) test expected actual)
 630   "Return the result of an output assertion."
 631   (declare (ignore test))
 632   (string=
 633    (string-trim '(#\newline #\return #\space) (car actual))
 634    (car expected)))
 635
 636 (defmethod record-failure ((type (eql :output))
 637                            form actual expected extras test)
 638   "Return an instance of an output failure result."
 639   (%record-failure 'output-result form actual expected extras test))
 640
 641 (defun internal-assert
 642        (type form code-thunk expected-thunk extras test)
 643   "Perform the assertion and record the results."
 644   (let* ((actual (multiple-value-list (funcall code-thunk)))
 645          (expected (multiple-value-list (funcall expected-thunk)))
 646          (result (assert-result type test expected actual)))
 647     (if result
 648         (incf *pass*)
 649         (push
 650          (record-failure
 651           type form actual expected
 652           (when extras (funcall extras)) test)
 653          *fail*))
 654     ;; Return the result
 655     result))
 656
 657 ;;; Unit test results
 658
 659 (defclass test-result ()
 660   ((name
 661     :type symbol
 662     :initarg :name
 663     :reader name)
 664    (pass
 665     :type fixnum
 666     :initarg :pass
 667     :reader pass)
 668    (fail
 669     :type list
 670     :initarg :fail
 671     :reader fail)
 672    (exerr
 673     :initarg :exerr
 674     :reader exerr)
 675    (run-time
 676     :initarg :run-time
 677     :reader run-time
 678     :documentation
 679     "Test run time measured in internal time units"))
 680   (:default-initargs :exerr nil)
 681   (:documentation
 682    "Store the results of the unit test."))
 683
 684 (defun print-summary (test-result &optional
 685                       (stream *standard-output*))
 686   "Print a summary of the test result."
 687   (format stream "~&~A: ~S assertions passed, ~S failed"
 688           (name test-result)
 689           (pass test-result)
 690           (length (fail test-result)))
 691   (if (exerr test-result)
 692       (format stream ", and an execution error.")
 693       (write-char #\. stream))
 694   (terpri stream)
 695   (terpri stream))
 696
 697 (defun run-code (code)
 698   "Run the code to test the assertions."
 699   (funcall (coerce `(lambda () ,@code) 'function)))
 700
 701 (defun run-test-thunk (name code)
 702   (let ((*pass* 0)
 703         (*fail* ())
 704         (start (get-internal-run-time)))
 705     (handler-bind
 706         ((error
 707           (lambda (condition)
 708             (if (use-debugger-p condition)
 709                 condition
 710                 (return-from run-test-thunk
 711                   (make-instance
 712                    'test-result
 713                    :name name
 714                    :pass *pass*
 715                    :fail *fail*
 716                    :run-time (- (get-internal-run-time) start)
 717                    :exerr condition))))))
 718       (run-code code))
 719     ;; Return the result count
 720     (make-instance
 721      'test-result
 722      :name name
 723      :pass *pass*
 724      :fail *fail*
 725      :run-time (- (get-internal-run-time) start))))
 726
 727 ;;; Test results database
 728
 729 (defclass test-results-db ()
 730   ((database
 731     :type hash-table
 732     :initform (make-hash-table :test #'eq)
 733     :reader database)
 734    (pass
 735     :type fixnum
 736     :initform 0
 737     :accessor pass)
 738    (fail
 739     :type fixnum
 740     :initform 0
 741     :accessor fail)
 742    (exerr
 743     :type fixnum
 744     :initform 0
 745     :accessor exerr)
 746    (failed-tests
 747     :type list
 748     :initform ()
 749     :accessor failed-tests)
 750    (error-tests
 751     :type list
 752     :initform ()
 753     :accessor error-tests)
 754    (missing-tests
 755     :type list
 756     :initform ()
 757     :accessor missing-tests))
 758   (:documentation
 759    "Store the results of the tests for further evaluation."))
 760
 761 (defmethod print-object ((object test-results-db) stream)
 762   "Print the summary counts with the object."
 763   (let ((pass (pass object))
 764         (fail (fail object))
 765         (exerr (exerr object)))
 766     (format
 767      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 768      (class-name (class-of object))
 769      (+ pass fail) pass fail exerr)))
 770
 771 (defun test-names (test-results-db)
 772   "Return a list of the test names in the database."
 773   (loop for name being each hash-key in (database test-results-db)
 774         collect name))
 775
 776 (defun record-result (test-name code results)
 777   "Run the test code and record the result."
 778   (let ((result (run-test-thunk test-name code)))
 779     ;; Store the result
 780     (setf (gethash test-name (database results)) result)
 781     ;; Count passed tests
 782     (when (plusp (pass result))
 783       (incf (pass results) (pass result)))
 784     ;; Count failed tests and record the name
 785     (when (fail result)
 786       (incf (fail results) (length (fail result)))
 787       (push test-name (failed-tests results)))
 788     ;; Count errors and record the name
 789     (when (exerr result)
 790       (incf (exerr results))
 791       (push test-name (error-tests results)))
 792     ;; Running output
 793     (when *print-failures* (print-failures result))
 794     (when *print-errors* (print-errors result))
 795     (when (or *print-summary* *print-failures* *print-errors*)
 796       (print-summary result))))
 797
 798 (defun summarize-results (results &optional
 799                           (stream *standard-output*))
 800   "Print a summary of all results to the stream."
 801   (let ((pass (pass results))
 802         (fail (fail results)))
 803     (format stream "~&Unit Test Summary~%")
 804     (format stream " | ~D assertions total~%" (+ pass fail))
 805     (format stream " | ~D passed~%" pass)
 806     (format stream " | ~D failed~%" fail)
 807     (format stream " | ~D execution errors~%" (exerr results))
 808     (format stream " | ~D missing tests~2%"
 809             (length (missing-tests results)))))
 810
 811 (defun default-db-merge-function (results new-results)
 812   "Signal an error by default if a merge is required."
 813   (lambda (key value1 value2)
 814     (error
 815      "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
 816 two values, ~A and ~A"
 817      results new-results key value1 value2)))
 818
 819 (defun nappend-test-results-db (results new-results &key merge)
 820   "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
 821 between RESULTS and NEW-RESULTS are handled by the function MERGE.
 822
 823 The lambda list for the MERGE functions is
 824
 825   (key results-value new-results-value)
 826
 827 where:
 828   KEY is the key which appears in RESULTS and NEW-RESULTS.
 829   RESULTS-VALUE is the value appearing RESULTS.
 830   NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
 831
 832 If MERGE is NIL, then an error is signalled when a conflict occurs.
 833 "
 834   (check-type results test-results-db)
 835   (check-type new-results test-results-db)
 836   (check-type merge (or null function))
 837   (loop
 838    with results-db = (database results)
 839    with new-results-db = (database new-results)
 840    with merge =
 841    (or merge (default-db-merge-function results new-results))
 842    ;; Merge test databases
 843    for key being each hash-key in new-results-db
 844    using (hash-value new-results-value)
 845    do
 846    (multiple-value-bind (results-value presentp)
 847        (gethash key results-db)
 848      (setf
 849       (gethash key results-db)
 850       (if presentp
 851           (funcall merge key results-value new-results-value)
 852           new-results-value)))
 853    finally
 854    ;; Update counters
 855    (incf (pass results) (pass new-results))
 856    (incf (fail results) (fail new-results))
 857    (incf (exerr results) (exerr new-results))
 858    ;; Merge failures, errors, and missing test details
 859    (setf
 860     ;; Failures
 861     (failed-tests results)
 862     (append (failed-tests results) (failed-tests new-results))
 863     ;; Errors
 864     (error-tests results)
 865     (append (error-tests results) (error-tests new-results))
 866     ;; Missing tests
 867     (missing-tests results)
 868     (append (missing-tests results) (missing-tests new-results))))
 869    ;; Return the merged results
 870    results)
 871
 872 (defun reduce-test-results-dbs (all-results &key merge)
 873   "Return a new instance of TEST-RESULTS-DB which contains all of the
 874 results in the sequence RESULTS. Any conflicts are handled by the
 875 function MERGE.
 876
 877 The lambda list for the MERGE function is
 878
 879   (key value-1 value-2)
 880
 881 where:
 882   KEY is the key which appears at least twice in the sequence RESULTS.
 883   VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
 884
 885 If MERGE is NIL, then an error is signalled when a conflict occurs."
 886   (loop
 887    with accumulated-test-results-db = (make-instance 'test-results-db)
 888    for new-results in all-results do
 889    (nappend-test-results-db
 890     accumulated-test-results-db new-results :merge merge)
 891    finally (return accumulated-test-results-db)))
 892
 893 ;;; Run the tests
 894
 895 (define-condition test-run-complete ()
 896   ((results
 897     :type 'test-results-db
 898     :initarg :results
 899     :reader results))
 900   (:documentation
 901    "Signaled when a test run is finished."))
 902
 903 (defun %run-all-thunks (&optional (package *package*))
 904   "Run all of the test thunks in the package."
 905   (with-package-table (table package)
 906     (loop
 907      with results = (make-instance 'test-results-db)
 908      for test-name being each hash-key in table
 909      using (hash-value unit-test)
 910      if unit-test do
 911      (record-result test-name (code unit-test) results)
 912      else do
 913      (push test-name (missing-tests results))
 914      ;; Summarize and return the test results
 915      finally
 916      (when *signal-results*
 917        (signal 'test-run-complete :results results))
 918      (when *summarize-results*
 919        (summarize-results results))
 920      (return results))))
 921
 922 (defun %run-thunks (test-names &optional (package *package*))
 923   "Run the list of test thunks in the package."
 924   (with-package-table (table package)
 925     (loop
 926      with results = (make-instance 'test-results-db)
 927      for test-name in test-names
 928      as unit-test = (gethash test-name table)
 929      if unit-test do
 930      (record-result test-name (code unit-test) results)
 931      else do
 932      (push test-name (missing-tests results))
 933      finally
 934      (when *signal-results*
 935        (signal 'test-run-complete :results results))
 936      (when *summarize-results*
 937        (summarize-results results))
 938      (return results))))
 939
 940 (defun run-tests (&optional (test-names :all) (package *package*))
 941   "Run the specified tests in package."
 942   (reset-counters)
 943   (if (eq :all test-names)
 944       (%run-all-thunks package)
 945       (%run-thunks test-names package)))
 946
 947 (defun run-tags (&optional (tags :all) (package *package*))
 948   "Run the tests associated with the specified tags in package."
 949   (reset-counters)
 950   (%run-thunks (tagged-tests tags package) package))
 951
 952 ;;; Print failures
 953
 954 (defgeneric print-failures (result &optional stream)
 955   (:documentation
 956    "Report the results of the failed assertion."))
 957
 958 (defmethod print-failures :around ((result failure-result) &optional
 959                                    (stream *standard-output*))
 960   "Failure header and footer output."
 961   (format stream "~& | Failed Form: ~S" (form result))
 962   (call-next-method)
 963   (when (extras result)
 964     (format stream "~{~& | ~S => ~S~}~%" (extras result)))
 965   (format stream "~& |~%"))
 966
 967 (defmethod print-failures ((result failure-result) &optional
 968                            (stream *standard-output*))
 969   (format stream "~& | Expected ~{~S~^; ~} " (expected result))
 970   (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 971
 972 (defmethod print-failures ((result error-result) &optional
 973                            (stream *standard-output*))
 974   (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 975           (expected result))
 976   (format stream " ~{~S~^; ~}" (actual result)))
 977
 978 (defmethod print-failures ((result macro-result) &optional
 979                            (stream *standard-output*))
 980   (format stream "~& | Should have expanded to ~{~S~^; ~} "
 981           (expected result))
 982   (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 983
 984 (defmethod print-failures ((result output-result) &optional
 985                            (stream *standard-output*))
 986   (format stream "~& | Should have printed ~{~S~^; ~} "
 987           (expected result))
 988   (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
 989           (actual result)))
 990
 991 (defmethod print-failures ((result test-result) &optional
 992                            (stream *standard-output*))
 993   "Print the failed assertions in the unit test."
 994   (loop for fail in (fail result) do
 995         (print-failures fail stream)))
 996
 997 (defmethod print-failures ((results test-results-db) &optional
 998                            (stream *standard-output*))
 999   "Print all of the failure tests."
1000   (loop with db = (database results)
1001         for test in (failed-tests results)
1002         as result = (gethash test db)
1003         do
1004         (print-failures result stream)
1005         (print-summary result stream)))
1006
1007 ;;; Print errors
1008
1009 (defgeneric print-errors (result &optional stream)
1010   (:documentation
1011    "Print the error condition."))
1012
1013 (defmethod print-errors ((result test-result) &optional
1014                          (stream *standard-output*))
1015   "Print the error condition."
1016   (let ((exerr (exerr result))
1017         (*print-escape* nil))
1018     (when exerr
1019       (format stream "~& | Execution error:~% | ~W" exerr)
1020       (format stream "~& |~%"))))
1021
1022 (defmethod print-errors ((results test-results-db) &optional
1023                          (stream *standard-output*))
1024   "Print all of the error tests."
1025   (loop with db = (database results)
1026         for test in (error-tests results)
1027         as result = (gethash test db)
1028         do
1029         (print-errors result stream)
1030         (print-summary result stream)))
1031
1032 ;;; Useful equality predicates for tests
1033
1034 (defun logically-equal (x y)
1035   "Return true if x and y are both false or both true."
1036   (eql (not x) (not y)))
1037
1038 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
1039   "Return true if every element of list1 is an element of list2 and
1040 vice versa."
1041   (declare (ignore key test))
1042   (and
1043    (listp list1)
1044    (listp list2)
1045    (apply #'subsetp list1 list2 initargs)
1046    (apply #'subsetp list2 list1 initargs)))
1047
1048 (pushnew :lisp-unit common-lisp:*features*)