From b289505a0e52c6c980813467548b20a93c25492b Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Fri, 7 Feb 2014 08:09:24 -0800
Subject: [PATCH] Import lisp-unit.  This is the version from quicklisp which
 marked it as lisp-unit-20130615-git.  No changes.

---
 src/contrib/lisp-unit/.gitignore              |   5 +
 src/contrib/lisp-unit/README.md               |  75 ++
 .../lisp-unit/extensions/floating-point.lisp  | 818 ++++++++++++++++
 .../lisp-unit/extensions/rational.lisp        |  96 ++
 .../extensions/test-anything-protocol.lisp    |  86 ++
 .../internal-test/example-tests.lisp          | 153 +++
 .../internal-test/floating-point.lisp         | 115 +++
 .../internal-test/fundamental-assertions.lisp | 170 ++++
 src/contrib/lisp-unit/lisp-unit.asd           |  38 +
 src/contrib/lisp-unit/lisp-unit.lisp          | 910 ++++++++++++++++++
 10 files changed, 2466 insertions(+)
 create mode 100644 src/contrib/lisp-unit/.gitignore
 create mode 100644 src/contrib/lisp-unit/README.md
 create mode 100644 src/contrib/lisp-unit/extensions/floating-point.lisp
 create mode 100644 src/contrib/lisp-unit/extensions/rational.lisp
 create mode 100644 src/contrib/lisp-unit/extensions/test-anything-protocol.lisp
 create mode 100644 src/contrib/lisp-unit/internal-test/example-tests.lisp
 create mode 100644 src/contrib/lisp-unit/internal-test/floating-point.lisp
 create mode 100644 src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp
 create mode 100644 src/contrib/lisp-unit/lisp-unit.asd
 create mode 100644 src/contrib/lisp-unit/lisp-unit.lisp

diff --git a/src/contrib/lisp-unit/.gitignore b/src/contrib/lisp-unit/.gitignore
new file mode 100644
index 000000000..73f35ddd3
--- /dev/null
+++ b/src/contrib/lisp-unit/.gitignore
@@ -0,0 +1,5 @@
+# Ignore FASL files
+*.fasl
+*.lx64fsl
+*.dx64fsl
+*~
diff --git a/src/contrib/lisp-unit/README.md b/src/contrib/lisp-unit/README.md
new file mode 100644
index 000000000..6114a2a65
--- /dev/null
+++ b/src/contrib/lisp-unit/README.md
@@ -0,0 +1,75 @@
+## lisp-unit
+
+*lisp-unit* is a Common Lisp library that supports unit testing. It is
+an extension of the [library written by Chris Riesbeck][orig]. There
+is a long history of testing packages in Lisp, usually called
+"regression" testers. More recent packages in Lisp and other languages
+have been inspired by [JUnit for Java][JUnit].
+
+[Documentation is located on the project wiki.][wiki]
+
+### Features
+
+* Written in portable Common Lisp
+* Loadable as a single file
+* Loadable with [ASDF][] or [Quicklisp][]
+* Simple to define and run tests
+* Redfine functions and macros without reloading tests
+* Test return values, printed output, macro expansions, and conditions
+* Fined grained control over the testing output
+* Store all test results in a database object that can be examined
+* Group tests by package for modularity
+* Group tests using tags
+* Signal test completion and return results with the condition.
+
+### Extensions
+
+* Floating point predicates
+* [Test Anything Protocol][TAP] output
+
+### How to use lisp-unit
+
+The core definitions of *lisp-unit* may be used by loading the single
+file 'lisp-unit.lisp'. To use the extensions, *lisp-unit* must be
+loaded using either [Quicklisp][] or [ASDF][].
+
+1. Load (or compile and load) as a single file : `(load "lisp-unit")`.
+2. Load using [Quicklisp][] : `(ql:quickload :lisp-unit)`.
+3. Load using [ASDF][] : `(asdf:load-system :lisp-unit)`.
+
+## Version 0.9.5 Features
+
+No new features, improved the usability based on user feedback. The
+list of tests or tags to the following functions is now optional and
+defaults to `:ALL`.
+
+* `(remove-tests [names] [package])`
+* `(tagged-tests [tags] [package])`
+* `(remove-tags [tags] [package])`
+* `(run-tests [names] [package])`
+* `(run-tags [tags] [package])`
+
+## Version 1 Remaining Tasks
+
+* (1.0.0) Expanded internal testing.
+
+### Future Features
+
+* Fixtures
+* Test Suites
+* Benchmarking tools
+
+[orig]: <http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html>
+  "Original Lisp Unit"
+[wiki]: <https://github.com/OdonataResearchLLC/lisp-unit/wiki>
+  "Lisp Unit Wiki"
+[JUnit]: <http://www.junit.org> "JUnit"
+[Quicklisp]: <http://www.quicklisp.org> "Quicklisp"
+[ASDF]: <http://common-lisp.net/project/asdf/> "ASDF"
+[TAP]: <http://testanything.org/> "Test Anything Protocol"
+
+## 0.9.5 Acknowledgments
+
+* [Jesse Alama][jessealama] for usability feedback.
+
+[jessealama]: <https://github.com/jessealama> "Jesse Alama"
diff --git a/src/contrib/lisp-unit/extensions/floating-point.lisp b/src/contrib/lisp-unit/extensions/floating-point.lisp
new file mode 100644
index 000000000..3df2b0690
--- /dev/null
+++ b/src/contrib/lisp-unit/extensions/floating-point.lisp
@@ -0,0 +1,818 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+#|
+
+  Floating tests and assertions for LISP-UNIT
+
+  Copyright (c) 2009-2012, Thomas M. Hermann
+
+  Permission is hereby granted, free of charge, to any person obtaining 
+  a copy of this software and associated documentation files (the "Software"), 
+  to deal in the Software without restriction, including without limitation 
+  the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+  and/or sell copies of the Software, and to permit persons to whom the 
+  Software is furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included 
+  in all copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+  ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+  OTHER DEALINGS IN THE SOFTWARE.
+
+  References
+  [NumAlgoC] Gisela Engeln-Mullges and Frank Uhlig "Numerical
+             Algorithms with C", Springer, 1996
+             ISBN: 3-540-60530-4
+
+|#
+
+(in-package :lisp-unit)
+
+;;; Symbols exported from the floating point extension
+
+;;; Global variables
+(export
+ '(*measure* *epsilon* *significant-figures*))
+
+;;; Functions
+(export
+ '(default-epsilon
+   sumsq sump norm
+   relative-error relative-error-norm
+   array-error))
+
+;;; Predicates and assertions
+(export
+ '(float-equal assert-float-equal
+   sigfig-equal assert-sigfig-equal
+   norm-equal assert-norm-equal
+   number-equal assert-number-equal
+   numerical-equal assert-numerical-equal))
+
+;;; Utilities
+(export
+ '(complex-random
+   make-2d-list
+   make-random-list
+   make-random-2d-list
+   make-random-2d-array))
+
+;;; Floating point extensions
+
+(defvar *measure* 1)
+
+(defvar *epsilon* nil
+  "Set the error epsilon if the defaults are not acceptable.")
+
+(defvar *significant-figures* 4
+  "Default to 4 significant figures.")
+
+(defgeneric default-epsilon (value)
+  (:documentation
+   "Return the default epsilon for the value."))
+
+(defgeneric relative-error (exact approximate)
+  (:documentation
+   "Return the relative-error between the 2 quantities."))
+
+(defgeneric float-equal (data1 data2 &optional epsilon)
+  (:documentation
+   "Return true if the floating point data is equal."))
+
+(defgeneric sumsq (data)
+  (:documentation
+   "Return the scaling parameter and the sum of the squares of the ~
+    data."))
+
+(defgeneric sump (data p)
+  (:documentation
+   "Return the scaling parameter and the sum of the powers of p of the ~
+    data."))
+
+(defgeneric norm (data &optional measure)
+  (:documentation
+   "Return the element-wise norm of the data."))
+
+(defgeneric relative-error-norm (exact approximate &optional measure)
+  (:documentation
+   "Return the relative error norm "))
+
+(defgeneric norm-equal (data1 data2 &optional epsilon measure)
+  (:documentation
+   "Return true if the norm of the data is equal."))
+
+(defgeneric sigfig-equal (data1 data2 &optional significant-figures)
+  (:documentation
+   "Return true if the data have equal significant figures."))
+
+(defgeneric numerical-equal (result1 result2 &key test)
+  (:documentation
+   "Return true if the results are numerically equal according to :TEST."))
+
+;;; (DEFAULT-EPSILON value) => epsilon
+(defmethod default-epsilon ((value float))
+  "Return a default epsilon value based on the floating point type."
+  (typecase value
+    (short-float  (* 2S0 short-float-epsilon))
+    (single-float (* 2F0 single-float-epsilon))
+    (double-float (* 2D0 double-float-epsilon))
+    (long-float   (* 2L0 long-float-epsilon))))
+
+(defmethod default-epsilon ((value complex))
+  "Return a default epsilon value based on the complex type."
+  (typecase value
+    ((complex short-float)  (* 2S0 short-float-epsilon))
+    ((complex single-float) (* 2F0 single-float-epsilon))
+    ((complex double-float) (* 2D0 double-float-epsilon))
+    ((complex long-float)   (* 2L0 long-float-epsilon))
+    (t 0)))
+
+(defmethod default-epsilon ((value list))
+  "Return the default epsilon based on contents of the list."
+  (loop for val in value maximize (default-epsilon val)))
+
+(defmethod default-epsilon ((value vector))
+  "Return the default epsilon based on the contents of the vector."
+  (loop for val across value maximize (default-epsilon val)))
+
+(defmethod default-epsilon ((value array))
+  "Return the default epsilon based on the contents of the array."
+  (loop for val across
+        (make-array
+         (array-total-size value)
+         :element-type (array-element-type value)
+         :displaced-to value)
+        maximize (default-epsilon val)))
+
+#|
+  (RELATIVE-ERROR x y) => float
+  [NumAlgoC] : Definition 1.3, pg. 2
+               modified with Definition 1.1, pg. 1
+ 
+  The definition of relative error in this routine is modified from
+  the Definition 1.3 in [NumAlgoC] for cases when either the exact
+  or the approximate value equals zero. According to Definition 1.3,
+  the relative error is identically equal to 1 in those cases. This
+  function returns the absolute error in those cases. This is more
+  useful for testing.
+|#
+(defun %relative-error (exact approximate)
+  "Return the relative error of the numbers."
+  (abs (if (or (zerop exact) (zerop approximate))
+	   (- exact approximate)
+	   (/ (- exact approximate) exact))))
+
+(defmethod relative-error ((exact float) (approximate float))
+  "Return the error delta between the exact and approximate floating
+point value."
+  (%relative-error exact approximate))
+
+(defmethod relative-error ((exact float) (approximate complex))
+  "Return the relative error between the float and complex number."
+  (%relative-error exact approximate))
+
+(defmethod relative-error ((exact complex) (approximate float))
+  "Return the relative error between the float and complex number."
+  (%relative-error exact approximate))
+
+(defmethod relative-error ((exact complex) (approximate complex))
+  "Return the relative error of the complex numbers."
+  (if (or (typep exact '(complex float))
+          (typep approximate '(complex float)))
+      (%relative-error exact approximate)
+      (error "Relative error is only applicable to complex values with ~
+              floating point parts.")))
+
+;;; (FLOAT-EQUAL data1 data2 epsilon) => true or false
+(defun %float-equal (data1 data2 epsilon)
+  "Return true if the relative error between the data is less than
+epsilon."
+  (or
+   (and (zerop data1) (zerop data2))
+   (< (%relative-error data1 data2) epsilon)))
+
+(defmethod float-equal ((data1 float) (data2 float)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (%float-equal data1 data2
+                (or epsilon (max (default-epsilon data1)
+                                 (default-epsilon data2)))))
+
+(defmethod float-equal ((data1 float) (data2 rational)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (%float-equal data1 (float data2 data1)
+                (or epsilon (default-epsilon data1))))
+
+(defmethod float-equal ((data1 rational) (data2 float)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (%float-equal (float data1 data2) data2
+                (or epsilon (default-epsilon data2))))
+
+(defmethod float-equal ((data1 float) (data2 complex)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (%float-equal data1 data2
+                (or epsilon (max (default-epsilon data1)
+                                 (default-epsilon data2)))))
+
+(defmethod float-equal ((data1 complex) (data2 float)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (%float-equal data1 data2
+                (or epsilon (max (default-epsilon data1)
+                                 (default-epsilon data2)))))
+
+(defmethod float-equal ((data1 complex) (data2 complex)
+                        &optional (epsilon *epsilon*))
+  "Return true if the relative error between data1 and data2 is less
+than epsilon."
+  (< (relative-error data1 data2)
+     (or epsilon (max (default-epsilon data1)
+                      (default-epsilon data2)))))
+
+(defun %seq-float-equal (seq1 seq2 epsilon)
+  "Return true if the element-wise comparison of relative error is
+less than epsilon."
+  (or
+   (and (null seq1) (null seq2))
+   (when (= (length seq1) (length seq2))
+     (every
+      (lambda (d1 d2) (float-equal d1 d2 epsilon)) seq1 seq2))))
+
+(defmethod float-equal ((data1 list) (data2 list)
+                        &optional (epsilon *epsilon*))
+  "Return true if the lists are equal in length and element-wise
+comparison of the relative error is less than epsilon."
+  (%seq-float-equal data1 data2 epsilon))
+
+(defmethod float-equal ((data1 list) (data2 vector)
+                        &optional (epsilon *epsilon*))
+  "Return true if the vector and the list are equal in length and
+element-wise comparison of the relative error is less than epsilon."
+  (%seq-float-equal data1 data2 epsilon))
+
+(defmethod float-equal ((data1 vector) (data2 list)
+                        &optional (epsilon *epsilon*))
+  "Return true if the vector and the list are equal in length and
+element-wise comparison of the relative error is less than epsilon."
+  (%seq-float-equal data1 data2 epsilon))
+
+(defmethod float-equal ((data1 vector) (data2 vector)
+                        &optional (epsilon *epsilon*))
+  "Return true if the vectors are equal in length and element-wise
+comparison of the relative error is less than epsilon."
+  (%seq-float-equal data1 data2 epsilon))
+
+(defmethod float-equal ((data1 array) (data2 array)
+                        &optional (epsilon *epsilon*))
+  "Return true if the arrays are equal in length and element-wise
+comparison of the relative error is less than epsilon."
+  (when (equal (array-dimensions data1)
+               (array-dimensions data2))
+    (%seq-float-equal
+     (make-array (array-total-size data1)
+                 :element-type (array-element-type data1)
+                 :displaced-to data1)
+     (make-array (array-total-size data2)
+                 :element-type (array-element-type data2)
+                 :displaced-to data2)
+     epsilon)))
+
+(defmacro assert-float-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'float-equal))
+
+;;; (SUMSQ data) => scale, sumsq
+(defmethod sumsq ((data list))
+  "Return the scaling parameter and the sum of the squares of the ~
+   list."
+  (let ((scale 0)
+        (sumsq 1)
+        (abs-val nil))
+    (dolist (elm data (values scale sumsq))
+      (when (plusp (setq abs-val (abs elm)))
+        (if (< scale abs-val)
+            (setq
+             sumsq (1+ (* sumsq (expt (/ scale abs-val) 2)))
+             scale abs-val)
+            (setq sumsq (+ sumsq (expt (/ elm scale) 2))))))))
+
+(defmethod sumsq ((data vector))
+  "Return the scaling parameter and the sum of the squares of the ~
+   vector."
+  (let ((scale 0)
+        (sumsq 1)
+        (abs-val nil)
+        (size (length data)))
+    (dotimes (index size (values scale sumsq))
+      (when (plusp (setq abs-val (abs (svref data index))))
+        (if (< scale abs-val)
+            (setq
+             sumsq (1+ (* sumsq (expt (/ scale abs-val) 2)))
+             scale abs-val)
+            (setq
+             sumsq
+             (+ sumsq (expt (/ (svref data index) scale) 2))))))))
+
+(defmethod sumsq ((data array))
+  "Return the scaling parameter and the sum of the squares of the ~
+   array."
+  (sumsq (make-array (array-total-size data)
+                     :element-type (array-element-type data)
+                     :displaced-to data)))
+
+;;; (SUMP data) => scale, sump
+(defmethod sump ((data list) (p real))
+  "Return the scaling parameter and the sum of the powers of p of the ~
+   data."
+  (let ((scale 0)
+        (sump 1)
+        (abs-val nil))
+    (dolist (elm data (values scale sump))
+      (when (plusp (setq abs-val (abs elm)))
+        (if (< scale abs-val)
+            (setq
+             sump (1+ (* sump (expt (/ scale abs-val) p)))
+             scale abs-val)
+            (setq sump (+ sump (expt (/ elm scale) p))))))))
+
+(defmethod sump ((data vector) (p real))
+  "Return the scaling parameter and the sum of the powers of p of the ~
+   vector."
+  (let ((scale 0)
+        (sump 1)
+        (abs-val nil)
+        (size (length data)))
+    (dotimes (index size (values scale sump))
+      (when (plusp (setq abs-val (abs (svref data index))))
+        (if (< scale abs-val)
+            (setq
+             sump (1+ (* sump (expt (/ scale abs-val) p)))
+             scale abs-val)
+            (setq
+             sump
+             (+ sump (expt (/ (svref data index) scale) p))))))))
+
+(defmethod sump ((data array) (p real))
+  "Return the scaling parameter and the sum of the powers of p of the ~
+   array."
+  (sump (make-array (array-total-size data)
+                    :element-type (array-element-type data)
+                    :displaced-to data)
+        p))
+
+;;; (NORM data) => float
+
+(defgeneric %norm (data measure)
+  (:documentation
+   "Return the norm of the data according to measure."))
+
+(defmethod %norm ((data list) (measure (eql 1)))
+  "Return the Taxicab norm of the list."
+  (loop for item in data sum (abs item)))
+
+(defmethod %norm ((data vector) (measure (eql 1)))
+  "Return the Taxicab norm of the vector."
+  (loop for item across data sum (abs item)))
+
+(defmethod %norm ((data list) (measure (eql 2)))
+  "Return the Euclidean norm of the list."
+  (multiple-value-bind (scale sumsq)
+      (sumsq (map-into (make-array (length data)) #'abs data))
+    (* scale (sqrt sumsq))))
+
+(defmethod %norm ((data vector) (measure (eql 2)))
+  "Return the Euclidean norm of the vector."
+  (multiple-value-bind (scale sumsq)
+      (sumsq (map-into (make-array (length data)) #'abs data))
+    (* scale (sqrt sumsq))))
+
+(defmethod %norm ((data list) (measure integer))
+  "Return the Euclidean norm of the list."
+  (multiple-value-bind (scale sump)
+      (sump (map-into (make-array (length data)) #'abs data)
+            measure)
+    (* scale (expt sump (/ measure)))))
+
+(defmethod %norm ((data vector) (measure integer))
+  "Return the Euclidean norm of the vector."
+  (multiple-value-bind (scale sump)
+      (sump (map-into (make-array (length data)) #'abs data)
+            measure)
+    (* scale (expt sump (/ measure)))))
+
+(defmethod %norm ((data list) (measure (eql :infinity)))
+  "Return the infinity, or maximum, norm of the list."
+  (loop for item in data maximize (abs item)))
+
+(defmethod %norm ((data vector) (measure (eql :infinity)))
+  "Return the infinity, or maximum, norm of the vector."
+  (loop for item across data maximize (abs item)))
+
+(defmethod norm ((data list) &optional (measure *measure*))
+  "Return the norm of the list according to the measure."
+  (%norm data measure))
+
+(defmethod norm ((data vector) &optional (measure *measure*))
+  "Return the norm of the vector according to the measure."
+  (%norm data measure))
+
+;;; FIXME : Is the entrywise norm of an array useful or confusing?
+(defmethod norm ((data array) &optional (measure *measure*))
+  "Return the entrywise norm of the array according to the measure."
+  (%norm
+   (make-array
+    (array-total-size data)
+    :element-type (array-element-type data)
+    :displaced-to data)
+   measure))
+
+;;; (RELATIVE-ERROR-NORM exact approximate measure) => float
+(defun %relative-error-norm (exact approximate measure)
+  "Return the relative error norm of the sequences."
+  (/ (norm (map-into (make-array (length exact))
+                     (lambda (x1 x2) (abs (- x1 x2)))
+                     exact approximate) measure)
+     (norm exact measure)))
+
+(defmethod relative-error-norm ((exact list) (approximate list)
+                                &optional (measure *measure*))
+  "Return the relative error norm of the lists."
+  (if (= (length exact) (length approximate))
+      (%relative-error-norm exact approximate measure)
+      (error "Lists are not equal in length.")))
+
+(defmethod relative-error-norm ((exact list) (approximate vector)
+                                &optional (measure *measure*))
+  "Return the relative error norm of the list and the vector."
+  (if (= (length exact) (length approximate))
+      (%relative-error-norm exact approximate measure)
+      (error "The list and vector are not equal in length.")))
+
+(defmethod relative-error-norm ((exact vector) (approximate list)
+                                &optional (measure *measure*))
+  "Return the relative error norm of the list and the vector."
+  (if (= (length exact) (length approximate))
+      (%relative-error-norm exact approximate measure)
+      (error "The list and vector are not equal in length.")))
+
+(defmethod relative-error-norm ((exact vector) (approximate vector)
+                                &optional (measure *measure*))
+  "Return the relative error norm of the vectors."
+  (if (= (length exact) (length approximate))
+      (%relative-error-norm exact approximate measure)
+      (error "Vectors are not equal in length.")))
+
+(defmethod relative-error-norm ((exact array) (approximate vector)
+                                &optional (measure *measure*))
+  "Return the relative error norm of the arrays."
+  (if (equal (array-dimensions exact)
+             (array-dimensions approximate))
+      (%relative-error-norm
+       (make-array (array-total-size exact)
+                   :element-type (array-element-type exact)
+                   :displaced-to exact)
+       (make-array (array-total-size approximate)
+                   :element-type (array-element-type approximate)
+                   :displaced-to approximate)
+       measure)
+      (error "Arrays are not equal dimensions.")))
+
+;;; (NORM-EQUAL data1 data2 epsilon measure) => boolean
+(defun %norm-equal (seq1 seq2 epsilon measure)
+  "Return true if the relative error norm is less than epsilon."
+  (or
+   (and (null seq1) (null seq2))
+   (< (%relative-error-norm seq1 seq2 measure) epsilon)))
+
+(defmethod norm-equal ((data1 list) (data2 list) &optional
+                       (epsilon *epsilon*) (measure *measure*))
+  "Return true if the lists are equal in length and the relative error
+norm is less than epsilon."
+  (%norm-equal data1 data2 epsilon measure))
+
+(defmethod norm-equal ((data1 list) (data2 vector) &optional
+                       (epsilon *epsilon*) (measure *measure*))
+  "Return true if the vector and the list are equal in length and the
+relative error norm is less than epsilon."
+  (%norm-equal data1 data2 epsilon measure))
+
+(defmethod norm-equal ((data1 vector) (data2 list) &optional
+                       (epsilon *epsilon*) (measure *measure*))
+  "Return true if the vector and the list are equal in length and the
+relative error norm is less than epsilon."
+  (%norm-equal data1 data2 epsilon measure))
+
+(defmethod norm-equal ((data1 vector) (data2 vector) &optional
+                       (epsilon *epsilon*) (measure *measure*))
+  "Return true if the vectors are equal in length and the relative
+error norm is less than epsilon."
+  (%norm-equal data1 data2 epsilon measure))
+
+(defmethod norm-equal ((data1 array) (data2 array) &optional
+                       (epsilon *epsilon*) (measure *measure*))
+  "Return true if the arrays are equal in length and the relative
+error norm is less than epsilon."
+  (when (equal (array-dimensions data1)
+               (array-dimensions data2))
+    (%norm-equal
+     (make-array (array-total-size data1)
+                 :element-type (array-element-type data1)
+                 :displaced-to data1)
+     (make-array (array-total-size data2)
+                 :element-type (array-element-type data2)
+                 :displaced-to data2)
+     epsilon measure)))
+
+(defmacro assert-norm-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'norm-equal))
+
+;;; (NORMALIZE-FLOAT significand &optional exponent) => significand,exponent
+;;; [NumAlgoC] : Definition 1.7, pg. 4
+;;;
+;;; To avoid using 0.1, first 1.0 <= significand < 10. On the final
+;;; return, scale 0.1 <= significand < 1.
+(defun %normalize-float (significand &optional (exponent 0))
+  "Return the normalized floating point number and exponent."
+  ;;; FIXME : Use the LOOP.
+  (cond
+    ((zerop significand)
+     (values significand 0))
+    ((>= (abs significand) 10)
+     (%normalize-float (/ significand 10.0) (1+ exponent)))
+    ((< (abs significand) 1)
+     (%normalize-float (* significand 10.0) (1- exponent)))
+    (t (values (/ significand 10.0) (1+ exponent)))))
+
+;;; (SIGFIG-EQUAL float1 float2 significant-figures) => true or false
+(defun %sigfig-equal (float1 float2 significant-figures)
+  "Return true if the floating point numbers have equal significant
+figures."
+  (if (or (zerop float1) (zerop float2))
+      (< (abs (+ float1 float2)) (* 5D-1 (expt 1D1 (- significant-figures))))
+      (multiple-value-bind (sig1 exp1) (%normalize-float float1)
+        (multiple-value-bind (sig2 exp2) (%normalize-float float2)
+          (= (round (* sig1 (expt 1D1 significant-figures)))
+             (round (* sig2 (expt 1D1 (- significant-figures (- exp1 exp2))))))))))
+
+(defmethod sigfig-equal ((data1 float) (data2 float) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the floating point numbers have equal significant
+figures."
+  (%sigfig-equal data1 data2 significant-figures))
+
+(defun %seq-sigfig-equal (seq1 seq2 significant-figures)
+  "Return true if the element-wise comparison is equal to the
+specified significant figures."
+  (or
+   (and (null seq1) (null seq2))
+   (when (= (length seq1) (length seq2))
+     (every
+      (lambda (d1 d2) (sigfig-equal d1 d2 significant-figures))
+      seq1 seq2))))
+
+(defmethod sigfig-equal ((data1 list) (data2 list) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the lists are equal in length and the element-wise
+comparison is equal to significant figures."
+  (%seq-sigfig-equal data1 data2 significant-figures))
+
+(defmethod sigfig-equal ((data1 vector) (data2 list) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the vector and the list are equal in length and the
+element-wise comparison is equal to significant figures."
+  (%seq-sigfig-equal data1 data2 significant-figures))
+
+(defmethod sigfig-equal ((data1 list) (data2 vector) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the list and the vector are equal in length and the
+element-wise comparison is equal to significant figures."
+  (%seq-sigfig-equal data1 data2 significant-figures))
+
+(defmethod sigfig-equal ((data1 vector) (data2 vector) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the vectors are equal in length and the element-wise
+comparison is equal to significant figures."
+  (%seq-sigfig-equal data1 data2 significant-figures))
+
+(defmethod sigfig-equal ((data1 array) (data2 array) &optional
+                         (significant-figures *significant-figures*))
+  "Return true if the arrays are equal in length and the element-wise
+comparison is equal to significant figures."
+  (when (equal (array-dimensions data1)
+               (array-dimensions data2))
+    (%seq-sigfig-equal
+     (make-array (array-total-size data1)
+                 :element-type (array-element-type data1)
+                 :displaced-to data1)
+     (make-array (array-total-size data2)
+                 :element-type (array-element-type data2)
+                 :displaced-to data2)
+     significant-figures)))
+
+(defmacro assert-sigfig-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'sigfig-equal))
+
+;;; (NUMBER-EQUAL number1 number2) => true or false
+(defun number-equal (number1 number2 &optional (epsilon *epsilon*) type-eq-p)
+  "Return true if the numbers are equal within some epsilon,
+optionally requiring the types to be identical."
+  (and
+   (or (not type-eq-p) (eq (type-of number1) (type-of number2)))
+   (float-equal (coerce number1 '(complex double-float))
+                (coerce number2 '(complex double-float))
+                epsilon)))
+
+(defmacro assert-number-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'number-equal))
+
+;;; (NUMERICAL-EQUAL result1 result2) => true or false
+;;;
+;;; This is a universal wrapper created by Liam Healy. It is
+;;; implemented to support testing in GSLL. The interface is expanded,
+;;; but backwards compatible with previous versions.
+;;;
+(defmethod numerical-equal ((result1 number) (result2 number)
+			    &key (test #'number-equal))
+  "Return true if the the numbers are equal according to :TEST."
+  (funcall test result1 result2))
+
+(defun %sequence-equal (seq1 seq2 test)
+  "Return true if the sequences are equal in length and each element
+is equal according to :TEST."
+  (when (= (length seq1) (length seq2))
+    (every (lambda (s1 s2) (numerical-equal s1 s2 :test test))
+	   seq1 seq2)))
+
+(defmethod numerical-equal ((result1 list) (result2 list)
+			    &key (test #'number-equal))
+  "Return true if the lists are equal in length and each element is
+equal according to :TEST."
+  (%sequence-equal result1 result2 test))
+
+(defmethod numerical-equal ((result1 vector) (result2 vector)
+			    &key (test #'number-equal))
+  "Return true if the vectors are equal in length and each element is
+equal according to :TEST."
+  (%sequence-equal result1 result2 test))
+
+(defmethod numerical-equal ((result1 list) (result2 vector)
+			    &key (test #'number-equal))
+  "Return true if every element of the list is equal to the
+corresponding element of the vector."
+  (%sequence-equal result1 result2 test))
+
+(defmethod numerical-equal ((result1 vector) (result2 list)
+			    &key (test #'number-equal))
+  "Return true if every element of the list is equla to the
+corresponding element of the vector."
+  (%sequence-equal result1 result2 test))
+
+(defmethod numerical-equal ((result1 array) (result2 array)
+			    &key (test #'number-equal))
+  "Return true if the arrays are equal in dimension and each element
+is equal according to :TEST."
+  (when (equal (array-dimensions result1) (array-dimensions result2))
+    (every test
+	   (make-array (array-total-size result1)
+		       :element-type (array-element-type result1)
+		       :displaced-to result1)
+	   (make-array (array-total-size result2)
+		       :element-type (array-element-type result2)
+		       :displaced-to result2))))
+
+(defmacro assert-numerical-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'numerical-equal))
+
+;;; FIXME : Audit and move the diagnostic functions to a separate
+;;; file.
+
+;;; Diagnostic functions
+;;; Failing a unit test is only half the problem.
+
+;;; Sequence errors and the indices.
+(defun %sequence-error (sequence1 sequence2 test error-function)
+  "Return a sequence of the indice and error between the sequences."
+  (let ((n1 nil) (n2 nil)
+	(errseq '()))
+    (dotimes (index (length sequence1) errseq)
+      (setf n1 (elt sequence1 index)
+	    n2 (elt sequence2 index))
+      (unless (funcall test n1 n2)
+	(push (list (1- index) n1 n2 (funcall error-function n1 n2))
+	      errseq)))))
+
+(defun sequence-error (sequence1 sequence2 &key
+		       (test #'number-equal)
+		       (error-function #'relative-error))
+  "Return a sequence of the indice and error between the sequence elements."
+  (cond
+    ((not (typep sequence1 'sequence))
+     (error "SEQUENCE1 is not a valid sequence."))
+    ((not (typep sequence2 'sequence))
+     (error "SEQUENCE2 is not a valid sequence."))
+    ((not (= (length sequence1) (length sequence2)))
+     (error "Lengths not equal. SEQUENCE1(~D) /= SEQUENCE2(~D)."
+	    (length sequence1) (length sequence2)))
+    (t (%sequence-error sequence1 sequence2 test error-function))))
+
+;;; Array errors and the indices.
+(defun %array-indices (row-major-index dimensions)
+  "Recursively calculate the indices from the row major index."
+  (let ((remaining (rest dimensions)))
+    (if remaining
+	(multiple-value-bind (index remainder)
+	    (floor row-major-index (reduce #'* remaining))
+	  (cons index (%array-indices remainder remaining)))
+	(cons row-major-index nil))))
+
+(defun %array-error (array1 array2 test errfun)
+  "Return a list of the indices, values and error of the elements that
+are not equal."
+  (let ((dimensions (array-dimensions array1))
+	(n1 nil) (n2 nil)
+	(indices '())
+	(errseq '()))
+    (dotimes (index (array-total-size array1) errseq)
+      (setf indices (%array-indices index dimensions)
+	    n1 (apply #'aref array1 indices)
+	    n2 (apply #'aref array2 indices))
+      (unless (funcall test n1 n2)
+	(push (list indices n1 n2 (funcall errfun n1 n2))
+	      errseq)))))
+
+(defun array-error (array1 array2 &key
+		    (test #'number-equal)
+		    (error-function #'relative-error))
+  "Return a list of the indices and error between the array elements."
+  (cond
+    ((not (arrayp array1))
+     (error "ARRAY1 is not an array."))
+    ((not (arrayp array2))
+     (error "ARRAY2 is not an array."))
+    ((not (equal (array-dimensions array1) (array-dimensions array2)))
+     (error "Arrays are not equal dimensions."))
+    (t (%array-error array1 array2 test error-function))))
+
+;;; Floating point data functions
+(defun make-2d-list (rows columns &key (initial-element 0))
+  "Return a nested list with INITIAL-ELEMENT."
+  (mapcar (lambda (x) (make-list columns :initial-element x))
+          (make-list rows :initial-element initial-element)))
+
+(defun %complex-float-random (limit &optional (state *random-state*))
+  "Return a random complex float number."
+  (complex
+   (random (realpart limit) state)
+   (random (imagpart limit) state)))
+
+(defun %complex-rational-random (limit &optional (state *random-state*))
+  "Return a random complex rational number."
+  (let ((imaglimit (imagpart limit)))
+    (if (< 1 imaglimit)
+        (complex
+         (random (realpart limit) state)
+         ;; Ensure that the imaginary part is not zero.
+         (do ((im (random imaglimit state)
+                  (random imaglimit state)))
+             ((< 0 im) im)))
+        (error "Imaginary part must be greater than 1."))))
+
+(defun complex-random (limit &optional (state *random-state*))
+  "Return a random complex number. "
+  (check-type limit complex)
+  (if (typep limit '(complex rational))
+      (%complex-rational-random limit state)
+      (%complex-float-random limit state)))
+
+(defun make-random-list (size &optional (limit 1.0))
+  "Return a list of random numbers."
+  (mapcar (if (complexp limit) #'complex-random #'random)
+	  (make-list size :initial-element limit)))
+
+(defun make-random-2d-list (rows columns &optional (limit 1.0))
+  "Return a nested list of random numbers."
+  (mapcar (lambda (x) (make-random-list columns x))
+          (make-list rows :initial-element limit)))
+
+(defun make-random-2d-array (rows columns &optional (limit 1.0))
+  "Return a 2D array of random numbers."
+  (let ((new-array (make-array (list rows columns)
+			       :element-type (type-of limit)))
+	(random-func (if (complexp limit)
+			 #'complex-random
+			 #'random)))
+    (dotimes (i0 rows new-array)
+      (dotimes (i1 columns)
+	(setf (aref new-array i0 i1)
+	      (funcall random-func limit))))))
diff --git a/src/contrib/lisp-unit/extensions/rational.lisp b/src/contrib/lisp-unit/extensions/rational.lisp
new file mode 100644
index 000000000..43403a6ba
--- /dev/null
+++ b/src/contrib/lisp-unit/extensions/rational.lisp
@@ -0,0 +1,96 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+#|
+
+  Rational tests and assertions for LISP-UNIT
+
+  Copyright (c) 2009-2012, Thomas M. Hermann
+
+  Permission is hereby granted, free of charge, to any person obtaining 
+  a copy of this software and associated documentation files (the "Software"), 
+  to deal in the Software without restriction, including without limitation 
+  the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+  and/or sell copies of the Software, and to permit persons to whom the 
+  Software is furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included 
+  in all copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+  ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+  OTHER DEALINGS IN THE SOFTWARE.
+
+|#
+
+(in-package :lisp-unit)
+
+;;; Symbols exported from the rational extension
+
+(export '(rational-equal assert-rational-equal))
+
+;;; Rational predicates and assertions
+
+(defgeneric rational-equal (data1 data2)
+  (:documentation
+   "Return true if the rational data is equal."))
+
+;;; (RATIONAL-EQUAL data1 data2) => boolean
+(defmethod rational-equal ((data1 rational) (data2 rational))
+  "Return true if the rational numbers are equal."
+  (= data1 data2))
+
+(defmethod rational-equal ((data1 complex) (data2 complex))
+  "Return true if the complex parts are rational and equal."
+  (if (and (typep data1 '(complex rational))
+           (typep data2 '(complex rational)))
+      (= data1 data2)
+      (error "Rational equality is not applicable to complex values ~
+              with floating point parts.")))
+
+(defun %seq-rational-equal (seq1 seq2)
+  "Return true if the sequences are equal length and at each position
+the corresponding elements are equal."
+  (or
+   (and (null seq1) (null seq2))
+   (and
+    (= (length seq1) (length seq2))
+    (every (lambda (d1 d2) (rational-equal d1 d2)) seq1 seq2))))
+
+(defmethod rational-equal ((data1 list) (data2 list))
+  "Return true if the lists are equal in length and element-wise
+equal."
+  (%seq-rational-equal data1 data2))
+
+(defmethod rational-equal ((data1 list) (data2 vector))
+  "Return true if the vector and the list are equal in length and
+element-wise equal."
+  (%seq-rational-equal data1 data2))
+
+(defmethod rational-equal ((data1 vector) (data2 list))
+  "Return true if the vector and the list are equal in length and
+element-wise equal."
+  (%seq-rational-equal data1 data2))
+
+(defmethod rational-equal ((data1 vector) (data2 vector))
+  "Return true if the vectors are equal in length and element-wise
+equal."
+  (%seq-rational-equal data1 data2))
+
+(defmethod rational-equal ((data1 array) (data2 array))
+  "Return true if the arrays are equal in dimension and element-wise
+equal."
+  (when (equal (array-dimensions data1)
+               (array-dimensions data2))
+    (%seq-rational-equal
+     (make-array (array-total-size data1)
+                 :element-type (array-element-type data1)
+                 :displaced-to data1)
+     (make-array (array-total-size data2)
+                 :element-type (array-element-type data2)
+                 :displaced-to data2))))
+
+(defmacro assert-rational-equal (expected form &rest extras)
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'rational-equal))
diff --git a/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp b/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp
new file mode 100644
index 000000000..09653f86a
--- /dev/null
+++ b/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp
@@ -0,0 +1,86 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+#|
+
+  Test Anything Protocol (TAP) support for LISP-UNIT
+
+  Copyright (c) 2009-2013, Ryan Davis <ryan@acceleration.net>
+
+  Permission is hereby granted, free of charge, to any person obtaining 
+  a copy of this software and associated documentation files (the "Software"), 
+  to deal in the Software without restriction, including without limitation 
+  the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+  and/or sell copies of the Software, and to permit persons to whom the 
+  Software is furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included 
+  in all copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+  ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+  OTHER DEALINGS IN THE SOFTWARE.
+
+  References
+  [TAP]: http://testanything.org/wiki/index.php/Main_Page
+  
+|#
+
+(in-package :lisp-unit)
+
+;;; Symbols exported from the TAP extension
+
+(export '(write-tap write-tap-to-file))
+
+(defun run-time-s (test-result)
+  "calculate the run-time of the test in seconds"
+  (/ (run-time test-result)
+     internal-time-units-per-second))
+
+(defun %write-tap-test-result (name test-result i stream)
+  "Output a single test, taking care to ensure the indentation level
+is the same before and after invocation."
+  (pprint-logical-block (stream nil)
+    (format stream
+            "~:[ok~;not ok~] ~d ~s (~,2f s)"
+            (or (fail test-result)
+                (exerr test-result))
+            i name
+            (run-time-s test-result))
+    (when (or (fail test-result)
+              (exerr test-result))
+      ;; indent only takes affect after a newline, so force one
+      (format stream "~2I~:@_---~@:_")
+      (when (exerr test-result)
+        (format stream "message: |~4I~_~s~2I~@:_" (exerr test-result)))
+      (when (fail test-result)
+        (format stream "message: ~d failed assertions~@:_"
+                (length (fail test-result))))
+      (format stream "..."))
+    ;; always reset to zero and force a newline
+    (format stream "~0I~@:_")))
+
+(defun write-tap (test-results &optional (stream *standard-output*))
+  "Write the test results to `stream` in TAP format. Returns the test
+results."
+  (check-type test-results test-results-db)
+  (let ((i 0)
+        (*print-pretty* T))
+    (format stream "TAP version 13~%1..~d~%"
+            (hash-table-count (database test-results)))
+    (maphash
+     #'(lambda (name test-result)
+         (%write-tap-test-result name test-result (incf i) stream))
+     (database test-results)))
+  test-results)
+
+(defun write-tap-to-file (test-results path)
+  "write the test results to `path` in TAP format, overwriting `path`.
+Returns pathname to the output file"
+  (check-type path (or string pathname))
+  (ensure-directories-exist path)
+  (with-open-file (s path :direction :output :if-exists :supersede)
+    (write-tap test-results s))
+  (truename path))
diff --git a/src/contrib/lisp-unit/internal-test/example-tests.lisp b/src/contrib/lisp-unit/internal-test/example-tests.lisp
new file mode 100644
index 000000000..6312be077
--- /dev/null
+++ b/src/contrib/lisp-unit/internal-test/example-tests.lisp
@@ -0,0 +1,153 @@
+#|
+
+ LISP-UNIT Example Tests
+
+ Copyright (c) 2010-2012, Thomas M. Hermann
+ All rights reserved.
+
+ Redistribution and  use  in  source  and  binary  forms, with or without
+ modification, are permitted  provided  that the following conditions are
+ met:
+
+   o  Redistributions of  source  code  must  retain  the above copyright
+      notice, this list of conditions and the following disclaimer.
+   o  Redistributions in binary  form  must reproduce the above copyright
+      notice, this list of  conditions  and  the  following disclaimer in
+      the  documentation  and/or   other   materials  provided  with  the
+      distribution.
+   o  The names of the contributors may not be used to endorse or promote
+      products derived from this software without  specific prior written
+      permission.
+
+ THIS SOFTWARE IS  PROVIDED  BY  THE  COPYRIGHT  HOLDERS AND CONTRIBUTORS
+ "AS IS"  AND  ANY  EXPRESS  OR  IMPLIED  WARRANTIES, INCLUDING,  BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES  OF MERCHANTABILITY AND FITNESS FOR A
+ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ EXEMPLARY, OR  CONSEQUENTIAL  DAMAGES  (INCLUDING,  BUT  NOT LIMITED TO,
+ PROCUREMENT OF  SUBSTITUTE  GOODS  OR  SERVICES;  LOSS  OF USE, DATA, OR
+ PROFITS; OR BUSINESS INTERRUPTION)  HOWEVER  CAUSED AND ON ANY THEORY OF
+ LIABILITY, WHETHER  IN  CONTRACT,  STRICT  LIABILITY, OR TORT (INCLUDING
+ NEGLIGENCE OR  OTHERWISE)  ARISING  IN  ANY  WAY  OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+|#
+
+(in-package :lisp-unit)
+
+(defun my-max (x y)
+  "Deliberately wrong"
+  (declare (ignore y))
+  x)
+
+(define-test test-my-max
+  ;; Wrong
+  (assert-equal 5 (my-max 2 5))
+  (assert-equal 5 (my-max 5 2))
+  (assert-equal 10 (my-max 10 10))
+  (assert-equal 0 (my-max -5 0))
+  ;; Error
+  (assert-equal 5 (my-max-err 2 5)))
+
+(defun my-sqrt (n)
+  "Not really."
+  (/ n 2))
+
+(define-test my-sqrt
+  (dotimes (i 5)
+    (assert-equal i (my-sqrt (* i i)) i)))
+
+;;; Macro
+
+(defmacro my-macro (arg1 arg2)
+  (let ((g1 (gensym))
+        (g2 (gensym)))
+    `(let ((,g1 ,arg1)
+           (,g2 ,arg2))
+       "Start"
+       (+ ,g1 ,g2 3))))
+
+(define-test test-macro
+  (assert-expands
+   (let ((#:G1 A) (#:G2 B)) "Start" (+ #:G1 #:G2 3))
+   (my-macro a b)))
+
+;;; Tags
+
+(defun add-integer (integer1 integer2)
+  "Add 2 integer numbers"
+  (check-type integer1 integer)
+  (check-type integer2 integer)
+  (+ integer1 integer2))
+
+(defun subtract-integer (integer1 integer2)
+  "Subtract 2 integer numbers"
+  (check-type integer1 integer)
+  (check-type integer2 integer)
+  (- integer1 integer2))
+
+(define-test add-integer
+  "Test add-integer for values and errors."
+  (:tag :add :integer)
+  (assert-eql 3 (add-integer 1 2))
+  (assert-error 'type-error (add-integer 1.0 2))
+  (assert-error 'type-error (add-integer 1 2.0)))
+
+(define-test subtract-integer
+  "Test subtract-integer for values and errors."
+  (:tag :subtract :integer)
+  (assert-eql 1 (subtract-integer 3 2))
+  (assert-error 'type-error (subtract-integer 3.0 2))
+  (assert-error 'type-error (subtract-integer 2 3.0)))
+
+(defun add-float (float1 float2)
+  "Add 2 floating point numbers"
+  (check-type float1 float)
+  (check-type float2 float)
+  (+ float1 float2))
+
+(defun subtract-float (float1 float2)
+  "Subtract 2 floating point numbers"
+  (check-type float1 float)
+  (check-type float2 float)
+  (- float1 float2))
+
+(define-test add-float
+  "Test add-float for values and errors."
+  (:tag :add :float)
+  (assert-eql 3.0 (add-float 1.0 2.0))
+  (assert-error 'type-error (add-float 1.0 2))
+  (assert-error 'type-error (add-float 1 2.0)))
+
+(define-test subtract-float
+  "Test subtract-float for values and errors."
+  (:tag :subtract :float)
+  (assert-eql 1.0 (subtract-float 3.0 2.0))
+  (assert-error 'type-error (subtract-float 3.0 2))
+  (assert-error 'type-error (subtract-float 2 3.0)))
+
+(defun add-complex (complex1 complex2)
+  "Add 2 complex numbers"
+  (check-type complex1 complex)
+  (check-type complex2 complex)
+  (+ complex1 complex2))
+
+(defun subtract-complex (complex1 complex2)
+  "Subtract 2 complex numbers"
+  (check-type complex1 complex)
+  (check-type complex2 complex)
+  (- complex1 complex2))
+
+(define-test add-complex
+  "Test add-complex for values and errors."
+  (:tag :add :complex)
+  (assert-eql #C(3 5) (add-complex #C(1 2) #C(2 3)))
+  (assert-error 'type-error (add-integer #C(1 2) 3))
+  (assert-error 'type-error (add-integer 1 #C(2 3))))
+
+(define-test subtract-complex
+  "Test subtract-complex for values and errors."
+  (:tag :subtract :complex)
+  (assert-eql #C(1 2) (subtract-complex #C(3 5) #C(2 3)))
+  (assert-error 'type-error (subtract-integer #C(3 5) 2))
+  (assert-error 'type-error (subtract-integer 2 #C(2 3))))
diff --git a/src/contrib/lisp-unit/internal-test/floating-point.lisp b/src/contrib/lisp-unit/internal-test/floating-point.lisp
new file mode 100644
index 000000000..2c89e5842
--- /dev/null
+++ b/src/contrib/lisp-unit/internal-test/floating-point.lisp
@@ -0,0 +1,115 @@
+#|
+
+ LISP-UNIT Floating Point Tests
+
+ Copyright (c) 2010-2012, Thomas M. Hermann
+ All rights reserved.
+
+ Redistribution and  use  in  source  and  binary  forms, with or without
+ modification, are permitted  provided  that the following conditions are
+ met:
+
+   o  Redistributions of  source  code  must  retain  the above copyright
+      notice, this list of conditions and the following disclaimer.
+   o  Redistributions in binary  form  must reproduce the above copyright
+      notice, this list of  conditions  and  the  following disclaimer in
+      the  documentation  and/or   other   materials  provided  with  the
+      distribution.
+   o  The names of the contributors may not be used to endorse or promote
+      products derived from this software without  specific prior written
+      permission.
+
+ THIS SOFTWARE IS  PROVIDED  BY  THE  COPYRIGHT  HOLDERS AND CONTRIBUTORS
+ "AS IS"  AND  ANY  EXPRESS  OR  IMPLIED  WARRANTIES, INCLUDING,  BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES  OF MERCHANTABILITY AND FITNESS FOR A
+ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ EXEMPLARY, OR  CONSEQUENTIAL  DAMAGES  (INCLUDING,  BUT  NOT LIMITED TO,
+ PROCUREMENT OF  SUBSTITUTE  GOODS  OR  SERVICES;  LOSS  OF USE, DATA, OR
+ PROFITS; OR BUSINESS INTERRUPTION)  HOWEVER  CAUSED AND ON ANY THEORY OF
+ LIABILITY, WHETHER  IN  CONTRACT,  STRICT  LIABILITY, OR TORT (INCLUDING
+ NEGLIGENCE OR  OTHERWISE)  ARISING  IN  ANY  WAY  OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+|#
+
+(in-package :lisp-unit)
+
+;;; List norms
+
+(define-test %norm-list
+  "Internal test of %norm on lists."
+  (:tag :norm)
+  ;; Taxicab norm
+  (assert-rational-equal
+   36 (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1))
+  (assert-float-equal
+   19.535658
+   (%norm
+    '(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+      #C(-2 3) #C(-3 1) #C(-1 0))
+    1))
+  ;; Euclidean norm
+  (assert-float-equal
+   12.083046
+   (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2))
+  (assert-float-equal
+   8.0
+   (%norm
+    '(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+      #C(-2 3) #C(-3 1) #C(-1 0)) 2))
+  ;; P-norm
+  (let ((data '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5))
+        (zdata '(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+                 #C(-2 3) #C(-3 1) #C(-1 0))))
+    (assert-float-equal 8.732892 (%norm data 3))
+    (assert-float-equal 6.064035 (%norm zdata 3)))
+  ;; Infinity norm
+  (assert-rational-equal
+   6 (%norm
+      '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5)
+      :infinity))
+  (assert-float-equal
+   4.0 (%norm
+        '(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+          #C(-2 3) #C(-3 1) #C(-1 0))
+        :infinity)))
+
+;;; Vector norms
+
+(define-test %norm-vector
+  "Internal test of %norm on vectors"
+  (:tag :norm)
+  ;; Taxicab norm
+  (assert-rational-equal
+   36 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1))
+  (assert-float-equal
+   19.535658
+   (%norm
+    #(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+      #C(-2 3) #C(-3 1) #C(-1 0))
+    1))
+  ;; Euclidean norm
+  (assert-float-equal
+   12.083046
+   (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2))
+  (assert-float-equal
+   8.0
+   (%norm
+    #(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+      #C(-2 3) #C(-3 1) #C(-1 0))
+    2))
+  ;; P-norm
+  (let ((data #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5))
+        (zdata #(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+                 #C(-2 3) #C(-3 1) #C(-1 0))))
+    (assert-float-equal 8.732892 (%norm data 3))
+    (assert-float-equal 6.064035 (%norm zdata 3)))
+  ;; Infinity norm
+  (assert-rational-equal
+   6 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) :infinity))
+  (assert-float-equal
+   4.0 (%norm
+        #(#C(1 0) #C(3 1) #C(2 3) #C(0 4)
+          #C(-2 3) #C(-3 1) #C(-1 0))
+        :infinity)))
diff --git a/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp b/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp
new file mode 100644
index 000000000..818d40117
--- /dev/null
+++ b/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp
@@ -0,0 +1,170 @@
+#|
+
+ LISP-UNIT Internal Tests
+
+ Copyright (c) 2010-2012, Thomas M. Hermann
+ All rights reserved.
+
+ Redistribution and  use  in  source  and  binary  forms, with or without
+ modification, are permitted  provided  that the following conditions are
+ met:
+
+   o  Redistributions of  source  code  must  retain  the above copyright
+      notice, this list of conditions and the following disclaimer.
+   o  Redistributions in binary  form  must reproduce the above copyright
+      notice, this list of  conditions  and  the  following disclaimer in
+      the  documentation  and/or   other   materials  provided  with  the
+      distribution.
+   o  The names of the contributors may not be used to endorse or promote
+      products derived from this software without  specific prior written
+      permission.
+
+ THIS SOFTWARE IS  PROVIDED  BY  THE  COPYRIGHT  HOLDERS AND CONTRIBUTORS
+ "AS IS"  AND  ANY  EXPRESS  OR  IMPLIED  WARRANTIES, INCLUDING,  BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES  OF MERCHANTABILITY AND FITNESS FOR A
+ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ EXEMPLARY, OR  CONSEQUENTIAL  DAMAGES  (INCLUDING,  BUT  NOT LIMITED TO,
+ PROCUREMENT OF  SUBSTITUTE  GOODS  OR  SERVICES;  LOSS  OF USE, DATA, OR
+ PROFITS; OR BUSINESS INTERRUPTION)  HOWEVER  CAUSED AND ON ANY THEORY OF
+ LIABILITY, WHETHER  IN  CONTRACT,  STRICT  LIABILITY, OR TORT (INCLUDING
+ NEGLIGENCE OR  OTHERWISE)  ARISING  IN  ANY  WAY  OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+|#
+
+(in-package :lisp-unit)
+
+;;; Internal utility functions
+
+(defun %expansion-equal (form1 form2)
+  "Descend into the forms checking for equality."
+  (let ((item1 (first form1))
+        (item2 (first form2)))
+    (cond
+     ((and (null item1) (null item2)))
+     ((and (listp item1) (listp item2))
+      (and (%expansion-equal item1 item2)
+           (%expansion-equal (rest form1) (rest form2))))
+     ((and (symbolp item1) (symbolp item2))
+      (and (string= (symbol-name item1) (symbol-name item2))
+           (%expansion-equal (rest form1) (rest form2))))
+     (t nil))))
+
+(defun expansion-equal (macro-form expansion)
+  "MACROEXPAND-1 the macro-form and compare with the expansion."
+  (let ((*gensym-counter* 1))
+    (%expansion-equal (macroexpand-1 macro-form) expansion)))
+
+(defun test-macro-expansions (expansions)
+  "Test each fundamental assertion and report the results."
+  (loop for (assertion macro-form expansion) in expansions collect
+        (list assertion (expansion-equal macro-form expansion))))
+
+;;; Expansions
+
+(defvar *expand-assert-expansions*
+  '(("EXPAND-ASSERT-BASIC"
+     (expand-assert
+      :equal form form expected (extra1 extra2) :test #'eq)
+     (INTERNAL-ASSERT :EQUAL
+                      (QUOTE FORM)
+                      (LAMBDA NIL FORM)
+                      (LAMBDA NIL EXPECTED)
+                      (EXPAND-EXTRAS (EXTRA1 EXTRA2))
+                      (FUNCTION EQ)))
+    ("EXPAND-ASSERT-ERROR"
+     (expand-assert
+      :error form (expand-error-form form) condition (extra1 extra2))
+     (INTERNAL-ASSERT :ERROR
+                      (QUOTE FORM)
+                      (LAMBDA NIL (HANDLER-CASE FORM (CONDITION (ERROR) ERROR)))
+                      (LAMBDA NIL (QUOTE CONDITION))
+                      (EXPAND-EXTRAS (EXTRA1 EXTRA2))
+                      (FUNCTION EQL)))
+    ("EXPAND-ASSERT-MACRO"
+     (expand-assert
+      :macro form
+      (expand-macro-form form nil)
+      expansion (extra1 extra2))
+     (INTERNAL-ASSERT :MACRO
+                      (QUOTE FORM)
+                      (LAMBDA NIL (MACROEXPAND-1 (QUOTE FORM) NIL))
+                      (LAMBDA NIL EXPANSION)
+                      (EXPAND-EXTRAS (EXTRA1 EXTRA2))
+                      (FUNCTION EQL)))
+    ("EXPAND-ASSERTS-PRINT"
+     (expand-assert
+      :output form (expand-output-form form) output (extra1 extra2))
+     (INTERNAL-ASSERT :OUTPUT
+                      (QUOTE FORM)
+                      (LAMBDA NIL
+                        (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM))
+                               (*STANDARD-OUTPUT* (MAKE-BROADCAST-STREAM
+                                                   *STANDARD-OUTPUT* #:G1)))
+                          FORM
+                          (GET-OUTPUT-STREAM-STRING #:G1)))
+                      (LAMBDA NIL OUTPUT)
+                      (EXPAND-EXTRAS (EXTRA1 EXTRA2))
+                      (FUNCTION EQL))))
+  "The correct expansions for the expand-assert macro.")
+
+(defvar *expansion-macros*
+  '(("EXPAND-ERROR-FORM"
+     (expand-error-form form)
+     (HANDLER-CASE FORM (CONDITION (ERROR) ERROR)))
+    ("EXPAND-OUTPUT-FORM"
+     (expand-output-form form)
+     (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM))
+            (*STANDARD-OUTPUT*
+             (MAKE-BROADCAST-STREAM *STANDARD-OUTPUT* #:G1)))
+       FORM
+       (GET-OUTPUT-STREAM-STRING #:G1)))
+    ("EXPAND-MACRO-FORM"
+     (expand-macro-form form env)
+     (MACROEXPAND-1 'FORM ENV))
+    ("EXPAND-EXTRAS"
+     (expand-extras (extra1 extra2))
+     (LAMBDA NIL (LIST (QUOTE EXTRA1) EXTRA1 (QUOTE EXTRA2) EXTRA2))))
+  "The correct expansions for macros that expand forms.")
+
+(defvar *fundamental-assertion-expansions*
+  '(("ASSERT-EQ"
+     (assert-eq expected form extra1 extra2)
+     (EXPAND-ASSERT
+      :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQ)))
+    ("ASSERT-EQL"
+     (assert-eql expected form extra1 extra2)
+     (EXPAND-ASSERT
+      :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQL)))
+    ("ASSERT-EQUAL"
+     (assert-equal expected form extra1 extra2)
+     (EXPAND-ASSERT
+      :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUAL)))
+    ("ASSERT-EQUALP"
+     (assert-equalp expected form extra1 extra2)
+     (EXPAND-ASSERT
+      :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUALP)))
+    ("ASSERT-ERROR"
+     (assert-error 'condition form extra1 extra2)
+     (EXPAND-ASSERT
+      :ERROR FORM (EXPAND-ERROR-FORM FORM) 'CONDITION (EXTRA1 EXTRA2)))
+    ("ASSERT-EXPANDS"
+     (assert-expands expansion form extra1 extra2)
+     (EXPAND-ASSERT
+      :MACRO FORM (EXPAND-MACRO-FORM FORM NIL) EXPANSION (EXTRA1 EXTRA2)))
+    ("ASSERT-FALSE"
+     (assert-false form extra1 extra2)
+     (EXPAND-ASSERT :RESULT FORM FORM NIL (EXTRA1 EXTRA2)))
+    ("ASSERT-EQUALITY"
+     (assert-equality test expected form extra1 extra2)
+     (EXPAND-ASSERT
+      :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST TEST))
+    ("ASSERT-PRINTS"
+     (assert-prints output form extra1 extra2)
+     (EXPAND-ASSERT
+      :OUTPUT FORM (expand-output-form form) OUTPUT (EXTRA1 EXTRA2)))
+    ("ASSERT-TRUE"
+     (assert-true form extra1 extra2)
+     (EXPAND-ASSERT :RESULT FORM FORM T (EXTRA1 EXTRA2))))
+  "The correct expansions for the fundamental assertions.")
diff --git a/src/contrib/lisp-unit/lisp-unit.asd b/src/contrib/lisp-unit/lisp-unit.asd
new file mode 100644
index 000000000..2409eb631
--- /dev/null
+++ b/src/contrib/lisp-unit/lisp-unit.asd
@@ -0,0 +1,38 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+#|
+  Copyright (c) 2009-2012, Thomas M. Hermann
+
+  Permission is hereby granted, free of charge, to any person obtaining 
+  a copy of this software and associated documentation files (the "Software"), 
+  to deal in the Software without restriction, including without limitation 
+  the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+  and/or sell copies of the Software, and to permit persons to whom the 
+  Software is furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included 
+  in all copies or substantial portions of the Software.
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+  ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+  OTHER DEALINGS IN THE SOFTWARE.
+
+|#
+
+(in-package :asdf)
+
+(defsystem :lisp-unit
+  :description "Common Lisp library that supports unit testing."
+  :version "0.9.2"
+  :author "Thomas M. Hermann <thomas.m.hermann@odonata-research.com>"
+  :license "MIT"
+  :components
+  ((:file "lisp-unit")
+   (:module extensions
+    :depends-on ("lisp-unit")
+    :components ((:file "rational")
+                 (:file "floating-point")
+                 (:file "test-anything-protocol")))))
diff --git a/src/contrib/lisp-unit/lisp-unit.lisp b/src/contrib/lisp-unit/lisp-unit.lisp
new file mode 100644
index 000000000..efaae1a49
--- /dev/null
+++ b/src/contrib/lisp-unit/lisp-unit.lisp
@@ -0,0 +1,910 @@
+;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
+
+#|
+Copyright (c) 2004-2005 Christopher K. Riesbeck
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
+
+
+How to use
+----------
+
+1. Read the documentation at:
+   https://github.com/OdonataResearchLLC/lisp-unit/wiki
+
+2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
+examples. If you want, start your test file with (REMOVE-TESTS :ALL)
+to clear any previously defined tests.
+
+3. Load this file.
+
+4. (use-package :lisp-unit)
+
+5. Load your code file and your file of tests.
+
+6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
+simply (RUN-TESTS :ALL) to run all defined tests.
+
+A summary of how many tests passed and failed will be printed.
+
+NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
+functions or even macros does not require reloading any tests.
+
+|#
+
+;;; Packages
+
+(in-package :cl-user)
+
+(defpackage :lisp-unit
+  (:use :common-lisp)
+  ;; Print parameters
+  (:export :*print-summary*
+           :*print-failures*
+           :*print-errors*)
+  ;; Forms for assertions
+  (:export :assert-eq
+           :assert-eql
+           :assert-equal
+           :assert-equalp
+           :assert-equality
+           :assert-prints
+           :assert-expands
+           :assert-true
+           :assert-false
+           :assert-error)
+  ;; Functions for managing tests
+  (:export :define-test
+           :list-tests
+           :test-code
+           :test-documentation
+           :remove-tests
+           :run-tests
+           :use-debugger)
+  ;; Functions for managing tags
+  (:export :list-tags
+           :tagged-tests
+           :remove-tags
+           :run-tags)
+  ;; Functions for reporting test results
+  (:export :test-names
+           :failed-tests
+           :error-tests
+           :missing-tests
+           :print-failures
+           :print-errors
+           :summarize-results)
+  ;; Functions for extensibility via signals
+  (:export :signal-results
+           :test-run-complete
+           :results)
+  ;; Utility predicates
+  (:export :logically-equal :set-equal))
+
+(in-package :lisp-unit)
+
+;;; Global counters
+
+(defparameter *pass* 0
+  "The passed assertion results.")
+
+(defparameter *fail* ()
+  "The failed assertion results.")
+
+(defun reset-counters ()
+  "Reset the counters to empty lists."
+  (setf *pass* 0 *fail* ()))
+
+;;; Global options
+
+(defparameter *print-summary* nil
+  "Print a summary of the pass, fail, and error count if non-nil.")
+
+(defparameter *print-failures* nil
+  "Print failure messages if non-NIL.")
+
+(defparameter *print-errors* nil
+  "Print error messages if non-NIL.")
+
+(defparameter *use-debugger* nil
+  "If not NIL, enter the debugger when an error is encountered in an
+assertion.")
+
+(defparameter *signal-results* nil
+  "Signal the result if non NIL.")
+
+(defun use-debugger-p (condition)
+  "Debug or ignore errors."
+  (cond
+   ((eq :ask *use-debugger*)
+    (y-or-n-p "~A -- debug?" condition))
+   (*use-debugger*)))
+
+(defun use-debugger (&optional (flag t))
+  "Use the debugger when testing, or not."
+  (setq *use-debugger* flag))
+
+(defun signal-results (&optional (flag t))
+  "Signal the results for extensibility."
+  (setq *signal-results* flag))
+
+;;; Global unit test database
+
+(defparameter *test-db* (make-hash-table :test #'eq)
+  "The unit test database is simply a hash table.")
+
+(defun null-tests-warning-report (null-tests-warning stream)
+  "Write the null-tests-warning to the stream."
+  (format stream "No tests defined for package ~A."
+          (tests-package-name null-tests-warning)))
+
+(define-condition null-tests-warning (simple-warning)
+  ((name
+    :type string
+    :initarg :name
+    :reader tests-package-name))
+  (:report null-tests-warning-report))
+
+(defun package-table (package &optional create)
+  (let ((packobj (find-package package)))
+    (cond
+     ((gethash packobj *test-db*))
+     (create
+      (setf (gethash packobj *test-db*) (make-hash-table)))
+     (t (warn 'null-tests-warning :name (package-name package))))))
+
+(defmacro with-package-table ((table
+                               &optional (package *package*) create)
+                              &body body)
+  "Execute the body only if the package table exists."
+  (let ((gtable (gensym "TABLE-")))
+    `(let* ((,gtable (package-table ,package ,create))
+            (,table ,gtable))
+       (when (hash-table-p ,gtable) ,@body))))
+
+;;; Global tags database
+
+(defparameter *tag-db* (make-hash-table :test #'eq)
+  "The tag database is simply a hash table.")
+
+(defun null-tags-warning-report (null-tags-warning stream)
+  "Write the null-tags-warning to the stream."
+  (format stream "No tags defined for package ~A."
+          (tags-package-name null-tags-warning)))
+
+(define-condition null-tags-warning (simple-warning)
+  ((name
+    :type string
+    :initarg :name
+    :reader tags-package-name))
+  (:report null-tags-warning-report))
+
+(defun package-tags (package &optional create)
+  "Return the tags DB for the package."
+  (let ((packobj (find-package package)))
+    (cond
+     ((gethash packobj *tag-db*))
+     (create
+      (setf (gethash packobj *tag-db*) (make-hash-table)))
+     (t (warn 'null-tags-warning :name (package-name package))))))
+
+(defmacro with-package-tags ((table
+                              &optional (package *package*) create)
+                             &body body)
+  "Execute the body only if the package tags exists."
+  (let ((gtable (gensym "TABLE-")))
+    `(let* ((,gtable (package-tags ,package ,create))
+            (,table ,gtable))
+       (when (hash-table-p ,gtable) ,@body))))
+
+;;; Unit test definition
+
+(defclass unit-test ()
+  ((doc
+    :type string
+    :initarg :doc
+    :reader doc)
+   (code
+    :type list
+    :initarg :code
+    :reader code))
+  (:default-initargs :doc "" :code ())
+  (:documentation
+   "Organize the unit test documentation and code."))
+
+;;; NOTE: Shamelessly taken from PG's analyze-body
+(defun parse-body (body &optional doc tag)
+  "Separate the components of the body."
+  (let ((item (first body)))
+    (cond
+     ((and (listp item) (eq :tag (first item)))
+      (parse-body (rest body) doc (nconc (rest item) tag)))
+     ((and (stringp item) (not doc) (rest body))
+      (if tag
+          (values doc tag (rest body))
+          (parse-body (rest body) doc tag)))
+     (t (values doc tag body)))))
+
+(defun test-name-error-report (test-name-error stream)
+  "Write the test-name-error to the stream."
+  (format stream "Test name ~S is not of type ~A."
+          (type-error-datum test-name-error)
+          (type-error-expected-type test-name-error)))
+
+(define-condition test-name-error (type-error)
+  ()
+  (:default-initargs :expected-type 'symbol)
+  (:report test-name-error-report)
+  (:documentation
+   "The test name error is a type error."))
+
+(defun valid-test-name (name)
+  "Signal a type-error if the test name is not a symbol."
+  (if (symbolp name)
+      name
+      (error 'test-name-error :datum name)))
+
+(defmacro define-test (name &body body)
+  "Store the test in the test database."
+  (let ((qname (gensym "NAME-")))
+    (multiple-value-bind (doc tag code) (parse-body body)
+      `(let* ((,qname (valid-test-name ',name))
+              (doc (or ,doc (string ,qname))))
+         (setf
+          ;; Unit test
+          (gethash ,qname (package-table *package* t))
+          (make-instance 'unit-test :doc doc :code ',code))
+         ;; Tags
+         (loop for tag in ',tag do
+               (pushnew
+                ,qname (gethash tag (package-tags *package* t))))
+         ;; Return the name of the test
+         ,qname))))
+
+;;; Manage tests
+
+(defun list-tests (&optional (package *package*))
+  "Return a list of the tests in package."
+  (with-package-table (table package)
+    (loop for test-name being each hash-key in table
+          collect test-name)))
+
+(defun test-documentation (name &optional (package *package*))
+  "Return the documentation for the test."
+  (with-package-table (table package)
+    (let ((unit-test (gethash name table)))
+      (if (null unit-test)
+          (warn "No test ~A in package ~A."
+                name (package-name package))
+          (doc unit-test)))))
+
+(defun test-code (name &optional (package *package*))
+  "Returns the code stored for the test name."
+  (with-package-table (table package)
+    (let ((unit-test (gethash name table)))
+      (if (null unit-test)
+          (warn "No test ~A in package ~A."
+                name (package-name package))
+          (code unit-test)))))
+
+(defun remove-tests (&optional (names :all) (package *package*))
+  "Remove individual tests or entire sets."
+  (if (eq :all names)
+      (if (null package)
+          (clrhash *test-db*)
+          (progn
+            (remhash (find-package package) *test-db*)
+            (remhash (find-package package) *tag-db*)))
+      (progn
+        ;; Remove tests
+        (with-package-table (table package)
+          (loop for name in names
+                unless (remhash name table) do
+                (warn "No test ~A in package ~A to remove."
+                      name (package-name package))))
+        ;; Remove tests from tags
+        (with-package-tags (tags package)
+          (loop for tag being each hash-key in tags
+                using (hash-value tagged-tests)
+                do
+                (setf
+                 (gethash tag tags)
+                 (set-difference tagged-tests names)))))))
+
+;;; Manage tags
+
+(defun %tests-from-all-tags (&optional (package *package*))
+  "Return all of the tests that have been tagged."
+  (with-package-tags (table package)
+    (loop for tests being each hash-value in table
+          nconc (copy-list tests) into all-tests
+          finally (return (delete-duplicates all-tests)))))
+
+(defun %tests-from-tags (tags &optional (package *package*))
+  "Return the tests associated with the tags."
+  (with-package-tags (table package)
+    (loop for tag in tags
+          as tests = (gethash tag table)
+          if (null tests) do (warn "No tests tagged with ~S." tag)
+          else nconc (copy-list tests) into all-tests
+          finally (return (delete-duplicates all-tests)))))
+
+(defun list-tags (&optional (package *package*))
+  "Return a list of the tags in package."
+  (with-package-tags (table package)
+    (loop for tag being each hash-key in table collect tag)))
+
+(defun tagged-tests (&optional (tags :all) (package *package*))
+  "Return a list of the tests associated with the tags."
+  (if (eq :all tags)
+      (%tests-from-all-tags package)
+      (%tests-from-tags tags package)))
+
+(defun remove-tags (&optional (tags :all) (package *package*))
+  "Remove individual tags or entire sets."
+  (if (eq :all tags)
+      (if (null package)
+          (clrhash *tag-db*)
+          (remhash (find-package package) *tag-db*))
+      (with-package-tags (tag-table package)
+        (loop for tag in tags
+              unless (remhash tag tag-table) do
+              (warn "No tag ~A in package ~A to remove."
+                    tag (package-name package))))))
+
+;;; Assert macros
+
+(defmacro assert-eq (expected form &rest extras)
+  "Assert whether expected and form are EQ."
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
+
+(defmacro assert-eql (expected form &rest extras)
+  "Assert whether expected and form are EQL."
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
+
+(defmacro assert-equal (expected form &rest extras)
+  "Assert whether expected and form are EQUAL."
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
+
+(defmacro assert-equalp (expected form &rest extras)
+  "Assert whether expected and form are EQUALP."
+  `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
+
+(defmacro assert-error (condition form &rest extras)
+  "Assert whether form signals condition."
+  `(expand-assert :error ,form (expand-error-form ,form)
+                  ,condition ,extras))
+
+(defmacro assert-expands (expansion form &rest extras)
+  "Assert whether form expands to expansion."
+  `(expand-assert :macro ,form
+                  (expand-macro-form ,form nil)
+                  ',expansion ,extras))
+
+(defmacro assert-false (form &rest extras)
+  "Assert whether the form is false."
+  `(expand-assert :result ,form ,form nil ,extras))
+
+(defmacro assert-equality (test expected form &rest extras)
+  "Assert whether expected and form are equal according to test."
+  `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
+
+(defmacro assert-prints (output form &rest extras)
+  "Assert whether printing the form generates the output."
+  `(expand-assert :output ,form (expand-output-form ,form)
+                  ,output ,extras))
+
+(defmacro assert-true (form &rest extras)
+  "Assert whether the form is true."
+  `(expand-assert :result ,form ,form t ,extras))
+
+(defmacro expand-assert (type form body expected extras &key (test '#'eql))
+  "Expand the assertion to the internal format."
+  `(internal-assert ,type ',form
+                    (lambda () ,body)
+                    (lambda () ,expected)
+                    (expand-extras ,extras)
+                    ,test))
+
+(defmacro expand-error-form (form)
+  "Wrap the error assertion in HANDLER-CASE."
+  `(handler-case ,form
+     (condition (error) error)))
+
+(defmacro expand-output-form (form)
+  "Capture the output of the form in a string."
+  (let ((out (gensym)))
+    `(let* ((,out (make-string-output-stream))
+            (*standard-output*
+             (make-broadcast-stream *standard-output* ,out)))
+       ,form
+       (get-output-stream-string ,out))))
+
+(defmacro expand-macro-form (form env)
+  "Expand the macro form once."
+  `(let ((*gensym-counter* 1))
+     (macroexpand-1 ',form ,env)))
+
+(defmacro expand-extras (extras)
+  "Expand extra forms."
+  `(lambda ()
+     (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
+
+(defgeneric assert-result (type test expected actual)
+  (:documentation
+   "Return the result of the assertion."))
+
+(defgeneric record-failure (type form actual expected extras test)
+  (:documentation
+   "Record the details of the failure."))
+
+(defclass failure-result ()
+  ((form
+    :initarg :form
+    :reader form)
+   (actual
+    :type list
+    :initarg :actual
+    :reader actual)
+   (expected
+    :type list
+    :initarg :expected
+    :reader expected)
+   (extras
+    :type list
+    :initarg :extras
+    :reader extras)
+   (test
+    :type function
+    :initarg :test
+    :reader test))
+  (:documentation
+   "Failure details of the assertion."))
+
+(defun %record-failure (class form actual expected extras test)
+  "Return an instance of the failure result."
+  (make-instance class
+                 :form form
+                 :actual actual
+                 :expected expected
+                 :extras extras
+                 :test test))
+
+(defclass equal-result (failure-result)
+  ()
+  (:documentation
+   "Result of a failed equal assertion."))
+
+(defmethod assert-result ((type (eql :equal)) test expected actual)
+  "Return the result of an equal assertion."
+  (and
+   (<= (length expected) (length actual))
+   (every test expected actual)))
+
+(defmethod record-failure ((type (eql :equal))
+                           form actual expected extras test)
+  "Return an instance of an equal failure result."
+  (%record-failure 'equal-result form actual expected extras test))
+
+(defclass error-result (failure-result)
+  ()
+  (:documentation
+   "Result of a failed error assertion."))
+
+(defmethod assert-result ((type (eql :error)) test expected actual)
+  "Return the result of an error assertion."
+  (declare (ignore test))
+  (or
+   (eql (car actual) (car expected))
+   (typep (car actual) (car expected))))
+
+(defmethod record-failure ((type (eql :error))
+                           form actual expected extras test)
+  "Return an instance of an error failure result."
+  (%record-failure 'error-result form actual expected extras test))
+
+(defclass macro-result (failure-result)
+  ()
+  (:documentation
+   "Result of a failed macro expansion assertion."))
+
+(defun %expansion-equal (form1 form2)
+  "Descend into the forms checking for equality."
+  (let ((item1 (first form1))
+        (item2 (first form2)))
+    (cond
+     ((and (null item1) (null item2)))
+     ((and (listp item1) (listp item2))
+      (and
+       (%expansion-equal item1 item2)
+       (%expansion-equal (rest form1) (rest form2))))
+     ((and (symbolp item1) (symbolp item2))
+      (and
+       (string= (symbol-name item1) (symbol-name item2))
+       (%expansion-equal (rest form1) (rest form2))))
+     (t (and
+         (equal item1 item2)
+         (%expansion-equal (rest form1) (rest form2)))))))
+
+(defmethod assert-result ((type (eql  :macro)) test expected actual)
+  "Return the result of a macro assertion."
+  (declare (ignore test))
+  (%expansion-equal (first expected) (first actual)))
+
+(defmethod record-failure ((type (eql :macro))
+                           form actual expected extras test)
+  "Return an instance of a macro failure result."
+  (%record-failure 'macro-result form actual expected extras test))
+
+(defclass boolean-result (failure-result)
+  ()
+  (:documentation
+   "Result of a failed boolean assertion."))
+
+(defmethod assert-result ((type (eql :result)) test expected actual)
+  "Return the result of a result assertion."
+  (declare (ignore test))
+  (logically-equal (car actual) (car expected)))
+
+(defmethod record-failure ((type (eql :result))
+                           form actual expected extras test)
+  "Return an instance of a boolean failure result."
+  (%record-failure 'boolean-result form actual expected extras test))
+
+(defclass output-result (failure-result)
+  ()
+  (:documentation
+   "Result of a failed output assertion."))
+
+(defmethod assert-result ((type (eql :output)) test expected actual)
+  "Return the result of an output assertion."
+  (declare (ignore test))
+  (string=
+   (string-trim '(#\newline #\return #\space) (car actual))
+   (car expected)))
+
+(defmethod record-failure ((type (eql :output))
+                           form actual expected extras test)
+  "Return an instance of an output failure result."
+  (%record-failure 'output-result form actual expected extras test))
+
+(defun internal-assert
+       (type form code-thunk expected-thunk extras test)
+  "Perform the assertion and record the results."
+  (let* ((actual (multiple-value-list (funcall code-thunk)))
+         (expected (multiple-value-list (funcall expected-thunk)))
+         (result (assert-result type test expected actual)))
+    (if result
+        (incf *pass*)
+        (push
+         (record-failure
+          type form actual expected
+          (when extras (funcall extras)) test)
+         *fail*))
+    ;; Return the result
+    result))
+
+;;; Unit test results
+
+(defclass test-result ()
+  ((name
+    :type symbol
+    :initarg :name
+    :reader name)
+   (pass
+    :type fixnum
+    :initarg :pass
+    :reader pass)
+   (fail
+    :type list
+    :initarg :fail
+    :reader fail)
+   (exerr
+    :initarg :exerr
+    :reader exerr)
+   (run-time
+    :initarg :run-time
+    :reader run-time
+    :documentation
+    "Test run time measured in internal time units"))
+  (:default-initargs :exerr nil)
+  (:documentation
+   "Store the results of the unit test."))
+
+(defun print-summary (test-result &optional
+                      (stream *standard-output*))
+  "Print a summary of the test result."
+  (format stream "~&~A: ~S assertions passed, ~S failed"
+          (name test-result)
+          (pass test-result)
+          (length (fail test-result)))
+  (if (exerr test-result)
+      (format stream ", and an execution error.")
+      (write-char #\. stream))
+  (terpri stream)
+  (terpri stream))
+
+(defun run-code (code)
+  "Run the code to test the assertions."
+  (funcall (coerce `(lambda () ,@code) 'function)))
+
+(defun run-test-thunk (name code)
+  (let ((*pass* 0)
+        (*fail* ())
+        (start (get-internal-run-time)))
+    (handler-bind
+        ((error
+          (lambda (condition)
+            (if (use-debugger-p condition)
+                condition
+                (return-from run-test-thunk
+                  (make-instance
+                   'test-result
+                   :name name
+                   :pass *pass*
+                   :fail *fail*
+                   :run-time (- (get-internal-run-time) start)
+                   :exerr condition))))))
+      (run-code code))
+    ;; Return the result count
+    (make-instance
+     'test-result
+     :name name
+     :pass *pass*
+     :fail *fail*
+     :run-time (- (get-internal-run-time) start))))
+
+;;; Test results database
+
+(defclass test-results-db ()
+  ((database
+    :type hash-table
+    :initform (make-hash-table :test #'eq)
+    :reader database)
+   (pass
+    :type fixnum
+    :initform 0
+    :accessor pass)
+   (fail
+    :type fixnum
+    :initform 0
+    :accessor fail)
+   (exerr
+    :type fixnum
+    :initform 0
+    :accessor exerr)
+   (failed-tests
+    :type list
+    :initform ()
+    :accessor failed-tests)
+   (error-tests
+    :type list
+    :initform ()
+    :accessor error-tests)
+   (missing-tests
+    :type list
+    :initform ()
+    :accessor missing-tests))
+  (:documentation
+   "Store the results of the tests for further evaluation."))
+
+(defmethod print-object ((object test-results-db) stream)
+  "Print the summary counts with the object."
+  (let ((pass (pass object))
+        (fail (fail object))
+        (exerr (exerr object)))
+    (format
+     stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
+     (class-name (class-of object))
+     (+ pass fail) pass fail exerr)))
+
+(defun test-names (test-results-db)
+  "Return a list of the test names in the database."
+  (loop for name being each hash-key in (database test-results-db)
+        collect name))
+
+(defun record-result (test-name code results)
+  "Run the test code and record the result."
+  (let ((result (run-test-thunk test-name code)))
+    ;; Store the result
+    (setf (gethash test-name (database results)) result)
+    ;; Count passed tests
+    (when (plusp (pass result))
+      (incf (pass results) (pass result)))
+    ;; Count failed tests and record the name
+    (when (fail result)
+      (incf (fail results) (length (fail result)))
+      (push test-name (failed-tests results)))
+    ;; Count errors and record the name
+    (when (exerr result)
+      (incf (exerr results))
+      (push test-name (error-tests results)))
+    ;; Running output
+    (when *print-failures* (print-failures result))
+    (when *print-errors* (print-errors result))
+    (when (or *print-summary* *print-failures* *print-errors*)
+      (print-summary result))))
+
+(defun summarize-results (results &optional
+                          (stream *standard-output*))
+  "Print a summary of all results to the stream."
+  (let ((pass (pass results))
+        (fail (fail results)))
+    (format stream "~&Unit Test Summary~%")
+    (format stream " | ~D assertions total~%" (+ pass fail))
+    (format stream " | ~D passed~%" pass)
+    (format stream " | ~D failed~%" fail)
+    (format stream " | ~D execution errors~%" (exerr results))
+    (format stream " | ~D missing tests~2%"
+            (length (missing-tests results)))))
+
+;;; Run the tests
+
+(define-condition test-run-complete ()
+  ((results
+    :type 'test-results-db
+    :initarg :results
+    :reader results))
+  (:documentation
+   "Signaled when a test run is finished."))
+
+(defun %run-all-thunks (&optional (package *package*))
+  "Run all of the test thunks in the package."
+  (with-package-table (table package)
+    (loop
+     with results = (make-instance 'test-results-db)
+     for test-name being each hash-key in table
+     using (hash-value unit-test)
+     if unit-test do
+     (record-result test-name (code unit-test) results)
+     else do
+     (push test-name (missing-tests results))
+     ;; Summarize and return the test results
+     finally
+     (when *signal-results*
+       (signal 'test-run-complete :results results))
+     (summarize-results results)
+     (return results))))
+
+(defun %run-thunks (test-names &optional (package *package*))
+  "Run the list of test thunks in the package."
+  (with-package-table (table package)
+    (loop
+     with results = (make-instance 'test-results-db)
+     for test-name in test-names
+     as unit-test = (gethash test-name table)
+     if unit-test do
+     (record-result test-name (code unit-test) results)
+     else do
+     (push test-name (missing-tests results))
+     finally
+     (when *signal-results*
+       (signal 'test-run-complete :results results))
+     (summarize-results results)
+     (return results))))
+
+(defun run-tests (&optional (test-names :all) (package *package*))
+  "Run the specified tests in package."
+  (reset-counters)
+  (if (eq :all test-names)
+      (%run-all-thunks package)
+      (%run-thunks test-names package)))
+
+(defun run-tags (&optional (tags :all) (package *package*))
+  "Run the tests associated with the specified tags in package."
+  (reset-counters)
+  (%run-thunks (tagged-tests tags package) package))
+
+;;; Print failures
+
+(defgeneric print-failures (result &optional stream)
+  (:documentation
+   "Report the results of the failed assertion."))
+
+(defmethod print-failures :around ((result failure-result) &optional
+                                   (stream *standard-output*))
+  "Failure header and footer output."
+  (format stream "~& | Failed Form: ~S" (form result))
+  (call-next-method)
+  (when (extras result)
+    (format stream "~{~& | ~S => ~S~}~%" (extras result)))
+  (format stream "~& |~%"))
+
+(defmethod print-failures ((result failure-result) &optional
+                           (stream *standard-output*))
+  (format stream "~& | Expected ~{~S~^; ~} " (expected result))
+  (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
+
+(defmethod print-failures ((result error-result) &optional
+                           (stream *standard-output*))
+  (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
+          (expected result))
+  (format stream " ~{~S~^; ~}" (actual result)))
+
+(defmethod print-failures ((result macro-result) &optional
+                           (stream *standard-output*))
+  (format stream "~& | Should have expanded to ~{~S~^; ~} "
+          (expected result))
+  (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
+
+(defmethod print-failures ((result output-result) &optional
+                           (stream *standard-output*))
+  (format stream "~& | Should have printed ~{~S~^; ~} "
+          (expected result))
+  (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
+          (actual result)))
+
+(defmethod print-failures ((result test-result) &optional
+                           (stream *standard-output*))
+  "Print the failed assertions in the unit test."
+  (loop for fail in (fail result) do
+        (print-failures fail stream)))
+
+(defmethod print-failures ((results test-results-db) &optional
+                           (stream *standard-output*))
+  "Print all of the failure tests."
+  (loop with db = (database results)
+        for test in (failed-tests results)
+        as result = (gethash test db)
+        do
+        (print-failures result stream)
+        (print-summary result stream)))
+
+;;; Print errors
+
+(defgeneric print-errors (result &optional stream)
+  (:documentation
+   "Print the error condition."))
+
+(defmethod print-errors ((result test-result) &optional
+                         (stream *standard-output*))
+  "Print the error condition."
+  (let ((exerr (exerr result))
+        (*print-escape* nil))
+    (when exerr
+      (format stream "~& | Execution error:~% | ~W" exerr)
+      (format stream "~& |~%"))))
+
+(defmethod print-errors ((results test-results-db) &optional
+                         (stream *standard-output*))
+  "Print all of the error tests."
+  (loop with db = (database results)
+        for test in (error-tests results)
+        as result = (gethash test db)
+        do
+        (print-errors result stream)
+        (print-summary result stream)))
+
+;;; Useful equality predicates for tests
+
+(defun logically-equal (x y)
+  "Return true if x and y are both false or both true."
+  (eql (not x) (not y)))
+
+(defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
+  "Return true if every element of list1 is an element of list2 and
+vice versa."
+  (declare (ignore key test))
+  (and
+   (listp list1)
+   (listp list2)
+   (apply #'subsetp list1 list2 initargs)
+   (apply #'subsetp list2 list1 initargs)))
+
+(pushnew :lisp-unit common-lisp:*features*)
-- 
GitLab