* floor, ceiling, etc on exacts [1.6]
@ 2004-04-23 21:11 Kevin Ryde
0 siblings, 0 replies; only message in thread
From: Kevin Ryde @ 2004-04-23 21:11 UTC (permalink / raw)
[-- Attachment #1: Type: text/plain, Size: 666 bytes --]
* numbers.c (scm_floor, scm_ceiling, scm_truncate_number,
scm_round_number): New functions, replacing scm_tc7_cxr definitions,
and ensuring exact arguments give exact results, as required by R5RS.
Derived in part from the same by Marius in the cvs head. Reported by
Ray Lehtiniemi.
* tests/numbers.test (truncate, round, floor, ceiling): Add tests, in
particular exercising exactness fixes and scm_round 2^53-1 fix.
These bits and pieces of tests will be for the cvs head too, though
the 2^53-1 part is still broken there at the moment (scm_round_number
is afflicted by the same problem as scm_round was).
[-- Attachment #2: numbers.c.floor-exact.diff --]
[-- Type: text/plain, Size: 3490 bytes --]
--- numbers.c.~1.135.2.15.~ 2004-04-22 10:27:57.000000000 +1000
+++ numbers.c 2004-04-23 18:20:43.000000000 +1000
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@@ -3892,9 +3892,20 @@
-SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
-/* "Round the inexact number @var{x} towards zero."
- */
+SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0,
+ (SCM x),
+ "Round the inexact number @var{x} towards zero.")
+#define FUNC_NAME s_scm_truncate_number
+{
+ if (SCM_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_make_real (scm_truncate (SCM_REAL_VALUE (x)));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, 1, s_scm_truncate_number);
+}
+#undef FUNC_NAME
+
double
scm_truncate (double x)
{
@@ -3930,10 +3941,6 @@
already. And if it's not then the exponent must be small enough to allow
an 0.5 to be represented, and hence added without a bad rounding. */
-SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
-/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
- * "numbers, round towards even."
- */
double
scm_round (double x)
{
@@ -3949,6 +3956,23 @@
? result - 1 : result;
}
+SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards the nearest integer. "
+ "When it is exactly halfway between two integers, "
+ "round towards the even one.")
+#define FUNC_NAME s_scm_round_number
+{
+ if (SCM_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_make_real (scm_round (SCM_REAL_VALUE (x)));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_round_number, x, 1, s_scm_round_number);
+}
+#undef FUNC_NAME
+
+
SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
@@ -3961,12 +3985,35 @@
}
-SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
-/* "Round the number @var{x} towards minus infinity."
- */
-SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
-/* "Round the number @var{x} towards infinity."
- */
+SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards minus infinity.")
+#define FUNC_NAME s_scm_floor
+{
+ if (SCM_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_make_real (floor (SCM_REAL_VALUE (x)));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards infinity.")
+#define FUNC_NAME s_scm_ceiling
+{
+ if (SCM_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_make_real (ceil (SCM_REAL_VALUE (x)));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+}
+#undef FUNC_NAME
+
+
SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
/* "Return the square root of the real number @var{x}."
*/
[-- Attachment #3: numbers.test.floor-exact.diff --]
[-- Type: text/plain, Size: 6337 bytes --]
--- numbers.test.~1.5.4.3.~ 2002-05-17 02:48:02.000000000 +1000
+++ numbers.test 2004-04-23 18:22:58.000000000 +1000
@@ -1,5 +1,5 @@
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -1274,10 +1274,147 @@
;;; truncate
;;;
+(with-test-prefix "truncate"
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (truncate 0))
+ (exact? (truncate 0))))
+
+ (pass-if "1"
+ (and (= 1 (truncate 1))
+ (exact? (truncate 1))))
+
+ (pass-if "-1"
+ (and (= -1 (truncate -1))
+ (exact? (truncate -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (truncate x))
+ (exact? (truncate x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (truncate x))
+ (exact? (truncate x))))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (truncate 0.0))
+ (inexact? (truncate 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (truncate 1.0))
+ (inexact? (truncate 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (truncate -1.0))
+ (inexact? (truncate -1.0))))
+
+ (pass-if "3.9"
+ (and (= 3.0 (truncate 3.9))
+ (inexact? (truncate 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -3.0 (truncate -3.9))
+ (inexact? (truncate -3.9))))))
+
;;;
;;; round
;;;
+(with-test-prefix "round"
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (round 0))
+ (exact? (round 0))))
+
+ (pass-if "1"
+ (and (= 1 (round 1))
+ (exact? (round 1))))
+
+ (pass-if "-1"
+ (and (= -1 (round -1))
+ (exact? (round -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (round x))
+ (exact? (round x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (round x))
+ (exact? (round x))))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (round 0.0))
+ (inexact? (round 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (round 1.0))
+ (inexact? (round 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (round -1.0))
+ (inexact? (round -1.0))))
+
+ (pass-if "-3.1"
+ (and (= -3.0 (round -3.1))
+ (inexact? (round -3.1))))
+
+ (pass-if "3.1"
+ (and (= 3.0 (round 3.1))
+ (inexact? (round 3.1))))
+
+ (pass-if "3.9"
+ (and (= 4.0 (round 3.9))
+ (inexact? (round 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -4.0 (round -3.9))
+ (inexact? (round -3.9))))
+
+ (pass-if "1.5"
+ (and (= 2.0 (round 1.5))
+ (inexact? (round 1.5))))
+
+ (pass-if "2.5"
+ (and (= 2.0 (round 2.5))
+ (inexact? (round 2.5))))
+
+ (pass-if "3.5"
+ (and (= 4.0 (round 3.5))
+ (inexact? (round 3.5))))
+
+ (pass-if "-1.5"
+ (and (= -2.0 (round -1.5))
+ (inexact? (round -1.5))))
+
+ (pass-if "-2.5"
+ (and (= -2.0 (round -2.5))
+ (inexact? (round -2.5))))
+
+ (pass-if "-3.5"
+ (and (= -4.0 (round -3.5))
+ (inexact? (round -3.5))))
+
+ ;; prior to guile 1.6.5, on an IEEE system an inexact 2^53-1 (ie. a
+ ;; float with mantissa all ones) came out as 2^53 from `round' (except
+ ;; on i386 and m68k systems using the coprocessor and optimizing, where
+ ;; extra precision hid the problem)
+ (pass-if "2^53-1"
+ (let ((x (exact->inexact (1- (ash 1 53)))))
+ (and (= x (round x))
+ (inexact? (round x)))))
+ (pass-if "-(2^53-1)"
+ (let ((x (exact->inexact (- (1- (ash 1 53))))))
+ (and (= x (round x))
+ (inexact? (round x)))))))
+
;;;
;;; exact->inexact
;;;
@@ -1286,10 +1423,102 @@
;;; floor
;;;
+(with-test-prefix "floor"
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (floor 0))
+ (exact? (floor 0))))
+
+ (pass-if "1"
+ (and (= 1 (floor 1))
+ (exact? (floor 1))))
+
+ (pass-if "-1"
+ (and (= -1 (floor -1))
+ (exact? (floor -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (floor x))
+ (exact? (floor x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (floor x))
+ (exact? (floor x))))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (floor 0.0))
+ (inexact? (floor 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (floor 1.0))
+ (inexact? (floor 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (floor -1.0))
+ (inexact? (floor -1.0))))
+
+ (pass-if "3.9"
+ (and (= 3.0 (floor 3.9))
+ (inexact? (floor 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -4.0 (floor -3.9))
+ (inexact? (floor -3.9))))))
+
;;;
;;; ceiling
;;;
+(with-test-prefix "ceiling"
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (ceiling 0))
+ (exact? (ceiling 0))))
+
+ (pass-if "1"
+ (and (= 1 (ceiling 1))
+ (exact? (ceiling 1))))
+
+ (pass-if "-1"
+ (and (= -1 (ceiling -1))
+ (exact? (ceiling -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (ceiling x))
+ (exact? (ceiling x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (ceiling x))
+ (exact? (ceiling x))))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (ceiling 0.0))
+ (inexact? (ceiling 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (ceiling 1.0))
+ (inexact? (ceiling 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (ceiling -1.0))
+ (inexact? (ceiling -1.0))))
+
+ (pass-if "3.9"
+ (and (= 4.0 (ceiling 3.9))
+ (inexact? (ceiling 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -3.0 (ceiling -3.9))
+ (inexact? (ceiling -3.9))))))
+
;;;
;;; sqrt
;;;
[-- Attachment #4: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2004-04-23 21:11 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2004-04-23 21:11 floor, ceiling, etc on exacts [1.6] Kevin Ryde
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).