cmucl-cvs April 2015

cmucl-cvs@common-lisp.net

3 participants
318 discussions

[git] CMU Common Lisp branch master updated. snapshot-2014-06-98-gf05a440
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 f05a4402996b0b7bc7c00c48fa4a27a4b3cf532b (commit) from 6635ef21befd5126c23140d4be12db874577e24c (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 f05a4402996b0b7bc7c00c48fa4a27a4b3cf532b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Aug 5 21:22:10 2014 -0700 Addresses ticket #84 for Linux. * Add -m32 flag to build 32-bit object files and binaries. * Update -L to where the 32-bit X11 libraries are on my OpenSuSE 11.3 system. (This wasn't working before because apparently I didn't actually have the 32-bit X11 libraries installed.) diff --git a/src/motif/server/Config.x86 b/src/motif/server/Config.x86 index ded67cd..bbfb987 100644 --- a/src/motif/server/Config.x86 +++ b/src/motif/server/Config.x86 @@ -1,5 +1,7 @@ -CFLAGS += -O2 -I/usr/X11R6/include -I. -I$(VPATH) -LDFLAGS += -L/usr/X11R6/lib +CFLAGS += -m3 -O2 -I/usr/X11R6/include -I. -I$(VPATH) +# LDFLAGS += -L/usr/X11R6/lib +# On OpenSuSE 11.3,the 32-bit X libraries are in /usr/lib. +LDFLAGS += -L/usr/lib LIBS = -lXm -lXt -lXext -lX11 -lSM -lICE -lXp -ldl -lpthread # This def assumes you are building in the same or parallel # tree to the CVS souce layout. Sites may need to customize ----------------------------------------------------------------------- Summary of changes: src/motif/server/Config.x86 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-60-g28ca349
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 28ca34951c313162068768fb80742254dd7af1b6 (commit) via 70bf595c72a9bb4a400dc6fdab9a269ccde060dd (commit) via 08fd3e4ea1565c8674c837cd9e08b1e24f438d33 (commit) via 8dd3a6aae9b37307eef4d48b740cba9cb265444d (commit) from c2e152be334f9e1272db737e2eb5056e67def8d0 (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 28ca34951c313162068768fb80742254dd7af1b6 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:42:38 2014 -0700 Add some braces to silence the warning from clang about dangling else statements. diff --git a/src/lisp/e_log.c b/src/lisp/e_log.c index 4404ce1..032f794 100644 --- a/src/lisp/e_log.c +++ b/src/lisp/e_log.c @@ -117,8 +117,15 @@ static double zero = 0.0; k += (i>>20); f = x-1.0; if((0x000fffff&(2+hx))<3) { /* |f| < 2**-20 */ - if(f==zero) if(k==0) return zero; else {dk=(double)k; - return dk*ln2_hi+dk*ln2_lo;} + if(f==zero) { + if(k==0) + return zero; + else { + dk=(double)k; + return dk*ln2_hi+dk*ln2_lo; + } + } + R = f*f*(0.5-0.33333333333333333*f); if(k==0) return f-R; else {dk=(double)k; return dk*ln2_hi-((R-dk*ln2_lo)-f);} diff --git a/src/lisp/s_expm1.c b/src/lisp/s_expm1.c index d6a1827..6e35fd8 100644 --- a/src/lisp/s_expm1.c +++ b/src/lisp/s_expm1.c @@ -194,9 +194,10 @@ Q5 = -2.01099218183624371326e-07; /* BE8AFDB7 6E09C32D */ e = (x*(e-c)-c); e -= hxs; if(k== -1) return 0.5*(x-e)-0.5; - if(k==1) + if(k==1) { if(x < -0.25) return -2.0*(e-(x+0.5)); else return one+2.0*(x-e); + } if (k <= -2 || k>56) { /* suffice to return exp(x)-1 */ y = one-(e-x); utmp.d = y; commit 70bf595c72a9bb4a400dc6fdab9a269ccde060dd Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:39:39 2014 -0700 Remove the sccsid variable. diff --git a/src/lisp/e_pow.c b/src/lisp/e_pow.c index 9dafc26..914d7d9 100644 --- a/src/lisp/e_pow.c +++ b/src/lisp/e_pow.c @@ -1,8 +1,3 @@ - -#ifndef lint -static char sccsid[] = "@(#)e_pow.c 1.5 04/04/22 SMI"; -#endif - /* * ==================================================== * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. commit 08fd3e4ea1565c8674c837cd9e08b1e24f438d33 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:38:58 2014 -0700 Initialize k to get rid of a compiler warning from clang. The compiler thinks k might not be initialized because the if on line 143 might not be true, leaving t uninitialized. We know that the condition is always true because |x| < -2^-28 in the previous line. diff --git a/src/lisp/e_exp.c b/src/lisp/e_exp.c index 4d94a1e..3d84224 100644 --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -106,7 +106,8 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ #endif { double y,hi,lo,c,t; - int k,xsb; + int k = 0; + int xsb; unsigned hx; union { int i[2]; double d; } ux; commit 8dd3a6aae9b37307eef4d48b740cba9cb265444d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 13:35:17 2014 -0700 Initialize t to get rid of a compiler warning from clang. The compiler thinks t might not be initialized because the if on line 90 might not be true, leaving t uninitialized. We know that the condition is always true because |x| < -2^-27 in the previous line. diff --git a/src/lisp/e_asin.c b/src/lisp/e_asin.c index 9b476a4..4aa6c63 100644 --- a/src/lisp/e_asin.c +++ b/src/lisp/e_asin.c @@ -73,7 +73,8 @@ qS4 = 7.70381505559019352791e-02; /* 0x3FB3B8C5, 0xB12E9282 */ double x; #endif { - double t,w,p,q,c,r,s; + double t = 0; + double w,p,q,c,r,s; int hx,ix; union { int i[2]; double d; } ux; ----------------------------------------------------------------------- Summary of changes: src/lisp/e_asin.c | 3 ++- src/lisp/e_exp.c | 3 ++- src/lisp/e_log.c | 11 +++++++++-- src/lisp/e_pow.c | 5 ----- src/lisp/s_expm1.c | 3 ++- 5 files changed, 15 insertions(+), 10 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-6-g59c5005
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 59c50055f4538c8ba49f6f8cae403563ea76cfbb (commit) via 78cce51df441b220c071024fb5e616f1928184dd (commit) from 0b5c1254cc522e4e10d0f14ea248cc74b82fae69 (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 59c50055f4538c8ba49f6f8cae403563ea76cfbb Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 18 17:47:39 2013 -0700 Update. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 74e024e..d9aeb5e 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -59,6 +59,7 @@ New in this release: * FILE-POSITION no longer returns incorrect values. See ticket #79. * Fix error in (format t "~ve" 21 5d-324). (See ticket #80). + * String reverse is much faster (upto 20 times) * Trac Tickets: @@ -77,6 +78,8 @@ New in this release: * Ticket #79 fixed. * Ticket #77 fixed. * Ticket #80 fixed. + * Ticket #81 fixed. + * Ticket #83 fixed. * Other changes: * -8 option for build-all.sh is deprecated since we don't commit 78cce51df441b220c071024fb5e616f1928184dd Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat May 18 17:44:02 2013 -0700 Fix ticket:81 and fix ticket:83. From ticket 81, the tests are now: {{{ (time (prog1 t (time-rev *s*))) ; Evaluation took: ; 0.49 seconds of real time ; 0.481813 seconds of user run time ; 0.003624 seconds of system run time ; 1,490,776,936 CPU cycles ; [Run times include 0.13 seconds GC run time] ; 0 page faults and ; 200,073,704 bytes consed. (time (prog1 t (time-rev *s2*))) ; Evaluation took: ; 0.97 seconds of real time ; 0.965893 seconds of user run time ; 0.005139 seconds of system run time ; 2,980,415,911 CPU cycles ; [Run times include 0.23 seconds GC run time] ; 0 page faults and ; 400,005,560 bytes consed. }}} So the new string-reverse* is 20 times faster for strings without surrogates and 10 times faster for strings containing only surrogates. diff --git a/src/code/string.lisp b/src/code/string.lisp index 4b90930..f23db5b 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -1172,13 +1172,24 @@ (type string sequence)) (with-string sequence (let* ((length (- end start)) - (string (make-string length)) - (j length)) - (declare (type kernel:index length j)) - (loop for i = start then n as n = (%glyph-f sequence i) do - (replace string sequence :start1 (decf j (- n i)) :start2 i :end2 n) - while (< n end)) - string))) + (r (make-string length))) + (do ((dst-index (1- length) (1- dst-index)) + (src-index start (1+ src-index))) + ((minusp dst-index)) + (declare (fixnum src-index dst-index)) + (let ((current-char (schar sequence src-index))) + (cond ((and (lisp::surrogatep current-char :leading) + (plusp dst-index)) + ;; Reverse surrogate pairs correctly, which means the + ;; pair isn't reversed at all. + (incf src-index) + (setf (schar r dst-index) (schar sequence src-index)) + (decf dst-index) + (setf (schar r dst-index) current-char)) + (t + ;; Easy case + (setf (schar r dst-index) current-char))))) + r))) #+unicode (defun string-nreverse* (sequence) ----------------------------------------------------------------------- Summary of changes: src/code/string.lisp | 25 ++++++++++++++++++------- src/general-info/release-20e.txt | 3 +++ 2 files changed, 21 insertions(+), 7 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-31-ge48e7e8
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 e48e7e828f77e7013ebf7a7e87ef8055543fc423 (commit) via 14783bb3f300f44ee99e185b4fbfb78a53296833 (commit) from d0aaa33ba7afbd83575e1cb9e23832c3a563ca6d (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 e48e7e828f77e7013ebf7a7e87ef8055543fc423 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 21 22:10:59 2013 -0800 Fix trac.50 to use princ-to-string. diff --git a/tests/trac.lisp b/tests/trac.lisp index 1fd0683..dbe8741 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -59,7 +59,7 @@ (define-test trac.50 (:tag :trac) (assert-equal "#P(:DIRECTORY (:ABSOLUTE \"tmp\" \"\" \"a\" \"\" \"b\"))" - (princ (make-pathname :directory '(:absolute "tmp" "" "a" "" "b"))))) + (princ-to-string (make-pathname :directory '(:absolute "tmp" "" "a" "" "b"))))) (defparameter *trac.70* (make-string 40 :initial-element #\A)) commit 14783bb3f300f44ee99e185b4fbfb78a53296833 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 21 22:08:12 2013 -0800 Add some selected tests from trac bug reports. diff --git a/tests/trac.lisp b/tests/trac.lisp new file mode 100644 index 0000000..1fd0683 --- /dev/null +++ b/tests/trac.lisp @@ -0,0 +1,84 @@ +;;; Tests from trac tickets + +(defpackage :trac-tests + (:use :cl :lisp-unit)) + +(in-package "TRAC-TESTS") + +(define-test trac.1 + (:tag :trac) + (assert-false + (let (failures) + (dotimes (k 1000) + (let ((x (random 1d-3))) + (let ((s (prin1-to-string x)) + (f (format nil "~E" x))) + (unless (string-equal s f) + (push (list x s f) + failures))))) + failures))) + +(define-test trac.8 + (:tag :trac) + (assert-false + (let (failures) + (dolist (base (list nil 2 2.0 2d0 + (ash 1 99) (ash 1 3000) + 8/7 (/ (ash 1 3000) 7))) + (dolist (number (list 100 100.0 100d0 + (ash 1 100) (ash 1 3500) + 50/7 (/ (ash 1 3500) 7))) + (multiple-value-bind (result cond) + (ignore-errors (if base + (log number base) + (log number))) + (unless result + (push (list number base cond) + failures))))) + failures))) + +(define-test trac.10 + (:tag :trac) + (assert-equal '(536870912 0.5d0) + (multiple-value-list (round (+ 536870911 1.5d0))))) + +(define-test trac.11 + (:tag :trac) + (assert-true (eql 0w0 0w0))) + +(define-test trac.12 + (:tag :trac) + (assert-equal " 0.1D-05" + (format nil "~10,1,2,0,'*,,'DE" 1d-6))) + +(define-test trac.13 + (:tag :trac) + (assert-equal " 0.100E+01" + (format nil "~11,3,2,0,'*,,'EE" .9999))) + +(define-test trac.50 + (:tag :trac) + (assert-equal "#P(:DIRECTORY (:ABSOLUTE \"tmp\" \"\" \"a\" \"\" \"b\"))" + (princ (make-pathname :directory '(:absolute "tmp" "" "a" "" "b"))))) + +(defparameter *trac.70* (make-string 40 :initial-element #\A)) + +(compile 'trac.70-test + (lambda (workspace s) + (declare (simple-string workspace s)) + (replace workspace s :start1 1 :end1 5 :start2 1 :end2 5))) + +(define-test trac.76 + (:tag :trac) + (assert-equal "A1234AAAA" + (subseq (trac.70-test *trac.70* "a12345") 0 9))) + +(define-test trac.80 + (:tag :trac) + ;; The following formats should not signal an error. + (assert-true (ignore-errors (format nil "~ve" 21 5d-234))) + (assert-true (ignore-errors (format nil "~ve" 100 5d-234)))) + + + + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: tests/trac.lisp | 84 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 84 insertions(+) create mode 100644 tests/trac.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag 20e created. 20e
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 annotated tag, 20e has been created at 828631213b891de7d4b4ea690123488971d27e1f (tag) tagging bc828bed51339b951d84d2a264adf0221172f126 (commit) replaces snapshot-2013-09 tagged by Raymond Toy on Sat Sep 28 08:04:49 2013 -0700 - Log ----------------------------------------------------------------- CMUCL Release 20e -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlJG8B0ACgkQJ5IjUmgZO7J0LQCgwKZlRTOZ7IcN/7+k3HbR+5q2 IokAniRDnBEPgl6YOyqyOPuW7lipYI3y =N5yQ -----END PGP SIGNATURE----- Raymond Toy (9): Change Sparc default variant to sparc_sunc instead of sparc_gcc. Allow disabling the use of git for the file-comment. Set lvshort to solaris too if lisp_variant=sparc*. Support all sun4 archs, not just sun4u. (sun4v is T1). Update for new documentation. Update for release 20e. Update to date to Oct 2013, 20e. Make :plus-integer actually print + or - as documented. Update for 20e. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-2-g9be8ccb
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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(a)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(a)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(a)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(a)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 -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-27-g7107249
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 7107249f265148e246a9eec84b15cfbe96121594 (commit) from 13f320d9568705f58010d456b957917b2d2c62c6 (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 7107249f265148e246a9eec84b15cfbe96121594 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 31 15:50:44 2014 -0700 Finally remove the Lisp implementation of the trig functions that are now in C. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index c48d09d..7c8b031 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -208,440 +208,6 @@ (declare (ignore ign)) (values s c))) -#|| -;; Implement sin/cos/tan in Lisp. These are based on the routines -;; from fdlibm. - -;; Block compile so the trig routines don't cons their args when -;; calling the kernel trig routines. -(declaim (ext:start-block kernel-sin kernel-cos kernel-tan - %sin %cos %tan - %sincos)) - -;; kernel sin function on [-pi/4, pi/4], pi/4 ~ 0.7854 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; Input iy indicates whether y is 0. (if iy=0, y assume to be 0). -;; -;; Algorithm -;; 1. Since sin(-x) = -sin(x), we need only to consider positive x. -;; 2. if x < 2^-27 (hx<0x3e400000 0), return x with inexact if x!=0. -;; 3. sin(x) is approximated by a polynomial of degree 13 on -;; [0,pi/4] -;; 3 13 -;; sin(x) ~ x + S1*x + ... + S6*x -;; where -;; -;; |sin(x) 2 4 6 8 10 12 | -58 -;; |----- - (1+S1*x +S2*x +S3*x +S4*x +S5*x +S6*x )| <= 2 -;; | x | -;; -;; 4. sin(x+y) = sin(x) + sin'(x')*y -;; ~ sin(x) + (1-x*x/2)*y -;; For better accuracy, let -;; 3 2 2 2 2 -;; r = x *(S2+x *(S3+x *(S4+x *(S5+x *S6)))) -;; then 3 2 -;; sin(x) = x + (S1*x + (x *(r-y/2)+y)) - -(declaim (ftype (function (double-float double-float fixnum) - double-float) - kernel-sin)) - -(defun kernel-sin (x y iy) - (declare (type (double-float -1d0 1d0) x y) - (fixnum iy) - (optimize (speed 3) (safety 0))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (when (< ix #x3e400000) - ;; |x| < 2^-27 - ;; Signal inexact if x /= 0 - (if (zerop (truncate x)) - (return-from kernel-sin x) - (return-from kernel-sin x))) - (let* ((s1 -1.66666666666666324348d-01) ; #xBFC55555 #x55555549 - (s2 8.33333333332248946124d-03) ; #x3F811111 #x1110F8A6 - (s3 -1.98412698298579493134d-04) ; #xBF2A01A0 #x19C161D5 - (s4 2.75573137070700676789d-06) ; #x3EC71DE3 #x57B1FE7D - (s5 -2.50507602534068634195d-08) ; #xBE5AE5E6 #x8A2B9CEB - (s6 1.58969099521155010221d-10) ; #x3DE5D93A #x5ACFD57C - (z (* x x)) - (v (* z x)) - (r (+ s2 - (* z - (+ s3 - (* z - (+ s4 - (* z - (+ s5 - (* z s6)))))))))) - (if (zerop iy) - (+ x (* v (+ s1 (* z r)))) - (- x (- (- (* z (- (* .5 y) - (* v r))) - y) - (* v s1))))))) - -;; kernel cos function on [-pi/4, pi/4], pi/4 ~ 0.785398164 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; -;; Algorithm -;; 1. Since cos(-x) = cos(x), we need only to consider positive x. -;; 2. if x < 2^-27 (hx<0x3e400000 0), return 1 with inexact if x!=0. -;; 3. cos(x) is approximated by a polynomial of degree 14 on -;; [0,pi/4] -;; 4 14 -;; cos(x) ~ 1 - x*x/2 + C1*x + ... + C6*x -;; where the remez error is -;; -;; | 2 4 6 8 10 12 14 | -58 -;; |cos(x)-(1-.5*x +C1*x +C2*x +C3*x +C4*x +C5*x +C6*x )| <= 2 -;; | | -;; -;; 4 6 8 10 12 14 -;; 4. let r = C1*x +C2*x +C3*x +C4*x +C5*x +C6*x , then -;; cos(x) = 1 - x*x/2 + r -;; since cos(x+y) ~ cos(x) - sin(x)*y -;; ~ cos(x) - x*y, -;; a correction term is necessary in cos(x) and hence -;; cos(x+y) = 1 - (x*x/2 - (r - x*y)) -;; For better accuracy when x > 0.3, let qx = |x|/4 with -;; the last 32 bits mask off, and if x > 0.78125, let qx = 0.28125. -;; Then -;; cos(x+y) = (1-qx) - ((x*x/2-qx) - (r-x*y)). -;; Note that 1-qx and (x*x/2-qx) is EXACT here, and the -;; magnitude of the latter is at least a quarter of x*x/2, -;; thus, reducing the rounding error in the subtraction. -(declaim (ftype (function (double-float double-float) - double-float) - kernel-cos)) - -(defun kernel-cos (x y) - (declare (type (double-float -1d0 1d0) x y) - (optimize (speed 3) (safety 0))) - ;; cos(-x) = cos(x), so we just compute cos(|x|). - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - ;; cos(x) = 1 when |x| < 2^-27 - (when (< ix #x3e400000) - ;; Signal inexact if x /= 0 - (if (zerop (truncate x)) - (return-from kernel-cos 1d0) - (return-from kernel-cos 1d0))) - (let* ((c1 4.16666666666666019037d-02) - (c2 -1.38888888888741095749d-03) - (c3 2.48015872894767294178d-05) - (c4 -2.75573143513906633035d-07) - (c5 2.08757232129817482790d-09) - (c6 -1.13596475577881948265d-11) - (z (* x x)) - (r (* z - (+ c1 - (* z - (+ c2 - (* z - (+ c3 - (* z - (+ c4 - (* z - (+ c5 - (* z c6))))))))))))) - (cond ((< ix #x3fd33333) - ;; \x| < 0.3 - (- 1 (- (* .5 z) - (- (* z r) - (* x y))))) - (t - ;; qx = 0.28125 if |x| > 0.78125, else x/4 dropping the - ;; least significant 32 bits. - (let* ((qx (if (> ix #x3fe90000) - 0.28125d0 - ;; x/4, exactly, and also dropping the - ;; least significant 32 bits of the - ;; fraction. - (make-double-float (- ix #x00200000) - 0))) - (hz (- (* 0.5 z) qx)) - (a (- 1 qx))) - (- a (- hz (- (* z r) - (* x y)))))))))) - -(declaim (type (simple-array double-float (*)) tan-coef)) -(defconstant tan-coef - (make-array 13 :element-type 'double-float - :initial-contents - '(3.33333333333334091986d-01 - 1.33333333333201242699d-01 - 5.39682539762260521377d-02 - 2.18694882948595424599d-02 - 8.86323982359930005737d-03 - 3.59207910759131235356d-03 - 1.45620945432529025516d-03 - 5.88041240820264096874d-04 - 2.46463134818469906812d-04 - 7.81794442939557092300d-05 - 7.14072491382608190305d-05 - -1.85586374855275456654d-05 - 2.59073051863633712884d-05))) - -;; kernel tan function on [-pi/4, pi/4], pi/4 ~ 0.7854 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; Input k indicates whether tan (if k = 1) or -1/tan (if k = -1) is returned. -;; -;; Algorithm -;; 1. Since tan(-x) = -tan(x), we need only to consider positive x. -;; 2. if x < 2^-28 (hx<0x3e300000 0), return x with inexact if x!=0. -;; 3. tan(x) is approximated by a odd polynomial of degree 27 on -;; [0,0.67434] -;; 3 27 -;; tan(x) ~ x + T1*x + ... + T13*x -;; where -;; -;; |tan(x) 2 4 26 | -59.2 -;; |----- - (1+T1*x +T2*x +.... +T13*x )| <= 2 -;; | x | -;; -;; Note: tan(x+y) = tan(x) + tan'(x)*y -;; ~ tan(x) + (1+x*x)*y -;; Therefore, for better accuracy in computing tan(x+y), let -;; 3 2 2 2 2 -;; r = x *(T2+x *(T3+x *(...+x *(T12+x *T13)))) -;; then -;; 3 2 -;; tan(x+y) = x + (T1*x + (x *(r+y)+y)) -;; -;; 4. For x in [0.67434,pi/4], let y = pi/4 - x, then -;; tan(x) = tan(pi/4-y) = (1-tan(y))/(1+tan(y)) -;; = 1 - 2*(tan(y) - (tan(y)^2)/(1+tan(y))) -(declaim (ftype (function (double-float double-float fixnum) - double-float) - kernel-tan)) - -(defun kernel-tan (x y iy) - (declare (type (double-float -1d0 1d0) x y) - (type (member -1 1) iy) - (optimize (speed 3) (safety 0))) - (let* ((hx (kernel:double-float-high-bits x)) - (ix (logand hx #x7fffffff)) - (w 0d0) - (z 0d0) - (v 0d0) - (s 0d0) - (r 0d0)) - (declare (double-float w z v s r)) - (when (< ix #x3e300000) - ;; |x| < 2^-28 - (when (zerop (truncate x)) - (cond ((zerop (logior (logior ix (kernel:double-float-low-bits x)) - (+ iy 1))) - ;; x = 0 (because hi and low bits are 0) and iy = -1 - ;; (cot) - (return-from kernel-tan (/ (abs x)))) - ((= iy 1) - (return-from kernel-tan x)) - (t - ;; x /= 0 and iy = -1 (cot) - ;; Compute -1/(x+y) carefully - (let ((a 0d0) - (tt 0d0)) - (setf w (+ x y)) - (setf z (make-double-float (double-float-high-bits w) 0)) - (setf v (- y (- z x))) - (setf a (/ -1 w)) - (setf tt (make-double-float (double-float-high-bits a) 0)) - (setf s (+ 1 (* tt z))) - (return-from kernel-tan (+ tt - (* a (+ s (* tt v)))))))))) - (when (>= ix #x3FE59428) - ;; |x| > .6744 - (when (minusp hx) - (setf x (- x)) - (setf y (- y))) - ;; The two constants below are such that pi/4 + pi/4_lo is pi/4 - ;; to twice the accuracy of a double float. - ;; - ;; z = pi/4-x - (setf z (- (make-double-float #x3FE921FB #x54442D18) x)) - ;; w = pi/4_lo - y. - (setf w (- (make-double-float #x3C81A626 #x33145C07) y)) - (setf x (+ z w)) - (setf y 0d0)) - (setf z (* x x)) - (setf w (* z z)) - ;; Break x^5*(T[1]+x^2*T[2]+...) into - ;; x^5(T[1]+x^4*T[3]+...+x^20*T[11]) + - ;; x^5(x^2*(T[2]+x^4*T[4]+...+x^22*[T12])) - (setf r (+ (aref tan-coef 1) - (* w - (+ (aref tan-coef 3) - (* w - (+ (aref tan-coef 5) - (* w - (+ (aref tan-coef 7) - (* w - (+ (aref tan-coef 9) - (* w (aref tan-coef 11)))))))))))) - (setf v (* z - (+ (aref tan-coef 2) - (* w - (+ (aref tan-coef 4) - (* w - (+ (aref tan-coef 6) - (* w - (+ (aref tan-coef 8) - (* w - (+ (aref tan-coef 10) - (* w (aref tan-coef 12))))))))))))) - (setf s (* z x)) - (setf r (+ y (* z (+ (* s (+ r v)) - y)))) - (incf r (* s (aref tan-coef 0))) - (setf w (+ x r)) - (when (>= ix #x3FE59428) - (let ((v (float iy 1d0))) - (return-from kernel-tan - (* (- 1 (logand 2 (ash hx -30))) - (- v - (* 2 - (- x (- (/ (* w w) - (+ w v)) - r)))))))) - (when (= iy 1) - (return-from kernel-tan w)) - ;; Compute 1/w=1/(x+r) carefully - (let ((a 0d0) - (tt 0d0)) - (setf z (kernel:make-double-float (kernel:double-float-high-bits w) 0)) - (setf v (- r (- z x))) ; z + v = r + x - (setf a (/ -1 w)) - (setf tt (kernel:make-double-float (kernel:double-float-high-bits a) 0)) - (setf s (+ 1 (* tt z))) - (+ tt - (* a - (+ s (* tt v))))))) - -;; Return sine function of x. -;; -;; kernel function: -;; __kernel_sin ... sine function on [-pi/4,pi/4] -;; __kernel_cos ... cose function on [-pi/4,pi/4] -;; __ieee754_rem_pio2 ... argument reduction routine -;; -;; Method. -;; Let S,C and T denote the sin, cos and tan respectively on -;; [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 -;; in [-pi/4 , +pi/4], and let n = k mod 4. -;; We have -;; -;; n sin(x) cos(x) tan(x) -;; ---------------------------------------------------------- -;; 0 S C T -;; 1 C -S -1/T -;; 2 -S -C T -;; 3 -C S -1/T -;; ---------------------------------------------------------- -;; -;; Special cases: -;; Let trig be any of sin, cos, or tan. -;; trig(+-INF) is NaN, with signals; -;; trig(NaN) is that NaN; -;; -;; Accuracy: -;; TRIG(x) returns trig(x) nearly rounded -(defun %sin (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (cond - ((<= ix #x3fe921fb) - ;; |x| < pi/4, approx - (kernel-sin x 0d0 0)) - ((>= ix #x7ff00000) - ;; sin(Inf or NaN) is NaN - (- x x)) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (case (logand n 3) - (0 - (kernel-sin y0 y1 1)) - (1 - (kernel-cos y0 y1)) - (2 - (- (kernel-sin y0 y1 1))) - (3 - (- (kernel-cos y0 y1))))))))) - -(defun %cos (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (cond - ((< ix #x3fe921fb) - ;;|x| < pi/4, approx - (kernel-cos x 0d0)) - ((>= ix #x7ff00000) - ;; cos(Inf or NaN) is NaN - (- x x)) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (ecase (logand n 3) - (0 - (kernel-cos y0 y1)) - (1 - (- (kernel-sin y0 y1 1))) - (2 - (- (kernel-cos y0 y1))) - (3 - (kernel-sin y0 y1 1)))))))) - -(defun %tan (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (logand #x7fffffff (kernel:double-float-high-bits x)))) - (cond ((<= ix #x3fe921fb) - ;; |x| < pi/4 - (kernel-tan x 0d0 1)) - ((>= ix #x7ff00000) - ;; tan(Inf or Nan) is NaN - (- x x)) - (t - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (let ((flag (- 1 (ash (logand n 1) 1)))) - ;; flag = 1 if n even, -1 if n odd - (kernel-tan y0 y1 flag))))))) -;; Compute sin and cos of x, simultaneously. -(defun %sincos (x) - (declare (double-float x) - (optimize (speed 3))) - (cond ((<= (abs x) (/ pi 4)) - (values (kernel-sin x 0d0 0) - (kernel-cos x 0d0))) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (case (logand n 3) - (0 - (values (kernel-sin y0 y1 1) - (kernel-cos y0 y1))) - (1 - (values (kernel-cos y0 y1) - (- (kernel-sin y0 y1 1)))) - (2 - (values (- (kernel-sin y0 y1 1)) - (- (kernel-cos y0 y1)))) - (3 - (values (- (kernel-cos y0 y1)) - (kernel-sin y0 y1 1)))))))) -;;(declaim (ext:end-block)) -||# - ;;;; Power functions. ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 434 --------------------------------------------------- 1 file changed, 434 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2014-04 created. snapshot-2014-04
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 annotated tag, snapshot-2014-04 has been created at d29f514ce86a5c31f5c73a3b048779c3c4d9984b (tag) tagging 28740a75c3a9948d9a6fea93f4fffde1453ea665 (commit) replaces snapshot-2014-03 tagged by Raymond Toy on Sat Mar 29 09:29:47 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-04 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlM29QEACgkQJ5IjUmgZO7JawACfbHukAckqWi9QSCqW1ooGTlnU 2EsAoKSQJQOTAVLcCeme2gzd5wfzfou3 =nIaD -----END PGP SIGNATURE----- Raymond Toy (13): Revert change for ticket 92. Add double-double-float-positive-infinity and Return the correct values for (log -0w0) and (log 0w0). Previously we Add unicode tests, based on the tests in src/i18n/tests. Remove these test files since they've been migrated to lisp-unit. First cut at adding PCL tests. Fix typos in eval-when cases. Add comments. Copy the PCL tests here, changing the package from PCL-TEST to Remove the tests and just use mk-defsystem to load the separate PCL Add comments. Note that this can't be run from a build; you have to Update from commit logs. Note dropping of x87 support after this snapshot. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-34-g7211ebf
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 7211ebf377b1b4025ab8424d6f31109fa7489479 (commit) from e9be6b48a40993444db72d4a9434b9eb44099f65 (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 7211ebf377b1b4025ab8424d6f31109fa7489479 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 31 19:56:40 2014 -0700 CLEAR-OUTPUT should call STREAM-CLEAR-OUTPUT for Gray streams. See ticket #101. This fixes item 1 of that bug report. diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 0e27cba..6cb5256 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1103,7 +1103,7 @@ ;; lisp-stream (funcall (lisp-stream-misc stream) stream :clear-output) ;; fundamental-stream - (stream-force-output stream))) + (stream-clear-output stream))) nil) (defun write-byte (integer stream) ----------------------------------------------------------------------- Summary of changes: src/code/stream.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-22-g3533a13
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

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 3533a13a8cc53e43a7c4d7d27b3e6b8bcc004672 (commit) via 250d2511450366c4e9f07c1515f04ccaf37ebf68 (commit) from b6bd0b590e541a159c4b5eb7e31b64c2ef0b47dc (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 3533a13a8cc53e43a7c4d7d27b3e6b8bcc004672 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jul 25 22:17:11 2014 -0700 Rename sin/cos/tan/sincos so we don't collide with libm. Update def-math-rtn to allow specifying the C function name and the lisp function name so we can use def-math-rtn with the new trig functions. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index f2b0e9b..032a6ac 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -28,13 +28,17 @@ ;;; call, and saves number consing to boot. ;;; (defmacro def-math-rtn (name num-args) - (let ((function (intern (concatenate 'simple-string + (multiple-value-bind (c-name lisp-name) + (if (listp name) + (values (first name) (second name)) + (values name + (intern (concatenate 'simple-string "%" (string-upcase name))))) `(progn - (declaim (inline ,function)) - (export ',function) - (alien:def-alien-routine (,name ,function) double-float + (declaim (inline ,lisp-name)) + (export ',lisp-name) + (alien:def-alien-routine (,c-name ,lisp-name) double-float ,@(let ((results nil)) (dotimes (i num-args (nreverse results)) (push (list (intern (format nil "ARG-~D" i)) @@ -65,9 +69,12 @@ ;; For x86 (without sse2), we can use x87 instructions to implement ;; these. With sse2, we don't currently support that, so these ;; should be disabled. - (def-math-rtn "sin" 1) - (def-math-rtn "cos" 1) - (def-math-rtn "tan" 1) +;; (def-math-rtn "sin" 1) +;; (def-math-rtn "cos" 1) + ;; (def-math-rtn "tan" 1) + (def-math-rtn ("fdlibm_sin" %sin) 1) + (def-math-rtn ("fdlibm_cos" %cos) 1) + (def-math-rtn ("fdlibm_tan" %tan) 1) (def-math-rtn "atan" 1) (def-math-rtn "atan2" 2)) (def-math-rtn "asin" 1) @@ -198,7 +205,7 @@ (y1 double-float :out)) (declaim (inline %%sincos)) -(alien:def-alien-routine ("sincos" %%sincos) c-call:void +(alien:def-alien-routine ("lisp_sincos" %%sincos) c-call:void (x double-float) (s double-float :out) (c double-float :out)) diff --git a/src/lisp/s_cos.c b/src/lisp/s_cos.c index a897133..9ae05d8 100644 --- a/src/lisp/s_cos.c +++ b/src/lisp/s_cos.c @@ -45,9 +45,9 @@ #include "fdlibm.h" #ifdef __STDC__ - double cos(double x) + double fdlibm_cos(double x) #else - double cos(x) + double fdlibm_cos(x) double x; #endif { diff --git a/src/lisp/s_sin.c b/src/lisp/s_sin.c index 1dba1c8..a7ad61d 100644 --- a/src/lisp/s_sin.c +++ b/src/lisp/s_sin.c @@ -45,9 +45,9 @@ #include "fdlibm.h" #ifdef __STDC__ - double sin(double x) + double fdlibm_sin(double x) #else - double sin(x) + double fdlibm_sin(x) double x; #endif { diff --git a/src/lisp/s_tan.c b/src/lisp/s_tan.c index 4761a4c..0b90762 100644 --- a/src/lisp/s_tan.c +++ b/src/lisp/s_tan.c @@ -44,9 +44,9 @@ #include "fdlibm.h" #ifdef __STDC__ - double tan(double x) + double fdlibm_tan(double x) #else - double tan(x) + double fdlibm_tan(x) double x; #endif { diff --git a/src/lisp/sincos.c b/src/lisp/sincos.c index f5db8b3..edd0eca 100644 --- a/src/lisp/sincos.c +++ b/src/lisp/sincos.c @@ -1,6 +1,6 @@ #include "fdlibm.h" -void sincos (double x, double *s, double *c) +void lisp_sincos (double x, double *s, double *c) { int ix; union { int i[2]; double d; } ux; commit 250d2511450366c4e9f07c1515f04ccaf37ebf68 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jul 25 21:08:05 2014 -0700 Add declaration to ignore unused variable. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index f95e32c..f2b0e9b 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -208,6 +208,7 @@ (declare (double-float x)) (multiple-value-bind (ign s c) (%%sincos x) + (declare (ignore ign)) (values s c))) #|| ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 24 ++++++++++++++++-------- src/lisp/s_cos.c | 4 ++-- src/lisp/s_sin.c | 4 ++-- src/lisp/s_tan.c | 4 ++-- src/lisp/sincos.c | 2 +- 5 files changed, 23 insertions(+), 15 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

← Newer
1
...
9
10
11
12
13
14
15
...
32
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs April 2015