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