From: Mark H Weaver <mhw@netris.org>
To: ludo@gnu.org (Ludovic Courtès)
Cc: guile-devel@gnu.org
Subject: [PATCH] Rework the testing framework for number-theoretic division operators
Date: Mon, 31 Jan 2011 01:19:29 -0500 [thread overview]
Message-ID: <87aaihzjbi.fsf_-_@yeeloong.netris.org> (raw)
In-Reply-To: <87aaiivw6t.fsf@gnu.org> ("Ludovic Courtès"'s message of "Sun, 30 Jan 2011 23:55:06 +0100")
[-- Attachment #1: Type: text/plain, Size: 221 bytes --]
ludo@gnu.org (Ludovic Courtès) writes:
> There are related test failures on i686-linux-gnu:
>
> http://hydra.nixos.org/build/875025
I believe this patch should fix the test failures.
Best,
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Rework the testing framework for number-theoretic division operators --]
[-- Type: text/x-diff, Size: 11848 bytes --]
From 650df0667f16cbbf3c05c8774d4d08c793605f47 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Mon, 31 Jan 2011 00:42:35 -0500
Subject: [PATCH] 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.
---
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)))
--
1.5.6.5
next prev parent reply other threads:[~2011-01-31 6:19 UTC|newest]
Thread overview: 12+ messages / expand[flat|nested] mbox.gz Atom feed top
2011-01-30 16:27 [PATCH] Fast R6RS div/mod; improved extensibility of numerics Mark H Weaver
2011-01-30 22:24 ` Andy Wingo
2011-01-30 22:55 ` Ludovic Courtès
2011-01-31 6:19 ` Mark H Weaver [this message]
2011-01-31 8:52 ` [PATCH] Rework the testing framework for number-theoretic division operators Andy Wingo
2011-01-31 17:14 ` [PATCH] Fast R6RS div/mod; improved extensibility of numerics Mark H Weaver
2011-01-31 17:35 ` Mark H Weaver
2011-01-31 19:26 ` Andy Wingo
2011-01-31 20:16 ` Andy Wingo
2011-01-31 20:30 ` Mark H Weaver
2011-01-31 20:46 ` Andy Wingo
2011-01-31 20:46 ` Mark H Weaver
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87aaihzjbi.fsf_-_@yeeloong.netris.org \
--to=mhw@netris.org \
--cc=guile-devel@gnu.org \
--cc=ludo@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).