[Guile-commits] GNU Guile branch, master, updated. release_1-9-14-150-ga8591a5

[Andy Wingo]

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 "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a8591a55f0d7186fbdd58b3c570bbe945b58fa11

The branch, master has been updated
       via  a8591a55f0d7186fbdd58b3c570bbe945b58fa11 (commit)
      from  6e0975603eb4e568def1a91f9b127a6a35bdbe44 (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 a8591a55f0d7186fbdd58b3c570bbe945b58fa11
Author: Mark H Weaver <address@hidden>
Date:   Mon Jan 31 00:42:35 2011 -0500

    Rework the testing framework for number-theoretic division operators
    
    * test-suite/tests/numbers.test (test-eqv?): Remove special handling of
      zeroes.  Zeroes are now compared like all other numbers.  Exact
      numbers are compared with `eqv?' and inexact numbers are compared to
      within test-epsilon.
    
      Rework the testing framework for number-theoretic division operators:
      `euclidean/', `euclidean-quotient', `euclidean-remainder',
      `centered/', `centered-quotient', and `centered-remainder'.
      Previously we compared all test results against a simple scheme
      implementation of the same operations.  However, these operations have
      discontinuous jumps where a tiny change in the inputs can lead to a
      large change in the outputs, e.g.:
    
        (euclidean/ 130.00000000000 10/7) ==> 91.0 and 0.0
        (euclidean/ 129.99999999999 10/7) ==> 90.0 and 1.42857142856141
    
      In the new testing scheme, we compare values against the simple
      implementations only if the input arguments contain an infinity or a
      NaN.  In the common case of two finite arguments, we simply make sure
      that the outputs of all three operators (e.g. `euclidean/',
      `euclidean-quotient', `euclidean-remainder') equal each other, that
      outputs are exact iff both inputs are exact, and that the required
      properties of the operator are met: that Q is an integer, that R is
      within the specified range, and that N = Q*D + R.

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

Summary of changes:
 test-suite/tests/numbers.test |  194 +++++++++++++++++++----------------------
 1 files changed, 91 insertions(+), 103 deletions(-)

diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 01bccda..0d711b0 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -18,6 +18,7 @@
 (define-module (test-suite test-numbers)
   #:use-module (test-suite lib)
   #:use-module (ice-9 documentation)
+  #:use-module (srfi srfi-1)    ; list library
   #:use-module (srfi srfi-11))  ; let-values
 
 ;;;
@@ -100,12 +101,9 @@
 
 ;;
 ;; Like eqv?, except that inexact finite numbers need only be within
-;; test-epsilon (1e-10) to be considered equal.  An exception is made
-;; for zeroes, however.  If X is zero, then it is tested using eqv?
-;; without any allowance for imprecision.  In particular, 0.0 is
-;; considered distinct from -0.0.  For non-real complex numbers,
-;; each component is tested according to these rules.  The intent
-;; is that the known-correct value will be the first parameter.
+;; test-epsilon (1e-10) to be considered equal.  For non-real complex
+;; numbers, each component is tested according to these rules.  The
+;; intent is that the known-correct value will be the first parameter.
 ;;
 (define (test-eqv? x y)
   (cond ((real? x)
@@ -118,7 +116,7 @@
 
 ;; Auxiliary predicate used by test-eqv?
 (define (test-real-eqv? x y)
-  (cond ((or (exact? x) (zero? x) (nan? x) (inf? x))
+  (cond ((or (exact? x) (nan? x) (inf? x))
         (eqv? x y))
        (else (and (inexact? y) (> test-epsilon (abs (- x y)))))))
 
@@ -3551,6 +3549,24 @@
               (hi (+ hi test-epsilon)))
           (<= lo x hi))))
 
+  ;; (cartesian-product-map list '(a b) '(1 2))
+  ;; ==> ((a 1) (a 2) (b 1) (b 2))
+  (define (cartesian-product-map f . lsts)
+    (define (cartmap rev-head lsts)
+      (if (null? lsts)
+          (list (apply f (reverse rev-head)))
+          (append-map (lambda (x) (cartmap (cons x rev-head) (cdr lsts)))
+                      (car lsts))))
+    (cartmap '() lsts))
+
+  (define (cartesian-product-for-each f . lsts)
+    (define (cartfor rev-head lsts)
+      (if (null? lsts)
+          (apply f (reverse rev-head))
+          (for-each (lambda (x) (cartfor (cons x rev-head) (cdr lsts)))
+                    (car lsts))))
+    (cartfor '() lsts))
+
   (define (safe-euclidean-quotient x y)
     (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
           ((zero? y) (throw 'divide-by-zero))
@@ -3560,20 +3576,19 @@
           (else (throw 'unknown-problem))))
 
   (define (safe-euclidean-remainder x y)
-    (- x (* y (safe-euclidean-quotient x y))))
-
-  (define (safe-euclidean/ x y)
-    (let ((q (safe-euclidean-quotient x y))
-          (r (safe-euclidean-remainder x y)))
-      (if (not (and (eq? (exact? q) (exact? r))
-                    (eq? (exact? q) (and (exact? x) (exact? y)))
-                    (test-real-eqv? r (- x (* q y)))
-                    (or (and (integer? q)
-                             (test-within-range? 0 (abs y) r))
-                        (not (finite? x))
-                        (not (finite? y)))))
-          (throw 'safe-euclidean/-is-broken (list x y q r))
-          (values q r))))
+    (let ((q (safe-euclidean-quotient x y)))
+      (- x (* y q))))
+
+  (define (valid-euclidean-answer? x y q r)
+    (if (and (finite? x) (finite? y))
+        (and (eq? (exact? q)
+                  (exact? r)
+                  (and (exact? x) (exact? y)))
+             (integer? q)
+             (test-eqv? r (- x (* q y)))
+             (test-within-range? 0 (abs y) r))
+        (and (test-eqv? q (safe-euclidean-quotient  x y))
+             (test-eqv? r (safe-euclidean-remainder x y)))))
 
   (define (safe-centered-quotient x y)
     (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
@@ -3584,37 +3599,36 @@
           (else (throw 'unknown-problem))))
 
   (define (safe-centered-remainder x y)
-    (- x (* y (safe-centered-quotient x y))))
-
-  (define (safe-centered/ x y)
-    (let ((q (safe-centered-quotient x y))
-          (r (safe-centered-remainder x y)))
-      (if (not (and (eq? (exact? q) (exact? r))
-                    (eq? (exact? q) (and (exact? x) (exact? y)))
-                    (test-real-eqv? r (- x (* q y)))
-                    (or (and (integer? q)
-                             (test-within-range? (* -1/2 (abs y))
-                                                 (* +1/2 (abs y))
-                                                 r))
-                        (not (finite? x))
-                        (not (finite? y)))))
-          (throw 'safe-centered/-is-broken (list x y q r))
-          (values q r))))
+    (let ((q (safe-centered-quotient x y)))
+      (- x (* y q))))
+
+  (define (valid-centered-answer? x y q r)
+    (if (and (finite? x) (finite? y))
+        (and (eq? (exact? q)
+                  (exact? r)
+                  (and (exact? x) (exact? y)))
+             (integer? q)
+             (test-eqv? r (- x (* q y)))
+             (test-within-range? (* -1/2 (abs y))
+                                 (* +1/2 (abs y))
+                                 r))
+        (and (test-eqv? q (safe-centered-quotient  x y))
+             (test-eqv? r (safe-centered-remainder x y)))))
 
   (define test-numerators
-    (append
-     (list  123  125  127  130  3  5  10  123.2  125.0
-            -123 -125 -127 -130 -3 -5 -10 -123.2 -125.0
-            127.2  130.0  123/7  125/7  127/7  130/7
-            -127.2 -130.0 -123/7 -125/7 -127/7 -130/7
-            0 +0.0 -0.0 +inf.0 -inf.0 +nan.0
-            most-negative-fixnum (1+ most-positive-fixnum)
-            (1- most-negative-fixnum))
-     (apply append
-            (map (lambda (x) (list (* x (+ 1 most-positive-fixnum))
-                                   (* x (+ 2 most-positive-fixnum))))
-                 '( 123  125  127  130  3  5  10
-                   -123 -125 -127 -130 -3 -5 -10)))))
+    (append (cartesian-product-map * '(1 -1)
+                                   '(123 125 127 130 3 5 10
+                                         123.2 125.0 127.2 130.0
+                                         123/7 125/7 127/7 130/7))
+            (cartesian-product-map * '(1 -1)
+                                   '(123 125 127 130 3 5 10)
+                                   (list 1
+                                         (+ 1 most-positive-fixnum)
+                                         (+ 2 most-positive-fixnum)))
+            (list 0 +0.0 -0.0 +inf.0 -inf.0 +nan.0
+                  most-negative-fixnum
+                  (1+ most-positive-fixnum)
+                  (1- most-negative-fixnum))))
 
   (define test-denominators
     (list   10  5  10/7  127/2  10.0  63.5
@@ -3623,58 +3637,32 @@
             (+ 1 most-positive-fixnum) (+ -1 most-negative-fixnum)
             (+ 2 most-positive-fixnum) (+ -2 most-negative-fixnum)))
 
-  (define (do-tests-1 op-name real-op safe-op)
-    (for-each (lambda (d)
-                (for-each (lambda (n)
-                            (run-test (list op-name n d) #t
-                                      (lambda ()
-                                        (test-eqv? (real-op n d)
-                                                   (safe-op n d)))))
-                          test-numerators))
-              test-denominators))
-
-  (define (do-tests-2 op-name real-op safe-op)
-    (for-each (lambda (d)
-                (for-each (lambda (n)
-                            (run-test (list op-name n d) #t
-                                      (lambda ()
-                                        (let-values
-                                            (((q  r)  (safe-op n d))
-                                             ((q1 r1) (real-op n d)))
-                                          (and (test-eqv? q q1)
-                                               (test-eqv? r r1))))))
-                          test-numerators))
-              test-denominators))
-
-  (pass-if (documented? euclidean/))
-  (pass-if (documented? euclidean-quotient))
-  (pass-if (documented? euclidean-remainder))
-  (pass-if (documented? centered/))
-  (pass-if (documented? centered-quotient))
-  (pass-if (documented? centered-remainder))
-
-  (with-test-prefix "euclidean-quotient"
-    (do-tests-1 'euclidean-quotient
-                euclidean-quotient
-                safe-euclidean-quotient))
-  (with-test-prefix "euclidean-remainder"
-    (do-tests-1 'euclidean-remainder
-                euclidean-remainder
-                safe-euclidean-remainder))
   (with-test-prefix "euclidean/"
-    (do-tests-2 'euclidean/
-                euclidean/
-                safe-euclidean/))
-
-  (with-test-prefix "centered-quotient"
-    (do-tests-1 'centered-quotient
-                centered-quotient
-                safe-centered-quotient))
-  (with-test-prefix "centered-remainder"
-    (do-tests-1 'centered-remainder
-                centered-remainder
-                safe-centered-remainder))
+    (pass-if (documented? euclidean/))
+    (pass-if (documented? euclidean-quotient))
+    (pass-if (documented? euclidean-remainder))
+
+    (cartesian-product-for-each
+     (lambda (n d)
+       (run-test (list 'euclidean/ n d) #t
+                 (lambda ()
+                   (let-values (((q r) (euclidean/ n d)))
+                     (and (test-eqv? q (euclidean-quotient n d))
+                          (test-eqv? r (euclidean-remainder n d))
+                          (valid-euclidean-answer? n d q r))))))
+     test-numerators test-denominators))
+
   (with-test-prefix "centered/"
-    (do-tests-2 'centered/
-                centered/
-                safe-centered/)))
+    (pass-if (documented? centered/))
+    (pass-if (documented? centered-quotient))
+    (pass-if (documented? centered-remainder))
+
+    (cartesian-product-for-each
+     (lambda (n d)
+       (run-test (list 'centered/ n d) #t
+                 (lambda ()
+                   (let-values (((q r) (centered/ n d)))
+                     (and (test-eqv? q (centered-quotient n d))
+                          (test-eqv? r (centered-remainder n d))
+                          (valid-centered-answer? n d q r))))))
+     test-numerators test-denominators)))


hooks/post-receive
-- 
GNU Guile