diff options
Diffstat (limited to 'third_party/lisp/fiveam/src')
| -rw-r--r-- | third_party/lisp/fiveam/src/check.lisp | 311 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/classes.lisp | 128 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/explain.lisp | 133 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/fixture.lisp | 82 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/package.lisp | 139 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/random.lisp | 265 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/run.lisp | 385 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/style.css | 64 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/suite.lisp | 140 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/test.lisp | 167 | ||||
| -rw-r--r-- | third_party/lisp/fiveam/src/utils.lisp | 226 |
11 files changed, 0 insertions, 2040 deletions
diff --git a/third_party/lisp/fiveam/src/check.lisp b/third_party/lisp/fiveam/src/check.lisp deleted file mode 100644 index b3808c5cf04c..000000000000 --- a/third_party/lisp/fiveam/src/check.lisp +++ /dev/null @@ -1,311 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/classes.lisp b/third_party/lisp/fiveam/src/classes.lisp deleted file mode 100644 index fc4dc782e8cb..000000000000 --- a/third_party/lisp/fiveam/src/classes.lisp +++ /dev/null @@ -1,128 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/explain.lisp b/third_party/lisp/fiveam/src/explain.lisp deleted file mode 100644 index 015cdf45521a..000000000000 --- a/third_party/lisp/fiveam/src/explain.lisp +++ /dev/null @@ -1,133 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/fixture.lisp b/third_party/lisp/fiveam/src/fixture.lisp deleted file mode 100644 index 26e993304fd9..000000000000 --- a/third_party/lisp/fiveam/src/fixture.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;; -*- 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/third_party/lisp/fiveam/src/package.lisp b/third_party/lisp/fiveam/src/package.lisp deleted file mode 100644 index 3279a9a4f7fc..000000000000 --- a/third_party/lisp/fiveam/src/package.lisp +++ /dev/null @@ -1,139 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/random.lisp b/third_party/lisp/fiveam/src/random.lisp deleted file mode 100644 index 49e14bc8a880..000000000000 --- a/third_party/lisp/fiveam/src/random.lisp +++ /dev/null @@ -1,265 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/run.lisp b/third_party/lisp/fiveam/src/run.lisp deleted file mode 100644 index 89c522351504..000000000000 --- a/third_party/lisp/fiveam/src/run.lisp +++ /dev/null @@ -1,385 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/style.css b/third_party/lisp/fiveam/src/style.css deleted file mode 100644 index 4a1e6010dce5..000000000000 --- a/third_party/lisp/fiveam/src/style.css +++ /dev/null @@ -1,64 +0,0 @@ -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/third_party/lisp/fiveam/src/suite.lisp b/third_party/lisp/fiveam/src/suite.lisp deleted file mode 100644 index 8497a9d12ddc..000000000000 --- a/third_party/lisp/fiveam/src/suite.lisp +++ /dev/null @@ -1,140 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/test.lisp b/third_party/lisp/fiveam/src/test.lisp deleted file mode 100644 index 4a6f2fee9a0a..000000000000 --- a/third_party/lisp/fiveam/src/test.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;;; -*- 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/third_party/lisp/fiveam/src/utils.lisp b/third_party/lisp/fiveam/src/utils.lisp deleted file mode 100644 index 49d552fa000e..000000000000 --- a/third_party/lisp/fiveam/src/utils.lisp +++ /dev/null @@ -1,226 +0,0 @@ -;;;; -*- 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 |