lisp-unit.lisp

   1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 #|
   4 Copyright (c) 2004-2005 Christopher K. Riesbeck
   5
   6 Permission is hereby granted, free of charge, to any person obtaining
   7 a copy of this software and associated documentation files (the "Software"),
   8 to deal in the Software without restriction, including without limitation
   9 the rights to use, copy, modify, merge, publish, distribute, sublicense,
  10 and/or sell copies of the Software, and to permit persons to whom the
  11 Software is furnished to do so, subject to the following conditions:
  12
  13 The above copyright notice and this permission notice shall be included
  14 in all copies or substantial portions of the Software.
  15
  16 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  17 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  19 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
  20 OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  21 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  22 OTHER DEALINGS IN THE SOFTWARE.
  23 |#
  24
  25
  26 ;;; A test suite package, modelled after JUnit.
  27 ;;; Author: Chris Riesbeck
  28 ;;;
  29 ;;; Update history:
  30 ;;;
  31 ;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
  32 ;;; 04/06/06 added ~<...~> to compact error output better [CKR]
  33 ;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
  34 ;;;          by Daniel Edward Burke) [CKR]
  35 ;;; 02/08/06 added newlines to error output [CKR]
  36 ;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
  37 ;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
  38 ;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger,
  39 ;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
  40 ;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
  41 ;;; 08/30/05 added license notice [CKR]
  42 ;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
  43 ;;; 02/21/05 removed length check from SET-EQUAL [CKR]
  44 ;;; 02/17/05 added RUN-ALL-TESTS [CKR]
  45 ;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
  46 ;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR]
  47 ;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
  48 ;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
  49 ;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
  50 ;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
  51 ;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
  52 ;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
  53 ;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
  54 ;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
  55 ;;; 12/02/04 changed to group tests under packages [CKR]
  56 ;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
  57 ;;; 11/30/04 improved error handling and summarization [CKR]
  58 ;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
  59 ;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
  60 ;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
  61 ;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
  62 ;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
  63 ;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
  64 ;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
  65 ;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
  66
  67
  68 #|
  69 How to use
  70 ----------
  71
  72 1. Read the documentation in lisp-unit.html.
  73
  74 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  75 examples. If you want, start your test file with (REMOVE-TESTS) to
  76 clear any previously defined tests.
  77
  78 2. Load this file.
  79
  80 2. (use-package :lisp-unit)
  81
  82 3. Load your code file and your file of tests.
  83
  84 4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
  85 or simply (RUN-TESTS) to run all defined tests.
  86
  87 A summary of how many tests passed and failed will be printed,
  88 with details on the failures.
  89
  90 Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
  91 functions or even macros does not require reloading any tests.
  92
  93 For more information, see lisp-unit.html.
  94
  95 |#
  96
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98 ;;; Packages
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100
 101 (cl:defpackage #:lisp-unit
 102   (:use #:common-lisp)
 103   (:export #:define-test #:run-all-tests #:run-tests
 104            #:assert-eq #:assert-eql #:assert-equal #:assert-equalp
 105            #:assert-error #:assert-expands #:assert-false
 106            #:assert-equality #:assert-prints #:assert-true
 107            #:get-test-code #:get-tests
 108            #:remove-all-tests #:remove-tests
 109            #:logically-equal #:set-equal
 110            #:float-equal #:complex-equal #:number-equal
 111            #:array-equal
 112            #:significant-figures-equal
 113            #:3-sigfig-equal #:4-sigfig-equal
 114            #:5-sigfig-equal #:6-sigfig-equal
 115            #:use-debugger
 116            #:with-test-listener)
 117   )
 118
 119 (in-package #:lisp-unit)
 120
 121 (pushnew :lisp-unit *features*)
 122
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 ;;; Globals
 125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126
 127 (defparameter *test-listener* nil)
 128
 129 (defparameter *tests* (make-hash-table))
 130
 131 ;;; Used by RUN-TESTS to collect summary statistics
 132 (defvar *test-count* 0)
 133 (defvar *pass-count* 0)
 134
 135 ;;; Set by RUN-TESTS for use by SHOW-FAILURE
 136 (defvar *test-name* nil)
 137
 138 ;;; If nil, errors in tests are caught and counted.
 139 ;;; If :ask, user is given option of entering debugger or not.
 140 ;;; If true and not :ask, debugger is entered.
 141 (defparameter *use-debugger* nil)
 142
 143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 144 ;;; Macros
 145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146
 147 ;;; DEFINE-TEST
 148
 149 (defmacro define-test (name &body body)
 150   `(progn
 151      (store-test-code ',name ',body)
 152      ',name))
 153
 154 ;;; ASSERT macros
 155
 156 (defmacro assert-eq (expected form &rest extras)
 157  (expand-assert :equal form form expected extras :test #'eq))
 158
 159 (defmacro assert-eql (expected form &rest extras)
 160  (expand-assert :equal form form expected extras :test #'eql))
 161
 162 (defmacro assert-equal (expected form &rest extras)
 163  (expand-assert :equal form form expected extras :test #'equal))
 164
 165 (defmacro assert-equalp (expected form &rest extras)
 166  (expand-assert :equal form form expected extras :test #'equalp))
 167
 168 (defmacro assert-error (condition form &rest extras)
 169  (expand-assert :error form (expand-error-form form)
 170                 condition extras))
 171
 172 (defmacro assert-expands (&environment env expansion form &rest extras)
 173   (expand-assert :macro form
 174                  (expand-macro-form form #+lispworks nil #-lispworks env)
 175                  expansion extras))
 176
 177 (defmacro assert-false (form &rest extras)
 178   (expand-assert :result form form nil extras))
 179
 180 (defmacro assert-equality (test expected form &rest extras)
 181  (expand-assert :equal form form expected extras :test test))
 182
 183 (defmacro assert-prints (output form &rest extras)
 184   (expand-assert :output form (expand-output-form form)
 185                  output extras))
 186
 187 (defmacro assert-true (form &rest extras)
 188   (expand-assert :result form form t extras))
 189
 190
 191 (defun expand-assert (type form body expected extras &key (test #'eql))
 192   `(internal-assert
 193     ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
 194
 195 (defun expand-error-form (form)
 196   `(handler-case ,form
 197      (condition (error) error)))
 198
 199 (defun expand-output-form (form)
 200   (let ((out (gensym)))
 201     `(let* ((,out (make-string-output-stream))
 202             (*standard-output* (make-broadcast-stream *standard-output* ,out)))
 203        ,form
 204        (get-output-stream-string ,out))))
 205
 206 (defun expand-macro-form (form env)
 207   `(macroexpand-1 ',form ,env))
 208
 209 (defun expand-extras (extras)
 210   `#'(lambda ()
 211        (list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
 212
 213
 214 ;;; RUN-TESTS
 215
 216 (defmacro run-all-tests (package &rest tests)
 217   `(let ((*package* (find-package ',package)))
 218      (run-tests
 219       ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
 220           tests))))
 221
 222 (defmacro run-tests (&rest names)
 223   `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
 224
 225 (defun get-test-thunks (names &optional (package *package*))
 226   (mapcar #'(lambda (name) (get-test-thunk name package))
 227     names))
 228
 229 (defun get-test-thunk (name package)
 230   (assert (get-test-code name package) (name package)
 231           "No test defined for ~S in package ~S" name package)
 232   (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
 233
 234 (defun use-debugger (&optional (flag t))
 235   (setq *use-debugger* flag))
 236
 237 ;;; WITH-TEST-LISTENER
 238 (defmacro with-test-listener (listener &body body)
 239   `(let ((*test-listener* #',listener)) ,@body))
 240
 241 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 242 ;;; Public functions
 243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244
 245 (defun get-test-code (name &optional (package *package*))
 246   (let ((table (get-package-table package)))
 247     (unless (null table)
 248       (gethash name table))))
 249
 250 (defun get-tests (&optional (package *package*))
 251   (let ((l nil)
 252         (table (get-package-table package)))
 253     (cond ((null table) nil)
 254           (t
 255            (maphash #'(lambda (key val)
 256                         (declare (ignore val))
 257                         (push key l))
 258                     table)
 259            (sort l #'string< :key #'string)))))
 260
 261
 262 (defun remove-tests (names &optional (package *package*))
 263   (let ((table (get-package-table package)))
 264     (unless (null table)
 265       (if (null names)
 266           (clrhash table)
 267         (dolist (name names)
 268           (remhash name table))))))
 269
 270 (defun remove-all-tests (&optional (package *package*))
 271   (if (null package)
 272       (clrhash *tests*)
 273     (remhash (find-package package) *tests*)))
 274
 275
 276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 277 ;;; Private functions
 278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279
 280
 281 ;;; DEFINE-TEST support
 282
 283 (defun get-package-table (package &key create)
 284   (let ((table (gethash (find-package package) *tests*)))
 285     (or table
 286         (and create
 287              (setf (gethash package *tests*)
 288                    (make-hash-table))))))
 289
 290 (defun get-test-name (form)
 291   (if (atom form) form (cadr form)))
 292
 293 (defun store-test-code (name code &optional (package *package*))
 294   (setf (gethash name
 295                  (get-package-table package :create t))
 296         code))
 297
 298
 299 ;;; ASSERTION support
 300
 301 (defun internal-assert (type form code-thunk expected-thunk extras test)
 302   (let* ((expected (multiple-value-list (funcall expected-thunk)))
 303          (actual (multiple-value-list (funcall code-thunk)))
 304          (passed (test-passed-p type expected actual test)))
 305
 306     (incf *test-count*)
 307     (when passed
 308       (incf *pass-count*))
 309
 310     (record-result passed type form expected actual extras)
 311
 312     passed))
 313
 314 (defun record-result (passed type form expected actual extras)
 315   (funcall (or *test-listener* 'default-listener)
 316            passed type *test-name* form expected actual
 317            (and extras (funcall extras))
 318            *test-count* *pass-count*))
 319
 320 (defun default-listener
 321     (passed type name form expected actual extras test-count pass-count)
 322   (declare (ignore test-count pass-count))
 323   (unless passed
 324     (show-failure type (get-failure-message type)
 325                   name form expected actual extras)))
 326
 327 (defun test-passed-p (type expected actual test)
 328   (ecase type
 329     (:error
 330      (or (eql (car actual) (car expected))
 331          (typep (car actual) (car expected))))
 332     (:equal
 333      (and (<= (length expected) (length actual))
 334           (every test expected actual)))
 335     (:macro
 336      (equal (car actual) (car expected)))
 337     (:output
 338      (string= (string-trim '(#\newline #\return #\space)
 339                            (car actual))
 340               (car expected)))
 341     (:result
 342      (logically-equal (car actual) (car expected)))
 343     ))
 344
 345
 346 ;;; RUN-TESTS support
 347
 348 (defun run-test-thunks (test-thunks)
 349   (unless (null test-thunks)
 350     (let ((total-test-count 0)
 351           (total-pass-count 0)
 352           (total-error-count 0))
 353       (dolist (test-thunk test-thunks)
 354         (multiple-value-bind (test-count pass-count error-count)
 355             (run-test-thunk (car test-thunk) (cadr test-thunk))
 356           (incf total-test-count test-count)
 357           (incf total-pass-count pass-count)
 358           (incf total-error-count error-count)))
 359       (unless (null (cdr test-thunks))
 360         (show-summary 'total total-test-count total-pass-count total-error-count))
 361       (values))))
 362
 363 (defun run-test-thunk (*test-name* thunk)
 364   (if (null thunk)
 365       (format t "~&    Test ~S not found" *test-name*)
 366     (prog ((*test-count* 0)
 367            (*pass-count* 0)
 368            (error-count 0))
 369       (handler-bind
 370           ((error #'(lambda (e)
 371                       (let ((*print-escape* nil))
 372                         (setq error-count 1)
 373                         (format t "~&    ~S: ~W" *test-name* e))
 374                       (if (use-debugger-p e) e (go exit)))))
 375         (funcall thunk)
 376         (show-summary *test-name* *test-count* *pass-count*))
 377       exit
 378       (return (values *test-count* *pass-count* error-count)))))
 379
 380 (defun use-debugger-p (e)
 381   (and *use-debugger*
 382        (or (not (eql *use-debugger* :ask))
 383            (y-or-n-p "~A -- debug?" e))))
 384
 385 ;;; OUTPUT support
 386
 387 (defun get-failure-message (type)
 388   (case type
 389     (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 390     (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 391     (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 392     (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 393     ))
 394
 395 (defun show-failure (type msg name form expected actual extras)
 396   (format t "~&~@[~S: ~]~S failed: " name form)
 397   (format t msg expected actual)
 398   (format t "~{~&   ~S => ~S~}~%" extras)
 399   type)
 400
 401 (defun show-summary (name test-count pass-count &optional error-count)
 402   (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
 403           name pass-count (- test-count pass-count) error-count))
 404
 405 (defun collect-form-values (form values)
 406   (mapcan #'(lambda (form-arg value)
 407               (if (constantp form-arg)
 408                   nil
 409                 (list form-arg value)))
 410           (cdr form)
 411           values))
 412
 413
 414 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 415 ;;; Useful equality predicates for tests
 416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 417
 418 ;;; (LOGICALLY-EQUAL x y) => true or false
 419 ;;;   Return true if x and y both false or both true
 420
 421 (defun logically-equal (x y)
 422   (eql (not x) (not y)))
 423
 424 ;;; (SET-EQUAL l1 l2 :test) => true or false
 425 ;;;   Return true if every element of l1 is an element of l2
 426 ;;;   and vice versa.
 427
 428 (defun set-equal (l1 l2 &key (test #'equal))
 429   (and (listp l1)
 430        (listp l2)
 431        (subsetp l1 l2 :test test)
 432        (subsetp l2 l1 :test test)))
 433
 434 ;;; (ROUNDOFF-ERROR x y) => number
 435 ;;; Return the error delta between the exact and approximate floating
 436 ;;; point value.
 437 ;;; Equation 1.1 in NumLinAlg
 438 (defun roundoff-error (exact approximate)
 439   "Returned the error delta between the exact and approximate floating
 440 point value."
 441   (abs (if (or (= 0.0 exact) (= 0.0 approximate))
 442            (+ exact approximate)
 443            (- (/ approximate exact) 1.0))))
 444
 445 ;;; (FLOAT-EQUAL float1 float2 &optional epsilon) => true or false
 446 ;;; Return true if the absolute difference between float1 and float2
 447 ;;; is less than epsilon. If an epsilon is not specified and either
 448 ;;; float1 or float2 is single precision, the single-float-epsilon is
 449 ;;; used.
 450 (defun float-equal (float1 float2 &optional epsilon)
 451   "Return true if the absolute difference between float1 and float2 is
 452 less than some epsilon."
 453   (and
 454    (floatp float1)
 455    (floatp float2)
 456    (cond
 457      ((and (zerop float1) (zerop float2)))
 458      (epsilon
 459       (> epsilon (roundoff-error float1 float2)))
 460      ((and (typep float1 'double-float) (typep float2 'double-float))
 461       (> (* 2.0 double-float-epsilon) (roundoff-error float1 float2)))
 462      ((or (typep float1 'single-float) (typep float2 'single-float))
 463       (> (* 2.0 single-float-epsilon) (roundoff-error float1 float2)))
 464      (t nil))))
 465
 466 ;;; (COMPLEX-EQUAL complex1 complex2 &optional epsilon) => true or false
 467 ;;; Return true if the absolute difference of the real components and
 468 ;;; the absolute difference of the imaginary components is less then
 469 ;;; epsilon. If an epsilon is not specified and either complex1 or
 470 ;;; complex2 is (complex single-float), the single-float-epsilon is
 471 ;;; used.
 472 (defun complex-equal (complex1 complex2 &optional epsilon)
 473   "Return true if the absolute difference between Re(complex1),
 474 Re(complex2) and the absolute difference between Im(complex1),
 475 Im(complex2) is less than epsilon."
 476   (and
 477    (typep complex1 '(complex float))
 478    (typep complex2 '(complex float))
 479    (float-equal (realpart complex1) (realpart complex2) epsilon)
 480    (float-equal (imagpart complex1) (imagpart complex2) epsilon)))
 481
 482 ;;; (NUMBER-EQUAL number1 number2) => true or false
 483 ;;; Return true if the numbers are equal using the appropriate
 484 ;;; comparison.
 485 (defun number-equal (number1 number2 &optional epsilon)
 486   "Return true if the numbers are equal using the appropriate
 487 comparison."
 488   (cond
 489     ((and (floatp number1) (floatp number2))
 490      (float-equal number1 number2 epsilon))
 491     ((and (typep number1 '(complex float)) (typep number2 '(complex float)))
 492      (complex-equal number1 number2 epsilon))
 493     ((and (numberp number1) (numberp number2))
 494      (= number1 number2))
 495     (t (error "~A and ~A are not numbers." number1 number2))))
 496
 497 ;;; (ELEMENT-EQUAL array1 array2 indice dimensions) => true or false
 498 ;;; A utility function for ARRAY-EQUAL.
 499 (defun element-equal (array1 array2 indices dimensions &key (test #'number-equal))
 500   "Return true if the index of array1 equals array2."
 501   (let* ((rank (first dimensions))
 502          (remaining (rest dimensions))
 503          (update-result
 504           (if remaining
 505               (lambda (index)
 506                 (element-equal array1 array2
 507                                (cons index indices) remaining :test test))
 508               (lambda (index)
 509                 (funcall test
 510                          (apply #'aref array1 index (reverse indices))
 511                          (apply #'aref array2 index (reverse indices)))))))
 512     (do ((index 0 (1+ index))
 513          (result t (funcall update-result index)))
 514         ((or (not result) (>= index rank)) result))))
 515
 516 ;;; (ARRAY-EQUAL array1 array2) => true or false
 517 ;;; Return true of the elements of the array are equal.
 518 (defun array-equal (array1 array2 &key (test #'number-equal))
 519   "Return true if the elements of the array are equal."
 520   (when (equal (array-dimensions array1) (array-dimensions array2))
 521     (element-equal array1 array2 nil (array-dimensions array1) :test test)))
 522
 523 ;;; (NORMALIZE-FLOAT significand &optional exponent) => significand,exponent
 524 (defun normalize-float (significand &optional (exponent 0))
 525   "Return the normalized floating point number and exponent."
 526   (cond
 527     ((>= (abs significand) 10)
 528      (normalize-float (* significand 0.10) (1+ exponent)))
 529     ((< (abs significand) 1)
 530      (normalize-float (* significand 10.0) (1- exponent)))
 531     (t (values significand exponent))))
 532
 533 ;;; (SIGNIFICANT-FIGURES-EQUAL float1 float2 significant-figures) => true or false
 534 (defun significant-figures-equal (float1 float2 significant-figures)
 535   "Return true if the floating point numbers have equal significant
 536 figures."
 537   (multiple-value-bind (sig1 exp1) (normalize-float float1)
 538     (multiple-value-bind (sig2 exp2) (normalize-float float2)
 539       (and (= exp1 exp2)
 540            (< (abs (- sig1 sig2))
 541               (* (float 5 float1) (expt (float 10 float2) (- significant-figures))))))))
 542
 543 (defun 3-sigfig-equal (float1 float2)
 544   "Return true if the floats are equal to 3 significant figures."
 545   (significant-figures-equal float1 float2 3))
 546
 547 (defun 4-sigfig-equal (float1 float2)
 548   "Return true if the floats are equal to 4 significant figures."
 549   (significant-figures-equal float1 float2 4))
 550
 551 (defun 5-sigfig-equal (float1 float2)
 552   "Return true if the floats are equal to 5 significant figures."
 553   (significant-figures-equal float1 float2 5))
 554
 555 (defun 6-sigfig-equal (float1 float2)
 556   "Return true if the floats are equal to 6 significant figures."
 557   (significant-figures-equal float1 float2 6))
 558
 559 ;;;; References
 560 ;;;; [NumLinAlg] James W. Demmel "Applied Numerical Linear Algebra",
 561 ;;;;             Society for Industrial and Applied Mathematics, 1997
 562 ;;;;             ISBN: 0-89871-389-7
 563
 564 (provide "lisp-unit")