Squashed 'third_party/lisp/fiveam/' content from commit ee9456a2

git-subtree-dir: third_party/lisp/fiveam
git-subtree-split: ee9456a2ac52b1c9f5f5f789d263f0f76a15176c

11 files changed, 2040 insertions, 0 deletions

diff --git a/src/check.lisp b/src/check.lisp
new file mode 100644
index 000000000000..b3808c5cf04c
--- /dev/null
+++ b/src/check.lisp
@@ -0,0 +1,311 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Checks
+
+;;;; At the lowest level testing the system requires that certain
+;;;; forms be evaluated and that certain post conditions are met: the
+;;;; value returned must satisfy a certain predicate, the form must
+;;;; (or must not) signal a certain condition, etc. In FiveAM these
+;;;; low level operations are called 'checks' and are defined using
+;;;; the various checking macros.
+
+;;;; Checks are the basic operators for collecting results. Tests and
+;;;; test suites on the other hand allow grouping multiple checks into
+;;;; logic collections.
+
+(defvar *test-dribble* t)
+
+(defmacro with-*test-dribble* (stream &body body)
+  `(let ((*test-dribble* ,stream))
+     (declare (special *test-dribble*))
+     ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-special-environment run-state ()
+    result-list
+    current-test))
+
+;;;; ** Types of test results
+
+;;;; Every check produces a result object.
+
+(defclass test-result ()
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "All checking macros will generate an object of
+ type TEST-RESULT."))
+
+(defclass test-passed (test-result)
+  ()
+  (:documentation "Class for successful checks."))
+
+(defgeneric test-passed-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-passed)) t))
+
+(define-condition check-failure (error)
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "Signaled when a check fails.")
+  (:report  (lambda (c stream)
+              (format stream "The following check failed: ~S~%~A."
+                      (test-expr c)
+                      (reason c)))))
+
+(defun process-failure (test-expr &optional reason-format &rest format-args)
+  (let ((reason (and reason-format
+                     (apply #'format nil reason-format format-args))))
+    (with-simple-restart (ignore-failure "Continue the test run.")
+      (error 'check-failure :test-expr test-expr
+                            :reason reason))
+    (add-result 'test-failure :test-expr test-expr
+                              :reason reason)))
+
+(defclass test-failure (test-result)
+  ()
+  (:documentation "Class for unsuccessful checks."))
+
+(defgeneric test-failure-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-failure)) t))
+
+(defclass unexpected-test-failure (test-failure)
+  ((actual-condition :accessor actual-condition :initarg :condition))
+  (:documentation "Represents the result of a test which neither
+passed nor failed, but signaled an error we couldn't deal
+with.
+
+Note: This is very different than a SIGNALS check which instead
+creates a TEST-PASSED or TEST-FAILURE object."))
+
+(defclass test-skipped (test-result)
+  ()
+  (:documentation "A test which was not run. Usually this is due to
+unsatisfied dependencies, but users can decide to skip the test when
+appropriate."))
+
+(defgeneric test-skipped-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-skipped)) t))
+
+(defun add-result (result-type &rest make-instance-args)
+  "Create a TEST-RESULT object of type RESULT-TYPE passing it the
+  initialize args MAKE-INSTANCE-ARGS and add the resulting
+  object to the list of test results."
+  (with-run-state (result-list current-test)
+    (let ((result (apply #'make-instance result-type
+                         (append make-instance-args (list :test-case current-test)))))
+      (etypecase result
+        (test-passed  (format *test-dribble* "."))
+        (unexpected-test-failure (format *test-dribble* "X"))
+        (test-failure (format *test-dribble* "f"))
+        (test-skipped (format *test-dribble* "s")))
+      (push result result-list))))
+
+;;;; ** The check operators
+
+;;;; *** The IS check
+
+(defmacro is (test &rest reason-args)
+  "The DWIM checking operator.
+
+If TEST returns a true value a test-passed result is generated,
+otherwise a test-failure result is generated. The reason, unless
+REASON-ARGS is provided, is generated based on the form of TEST:
+
+ (predicate expected actual) - Means that we want to check
+ whether, according to PREDICATE, the ACTUAL value is
+ in fact what we EXPECTED.
+
+ (predicate value) - Means that we want to ensure that VALUE
+ satisfies PREDICATE.
+
+ Wrapping the TEST form in a NOT simply produces a negated reason
+ string."
+  (assert (listp test)
+          (test)
+          "Argument to IS must be a list, not ~S" test)
+  (let (bindings effective-test default-reason-args)
+    (with-gensyms (e a v)
+      (flet ((process-entry (predicate expected actual &optional negatedp)
+               ;; make sure EXPECTED is holding the entry that starts with 'values
+               (when (and (consp actual)
+                          (eq (car actual) 'values))
+                 (assert (not (and (consp expected)
+                                   (eq (car expected) 'values))) ()
+                                   "Both the expected and actual part is a values expression.")
+                 (rotatef expected actual))
+               (let ((setf-forms))
+                 (if (and (consp expected)
+                          (eq (car expected) 'values))
+                     (progn
+                       (setf expected (copy-list expected))
+                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+                                              for i from 0
+                                              while cell
+                                              when (eq (car cell) '*)
+                                              collect `(setf (elt ,a ,i) nil)
+                                              and do (setf (car cell) nil)))
+                       (setf bindings (list (list e `(list ,@(rest expected)))
+                                            (list a `(multiple-value-list ,actual)))))
+                     (setf bindings (list (list e expected)
+                                          (list a actual))))
+                 (setf effective-test `(progn
+                                         ,@setf-forms
+                                         ,(if negatedp
+                                              `(not (,predicate ,e ,a))
+                                              `(,predicate ,e ,a)))))))
+        (list-match-case test
+          ((not (?predicate ?expected ?actual))
+           (process-entry ?predicate ?expected ?actual t)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
+                       `',?actual a `',?predicate e)))
+          ((not (?satisfies ?value))
+           (setf bindings (list (list v ?value))
+                 effective-test `(not (,?satisfies ,v))
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
+                       `',?value v `',?satisfies)))
+          ((?predicate ?expected ?actual)
+           (process-entry ?predicate ?expected ?actual)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%."
+                       `',?actual a `',?predicate e)))
+          ((?satisfies ?value)
+           (setf bindings (list (list v ?value))
+                 effective-test `(,?satisfies ,v)
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
+                       `',?value v `',?satisfies)))
+          (?_
+           (setf bindings '()
+                 effective-test test
+                 default-reason-args (list "~2&~S~2% was NIL." `',test)))))
+      `(let ,bindings
+         (if ,effective-test
+             (add-result 'test-passed :test-expr ',test)
+             (process-failure ',test
+                              ,@(or reason-args default-reason-args)))))))
+
+;;;; *** Other checks
+
+(defmacro skip (&rest reason)
+  "Generates a TEST-SKIPPED result."
+  `(progn
+     (format *test-dribble* "s")
+     (add-result 'test-skipped :reason (format nil ,@reason))))
+
+(defmacro is-every (predicate &body clauses)
+  "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+   for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+  `(progn
+     ,@(if (every #'consp clauses)
+           (loop for (expected actual . reason) in clauses
+                 collect `(is (,predicate ,expected ,actual) ,@reason))
+           (progn
+             (assert (evenp (list-length clauses)))
+             (loop for (expr value) on clauses by #'cddr
+                   collect `(is (,predicate ,expr ,value)))))))
+
+(defmacro is-true (condition &rest reason-args)
+  "Like IS this check generates a pass if CONDITION returns true
+  and a failure if CONDITION returns false. Unlike IS this check
+  does not inspect CONDITION to determine how to report the
+  failure."
+  `(if ,condition
+       (add-result 'test-passed :test-expr ',condition)
+       (process-failure ',condition
+                        ,@(or reason-args
+                              `("~S did not return a true value" ',condition)))))
+
+(defmacro is-false (condition &rest reason-args)
+  "Generates a pass if CONDITION returns false, generates a
+  failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
+  not inspect CONDITION to determine what reason to give it case
+  of test failure"
+  (with-gensyms (value)
+    `(let ((,value ,condition))
+       (if ,value
+           (process-failure ',condition
+                            ,@(or reason-args
+                                  `("~S returned the value ~S, which is true" ',condition ,value)))
+           (add-result 'test-passed :test-expr ',condition)))))
+
+(defmacro signals (condition-spec
+                   &body body)
+  "Generates a pass if BODY signals a condition of type
+CONDITION. BODY is evaluated in a block named NIL, CONDITION is
+not evaluated."
+  (let ((block-name (gensym)))
+    (destructuring-bind (condition &optional reason-control reason-args)
+        (ensure-list condition-spec)
+      `(block ,block-name
+         (handler-bind ((,condition (lambda (c)
+                                      (declare (ignore c))
+                                      ;; ok, body threw condition
+                                      (add-result 'test-passed
+                                                  :test-expr ',condition)
+                                      (return-from ,block-name t))))
+           (block nil
+             ,@body))
+         (process-failure
+           ',condition
+           ,@(if reason-control
+                 `(,reason-control ,@reason-args)
+                 `("Failed to signal a ~S" ',condition)))
+         (return-from ,block-name nil)))))
+
+(defmacro finishes (&body body)
+  "Generates a pass if BODY executes to normal completion. In
+other words if body does signal, return-from or throw this test
+fails."
+  `(unwind-protect-case () (progn ,@body)
+     (:normal (add-result 'test-passed :test-expr ',body))
+     (:abort (process-failure ',body "Test didn't finish"))))
+
+(defmacro pass (&rest message-args)
+  "Simply generate a PASS."
+  `(add-result 'test-passed
+               :test-expr ',message-args
+               ,@(when message-args
+                   `(:reason (format nil ,@message-args)))))
+
+(defmacro fail (&rest message-args)
+  "Simply generate a FAIL."
+  `(process-failure ',message-args
+                    ,@message-args))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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
diff --git a/src/classes.lisp b/src/classes.lisp
new file mode 100644
index 000000000000..fc4dc782e8cb
--- /dev/null
+++ b/src/classes.lisp
@@ -0,0 +1,128 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+(defclass testable-object ()
+  ((name :initarg :name :accessor name
+         :documentation "A symbol naming this test object.")
+   (description :initarg :description :accessor description :initform nil
+                :documentation "The textual description of this test object.")
+   (depends-on :initarg :depends-on :accessor depends-on :initform nil
+               :documentation "The list of AND, OR, NOT forms specifying when to run this test.")
+   (status :initarg :status :accessor status :initform :unknown
+           :documentation "A symbol specifying the current status
+	   of this test. Either: T - this test (and all its
+	   dependencies, have passed. NIL - this test
+	   failed (either it failed or its dependecies weren't
+	   met. :circular this test has a circular dependency
+	   and was skipped. Or :depends-not-satisfied or :resolving")
+   (profiling-info :accessor profiling-info
+                   :initform nil
+                   :documentation "An object representing how
+                   much time and memory where used by the
+                   test.")
+   (collect-profiling-info :accessor collect-profiling-info
+                           :initarg :collect-profiling-info
+                           :initform nil
+                           :documentation "When T profiling
+                           information will be collected when the
+                           test is run.")))
+
+(defmethod print-object ((test testable-object) stream)
+  (print-unreadable-object (test stream :type t :identity t)
+    (format stream "~S" (name test))))
+
+(defclass test-suite (testable-object)
+  ((tests :accessor tests :initform (make-hash-table :test 'eql)
+          :documentation "The hash table mapping names to test
+	  objects in this suite. The values in this hash table
+	  can be either test-cases or other test-suites."))
+  (:documentation "A test suite is a collection of tests or test suites.
+
+Test suites serve to organize tests into groups so that the
+developer can chose to run some tests and not just one or
+all. Like tests test suites have a name and a description.
+
+Test suites, like tests, can be part of other test suites, this
+allows the developer to create a hierarchy of tests where sub
+trees can be singularly run.
+
+Running a test suite has the effect of running every test (or
+suite) in the suite."))
+
+(defclass test-case (testable-object)
+  ((test-lambda :initarg :test-lambda :accessor test-lambda
+                :documentation "The function to run.")
+   (runtime-package :initarg :runtime-package :accessor runtime-package
+                    :documentation "By default it stores *package* from the time this test was defined (macroexpanded)."))
+  (:documentation "A test case is a single, named, collection of
+checks.
+
+A test case is the smallest organizational element which can be
+run individually. Every test case has a name, which is a symbol,
+a description and a test lambda. The test lambda is a regular
+funcall'able function which should use the various checking
+macros to collect results.
+
+Every test case is part of a suite, when a suite is not
+explicitly specified (either via the :SUITE parameter to the TEST
+macro or the global variable *SUITE*) the test is inserted into
+the global suite named NIL.
+
+Sometimes we want to run a certain test only if another test has
+passed. FiveAM allows us to specify the ways in which one test is
+dependent on another.
+
+- AND Run this test only if all the named tests passed.
+
+- OR Run this test if at least one of the named tests passed.
+
+- NOT Run this test only if another test has failed.
+
+FiveAM considers a test to have passed if all the checks executed
+were successful, otherwise we consider the test a failure.
+
+When a test is not run due to it's dependencies having failed a
+test-skipped result is added to the results."))
+
+(defclass explainer ()
+  ())
+
+(defclass text-explainer (explainer)
+  ())
+
+(defclass simple-text-explainer (text-explainer)
+  ())
+
+(defclass detailed-text-explainer (text-explainer)
+  ())
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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
diff --git a/src/explain.lisp b/src/explain.lisp
new file mode 100644
index 000000000000..015cdf45521a
--- /dev/null
+++ b/src/explain.lisp
@@ -0,0 +1,133 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Analyzing the results
+
+(defparameter *verbose-failures* nil
+  "T if we should print the expression failing, NIL otherwise.")
+
+;;;; Just as important as defining and runnig the tests is
+;;;; understanding the results. FiveAM provides the function EXPLAIN
+;;;; which prints a human readable summary (number passed, number
+;;;; failed, what failed and why, etc.) of a list of test results.
+
+(defgeneric explain (explainer results &optional stream recursive-depth)
+  (:documentation "Given a list of test results report write to stream detailed
+ human readable statistics regarding the results."))
+
+(defmethod explain ((exp detailed-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  (multiple-value-bind (num-checks passed num-passed passed%
+                                   skipped num-skipped skipped%
+                                   failed num-failed failed%
+                                   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed))
+    (flet ((output (&rest format-args)
+             (format stream "~&~vT" recursive-depth)
+             (apply #'format stream format-args)))
+
+      (when (zerop num-checks)
+        (output "Didn't run anything...huh?")
+        (return-from explain nil))
+      (output "Did ~D check~P.~%" num-checks num-checks)
+      (output "   Pass: ~D (~2D%)~%" num-passed passed%)
+      (output "   Skip: ~D (~2D%)~%" num-skipped skipped%)
+      (output "   Fail: ~D (~2D%)~%" num-failed failed%)
+      (when unknown
+        (output "   UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%))
+      (terpri stream)
+      (when failed
+        (output "Failure Details:~%")
+        (dolist (f (reverse failed))
+          (output "--------------------------------~%")
+          (output "~A ~@{[~A]~}: ~%"
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "     ~A.~%" (reason f))
+          (when (for-all-test-failed-p f)
+            (output "Results collected with failure data:~%")
+            (explain exp (slot-value f 'result-list)
+                     stream (+ 4 recursive-depth)))
+          (when (and *verbose-failures* (test-expr f))
+            (output "    ~S~%" (test-expr f)))
+          (output "--------------------------------~%"))
+        (terpri stream))
+      (when skipped
+        (output "Skip Details:~%")
+        (dolist (f skipped)
+          (output "~A ~@{[~A]~}: ~%"
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "    ~A.~%" (reason f)))
+        (terpri stream)))))
+
+(defmethod explain ((exp simple-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  (multiple-value-bind (num-checks passed num-passed passed%
+                                   skipped num-skipped skipped%
+                                   failed num-failed failed%
+                                   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%))
+    (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed)
+    (when (plusp num-skipped)
+      (format stream ", ~D skipped " num-skipped))
+    (format stream " and ~D failed.~%" num-failed)
+    (when (plusp num-unknown)
+      (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown))))
+
+(defun partition-results (results-list)
+  (let ((num-checks (length results-list)))
+    (destructuring-bind (passed skipped failed unknown)
+        (partitionx results-list
+                    (lambda (res)
+                      (typep res 'test-passed))
+                    (lambda (res)
+                      (typep res 'test-skipped))
+                    (lambda (res)
+                      (typep res 'test-failure))
+                    t)
+      (if (zerop num-checks)
+          (values 0
+                  nil 0 0
+                  nil 0 0
+                  nil 0 0
+                  nil 0 0)
+          (values
+           num-checks
+           passed (length passed) (floor (* 100 (/ (length passed) num-checks)))
+           skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks)))
+           failed (length failed) (floor (* 100 (/ (length failed) num-checks)))
+           unknown (length unknown) (floor (* 100 (/ (length failed) num-checks))))))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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
diff --git a/src/fixture.lisp b/src/fixture.lisp
new file mode 100644
index 000000000000..26e993304fd9
--- /dev/null
+++ b/src/fixture.lisp
@@ -0,0 +1,82 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; ** Fixtures
+
+;;;; When running tests we often need to setup some kind of context
+;;;; (create dummy db connections, simulate an http request,
+;;;; etc.). Fixtures provide a way to conviently hide this context
+;;;; into a macro and allow the test to focus on testing.
+
+;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term
+;;;; 'fixture' is so common in testing frameworks we've provided a
+;;;; wrapper around defmacro for this purpose.
+
+(defvar *fixture*
+  (make-hash-table :test 'eql)
+  "Lookup table mapping fixture names to fixture
+  objects.")
+
+(defun get-fixture (key &optional default)
+  (gethash key *fixture* default))
+
+(defun (setf get-fixture) (value key)
+  (setf (gethash key *fixture*) value))
+
+(defun rem-fixture (key)
+  (remhash key *fixture*))
+
+(defmacro def-fixture (name (&rest args) &body body)
+  "Defines a fixture named NAME. A fixture is very much like a
+macro but is used only for simple templating. A fixture created
+with DEF-FIXTURE is a macro which can use the special macrolet
+&BODY to specify where the body should go.
+
+See Also: WITH-FIXTURE
+"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (get-fixture ',name) (cons ',args ',body))
+     ',name))
+
+(defmacro with-fixture (fixture-name (&rest args) &body body)
+  "Insert BODY into the fixture named FIXTURE-NAME.
+
+See Also: DEF-FIXTURE"
+  (assert (get-fixture fixture-name)
+          (fixture-name)
+          "Unknown fixture ~S." fixture-name)
+  (destructuring-bind ((&rest largs) &rest lbody)
+      (get-fixture fixture-name)
+    `(macrolet ((&body () '(progn ,@body)))
+       (funcall (lambda (,@largs) ,@lbody) ,@args))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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.
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 000000000000..3279a9a4f7fc
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,139 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+;;;; * Introduction
+
+;;;; FiveAM is a testing framework. It takes care of all the boring
+;;;; bookkeeping associated with managing a test framework allowing
+;;;; the developer to focus on writing tests and code.
+
+;;;; FiveAM was designed with the following premises:
+
+;;;; - Defining tests should be about writing tests, not
+;;;; infrastructure. The developer should be able to focus on what
+;;;; they're testing, not the testing framework.
+
+;;;; - Interactive testing is the norm. Common Lisp is an interactive
+;;;; development environment, the testing environment should allow the
+;;;; developer to quickly and easily redefine, change, remove and run
+;;;; tests.
+
+(defpackage :it.bese.fiveam
+  (:use :common-lisp :alexandria)
+  (:nicknames :5am :fiveam)
+  #+sb-package-locks
+  (:lock t)
+  (:export
+   ;; creating tests and test-suites
+   #:make-suite
+   #:def-suite
+   #:def-suite*
+   #:in-suite
+   #:in-suite*
+   #:test
+   #:def-test
+   #:get-test
+   #:rem-test
+   #:test-names
+   #:*default-test-compilation-time*
+   ;; fixtures
+   #:def-fixture
+   #:with-fixture
+   #:get-fixture
+   #:rem-fixture
+   ;; running checks
+   #:is
+   #:is-every
+   #:is-true
+   #:is-false
+   #:signals
+   #:finishes
+   #:skip
+   #:pass
+   #:fail
+   #:*test-dribble*
+   #:for-all
+   #:*num-trials*
+   #:*max-trials*
+   #:gen-integer
+   #:gen-float
+   #:gen-character
+   #:gen-string
+   #:gen-list
+   #:gen-tree
+   #:gen-buffer
+   #:gen-one-element
+   ;; running tests
+   #:run
+   #:run-all-tests
+   #:explain
+   #:explain!
+   #:run!
+   #:debug!
+   #:!
+   #:!!
+   #:!!!
+   #:*run-test-when-defined*
+   #:*debug-on-error*
+   #:*debug-on-failure*
+   #:*on-error*
+   #:*on-failure*
+   #:*verbose-failures*
+   #:*print-names*
+   #:results-status))
+
+;;;; You can use #+5am to put your test-defining code inline with your
+;;;; other code - and not require people to have fiveam to run your
+;;;; package.
+
+(pushnew :5am *features*)
+
+;;;;@include "check.lisp"
+
+;;;;@include "random.lisp"
+
+;;;;@include "fixture.lisp"
+
+;;;;@include "test.lisp"
+
+;;;;@include "suite.lisp"
+
+;;;;@include "run.lisp"
+
+;;;;@include "explain.lisp"
+
+;;;; * Colophon
+
+;;;; This documentaion was written by Edward Marco Baringer
+;;;; <mb@bese.it> and generated by qbook.
+
+;;;; ** COPYRIGHT
+
+;;;; Copyright (c) 2002-2003, Edward Marco Baringer
+;;;; All rights reserved.
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;  - Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+
+;;;;  - 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.
+
+;;;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;;;    of its contributors may 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
diff --git a/src/random.lisp b/src/random.lisp
new file mode 100644
index 000000000000..49e14bc8a880
--- /dev/null
+++ b/src/random.lisp
@@ -0,0 +1,265 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; ** Random (QuickCheck-ish) testing
+
+;;;; FiveAM provides the ability to automatically generate a
+;;;; collection of random input data for a specific test and run a
+;;;; test multiple times.
+
+;;;; Specification testing is done through the FOR-ALL macro. This
+;;;; macro will bind variables to random data and run a test body a
+;;;; certain number of times. Should the test body ever signal a
+;;;; failure we stop running and report what values of the variables
+;;;; caused the code to fail.
+
+;;;; The generation of the random data is done using "generator
+;;;; functions" (see below for details). A generator function is a
+;;;; function which creates, based on user supplied parameters, a
+;;;; function which returns random data. In order to facilitate
+;;;; generating good random data the FOR-ALL macro also supports guard
+;;;; conditions and creating one random input based on the values of
+;;;; another (see the FOR-ALL macro for details).
+
+;;;; *** Public Interface to the Random Tester
+
+(defparameter *num-trials* 100
+  "Number of times we attempt to run the body of the FOR-ALL test.")
+
+(defparameter *max-trials* 10000
+  "Number of total times we attempt to run the body of the
+  FOR-ALL test including when the body is skipped due to failed
+  guard conditions.
+
+Since we have guard conditions we may get into infinite loops
+where the test code is never run due to the guards never
+returning true. This second run limit prevents that.")
+
+(defmacro for-all (bindings &body body)
+  "Bind BINDINGS to random variables and test BODY *num-trials* times.
+
+BINDINGS is a list of binding forms, each element is a list
+of (BINDING VALUE &optional GUARD). Value, which is evaluated
+once when the for-all is evaluated, must return a generator which
+be called each time BODY is evaluated. BINDING is either a symbol
+or a list which will be passed to destructuring-bind. GUARD is a
+form which, if present, stops BODY from executing when IT returns
+NIL. The GUARDS are evaluated after all the random data has been
+generated and they can refer to the current value of any
+binding. NB: Generator forms, unlike guard forms, can not contain
+references to the bound variables.
+
+Examples:
+
+  (for-all ((a (gen-integer)))
+    (is (integerp a)))
+
+  (for-all ((a (gen-integer) (plusp a)))
+    (is (integerp a))
+    (is (plusp a)))
+
+  (for-all ((less (gen-integer))
+            (more (gen-integer) (< less more)))
+    (is (<= less more)))
+
+  (for-all (((a b) (gen-two-integers)))
+    (is (integerp a))
+    (is (integerp b)))"
+  (with-gensyms (test-lambda-args)
+    `(perform-random-testing
+      (list ,@(mapcar #'second bindings))
+      (lambda (,test-lambda-args)
+        (destructuring-bind ,(mapcar #'first bindings)
+            ,test-lambda-args
+          (if (and ,@(delete-if #'null (mapcar #'third bindings)))
+              (progn ,@body)
+              (throw 'run-once
+                (list :guard-conditions-failed))))))))
+
+;;;; *** Implementation
+
+;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be
+;;;; a preproccessor for the perform-random-testing function is
+;;;; actually much easier.
+
+(defun perform-random-testing (generators body)
+  (loop
+     with random-state = *random-state*
+     with total-counter = *max-trials*
+     with counter = *num-trials*
+     with run-at-least-once = nil
+     until (or (zerop total-counter)
+               (zerop counter))
+     do (let ((result (perform-random-testing/run-once generators body)))
+          (ecase (first result)
+            (:pass
+             (decf counter)
+             (decf total-counter)
+             (setf run-at-least-once t))
+            (:no-tests
+             (add-result 'for-all-test-no-tests
+                         :reason "No tests"
+                         :random-state random-state)
+             (return-from perform-random-testing nil))
+            (:guard-conditions-failed
+             (decf total-counter))
+            (:fail
+             (add-result 'for-all-test-failed
+                         :reason "Found failing test data"
+                         :random-state random-state
+                         :failure-values (second result)
+                         :result-list (third result))
+             (return-from perform-random-testing nil))))
+     finally (if run-at-least-once
+                 (add-result 'for-all-test-passed)
+                 (add-result 'for-all-test-never-run
+                             :reason "Guard conditions never passed"))))
+
+(defun perform-random-testing/run-once (generators body)
+  (catch 'run-once
+    (bind-run-state ((result-list '()))
+      (let ((values (mapcar #'funcall generators)))
+        (funcall body values)
+        (cond
+          ((null result-list)
+           (throw 'run-once (list :no-tests)))
+          ((every #'test-passed-p result-list)
+           (throw 'run-once (list :pass)))
+          ((notevery #'test-passed-p result-list)
+           (throw 'run-once (list :fail values result-list))))))))
+
+(defclass for-all-test-result ()
+  ((random-state :initarg :random-state)))
+
+(defclass for-all-test-passed (test-passed for-all-test-result)
+  ())
+
+(defclass for-all-test-failed (test-failure for-all-test-result)
+  ((failure-values :initarg :failure-values)
+   (result-list :initarg :result-list)))
+
+(defgeneric for-all-test-failed-p (object)
+  (:method ((object for-all-test-failed)) t)
+  (:method ((object t)) nil))
+
+(defmethod reason ((result for-all-test-failed))
+  (format nil "Falsifiable with ~S" (slot-value result 'failure-values)))
+
+(defclass for-all-test-no-tests (test-failure for-all-test-result)
+  ())
+
+(defclass for-all-test-never-run (test-failure for-all-test-result)
+  ())
+
+;;;; *** Generators
+
+;;;; Since this is random testing we need some way of creating random
+;;;; data to feed to our code. Generators are regular functions which
+;;;; create this random data.
+
+;;;; We provide a set of built-in generators.
+
+(defun gen-integer (&key (max (1+ most-positive-fixnum))
+                         (min (1- most-negative-fixnum)))
+  "Returns a generator which produces random integers greater
+than or equal to MIN and less than or equal to MAX."
+  (lambda ()
+    (+ min (random (1+ (- max min))))))
+
+(defun gen-float (&key bound (type 'short-float))
+  "Returns a generator which produces floats of type TYPE. BOUND,
+if specified, constrains the results to be in the range (-BOUND,
+BOUND)."
+  (lambda ()
+    (let* ((most-negative (ecase type
+                            (short-float most-negative-short-float)
+                            (single-float most-negative-single-float)
+                            (double-float most-negative-double-float)
+                            (long-float most-negative-long-float)))
+           (most-positive (ecase type
+                            (short-float most-positive-short-float)
+                            (single-float most-positive-single-float)
+                            (double-float most-positive-double-float)
+                            (long-float most-positive-long-float)))
+           (bound (or bound (max most-positive (- most-negative)))))
+      (coerce
+       (ecase (random 2)
+         (0 ;; generate a positive number
+          (random (min most-positive bound)))
+         (1 ;; generate a negative number
+          (- (random (min (- most-negative) bound)))))
+       type))))
+
+(defun gen-character (&key (code-limit char-code-limit)
+                           (code (gen-integer :min 0 :max (1- code-limit)))
+                           (alphanumericp nil))
+  "Returns a generator of characters.
+
+CODE must be a generator of random integers. ALPHANUMERICP, if
+non-NIL, limits the returned chars to those which pass
+alphanumericp."
+  (lambda ()
+    (loop
+       for count upfrom 0
+       for char = (code-char (funcall code))
+       until (and char
+                  (or (not alphanumericp)
+                      (alphanumericp char)))
+       when (= 1000 count)
+       do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(."
+                 code alphanumericp)
+       finally (return char))))
+
+(defun gen-string (&key (length (gen-integer :min 0 :max 80))
+                        (elements (gen-character))
+                        (element-type 'character))
+  "Returns a generator which produces random strings. LENGTH must
+be a generator which produces integers, ELEMENTS must be a
+generator which produces characters of type ELEMENT-TYPE."
+  (lambda ()
+    (loop
+       with length = (funcall length)
+       with string = (make-string length :element-type element-type)
+       for index below length
+       do (setf (aref string index) (funcall elements))
+       finally (return string))))
+
+(defun gen-list (&key (length (gen-integer :min 0 :max 10))
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which produces random lists. LENGTH must be
+an integer generator and ELEMENTS must be a generator which
+produces objects."
+  (lambda ()
+    (loop
+       repeat (funcall length)
+       collect (funcall elements))))
+
+(defun gen-tree (&key (size 20)
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which produces random trees. SIZE controls
+the approximate size of the tree, but don't try anything above
+ 30, you have been warned. ELEMENTS must be a generator which
+will produce the elements."
+  (labels ((rec (&optional (current-depth 0))
+             (let ((key (random (+ 3 (- size current-depth)))))
+               (cond ((> key 2)
+                      (list (rec (+ current-depth 1))
+                            (rec (+ current-depth 1))))
+                     (t (funcall elements))))))
+    (lambda ()
+      (rec))))
+
+(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
+                        (element-type '(unsigned-byte 8))
+                        (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
+  (lambda ()
+    (let ((buffer (make-array (funcall length) :element-type element-type)))
+      (map-into buffer elements))))
+
+(defun gen-one-element (&rest elements)
+  (lambda ()
+    (nth (random (length elements)) elements)))
+
+;;;; The trivial always-produce-the-same-thing generator is done using
+;;;; cl:constantly.
diff --git a/src/run.lisp b/src/run.lisp
new file mode 100644
index 000000000000..89c522351504
--- /dev/null
+++ b/src/run.lisp
@@ -0,0 +1,385 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Running Tests
+
+;;;; Once the programmer has defined what the tests are these need to
+;;;; be run and the expected effects should be compared with the
+;;;; actual effects. FiveAM provides the function RUN for this
+;;;; purpose, RUN executes a number of tests and collects the results
+;;;; of each individual check into a list which is then
+;;;; returned. There are three types of test results: passed, failed
+;;;; and skipped, these are represented by TEST-RESULT objects.
+
+;;;; Generally running a test will return normally, but there are two
+;;;; exceptional situations which can occur:
+
+;;;; - An exception is signaled while running the test. If the
+;;;;   variable *on-error* is :DEBUG than FiveAM will enter the
+;;;;   debugger, otherwise a test failure (of type
+;;;;   unexpected-test-failure) is returned. When entering the
+;;;;   debugger two restarts are made available, one simply reruns the
+;;;;   current test and another signals a test-failure and continues
+;;;;   with the remaining tests.
+
+;;;; - A circular dependency is detected. An error is signaled and a
+;;;;   restart is made available which signals a test-skipped and
+;;;;   continues with the remaining tests. This restart also sets the
+;;;;   dependency status of the test to nil, so any tests which depend
+;;;;   on this one (even if the dependency is not circular) will be
+;;;;   skipped.
+
+;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
+;;;; RUN and EXPLAIN.
+
+(deftype on-problem-action ()
+  '(member :debug :backtrace nil))
+
+(declaim (type on-problem-action *on-error* *on-failure*))
+
+(defvar *on-error* nil
+  "The action to perform on error:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *on-failure* nil
+  "The action to perform on check failure:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *debug-on-error* nil
+  "T if we should drop into the debugger on error, NIL otherwise.
+OBSOLETE: superseded by *ON-ERROR*")
+
+(defvar *debug-on-failure* nil
+  "T if we should drop into the debugger on a failing check, NIL otherwise.
+OBSOLETE: superseded by *ON-FAILURE*")
+
+(defparameter *print-names* t
+  "T if we should print test running progress, NIL otherwise.")
+
+(defparameter *test-dribble-indent* (make-array 0
+                                        :element-type 'character
+                                        :fill-pointer 0
+                                        :adjustable t)
+  "Used to indent tests and test suites in their parent suite")
+
+(defun import-testing-symbols (package-designator)
+  (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
+          package-designator))
+
+(defparameter *run-queue* '()
+  "List of test waiting to be run.")
+
+(define-condition circular-dependency (error)
+  ((test-case :initarg :test-case))
+  (:report (lambda (cd stream)
+             (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case))))
+  (:documentation "Condition signaled when a circular dependency
+between test-cases has been detected."))
+
+(defgeneric run-resolving-dependencies (test)
+  (:documentation "Given a dependency spec determine if the spec
+is satisfied or not, this will generally involve running other
+tests. If the dependency spec can be satisfied the test is also
+run."))
+
+(defmethod run-resolving-dependencies ((test test-case))
+  "Return true if this test, and its dependencies, are satisfied,
+  NIL otherwise."
+  (case (status test)
+    (:unknown
+     (setf (status test) :resolving)
+     (if (or (not (depends-on test))
+             (eql t (resolve-dependencies (depends-on test))))
+         (progn
+           (run-test-lambda test)
+           (status test))
+         (with-run-state (result-list)
+           (unless (eql :circular (status test))
+             (push (make-instance 'test-skipped
+                                  :test-case test
+                                  :reason "Dependencies not satisfied")
+                   result-list)
+             (setf (status test) :depends-not-satisfied)))))
+    (:resolving
+     (restart-case
+         (error 'circular-dependency :test-case test)
+       (skip ()
+         :report (lambda (s)
+                   (format s "Skip the test ~S and all its dependencies." (name test)))
+         (with-run-state (result-list)
+           (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
+                 result-list))
+         (setf (status test) :circular))))
+    (t (status test))))
+
+(defgeneric resolve-dependencies (depends-on))
+
+(defmethod resolve-dependencies ((depends-on symbol))
+  "A test which depends on a symbol is interpreted as `(AND
+  ,DEPENDS-ON)."
+  (run-resolving-dependencies (get-test depends-on)))
+
+(defmethod resolve-dependencies ((depends-on list))
+  "Return true if the dependency spec DEPENDS-ON is satisfied,
+  nil otherwise."
+  (if (null depends-on)
+      t
+      (flet ((satisfies-depends-p (test)
+               (funcall test (lambda (dep)
+                               (eql t (resolve-dependencies dep)))
+                        (cdr depends-on))))
+        (ecase (car depends-on)
+          (and (satisfies-depends-p #'every))
+          (or  (satisfies-depends-p #'some))
+          (not (satisfies-depends-p #'notany))
+          (:before (every #'(lambda (dep)
+                              (let ((status (status (get-test dep))))
+                                (if (eql :unknown status)
+                                    (run-resolving-dependencies (get-test dep))
+                                    status)))
+                          (cdr depends-on)))))))
+
+(defun results-status (result-list)
+  "Given a list of test results (generated while running a test)
+  return true if no results are of type TEST-FAILURE.  Returns second
+  and third values, which are the set of failed tests and skipped
+  tests respectively."
+  (let ((failed-tests
+          (remove-if-not #'test-failure-p result-list))
+        (skipped-tests
+          (remove-if-not #'test-skipped-p result-list)))
+    (values (null failed-tests)
+            failed-tests
+            skipped-tests)))
+
+(defun return-result-list (test-lambda)
+  "Run the test function TEST-LAMBDA and return a list of all
+  test results generated, does not modify the special environment
+  variable RESULT-LIST."
+  (bind-run-state ((result-list '()))
+    (funcall test-lambda)
+    result-list))
+
+(defgeneric run-test-lambda (test))
+
+(defmethod run-test-lambda ((test test-case))
+  (with-run-state (result-list)
+    (bind-run-state ((current-test test))
+      (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e)))
+                 (add-result 'unexpected-test-failure
+                             :test-expr nil
+                             :test-case test
+                             :reason reason
+                             :condition e))
+               (run-it ()
+                 (let ((result-list '()))
+                   (declare (special result-list))
+                   (handler-bind ((check-failure (lambda (e)
+                                                   (declare (ignore e))
+                                                   (cond
+                                                     ((eql *on-failure* :debug)
+                                                      nil)
+                                                     (t
+                                                      (when (eql *on-failure* :backtrace)
+                                                        (trivial-backtrace:print-backtrace-to-stream
+                                                         *test-dribble*))
+                                                      (invoke-restart
+                                                       (find-restart 'ignore-failure))))))
+                                  (error (lambda (e)
+                                           (unless (or (eql *on-error* :debug)
+                                                       (typep e 'check-failure))
+                                             (when (eql *on-error* :backtrace)
+                                               (trivial-backtrace:print-backtrace-to-stream
+                                                *test-dribble*))
+                                             (abort-test e)
+                                             (return-from run-it result-list)))))
+                     (restart-case
+                         (handler-case
+                             (let ((*readtable* (copy-readtable))
+                                   (*package* (runtime-package test)))
+                               (when *print-names*
+                                   (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test)))
+                               (if (collect-profiling-info test)
+                                   ;; Timing info doesn't get collected ATM, we need a portable library
+                                   ;; (setf (profiling-info test) (collect-timing (test-lambda test)))
+                                   (funcall (test-lambda test))
+                                   (funcall (test-lambda test))))
+                           (storage-condition (e)
+                             ;; heap-exhausted/constrol-stack-exhausted
+                             ;; handler-case unwinds the stack (unlike handler-bind)
+                             (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e))
+                             (return-from run-it result-list)))
+                       (retest ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Rerun the test ~S~@:>" test))
+                         (return-from run-it (run-it)))
+                       (ignore ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+                         (abort-test (make-instance 'test-failure :test-case test
+                                                                  :reason "Failure restart."))))
+                     result-list))))
+        (let ((results (run-it)))
+          (setf (status test) (results-status results)
+                result-list (nconc result-list results)))))))
+
+(defgeneric %run (test-spec)
+  (:documentation "Internal method for running a test. Does not
+  update the status of the tests nor the special variables !,
+  !!, !!!"))
+
+(defmethod %run ((test test-case))
+  (run-resolving-dependencies test))
+
+(defmethod %run ((tests list))
+  (mapc #'%run tests))
+
+(defmethod %run ((suite test-suite))
+  (when *print-names*
+    (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite)))
+  (let ((suite-results '()))
+    (flet ((run-tests ()
+             (loop
+                for test being the hash-values of (tests suite)
+                do (%run test))))
+      (vector-push-extend #\space *test-dribble-indent*)
+      (unwind-protect
+           (bind-run-state ((result-list '()))
+             (unwind-protect
+                  (if (collect-profiling-info suite)
+                      ;; Timing info doesn't get collected ATM, we need a portable library
+                      ;; (setf (profiling-info suite) (collect-timing #'run-tests))
+                      (run-tests)
+                      (run-tests)))
+             (setf suite-results result-list
+                   (status suite) (every #'test-passed-p suite-results)))
+        (vector-pop *test-dribble-indent*)
+        (with-run-state (result-list)
+          (setf result-list (nconc result-list suite-results)))))))
+
+(defmethod %run ((test-name symbol))
+  (when-let (test (get-test test-name))
+    (%run test)))
+
+(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
+
+(defvar *!* *initial-!*)
+(defvar *!!* *initial-!*)
+(defvar *!!!* *initial-!*)
+
+;;;; ** Public entry points
+
+(defun run! (&optional (test-spec *suite*)
+             &key ((:print-names *print-names*) *print-names*))
+  "Equivalent to (explain! (run TEST-SPEC))."
+  (explain! (run test-spec)))
+
+(defun explain! (result-list)
+  "Explain the results of RESULT-LIST using a
+detailed-text-explainer with output going to *test-dribble*.
+Return a boolean indicating whether no tests failed."
+  (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*)
+  (results-status result-list))
+
+(defun debug! (&optional (test-spec *suite*))
+  "Calls (run! test-spec) but enters the debugger if any kind of error happens."
+  (let ((*on-error* :debug)
+        (*on-failure* :debug))
+    (run! test-spec)))
+
+(defun run (test-spec &key ((:print-names *print-names*) *print-names*))
+  "Run the test specified by TEST-SPEC.
+
+TEST-SPEC can be either a symbol naming a test or test suite, or
+a testable-object object. This function changes the operations
+performed by the !, !! and !!! functions."
+  (psetf *!* (lambda ()
+               (loop :for test :being :the :hash-keys :of *test*
+                     :do (setf (status (get-test test)) :unknown))
+               (bind-run-state ((result-list '()))
+                 (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
+                   (%run test-spec))
+                 result-list))
+         *!!* *!*
+         *!!!* *!!*)
+  (let ((*on-error*
+          (or *on-error* (cond
+                           (*debug-on-error*
+                            (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.")
+                            :debug)
+                           (t nil))))
+        (*on-failure*
+          (or *on-failure* (cond
+                           (*debug-on-failure*
+                            (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.")
+                            :debug)
+                           (t nil)))))
+    (funcall *!*)))
+
+(defun ! ()
+  "Rerun the most recently run test and explain the results."
+  (explain! (funcall *!*)))
+
+(defun !! ()
+  "Rerun the second most recently run test and explain the results."
+  (explain! (funcall *!!*)))
+
+(defun !!! ()
+  "Rerun the third most recently run test and explain the results."
+  (explain! (funcall *!!!*)))
+
+(defun run-all-tests (&key (summary :end))
+  "Runs all defined test suites, T if all tests passed and NIL otherwise.
+SUMMARY can be :END to print a summary at the end, :SUITE to print it
+after each suite or NIL to skip explanations."
+  (check-type summary (member nil :suite :end))
+  (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=))
+        :for results := (if (suite-emptyp suite) nil (run suite))
+        :when (consp results)
+          :collect results :into all-results
+        :do (cond
+              ((not (eql summary :suite))
+               nil)
+              (results
+               (explain! results))
+              (suite
+               (format *test-dribble* "Suite ~A is empty~%" suite)))
+        :finally (progn
+                   (when (eql summary :end)
+                     (explain! (alexandria:flatten all-results)))
+                   (return (every #'results-status all-results)))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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.
diff --git a/src/style.css b/src/style.css
new file mode 100644
index 000000000000..4a1e6010dce5
--- /dev/null
+++ b/src/style.css
@@ -0,0 +1,64 @@
+body {
+  background-color: #FFFFFF;
+  color: #000000;
+  padding: 0px; margin: 0px;
+}
+
+.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; 
+         border-left: 3em solid #660000; padding: 3px; }
+
+h1 { text-align: center; margin: 0px;
+     color: #333333; 
+     border-bottom: 0.3em solid #660000; 
+}
+
+p { padding-left: 1em; }
+
+h2 { border-bottom: 0.2em solid #000000; font-family: verdana; }
+
+h3 { border-bottom: 0.1em solid #000000; }
+
+pre.code {
+	background-color: #eeeeee;
+	border: solid 1px #d0d0d0;
+        overflow: auto;
+}
+
+pre.code * .paren { color: #666666; } 
+
+pre.code a:active  { color: #000000; }
+pre.code a:link    { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+div.contents { font-family: verdana; }
+
+div.contents a:active  { color: #000000; }
+div.contents a:link    { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active  { color: #660000; }
+div.contents div.contents-heading-1 a:link    { color: #660000; }
+div.contents div.contents-heading-1 a:visited { color: #660000; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active  { color: #660000; }
+div.contents div.contents-heading-2 a:link    { color: #660000; }
+div.contents div.contents-heading-2 a:visited { color: #660000; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active  { color: #660000; }
+div.contents div.contents-heading-3 a:link    { color: #660000; }
+div.contents div.contents-heading-3 a:visited { color: #660000; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active  { color: #660000; }
+div.contents div.contents-heading-4 a:link    { color: #660000; }
+div.contents div.contents-heading-4 a:visited { color: #660000; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active  { color: #660000; }
+div.contents div.contents-heading-5 a:link    { color: #660000; }
+div.contents div.contents-heading-5 a:visited { color: #660000; }
diff --git a/src/suite.lisp b/src/suite.lisp
new file mode 100644
index 000000000000..8497a9d12ddc
--- /dev/null
+++ b/src/suite.lisp
@@ -0,0 +1,140 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Test Suites
+
+;;;; Test suites allow us to collect multiple tests into a single
+;;;; object and run them all using asingle name. Test suites do not
+;;;; affect the way test are run nor the way the results are handled,
+;;;; they are simply a test organizing group.
+
+;;;; Test suites can contain both tests and other test suites. Running
+;;;; a test suite causes all of its tests and test suites to be
+;;;; run. Suites do not affect test dependencies, running a test suite
+;;;; can cause tests which are not in the suite to be run.
+
+;;;; ** Current Suite
+
+(defvar *suite* nil
+  "The current test suite object")
+(net.didierverna.asdf-flv:set-file-local-variable *suite*)
+
+;;;; ** Creating Suits
+
+;; Suites that have no parent suites.
+(defvar *toplevel-suites* nil)
+
+(defgeneric suite-emptyp (suite)
+  (:method ((suite symbol))
+    (suite-emptyp (get-test suite)))
+  (:method ((suite test-suite))
+    (= 0 (hash-table-count (tests suite)))))
+
+(defmacro def-suite (name &key description in)
+  "Define a new test-suite named NAME.
+
+IN (a symbol), if provided, causes this suite te be nested in the
+suite named by IN. NB: This macro is built on top of make-suite,
+as such it, like make-suite, will overrwrite any existing suite
+named NAME."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (make-suite ',name
+                 ,@(when description `(:description ,description))
+                 ,@(when in `(:in ',in)))
+     ',name))
+
+(defmacro def-suite* (name &rest def-suite-args)
+  `(progn
+     (def-suite ,name ,@def-suite-args)
+     (in-suite ,name)))
+
+(defun make-suite (name &key description ((:in parent-suite)))
+  "Create a new test suite object.
+
+Overrides any existing suite named NAME."
+  (let ((suite (make-instance 'test-suite :name name)))
+    (when description
+      (setf (description suite) description))
+    (when (and name
+               (null (name *suite*))
+               (null parent-suite))
+      (pushnew name *toplevel-suites*))
+    (loop for i in (ensure-list parent-suite)
+          for in-suite = (get-test i)
+          do (progn
+               (when (null in-suite)
+                 (cerror "Create a new suite named ~A." "Unknown suite ~A." i)
+                 (setf (get-test in-suite) (make-suite i)
+                       in-suite (get-test in-suite)))
+               (setf (gethash name (tests in-suite)) suite)))
+    (setf (get-test name) suite)
+    suite))
+
+(eval-when (:load-toplevel :execute)
+  (setf *suite*
+        (setf (get-test 'nil)
+              (make-suite 'nil :description "Global Suite"))))
+
+(defun list-all-suites ()
+  "Returns an unordered LIST of all suites."
+  (hash-table-values *suite*))
+
+;;;; ** Managing the Current Suite
+
+(defmacro in-suite (suite-name)
+  "Set the *suite* special variable so that all tests defined
+after the execution of this form are, unless specified otherwise,
+in the test-suite named SUITE-NAME.
+
+See also: DEF-SUITE *SUITE*"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%in-suite ,suite-name)))
+
+(defmacro in-suite* (suite-name &key in)
+  "Just like in-suite, but silently creates missing suites."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%in-suite ,suite-name :in ,in :fail-on-error nil)))
+
+(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+  (with-gensyms (suite)
+    `(progn
+       (if-let (,suite (get-test ',suite-name))
+         (setf *suite* ,suite)
+         (progn
+           (when ,fail-on-error
+             (cerror "Create a new suite named ~A."
+                     "Unknown suite ~A." ',suite-name))
+           (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in)
+                 *suite* (get-test ',suite-name))))
+       ',suite-name)))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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
diff --git a/src/test.lisp b/src/test.lisp
new file mode 100644
index 000000000000..4a6f2fee9a0a
--- /dev/null
+++ b/src/test.lisp
@@ -0,0 +1,167 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Tests
+
+;;;; While executing checks and collecting the results is the core job
+;;;; of a testing framework it is also important to be able to
+;;;; organize checks into groups, fiveam provides two mechanisms for
+;;;; organizing checks: tests and test suites. A test is a named
+;;;; collection of checks which can be run and a test suite is a named
+;;;; collection of tests and test suites.
+
+(declaim (special *suite*))
+
+(defvar *test*
+  (make-hash-table :test 'eql)
+  "Lookup table mapping test (and test suite)
+  names to objects.")
+
+(defun get-test (key &optional default)
+  (gethash key *test* default))
+
+(defun (setf get-test) (value key)
+  (setf (gethash key *test*) value))
+
+(defun rem-test (key)
+  (remhash key *test*))
+
+(defun test-names ()
+  (hash-table-keys *test*))
+
+(defmacro test (name &body body)
+  "Create a test named NAME. If NAME is a list it must be of the
+form:
+
+  (name &key depends-on suite fixture compile-at profile)
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixture to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (destructuring-bind (name &rest args)
+      (ensure-list name)
+    `(def-test ,name (,@args) ,@body)))
+
+(defvar *default-test-compilation-time* :definition-time)
+
+(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
+                            (compile-at *default-test-compilation-time*) profile)
+                    &body body)
+  "Create a test named NAME.
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixture to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (check-type compile-at (member :run-time :definition-time))
+  (multiple-value-bind (forms decls docstring)
+      (parse-body body :documentation t :whole name)
+    (let* ((description (or docstring ""))
+           (body-forms (append decls forms))
+           (suite-form (if suite-p
+                           `(get-test ',suite)
+                           (or suite '*suite*)))
+           (effective-body (if fixture
+                               (destructuring-bind (name &rest args)
+                                   (ensure-list fixture)
+                                 `((with-fixture ,name ,args ,@body-forms)))
+                               body-forms)))
+      `(progn
+         (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile)
+         (when *run-test-when-defined*
+           (run! ',name))
+         ',name))))
+
+(defun register-test (name description body suite depends-on compile-at profile)
+  (let ((lambda-name
+          (format-symbol t "%~A-~A" '#:test name))
+        (inner-lambda-name
+          (format-symbol t "%~A-~A" '#:inner-test name)))
+    (setf (get-test name)
+          (make-instance 'test-case
+                         :name name
+                         :runtime-package (find-package (package-name *package*))
+                         :test-lambda
+                         (eval
+                          `(named-lambda ,lambda-name ()
+                             ,@(ecase compile-at
+                                 (:run-time `((funcall
+                                               (let ((*package* (find-package ',(package-name *package*))))
+                                                 (compile ',inner-lambda-name
+                                                          '(lambda () ,@body))))))
+                                 (:definition-time body))))
+                         :description description
+                         :depends-on depends-on
+                         :collect-profiling-info profile))
+    (setf (gethash name (tests suite)) name)))
+
+(defvar *run-test-when-defined* nil
+  "When non-NIL tests are run as soon as they are defined.")
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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.
diff --git a/src/utils.lisp b/src/utils.lisp
new file mode 100644
index 000000000000..49d552fa000e
--- /dev/null
+++ b/src/utils.lisp
@@ -0,0 +1,226 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+(defmacro dolist* ((iterator list &optional return-value) &body body)
+  "Like DOLIST but destructuring-binds the elements of LIST.
+
+If ITERATOR is a symbol then dolist* is just like dolist EXCEPT
+that it creates a fresh binding."
+  (if (listp iterator)
+      (let ((i (gensym "DOLIST*-I-")))
+        `(dolist (,i ,list ,return-value)
+           (destructuring-bind ,iterator ,i
+             ,@body)))
+      `(dolist (,iterator ,list ,return-value)
+         (let ((,iterator ,iterator))
+           ,@body))))
+
+(defun make-collector (&optional initial-value)
+  "Create a collector function.
+
+A Collector function will collect, into a list, all the values
+passed to it in the order in which they were passed. If the
+callector function is called without arguments it returns the
+current list of values."
+  (let ((value initial-value)
+        (cdr (last initial-value)))
+    (lambda (&rest items)
+      (if items
+          (progn
+            (if value
+                (if cdr
+                    (setf (cdr cdr) items
+                          cdr (last items))
+                    (setf cdr (last items)))
+                (setf value items
+                      cdr (last items)))
+            items)
+          value))))
+
+(defun partitionx (list &rest lambdas)
+  (let ((collectors (mapcar (lambda (l)
+                              (cons (if (and (symbolp l)
+                                             (member l (list :otherwise t)
+                                                     :test #'string=))
+                                        (constantly t)
+                                        l)
+                                    (make-collector)))
+                            lambdas)))
+    (dolist (item list)
+      (block item
+        (dolist* ((test-func . collector-func) collectors)
+          (when (funcall test-func item)
+            (funcall collector-func item)
+            (return-from item)))))
+    (mapcar #'funcall (mapcar #'cdr collectors))))
+
+;;;; ** Anaphoric conditionals
+
+(defmacro if-bind (var test &body then/else)
+  "Anaphoric IF control structure.
+
+VAR (a symbol) will be bound to the primary value of TEST. If
+TEST returns a true value then THEN will be executed, otherwise
+ELSE will be executed."
+  (assert (first then/else)
+          (then/else)
+          "IF-BIND missing THEN clause.")
+  (destructuring-bind (then &optional else)
+      then/else
+    `(let ((,var ,test))
+       (if ,var ,then ,else))))
+
+(defmacro aif (test then &optional else)
+  "Just like IF-BIND but the var is always IT."
+  `(if-bind it ,test ,then ,else))
+
+;;;; ** Simple list matching based on code from Paul Graham's On Lisp.
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (with-gensyms (val foundp)
+        (destructuring-bind ((test &rest progn) &rest others)
+            clauses
+          `(multiple-value-bind (,val ,foundp)
+               ,test
+             (if (or ,val ,foundp)
+                 (let ((it ,val))
+                   (declare (ignorable it))
+                   ,@progn)
+                 (acond2 ,@others)))))))
+
+(defun varsymp (x)
+  (and (symbolp x)
+       (let ((name (symbol-name x)))
+         (and (>= (length name) 2)
+              (char= (char name 0) #\?)))))
+
+(defun binding (x binds)
+  (labels ((recbind (x binds)
+             (aif (assoc x binds)
+                  (or (recbind (cdr it) binds)
+                      it))))
+    (let ((b (recbind x binds)))
+      (values (cdr b) b))))
+
+(defun list-match (x y &optional binds)
+  (acond2
+    ((or (eql x y) (eql x '_) (eql y '_))
+     (values binds t))
+    ((binding x binds) (list-match it y binds))
+    ((binding y binds) (list-match x it binds))
+    ((varsymp x) (values (cons (cons x y) binds) t))
+    ((varsymp y) (values (cons (cons y x) binds) t))
+    ((and (consp x) (consp y) (list-match (car x) (car y) binds))
+     (list-match (cdr x) (cdr y) it))
+    (t (values nil nil))))
+
+(defun vars (match-spec)
+  (let ((vars nil))
+    (labels ((find-vars (spec)
+               (cond
+                 ((null spec) nil)
+                 ((varsymp spec) (push spec vars))
+                 ((consp spec)
+                  (find-vars (car spec))
+                  (find-vars (cdr spec))))))
+      (find-vars match-spec))
+    (delete-duplicates vars)))
+
+(defmacro list-match-case (target &body clauses)
+  (if clauses
+      (destructuring-bind ((test &rest progn) &rest others)
+          clauses
+        (with-gensyms (tgt binds success)
+          `(let ((,tgt ,target))
+             (multiple-value-bind (,binds ,success)
+                 (list-match ,tgt ',test)
+               (declare (ignorable ,binds))
+               (if ,success
+                   (let ,(mapcar (lambda (var)
+                                   `(,var (cdr (assoc ',var ,binds))))
+                                 (vars test))
+                     (declare (ignorable ,@(vars test)))
+                     ,@progn)
+                   (list-match-case ,tgt ,@others))))))
+      nil))
+
+;;;; * def-special-environment
+
+(defun check-required (name vars required)
+  (dolist (var required)
+    (assert (member var vars)
+            (var)
+            "Unrecognized symbol ~S in ~S." var name)))
+
+(defmacro def-special-environment (name (&key accessor binder binder*)
+                                  &rest vars)
+  "Define two macros for dealing with groups or related special variables.
+
+ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest
+BODY)).  Each element of VARS will be bound to the
+current (dynamic) value of the special variable.
+
+BINDER is defined as a macro for introducing (and binding new)
+special variables. It is basically a readable LET form with the
+prorpe declarations appended to the body. The first argument to
+BINDER must be a form suitable as the first argument to LET.
+
+ACCESSOR defaults to a new symbol in the same package as NAME
+which is the concatenation of \"WITH-\" NAME. BINDER is built as
+\"BIND-\" and BINDER* is BINDER \"*\"."
+  (unless accessor
+    (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name)))
+  (unless binder
+    (setf binder   (format-symbol (symbol-package name) "~A-~A" '#:bind name)))
+  (unless binder*
+    (setf binder*  (format-symbol (symbol-package binder) "~A~A" binder '#:*)))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (flet ()
+       (defmacro ,binder (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            ,@body))
+       (defmacro ,binder* (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let* ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            ,@body))
+       (defmacro ,accessor (requested-vars &body body)
+         (check-required ',name ',vars requested-vars)
+         `(locally (declare (special ,@requested-vars))
+            ,@body))
+       ',name)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may 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