[git] CMU Common Lisp branch master updated. snapshot-2014-02-2-g9be8ccb

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp".

The branch, master has been updated via 9be8ccbffdd602b08e0ba12aa59bc0d137dc569d (commit) via b289505a0e52c6c980813467548b20a93c25492b (commit) from c96b5d32cec8300cccfcbcfc25211621a145f527 (commit)

Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below.

- Log ----------------------------------------------------------------- commit 9be8ccbffdd602b08e0ba12aa59bc0d137dc569d Author: Raymond Toy toy.raymond@gmail.com Date: Fri Feb 7 08:12:40 2014 -0800

Add lisp-unit as a module. Use (require :lisp-unit) (or "lisp-unit") to load lisp-unit. This also allows the regression tests to be self-contained so we don't have to have lisp-unit installed via quicklisp or some other means.

Unlike asdf and defsystem, we do not provide a precompiled fasl.

code/module.lisp: * Add defmodule forms for lisp-unit

contrib/load-lisp-unit.lisp: * Module file to compile and load lisp-unit.

diff --git a/src/code/module.lisp b/src/code/module.lisp index 70ccba7..1ba11d8 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -148,6 +148,13 @@ (defmodule "asdf" "modules:asdf/asdf")

+;; Lisp-unit +(defmodule :lisp-unit + "modules:lisp-unit/load-lisp-unit") + +(defmodule "lisp-unit" + "modules:load-lisp-unit") + ;; Allow user to specify "cmu-contribs" or :cmu-contribs. (defmodule "cmu-contribs" "modules:contrib") diff --git a/src/contrib/load-lisp-unit.lisp b/src/contrib/load-lisp-unit.lisp new file mode 100644 index 0000000..4270cfe --- /dev/null +++ b/src/contrib/load-lisp-unit.lisp @@ -0,0 +1,6 @@ +;; Load lisp-unit +(require "asdf") + +(load "modules:lisp-unit/lisp-unit.asd") + +(asdf:oos 'asdf:load-op :lisp-unit)

commit b289505a0e52c6c980813467548b20a93c25492b Author: Raymond Toy toy.raymond@gmail.com Date: Fri Feb 7 08:09:24 2014 -0800

Import lisp-unit. This is the version from quicklisp which marked it as lisp-unit-20130615-git. No changes.

diff --git a/src/contrib/lisp-unit/.gitignore b/src/contrib/lisp-unit/.gitignore new file mode 100644 index 0000000..73f35dd --- /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 0000000..6114a2a --- /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 0000000..3df2b06 --- /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 0000000..43403a6 --- /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 0000000..09653f8 --- /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 0000000..6312be0 --- /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 0000000..2c89e58 --- /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 0000000..818d401 --- /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 0000000..2409eb6 --- /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 0000000..efaae1a --- /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*)

-----------------------------------------------------------------------

Summary of changes: src/code/module.lisp | 7 + src/contrib/lisp-unit/.gitignore | 5 + src/contrib/lisp-unit/README.md | 75 ++ .../lisp-unit/extensions/floating-point.lisp | 818 ++++++++++++++++++ src/contrib/lisp-unit/extensions/rational.lisp | 96 +++ .../extensions/test-anything-protocol.lisp | 86 ++ .../lisp-unit/internal-test/example-tests.lisp | 153 ++++ .../lisp-unit/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 ++++++++++++++++++++ src/contrib/load-lisp-unit.lisp | 6 + 12 files changed, 2479 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 create mode 100644 src/contrib/load-lisp-unit.lisp

hooks/post-receive