* [PATCH] First batch of numerics changes
@ 2011-01-26 16:32 Mark H Weaver
2011-01-26 18:07 ` Mark H Weaver
` (2 more replies)
0 siblings, 3 replies; 24+ messages in thread
From: Mark H Weaver @ 2011-01-26 16:32 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 212 bytes --]
Hello all,
Here's my first batch of numerics bugfixes and other changes for
improved mathematical correctness and R6RS compliance. As far as
I can tell, they're ready to commit. Reviews solicited.
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Do not apply `inf?' or `nan?' to strings --]
[-- Type: text/x-diff, Size: 2582 bytes --]
From 4eddcd72d900d34bd19604209f20256a062ecc20 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 25 Jan 2011 18:35:22 -0500
Subject: [PATCH] Do not apply `inf?' or `nan?' to strings
* module/ice-9/format.scm (format): Test to make sure an argument is a
number before applying `inf?' and `nan?' to it. Formerly, format
would call `inf?' and `nan?' on arguments that might be either a
number or a string, although those predicates should ideally throw an
exception when applied to non-number objects.
---
module/ice-9/format.scm | 14 +++++++++-----
1 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index 1681004..7cd0183 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -1,5 +1,5 @@
;;;; "format.scm" Common LISP text output formatter for SLIB
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -1079,7 +1079,8 @@
(padch (format:par pars l 4 format:space-ch #f)))
(cond
- ((or (inf? number) (nan? number))
+ ((and (number? number)
+ (or (inf? number) (nan? number)))
(format:out-inf-nan number width digits #f overch padch))
(digits
@@ -1140,7 +1141,8 @@
(expch (format:par pars l 6 #f #f)))
(cond
- ((or (inf? number) (nan? number))
+ ((and (number? number)
+ (or (inf? number) (nan? number)))
(format:out-inf-nan number width digits edigits overch padch))
(digits ; fixed precision
@@ -1231,7 +1233,8 @@
(overch (if (> l 4) (list-ref pars 4) #f))
(padch (if (> l 5) (list-ref pars 5) #f)))
(cond
- ((or (inf? number) (nan? number))
+ ((and (number? number)
+ (or (inf? number) (nan? number)))
;; FIXME: this isn't right.
(format:out-inf-nan number width digits edigits overch padch))
(else
@@ -1265,7 +1268,8 @@
(padch (format:par pars l 3 format:space-ch #f)))
(cond
- ((or (inf? number) (nan? number))
+ ((and (number? number)
+ (or (inf? number) (nan? number)))
(format:out-inf-nan number width digits #f #f padch))
(else
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Fix NEWS entry regarding changes to `expt' for zero base --]
[-- Type: text/x-diff, Size: 1124 bytes --]
From 300f6d33bceae8750caf8f531f0c01676c4071b3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 25 Jan 2011 18:53:36 -0500
Subject: [PATCH] Fix NEWS entry regarding changes to `expt' for zero base
NEWS: Fix NEWS entry regarding changes to `expt' when base is zero
---
NEWS | 8 ++++----
1 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/NEWS b/NEWS
index c2bb1c1..388f43d 100644
--- a/NEWS
+++ b/NEWS
@@ -23,11 +23,11 @@ manual, for more information.
** `expt' and `integer-expt' changes when the base is 0
-While `(expt 0 0)' is still 1, `(expt 0 N)' for N > 0 is now 0, and
-`(expt 0 N)' for N < 0 is now a NaN value, and likewise for
+While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still
+zero, `(expt 0 N)' for N < 0 is now a NaN value, and likewise for
integer-expt. This is more correct, and conforming to R6RS, but seems
-to be incompatible with R5RS, which would always return 0 for all values
-of N.
+to be incompatible with R5RS, which would return 0 for all non-zero
+values of N.
** And of course, the usual collection of bugfixes
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Add SCM_INUM1 to numbers.h, and make use of it and SCM_INUM0 in numbers.c --]
[-- Type: text/x-diff, Size: 10259 bytes --]
From 2cd8b80949c199a44bc9aea6604b4a77fca7a144 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 25 Jan 2011 18:58:47 -0500
Subject: [PATCH] Add SCM_INUM1 to numbers.h, and make use of it and SCM_INUM0 in numbers.c
* libguile/numbers.h: Add SCM_INUM1, a name for the fixnum 1. This is
analogous to SCM_INUM0, a name for 0, which already existed.
* libguile/numbers.c: Change occurrences of SCM_I_MAKINUM (0) and
SCM_I_MAKINUM (1) to SCM_INUM0 and SCM_INUM1, respectively.
---
libguile/numbers.c | 58 ++++++++++++++++++++++++++--------------------------
libguile/numbers.h | 7 +++--
2 files changed, 33 insertions(+), 32 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 9c33d07..c1b1d98 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -403,7 +403,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
{
if (scm_is_eq (denominator, SCM_INUM0))
scm_num_overflow ("make-ratio");
- if (scm_is_eq (denominator, SCM_I_MAKINUM(1)))
+ if (scm_is_eq (denominator, SCM_INUM1))
return numerator;
}
else
@@ -435,7 +435,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
scm_t_inum y;
y = SCM_I_INUM (denominator);
if (x == y)
- return SCM_I_MAKINUM(1);
+ return SCM_INUM1;
if ((x % y) == 0)
return SCM_I_MAKINUM (x / y);
}
@@ -462,7 +462,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
else
{
if (scm_is_eq (numerator, denominator))
- return SCM_I_MAKINUM(1);
+ return SCM_INUM1;
if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
SCM_I_BIG_MPZ (denominator)))
return scm_divide(numerator, denominator);
@@ -473,7 +473,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
*/
{
SCM divisor = scm_gcd (numerator, denominator);
- if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
+ if (!(scm_is_eq (divisor, SCM_INUM1)))
{
numerator = scm_divide (numerator, divisor);
denominator = scm_divide (denominator, divisor);
@@ -772,7 +772,7 @@ scm_quotient (SCM x, SCM y)
return SCM_I_MAKINUM (-1);
}
else
- return SCM_I_MAKINUM (0);
+ return SCM_INUM0;
}
else
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
@@ -849,7 +849,7 @@ scm_remainder (SCM x, SCM y)
{
/* Special case: x == fixnum-min && y == abs (fixnum-min) */
scm_remember_upto_here_1 (y);
- return SCM_I_MAKINUM (0);
+ return SCM_INUM0;
}
else
return x;
@@ -1932,7 +1932,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
{
bits_to_shift = -bits_to_shift;
if (bits_to_shift >= SCM_LONG_BIT)
- return (nn >= 0 ? SCM_I_MAKINUM (0) : SCM_I_MAKINUM(-1));
+ return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1));
else
return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
}
@@ -2694,7 +2694,7 @@ mem2decimal_from_point (SCM result, SCM mem,
scm_t_bits shift = 1;
scm_t_bits add = 0;
unsigned int digit_value;
- SCM big_shift = SCM_I_MAKINUM (1);
+ SCM big_shift = SCM_INUM1;
idx++;
while (idx != len)
@@ -2882,7 +2882,7 @@ mem2ureal (SCM mem, unsigned int *p_idx,
else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
return SCM_BOOL_F;
else
- result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem,
+ result = mem2decimal_from_point (SCM_INUM0, mem,
p_idx, &x);
}
else
@@ -2933,7 +2933,7 @@ mem2ureal (SCM mem, unsigned int *p_idx,
/* When returning an inexact zero, make sure it is represented as a
floating point value so that we can change its sign.
*/
- if (scm_is_eq (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT)
+ if (scm_is_eq (result, SCM_INUM0) && *p_exactness == INEXACT)
result = scm_from_double (0.0);
return result;
@@ -2984,7 +2984,7 @@ mem2complex (SCM mem, unsigned int idx,
if (idx != len)
return SCM_BOOL_F;
- return scm_make_rectangular (SCM_I_MAKINUM (0), SCM_I_MAKINUM (sign));
+ return scm_make_rectangular (SCM_INUM0, SCM_I_MAKINUM (sign));
}
else
return SCM_BOOL_F;
@@ -3008,7 +3008,7 @@ mem2complex (SCM mem, unsigned int idx,
return SCM_BOOL_F;
if (idx != len)
return SCM_BOOL_F;
- return scm_make_rectangular (SCM_I_MAKINUM (0), ureal);
+ return scm_make_rectangular (SCM_INUM0, ureal);
case '@':
/* polar input: <real>@<real>. */
@@ -4398,7 +4398,7 @@ SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
"Return @math{@var{x}+1}.")
#define FUNC_NAME s_scm_oneplus
{
- return scm_sum (x, SCM_I_MAKINUM (1));
+ return scm_sum (x, SCM_INUM1);
}
#undef FUNC_NAME
@@ -4658,7 +4658,7 @@ SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
"Return @math{@var{x}-1}.")
#define FUNC_NAME s_scm_oneminus
{
- return scm_difference (x, SCM_I_MAKINUM (1));
+ return scm_difference (x, SCM_INUM1);
}
#undef FUNC_NAME
@@ -4939,14 +4939,14 @@ do_divide (SCM x, SCM y, int inexact)
{
if (inexact)
return scm_from_double (1.0 / (double) xx);
- else return scm_i_make_ratio (SCM_I_MAKINUM(1), x);
+ else return scm_i_make_ratio (SCM_INUM1, x);
}
}
else if (SCM_BIGP (x))
{
if (inexact)
return scm_from_double (1.0 / scm_i_big2dbl (x));
- else return scm_i_make_ratio (SCM_I_MAKINUM(1), x);
+ else return scm_i_make_ratio (SCM_INUM1, x);
}
else if (SCM_REALP (x))
{
@@ -5410,7 +5410,7 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
/* Adjust so that the rounding is towards even. */
if (scm_is_true (scm_num_eq_p (plus_half, result))
&& scm_is_true (scm_odd_p (result)))
- return scm_difference (result, SCM_I_MAKINUM (1));
+ return scm_difference (result, SCM_INUM1);
else
return result;
}
@@ -5440,7 +5440,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
/* For negative x, we need to return q-1 unless x is an
integer. But fractions are never integer, per our
assumptions. */
- return scm_difference (q, SCM_I_MAKINUM (1));
+ return scm_difference (q, SCM_INUM1);
}
}
else
@@ -5471,7 +5471,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
/* For positive x, we need to return q+1 unless x is an
integer. But fractions are never integer, per our
assumptions. */
- return scm_sum (q, SCM_I_MAKINUM (1));
+ return scm_sum (q, SCM_INUM1);
}
}
else
@@ -5743,7 +5743,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
else if (scm_is_number (z))
return scm_log (scm_sum (z,
scm_sqrt (scm_sum (scm_product (z, z),
- SCM_I_MAKINUM (1)))));
+ SCM_INUM1))));
else
SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
}
@@ -5759,7 +5759,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
else if (scm_is_number (z))
return scm_log (scm_sum (z,
scm_sqrt (scm_difference (scm_product (z, z),
- SCM_I_MAKINUM (1)))));
+ SCM_INUM1))));
else
SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
}
@@ -5773,8 +5773,8 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
return scm_from_double (atanh (scm_to_double (z)));
else if (scm_is_number (z))
- return scm_divide (scm_log (scm_divide (scm_sum (SCM_I_MAKINUM (1), z),
- scm_difference (SCM_I_MAKINUM (1), z))),
+ return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
+ scm_difference (SCM_INUM1, z))),
SCM_I_MAKINUM (2));
else
SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
@@ -5911,9 +5911,9 @@ SCM
scm_denominator (SCM z)
{
if (SCM_I_INUMP (z))
- return SCM_I_MAKINUM (1);
+ return SCM_INUM1;
else if (SCM_BIGP (z))
- return SCM_I_MAKINUM (1);
+ return SCM_INUM1;
else if (SCM_FRACTIONP (z))
return SCM_FRACTION_DENOMINATOR (z);
else if (SCM_REALP (z))
@@ -6093,9 +6093,9 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
SCM ex = scm_inexact_to_exact (x);
SCM int_part = scm_floor (ex);
- SCM tt = SCM_I_MAKINUM (1);
- SCM a1 = SCM_I_MAKINUM (0), a2 = SCM_I_MAKINUM (1), a = SCM_I_MAKINUM (0);
- SCM b1 = SCM_I_MAKINUM (1), b2 = SCM_I_MAKINUM (0), b = SCM_I_MAKINUM (0);
+ SCM tt = SCM_INUM1;
+ SCM a1 = SCM_INUM0, a2 = SCM_INUM1, a = SCM_INUM0;
+ SCM b1 = SCM_INUM1, b2 = SCM_INUM0, b = SCM_INUM0;
SCM rx;
int i = 0;
@@ -6664,7 +6664,7 @@ scm_init_numbers ()
scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
#endif
- exactly_one_half = scm_divide (SCM_I_MAKINUM (1), SCM_I_MAKINUM (2));
+ exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
#include "libguile/numbers.x"
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index a3701a6..740dc80 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -3,7 +3,7 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -68,8 +68,9 @@ typedef scm_t_int32 scm_t_wchar;
#define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n))
-/* A name for 0. */
-#define SCM_INUM0 (SCM_I_MAKINUM (0))
+#define SCM_INUM0 (SCM_I_MAKINUM (0)) /* A name for 0 */
+#define SCM_INUM1 (SCM_I_MAKINUM (1)) /* A name for 1 */
+
/* SCM_MAXEXP is the maximum double precision exponent
* SCM_FLTMAX is less than or scm_equal the largest single precision float
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: Implement `finite?' in core and fix R6RS `finite?' and `infinite?' --]
[-- Type: text/x-diff, Size: 8028 bytes --]
From 5d0a3351430f1c6b2921380114661b1bd069e23f Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:34:02 -0500
Subject: [PATCH] Implement `finite?' in core and fix R6RS `finite?' and `infinite?'
* libguile/numbers.c (scm_finite_p): Add new predicate `finite?' from
R6RS to guile core, which returns #t if and only if its argument is
neither infinite nor a NaN. Note that this is not the same as (not
(inf? x)) or (not (infinite? x)), since NaNs are neither finite nor
infinite.
* test-suite/tests/numbers.test: Add test cases for `finite?'.
* module/rnrs/base.scm: Import `inf?' as `infinite?' instead of
reimplementing it. Previously, the R6RS implementation of
`infinite?' did not detect non-real complex infinities, nor did it
throw exceptions for non-numbers. (Note that NaNs _are_ considered
numbers by scheme, despite their name).
Import `finite?' instead of reimplementing it. Previously, the R6RS
implementation of `finite?' returned #t for both NaNs and non-real
complex infinities, in violation of R6RS.
* NEWS: Add NEWS entries, and reorganize existing numerics-related
entries together under one subheading.
* doc/ref/api-data.texi (Real and Rational Numbers): Add docs for
`finite?' and scm_finite_p.
---
NEWS | 39 +++++++++++++++++++++++++++++++--------
doc/ref/api-data.texi | 9 ++++++++-
libguile/numbers.c | 22 ++++++++++++++++++++++
module/rnrs/base.scm | 6 ++----
test-suite/tests/numbers.test | 26 ++++++++++++++++++++++++++
5 files changed, 89 insertions(+), 13 deletions(-)
diff --git a/NEWS b/NEWS
index 388f43d..757f783 100644
--- a/NEWS
+++ b/NEWS
@@ -10,18 +10,14 @@ latest prerelease, and a full NEWS corresponding to 1.8 -> 2.0.
Changes in 1.9.15 (since the 1.9.14 prerelease):
-** Infinities are no longer integers.
+** Changes and bugfixes in numerics code
+
+*** Infinities are no longer integers.
Following the R6RS, infinities (+inf.0 and -inf.0) are no longer
considered to be integers.
-** New reader option: `hungry-eol-escapes'
-
-Guile's string syntax is more compatible with R6RS when the
-`hungry-eol-escapes' option is enabled. See "String Syntax" in the
-manual, for more information.
-
-** `expt' and `integer-expt' changes when the base is 0
+*** `expt' and `integer-expt' changes when the base is 0
While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still
zero, `(expt 0 N)' for N < 0 is now a NaN value, and likewise for
@@ -29,6 +25,33 @@ integer-expt. This is more correct, and conforming to R6RS, but seems
to be incompatible with R5RS, which would return 0 for all non-zero
values of N.
+*** New procedure: `finite?'
+
+Add scm_finite_p `finite?' from R6RS to guile core, which returns #t
+if and only if its argument is neither infinite nor a NaN. Note that
+this is not the same as (not (inf? x)) or (not (infinite? x)), since
+NaNs are neither finite nor infinite.
+
+*** R6RS base library changes
+
+**** `infinite?' changes
+
+`infinite?' now returns #t for non-real complex infinities, and throws
+exceptions for non-numbers. (Note that NaNs _are_ considered numbers
+by scheme, despite their name).
+
+**** `finite?' changes
+
+`finite?' now returns #f for NaNs and non-real complex infinities, and
+throws exceptions for non-numbers. (Note that NaNs _are_ considered
+numbers by scheme, despite their name).
+
+** New reader option: `hungry-eol-escapes'
+
+Guile's string syntax is more compatible with R6RS when the
+`hungry-eol-escapes' option is enabled. See "String Syntax" in the
+manual, for more information.
+
** And of course, the usual collection of bugfixes
Interested users should see the ChangeLog for more information.
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 4835f30..fc253b0 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -549,7 +549,8 @@ While @samp{+nan.0} is not @code{=} to itself, it is @code{eqv?} to
itself.
To test for the special values, use the functions @code{inf?} and
-@code{nan?}.
+@code{nan?}. To test for numbers than are neither infinite nor a NaN,
+use @code{finite?}.
@deffn {Scheme Procedure} real? obj
@deffnx {C Function} scm_real_p (obj)
@@ -597,6 +598,12 @@ Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0},
Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise.
@end deffn
+@deffn {Scheme Procedure} finite? x
+@deffnx {C Function} scm_finite_p (x)
+Return @code{#t} if @var{x} is neither infinite nor a NaN,
+@code{#f} otherwise.
+@end deffn
+
@deffn {Scheme Procedure} nan
@deffnx {C Function} scm_nan ()
Return NaN.
diff --git a/libguile/numbers.c b/libguile/numbers.c
index c1b1d98..174ad23 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -79,6 +79,10 @@
typedef scm_t_signed_bits scm_t_inum;
#define scm_from_inum(x) (scm_from_signed_integer (x))
+/* Tests to see if a C double is neither infinite nor a NaN.
+ TODO: if it's available, use C99's isfinite(x) instead */
+#define SCM_I_CDBL_IS_FINITE(x) (!isinf(x) && !isnan(x))
+
\f
/*
@@ -581,6 +585,24 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is neither infinite\n"
+ "nor a NaN, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_finite_p
+{
+ if (SCM_REALP (x))
+ return scm_from_bool (SCM_I_CDBL_IS_FINITE (SCM_REAL_VALUE (x)));
+ else if (SCM_COMPLEXP (x))
+ return scm_from_bool (SCM_I_CDBL_IS_FINITE (SCM_COMPLEX_REAL (x))
+ && SCM_I_CDBL_IS_FINITE (SCM_COMPLEX_IMAG (x)));
+ else if (SCM_NUMBERP (x))
+ return SCM_BOOL_T;
+ else
+ SCM_WRONG_TYPE_ARG (1, x);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is either @samp{+inf.0}\n"
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index a6ae1b9..c7579c3 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -1,6 +1,6 @@
;;; base.scm --- The R6RS base library
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -76,6 +76,7 @@
(import (rename (except (guile) error raise)
(quotient div)
(modulo mod)
+ (inf? infinite?)
(exact->inexact inexact)
(inexact->exact exact))
(srfi srfi-11))
@@ -98,9 +99,6 @@
(let ((sym (car syms)))
(and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
- (define (infinite? x) (or (eqv? x +inf.0) (eqv? x -inf.0)))
- (define (finite? x) (not (infinite? x)))
-
(define (exact-integer-sqrt x)
(let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 5ea4764..d9a75f3 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -305,6 +305,32 @@
(pass-if (even? (* 2 fixnum-min))))
;;;
+;;; finite?
+;;;
+
+(with-test-prefix "finite?"
+ (pass-if (documented? finite?))
+ (pass-if (not (finite? (inf))))
+ (pass-if (not (finite? +inf.0)))
+ (pass-if (not (finite? -inf.0)))
+ (pass-if (not (finite? +inf.0+1i)))
+ (pass-if (not (finite? -inf.0+1i)))
+ (pass-if (not (finite? +1+inf.0i)))
+ (pass-if (not (finite? +1-inf.0i)))
+ (pass-if (not (finite? (nan))))
+ (pass-if (not (finite? +nan.0)))
+ (pass-if (not (finite? 1+nan.0i)))
+ (pass-if (not (finite? +nan.0+nan.0i)))
+ (pass-if (finite? 0))
+ (pass-if (finite? 0.0))
+ (pass-if (finite? -0.0))
+ (pass-if (finite? 42.0))
+ (pass-if (finite? 1/2))
+ (pass-if (finite? 42.0+700i))
+ (pass-if (finite? (+ fixnum-max 1)))
+ (pass-if (finite? (- fixnum-min 1))))
+
+;;;
;;; inf? and inf
;;;
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: Optimize scm_exact_p by making use of SCM_INEXACTP --]
[-- Type: text/x-diff, Size: 3067 bytes --]
From e01510607a341085d90cf9be8af303011e933f79 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:36:05 -0500
Subject: [PATCH] Optimize scm_exact_p by making use of SCM_INEXACTP
* libguile/numbers.c (scm_exact_p): Optimize by making use of the
SCM_INEXACTP macro.
(scm_inexact_p): Move it next to scm_exact_p, and add else's.
* test-suite/tests/numbers.test: Add test cases for `exact?'
and `inexact?' applied to infinities and NaNs.
---
libguile/numbers.c | 40 +++++++++++++++++++---------------------
test-suite/tests/numbers.test | 9 ++++++++-
2 files changed, 27 insertions(+), 22 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 174ad23..f417559 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -503,15 +503,28 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
"otherwise.")
#define FUNC_NAME s_scm_exact_p
{
- if (SCM_I_INUMP (x))
- return SCM_BOOL_T;
- if (SCM_BIGP (x))
+ if (SCM_INEXACTP (x))
+ return SCM_BOOL_F;
+ else if (SCM_NUMBERP (x))
return SCM_BOOL_T;
- if (SCM_FRACTIONP (x))
+ else
+ SCM_WRONG_TYPE_ARG (1, x);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
+ "else.")
+#define FUNC_NAME s_scm_inexact_p
+{
+ if (SCM_INEXACTP (x))
return SCM_BOOL_T;
- if (SCM_NUMBERP (x))
+ else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
- SCM_WRONG_TYPE_ARG (1, x);
+ else
+ SCM_WRONG_TYPE_ARG (1, x);
}
#undef FUNC_NAME
@@ -3364,21 +3377,6 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
- "else.")
-#define FUNC_NAME s_scm_inexact_p
-{
- if (SCM_INEXACTP (x))
- return SCM_BOOL_T;
- if (SCM_NUMBERP (x))
- return SCM_BOOL_F;
- SCM_WRONG_TYPE_ARG (1, x);
-}
-#undef FUNC_NAME
-
-
SCM scm_i_num_eq_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
(SCM x, SCM y, SCM rest),
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index d9a75f3..27de045 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -240,7 +240,11 @@
(eq? #f (exact? (sqrt (- (expt fixnum-max 2) 1)))))
(pass-if "sqrt ((fixnum-max+1)^2 - 1)"
- (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1)))))))
+ (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1)))))
+
+ (pass-if (not (exact? +inf.0)))
+ (pass-if (not (exact? -inf.0)))
+ (pass-if (not (exact? +nan.0)))))
;;;
;;; exp
@@ -1559,6 +1563,9 @@
(pass-if (not (inexact? (- 1 fixnum-min))))
(pass-if (inexact? 1.3))
(pass-if (inexact? 3.1+4.2i))
+ (pass-if (inexact? +inf.0))
+ (pass-if (inexact? -inf.0))
+ (pass-if (inexact? +nan.0))
(pass-if-exception "char"
exception:wrong-type-arg
(not (inexact? #\a)))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: Remove useless code from do_divide --]
[-- Type: text/x-diff, Size: 3085 bytes --]
From d6fdf74639bb7a381e20cde6294b61beb8ef8229 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 02:50:03 -0500
Subject: [PATCH] Remove useless code from do_divide
* libguile/numbers.c (do_divide): Remove code which handled a case
that never occurs: a zero bignum.
---
libguile/numbers.c | 60 ++++++++++++++++++++--------------------------------
1 files changed, 23 insertions(+), 37 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index f417559..e25242f 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5124,47 +5124,33 @@ do_divide (SCM x, SCM y, int inexact)
}
else if (SCM_BIGP (y))
{
- int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
- if (y_is_zero)
+ /* big_x / big_y */
+ if (inexact)
{
-#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
- scm_num_overflow (s_divide);
-#else
- int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
- scm_remember_upto_here_1 (x);
- return (sgn == 0) ? scm_nan () : scm_inf ();
-#endif
+ /* It's easily possible for the ratio x/y to fit a double
+ but one or both x and y be too big to fit a double,
+ hence the use of mpq_get_d rather than converting and
+ dividing. */
+ mpq_t q;
+ *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
+ *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
+ return scm_from_double (mpq_get_d (q));
}
else
{
- /* big_x / big_y */
- if (inexact)
- {
- /* It's easily possible for the ratio x/y to fit a double
- but one or both x and y be too big to fit a double,
- hence the use of mpq_get_d rather than converting and
- dividing. */
- mpq_t q;
- *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
- *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
- return scm_from_double (mpq_get_d (q));
- }
- else
- {
- int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- if (divisible_p)
- {
- SCM result = scm_i_mkbig ();
- mpz_divexact (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (result);
- }
- else
- return scm_i_make_ratio (x, y);
- }
+ int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ if (divisible_p)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ return scm_i_make_ratio (x, y);
}
}
else if (SCM_REALP (y))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #8: Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p --]
[-- Type: text/x-diff, Size: 2656 bytes --]
From c42d03050ea0f96556e73e405e530b78bb85aba7 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 02:56:20 -0500
Subject: [PATCH] Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p
* libguile/eq.c (scm_equal_p): Add a special case for fractions with
differing SCM_CELL_TYPE, which might nonetheless be considered equal
(due to the use of 0x10000 as a flag), to scm_equal_p. This code
was already present in scm_eqv_p.
(scm_eqv_p): Move comment (regarding special case for fractions)
next to the corresponding code.
---
libguile/eq.c | 19 +++++++++++++------
1 files changed, 13 insertions(+), 6 deletions(-)
diff --git a/libguile/eq.c b/libguile/eq.c
index 7502559..dc548b8 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -170,11 +170,6 @@ SCM scm_eqv_p (SCM x, SCM y)
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
{
- /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
- but this checks the entire type word, so fractions may be accidentally
- flagged here as unequal. Perhaps I should use the 4th double_cell word?
- */
-
/* treat mixes of real and complex types specially */
if (SCM_INEXACTP (x))
{
@@ -190,8 +185,13 @@ SCM scm_eqv_p (SCM x, SCM y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
+ /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
+ but this checks the entire type word, so fractions may be accidentally
+ flagged here as unequal. Perhaps I should use the 4th double_cell word?
+ */
if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
+
return SCM_BOOL_F;
}
if (SCM_NUMP (x))
@@ -322,6 +322,13 @@ scm_equal_p (SCM x, SCM y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
+ /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
+ but this checks the entire type word, so fractions may be accidentally
+ flagged here as unequal. Perhaps I should use the 4th double_cell word?
+ */
+ if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
+ return scm_i_fraction_equalp (x, y);
+
/* Vectors can be equal to one-dimensional arrays.
*/
if (scm_is_array (x) && scm_is_array (y))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #9: equal? and eqv? equivalent for numbers, and (not (eqv? +nan.0 +nan.0)) --]
[-- Type: text/x-diff, Size: 12856 bytes --]
From 0a7ce98bd8bfc34176ca78ad91a29c5b2087db0f Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 04:20:32 -0500
Subject: [PATCH] equal? and eqv? equivalent for numbers, and (not (eqv? +nan.0 +nan.0))
* libguile/numbers.c (scm_real_equalp, scm_bigequal,
scm_complex_equalp, scm_i_fraction_equalp): Move to eq.c.
* libguile/eq.c (scm_bigequal, scm_i_fraction_equalp):
Do the same thing that `eqv?' does.
(scm_real_equalp): Do the same thing that `eqv?' does.
Previously worked differently in some cases, e.g.
when comparing signed zeroes.
Also return #f if either argument is a NaN, per R6RS.
Previously returned #t if both were real NaNs.
(scm_complex_equalp): Do the same thing that `eqv?' does.
Previously worked differently in some cases, e.g.
when comparing signed zeroes.
Also return #f if either argument is a NaN, per R6RS.
(real_eqv): Return false if either argument is a NaN, per R6RS.
Previously returned true if both were NaNs.
* test-suite/standalone/test-conversion.c (test_from_double):
Modify NaN test to use scm_nan_p instead of scm_eqv_p,
since scm_eqv_p can no longer be used to detect NaNs.
* test-suite/tests/numbers.test: Add test cases for `eqv?' and
`equal?'.
* doc/ref/api-data.texi (Real and Rational Numbers): Update
docs to reflect changes in NaN handling, and improve
discussion on infinities and NaNs.
* NEWS: Add NEWS entries regarding changes in NaN handling and
equivalence of `equal?' and `eqv?'.
---
NEWS | 13 ++++++
doc/ref/api-data.texi | 37 +++++++++-------
libguile/eq.c | 42 +++++++++++++++---
libguile/numbers.c | 34 ---------------
test-suite/standalone/test-conversion.c | 8 +++-
test-suite/tests/numbers.test | 71 +++++++++++++++++++++++++++++++
6 files changed, 145 insertions(+), 60 deletions(-)
diff --git a/NEWS b/NEWS
index 757f783..d5fdb08 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,19 @@ Changes in 1.9.15 (since the 1.9.14 prerelease):
** Changes and bugfixes in numerics code
+*** `eqv?' and `equal?' now handle numbers equivalently
+
+scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for
+numeric values, per R5RS. Previously, equal? worked differently,
+e.g. (equal? 0.0 -0.0) returned #t but (eqv? 0.0 -0.0) returned #f.
+
+*** NaNs are no longer `eqv?' nor `equal?'
+
+scm_eqv_p `eqv?', scm_equal_p `equal?' and scm_real_equalp now return
+#f if either argument is a NaN, per R6RS. Previously, they returned
+#t if both were real NaNs, or both were non-real complex NaNs. Use
+scm_nan_p `nan?' to test for NaNs.
+
*** Infinities are no longer integers.
Following the R6RS, infinities (+inf.0 and -inf.0) are no longer
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index fc253b0..55457cd 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -526,18 +526,28 @@ by sufficient powers of 10 (or in fact, 2). For example,
@code{rational?} and @code{real?} predicates are equivalent.
-Dividing by an exact zero leads to a error message, as one might
-expect. However, dividing by an inexact zero does not produce an
-error. Instead, the result of the division is either plus or minus
-infinity, depending on the sign of the divided number.
-
-The infinities are written @samp{+inf.0} and @samp{-inf.0},
+Dividing by an exact zero leads to a error message, as one might expect.
+However, dividing by an inexact zero does not produce an error.
+Instead, the result of the division is either plus or minus infinity,
+depending on the sign of the divided number and the sign of the zero
+divisor (some platforms support signed zeroes @samp{0.0} and
+@samp{-0.0}).
+
+The real infinities are written @samp{+inf.0} and @samp{-inf.0},
respectively. This syntax is also recognized by @code{read} as an
extension to the usual Scheme syntax. The infinities are considered to
-be inexact, non-integer values.
+be inexact, non-integer values. You can test for them using
+@code{inf?}.
+
+Dividing zero by an inexact zero yields a NaN (`not a number') value,
+although they are actually considered numbers by Scheme. NaNs are
+unequal to all numbers, including themselves. Attempts to compare them
+with any number using @code{equal?}, @code{eqv?}, @code{=}, @code{<},
+@code{>}, @code{<=} or @code{>=} always returns @code{#f}. You can test
+for them using @code{nan?}.
-Dividing zero by zero yields something that is not a number at all:
-@samp{+nan.0}. This is the special `not a number' value.
+To test for numbers that are neither infinite nor a NaN, use
+@code{finite?}.
On platforms that follow @acronym{IEEE} 754 for their floating point
arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values
@@ -545,13 +555,6 @@ are implemented using the corresponding @acronym{IEEE} 754 values.
They behave in arithmetic operations like @acronym{IEEE} 754 describes
it, i.e., @code{(= +nan.0 +nan.0)} @result{} @code{#f}.
-While @samp{+nan.0} is not @code{=} to itself, it is @code{eqv?} to
-itself.
-
-To test for the special values, use the functions @code{inf?} and
-@code{nan?}. To test for numbers than are neither infinite nor a NaN,
-use @code{finite?}.
-
@deffn {Scheme Procedure} real? obj
@deffnx {C Function} scm_real_p (obj)
Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note
@@ -595,7 +598,7 @@ Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0},
@deffn {Scheme Procedure} nan? x
@deffnx {C Function} scm_nan_p (x)
-Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise.
+Return @code{#t} if @var{x} is a NaN, @code{#f} otherwise.
@end deffn
@deffn {Scheme Procedure} finite? x
diff --git a/libguile/eq.c b/libguile/eq.c
index dc548b8..cbd2ceb 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -118,7 +118,38 @@ scm_eq_p (SCM x, SCM y)
static int
real_eqv (double x, double y)
{
- return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
+ return !memcmp (&x, &y, sizeof(double)) && (x == x);
+}
+
+SCM
+scm_real_equalp (SCM x, SCM y)
+{
+ return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
+}
+
+SCM
+scm_bigequal (SCM x, SCM y)
+{
+ return scm_from_bool (scm_i_bigcmp (x, y) == 0);
+}
+
+SCM
+scm_complex_equalp (SCM x, SCM y)
+{
+ return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
+ SCM_COMPLEX_REAL (y))
+ && real_eqv (SCM_COMPLEX_IMAG (x),
+ SCM_COMPLEX_IMAG (y)));
+}
+
+SCM
+scm_i_fraction_equalp (SCM x, SCM y)
+{
+ return scm_from_bool
+ (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_NUMERATOR (y)))
+ && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_DENOMINATOR (y))));
}
static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
@@ -197,16 +228,13 @@ SCM scm_eqv_p (SCM x, SCM y)
if (SCM_NUMP (x))
{
if (SCM_BIGP (x)) {
- return scm_from_bool (scm_i_bigcmp (x, y) == 0);
+ return scm_bigequal (x, y);
} else if (SCM_REALP (x)) {
- return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
+ return scm_real_equalp (x, y);
} else if (SCM_FRACTIONP (x)) {
return scm_i_fraction_equalp (x, y);
} else { /* complex */
- return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
- SCM_COMPLEX_REAL (y))
- && real_eqv (SCM_COMPLEX_IMAG (x),
- SCM_COMPLEX_IMAG (y)));
+ return scm_complex_equalp (x, y);
}
}
return SCM_BOOL_F;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index e25242f..166503a 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -3254,40 +3254,6 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
/*** END strs->nums ***/
-SCM
-scm_bigequal (SCM x, SCM y)
-{
- int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_from_bool (0 == result);
-}
-
-SCM
-scm_real_equalp (SCM x, SCM y)
-{
- return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
-}
-
-SCM
-scm_complex_equalp (SCM x, SCM y)
-{
- return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
- && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
-}
-
-SCM
-scm_i_fraction_equalp (SCM x, SCM y)
-{
- if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
- SCM_FRACTION_NUMERATOR (y)))
- || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
- SCM_FRACTION_DENOMINATOR (y))))
- return SCM_BOOL_F;
- else
- return SCM_BOOL_T;
-}
-
-
SCM_DEFINE (scm_number_p, "number?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is a number, @code{#f}\n"
diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c
index 124ae9d..cce4258 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -866,7 +866,11 @@ test_from_double ()
test_9 (0.1, "0.1");
test_9 (guile_Inf, "+inf.0");
test_9 (-guile_Inf, "-inf.0");
- test_9 (guile_NaN, "+nan.0");
+ if (scm_is_false (scm_nan_p (scm_from_double (guile_NaN))))
+ {
+ fprintf (stderr, "fail: scm_nan_p (scm_from_double (+nan.0))\n");
+ exit (EXIT_FAILURE);
+ }
}
typedef struct {
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 27de045..1528f52 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1599,7 +1599,15 @@
(pass-if (equal? -7 -7))
(pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max)))
(pass-if (equal? (- fixnum-min 1) (- fixnum-min 1)))
+ (pass-if (equal? 0.0 0.0))
+ (pass-if (equal? -0.0 -0.0))
+ (pass-if (not (equal? 0.0 -0.0)))
(pass-if (not (equal? 0 1)))
+ (pass-if (not (equal? 0 0.0)))
+ (pass-if (not (equal? 1 1.0)))
+ (pass-if (not (equal? 0.0 0)))
+ (pass-if (not (equal? 1.0 1)))
+ (pass-if (not (equal? -1.0 -1)))
(pass-if (not (equal? fixnum-max (+ 1 fixnum-max))))
(pass-if (not (equal? (+ 1 fixnum-max) fixnum-max)))
(pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max))))
@@ -1644,6 +1652,69 @@
(pass-if (not (equal? +nan.0 (ash 3 1023)))))
;;;
+;;; eqv?
+;;;
+
+(with-test-prefix "eqv?"
+ (pass-if (documented? eqv?))
+ (pass-if (eqv? 0 0))
+ (pass-if (eqv? 7 7))
+ (pass-if (eqv? -7 -7))
+ (pass-if (eqv? (+ 1 fixnum-max) (+ 1 fixnum-max)))
+ (pass-if (eqv? (- fixnum-min 1) (- fixnum-min 1)))
+ (pass-if (eqv? 0.0 0.0))
+ (pass-if (eqv? -0.0 -0.0))
+ (pass-if (not (eqv? 0.0 -0.0)))
+ (pass-if (not (eqv? 0 1)))
+ (pass-if (not (eqv? 0 0.0)))
+ (pass-if (not (eqv? 1 1.0)))
+ (pass-if (not (eqv? 0.0 0)))
+ (pass-if (not (eqv? 1.0 1)))
+ (pass-if (not (eqv? -1.0 -1)))
+ (pass-if (not (eqv? fixnum-max (+ 1 fixnum-max))))
+ (pass-if (not (eqv? (+ 1 fixnum-max) fixnum-max)))
+ (pass-if (not (eqv? (+ 1 fixnum-max) (+ 2 fixnum-max))))
+ (pass-if (not (eqv? fixnum-min (- fixnum-min 1))))
+ (pass-if (not (eqv? (- fixnum-min 1) fixnum-min)))
+ (pass-if (not (eqv? (- fixnum-min 1) (- fixnum-min 2))))
+ (pass-if (not (eqv? (+ fixnum-max 1) (- fixnum-min 1))))
+
+ (pass-if (not (eqv? (ash 1 256) +inf.0)))
+ (pass-if (not (eqv? +inf.0 (ash 1 256))))
+ (pass-if (not (eqv? (ash 1 256) -inf.0)))
+ (pass-if (not (eqv? -inf.0 (ash 1 256))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (pass-if (not (eqv? (ash 1 1024) +inf.0)))
+ (pass-if (not (eqv? +inf.0 (ash 1 1024))))
+ (pass-if (not (eqv? (- (ash 1 1024)) -inf.0)))
+ (pass-if (not (eqv? -inf.0 (- (ash 1 1024)))))
+
+ (pass-if (not (eqv? +nan.0 +nan.0)))
+ (pass-if (not (eqv? 0 +nan.0)))
+ (pass-if (not (eqv? +nan.0 0)))
+ (pass-if (not (eqv? 1 +nan.0)))
+ (pass-if (not (eqv? +nan.0 1)))
+ (pass-if (not (eqv? -1 +nan.0)))
+ (pass-if (not (eqv? +nan.0 -1)))
+
+ (pass-if (not (eqv? (ash 1 256) +nan.0)))
+ (pass-if (not (eqv? +nan.0 (ash 1 256))))
+ (pass-if (not (eqv? (- (ash 1 256)) +nan.0)))
+ (pass-if (not (eqv? +nan.0 (- (ash 1 256)))))
+
+ (pass-if (not (eqv? (ash 1 8192) +nan.0)))
+ (pass-if (not (eqv? +nan.0 (ash 1 8192))))
+ (pass-if (not (eqv? (- (ash 1 8192)) +nan.0)))
+ (pass-if (not (eqv? +nan.0 (- (ash 1 8192)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (not (eqv? (ash 3 1023) +nan.0)))
+ (pass-if (not (eqv? +nan.0 (ash 3 1023)))))
+
+;;;
;;; =
;;;
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #10: Improve docs for `inf?' regarding non-real complex infinities --]
[-- Type: text/x-diff, Size: 1913 bytes --]
From 5aa2810a3ad7fb201d7872e6f1ed301dfec9ecc6 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 04:34:55 -0500
Subject: [PATCH] Improve docs for `inf?' regarding non-real complex infinities
* libguile/numbers.c: (scm_inf_p) Improve documentation string to
mention that complex numbers with infinite real or imaginary part
are also considered infinite.
* doc/ref/api-data.texi (Real and Rational Numbers): Improve
documentation for `inf?' to mention that complex numbers with
infinite real or imaginary part are also considered infinite.
---
doc/ref/api-data.texi | 5 +++--
libguile/numbers.c | 5 +++--
2 files changed, 6 insertions(+), 4 deletions(-)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 55457cd..2055eb1 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -592,8 +592,9 @@ to use @code{inexact->exact} on the arguments.
@deffn {Scheme Procedure} inf? x
@deffnx {C Function} scm_inf_p (x)
-Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0},
-@code{#f} otherwise.
+Return @code{#t} if @var{x} is @samp{+inf.0}, @samp{-inf.0}, or
+a complex number whose real or imaginary part is infinite.
+Otherwise return @code{#f}.
@end deffn
@deffn {Scheme Procedure} nan? x
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 166503a..dc10a03 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -618,8 +618,9 @@ SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0,
SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
(SCM x),
- "Return @code{#t} if @var{x} is either @samp{+inf.0}\n"
- "or @samp{-inf.0}, @code{#f} otherwise.")
+ "Return @code{#t} if @var{x} is @samp{+inf.0}, @samp{-inf.0},\n"
+ "or a complex number whose real or imaginary part is infinite.\n"
+ "Otherwise return @code{#f}.")
#define FUNC_NAME s_scm_inf_p
{
if (SCM_REALP (x))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #11: `inf?' and `nan?' throw exceptions when applied to non-numbers --]
[-- Type: text/x-diff, Size: 1939 bytes --]
From 68b1acaefc448add19e2ea90f2acf2b165539c64 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 04:42:04 -0500
Subject: [PATCH] `inf?' and `nan?' throw exceptions when applied to non-numbers
* libguile/numbers.c (scm_inf_p, scm_nan_p): Throw an exception if
applied to a non-number object. Previously returned #f. (Note that
NaNs _are_ considered numbers by scheme, despite their name).
---
NEWS | 6 ++++++
libguile/numbers.c | 8 ++++++--
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/NEWS b/NEWS
index d5fdb08..80a8c32 100644
--- a/NEWS
+++ b/NEWS
@@ -38,6 +38,12 @@ integer-expt. This is more correct, and conforming to R6RS, but seems
to be incompatible with R5RS, which would return 0 for all non-zero
values of N.
+*** `inf?' and `nan?' now throw exceptions for non-numbers
+
+scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed
+non-number objects. Previously they returned #f. (Note that NaNs
+_are_ considered numbers by scheme, despite their name).
+
*** New procedure: `finite?'
Add scm_finite_p `finite?' from R6RS to guile core, which returns #t
diff --git a/libguile/numbers.c b/libguile/numbers.c
index dc10a03..48de05a 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -628,8 +628,10 @@ SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
else if (SCM_COMPLEXP (x))
return scm_from_bool (isinf (SCM_COMPLEX_REAL (x))
|| isinf (SCM_COMPLEX_IMAG (x)));
- else
+ else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
+ else
+ SCM_WRONG_TYPE_ARG (1, x);
}
#undef FUNC_NAME
@@ -644,8 +646,10 @@ SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
else if (SCM_COMPLEXP (n))
return scm_from_bool (isnan (SCM_COMPLEX_REAL (n))
|| isnan (SCM_COMPLEX_IMAG (n)));
- else
+ else if (SCM_NUMBERP (n))
return SCM_BOOL_F;
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
}
#undef FUNC_NAME
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #12: Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1 --]
[-- Type: text/x-diff, Size: 4005 bytes --]
From 17f400a4aee7ff9076ed131a259e12083048b4f9 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 05:21:03 -0500
Subject: [PATCH] Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1
* libguile/numbers.c (scm_difference, scm_product):
Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1,
aka -SCM_MOST_NEGATIVE_FIXNUM. Previously, these cases
failed to normalize the result to a fixnum, causing
`=', `eqv?' and `equal?' to fail, e.g.:
(= most-negative-fixnum (- 0 (- most-negative-fixnum)))
(= most-negative-fixnum (* -1 (- most-negative-fixnum)))
(= most-negative-fixnum (* (- most-negative-fixnum) -1))
* test-suite/test/numbers.test: Add test cases to detect
bugs when negating SCM_MOST_POSITIVE_FIXNUM+1 and
SCM_MOST_NEGATIVE_FIXNUM by various methods.
---
libguile/numbers.c | 17 ++++++++++++++++-
test-suite/tests/numbers.test | 27 +++++++++++++++++++++++++++
2 files changed, 43 insertions(+), 1 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 48de05a..7983a28 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -4464,7 +4464,11 @@ scm_difference (SCM x, SCM y)
scm_t_inum xx = SCM_I_INUM (x);
if (xx == 0)
- return scm_i_clonebig (y, 0);
+ {
+ /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
+ bignum, but negating that gives a fixnum. */
+ return scm_i_normbig (scm_i_clonebig (y, 0));
+ }
else
{
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
@@ -4696,6 +4700,17 @@ scm_product (SCM x, SCM y)
{
case 0: return x; break;
case 1: return y; break;
+ /*
+ * The following case (x = -1) is important for more than
+ * just optimization. It handles the case of negating
+ * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
+ * which is a bignum that must be changed back into a fixnum.
+ * Failure to do so will cause the following to return #f:
+ * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
+ */
+ case -1:
+ return scm_difference(y, SCM_UNDEFINED);
+ break;
}
if (SCM_LIKELY (SCM_I_INUMP (y)))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 1528f52..76a498f 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -2585,6 +2585,20 @@
(with-test-prefix/c&e "-"
+ (pass-if "double-negation of fixnum-min: ="
+ (= fixnum-min (- (- fixnum-min))))
+ (pass-if "double-negation of fixnum-min: eqv?"
+ (eqv? fixnum-min (- (- fixnum-min))))
+ (pass-if "double-negation of fixnum-min: equal?"
+ (equal? fixnum-min (- (- fixnum-min))))
+
+ (pass-if "binary double-negation of fixnum-min: ="
+ (= fixnum-min (- 0 (- 0 fixnum-min))))
+ (pass-if "binary double-negation of fixnum-min: eqv?"
+ (eqv? fixnum-min (- 0 (- 0 fixnum-min))))
+ (pass-if "binary double-negation of fixnum-min: equal?"
+ (equal? fixnum-min (- 0 (- 0 fixnum-min))))
+
(pass-if "-inum - +bignum"
(= #x-100000000000000000000000000000001
(- -1 #x100000000000000000000000000000000)))
@@ -2614,6 +2628,14 @@
(with-test-prefix "*"
+ (with-test-prefix "double-negation of fixnum-min"
+ (pass-if (= fixnum-min (* -1 (* -1 fixnum-min))))
+ (pass-if (eqv? fixnum-min (* -1 (* -1 fixnum-min))))
+ (pass-if (equal? fixnum-min (* -1 (* -1 fixnum-min))))
+ (pass-if (= fixnum-min (* (* fixnum-min -1) -1)))
+ (pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1)))
+ (pass-if (equal? fixnum-min (* (* fixnum-min -1) -1))))
+
(with-test-prefix "inum * bignum"
(pass-if "0 * 2^256 = 0"
@@ -2667,6 +2689,11 @@
(with-test-prefix "/"
+ (with-test-prefix "double-negation of fixnum-min"
+ (pass-if (= fixnum-min (/ (/ fixnum-min -1) -1)))
+ (pass-if (eqv? fixnum-min (/ (/ fixnum-min -1) -1)))
+ (pass-if (equal? fixnum-min (/ (/ fixnum-min -1) -1))))
+
(pass-if "documented?"
(documented? /))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #13: Infinities are no longer rational --]
[-- Type: text/x-diff, Size: 5686 bytes --]
From 5c343ae0e317459b5185eea3a7d4c24191a2c351 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:43:04 -0500
Subject: [PATCH] Infinities are no longer rational
* libguile/numbers.c (scm_rational_p): return #f for infinities, per
R6RS. Previously it returned #t for real infinities. The real
infinities and NaNs are still considered real by scm_real `real?'
however, per R6RS.
* test-suite/tests/numbers.test: Add test cases for `rational?'
and `real?' applied to infinities and NaNs.
* doc/ref/api-data.texi (Real and Rational Numbers): Update docs to
reflect that infinities are irrational, and that `real?' is no
longer implies `rational?'.
* NEWS: Add NEWS entry, and combine with earlier entry about
infinities no longer being integers.
---
NEWS | 12 +++++++-----
doc/ref/api-data.texi | 7 +++----
libguile/numbers.c | 18 +++++++++++++-----
test-suite/tests/numbers.test | 12 +++++++++++-
4 files changed, 34 insertions(+), 15 deletions(-)
diff --git a/NEWS b/NEWS
index 80a8c32..5c6e968 100644
--- a/NEWS
+++ b/NEWS
@@ -25,11 +25,6 @@ scm_eqv_p `eqv?', scm_equal_p `equal?' and scm_real_equalp now return
#t if both were real NaNs, or both were non-real complex NaNs. Use
scm_nan_p `nan?' to test for NaNs.
-*** Infinities are no longer integers.
-
-Following the R6RS, infinities (+inf.0 and -inf.0) are no longer
-considered to be integers.
-
*** `expt' and `integer-expt' changes when the base is 0
While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still
@@ -38,6 +33,13 @@ integer-expt. This is more correct, and conforming to R6RS, but seems
to be incompatible with R5RS, which would return 0 for all non-zero
values of N.
+*** Infinities are no longer integers, nor rationals
+
+scm_integer_p `integer?' and scm_rational_p `rational?' now return
+#f for infinities, per R6RS. Previously they returned #t for real
+infinities. The real infinities and NaNs are still considered real
+by scm_real `real?' however, per R6RS.
+
*** `inf?' and `nan?' now throw exceptions for non-numbers
scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 2055eb1..5df7ee4 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -536,8 +536,7 @@ divisor (some platforms support signed zeroes @samp{0.0} and
The real infinities are written @samp{+inf.0} and @samp{-inf.0},
respectively. This syntax is also recognized by @code{read} as an
extension to the usual Scheme syntax. The infinities are considered to
-be inexact, non-integer values. You can test for them using
-@code{inf?}.
+be inexact, irrational values. You can test for them using @code{inf?}.
Dividing zero by an inexact zero yields a NaN (`not a number') value,
although they are actually considered numbers by Scheme. NaNs are
@@ -570,8 +569,8 @@ Note that the set of integer values forms a subset of the set of
rational numbers, i. e. the predicate will also be fulfilled if
@var{x} is an integer number.
-Since Guile can not represent irrational numbers, every number
-satisfying @code{real?} also satisfies @code{rational?} in Guile.
+The only irrational real numbers representable by Guile are
+@samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0}.
@end deffn
@deffn {Scheme Procedure} rationalize x eps
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 7983a28..228d994 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -3291,8 +3291,18 @@ SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
"fulfilled if @var{x} is an integer number.")
#define FUNC_NAME s_scm_real_p
{
- /* we can't represent irrational numbers. */
- return scm_rational_p (x);
+ if (SCM_I_INUMP (x))
+ return SCM_BOOL_T;
+ else if (SCM_IMP (x))
+ return SCM_BOOL_F;
+ else if (SCM_BIGP (x))
+ return SCM_BOOL_T;
+ else if (SCM_FRACTIONP (x))
+ return SCM_BOOL_T;
+ else if (SCM_REALP (x))
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -3312,9 +3322,7 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
return SCM_BOOL_T;
else if (SCM_FRACTIONP (x))
return SCM_BOOL_T;
- else if (SCM_REALP (x))
- /* due to their limited precision, all floating point numbers are
- rational as well. */
+ else if (SCM_REALP (x) && SCM_I_CDBL_IS_FINITE (SCM_REAL_VALUE (x)))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 76a498f..a3a0e72 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1494,6 +1494,11 @@
(pass-if (real? (+ 1 fixnum-max)))
(pass-if (real? (- 1 fixnum-min)))
(pass-if (real? 1.3))
+ (pass-if (real? +inf.0))
+ (pass-if (real? -inf.0))
+ (pass-if (real? +nan.0))
+ (pass-if (not (real? +inf.0-inf.0i)))
+ (pass-if (not (real? +nan.0+nan.0i)))
(pass-if (not (real? 3+4i)))
(pass-if (not (real? #\a)))
(pass-if (not (real? "a")))
@@ -1504,7 +1509,7 @@
(pass-if (not (real? (current-input-port)))))
;;;
-;;; rational? (same as real? right now)
+;;; rational?
;;;
(with-test-prefix "rational?"
@@ -1515,6 +1520,11 @@
(pass-if (rational? (+ 1 fixnum-max)))
(pass-if (rational? (- 1 fixnum-min)))
(pass-if (rational? 1.3))
+ (pass-if (not (rational? +inf.0)))
+ (pass-if (not (rational? -inf.0)))
+ (pass-if (not (rational? +nan.0)))
+ (pass-if (not (rational? +inf.0-inf.0i)))
+ (pass-if (not (rational? +nan.0+nan.0i)))
(pass-if (not (rational? 3+4i)))
(pass-if (not (rational? #\a)))
(pass-if (not (rational? "a")))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #14: Implement R6RS `real-valued?', `rational-valued?', `integer-valued?' --]
[-- Type: text/x-diff, Size: 6369 bytes --]
From 90764df615e72c38bc03701b5ea42ce792e76dab Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 07:28:01 -0500
Subject: [PATCH] Implement R6RS `real-valued?', `rational-valued?', `integer-valued?'
* module/rnrs/base.scm (real-valued?, rational-valued?,
integer-valued?): implement in compliance with R6RS.
* test-suite/tests/r6rs-base.test: Add test cases for
`real-valued?', `rational-valued?', and `integer-valued?'.
* NEWS: Add NEWS entries.
---
NEWS | 4 ++
module/rnrs/base.scm | 19 +++++----
test-suite/tests/r6rs-base.test | 89 ++++++++++++++++++++++++++++++++++++++-
3 files changed, 103 insertions(+), 9 deletions(-)
diff --git a/NEWS b/NEWS
index 5c6e968..2a86357 100644
--- a/NEWS
+++ b/NEWS
@@ -67,6 +67,10 @@ by scheme, despite their name).
throws exceptions for non-numbers. (Note that NaNs _are_ considered
numbers by scheme, despite their name).
+**** `real-valued?', `rational-valued?' and `integer-valued?' changes
+
+These predicates are now implemented in accordance with R6RS.
+
** New reader option: `hungry-eol-escapes'
Guile's string syntax is more compatible with R6RS when the
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index c7579c3..04a7e23 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -102,14 +102,17 @@
(define (exact-integer-sqrt x)
(let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
- ;; These definitions should be revisited, since the behavior of Guile's
- ;; implementations of `integer?', `rational?', and `real?' (exported from this
- ;; library) is not entirely consistent with R6RS's requirements for those
- ;; functions.
-
- (define integer-valued? integer?)
- (define rational-valued? rational?)
- (define real-valued? real?)
+ (define (real-valued? x)
+ (and (complex? x)
+ (zero? (imag-part x))))
+
+ (define (rational-valued? x)
+ (and (real-valued? x)
+ (rational? (real-part x))))
+
+ (define (integer-valued? x)
+ (and (rational-valued? x)
+ (= x (floor (real-part x)))))
(define (vector-for-each proc . vecs)
(apply for-each (cons proc (map vector->list vecs))))
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index a3603a1..1509b04 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -1,6 +1,6 @@
;;; r6rs-base.test --- Test suite for R6RS (rnrs base)
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -85,3 +85,90 @@
(pass-if "vector-map simple"
(equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3)))))
+(with-test-prefix "real-valued?"
+ (pass-if (real-valued? +nan.0))
+ (pass-if (real-valued? +nan.0+0i))
+ (pass-if (real-valued? +nan.0+0.0i))
+ (pass-if (real-valued? +inf.0))
+ (pass-if (real-valued? -inf.0))
+ (pass-if (real-valued? +inf.0+0.0i))
+ (pass-if (real-valued? -inf.0-0.0i))
+ (pass-if (real-valued? 3))
+ (pass-if (real-valued? -2.5))
+ (pass-if (real-valued? -2.5+0i))
+ (pass-if (real-valued? -2.5+0.0i))
+ (pass-if (real-valued? -2.5-0i))
+ (pass-if (real-valued? #e1e10))
+ (pass-if (real-valued? 1e200))
+ (pass-if (real-valued? 1e200+0.0i))
+ (pass-if (real-valued? 6/10))
+ (pass-if (real-valued? 6/10+0.0i))
+ (pass-if (real-valued? 6/10+0i))
+ (pass-if (real-valued? 6/3))
+ (pass-if (not (real-valued? 3+i)))
+ (pass-if (not (real-valued? -2.5+0.01i)))
+ (pass-if (not (real-valued? +nan.0+0.01i)))
+ (pass-if (not (real-valued? +nan.0+nan.0i)))
+ (pass-if (not (real-valued? +inf.0-0.01i)))
+ (pass-if (not (real-valued? +0.01i)))
+ (pass-if (not (real-valued? -inf.0i))))
+
+(with-test-prefix "rational-valued?"
+ (pass-if (not (rational-valued? +nan.0)))
+ (pass-if (not (rational-valued? +nan.0+0i)))
+ (pass-if (not (rational-valued? +nan.0+0.0i)))
+ (pass-if (not (rational-valued? +inf.0)))
+ (pass-if (not (rational-valued? -inf.0)))
+ (pass-if (not (rational-valued? +inf.0+0.0i)))
+ (pass-if (not (rational-valued? -inf.0-0.0i)))
+ (pass-if (rational-valued? 3))
+ (pass-if (rational-valued? -2.5))
+ (pass-if (rational-valued? -2.5+0i))
+ (pass-if (rational-valued? -2.5+0.0i))
+ (pass-if (rational-valued? -2.5-0i))
+ (pass-if (rational-valued? #e1e10))
+ (pass-if (rational-valued? 1e200))
+ (pass-if (rational-valued? 1e200+0.0i))
+ (pass-if (rational-valued? 6/10))
+ (pass-if (rational-valued? 6/10+0.0i))
+ (pass-if (rational-valued? 6/10+0i))
+ (pass-if (rational-valued? 6/3))
+ (pass-if (not (rational-valued? 3+i)))
+ (pass-if (not (rational-valued? -2.5+0.01i)))
+ (pass-if (not (rational-valued? +nan.0+0.01i)))
+ (pass-if (not (rational-valued? +nan.0+nan.0i)))
+ (pass-if (not (rational-valued? +inf.0-0.01i)))
+ (pass-if (not (rational-valued? +0.01i)))
+ (pass-if (not (rational-valued? -inf.0i))))
+
+(with-test-prefix "integer-valued?"
+ (pass-if (not (integer-valued? +nan.0)))
+ (pass-if (not (integer-valued? +nan.0+0i)))
+ (pass-if (not (integer-valued? +nan.0+0.0i)))
+ (pass-if (not (integer-valued? +inf.0)))
+ (pass-if (not (integer-valued? -inf.0)))
+ (pass-if (not (integer-valued? +inf.0+0.0i)))
+ (pass-if (not (integer-valued? -inf.0-0.0i)))
+ (pass-if (integer-valued? 3))
+ (pass-if (integer-valued? 3.0))
+ (pass-if (integer-valued? 3+0i))
+ (pass-if (integer-valued? 3+0.0i))
+ (pass-if (integer-valued? 8/4))
+ (pass-if (integer-valued? #e1e10))
+ (pass-if (integer-valued? 1e200))
+ (pass-if (integer-valued? 1e200+0.0i))
+ (pass-if (not (integer-valued? -2.5)))
+ (pass-if (not (integer-valued? -2.5+0i)))
+ (pass-if (not (integer-valued? -2.5+0.0i)))
+ (pass-if (not (integer-valued? -2.5-0i)))
+ (pass-if (not (integer-valued? 6/10)))
+ (pass-if (not (integer-valued? 6/10+0.0i)))
+ (pass-if (not (integer-valued? 6/10+0i)))
+ (pass-if (not (integer-valued? 3+i)))
+ (pass-if (not (integer-valued? -2.5+0.01i)))
+ (pass-if (not (integer-valued? +nan.0+0.01i)))
+ (pass-if (not (integer-valued? +nan.0+nan.0i)))
+ (pass-if (not (integer-valued? +inf.0-0.01i)))
+ (pass-if (not (integer-valued? +0.01i)))
+ (pass-if (not (integer-valued? -inf.0i))))
+
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #15: Fix R6RS `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0' --]
[-- Type: text/x-diff, Size: 10255 bytes --]
From 771b2f0be39b0f45417925e628d7158cc86ab771 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 07:37:32 -0500
Subject: [PATCH] Fix R6RS `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'
* module/rnrs/base.scm (div, mod, div-and-mod): Implement these
properly (though admittedly inefficiently). Previously, `div' and
`mod' were aliases of R5RS `quotient' and `modulo', although they
have different semantics. R6RS `mod' is supposed to return a
non-negative number less than the absolute value of the divisor, but
R5RS `modulo' returns a number of the same sign as the divisor (or
zero). R6RS `div' is supposed to return (floor (/ x y)), but R5RS
`quotient' returns (truncate (/ x y)). For example, R6RS states
that (div-and-mod 123 -10) should return -12 and 3, but previously
it returned -12 and -7.
(div0, mod0, div0-and-mod0): Implement these properly (though
admittedly inefficiently). For example, R6RS states that
(div0-and-mod0 123 -10) should return -12 and 3, but previously it
returned -12 and -7.
* test-suite/tests/r6rs-base.test: Add test cases for `div', `mod',
`div-and-mod', `div0', `mod0', and `div0-and-mod0'.
* test-suite/tests/r6rs-arithmetic-fixnums.test: Remove incorrect
tests, and add proper test cases for `fxdiv', `fxmod',
`fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'.
---
NEWS | 14 ++++
module/rnrs/base.scm | 27 +++++---
test-suite/tests/r6rs-arithmetic-fixnums.test | 82 +++++++++++++++++-------
test-suite/tests/r6rs-base.test | 81 ++++++++++++++++++++++++
4 files changed, 170 insertions(+), 34 deletions(-)
diff --git a/NEWS b/NEWS
index 2a86357..bc2c7d3 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,20 @@ NaNs are neither finite nor infinite.
*** R6RS base library changes
+**** `div', `mod', and `div-and-mod' now implemented correctly
+
+These functions are now implemented correctly (though admittedly
+inefficiently). Previously, `div' and `mod' were aliases of R5RS
+`quotient' and `modulo', although they have different semantics.
+For example, R6RS states that (div-and-mod 123 -10) should return
+-12 and 3, but previously it returned -12 and -7.
+
+**** `div0', `mod0', and `div0-and-mod0' now implemented correctly
+
+These functions are now implemented correctly (though admittedly
+inefficiently). R6RS states that (div0-and-mod0 123 -10) should
+return -12 and 3, but previously it returned -12 and -7.
+
**** `infinite?' changes
`infinite?' now returns #t for non-real complex infinities, and throws
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 04a7e23..f4f1c86 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -74,8 +74,6 @@
syntax-rules identifier-syntax)
(import (rename (except (guile) error raise)
- (quotient div)
- (modulo mod)
(inf? infinite?)
(exact->inexact inexact)
(inexact->exact exact))
@@ -119,20 +117,29 @@
(define (vector-map proc . vecs)
(list->vector (apply map (cons proc (map vector->list vecs)))))
- (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r)))
+ (define (div x y)
+ (cond ((positive? y) (floor (/ x y)))
+ ((negative? y) (ceiling (/ x y)))
+ (else (raise (make-assertion-violation)))))
+
+ (define (mod x y)
+ (- x (* y (div x y))))
+
+ (define (div-and-mod x y)
+ (let ((q (div x y)))
+ (values q (- x (* y q)))))
(define (div0 x y)
- (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q)))
+ (cond ((positive? y) (floor (+ 1/2 (/ x y))))
+ ((negative? y) (ceiling (+ -1/2 (/ x y))))
+ (else (raise (make-assertion-violation)))))
(define (mod0 x y)
- (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r)))
+ (- x (* y (div0 x y))))
(define (div0-and-mod0 x y)
- (call-with-values (lambda () (div-and-mod x y))
- (lambda (q r)
- (cond ((< r (abs (/ y 2))) (values q r))
- ((negative? y) (values (- q 1) (+ r y)))
- (else (values (+ q 1) (+ r y)))))))
+ (let ((q (div0 x y)))
+ (values q (- x (* y q)))))
(define raise
(@ (rnrs exceptions) raise))
diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test
index fed72eb..4bf20a9 100644
--- a/test-suite/tests/r6rs-arithmetic-fixnums.test
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -1,6 +1,6 @@
;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -118,35 +118,69 @@
(fx- (least-fixnum) 1))))
(with-test-prefix "fxdiv-and-mod"
- (pass-if "simple"
- (call-with-values (lambda () (fxdiv-and-mod 123 10))
- (lambda (d m)
- (or (and (fx=? d 12) (fx=? m 3))
- (throw 'unresolved))))))
-
-(with-test-prefix "fxdiv"
- (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved))))
-
-(with-test-prefix "fxmod"
- (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved))))
+ (let ((tests '(( 123 10 12 3 )
+ ( 123 -10 -12 3 )
+ (-123 10 -13 7 )
+ (-123 -10 13 7 )
+ ( 12 3 4 0 )
+ ( 12 -3 -4 0 )
+ ( -12 3 -4 0 )
+ ( -12 -3 4 0 ))))
+ (pass-if "fxdiv-and-mod"
+ (for-each (lambda (quad)
+ (apply
+ (lambda (x y q r)
+ (call-with-values
+ (lambda () (fxdiv-and-mod x y))
+ (lambda (qq rr)
+ (if (not (and (eqv? q qq)
+ (eqv? r rr)
+ (eqv? q (fxdiv x y))
+ (eqv? r (fxmod x y))
+ (>= r 0)
+ (< r (abs y))
+ (fx=? x (+ r (* y q)))))
+ (begin
+ (pk x y q r)
+ (throw 'fail))))))
+ quad))
+ tests)
+ #t)))
(with-test-prefix "fxdiv0-and-mod0"
- (pass-if "simple"
- (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
- (lambda (d m)
- (or (and (fx=? d 12) (fx=? m -3))
- (throw 'unresolved))))))
-
-(with-test-prefix "fxdiv0"
- (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved))))
-
-(with-test-prefix "fxmod0"
- (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved))))
-
+ (let ((tests '(( 123 10 12 3 )
+ ( 123 -10 -12 3 )
+ (-123 10 -12 -3 )
+ (-123 -10 12 -3 )
+ ( 12 3 4 0 )
+ ( 12 -3 -4 0 )
+ ( -12 3 -4 0 )
+ ( -12 -3 4 0 ))))
+ (pass-if "fxdiv0-and-mod0"
+ (for-each (lambda (quad)
+ (apply
+ (lambda (x y q r)
+ (call-with-values
+ (lambda () (fxdiv0-and-mod0 x y))
+ (lambda (qq rr)
+ (if (not (and (eqv? q qq)
+ (eqv? r rr)
+ (eqv? q (fxdiv0 x y))
+ (eqv? r (fxmod0 x y))
+ (>= r (* -1/2 (abs y)))
+ (< r (* 1/2 (abs y)))
+ (fx=? x (+ r (* y q)))))
+ (begin
+ (pk x y q r)
+ (throw 'fail))))))
+ quad))
+ tests)
+ #t)))
;; Without working div and mod implementations and without any example results
;; from the spec, I have no idea what the results of these functions should
;; be. -juliang
+;; UPDATE: div and mod implementations are now working properly -mhw
(with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index 1509b04..7a5895a 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -172,3 +172,84 @@
(pass-if (not (integer-valued? +0.01i)))
(pass-if (not (integer-valued? -inf.0i))))
+(with-test-prefix "div-and-mod"
+ (let ((tests '(( 123 10 12 3 )
+ ( 123 -10 -12 3 )
+ (-123 10 -13 7 )
+ (-123 -10 13 7 )
+ ( 12 3 4 0 )
+ ( 12 -3 -4 0 )
+ ( -12 3 -4 0 )
+ ( -12 -3 4 0 )
+ ( 8.5 4 2.0 0.5 )
+ ( 8.5 -4 -2.0 0.5 )
+ (-8.5 4 -3.0 3.5 )
+ (-8.5 -4 3.0 3.5 )
+ ( 8.75 4.5 1.0 4.25 )
+ ( 8.75 -4.5 -1.0 4.25 )
+ (-8.75 4.5 -2.0 0.25 )
+ (-8.75 -4.5 2.0 0.25 )
+ ( 8.875 4.5 1.0 4.375)
+ ( 9 4.5 2.0 0.0 )
+ ( 9.125 4.5 2.0 0.125))))
+ (pass-if "div-and-mod"
+ (for-each (lambda (quad)
+ (apply
+ (lambda (x y q r)
+ (call-with-values
+ (lambda () (div-and-mod x y))
+ (lambda (qq rr)
+ (if (not (and (eqv? q qq)
+ (eqv? r rr)
+ (eqv? q (div x y))
+ (eqv? r (mod x y))
+ (>= r 0)
+ (< r (abs y))
+ (= x (+ r (* y q)))))
+ (begin
+ (pk x y q r)
+ (throw 'fail))))))
+ quad))
+ tests)
+ #t)))
+
+(with-test-prefix "div0-and-mod0"
+ (let ((tests '(( 123 10 12 3 )
+ ( 123 -10 -12 3 )
+ (-123 10 -12 -3 )
+ (-123 -10 12 -3 )
+ ( 12 3 4 0 )
+ ( 12 -3 -4 0 )
+ ( -12 3 -4 0 )
+ ( -12 -3 4 0 )
+ ( 8.5 4 2.0 0.5 )
+ ( 8.5 -4 -2.0 0.5 )
+ (-8.5 4 -2.0 -0.5 )
+ (-8.5 -4 2.0 -0.5 )
+ ( 8.75 4.5 2.0 -0.25 )
+ ( 8.75 -4.5 -2.0 -0.25 )
+ (-8.75 4.5 -2.0 0.25 )
+ (-8.75 -4.5 2.0 0.25 )
+ ( 6.875 4.5 2.0 -2.125)
+ ( 6.75 4.5 2.0 -2.25 )
+ ( 6.625 4.5 1.0 2.125))))
+ (pass-if "div0-and-mod0"
+ (for-each (lambda (quad)
+ (apply
+ (lambda (x y q r)
+ (call-with-values
+ (lambda () (div0-and-mod0 x y))
+ (lambda (qq rr)
+ (if (not (and (eqv? q qq)
+ (eqv? r rr)
+ (eqv? q (div0 x y))
+ (eqv? r (mod0 x y))
+ (>= r (* -1/2 (abs y)))
+ (< r (* 1/2 (abs y)))
+ (= x (+ r (* y q)))))
+ (begin
+ (pk x y q r)
+ (throw 'fail))))))
+ quad))
+ tests)
+ #t)))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #16: `even?' and `odd?' now throw exceptions only for non-numbers --]
[-- Type: text/x-diff, Size: 4581 bytes --]
From cb3b353b8e0d4baa11feaa5dcf3e64f7fd6b2aef Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 10:00:46 -0500
Subject: [PATCH] `even?' and `odd?' now throw exceptions only for non-numbers
* libguile/numbers.c (scm_even_p, scm_odd_p): Throw exceptions only
when applied to non-number objects, per R5RS. Previously threw
exceptions for non-integers. (Note that NaNs _are_ considered
numbers by scheme, despite their name).
* test-suite/tests/numbers.test: Add more test cases for `even?' and
`odd?'.
* NEWS: Add NEWS entry
---
NEWS | 7 +++++++
libguile/numbers.c | 30 ++++++++++++++++++------------
test-suite/tests/numbers.test | 28 ++++++++++++++++++++++++++++
3 files changed, 53 insertions(+), 12 deletions(-)
diff --git a/NEWS b/NEWS
index bc2c7d3..48468cc 100644
--- a/NEWS
+++ b/NEWS
@@ -40,6 +40,13 @@ scm_integer_p `integer?' and scm_rational_p `rational?' now return
infinities. The real infinities and NaNs are still considered real
by scm_real `real?' however, per R6RS.
+*** `even?' and `odd?' now throw exceptions for non-numbers only
+
+scm_even_p `even?' and scm_odd_p `odd?' now throw exceptions only if
+passed non-number objects, per R5RS. Previously, they threw
+exceptions for non-integers. (Note that NaNs _are_ considered numbers
+by scheme, despite their name).
+
*** `inf?' and `nan?' now throw exceptions for non-numbers
scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 228d994..9e1640f 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -546,18 +546,21 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
scm_remember_upto_here_1 (n);
return scm_from_bool (odd_p);
}
- else if (scm_is_true (scm_inf_p (n)))
- SCM_WRONG_TYPE_ARG (1, n);
else if (SCM_REALP (n))
{
- double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
+ double val = SCM_REAL_VALUE (n);
+ double rem;
+
+ if (!SCM_I_CDBL_IS_FINITE (val))
+ return SCM_BOOL_F;
+ rem = fabs (fmod (val, 2.0));
if (rem == 1.0)
return SCM_BOOL_T;
- else if (rem == 0.0)
- return SCM_BOOL_F;
else
- SCM_WRONG_TYPE_ARG (1, n);
+ return SCM_BOOL_F;
}
+ else if (SCM_NUMBERP (n))
+ return SCM_BOOL_F;
else
SCM_WRONG_TYPE_ARG (1, n);
}
@@ -581,18 +584,21 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
scm_remember_upto_here_1 (n);
return scm_from_bool (even_p);
}
- else if (scm_is_true (scm_inf_p (n)))
- SCM_WRONG_TYPE_ARG (1, n);
else if (SCM_REALP (n))
{
- double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
- if (rem == 1.0)
+ double val = SCM_REAL_VALUE (n);
+ double rem;
+
+ if (!SCM_I_CDBL_IS_FINITE (val))
return SCM_BOOL_F;
- else if (rem == 0.0)
+ rem = fabs (fmod (val, 2.0));
+ if (rem == 0.0)
return SCM_BOOL_T;
else
- SCM_WRONG_TYPE_ARG (1, n);
+ return SCM_BOOL_F;
}
+ else if (SCM_NUMBERP (n))
+ return SCM_BOOL_F;
else
SCM_WRONG_TYPE_ARG (1, n);
}
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index a3a0e72..d6ff7c3 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -287,6 +287,20 @@
(pass-if (not (odd? 0)))
(pass-if (not (odd? 2)))
(pass-if (not (odd? -2)))
+ (pass-if (odd? 43))
+ (pass-if (odd? 43.0))
+ (pass-if (odd? -43))
+ (pass-if (odd? -43.0))
+ (pass-if (not (odd? 1/2)))
+ (pass-if (not (odd? -42)))
+ (pass-if (not (odd? -42.0)))
+ (pass-if (not (odd? 42)))
+ (pass-if (not (odd? 42.0)))
+ (pass-if (not (odd? 43.1)))
+ (pass-if (not (odd? 43.0+1.0i)))
+ (pass-if (not (odd? +inf.0)))
+ (pass-if (not (odd? -inf.0)))
+ (pass-if (not (odd? +nan.0)))
(pass-if (odd? (+ (* 2 fixnum-max) 1)))
(pass-if (not (odd? (* 2 fixnum-max))))
(pass-if (odd? (- (* 2 fixnum-min) 1)))
@@ -301,6 +315,20 @@
(pass-if (even? 2))
(pass-if (even? -2))
(pass-if (even? 0))
+ (pass-if (even? 42))
+ (pass-if (even? 42.0))
+ (pass-if (even? -42))
+ (pass-if (even? -42.0))
+ (pass-if (not (even? 1/2)))
+ (pass-if (not (even? -43)))
+ (pass-if (not (even? -43.0)))
+ (pass-if (not (even? 43)))
+ (pass-if (not (even? 43.0)))
+ (pass-if (not (even? 42.1)))
+ (pass-if (not (even? 42.0+1.0i)))
+ (pass-if (not (even? +inf.0)))
+ (pass-if (not (even? -inf.0)))
+ (pass-if (not (even? +nan.0)))
(pass-if (not (even? 1)))
(pass-if (not (even? -1)))
(pass-if (not (even? (+ (* 2 fixnum-max) 1))))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #17: Fix bugs in `rationalize' --]
[-- Type: text/x-diff, Size: 6546 bytes --]
From 97d71e599588f18117b4c79dbc2bca12afbafe92 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 08:18:12 -0500
Subject: [PATCH] Fix bugs in `rationalize'
* libguile/numbers.c (scm_rationalize): Fix bugs. Previously, it
returned exact integers unmodified, although that was incorrect if
the epsilon was at least 1 or inexact, e.g. (rationalize 4 1) should
return 3 per R5RS and R6RS, but previously it returned 4. Also
handle cases involving infinities and NaNs properly, per R6RS.
* test-suite/tests/numbers.test: Add test cases for `rationalize'.
* NEWS: Add NEWS entry
---
NEWS | 8 ++++++
libguile/numbers.c | 52 +++++++++++++++++++++++++++++++---------
test-suite/tests/numbers.test | 46 ++++++++++++++++++++++++++++++++++++
3 files changed, 94 insertions(+), 12 deletions(-)
diff --git a/NEWS b/NEWS
index 48468cc..b3365b8 100644
--- a/NEWS
+++ b/NEWS
@@ -53,6 +53,14 @@ scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed
non-number objects. Previously they returned #f. (Note that NaNs
_are_ considered numbers by scheme, despite their name).
+*** `rationalize' bugfixes and changes
+
+Fixed bugs in scm_rationalize `rationalize'. Previously, it returned
+exact integers unmodified, although that was incorrect if the epsilon
+was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per
+R5RS and R6RS, but previously it returned 4. It also now handles
+cases involving infinities and NaNs properly, per R6RS.
+
*** New procedure: `finite?'
Add scm_finite_p `finite?' from R6RS to guile core, which returns #t
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 9e1640f..5eb775d 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -6087,11 +6087,46 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_rationalize
{
- if (SCM_I_INUMP (x))
- return x;
- else if (SCM_BIGP (x))
+ SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real");
+ eps = scm_abs (eps);
+ if (scm_is_false (scm_positive_p (eps)))
+ {
+ /* eps is either zero or a NaN */
+ if (scm_is_true (scm_nan_p (eps)))
+ return scm_nan ();
+ else if (SCM_INEXACTP (eps))
+ return scm_exact_to_inexact (x);
+ else
+ return x;
+ }
+ else if (scm_is_false (scm_finite_p (eps)))
+ {
+ if (scm_is_true (scm_finite_p (x)))
+ return flo0;
+ else
+ return scm_nan ();
+ }
+ else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */
return x;
- else if ((SCM_REALP (x)) || SCM_FRACTIONP (x))
+ else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)),
+ scm_ceiling (scm_difference (x, eps)))))
+ {
+ /* There's an integer within range; we want the one closest to zero */
+ if (scm_is_false (scm_less_p (eps, scm_abs (x))))
+ {
+ /* zero is within range */
+ if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
+ return flo0;
+ else
+ return SCM_INUM0;
+ }
+ else if (scm_is_true (scm_positive_p (x)))
+ return scm_ceiling (scm_difference (x, eps));
+ else
+ return scm_floor (scm_sum (x, eps));
+ }
+ else
{
/* Use continued fractions to find closest ratio. All
arithmetic is done with exact numbers.
@@ -6105,9 +6140,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
SCM rx;
int i = 0;
- if (scm_is_true (scm_num_eq_p (ex, int_part)))
- return ex;
-
ex = scm_difference (ex, int_part); /* x = x-int_part */
rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
@@ -6116,7 +6148,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
converges after less than a dozen iterations.
*/
- eps = scm_abs (eps);
while (++i < 1000000)
{
a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
@@ -6127,8 +6158,7 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
eps))) /* abs(x-a/b) <= eps */
{
SCM res = scm_sum (int_part, scm_divide (a, b));
- if (scm_is_false (scm_exact_p (x))
- || scm_is_false (scm_exact_p (eps)))
+ if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
return scm_exact_to_inexact (res);
else
return res;
@@ -6143,8 +6173,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
}
scm_num_overflow (s_scm_rationalize);
}
- else
- SCM_WRONG_TYPE_ARG (1, x);
}
#undef FUNC_NAME
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index d6ff7c3..5dd95e1 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1324,6 +1324,52 @@
(pass-if (= lcm-of-big-n-and-11 (lcm 11 big-n 11)))))
;;;
+;;; rationalize
+;;;
+(with-test-prefix "rationalize"
+ (pass-if (documented? rationalize))
+ (pass-if (eqv? 2 (rationalize 4 2 )))
+ (pass-if (eqv? -2 (rationalize -4 2 )))
+ (pass-if (eqv? 2.0 (rationalize 4 2.0)))
+ (pass-if (eqv? -2.0 (rationalize -4.0 2 )))
+
+ (pass-if (eqv? 0 (rationalize 4 8 )))
+ (pass-if (eqv? 0 (rationalize -4 8 )))
+ (pass-if (eqv? 0.0 (rationalize 4 8.0)))
+ (pass-if (eqv? 0.0 (rationalize -4.0 8 )))
+
+ (pass-if (eqv? 0.0 (rationalize 3 +inf.0)))
+ (pass-if (eqv? 0.0 (rationalize -3 +inf.0)))
+
+ (pass-if (nan? (rationalize +inf.0 +inf.0)))
+ (pass-if (nan? (rationalize +nan.0 +inf.0)))
+ (pass-if (nan? (rationalize +nan.0 4)))
+ (pass-if (eqv? +inf.0 (rationalize +inf.0 3)))
+
+ (pass-if (eqv? 3/10 (rationalize 3/10 0)))
+ (pass-if (eqv? -3/10 (rationalize -3/10 0)))
+
+ (pass-if (eqv? 1/3 (rationalize 3/10 1/10)))
+ (pass-if (eqv? -1/3 (rationalize -3/10 1/10)))
+
+ (pass-if (eqv? 1/3 (rationalize 3/10 -1/10)))
+ (pass-if (eqv? -1/3 (rationalize -3/10 -1/10)))
+
+ (pass-if (let ((ans (rationalize 0.3 1/10)))
+ (and (eqv-loosely? ans 0.3333)
+ (inexact? ans))))
+ (pass-if (let ((ans (rationalize -0.3 1/10)))
+ (and (eqv-loosely? ans -0.3333)
+ (inexact? ans))))
+
+ (pass-if (let ((ans (rationalize 0.3 -1/10)))
+ (and (eqv-loosely? ans 0.3333)
+ (inexact? ans))))
+ (pass-if (let ((ans (rationalize -0.3 -1/10)))
+ (and (eqv-loosely? ans -0.3333)
+ (inexact? ans)))))
+
+;;;
;;; number->string
;;;
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #18: More discriminating NaN predicates for numbers.test --]
[-- Type: text/x-diff, Size: 7561 bytes --]
From 4b763af9a2a39b49064239d054afbaf004d4388d Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 08:54:19 -0500
Subject: [PATCH] More discriminating NaN predicates for numbers.test
* test-suite/tests/numbers.test: (real-nan?, complex-nan?,
imaginary-nan?): Add more discriminating NaN testing predicates
internal to numbers.test, and convert several uses of `nan?'
to use these instead:
* `real-nan?' checks that its argument is real and a NaN.
* `complex-nan?' checks that both the real and imaginary
parts of its argument are NaNs.
* `imaginary-nan?' checks that its argument's real part
is zero and the imaginary part is a NaN.
---
test-suite/tests/numbers.test | 73 +++++++++++++++++++++++++----------------
1 files changed, 45 insertions(+), 28 deletions(-)
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 5dd95e1..17fdcbc 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -92,6 +92,23 @@
(negative? obj)
(inf? obj)))
+;; return true if OBJ is a real NaN
+(define (real-nan? obj)
+ (and (real? obj)
+ (nan? obj)))
+
+;; return true if both the real and imaginary
+;; parts of OBJ are NaNs
+(define (complex-nan? obj)
+ (and (nan? (real-part obj))
+ (nan? (imag-part obj))))
+
+;; return true if the real part of OBJ is zero
+;; and the imaginary part is a NaN.
+(define (imaginary-nan? obj)
+ (and (zero? (real-part obj))
+ (nan? (imag-part obj))))
+
(define const-e 2.7182818284590452354)
(define const-e^2 7.3890560989306502274)
(define const-1/e 0.3678794411714423215)
@@ -404,7 +421,7 @@
(pass-if (= 0.0 (abs 0.0)))
(pass-if (= 1.0 (abs 1.0)))
(pass-if (= 1.0 (abs -1.0)))
- (pass-if (nan? (abs +nan.0)))
+ (pass-if (real-nan? (abs +nan.0)))
(pass-if (= +inf.0 (abs +inf.0)))
(pass-if (= +inf.0 (abs -inf.0))))
@@ -1341,9 +1358,9 @@
(pass-if (eqv? 0.0 (rationalize 3 +inf.0)))
(pass-if (eqv? 0.0 (rationalize -3 +inf.0)))
- (pass-if (nan? (rationalize +inf.0 +inf.0)))
- (pass-if (nan? (rationalize +nan.0 +inf.0)))
- (pass-if (nan? (rationalize +nan.0 4)))
+ (pass-if (real-nan? (rationalize +inf.0 +inf.0)))
+ (pass-if (real-nan? (rationalize +nan.0 +inf.0)))
+ (pass-if (real-nan? (rationalize +nan.0 4)))
(pass-if (eqv? +inf.0 (rationalize +inf.0 3)))
(pass-if (eqv? 3/10 (rationalize 3/10 0)))
@@ -2454,10 +2471,10 @@
(pass-if (= 5/2 (max 5/2 2))))
(with-test-prefix "inum / real"
- (pass-if (nan? (max 123 +nan.0))))
+ (pass-if (real-nan? (max 123 +nan.0))))
(with-test-prefix "real / inum"
- (pass-if (nan? (max +nan.0 123))))
+ (pass-if (real-nan? (max +nan.0 123))))
(with-test-prefix "big / frac"
(pass-if (= big*2 (max big*2 5/2)))
@@ -2468,14 +2485,14 @@
(pass-if (= 5/2 (max 5/2 (- big*2)))))
(with-test-prefix "big / real"
- (pass-if (nan? (max big*5 +nan.0)))
+ (pass-if (real-nan? (max big*5 +nan.0)))
(pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0)))
(pass-if (eqv? (exact->inexact big*5) (max big*5 1.0)))
(pass-if (eqv? +inf.0 (max big*5 +inf.0)))
(pass-if (eqv? 1.0 (max (- big*5) 1.0))))
(with-test-prefix "real / big"
- (pass-if (nan? (max +nan.0 big*5)))
+ (pass-if (real-nan? (max +nan.0 big*5)))
(pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5)))
(pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5)))
(pass-if (eqv? +inf.0 (max +inf.0 big*5)))
@@ -2488,9 +2505,9 @@
(pass-if (= -1/2 (max -2/3 -1/2))))
(with-test-prefix "real / real"
- (pass-if (nan? (max 123.0 +nan.0)))
- (pass-if (nan? (max +nan.0 123.0)))
- (pass-if (nan? (max +nan.0 +nan.0)))
+ (pass-if (real-nan? (max 123.0 +nan.0)))
+ (pass-if (real-nan? (max +nan.0 123.0)))
+ (pass-if (real-nan? (max +nan.0 +nan.0)))
(pass-if (= 456.0 (max 123.0 456.0)))
(pass-if (= 456.0 (max 456.0 123.0)))))
@@ -2514,8 +2531,8 @@
;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
;; sure we've avoided that
- (pass-if (nan? (max (ash 1 2048) +nan.0)))
- (pass-if (nan? (max +nan.0 (ash 1 2048)))))
+ (pass-if (real-nan? (max (ash 1 2048) +nan.0)))
+ (pass-if (real-nan? (max +nan.0 (ash 1 2048)))))
;;;
;;; min
@@ -2579,10 +2596,10 @@
(pass-if (= 2 (min 5/2 2))))
(with-test-prefix "inum / real"
- (pass-if (nan? (min 123 +nan.0))))
+ (pass-if (real-nan? (min 123 +nan.0))))
(with-test-prefix "real / inum"
- (pass-if (nan? (min +nan.0 123))))
+ (pass-if (real-nan? (min +nan.0 123))))
(with-test-prefix "big / frac"
(pass-if (= 5/2 (min big*2 5/2)))
@@ -2593,14 +2610,14 @@
(pass-if (= (- big*2) (min 5/2 (- big*2)))))
(with-test-prefix "big / real"
- (pass-if (nan? (min big*5 +nan.0)))
+ (pass-if (real-nan? (min big*5 +nan.0)))
(pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0)))
(pass-if (eqv? -inf.0 (min big*5 -inf.0)))
(pass-if (eqv? 1.0 (min big*5 1.0)))
(pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0))))
(with-test-prefix "real / big"
- (pass-if (nan? (min +nan.0 big*5)))
+ (pass-if (real-nan? (min +nan.0 big*5)))
(pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5)))
(pass-if (eqv? -inf.0 (min -inf.0 big*5)))
(pass-if (eqv? 1.0 (min 1.0 big*5)))
@@ -2613,9 +2630,9 @@
(pass-if (= -2/3 (min -2/3 -1/2))))
(with-test-prefix "real / real"
- (pass-if (nan? (min 123.0 +nan.0)))
- (pass-if (nan? (min +nan.0 123.0)))
- (pass-if (nan? (min +nan.0 +nan.0)))
+ (pass-if (real-nan? (min 123.0 +nan.0)))
+ (pass-if (real-nan? (min +nan.0 123.0)))
+ (pass-if (real-nan? (min +nan.0 +nan.0)))
(pass-if (= 123.0 (min 123.0 456.0)))
(pass-if (= 123.0 (min 456.0 123.0)))))
@@ -2640,8 +2657,8 @@
;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
;; sure we've avoided that
- (pass-if (nan? (min (- (ash 1 2048)) (- +nan.0))))
- (pass-if (nan? (min (- +nan.0) (- (ash 1 2048))))))
+ (pass-if (real-nan? (min (- (ash 1 2048)) (- +nan.0))))
+ (pass-if (real-nan? (min (- +nan.0) (- (ash 1 2048))))))
;;;
;;; +
@@ -3144,10 +3161,10 @@
(pass-if (eqv? 1 (expt 0.0 0)))
(pass-if (eqv? 1.0 (expt 0 0.0)))
(pass-if (eqv? 1.0 (expt 0.0 0.0)))
- (pass-if (nan? (expt 0 -1)))
- (pass-if (nan? (expt 0 -1.0)))
- (pass-if (nan? (expt 0.0 -1)))
- (pass-if (nan? (expt 0.0 -1.0)))
+ (pass-if (real-nan? (expt 0 -1)))
+ (pass-if (real-nan? (expt 0 -1.0)))
+ (pass-if (real-nan? (expt 0.0 -1)))
+ (pass-if (real-nan? (expt 0.0 -1.0)))
(pass-if (eqv? 0 (expt 0 3)))
(pass-if (= 0 (expt 0 4.0)))
(pass-if (eqv? 0.0 (expt 0.0 5)))
@@ -3295,8 +3312,8 @@
(pass-if (eqv? 1 (integer-expt 0 0)))
(pass-if (eqv? 1 (integer-expt 0.0 0)))
- (pass-if (nan? (integer-expt 0 -1)))
- (pass-if (nan? (integer-expt 0.0 -1)))
+ (pass-if (real-nan? (integer-expt 0 -1)))
+ (pass-if (real-nan? (integer-expt 0.0 -1)))
(pass-if (eqv? 0 (integer-expt 0 3)))
(pass-if (eqv? 0.0 (integer-expt 0.0 5)))
(pass-if (eqv? -2742638075.5 (integer-expt -2742638075.5 1)))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #19: Exact 0 times infinity or a NaN yields a NaN --]
[-- Type: text/x-diff, Size: 8652 bytes --]
From 79c138d758bddfe1efbf5de58e7c27f0c9671be4 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:00:29 -0500
Subject: [PATCH] Exact 0 times infinity or a NaN yields a NaN
* libguile/numbers.c (scm_product): Handle exact 0 differently. A
product containing an exact 0 now returns an exact 0 if and only if
the other arguments are all finite, otherwise a NaN is returned.
* test-suite/tests/numbers.test: Add many multiplication tests.
* NEWS: Add NEWS entry.
---
NEWS | 6 ++
libguile/numbers.c | 41 +++++++++------
test-suite/tests/numbers.test | 109 +++++++++++++++++++++++++++++++++++++++++
3 files changed, 139 insertions(+), 17 deletions(-)
diff --git a/NEWS b/NEWS
index b3365b8..5864755 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,12 @@ scm_eqv_p `eqv?', scm_equal_p `equal?' and scm_real_equalp now return
#t if both were real NaNs, or both were non-real complex NaNs. Use
scm_nan_p `nan?' to test for NaNs.
+*** Change in handling products `*' involving exact 0
+
+scm_product `*' now handles exact 0 differently. A product containing
+an exact 0 now returns an exact 0 if and only if the other arguments
+are all finite, otherwise a NaN value is returned.
+
*** `expt' and `integer-expt' changes when the base is 0
While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 5eb775d..53bd0d2 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -4707,13 +4707,25 @@ scm_product (SCM x, SCM y)
{
scm_t_inum xx;
- intbig:
+ xinum:
xx = SCM_I_INUM (x);
switch (xx)
{
- case 0: return x; break;
- case 1: return y; break;
+ case 0:
+ /* exact0 times any finite number is exact0 */
+ if (SCM_LIKELY (SCM_I_INUMP (y))) /* optimize this case */
+ return x;
+ else if (SCM_LIKELY (scm_is_true (scm_finite_p (y))))
+ return x;
+ else
+ return scm_make_rectangular
+ (scm_is_true (scm_finite_p (scm_real_part (y))) ? x : scm_nan(),
+ scm_is_true (scm_finite_p (scm_imag_part (y))) ? x : scm_nan());
+ break;
+ case 1:
+ return y;
+ break;
/*
* The following case (x = -1) is important for more than
* just optimization. It handles the case of negating
@@ -4764,7 +4776,7 @@ scm_product (SCM x, SCM y)
if (SCM_I_INUMP (y))
{
SCM_SWAP (x, y);
- goto intbig;
+ goto xinum;
}
else if (SCM_BIGP (y))
{
@@ -4797,12 +4809,10 @@ scm_product (SCM x, SCM y)
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
- {
- /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
- if (scm_is_eq (y, SCM_INUM0))
- return y;
- return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
- }
+ {
+ SCM_SWAP (x, y);
+ goto xinum;
+ }
else if (SCM_BIGP (y))
{
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
@@ -4822,13 +4832,10 @@ scm_product (SCM x, SCM y)
else if (SCM_COMPLEXP (x))
{
if (SCM_I_INUMP (y))
- {
- /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
- if (scm_is_eq (y, SCM_INUM0))
- return y;
- return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
- SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
- }
+ {
+ SCM_SWAP (x, y);
+ goto xinum;
+ }
else if (SCM_BIGP (y))
{
double z = mpz_get_d (SCM_I_BIG_MPZ (y));
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 17fdcbc..cfcabe3 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -2737,6 +2737,115 @@
(pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1)))
(pass-if (equal? fixnum-min (* (* fixnum-min -1) -1))))
+ (with-test-prefix "exactness propagation"
+ (pass-if (eqv? 0 (* 0 -1.0 )))
+ (pass-if (eqv? 0 (* 0 1.0 )))
+ (pass-if (eqv? 0 (* -1.0 0 )))
+ (pass-if (eqv? 0 (* 1.0 0 )))
+ (pass-if (eqv? 0 (* 0 1/2 )))
+ (pass-if (eqv? 0 (* 1/2 0 )))
+ (pass-if (eqv? 0 (* 0 1+i )))
+ (pass-if (eqv? 0 (* 1+i 0 )))
+ (pass-if (eqv? -1.0 (* 1 -1.0 )))
+ (pass-if (eqv? 1.0 (* 1 1.0 )))
+ (pass-if (eqv? -1.0 (* -1.0 1 )))
+ (pass-if (eqv? 1.0 (* 1.0 1 )))
+ (pass-if (eqv? 1/2 (* 1 1/2 )))
+ (pass-if (eqv? 1/2 (* 1/2 1 )))
+ (pass-if (eqv? 1+i (* 1 1+i )))
+ (pass-if (eqv? 1+i (* 1+i 1 ))))
+
+ (with-test-prefix "propagation of NaNs"
+ (pass-if (real-nan? (* +nan.0 +nan.0)))
+ (pass-if (real-nan? (* +nan.0 1 )))
+ (pass-if (real-nan? (* +nan.0 -1 )))
+ (pass-if (real-nan? (* +nan.0 -7/2 )))
+ (pass-if (real-nan? (* +nan.0 1e20 )))
+ (pass-if (real-nan? (* 1 +nan.0)))
+ (pass-if (real-nan? (* -1 +nan.0)))
+ (pass-if (real-nan? (* -7/2 +nan.0)))
+ (pass-if (real-nan? (* 1e20 +nan.0)))
+ (pass-if (real-nan? (* +inf.0 +nan.0)))
+ (pass-if (real-nan? (* +nan.0 +inf.0)))
+ (pass-if (real-nan? (* -inf.0 +nan.0)))
+ (pass-if (real-nan? (* +nan.0 -inf.0)))
+ (pass-if (real-nan? (* (* fixnum-max 2) +nan.0)))
+ (pass-if (real-nan? (* +nan.0 (* fixnum-max 2))))
+
+ (pass-if (real-nan? (* 0 +nan.0 )))
+ (pass-if (real-nan? (* +nan.0 0 )))
+ (pass-if (real-nan? (* 0 +nan.0+i)))
+ (pass-if (real-nan? (* +nan.0+i 0 )))
+
+ (pass-if (imaginary-nan? (* 0 +nan.0i )))
+ (pass-if (imaginary-nan? (* +nan.0i 0 )))
+ (pass-if (imaginary-nan? (* 0 1+nan.0i )))
+ (pass-if (imaginary-nan? (* 1+nan.0i 0 )))
+
+ (pass-if (complex-nan? (* 0 +nan.0+nan.0i )))
+ (pass-if (complex-nan? (* +nan.0+nan.0i 0 ))))
+
+ (with-test-prefix "infinities"
+ (pass-if (eqv? +inf.0 (* +inf.0 5 )))
+ (pass-if (eqv? -inf.0 (* +inf.0 -5 )))
+ (pass-if (eqv? +inf.0 (* +inf.0 73.1)))
+ (pass-if (eqv? -inf.0 (* +inf.0 -9.2)))
+ (pass-if (eqv? +inf.0 (* +inf.0 5/2)))
+ (pass-if (eqv? -inf.0 (* +inf.0 -5/2)))
+ (pass-if (eqv? -inf.0 (* -5 +inf.0)))
+ (pass-if (eqv? +inf.0 (* 73.1 +inf.0)))
+ (pass-if (eqv? -inf.0 (* -9.2 +inf.0)))
+ (pass-if (eqv? +inf.0 (* 5/2 +inf.0)))
+ (pass-if (eqv? -inf.0 (* -5/2 +inf.0)))
+
+ (pass-if (eqv? -inf.0 (* -inf.0 5 )))
+ (pass-if (eqv? +inf.0 (* -inf.0 -5 )))
+ (pass-if (eqv? -inf.0 (* -inf.0 73.1)))
+ (pass-if (eqv? +inf.0 (* -inf.0 -9.2)))
+ (pass-if (eqv? -inf.0 (* -inf.0 5/2)))
+ (pass-if (eqv? +inf.0 (* -inf.0 -5/2)))
+ (pass-if (eqv? +inf.0 (* -5 -inf.0)))
+ (pass-if (eqv? -inf.0 (* 73.1 -inf.0)))
+ (pass-if (eqv? +inf.0 (* -9.2 -inf.0)))
+ (pass-if (eqv? -inf.0 (* 5/2 -inf.0)))
+ (pass-if (eqv? +inf.0 (* -5/2 -inf.0)))
+
+ (pass-if (real-nan? (* 0.0 +inf.0)))
+ (pass-if (real-nan? (* -0.0 +inf.0)))
+ (pass-if (real-nan? (* +inf.0 0.0)))
+ (pass-if (real-nan? (* +inf.0 -0.0)))
+
+ (pass-if (real-nan? (* 0.0 -inf.0)))
+ (pass-if (real-nan? (* -0.0 -inf.0)))
+ (pass-if (real-nan? (* -inf.0 0.0)))
+ (pass-if (real-nan? (* -inf.0 -0.0)))
+
+ (pass-if (real-nan? (* 0 +inf.0 )))
+ (pass-if (real-nan? (* +inf.0 0 )))
+ (pass-if (real-nan? (* 0 +inf.0+i)))
+ (pass-if (real-nan? (* +inf.0+i 0 )))
+
+ (pass-if (real-nan? (* 0 -inf.0 )))
+ (pass-if (real-nan? (* -inf.0 0 )))
+ (pass-if (real-nan? (* 0 -inf.0+i)))
+ (pass-if (real-nan? (* -inf.0+i 0 )))
+
+ (pass-if (imaginary-nan? (* 0 +inf.0i )))
+ (pass-if (imaginary-nan? (* +inf.0i 0 )))
+ (pass-if (imaginary-nan? (* 0 1+inf.0i )))
+ (pass-if (imaginary-nan? (* 1+inf.0i 0 )))
+
+ (pass-if (imaginary-nan? (* 0 -inf.0i )))
+ (pass-if (imaginary-nan? (* -inf.0i 0 )))
+ (pass-if (imaginary-nan? (* 0 1-inf.0i )))
+ (pass-if (imaginary-nan? (* 1-inf.0i 0 )))
+
+ (pass-if (complex-nan? (* 0 +inf.0+inf.0i )))
+ (pass-if (complex-nan? (* +inf.0+inf.0i 0 )))
+
+ (pass-if (complex-nan? (* 0 +inf.0-inf.0i )))
+ (pass-if (complex-nan? (* -inf.0+inf.0i 0 ))))
+
(with-test-prefix "inum * bignum"
(pass-if "0 * 2^256 = 0"
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #20: Move comment about trig functions back where it belongs --]
[-- Type: text/x-diff, Size: 1591 bytes --]
From 698678372a944f5e90bcb6c331f0d27c051b5002 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:05:34 -0500
Subject: [PATCH] Move comment about trig functions back where it belongs
* libguile/numbers.c: Move a comment about the trigonometric functions
next to those functions. At some point they became separated, when
scm_expt was placed between them.
---
libguile/numbers.c | 12 ++++++------
1 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 53bd0d2..80af674 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5492,12 +5492,6 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
}
#undef FUNC_NAME
-/* sin/cos/tan/asin/acos/atan
- sinh/cosh/tanh/asinh/acosh/atanh
- Derived from "Transcen.scm", Complex trancendental functions for SCM.
- Written by Jerry D. Hedden, (C) FSF.
- See the file `COPYING' for terms applying to this program. */
-
SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
(SCM x, SCM y),
"Return @var{x} raised to the power of @var{y}.")
@@ -5535,6 +5529,12 @@ SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
}
#undef FUNC_NAME
+/* sin/cos/tan/asin/acos/atan
+ sinh/cosh/tanh/asinh/acosh/atanh
+ Derived from "Transcen.scm", Complex trancendental functions for SCM.
+ Written by Jerry D. Hedden, (C) FSF.
+ See the file `COPYING' for terms applying to this program. */
+
SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
(SCM z),
"Compute the sine of @var{z}.")
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #21: Trigonometric functions return exact numbers in some cases --]
[-- Type: text/x-diff, Size: 8741 bytes --]
From 45e061f24ad470d5a2517cec958db590b79e5c4c Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 26 Jan 2011 09:17:43 -0500
Subject: [PATCH] Trigonometric functions return exact numbers in some cases
* libguile/numbers.c (scm_sin, scm_cos, scm_tan, scm_sinh, scm_cosh,
scm_tanh, scm_asin, scm_acos, scm_sys_asinh, scm_sys_acosh,
scm_sys_acosh, scm_sys_atanh, scm_atan): Return an exact result in
some cases.
* test-suite/tests/numbers.test: Add test cases.
* NEWS: Add NEWS entry
---
NEWS | 8 +++++
libguile/numbers.c | 48 +++++++++++++++++++++-------
test-suite/tests/numbers.test | 69 +++++++++++++++++++++++++++++++++++++++++
3 files changed, 113 insertions(+), 12 deletions(-)
diff --git a/NEWS b/NEWS
index 5864755..b1196db 100644
--- a/NEWS
+++ b/NEWS
@@ -67,6 +67,14 @@ was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per
R5RS and R6RS, but previously it returned 4. It also now handles
cases involving infinities and NaNs properly, per R6RS.
+*** Trigonometric functions now return exact numbers in some cases
+
+scm_sin `sin', scm_cos `cos', scm_tan `tan', scm_sinh `sinh', scm_cosh
+`cosh', scm_tanh `tanh', scm_asin `asin', scm_acos `acos',
+scm_sys_asinh `asinh', scm_sys_acosh `acosh', scm_sys_acosh `acosh',
+scm_sys_atanh `atanh' and the one-argument case of scm_atan `atan' now
+return exact results in some cases.
+
*** New procedure: `finite?'
Add scm_finite_p `finite?' from R6RS to guile core, which returns #t
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 80af674..e71e9f4 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5540,7 +5540,9 @@ SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
"Compute the sine of @var{z}.")
#define FUNC_NAME s_scm_sin
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* sin(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (sin (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
@@ -5559,7 +5561,9 @@ SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
"Compute the cosine of @var{z}.")
#define FUNC_NAME s_scm_cos
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return SCM_INUM1; /* cos(exact0) = exact1 */
+ else if (scm_is_real (z))
return scm_from_double (cos (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
@@ -5578,7 +5582,9 @@ SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
"Compute the tangent of @var{z}.")
#define FUNC_NAME s_scm_tan
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* tan(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (tan (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y, w;
@@ -5601,7 +5607,9 @@ SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
"Compute the hyperbolic sine of @var{z}.")
#define FUNC_NAME s_scm_sinh
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* sinh(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (sinh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
@@ -5620,7 +5628,9 @@ SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
"Compute the hyperbolic cosine of @var{z}.")
#define FUNC_NAME s_scm_cosh
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return SCM_INUM1; /* cosh(exact0) = exact1 */
+ else if (scm_is_real (z))
return scm_from_double (cosh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y;
@@ -5639,7 +5649,9 @@ SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
"Compute the hyperbolic tangent of @var{z}.")
#define FUNC_NAME s_scm_tanh
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* tanh(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (tanh (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{ double x, y, w;
@@ -5662,7 +5674,9 @@ SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
"Compute the arc sine of @var{z}.")
#define FUNC_NAME s_scm_asin
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* asin(exact0) = exact0 */
+ else if (scm_is_real (z))
{
double w = scm_to_double (z);
if (w >= -1.0 && w <= 1.0)
@@ -5688,7 +5702,9 @@ SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
"Compute the arc cosine of @var{z}.")
#define FUNC_NAME s_scm_acos
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
+ return SCM_INUM0; /* acos(exact1) = exact0 */
+ else if (scm_is_real (z))
{
double w = scm_to_double (z);
if (w >= -1.0 && w <= 1.0)
@@ -5720,7 +5736,9 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
{
if (SCM_UNBNDP (y))
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* atan(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (atan (scm_to_double (z)));
else if (SCM_COMPLEXP (z))
{
@@ -5751,7 +5769,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
"Compute the inverse hyperbolic sine of @var{z}.")
#define FUNC_NAME s_scm_sys_asinh
{
- if (scm_is_real (z))
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* asinh(exact0) = exact0 */
+ else if (scm_is_real (z))
return scm_from_double (asinh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_log (scm_sum (z,
@@ -5767,7 +5787,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
"Compute the inverse hyperbolic cosine of @var{z}.")
#define FUNC_NAME s_scm_sys_acosh
{
- if (scm_is_real (z) && scm_to_double (z) >= 1.0)
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
+ return SCM_INUM0; /* acosh(exact1) = exact0 */
+ else if (scm_is_real (z) && scm_to_double (z) >= 1.0)
return scm_from_double (acosh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_log (scm_sum (z,
@@ -5783,7 +5805,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
"Compute the inverse hyperbolic tangent of @var{z}.")
#define FUNC_NAME s_scm_sys_atanh
{
- if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
+ if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
+ return z; /* atanh(exact0) = exact0 */
+ else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
return scm_from_double (atanh (scm_to_double (z)));
else if (scm_is_number (z))
return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index cfcabe3..8a984f6 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -3298,6 +3298,75 @@
;;;
+;;; sin
+;;;
+
+(with-test-prefix "sin"
+ (pass-if (eqv? 0 (sin 0)))
+ (pass-if (eqv? 0.0 (sin 0.0)))
+ (pass-if (eqv-loosely? 1.0 (sin 1.57)))
+ (pass-if (eqv-loosely? +1.175i (sin +i)))
+ (pass-if (real-nan? (sin +nan.0)))
+ (pass-if (real-nan? (sin +inf.0)))
+ (pass-if (real-nan? (sin -inf.0))))
+
+;;;
+;;; cos
+;;;
+
+(with-test-prefix "cos"
+ (pass-if (eqv? 1 (cos 0)))
+ (pass-if (eqv? 1.0 (cos 0.0)))
+ (pass-if (eqv-loosely? 0.0 (cos 1.57)))
+ (pass-if (eqv-loosely? 1.543 (cos +i)))
+ (pass-if (real-nan? (cos +nan.0)))
+ (pass-if (real-nan? (cos +inf.0)))
+ (pass-if (real-nan? (cos -inf.0))))
+
+;;;
+;;; tan
+;;;
+
+(with-test-prefix "tan"
+ (pass-if (eqv? 0 (tan 0)))
+ (pass-if (eqv? 0.0 (tan 0.0)))
+ (pass-if (eqv-loosely? 1.0 (tan 0.785)))
+ (pass-if (eqv-loosely? +0.76i (tan +i)))
+ (pass-if (real-nan? (tan +nan.0)))
+ (pass-if (real-nan? (tan +inf.0)))
+ (pass-if (real-nan? (tan -inf.0))))
+
+;;;
+;;; asin
+;;;
+
+(with-test-prefix "asin"
+ (pass-if (complex-nan? (asin +nan.0)))
+ (pass-if (eqv? 0 (asin 0)))
+ (pass-if (eqv? 0.0 (asin 0.0))))
+
+;;;
+;;; acos
+;;;
+
+(with-test-prefix "acos"
+ (pass-if (complex-nan? (acos +nan.0)))
+ (pass-if (eqv? 0 (acos 1)))
+ (pass-if (eqv? 0.0 (acos 1.0))))
+
+;;;
+;;; atan
+;;;
+;;; FIXME: add tests for two-argument atan
+;;;
+(with-test-prefix "atan"
+ (pass-if (real-nan? (atan +nan.0)))
+ (pass-if (eqv? 0 (atan 0)))
+ (pass-if (eqv? 0.0 (atan 0.0)))
+ (pass-if (eqv-loosely? 1.57 (atan +inf.0)))
+ (pass-if (eqv-loosely? -1.57 (atan -inf.0))))
+
+;;;
;;; asinh
;;;
--
1.5.6.5
^ permalink raw reply related [flat|nested] 24+ messages in thread* Re: [PATCH] First batch of numerics changes 2011-01-26 16:32 [PATCH] First batch of numerics changes Mark H Weaver @ 2011-01-26 18:07 ` Mark H Weaver 2011-01-26 22:46 ` Mark H Weaver 2011-01-28 11:41 ` Andy Wingo 2 siblings, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-26 18:07 UTC (permalink / raw) To: guile-devel I wrote: > Here's my first batch of numerics bugfixes and other changes for > improved mathematical correctness and R6RS compliance. As far as > I can tell, they're ready to commit. Reviews solicited. Apologies for the wasted bandwidth, but I now realize that R6RS does not actually require that (eqv? +nan.0 +nan.0) be false, so I will let it remain true for the sake of backward compatibility. Therefore, for the time being, please disregard: 0008-equal-and-eqv-equivalent-for-numbers-and-not-eq.patch and all patches after it. I will post revised patches soon. Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-26 16:32 [PATCH] First batch of numerics changes Mark H Weaver 2011-01-26 18:07 ` Mark H Weaver @ 2011-01-26 22:46 ` Mark H Weaver 2011-01-27 22:06 ` Mark H Weaver ` (2 more replies) 2011-01-28 11:41 ` Andy Wingo 2 siblings, 3 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-26 22:46 UTC (permalink / raw) To: guile-devel [-- Attachment #1: Type: text/plain, Size: 1503 bytes --] Attached is an improved version of my first 20 patches of numerics bugfixes and changes for improved R6RS (and in some cases, R5RS!) standards compliance. The first seven patches are unchanged from my last post, but I rebased them and they're not very large, so I include them here for completeness. There are many changes, but I would like to draw attention to one in particular: R5RS requires that `equal?' must be equivalent to `eqv?' for numbers, but that is not the case in the existing Guile code. The two differences of which I'm aware are NaNs and signed zeroes: (eqv? +nan.0 +nan.0) => #t (equal? +nan.0 +nan.0) => #f (eqv? 0.0 -0.0) => #f (equal? 0.0 -0.0) => #t After applying these patches, the behavior of `equal?' will change to match that of `eqv?': henceforth, they will both be able to distinguish signed zeroes and detect NaNs (although using `nan?' for the latter job is highly recommended). There are some other user-visible changes as well. See the commit logs, and the included NEWS patches for details. [Note that I still have a 116 kilobyte patch with more numerics changes that aren't included here, because I haven't yet split that portion into small commits. Most notably, the remaining changes allow non-real complex numbers to have inexact zero imaginary parts, as required by R6RS. Only numbers with an _exact_ 0 imaginary part are considered real by R6RS.] In any case, reviews of the attached patches are solicited. Thanks, Mark [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: Do not apply `inf?' or `nan?' to strings --] [-- Type: text/x-diff, Size: 2582 bytes --] From 9f9012a5a830145be908977b3f4058f950348811 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 25 Jan 2011 18:35:22 -0500 Subject: [PATCH] Do not apply `inf?' or `nan?' to strings * module/ice-9/format.scm (format): Test to make sure an argument is a number before applying `inf?' and `nan?' to it. Formerly, format would call `inf?' and `nan?' on arguments that might be either a number or a string, although those predicates should ideally throw an exception when applied to non-number objects. --- module/ice-9/format.scm | 14 +++++++++----- 1 files changed, 9 insertions(+), 5 deletions(-) diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm index 1681004..7cd0183 100644 --- a/module/ice-9/format.scm +++ b/module/ice-9/format.scm @@ -1,5 +1,5 @@ ;;;; "format.scm" Common LISP text output formatter for SLIB -;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -1079,7 +1079,8 @@ (padch (format:par pars l 4 format:space-ch #f))) (cond - ((or (inf? number) (nan? number)) + ((and (number? number) + (or (inf? number) (nan? number))) (format:out-inf-nan number width digits #f overch padch)) (digits @@ -1140,7 +1141,8 @@ (expch (format:par pars l 6 #f #f))) (cond - ((or (inf? number) (nan? number)) + ((and (number? number) + (or (inf? number) (nan? number))) (format:out-inf-nan number width digits edigits overch padch)) (digits ; fixed precision @@ -1231,7 +1233,8 @@ (overch (if (> l 4) (list-ref pars 4) #f)) (padch (if (> l 5) (list-ref pars 5) #f))) (cond - ((or (inf? number) (nan? number)) + ((and (number? number) + (or (inf? number) (nan? number))) ;; FIXME: this isn't right. (format:out-inf-nan number width digits edigits overch padch)) (else @@ -1265,7 +1268,8 @@ (padch (format:par pars l 3 format:space-ch #f))) (cond - ((or (inf? number) (nan? number)) + ((and (number? number) + (or (inf? number) (nan? number))) (format:out-inf-nan number width digits #f #f padch)) (else -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #3: Fix NEWS entry regarding changes to `expt' for zero base --] [-- Type: text/x-diff, Size: 1124 bytes --] From 08658dc63d709e1274d110d787649a2fe21776e6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 25 Jan 2011 18:53:36 -0500 Subject: [PATCH] Fix NEWS entry regarding changes to `expt' for zero base NEWS: Fix NEWS entry regarding changes to `expt' when base is zero --- NEWS | 8 ++++---- 1 files changed, 4 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index c2bb1c1..388f43d 100644 --- a/NEWS +++ b/NEWS @@ -23,11 +23,11 @@ manual, for more information. ** `expt' and `integer-expt' changes when the base is 0 -While `(expt 0 0)' is still 1, `(expt 0 N)' for N > 0 is now 0, and -`(expt 0 N)' for N < 0 is now a NaN value, and likewise for +While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still +zero, `(expt 0 N)' for N < 0 is now a NaN value, and likewise for integer-expt. This is more correct, and conforming to R6RS, but seems -to be incompatible with R5RS, which would always return 0 for all values -of N. +to be incompatible with R5RS, which would return 0 for all non-zero +values of N. ** And of course, the usual collection of bugfixes -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #4: Add SCM_INUM1 to numbers.h, and make use of it and SCM_INUM0 in numbers.c --] [-- Type: text/x-diff, Size: 10259 bytes --] From d8af87fafe19b54d6155c485afce3058af90c457 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Tue, 25 Jan 2011 18:58:47 -0500 Subject: [PATCH] Add SCM_INUM1 to numbers.h, and make use of it and SCM_INUM0 in numbers.c * libguile/numbers.h: Add SCM_INUM1, a name for the fixnum 1. This is analogous to SCM_INUM0, a name for 0, which already existed. * libguile/numbers.c: Change occurrences of SCM_I_MAKINUM (0) and SCM_I_MAKINUM (1) to SCM_INUM0 and SCM_INUM1, respectively. --- libguile/numbers.c | 58 ++++++++++++++++++++++++++-------------------------- libguile/numbers.h | 7 +++-- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9c33d07..c1b1d98 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -403,7 +403,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator) { if (scm_is_eq (denominator, SCM_INUM0)) scm_num_overflow ("make-ratio"); - if (scm_is_eq (denominator, SCM_I_MAKINUM(1))) + if (scm_is_eq (denominator, SCM_INUM1)) return numerator; } else @@ -435,7 +435,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator) scm_t_inum y; y = SCM_I_INUM (denominator); if (x == y) - return SCM_I_MAKINUM(1); + return SCM_INUM1; if ((x % y) == 0) return SCM_I_MAKINUM (x / y); } @@ -462,7 +462,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator) else { if (scm_is_eq (numerator, denominator)) - return SCM_I_MAKINUM(1); + return SCM_INUM1; if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator), SCM_I_BIG_MPZ (denominator))) return scm_divide(numerator, denominator); @@ -473,7 +473,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator) */ { SCM divisor = scm_gcd (numerator, denominator); - if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) + if (!(scm_is_eq (divisor, SCM_INUM1))) { numerator = scm_divide (numerator, divisor); denominator = scm_divide (denominator, divisor); @@ -772,7 +772,7 @@ scm_quotient (SCM x, SCM y) return SCM_I_MAKINUM (-1); } else - return SCM_I_MAKINUM (0); + return SCM_INUM0; } else SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); @@ -849,7 +849,7 @@ scm_remainder (SCM x, SCM y) { /* Special case: x == fixnum-min && y == abs (fixnum-min) */ scm_remember_upto_here_1 (y); - return SCM_I_MAKINUM (0); + return SCM_INUM0; } else return x; @@ -1932,7 +1932,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, { bits_to_shift = -bits_to_shift; if (bits_to_shift >= SCM_LONG_BIT) - return (nn >= 0 ? SCM_I_MAKINUM (0) : SCM_I_MAKINUM(-1)); + return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1)); else return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); } @@ -2694,7 +2694,7 @@ mem2decimal_from_point (SCM result, SCM mem, scm_t_bits shift = 1; scm_t_bits add = 0; unsigned int digit_value; - SCM big_shift = SCM_I_MAKINUM (1); + SCM big_shift = SCM_INUM1; idx++; while (idx != len) @@ -2882,7 +2882,7 @@ mem2ureal (SCM mem, unsigned int *p_idx, else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1))) return SCM_BOOL_F; else - result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, + result = mem2decimal_from_point (SCM_INUM0, mem, p_idx, &x); } else @@ -2933,7 +2933,7 @@ mem2ureal (SCM mem, unsigned int *p_idx, /* When returning an inexact zero, make sure it is represented as a floating point value so that we can change its sign. */ - if (scm_is_eq (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT) + if (scm_is_eq (result, SCM_INUM0) && *p_exactness == INEXACT) result = scm_from_double (0.0); return result; @@ -2984,7 +2984,7 @@ mem2complex (SCM mem, unsigned int idx, if (idx != len) return SCM_BOOL_F; - return scm_make_rectangular (SCM_I_MAKINUM (0), SCM_I_MAKINUM (sign)); + return scm_make_rectangular (SCM_INUM0, SCM_I_MAKINUM (sign)); } else return SCM_BOOL_F; @@ -3008,7 +3008,7 @@ mem2complex (SCM mem, unsigned int idx, return SCM_BOOL_F; if (idx != len) return SCM_BOOL_F; - return scm_make_rectangular (SCM_I_MAKINUM (0), ureal); + return scm_make_rectangular (SCM_INUM0, ureal); case '@': /* polar input: <real>@<real>. */ @@ -4398,7 +4398,7 @@ SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0, "Return @math{@var{x}+1}.") #define FUNC_NAME s_scm_oneplus { - return scm_sum (x, SCM_I_MAKINUM (1)); + return scm_sum (x, SCM_INUM1); } #undef FUNC_NAME @@ -4658,7 +4658,7 @@ SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0, "Return @math{@var{x}-1}.") #define FUNC_NAME s_scm_oneminus { - return scm_difference (x, SCM_I_MAKINUM (1)); + return scm_difference (x, SCM_INUM1); } #undef FUNC_NAME @@ -4939,14 +4939,14 @@ do_divide (SCM x, SCM y, int inexact) { if (inexact) return scm_from_double (1.0 / (double) xx); - else return scm_i_make_ratio (SCM_I_MAKINUM(1), x); + else return scm_i_make_ratio (SCM_INUM1, x); } } else if (SCM_BIGP (x)) { if (inexact) return scm_from_double (1.0 / scm_i_big2dbl (x)); - else return scm_i_make_ratio (SCM_I_MAKINUM(1), x); + else return scm_i_make_ratio (SCM_INUM1, x); } else if (SCM_REALP (x)) { @@ -5410,7 +5410,7 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0, /* Adjust so that the rounding is towards even. */ if (scm_is_true (scm_num_eq_p (plus_half, result)) && scm_is_true (scm_odd_p (result))) - return scm_difference (result, SCM_I_MAKINUM (1)); + return scm_difference (result, SCM_INUM1); else return result; } @@ -5440,7 +5440,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, /* For negative x, we need to return q-1 unless x is an integer. But fractions are never integer, per our assumptions. */ - return scm_difference (q, SCM_I_MAKINUM (1)); + return scm_difference (q, SCM_INUM1); } } else @@ -5471,7 +5471,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, /* For positive x, we need to return q+1 unless x is an integer. But fractions are never integer, per our assumptions. */ - return scm_sum (q, SCM_I_MAKINUM (1)); + return scm_sum (q, SCM_INUM1); } } else @@ -5743,7 +5743,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0, else if (scm_is_number (z)) return scm_log (scm_sum (z, scm_sqrt (scm_sum (scm_product (z, z), - SCM_I_MAKINUM (1))))); + SCM_INUM1)))); else SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh); } @@ -5759,7 +5759,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0, else if (scm_is_number (z)) return scm_log (scm_sum (z, scm_sqrt (scm_difference (scm_product (z, z), - SCM_I_MAKINUM (1))))); + SCM_INUM1)))); else SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh); } @@ -5773,8 +5773,8 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0, if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0) return scm_from_double (atanh (scm_to_double (z))); else if (scm_is_number (z)) - return scm_divide (scm_log (scm_divide (scm_sum (SCM_I_MAKINUM (1), z), - scm_difference (SCM_I_MAKINUM (1), z))), + return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z), + scm_difference (SCM_INUM1, z))), SCM_I_MAKINUM (2)); else SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh); @@ -5911,9 +5911,9 @@ SCM scm_denominator (SCM z) { if (SCM_I_INUMP (z)) - return SCM_I_MAKINUM (1); + return SCM_INUM1; else if (SCM_BIGP (z)) - return SCM_I_MAKINUM (1); + return SCM_INUM1; else if (SCM_FRACTIONP (z)) return SCM_FRACTION_DENOMINATOR (z); else if (SCM_REALP (z)) @@ -6093,9 +6093,9 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, SCM ex = scm_inexact_to_exact (x); SCM int_part = scm_floor (ex); - SCM tt = SCM_I_MAKINUM (1); - SCM a1 = SCM_I_MAKINUM (0), a2 = SCM_I_MAKINUM (1), a = SCM_I_MAKINUM (0); - SCM b1 = SCM_I_MAKINUM (1), b2 = SCM_I_MAKINUM (0), b = SCM_I_MAKINUM (0); + SCM tt = SCM_INUM1; + SCM a1 = SCM_INUM0, a2 = SCM_INUM1, a = SCM_INUM0; + SCM b1 = SCM_INUM1, b2 = SCM_INUM0, b = SCM_INUM0; SCM rx; int i = 0; @@ -6664,7 +6664,7 @@ scm_init_numbers () scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG; #endif - exactly_one_half = scm_divide (SCM_I_MAKINUM (1), SCM_I_MAKINUM (2)); + exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2)); #include "libguile/numbers.x" } diff --git a/libguile/numbers.h b/libguile/numbers.h index a3701a6..740dc80 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -3,7 +3,7 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -68,8 +68,9 @@ typedef scm_t_int32 scm_t_wchar; #define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n)) -/* A name for 0. */ -#define SCM_INUM0 (SCM_I_MAKINUM (0)) +#define SCM_INUM0 (SCM_I_MAKINUM (0)) /* A name for 0 */ +#define SCM_INUM1 (SCM_I_MAKINUM (1)) /* A name for 1 */ + /* SCM_MAXEXP is the maximum double precision exponent * SCM_FLTMAX is less than or scm_equal the largest single precision float -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #5: Implement `finite?' in core and fix R6RS `finite?' and `infinite?' --] [-- Type: text/x-diff, Size: 8028 bytes --] From 4983deef36933e7b6678a5c3412241c1f37d4cfb Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 09:34:02 -0500 Subject: [PATCH] Implement `finite?' in core and fix R6RS `finite?' and `infinite?' * libguile/numbers.c (scm_finite_p): Add new predicate `finite?' from R6RS to guile core, which returns #t if and only if its argument is neither infinite nor a NaN. Note that this is not the same as (not (inf? x)) or (not (infinite? x)), since NaNs are neither finite nor infinite. * test-suite/tests/numbers.test: Add test cases for `finite?'. * module/rnrs/base.scm: Import `inf?' as `infinite?' instead of reimplementing it. Previously, the R6RS implementation of `infinite?' did not detect non-real complex infinities, nor did it throw exceptions for non-numbers. (Note that NaNs _are_ considered numbers by scheme, despite their name). Import `finite?' instead of reimplementing it. Previously, the R6RS implementation of `finite?' returned #t for both NaNs and non-real complex infinities, in violation of R6RS. * NEWS: Add NEWS entries, and reorganize existing numerics-related entries together under one subheading. * doc/ref/api-data.texi (Real and Rational Numbers): Add docs for `finite?' and scm_finite_p. --- NEWS | 39 +++++++++++++++++++++++++++++++-------- doc/ref/api-data.texi | 9 ++++++++- libguile/numbers.c | 22 ++++++++++++++++++++++ module/rnrs/base.scm | 6 ++---- test-suite/tests/numbers.test | 26 ++++++++++++++++++++++++++ 5 files changed, 89 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 388f43d..757f783 100644 --- a/NEWS +++ b/NEWS @@ -10,18 +10,14 @@ latest prerelease, and a full NEWS corresponding to 1.8 -> 2.0. Changes in 1.9.15 (since the 1.9.14 prerelease): -** Infinities are no longer integers. +** Changes and bugfixes in numerics code + +*** Infinities are no longer integers. Following the R6RS, infinities (+inf.0 and -inf.0) are no longer considered to be integers. -** New reader option: `hungry-eol-escapes' - -Guile's string syntax is more compatible with R6RS when the -`hungry-eol-escapes' option is enabled. See "String Syntax" in the -manual, for more information. - -** `expt' and `integer-expt' changes when the base is 0 +*** `expt' and `integer-expt' changes when the base is 0 While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still zero, `(expt 0 N)' for N < 0 is now a NaN value, and likewise for @@ -29,6 +25,33 @@ integer-expt. This is more correct, and conforming to R6RS, but seems to be incompatible with R5RS, which would return 0 for all non-zero values of N. +*** New procedure: `finite?' + +Add scm_finite_p `finite?' from R6RS to guile core, which returns #t +if and only if its argument is neither infinite nor a NaN. Note that +this is not the same as (not (inf? x)) or (not (infinite? x)), since +NaNs are neither finite nor infinite. + +*** R6RS base library changes + +**** `infinite?' changes + +`infinite?' now returns #t for non-real complex infinities, and throws +exceptions for non-numbers. (Note that NaNs _are_ considered numbers +by scheme, despite their name). + +**** `finite?' changes + +`finite?' now returns #f for NaNs and non-real complex infinities, and +throws exceptions for non-numbers. (Note that NaNs _are_ considered +numbers by scheme, despite their name). + +** New reader option: `hungry-eol-escapes' + +Guile's string syntax is more compatible with R6RS when the +`hungry-eol-escapes' option is enabled. See "String Syntax" in the +manual, for more information. + ** And of course, the usual collection of bugfixes Interested users should see the ChangeLog for more information. diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4835f30..fc253b0 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -549,7 +549,8 @@ While @samp{+nan.0} is not @code{=} to itself, it is @code{eqv?} to itself. To test for the special values, use the functions @code{inf?} and -@code{nan?}. +@code{nan?}. To test for numbers than are neither infinite nor a NaN, +use @code{finite?}. @deffn {Scheme Procedure} real? obj @deffnx {C Function} scm_real_p (obj) @@ -597,6 +598,12 @@ Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0}, Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise. @end deffn +@deffn {Scheme Procedure} finite? x +@deffnx {C Function} scm_finite_p (x) +Return @code{#t} if @var{x} is neither infinite nor a NaN, +@code{#f} otherwise. +@end deffn + @deffn {Scheme Procedure} nan @deffnx {C Function} scm_nan () Return NaN. diff --git a/libguile/numbers.c b/libguile/numbers.c index c1b1d98..174ad23 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -79,6 +79,10 @@ typedef scm_t_signed_bits scm_t_inum; #define scm_from_inum(x) (scm_from_signed_integer (x)) +/* Tests to see if a C double is neither infinite nor a NaN. + TODO: if it's available, use C99's isfinite(x) instead */ +#define SCM_I_CDBL_IS_FINITE(x) (!isinf(x) && !isnan(x)) + \f /* @@ -581,6 +585,24 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is neither infinite\n" + "nor a NaN, @code{#f} otherwise.") +#define FUNC_NAME s_scm_finite_p +{ + if (SCM_REALP (x)) + return scm_from_bool (SCM_I_CDBL_IS_FINITE (SCM_REAL_VALUE (x))); + else if (SCM_COMPLEXP (x)) + return scm_from_bool (SCM_I_CDBL_IS_FINITE (SCM_COMPLEX_REAL (x)) + && SCM_I_CDBL_IS_FINITE (SCM_COMPLEX_IMAG (x))); + else if (SCM_NUMBERP (x)) + return SCM_BOOL_T; + else + SCM_WRONG_TYPE_ARG (1, x); +} +#undef FUNC_NAME + SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is either @samp{+inf.0}\n" diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index a6ae1b9..c7579c3 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -1,6 +1,6 @@ ;;; base.scm --- The R6RS base library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -76,6 +76,7 @@ (import (rename (except (guile) error raise) (quotient div) (modulo mod) + (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) (srfi srfi-11)) @@ -98,9 +99,6 @@ (let ((sym (car syms))) (and (symbol? sym) (symbol=?-internal (cdr syms) sym))))) - (define (infinite? x) (or (eqv? x +inf.0) (eqv? x -inf.0))) - (define (finite? x) (not (infinite? x))) - (define (exact-integer-sqrt x) (let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 5ea4764..d9a75f3 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -305,6 +305,32 @@ (pass-if (even? (* 2 fixnum-min)))) ;;; +;;; finite? +;;; + +(with-test-prefix "finite?" + (pass-if (documented? finite?)) + (pass-if (not (finite? (inf)))) + (pass-if (not (finite? +inf.0))) + (pass-if (not (finite? -inf.0))) + (pass-if (not (finite? +inf.0+1i))) + (pass-if (not (finite? -inf.0+1i))) + (pass-if (not (finite? +1+inf.0i))) + (pass-if (not (finite? +1-inf.0i))) + (pass-if (not (finite? (nan)))) + (pass-if (not (finite? +nan.0))) + (pass-if (not (finite? 1+nan.0i))) + (pass-if (not (finite? +nan.0+nan.0i))) + (pass-if (finite? 0)) + (pass-if (finite? 0.0)) + (pass-if (finite? -0.0)) + (pass-if (finite? 42.0)) + (pass-if (finite? 1/2)) + (pass-if (finite? 42.0+700i)) + (pass-if (finite? (+ fixnum-max 1))) + (pass-if (finite? (- fixnum-min 1)))) + +;;; ;;; inf? and inf ;;; -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #6: Optimize scm_exact_p by making use of SCM_INEXACTP --] [-- Type: text/x-diff, Size: 3067 bytes --] From f0e96e00a247d9a31e73f4fe901b6471ce73e902 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 09:36:05 -0500 Subject: [PATCH] Optimize scm_exact_p by making use of SCM_INEXACTP * libguile/numbers.c (scm_exact_p): Optimize by making use of the SCM_INEXACTP macro. (scm_inexact_p): Move it next to scm_exact_p, and add else's. * test-suite/tests/numbers.test: Add test cases for `exact?' and `inexact?' applied to infinities and NaNs. --- libguile/numbers.c | 40 +++++++++++++++++++--------------------- test-suite/tests/numbers.test | 9 ++++++++- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 174ad23..f417559 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -503,15 +503,28 @@ SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_exact_p { - if (SCM_I_INUMP (x)) - return SCM_BOOL_T; - if (SCM_BIGP (x)) + if (SCM_INEXACTP (x)) + return SCM_BOOL_F; + else if (SCM_NUMBERP (x)) return SCM_BOOL_T; - if (SCM_FRACTIONP (x)) + else + SCM_WRONG_TYPE_ARG (1, x); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n" + "else.") +#define FUNC_NAME s_scm_inexact_p +{ + if (SCM_INEXACTP (x)) return SCM_BOOL_T; - if (SCM_NUMBERP (x)) + else if (SCM_NUMBERP (x)) return SCM_BOOL_F; - SCM_WRONG_TYPE_ARG (1, x); + else + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME @@ -3364,21 +3377,6 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n" - "else.") -#define FUNC_NAME s_scm_inexact_p -{ - if (SCM_INEXACTP (x)) - return SCM_BOOL_T; - if (SCM_NUMBERP (x)) - return SCM_BOOL_F; - SCM_WRONG_TYPE_ARG (1, x); -} -#undef FUNC_NAME - - SCM scm_i_num_eq_p (SCM, SCM, SCM); SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1, (SCM x, SCM y, SCM rest), diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index d9a75f3..27de045 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -240,7 +240,11 @@ (eq? #f (exact? (sqrt (- (expt fixnum-max 2) 1))))) (pass-if "sqrt ((fixnum-max+1)^2 - 1)" - (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) + (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))) + + (pass-if (not (exact? +inf.0))) + (pass-if (not (exact? -inf.0))) + (pass-if (not (exact? +nan.0))))) ;;; ;;; exp @@ -1559,6 +1563,9 @@ (pass-if (not (inexact? (- 1 fixnum-min)))) (pass-if (inexact? 1.3)) (pass-if (inexact? 3.1+4.2i)) + (pass-if (inexact? +inf.0)) + (pass-if (inexact? -inf.0)) + (pass-if (inexact? +nan.0)) (pass-if-exception "char" exception:wrong-type-arg (not (inexact? #\a))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #7: Remove useless code from do_divide --] [-- Type: text/x-diff, Size: 3085 bytes --] From dc66756782033f21a36d801eafe6a1fa1b4568ed Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 02:50:03 -0500 Subject: [PATCH] Remove useless code from do_divide * libguile/numbers.c (do_divide): Remove code which handled a case that never occurs: a zero bignum. --- libguile/numbers.c | 60 ++++++++++++++++++++-------------------------------- 1 files changed, 23 insertions(+), 37 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index f417559..e25242f 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5124,47 +5124,33 @@ do_divide (SCM x, SCM y, int inexact) } else if (SCM_BIGP (y)) { - int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0); - if (y_is_zero) + /* big_x / big_y */ + if (inexact) { -#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO - scm_num_overflow (s_divide); -#else - int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - scm_remember_upto_here_1 (x); - return (sgn == 0) ? scm_nan () : scm_inf (); -#endif + /* It's easily possible for the ratio x/y to fit a double + but one or both x and y be too big to fit a double, + hence the use of mpq_get_d rather than converting and + dividing. */ + mpq_t q; + *mpq_numref(q) = *SCM_I_BIG_MPZ (x); + *mpq_denref(q) = *SCM_I_BIG_MPZ (y); + return scm_from_double (mpq_get_d (q)); } else { - /* big_x / big_y */ - if (inexact) - { - /* It's easily possible for the ratio x/y to fit a double - but one or both x and y be too big to fit a double, - hence the use of mpq_get_d rather than converting and - dividing. */ - mpq_t q; - *mpq_numref(q) = *SCM_I_BIG_MPZ (x); - *mpq_denref(q) = *SCM_I_BIG_MPZ (y); - return scm_from_double (mpq_get_d (q)); - } - else - { - int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - if (divisible_p) - { - SCM result = scm_i_mkbig (); - mpz_divexact (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_i_normbig (result); - } - else - return scm_i_make_ratio (x, y); - } + int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + if (divisible_p) + { + SCM result = scm_i_mkbig (); + mpz_divexact (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (result); + } + else + return scm_i_make_ratio (x, y); } } else if (SCM_REALP (y)) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #8: Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p --] [-- Type: text/x-diff, Size: 2656 bytes --] From 5ed835b307820e5ebb3fdd1d3b80143c7d4e3430 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 02:56:20 -0500 Subject: [PATCH] Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p * libguile/eq.c (scm_equal_p): Add a special case for fractions with differing SCM_CELL_TYPE, which might nonetheless be considered equal (due to the use of 0x10000 as a flag), to scm_equal_p. This code was already present in scm_eqv_p. (scm_eqv_p): Move comment (regarding special case for fractions) next to the corresponding code. --- libguile/eq.c | 19 +++++++++++++------ 1 files changed, 13 insertions(+), 6 deletions(-) diff --git a/libguile/eq.c b/libguile/eq.c index 7502559..dc548b8 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -170,11 +170,6 @@ SCM scm_eqv_p (SCM x, SCM y) if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { - /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), - but this checks the entire type word, so fractions may be accidentally - flagged here as unequal. Perhaps I should use the 4th double_cell word? - */ - /* treat mixes of real and complex types specially */ if (SCM_INEXACTP (x)) { @@ -190,8 +185,13 @@ SCM scm_eqv_p (SCM x, SCM y) && SCM_COMPLEX_IMAG (x) == 0.0); } + /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), + but this checks the entire type word, so fractions may be accidentally + flagged here as unequal. Perhaps I should use the 4th double_cell word? + */ if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) return scm_i_fraction_equalp (x, y); + return SCM_BOOL_F; } if (SCM_NUMP (x)) @@ -322,6 +322,13 @@ scm_equal_p (SCM x, SCM y) && SCM_COMPLEX_IMAG (x) == 0.0); } + /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), + but this checks the entire type word, so fractions may be accidentally + flagged here as unequal. Perhaps I should use the 4th double_cell word? + */ + if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) + return scm_i_fraction_equalp (x, y); + /* Vectors can be equal to one-dimensional arrays. */ if (scm_is_array (x) && scm_is_array (y)) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #9: equal? and eqv? are now equivalent for numbers --] [-- Type: text/x-diff, Size: 13970 bytes --] From 31d0b8d63b388ce8eb331ad75954bdc7a0175feb Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 15:57:08 -0500 Subject: [PATCH] equal? and eqv? are now equivalent for numbers * libguile/numbers.c (scm_real_equalp, scm_bigequal, scm_complex_equalp, scm_i_fraction_equalp): Move to eq.c. (scm_nan_p): Improve documentation string to mention the existence of non-real complex NaNs. * libguile/eq.c (scm_bigequal, scm_i_fraction_equalp): Do the same thing that `eqv?' does. (real_eqv): Test for NaNs using isnan(x) instead of (x != x), and use SCM_UNLIKELY for optimization. (scm_real_equalp): Do the same thing that `eqv?' does. Previously worked differently in some cases, e.g. when comparing signed zeroes or NaNs. For example, (equal? 0.0 -0.0) returned #t but (eqv? 0.0 -0.0) returned #f, and (equal? +nan.0 +nan.0) returned #f but (eqv? +nan.0 +nan.0) returned #t. (scm_complex_equalp): Do the same thing that `eqv?' does. Previously worked differently in some cases, e.g. when comparing signed zeroes or NaNs. * test-suite/tests/numbers.test: Add test cases for `eqv?' and `equal?'. Change existing test case for `(equal? +nan.0 +nan.0)' to expect #t instead of #f. * doc/ref/api-data.texi (Real and Rational Numbers): Improve the discussion on infinities and NaNs, and clarify the documentation for scm_nan_p `nan?' to mention the existence of non-real complex NaNs. * NEWS: Add NEWS entries. --- NEWS | 15 +++++++ doc/ref/api-data.texi | 50 +++++++++++++----------- libguile/eq.c | 44 ++++++++++++++++++--- libguile/numbers.c | 39 +----------------- test-suite/tests/numbers.test | 85 ++++++++++++++++++++++++++++++++++++++++- 5 files changed, 166 insertions(+), 67 deletions(-) diff --git a/NEWS b/NEWS index 757f783..436efe8 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,21 @@ Changes in 1.9.15 (since the 1.9.14 prerelease): ** Changes and bugfixes in numerics code +*** `eqv?' and `equal?' now compare numbers equivalently + +scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for +numeric values, per R5RS. Previously, equal? worked differently, +e.g. `(equal? 0.0 -0.0)' returned #t but `(eqv? 0.0 -0.0)' returned #f, +and `(equal? +nan.0 +nan.0)' returned #f but `(eqv? +nan.0 +nan.0)' +returned #t. + +*** `(equal? +nan.0 +nan.0)' now returns #t + +Previously, `(equal? +nan.0 +nan.0)' returned #f, although +`(let ((x +nan.0)) (equal? x x))' and `(eqv? +nan.0 +nan.0)' +both returned #t. R5RS requires that `equal?' behave like +`eqv?' when comparing numbers. + *** Infinities are no longer integers. Following the R6RS, infinities (+inf.0 and -inf.0) are no longer diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index fc253b0..b2c4b89 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -526,18 +526,28 @@ by sufficient powers of 10 (or in fact, 2). For example, @code{rational?} and @code{real?} predicates are equivalent. -Dividing by an exact zero leads to a error message, as one might -expect. However, dividing by an inexact zero does not produce an -error. Instead, the result of the division is either plus or minus -infinity, depending on the sign of the divided number. - -The infinities are written @samp{+inf.0} and @samp{-inf.0}, -respectively. This syntax is also recognized by @code{read} as an +Dividing by an exact zero leads to a error message, as one might expect. +However, dividing by an inexact zero does not produce an error. +Instead, the result of the division is either plus or minus infinity, +depending on the sign of the divided number and the sign of the zero +divisor (some platforms support signed zeroes @samp{-0.0} and +@samp{+0.0}; @samp{0.0} is the same as @samp{+0.0}). + +Dividing zero by an inexact zero yields a @acronym{NaN} (`not a number') +value, although they are actually considered numbers by Scheme. +Attempts to compare a @acronym{NaN} with any number (including itself) +using @code{=}, @code{<}, @code{>}, @code{<=} or @code{>=} always +returns @code{#f}. Although @code{+nan.0} is not @code{=} to itself, it +is both @code{eqv?} and @code{equal?} to itself. The best way to test +for them is by using @code{nan?}, which also detects complex numbers +whose real or imaginary part is a @acronym{NaN}. + +These special values are written @samp{+nan.0}, @samp{+inf.0} and +@samp{-inf.0}. This syntax is also recognized by @code{read} as an extension to the usual Scheme syntax. The infinities are considered to -be inexact, non-integer values. - -Dividing zero by zero yields something that is not a number at all: -@samp{+nan.0}. This is the special `not a number' value. +be inexact, non-integer values. @acronym{NaN} values are considered to +be inexact and irrational. To test for numbers that are neither +infinite nor a @acronym{NaN}, use @code{finite?}. On platforms that follow @acronym{IEEE} 754 for their floating point arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values @@ -545,13 +555,6 @@ are implemented using the corresponding @acronym{IEEE} 754 values. They behave in arithmetic operations like @acronym{IEEE} 754 describes it, i.e., @code{(= +nan.0 +nan.0)} @result{} @code{#f}. -While @samp{+nan.0} is not @code{=} to itself, it is @code{eqv?} to -itself. - -To test for the special values, use the functions @code{inf?} and -@code{nan?}. To test for numbers than are neither infinite nor a NaN, -use @code{finite?}. - @deffn {Scheme Procedure} real? obj @deffnx {C Function} scm_real_p (obj) Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note @@ -595,23 +598,24 @@ Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0}, @deffn {Scheme Procedure} nan? x @deffnx {C Function} scm_nan_p (x) -Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise. +Return @code{#t} if @var{x} is @samp{+nan.0}, or a complex number whose +real or imaginary part is @samp{+nan.0}. Otherwise return @code{#f}. @end deffn @deffn {Scheme Procedure} finite? x @deffnx {C Function} scm_finite_p (x) -Return @code{#t} if @var{x} is neither infinite nor a NaN, -@code{#f} otherwise. +Return @code{#t} if @var{x} is neither @code{inf?} nor @code{nan?}. +Otherwise return @code{#f}. @end deffn @deffn {Scheme Procedure} nan @deffnx {C Function} scm_nan () -Return NaN. +Return @samp{+nan.0}. @end deffn @deffn {Scheme Procedure} inf @deffnx {C Function} scm_inf () -Return Inf. +Return @samp{+inf.0}. @end deffn @deffn {Scheme Procedure} numerator x diff --git a/libguile/eq.c b/libguile/eq.c index dc548b8..e03021e 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -118,7 +118,40 @@ scm_eq_p (SCM x, SCM y) static int real_eqv (double x, double y) { - return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y); + return !memcmp (&x, &y, sizeof(double)) + || (SCM_UNLIKELY (isnan (x)) && SCM_UNLIKELY (isnan (y))); +} + +SCM +scm_real_equalp (SCM x, SCM y) +{ + return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), + SCM_REAL_VALUE (y))); +} + +SCM +scm_bigequal (SCM x, SCM y) +{ + return scm_from_bool (scm_i_bigcmp (x, y) == 0); +} + +SCM +scm_complex_equalp (SCM x, SCM y) +{ + return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), + SCM_COMPLEX_REAL (y)) + && real_eqv (SCM_COMPLEX_IMAG (x), + SCM_COMPLEX_IMAG (y))); +} + +SCM +scm_i_fraction_equalp (SCM x, SCM y) +{ + return scm_from_bool + (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y))) + && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y)))); } static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest); @@ -197,16 +230,13 @@ SCM scm_eqv_p (SCM x, SCM y) if (SCM_NUMP (x)) { if (SCM_BIGP (x)) { - return scm_from_bool (scm_i_bigcmp (x, y) == 0); + return scm_bigequal (x, y); } else if (SCM_REALP (x)) { - return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); + return scm_real_equalp (x, y); } else if (SCM_FRACTIONP (x)) { return scm_i_fraction_equalp (x, y); } else { /* complex */ - return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), - SCM_COMPLEX_REAL (y)) - && real_eqv (SCM_COMPLEX_IMAG (x), - SCM_COMPLEX_IMAG (y))); + return scm_complex_equalp (x, y); } } return SCM_BOOL_F; diff --git a/libguile/numbers.c b/libguile/numbers.c index e25242f..7b00ba9 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -634,8 +634,9 @@ SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, (SCM n), - "Return @code{#t} if @var{n} is a NaN, @code{#f}\n" - "otherwise.") + "Return @code{#t} if @var{x} is @samp{+nan.0},\n" + "or a complex number whose real or imaginary part\n" + "is @samp{+nan.0}. Otherwise return @code{#f}.") #define FUNC_NAME s_scm_nan_p { if (SCM_REALP (n)) @@ -3254,40 +3255,6 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, /*** END strs->nums ***/ -SCM -scm_bigequal (SCM x, SCM y) -{ - int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_from_bool (0 == result); -} - -SCM -scm_real_equalp (SCM x, SCM y) -{ - return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); -} - -SCM -scm_complex_equalp (SCM x, SCM y) -{ - return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y) - && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)); -} - -SCM -scm_i_fraction_equalp (SCM x, SCM y) -{ - if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x), - SCM_FRACTION_NUMERATOR (y))) - || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), - SCM_FRACTION_DENOMINATOR (y)))) - return SCM_BOOL_F; - else - return SCM_BOOL_T; -} - - SCM_DEFINE (scm_number_p, "number?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a number, @code{#f}\n" diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 27de045..7b0b73f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1594,12 +1594,24 @@ (with-test-prefix "equal?" (pass-if (documented? equal?)) + + ;; The following test will fail on platforms + ;; without distinct signed zeroes 0.0 and -0.0. + (pass-if (not (equal? 0.0 -0.0))) + (pass-if (equal? 0 0)) (pass-if (equal? 7 7)) (pass-if (equal? -7 -7)) (pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max))) (pass-if (equal? (- fixnum-min 1) (- fixnum-min 1))) + (pass-if (equal? 0.0 0.0)) + (pass-if (equal? -0.0 -0.0)) (pass-if (not (equal? 0 1))) + (pass-if (not (equal? 0 0.0))) + (pass-if (not (equal? 1 1.0))) + (pass-if (not (equal? 0.0 0))) + (pass-if (not (equal? 1.0 1))) + (pass-if (not (equal? -1.0 -1))) (pass-if (not (equal? fixnum-max (+ 1 fixnum-max)))) (pass-if (not (equal? (+ 1 fixnum-max) fixnum-max))) (pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max)))) @@ -1620,7 +1632,9 @@ (pass-if (not (equal? (- (ash 1 1024)) -inf.0))) (pass-if (not (equal? -inf.0 (- (ash 1 1024))))) - (pass-if (not (equal? +nan.0 +nan.0))) + (pass-if (equal? +nan.0 +nan.0)) + (pass-if (not (equal? +nan.0 0.0+nan.0i))) + (pass-if (not (equal? 0 +nan.0))) (pass-if (not (equal? +nan.0 0))) (pass-if (not (equal? 1 +nan.0))) @@ -1644,6 +1658,75 @@ (pass-if (not (equal? +nan.0 (ash 3 1023))))) ;;; +;;; eqv? +;;; + +(with-test-prefix "eqv?" + (pass-if (documented? eqv?)) + + ;; The following test will fail on platforms + ;; without distinct signed zeroes 0.0 and -0.0. + (pass-if (not (eqv? 0.0 -0.0))) + + (pass-if (eqv? 0 0)) + (pass-if (eqv? 7 7)) + (pass-if (eqv? -7 -7)) + (pass-if (eqv? (+ 1 fixnum-max) (+ 1 fixnum-max))) + (pass-if (eqv? (- fixnum-min 1) (- fixnum-min 1))) + (pass-if (eqv? 0.0 0.0)) + (pass-if (eqv? -0.0 -0.0)) + (pass-if (not (eqv? 0 1))) + (pass-if (not (eqv? 0 0.0))) + (pass-if (not (eqv? 1 1.0))) + (pass-if (not (eqv? 0.0 0))) + (pass-if (not (eqv? 1.0 1))) + (pass-if (not (eqv? -1.0 -1))) + (pass-if (not (eqv? fixnum-max (+ 1 fixnum-max)))) + (pass-if (not (eqv? (+ 1 fixnum-max) fixnum-max))) + (pass-if (not (eqv? (+ 1 fixnum-max) (+ 2 fixnum-max)))) + (pass-if (not (eqv? fixnum-min (- fixnum-min 1)))) + (pass-if (not (eqv? (- fixnum-min 1) fixnum-min))) + (pass-if (not (eqv? (- fixnum-min 1) (- fixnum-min 2)))) + (pass-if (not (eqv? (+ fixnum-max 1) (- fixnum-min 1)))) + + (pass-if (not (eqv? (ash 1 256) +inf.0))) + (pass-if (not (eqv? +inf.0 (ash 1 256)))) + (pass-if (not (eqv? (ash 1 256) -inf.0))) + (pass-if (not (eqv? -inf.0 (ash 1 256)))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make + ;; sure we've avoided that + (pass-if (not (eqv? (ash 1 1024) +inf.0))) + (pass-if (not (eqv? +inf.0 (ash 1 1024)))) + (pass-if (not (eqv? (- (ash 1 1024)) -inf.0))) + (pass-if (not (eqv? -inf.0 (- (ash 1 1024))))) + + (pass-if (eqv? +nan.0 +nan.0)) + (pass-if (not (eqv? +nan.0 0.0+nan.0i))) + + (pass-if (not (eqv? 0 +nan.0))) + (pass-if (not (eqv? +nan.0 0))) + (pass-if (not (eqv? 1 +nan.0))) + (pass-if (not (eqv? +nan.0 1))) + (pass-if (not (eqv? -1 +nan.0))) + (pass-if (not (eqv? +nan.0 -1))) + + (pass-if (not (eqv? (ash 1 256) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 1 256)))) + (pass-if (not (eqv? (- (ash 1 256)) +nan.0))) + (pass-if (not (eqv? +nan.0 (- (ash 1 256))))) + + (pass-if (not (eqv? (ash 1 8192) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 1 8192)))) + (pass-if (not (eqv? (- (ash 1 8192)) +nan.0))) + (pass-if (not (eqv? +nan.0 (- (ash 1 8192))))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make + ;; sure we've avoided that + (pass-if (not (eqv? (ash 3 1023) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 3 1023))))) + +;;; ;;; = ;;; -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #10: Improve docs for `inf?' regarding non-real complex infinities --] [-- Type: text/x-diff, Size: 1913 bytes --] From 09c1a959bdff9cdc0152638086b9e4a509d7c31c Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 04:34:55 -0500 Subject: [PATCH] Improve docs for `inf?' regarding non-real complex infinities * libguile/numbers.c: (scm_inf_p) Improve documentation string to mention that complex numbers with infinite real or imaginary part are also considered infinite. * doc/ref/api-data.texi (Real and Rational Numbers): Improve documentation for `inf?' to mention that complex numbers with infinite real or imaginary part are also considered infinite. --- doc/ref/api-data.texi | 5 +++-- libguile/numbers.c | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index b2c4b89..f2a03b3 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -592,8 +592,9 @@ to use @code{inexact->exact} on the arguments. @deffn {Scheme Procedure} inf? x @deffnx {C Function} scm_inf_p (x) -Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0}, -@code{#f} otherwise. +Return @code{#t} if @var{x} is @samp{+inf.0}, @samp{-inf.0}, or +a complex number whose real or imaginary part is infinite. +Otherwise return @code{#f}. @end deffn @deffn {Scheme Procedure} nan? x diff --git a/libguile/numbers.c b/libguile/numbers.c index 7b00ba9..a631ee4 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -618,8 +618,9 @@ SCM_DEFINE (scm_finite_p, "finite?", 1, 0, 0, SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, (SCM x), - "Return @code{#t} if @var{x} is either @samp{+inf.0}\n" - "or @samp{-inf.0}, @code{#f} otherwise.") + "Return @code{#t} if @var{x} is @samp{+inf.0}, @samp{-inf.0},\n" + "or a complex number whose real or imaginary part is infinite.\n" + "Otherwise return @code{#f}.") #define FUNC_NAME s_scm_inf_p { if (SCM_REALP (x)) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #11: `inf?' and `nan?' throw exceptions when applied to non-numbers --] [-- Type: text/x-diff, Size: 1964 bytes --] From a112e4169b07a9b2aa49e1375ed507004768f6cd Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 04:42:04 -0500 Subject: [PATCH] `inf?' and `nan?' throw exceptions when applied to non-numbers * libguile/numbers.c (scm_inf_p, scm_nan_p): Throw an exception if applied to a non-number object. Previously returned #f. (Note that NaNs _are_ considered numbers by scheme, despite their name). * NEWS: Add NEWS entry. --- NEWS | 6 ++++++ libguile/numbers.c | 8 ++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 436efe8..8153d0e 100644 --- a/NEWS +++ b/NEWS @@ -40,6 +40,12 @@ integer-expt. This is more correct, and conforming to R6RS, but seems to be incompatible with R5RS, which would return 0 for all non-zero values of N. +*** `inf?' and `nan?' now throw exceptions for non-numbers + +scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed +non-number objects. Previously they returned #f. (Note that NaNs +_are_ considered numbers by scheme, despite their name). + *** New procedure: `finite?' Add scm_finite_p `finite?' from R6RS to guile core, which returns #t diff --git a/libguile/numbers.c b/libguile/numbers.c index a631ee4..c6a2162 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -628,8 +628,10 @@ SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, else if (SCM_COMPLEXP (x)) return scm_from_bool (isinf (SCM_COMPLEX_REAL (x)) || isinf (SCM_COMPLEX_IMAG (x))); - else + else if (SCM_NUMBERP (x)) return SCM_BOOL_F; + else + SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME @@ -645,8 +647,10 @@ SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0, else if (SCM_COMPLEXP (n)) return scm_from_bool (isnan (SCM_COMPLEX_REAL (n)) || isnan (SCM_COMPLEX_IMAG (n))); - else + else if (SCM_NUMBERP (n)) return SCM_BOOL_F; + else + SCM_WRONG_TYPE_ARG (1, n); } #undef FUNC_NAME -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #12: Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1 --] [-- Type: text/x-diff, Size: 4005 bytes --] From d3b7e9c346aaa517aa27c22b17238a57e11fc84d Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 05:21:03 -0500 Subject: [PATCH] Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1 * libguile/numbers.c (scm_difference, scm_product): Fix bugs when negating SCM_MOST_POSITIVE_FIXNUM+1, aka -SCM_MOST_NEGATIVE_FIXNUM. Previously, these cases failed to normalize the result to a fixnum, causing `=', `eqv?' and `equal?' to fail, e.g.: (= most-negative-fixnum (- 0 (- most-negative-fixnum))) (= most-negative-fixnum (* -1 (- most-negative-fixnum))) (= most-negative-fixnum (* (- most-negative-fixnum) -1)) * test-suite/test/numbers.test: Add test cases to detect bugs when negating SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM by various methods. --- libguile/numbers.c | 17 ++++++++++++++++- test-suite/tests/numbers.test | 27 +++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 1 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index c6a2162..bfa6c22 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4465,7 +4465,11 @@ scm_difference (SCM x, SCM y) scm_t_inum xx = SCM_I_INUM (x); if (xx == 0) - return scm_i_clonebig (y, 0); + { + /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a + bignum, but negating that gives a fixnum. */ + return scm_i_normbig (scm_i_clonebig (y, 0)); + } else { int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); @@ -4697,6 +4701,17 @@ scm_product (SCM x, SCM y) { case 0: return x; break; case 1: return y; break; + /* + * The following case (x = -1) is important for more than + * just optimization. It handles the case of negating + * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum), + * which is a bignum that must be changed back into a fixnum. + * Failure to do so will cause the following to return #f: + * (= most-negative-fixnum (* -1 (- most-negative-fixnum))) + */ + case -1: + return scm_difference(y, SCM_UNDEFINED); + break; } if (SCM_LIKELY (SCM_I_INUMP (y))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 7b0b73f..2d20ef2 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2597,6 +2597,20 @@ (with-test-prefix/c&e "-" + (pass-if "double-negation of fixnum-min: =" + (= fixnum-min (- (- fixnum-min)))) + (pass-if "double-negation of fixnum-min: eqv?" + (eqv? fixnum-min (- (- fixnum-min)))) + (pass-if "double-negation of fixnum-min: equal?" + (equal? fixnum-min (- (- fixnum-min)))) + + (pass-if "binary double-negation of fixnum-min: =" + (= fixnum-min (- 0 (- 0 fixnum-min)))) + (pass-if "binary double-negation of fixnum-min: eqv?" + (eqv? fixnum-min (- 0 (- 0 fixnum-min)))) + (pass-if "binary double-negation of fixnum-min: equal?" + (equal? fixnum-min (- 0 (- 0 fixnum-min)))) + (pass-if "-inum - +bignum" (= #x-100000000000000000000000000000001 (- -1 #x100000000000000000000000000000000))) @@ -2626,6 +2640,14 @@ (with-test-prefix "*" + (with-test-prefix "double-negation of fixnum-min" + (pass-if (= fixnum-min (* -1 (* -1 fixnum-min)))) + (pass-if (eqv? fixnum-min (* -1 (* -1 fixnum-min)))) + (pass-if (equal? fixnum-min (* -1 (* -1 fixnum-min)))) + (pass-if (= fixnum-min (* (* fixnum-min -1) -1))) + (pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1))) + (pass-if (equal? fixnum-min (* (* fixnum-min -1) -1)))) + (with-test-prefix "inum * bignum" (pass-if "0 * 2^256 = 0" @@ -2679,6 +2701,11 @@ (with-test-prefix "/" + (with-test-prefix "double-negation of fixnum-min" + (pass-if (= fixnum-min (/ (/ fixnum-min -1) -1))) + (pass-if (eqv? fixnum-min (/ (/ fixnum-min -1) -1))) + (pass-if (equal? fixnum-min (/ (/ fixnum-min -1) -1)))) + (pass-if "documented?" (documented? /)) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #13: Infinities and NaNs are no longer rational --] [-- Type: text/x-diff, Size: 8825 bytes --] From 6d2d6566539e5eec70310113aee14a5ba8fb51e7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 16:44:57 -0500 Subject: [PATCH] Infinities and NaNs are no longer rational * libguile/numbers.c (scm_rational_p): return #f for infinities and NaNs, per R6RS. Previously it returned #t for real infinities and NaNs. They are still considered real by scm_real `real?' however, per R6RS. * test-suite/tests/numbers.test: Add test cases for `rational?' and `real?' applied to infinities and NaNs. * doc/ref/api-data.texi (Real and Rational Numbers): Update docs to reflect that infinities and NaNs are irrational, and that `real?' no longer implies `rational?'. * NEWS: Add NEWS entries, and combine with an earlier entry about infinities no longer being integers. --- NEWS | 23 ++++++++++++++++++----- doc/ref/api-data.texi | 38 +++++++++++++++++++------------------- libguile/numbers.c | 20 +++++++++++++++----- test-suite/tests/numbers.test | 12 +++++++++++- 4 files changed, 63 insertions(+), 30 deletions(-) diff --git a/NEWS b/NEWS index 8153d0e..13d90a5 100644 --- a/NEWS +++ b/NEWS @@ -27,11 +27,6 @@ Previously, `(equal? +nan.0 +nan.0)' returned #f, although both returned #t. R5RS requires that `equal?' behave like `eqv?' when comparing numbers. -*** Infinities are no longer integers. - -Following the R6RS, infinities (+inf.0 and -inf.0) are no longer -considered to be integers. - *** `expt' and `integer-expt' changes when the base is 0 While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still @@ -40,6 +35,24 @@ integer-expt. This is more correct, and conforming to R6RS, but seems to be incompatible with R5RS, which would return 0 for all non-zero values of N. +*** Infinities are no longer integers, nor rationals + +scm_integer_p `integer?' and scm_rational_p `rational?' now return #f +for infinities, per R6RS. Previously they returned #t for real +infinities. The real infinities and NaNs are still considered real by +scm_real `real?' however, per R6RS. Note that non-real complex +numbers may contain infinities in their real or complex parts. Such +numbers are not real. + +*** NaNs are no longer rationals + +scm_rational_p `rational?' now returns #f for NaN values, per R6RS. +Previously it returned #t for real NaN values. They are still +considered real by scm_real `real?' however, per R6RS. Note that +non-real complex numbers may contain NaNs in their real or complex +parts. Such numbers are not real. In fact it is possible for a +non-real complex number to be both a NaN and infinite. + *** `inf?' and `nan?' now throw exceptions for non-numbers scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index f2a03b3..ce08584 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -491,11 +491,11 @@ All rational numbers are also real, but there are real numbers that are not rational, for example @m{\sqrt2, the square root of 2}, and @m{\pi,pi}. -Guile can represent both exact and inexact rational numbers, but it -can not represent irrational numbers. Exact rationals are represented -by storing the numerator and denominator as two exact integers. -Inexact rationals are stored as floating point numbers using the C -type @code{double}. +Guile can represent both exact and inexact rational numbers, but it can +not represent precise finite irrational numbers. Exact rationals are +represented by storing the numerator and denominator as two exact +integers. Inexact rationals are stored as floating point numbers using +the C type @code{double}. Exact rationals are written as a fraction of integers. There must be no whitespace around the slash: @@ -518,12 +518,13 @@ example: 4.0 @end lisp -The limited precision of Guile's encoding means that any ``real'' number -in Guile can be written in a rational form, by multiplying and then dividing -by sufficient powers of 10 (or in fact, 2). For example, -@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided by -100000000000000000. In Guile's current incarnation, therefore, the -@code{rational?} and @code{real?} predicates are equivalent. +The limited precision of Guile's encoding means that any finite ``real'' +number in Guile can be written in a rational form, by multiplying and +then dividing by sufficient powers of 10 (or in fact, 2). For example, +@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided +by 100000000000000000. In Guile's current incarnation, therefore, the +@code{rational?} and @code{real?} predicates are equivalent for finite +numbers. Dividing by an exact zero leads to a error message, as one might expect. @@ -542,12 +543,11 @@ is both @code{eqv?} and @code{equal?} to itself. The best way to test for them is by using @code{nan?}, which also detects complex numbers whose real or imaginary part is a @acronym{NaN}. -These special values are written @samp{+nan.0}, @samp{+inf.0} and -@samp{-inf.0}. This syntax is also recognized by @code{read} as an -extension to the usual Scheme syntax. The infinities are considered to -be inexact, non-integer values. @acronym{NaN} values are considered to -be inexact and irrational. To test for numbers that are neither -infinite nor a @acronym{NaN}, use @code{finite?}. +The real infinities and NaNs are written @samp{+nan.0}, @samp{+inf.0} +and @samp{-inf.0}. This syntax is also recognized by @code{read} as an +extension to the usual Scheme syntax. All three of these special values +are considered to be inexact, irrational reals. To test for numbers +that are neither infinite nor a @acronym{NaN}, use @code{finite?}. On platforms that follow @acronym{IEEE} 754 for their floating point arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values @@ -570,8 +570,8 @@ Note that the set of integer values forms a subset of the set of rational numbers, i. e. the predicate will also be fulfilled if @var{x} is an integer number. -Since Guile can not represent irrational numbers, every number -satisfying @code{real?} also satisfies @code{rational?} in Guile. +The only irrational real numbers representable by Guile are +@samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0}. @end deffn @deffn {Scheme Procedure} rationalize x eps diff --git a/libguile/numbers.c b/libguile/numbers.c index bfa6c22..bfe3699 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3292,8 +3292,18 @@ SCM_DEFINE (scm_real_p, "real?", 1, 0, 0, "fulfilled if @var{x} is an integer number.") #define FUNC_NAME s_scm_real_p { - /* we can't represent irrational numbers. */ - return scm_rational_p (x); + if (SCM_I_INUMP (x)) + return SCM_BOOL_T; + else if (SCM_IMP (x)) + return SCM_BOOL_F; + else if (SCM_BIGP (x)) + return SCM_BOOL_T; + else if (SCM_FRACTIONP (x)) + return SCM_BOOL_T; + else if (SCM_REALP (x)) + return SCM_BOOL_T; + else + return SCM_BOOL_F; } #undef FUNC_NAME @@ -3313,9 +3323,9 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0, return SCM_BOOL_T; else if (SCM_FRACTIONP (x)) return SCM_BOOL_T; - else if (SCM_REALP (x)) - /* due to their limited precision, all floating point numbers are - rational as well. */ + else if (SCM_REALP (x) && SCM_I_CDBL_IS_FINITE (SCM_REAL_VALUE (x))) + /* due to their limited precision, finite floating point numbers are + rational as well. (finite means neither infinity nor a NaN) */ return SCM_BOOL_T; else return SCM_BOOL_F; diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 2d20ef2..8851068 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1494,6 +1494,11 @@ (pass-if (real? (+ 1 fixnum-max))) (pass-if (real? (- 1 fixnum-min))) (pass-if (real? 1.3)) + (pass-if (real? +inf.0)) + (pass-if (real? -inf.0)) + (pass-if (real? +nan.0)) + (pass-if (not (real? +inf.0-inf.0i))) + (pass-if (not (real? +nan.0+nan.0i))) (pass-if (not (real? 3+4i))) (pass-if (not (real? #\a))) (pass-if (not (real? "a"))) @@ -1504,7 +1509,7 @@ (pass-if (not (real? (current-input-port))))) ;;; -;;; rational? (same as real? right now) +;;; rational? ;;; (with-test-prefix "rational?" @@ -1515,6 +1520,11 @@ (pass-if (rational? (+ 1 fixnum-max))) (pass-if (rational? (- 1 fixnum-min))) (pass-if (rational? 1.3)) + (pass-if (not (rational? +inf.0))) + (pass-if (not (rational? -inf.0))) + (pass-if (not (rational? +nan.0))) + (pass-if (not (rational? +inf.0-inf.0i))) + (pass-if (not (rational? +nan.0+nan.0i))) (pass-if (not (rational? 3+4i))) (pass-if (not (rational? #\a))) (pass-if (not (rational? "a"))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #14: Implement R6RS `real-valued?', `rational-valued?', `integer-valued?' --] [-- Type: text/x-diff, Size: 6369 bytes --] From f19e8cbcc17019279de6097158025ebd51a834e6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 07:28:01 -0500 Subject: [PATCH] Implement R6RS `real-valued?', `rational-valued?', `integer-valued?' * module/rnrs/base.scm (real-valued?, rational-valued?, integer-valued?): Implement in compliance with R6RS. * test-suite/tests/r6rs-base.test: Add test cases for `real-valued?', `rational-valued?', and `integer-valued?'. * NEWS: Add NEWS entries. --- NEWS | 4 ++ module/rnrs/base.scm | 19 +++++---- test-suite/tests/r6rs-base.test | 89 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 103 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index 13d90a5..56cf88d 100644 --- a/NEWS +++ b/NEWS @@ -80,6 +80,10 @@ by scheme, despite their name). throws exceptions for non-numbers. (Note that NaNs _are_ considered numbers by scheme, despite their name). +**** `real-valued?', `rational-valued?' and `integer-valued?' changes + +These predicates are now implemented in accordance with R6RS. + ** New reader option: `hungry-eol-escapes' Guile's string syntax is more compatible with R6RS when the diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index c7579c3..04a7e23 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -102,14 +102,17 @@ (define (exact-integer-sqrt x) (let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e))) - ;; These definitions should be revisited, since the behavior of Guile's - ;; implementations of `integer?', `rational?', and `real?' (exported from this - ;; library) is not entirely consistent with R6RS's requirements for those - ;; functions. - - (define integer-valued? integer?) - (define rational-valued? rational?) - (define real-valued? real?) + (define (real-valued? x) + (and (complex? x) + (zero? (imag-part x)))) + + (define (rational-valued? x) + (and (real-valued? x) + (rational? (real-part x)))) + + (define (integer-valued? x) + (and (rational-valued? x) + (= x (floor (real-part x))))) (define (vector-for-each proc . vecs) (apply for-each (cons proc (map vector->list vecs)))) diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test index a3603a1..1509b04 100644 --- a/test-suite/tests/r6rs-base.test +++ b/test-suite/tests/r6rs-base.test @@ -1,6 +1,6 @@ ;;; r6rs-base.test --- Test suite for R6RS (rnrs base) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -85,3 +85,90 @@ (pass-if "vector-map simple" (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3))))) +(with-test-prefix "real-valued?" + (pass-if (real-valued? +nan.0)) + (pass-if (real-valued? +nan.0+0i)) + (pass-if (real-valued? +nan.0+0.0i)) + (pass-if (real-valued? +inf.0)) + (pass-if (real-valued? -inf.0)) + (pass-if (real-valued? +inf.0+0.0i)) + (pass-if (real-valued? -inf.0-0.0i)) + (pass-if (real-valued? 3)) + (pass-if (real-valued? -2.5)) + (pass-if (real-valued? -2.5+0i)) + (pass-if (real-valued? -2.5+0.0i)) + (pass-if (real-valued? -2.5-0i)) + (pass-if (real-valued? #e1e10)) + (pass-if (real-valued? 1e200)) + (pass-if (real-valued? 1e200+0.0i)) + (pass-if (real-valued? 6/10)) + (pass-if (real-valued? 6/10+0.0i)) + (pass-if (real-valued? 6/10+0i)) + (pass-if (real-valued? 6/3)) + (pass-if (not (real-valued? 3+i))) + (pass-if (not (real-valued? -2.5+0.01i))) + (pass-if (not (real-valued? +nan.0+0.01i))) + (pass-if (not (real-valued? +nan.0+nan.0i))) + (pass-if (not (real-valued? +inf.0-0.01i))) + (pass-if (not (real-valued? +0.01i))) + (pass-if (not (real-valued? -inf.0i)))) + +(with-test-prefix "rational-valued?" + (pass-if (not (rational-valued? +nan.0))) + (pass-if (not (rational-valued? +nan.0+0i))) + (pass-if (not (rational-valued? +nan.0+0.0i))) + (pass-if (not (rational-valued? +inf.0))) + (pass-if (not (rational-valued? -inf.0))) + (pass-if (not (rational-valued? +inf.0+0.0i))) + (pass-if (not (rational-valued? -inf.0-0.0i))) + (pass-if (rational-valued? 3)) + (pass-if (rational-valued? -2.5)) + (pass-if (rational-valued? -2.5+0i)) + (pass-if (rational-valued? -2.5+0.0i)) + (pass-if (rational-valued? -2.5-0i)) + (pass-if (rational-valued? #e1e10)) + (pass-if (rational-valued? 1e200)) + (pass-if (rational-valued? 1e200+0.0i)) + (pass-if (rational-valued? 6/10)) + (pass-if (rational-valued? 6/10+0.0i)) + (pass-if (rational-valued? 6/10+0i)) + (pass-if (rational-valued? 6/3)) + (pass-if (not (rational-valued? 3+i))) + (pass-if (not (rational-valued? -2.5+0.01i))) + (pass-if (not (rational-valued? +nan.0+0.01i))) + (pass-if (not (rational-valued? +nan.0+nan.0i))) + (pass-if (not (rational-valued? +inf.0-0.01i))) + (pass-if (not (rational-valued? +0.01i))) + (pass-if (not (rational-valued? -inf.0i)))) + +(with-test-prefix "integer-valued?" + (pass-if (not (integer-valued? +nan.0))) + (pass-if (not (integer-valued? +nan.0+0i))) + (pass-if (not (integer-valued? +nan.0+0.0i))) + (pass-if (not (integer-valued? +inf.0))) + (pass-if (not (integer-valued? -inf.0))) + (pass-if (not (integer-valued? +inf.0+0.0i))) + (pass-if (not (integer-valued? -inf.0-0.0i))) + (pass-if (integer-valued? 3)) + (pass-if (integer-valued? 3.0)) + (pass-if (integer-valued? 3+0i)) + (pass-if (integer-valued? 3+0.0i)) + (pass-if (integer-valued? 8/4)) + (pass-if (integer-valued? #e1e10)) + (pass-if (integer-valued? 1e200)) + (pass-if (integer-valued? 1e200+0.0i)) + (pass-if (not (integer-valued? -2.5))) + (pass-if (not (integer-valued? -2.5+0i))) + (pass-if (not (integer-valued? -2.5+0.0i))) + (pass-if (not (integer-valued? -2.5-0i))) + (pass-if (not (integer-valued? 6/10))) + (pass-if (not (integer-valued? 6/10+0.0i))) + (pass-if (not (integer-valued? 6/10+0i))) + (pass-if (not (integer-valued? 3+i))) + (pass-if (not (integer-valued? -2.5+0.01i))) + (pass-if (not (integer-valued? +nan.0+0.01i))) + (pass-if (not (integer-valued? +nan.0+nan.0i))) + (pass-if (not (integer-valued? +inf.0-0.01i))) + (pass-if (not (integer-valued? +0.01i))) + (pass-if (not (integer-valued? -inf.0i)))) + -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #15: Fix R6RS `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0' --] [-- Type: text/x-diff, Size: 10255 bytes --] From c2afe44e9de376b7e3dc2f1f53fc18adbfe63552 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 07:37:32 -0500 Subject: [PATCH] Fix R6RS `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0' * module/rnrs/base.scm (div, mod, div-and-mod): Implement these properly (though admittedly inefficiently). Previously, `div' and `mod' were aliases of R5RS `quotient' and `modulo', although they have different semantics. R6RS `mod' is supposed to return a non-negative number less than the absolute value of the divisor, but R5RS `modulo' returns a number of the same sign as the divisor (or zero). R6RS `div' is supposed to return (floor (/ x y)), but R5RS `quotient' returns (truncate (/ x y)). For example, R6RS states that (div-and-mod 123 -10) should return -12 and 3, but previously it returned -12 and -7. (div0, mod0, div0-and-mod0): Implement these properly (though admittedly inefficiently). For example, R6RS states that (div0-and-mod0 123 -10) should return -12 and 3, but previously it returned -12 and -7. * test-suite/tests/r6rs-base.test: Add test cases for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * test-suite/tests/r6rs-arithmetic-fixnums.test: Remove incorrect tests, and add proper test cases for `fxdiv', `fxmod', `fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'. --- NEWS | 14 ++++ module/rnrs/base.scm | 27 +++++--- test-suite/tests/r6rs-arithmetic-fixnums.test | 82 +++++++++++++++++------- test-suite/tests/r6rs-base.test | 81 ++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 34 deletions(-) diff --git a/NEWS b/NEWS index 56cf88d..f2178f6 100644 --- a/NEWS +++ b/NEWS @@ -68,6 +68,20 @@ NaNs are neither finite nor infinite. *** R6RS base library changes +**** `div', `mod', and `div-and-mod' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). Previously, `div' and `mod' were aliases of R5RS +`quotient' and `modulo', although they have different semantics. +For example, R6RS states that (div-and-mod 123 -10) should return +-12 and 3, but previously it returned -12 and -7. + +**** `div0', `mod0', and `div0-and-mod0' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). R6RS states that (div0-and-mod0 123 -10) should +return -12 and 3, but previously it returned -12 and -7. + **** `infinite?' changes `infinite?' now returns #t for non-real complex infinities, and throws diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 04a7e23..f4f1c86 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -74,8 +74,6 @@ syntax-rules identifier-syntax) (import (rename (except (guile) error raise) - (quotient div) - (modulo mod) (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) @@ -119,20 +117,29 @@ (define (vector-map proc . vecs) (list->vector (apply map (cons proc (map vector->list vecs))))) - (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r))) + (define (div x y) + (cond ((positive? y) (floor (/ x y))) + ((negative? y) (ceiling (/ x y))) + (else (raise (make-assertion-violation))))) + + (define (mod x y) + (- x (* y (div x y)))) + + (define (div-and-mod x y) + (let ((q (div x y))) + (values q (- x (* y q))))) (define (div0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q))) + (cond ((positive? y) (floor (+ 1/2 (/ x y)))) + ((negative? y) (ceiling (+ -1/2 (/ x y)))) + (else (raise (make-assertion-violation))))) (define (mod0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r))) + (- x (* y (div0 x y)))) (define (div0-and-mod0 x y) - (call-with-values (lambda () (div-and-mod x y)) - (lambda (q r) - (cond ((< r (abs (/ y 2))) (values q r)) - ((negative? y) (values (- q 1) (+ r y))) - (else (values (+ q 1) (+ r y))))))) + (let ((q (div0 x y))) + (values q (- x (* y q))))) (define raise (@ (rnrs exceptions) raise)) diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index fed72eb..4bf20a9 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -1,6 +1,6 @@ ;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -118,35 +118,69 @@ (fx- (least-fixnum) 1)))) (with-test-prefix "fxdiv-and-mod" - (pass-if "simple" - (call-with-values (lambda () (fxdiv-and-mod 123 10)) - (lambda (d m) - (or (and (fx=? d 12) (fx=? m 3)) - (throw 'unresolved)))))) - -(with-test-prefix "fxdiv" - (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved)))) - -(with-test-prefix "fxmod" - (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved)))) + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -13 7 ) + (-123 -10 13 7 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 )))) + (pass-if "fxdiv-and-mod" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (fxdiv-and-mod x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (fxdiv x y)) + (eqv? r (fxmod x y)) + (>= r 0) + (< r (abs y)) + (fx=? x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) (with-test-prefix "fxdiv0-and-mod0" - (pass-if "simple" - (call-with-values (lambda () (fxdiv0-and-mod0 -123 10)) - (lambda (d m) - (or (and (fx=? d 12) (fx=? m -3)) - (throw 'unresolved)))))) - -(with-test-prefix "fxdiv0" - (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved)))) - -(with-test-prefix "fxmod0" - (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved)))) - + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -12 -3 ) + (-123 -10 12 -3 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 )))) + (pass-if "fxdiv0-and-mod0" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (fxdiv0-and-mod0 x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (fxdiv0 x y)) + (eqv? r (fxmod0 x y)) + (>= r (* -1/2 (abs y))) + (< r (* 1/2 (abs y))) + (fx=? x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) ;; Without working div and mod implementations and without any example results ;; from the spec, I have no idea what the results of these functions should ;; be. -juliang +;; UPDATE: div and mod implementations are now working properly -mhw (with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved))) diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test index 1509b04..7a5895a 100644 --- a/test-suite/tests/r6rs-base.test +++ b/test-suite/tests/r6rs-base.test @@ -172,3 +172,84 @@ (pass-if (not (integer-valued? +0.01i))) (pass-if (not (integer-valued? -inf.0i)))) +(with-test-prefix "div-and-mod" + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -13 7 ) + (-123 -10 13 7 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 ) + ( 8.5 4 2.0 0.5 ) + ( 8.5 -4 -2.0 0.5 ) + (-8.5 4 -3.0 3.5 ) + (-8.5 -4 3.0 3.5 ) + ( 8.75 4.5 1.0 4.25 ) + ( 8.75 -4.5 -1.0 4.25 ) + (-8.75 4.5 -2.0 0.25 ) + (-8.75 -4.5 2.0 0.25 ) + ( 8.875 4.5 1.0 4.375) + ( 9 4.5 2.0 0.0 ) + ( 9.125 4.5 2.0 0.125)))) + (pass-if "div-and-mod" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (div-and-mod x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (div x y)) + (eqv? r (mod x y)) + (>= r 0) + (< r (abs y)) + (= x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) + +(with-test-prefix "div0-and-mod0" + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -12 -3 ) + (-123 -10 12 -3 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 ) + ( 8.5 4 2.0 0.5 ) + ( 8.5 -4 -2.0 0.5 ) + (-8.5 4 -2.0 -0.5 ) + (-8.5 -4 2.0 -0.5 ) + ( 8.75 4.5 2.0 -0.25 ) + ( 8.75 -4.5 -2.0 -0.25 ) + (-8.75 4.5 -2.0 0.25 ) + (-8.75 -4.5 2.0 0.25 ) + ( 6.875 4.5 2.0 -2.125) + ( 6.75 4.5 2.0 -2.25 ) + ( 6.625 4.5 1.0 2.125)))) + (pass-if "div0-and-mod0" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (div0-and-mod0 x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (div0 x y)) + (eqv? r (mod0 x y)) + (>= r (* -1/2 (abs y))) + (< r (* 1/2 (abs y))) + (= x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #16: `even?' and `odd?' now throw exceptions only for non-numbers --] [-- Type: text/x-diff, Size: 4595 bytes --] From 3191ee86de3330b4bdbd39041743df0dcbdec924 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 16:47:13 -0500 Subject: [PATCH] `even?' and `odd?' now throw exceptions only for non-numbers * libguile/numbers.c (scm_even_p, scm_odd_p): Throw exceptions only when applied to non-number objects, per R5RS. Previously threw exceptions for non-integers. (Note that NaNs _are_ considered numbers by scheme, despite their name). * test-suite/tests/numbers.test: Add more test cases for `even?' and `odd?'. * NEWS: Add NEWS entry. --- NEWS | 7 +++++++ libguile/numbers.c | 30 ++++++++++++++++++------------ test-suite/tests/numbers.test | 28 ++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 12 deletions(-) diff --git a/NEWS b/NEWS index f2178f6..194ff7a 100644 --- a/NEWS +++ b/NEWS @@ -53,6 +53,13 @@ non-real complex numbers may contain NaNs in their real or complex parts. Such numbers are not real. In fact it is possible for a non-real complex number to be both a NaN and infinite. +*** `even?' and `odd?' now throw exceptions for non-numbers only + +scm_even_p `even?' and scm_odd_p `odd?' now throw exceptions only if +passed non-number objects, per R5RS. Previously, they threw +exceptions for non-integers. (Note that NaNs _are_ considered numbers +by scheme, despite their name). + *** `inf?' and `nan?' now throw exceptions for non-numbers scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed diff --git a/libguile/numbers.c b/libguile/numbers.c index bfe3699..32e50c7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -546,18 +546,21 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0, scm_remember_upto_here_1 (n); return scm_from_bool (odd_p); } - else if (scm_is_true (scm_inf_p (n))) - SCM_WRONG_TYPE_ARG (1, n); else if (SCM_REALP (n)) { - double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); + double val = SCM_REAL_VALUE (n); + double rem; + + if (!SCM_I_CDBL_IS_FINITE (val)) + return SCM_BOOL_F; + rem = fabs (fmod (val, 2.0)); if (rem == 1.0) return SCM_BOOL_T; - else if (rem == 0.0) - return SCM_BOOL_F; else - SCM_WRONG_TYPE_ARG (1, n); + return SCM_BOOL_F; } + else if (SCM_NUMBERP (n)) + return SCM_BOOL_F; else SCM_WRONG_TYPE_ARG (1, n); } @@ -581,18 +584,21 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, scm_remember_upto_here_1 (n); return scm_from_bool (even_p); } - else if (scm_is_true (scm_inf_p (n))) - SCM_WRONG_TYPE_ARG (1, n); else if (SCM_REALP (n)) { - double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0)); - if (rem == 1.0) + double val = SCM_REAL_VALUE (n); + double rem; + + if (!SCM_I_CDBL_IS_FINITE (val)) return SCM_BOOL_F; - else if (rem == 0.0) + rem = fabs (fmod (val, 2.0)); + if (rem == 0.0) return SCM_BOOL_T; else - SCM_WRONG_TYPE_ARG (1, n); + return SCM_BOOL_F; } + else if (SCM_NUMBERP (n)) + return SCM_BOOL_F; else SCM_WRONG_TYPE_ARG (1, n); } diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 8851068..7a0510e 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -287,6 +287,20 @@ (pass-if (not (odd? 0))) (pass-if (not (odd? 2))) (pass-if (not (odd? -2))) + (pass-if (odd? 43)) + (pass-if (odd? 43.0)) + (pass-if (odd? -43)) + (pass-if (odd? -43.0)) + (pass-if (not (odd? 1/2))) + (pass-if (not (odd? -42))) + (pass-if (not (odd? -42.0))) + (pass-if (not (odd? 42))) + (pass-if (not (odd? 42.0))) + (pass-if (not (odd? 43.1))) + (pass-if (not (odd? 43.0+1.0i))) + (pass-if (not (odd? +inf.0))) + (pass-if (not (odd? -inf.0))) + (pass-if (not (odd? +nan.0))) (pass-if (odd? (+ (* 2 fixnum-max) 1))) (pass-if (not (odd? (* 2 fixnum-max)))) (pass-if (odd? (- (* 2 fixnum-min) 1))) @@ -301,6 +315,20 @@ (pass-if (even? 2)) (pass-if (even? -2)) (pass-if (even? 0)) + (pass-if (even? 42)) + (pass-if (even? 42.0)) + (pass-if (even? -42)) + (pass-if (even? -42.0)) + (pass-if (not (even? 1/2))) + (pass-if (not (even? -43))) + (pass-if (not (even? -43.0))) + (pass-if (not (even? 43))) + (pass-if (not (even? 43.0))) + (pass-if (not (even? 42.1))) + (pass-if (not (even? 42.0+1.0i))) + (pass-if (not (even? +inf.0))) + (pass-if (not (even? -inf.0))) + (pass-if (not (even? +nan.0))) (pass-if (not (even? 1))) (pass-if (not (even? -1))) (pass-if (not (even? (+ (* 2 fixnum-max) 1)))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #17: Fix bugs in `rationalize' --] [-- Type: text/x-diff, Size: 6546 bytes --] From 2eee540e595d5ca03ae11560c14ff861a404e304 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 08:18:12 -0500 Subject: [PATCH] Fix bugs in `rationalize' * libguile/numbers.c (scm_rationalize): Fix bugs. Previously, it returned exact integers unmodified, although that was incorrect if the epsilon was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per R5RS and R6RS, but previously it returned 4. Also handle cases involving infinities and NaNs properly, per R6RS. * test-suite/tests/numbers.test: Add test cases for `rationalize'. * NEWS: Add NEWS entry --- NEWS | 8 ++++++ libguile/numbers.c | 52 +++++++++++++++++++++++++++++++--------- test-suite/tests/numbers.test | 46 ++++++++++++++++++++++++++++++++++++ 3 files changed, 94 insertions(+), 12 deletions(-) diff --git a/NEWS b/NEWS index 194ff7a..b8ffca0 100644 --- a/NEWS +++ b/NEWS @@ -66,6 +66,14 @@ scm_inf_p `inf?' and scm_nan_p `nan?' now throw exceptions if passed non-number objects. Previously they returned #f. (Note that NaNs _are_ considered numbers by scheme, despite their name). +*** `rationalize' bugfixes and changes + +Fixed bugs in scm_rationalize `rationalize'. Previously, it returned +exact integers unmodified, although that was incorrect if the epsilon +was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per +R5RS and R6RS, but previously it returned 4. It also now handles +cases involving infinities and NaNs properly, per R6RS. + *** New procedure: `finite?' Add scm_finite_p `finite?' from R6RS to guile core, which returns #t diff --git a/libguile/numbers.c b/libguile/numbers.c index 32e50c7..fb680a2 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -6090,11 +6090,46 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_rationalize { - if (SCM_I_INUMP (x)) - return x; - else if (SCM_BIGP (x)) + SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real"); + SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real"); + eps = scm_abs (eps); + if (scm_is_false (scm_positive_p (eps))) + { + /* eps is either zero or a NaN */ + if (scm_is_true (scm_nan_p (eps))) + return scm_nan (); + else if (SCM_INEXACTP (eps)) + return scm_exact_to_inexact (x); + else + return x; + } + else if (scm_is_false (scm_finite_p (eps))) + { + if (scm_is_true (scm_finite_p (x))) + return flo0; + else + return scm_nan (); + } + else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */ return x; - else if ((SCM_REALP (x)) || SCM_FRACTIONP (x)) + else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)), + scm_ceiling (scm_difference (x, eps))))) + { + /* There's an integer within range; we want the one closest to zero */ + if (scm_is_false (scm_less_p (eps, scm_abs (x)))) + { + /* zero is within range */ + if (SCM_INEXACTP (x) || SCM_INEXACTP (eps)) + return flo0; + else + return SCM_INUM0; + } + else if (scm_is_true (scm_positive_p (x))) + return scm_ceiling (scm_difference (x, eps)); + else + return scm_floor (scm_sum (x, eps)); + } + else { /* Use continued fractions to find closest ratio. All arithmetic is done with exact numbers. @@ -6108,9 +6143,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, SCM rx; int i = 0; - if (scm_is_true (scm_num_eq_p (ex, int_part))) - return ex; - ex = scm_difference (ex, int_part); /* x = x-int_part */ rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */ @@ -6119,7 +6151,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, converges after less than a dozen iterations. */ - eps = scm_abs (eps); while (++i < 1000000) { a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */ @@ -6130,8 +6161,7 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, eps))) /* abs(x-a/b) <= eps */ { SCM res = scm_sum (int_part, scm_divide (a, b)); - if (scm_is_false (scm_exact_p (x)) - || scm_is_false (scm_exact_p (eps))) + if (SCM_INEXACTP (x) || SCM_INEXACTP (eps)) return scm_exact_to_inexact (res); else return res; @@ -6146,8 +6176,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, } scm_num_overflow (s_scm_rationalize); } - else - SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 7a0510e..07d58c8 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1324,6 +1324,52 @@ (pass-if (= lcm-of-big-n-and-11 (lcm 11 big-n 11))))) ;;; +;;; rationalize +;;; +(with-test-prefix "rationalize" + (pass-if (documented? rationalize)) + (pass-if (eqv? 2 (rationalize 4 2 ))) + (pass-if (eqv? -2 (rationalize -4 2 ))) + (pass-if (eqv? 2.0 (rationalize 4 2.0))) + (pass-if (eqv? -2.0 (rationalize -4.0 2 ))) + + (pass-if (eqv? 0 (rationalize 4 8 ))) + (pass-if (eqv? 0 (rationalize -4 8 ))) + (pass-if (eqv? 0.0 (rationalize 4 8.0))) + (pass-if (eqv? 0.0 (rationalize -4.0 8 ))) + + (pass-if (eqv? 0.0 (rationalize 3 +inf.0))) + (pass-if (eqv? 0.0 (rationalize -3 +inf.0))) + + (pass-if (nan? (rationalize +inf.0 +inf.0))) + (pass-if (nan? (rationalize +nan.0 +inf.0))) + (pass-if (nan? (rationalize +nan.0 4))) + (pass-if (eqv? +inf.0 (rationalize +inf.0 3))) + + (pass-if (eqv? 3/10 (rationalize 3/10 0))) + (pass-if (eqv? -3/10 (rationalize -3/10 0))) + + (pass-if (eqv? 1/3 (rationalize 3/10 1/10))) + (pass-if (eqv? -1/3 (rationalize -3/10 1/10))) + + (pass-if (eqv? 1/3 (rationalize 3/10 -1/10))) + (pass-if (eqv? -1/3 (rationalize -3/10 -1/10))) + + (pass-if (let ((ans (rationalize 0.3 1/10))) + (and (eqv-loosely? ans 0.3333) + (inexact? ans)))) + (pass-if (let ((ans (rationalize -0.3 1/10))) + (and (eqv-loosely? ans -0.3333) + (inexact? ans)))) + + (pass-if (let ((ans (rationalize 0.3 -1/10))) + (and (eqv-loosely? ans 0.3333) + (inexact? ans)))) + (pass-if (let ((ans (rationalize -0.3 -1/10))) + (and (eqv-loosely? ans -0.3333) + (inexact? ans))))) + +;;; ;;; number->string ;;; -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #18: More discriminating NaN predicates for numbers.test --] [-- Type: text/x-diff, Size: 7561 bytes --] From a584b5d029e74c6510a5f0bf4a2198d2e0f4d68b Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 08:54:19 -0500 Subject: [PATCH] More discriminating NaN predicates for numbers.test * test-suite/tests/numbers.test: (real-nan?, complex-nan?, imaginary-nan?): Add more discriminating NaN testing predicates internal to numbers.test, and convert several uses of `nan?' to use these instead: * `real-nan?' checks that its argument is real and a NaN. * `complex-nan?' checks that both the real and imaginary parts of its argument are NaNs. * `imaginary-nan?' checks that its argument's real part is zero and the imaginary part is a NaN. --- test-suite/tests/numbers.test | 73 +++++++++++++++++++++++++---------------- 1 files changed, 45 insertions(+), 28 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 07d58c8..195c8fd 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -92,6 +92,23 @@ (negative? obj) (inf? obj))) +;; return true if OBJ is a real NaN +(define (real-nan? obj) + (and (real? obj) + (nan? obj))) + +;; return true if both the real and imaginary +;; parts of OBJ are NaNs +(define (complex-nan? obj) + (and (nan? (real-part obj)) + (nan? (imag-part obj)))) + +;; return true if the real part of OBJ is zero +;; and the imaginary part is a NaN. +(define (imaginary-nan? obj) + (and (zero? (real-part obj)) + (nan? (imag-part obj)))) + (define const-e 2.7182818284590452354) (define const-e^2 7.3890560989306502274) (define const-1/e 0.3678794411714423215) @@ -404,7 +421,7 @@ (pass-if (= 0.0 (abs 0.0))) (pass-if (= 1.0 (abs 1.0))) (pass-if (= 1.0 (abs -1.0))) - (pass-if (nan? (abs +nan.0))) + (pass-if (real-nan? (abs +nan.0))) (pass-if (= +inf.0 (abs +inf.0))) (pass-if (= +inf.0 (abs -inf.0)))) @@ -1341,9 +1358,9 @@ (pass-if (eqv? 0.0 (rationalize 3 +inf.0))) (pass-if (eqv? 0.0 (rationalize -3 +inf.0))) - (pass-if (nan? (rationalize +inf.0 +inf.0))) - (pass-if (nan? (rationalize +nan.0 +inf.0))) - (pass-if (nan? (rationalize +nan.0 4))) + (pass-if (real-nan? (rationalize +inf.0 +inf.0))) + (pass-if (real-nan? (rationalize +nan.0 +inf.0))) + (pass-if (real-nan? (rationalize +nan.0 4))) (pass-if (eqv? +inf.0 (rationalize +inf.0 3))) (pass-if (eqv? 3/10 (rationalize 3/10 0))) @@ -2466,10 +2483,10 @@ (pass-if (= 5/2 (max 5/2 2)))) (with-test-prefix "inum / real" - (pass-if (nan? (max 123 +nan.0)))) + (pass-if (real-nan? (max 123 +nan.0)))) (with-test-prefix "real / inum" - (pass-if (nan? (max +nan.0 123)))) + (pass-if (real-nan? (max +nan.0 123)))) (with-test-prefix "big / frac" (pass-if (= big*2 (max big*2 5/2))) @@ -2480,14 +2497,14 @@ (pass-if (= 5/2 (max 5/2 (- big*2))))) (with-test-prefix "big / real" - (pass-if (nan? (max big*5 +nan.0))) + (pass-if (real-nan? (max big*5 +nan.0))) (pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0))) (pass-if (eqv? (exact->inexact big*5) (max big*5 1.0))) (pass-if (eqv? +inf.0 (max big*5 +inf.0))) (pass-if (eqv? 1.0 (max (- big*5) 1.0)))) (with-test-prefix "real / big" - (pass-if (nan? (max +nan.0 big*5))) + (pass-if (real-nan? (max +nan.0 big*5))) (pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5))) (pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5))) (pass-if (eqv? +inf.0 (max +inf.0 big*5))) @@ -2500,9 +2517,9 @@ (pass-if (= -1/2 (max -2/3 -1/2)))) (with-test-prefix "real / real" - (pass-if (nan? (max 123.0 +nan.0))) - (pass-if (nan? (max +nan.0 123.0))) - (pass-if (nan? (max +nan.0 +nan.0))) + (pass-if (real-nan? (max 123.0 +nan.0))) + (pass-if (real-nan? (max +nan.0 123.0))) + (pass-if (real-nan? (max +nan.0 +nan.0))) (pass-if (= 456.0 (max 123.0 456.0))) (pass-if (= 456.0 (max 456.0 123.0))))) @@ -2526,8 +2543,8 @@ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make ;; sure we've avoided that - (pass-if (nan? (max (ash 1 2048) +nan.0))) - (pass-if (nan? (max +nan.0 (ash 1 2048))))) + (pass-if (real-nan? (max (ash 1 2048) +nan.0))) + (pass-if (real-nan? (max +nan.0 (ash 1 2048))))) ;;; ;;; min @@ -2591,10 +2608,10 @@ (pass-if (= 2 (min 5/2 2)))) (with-test-prefix "inum / real" - (pass-if (nan? (min 123 +nan.0)))) + (pass-if (real-nan? (min 123 +nan.0)))) (with-test-prefix "real / inum" - (pass-if (nan? (min +nan.0 123)))) + (pass-if (real-nan? (min +nan.0 123)))) (with-test-prefix "big / frac" (pass-if (= 5/2 (min big*2 5/2))) @@ -2605,14 +2622,14 @@ (pass-if (= (- big*2) (min 5/2 (- big*2))))) (with-test-prefix "big / real" - (pass-if (nan? (min big*5 +nan.0))) + (pass-if (real-nan? (min big*5 +nan.0))) (pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0))) (pass-if (eqv? -inf.0 (min big*5 -inf.0))) (pass-if (eqv? 1.0 (min big*5 1.0))) (pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0)))) (with-test-prefix "real / big" - (pass-if (nan? (min +nan.0 big*5))) + (pass-if (real-nan? (min +nan.0 big*5))) (pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5))) (pass-if (eqv? -inf.0 (min -inf.0 big*5))) (pass-if (eqv? 1.0 (min 1.0 big*5))) @@ -2625,9 +2642,9 @@ (pass-if (= -2/3 (min -2/3 -1/2)))) (with-test-prefix "real / real" - (pass-if (nan? (min 123.0 +nan.0))) - (pass-if (nan? (min +nan.0 123.0))) - (pass-if (nan? (min +nan.0 +nan.0))) + (pass-if (real-nan? (min 123.0 +nan.0))) + (pass-if (real-nan? (min +nan.0 123.0))) + (pass-if (real-nan? (min +nan.0 +nan.0))) (pass-if (= 123.0 (min 123.0 456.0))) (pass-if (= 123.0 (min 456.0 123.0))))) @@ -2652,8 +2669,8 @@ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make ;; sure we've avoided that - (pass-if (nan? (min (- (ash 1 2048)) (- +nan.0)))) - (pass-if (nan? (min (- +nan.0) (- (ash 1 2048)))))) + (pass-if (real-nan? (min (- (ash 1 2048)) (- +nan.0)))) + (pass-if (real-nan? (min (- +nan.0) (- (ash 1 2048)))))) ;;; ;;; + @@ -3156,10 +3173,10 @@ (pass-if (eqv? 1 (expt 0.0 0))) (pass-if (eqv? 1.0 (expt 0 0.0))) (pass-if (eqv? 1.0 (expt 0.0 0.0))) - (pass-if (nan? (expt 0 -1))) - (pass-if (nan? (expt 0 -1.0))) - (pass-if (nan? (expt 0.0 -1))) - (pass-if (nan? (expt 0.0 -1.0))) + (pass-if (real-nan? (expt 0 -1))) + (pass-if (real-nan? (expt 0 -1.0))) + (pass-if (real-nan? (expt 0.0 -1))) + (pass-if (real-nan? (expt 0.0 -1.0))) (pass-if (eqv? 0 (expt 0 3))) (pass-if (= 0 (expt 0 4.0))) (pass-if (eqv? 0.0 (expt 0.0 5))) @@ -3307,8 +3324,8 @@ (pass-if (eqv? 1 (integer-expt 0 0))) (pass-if (eqv? 1 (integer-expt 0.0 0))) - (pass-if (nan? (integer-expt 0 -1))) - (pass-if (nan? (integer-expt 0.0 -1))) + (pass-if (real-nan? (integer-expt 0 -1))) + (pass-if (real-nan? (integer-expt 0.0 -1))) (pass-if (eqv? 0 (integer-expt 0 3))) (pass-if (eqv? 0.0 (integer-expt 0.0 5))) (pass-if (eqv? -2742638075.5 (integer-expt -2742638075.5 1))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #19: Exact 0 times infinity or a NaN yields a NaN --] [-- Type: text/x-diff, Size: 8628 bytes --] From 6f8853937fb85f09505d14c1e682e5ec4d5f1bef Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 16:01:21 -0500 Subject: [PATCH] Exact 0 times infinity or a NaN yields a NaN * libguile/numbers.c (scm_product): Handle exact 0 differently. A product containing an exact 0 now returns an exact 0 if and only if the other arguments are all finite, otherwise a NaN is returned. * test-suite/tests/numbers.test: Add many multiplication tests. * NEWS: Add NEWS entry. --- NEWS | 6 ++ libguile/numbers.c | 41 +++++++++------ test-suite/tests/numbers.test | 109 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 139 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index b8ffca0..9c1f32f 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,12 @@ Previously, `(equal? +nan.0 +nan.0)' returned #f, although both returned #t. R5RS requires that `equal?' behave like `eqv?' when comparing numbers. +*** Change in handling products `*' involving exact 0 + +scm_product `*' now handles exact 0 differently. A product containing +an exact 0 now returns an exact 0 if and only if the other arguments +are all finite, otherwise a NaN value is returned. + *** `expt' and `integer-expt' changes when the base is 0 While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still diff --git a/libguile/numbers.c b/libguile/numbers.c index fb680a2..9ff8e41 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4710,13 +4710,25 @@ scm_product (SCM x, SCM y) { scm_t_inum xx; - intbig: + xinum: xx = SCM_I_INUM (x); switch (xx) { - case 0: return x; break; - case 1: return y; break; + case 0: + /* exact0 times any finite number is exact0 */ + if (SCM_LIKELY (SCM_I_INUMP (y))) /* optimize this case */ + return x; + else if (SCM_LIKELY (scm_is_true (scm_finite_p (y)))) + return x; + else + return scm_make_rectangular + (scm_is_true (scm_finite_p (scm_real_part (y))) ? x : scm_nan(), + scm_is_true (scm_finite_p (scm_imag_part (y))) ? x : scm_nan()); + break; + case 1: + return y; + break; /* * The following case (x = -1) is important for more than * just optimization. It handles the case of negating @@ -4767,7 +4779,7 @@ scm_product (SCM x, SCM y) if (SCM_I_INUMP (y)) { SCM_SWAP (x, y); - goto intbig; + goto xinum; } else if (SCM_BIGP (y)) { @@ -4800,12 +4812,10 @@ scm_product (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - { - /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ - if (scm_is_eq (y, SCM_INUM0)) - return y; - return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); - } + { + SCM_SWAP (x, y); + goto xinum; + } else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); @@ -4825,13 +4835,10 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - { - /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ - if (scm_is_eq (y, SCM_INUM0)) - return y; - return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); - } + { + SCM_SWAP (x, y); + goto xinum; + } else if (SCM_BIGP (y)) { double z = mpz_get_d (SCM_I_BIG_MPZ (y)); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 195c8fd..e812658 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2749,6 +2749,115 @@ (pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1))) (pass-if (equal? fixnum-min (* (* fixnum-min -1) -1)))) + (with-test-prefix "exactness propagation" + (pass-if (eqv? 0 (* 0 -1.0 ))) + (pass-if (eqv? 0 (* 0 1.0 ))) + (pass-if (eqv? 0 (* -1.0 0 ))) + (pass-if (eqv? 0 (* 1.0 0 ))) + (pass-if (eqv? 0 (* 0 1/2 ))) + (pass-if (eqv? 0 (* 1/2 0 ))) + (pass-if (eqv? 0 (* 0 1+i ))) + (pass-if (eqv? 0 (* 1+i 0 ))) + (pass-if (eqv? -1.0 (* 1 -1.0 ))) + (pass-if (eqv? 1.0 (* 1 1.0 ))) + (pass-if (eqv? -1.0 (* -1.0 1 ))) + (pass-if (eqv? 1.0 (* 1.0 1 ))) + (pass-if (eqv? 1/2 (* 1 1/2 ))) + (pass-if (eqv? 1/2 (* 1/2 1 ))) + (pass-if (eqv? 1+i (* 1 1+i ))) + (pass-if (eqv? 1+i (* 1+i 1 )))) + + (with-test-prefix "propagation of NaNs" + (pass-if (real-nan? (* +nan.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 1 ))) + (pass-if (real-nan? (* +nan.0 -1 ))) + (pass-if (real-nan? (* +nan.0 -7/2 ))) + (pass-if (real-nan? (* +nan.0 1e20 ))) + (pass-if (real-nan? (* 1 +nan.0))) + (pass-if (real-nan? (* -1 +nan.0))) + (pass-if (real-nan? (* -7/2 +nan.0))) + (pass-if (real-nan? (* 1e20 +nan.0))) + (pass-if (real-nan? (* +inf.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 +inf.0))) + (pass-if (real-nan? (* -inf.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 -inf.0))) + (pass-if (real-nan? (* (* fixnum-max 2) +nan.0))) + (pass-if (real-nan? (* +nan.0 (* fixnum-max 2)))) + + (pass-if (real-nan? (* 0 +nan.0 ))) + (pass-if (real-nan? (* +nan.0 0 ))) + (pass-if (real-nan? (* 0 +nan.0+i))) + (pass-if (real-nan? (* +nan.0+i 0 ))) + + (pass-if (imaginary-nan? (* 0 +nan.0i ))) + (pass-if (imaginary-nan? (* +nan.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1+nan.0i ))) + (pass-if (imaginary-nan? (* 1+nan.0i 0 ))) + + (pass-if (complex-nan? (* 0 +nan.0+nan.0i ))) + (pass-if (complex-nan? (* +nan.0+nan.0i 0 )))) + + (with-test-prefix "infinities" + (pass-if (eqv? +inf.0 (* +inf.0 5 ))) + (pass-if (eqv? -inf.0 (* +inf.0 -5 ))) + (pass-if (eqv? +inf.0 (* +inf.0 73.1))) + (pass-if (eqv? -inf.0 (* +inf.0 -9.2))) + (pass-if (eqv? +inf.0 (* +inf.0 5/2))) + (pass-if (eqv? -inf.0 (* +inf.0 -5/2))) + (pass-if (eqv? -inf.0 (* -5 +inf.0))) + (pass-if (eqv? +inf.0 (* 73.1 +inf.0))) + (pass-if (eqv? -inf.0 (* -9.2 +inf.0))) + (pass-if (eqv? +inf.0 (* 5/2 +inf.0))) + (pass-if (eqv? -inf.0 (* -5/2 +inf.0))) + + (pass-if (eqv? -inf.0 (* -inf.0 5 ))) + (pass-if (eqv? +inf.0 (* -inf.0 -5 ))) + (pass-if (eqv? -inf.0 (* -inf.0 73.1))) + (pass-if (eqv? +inf.0 (* -inf.0 -9.2))) + (pass-if (eqv? -inf.0 (* -inf.0 5/2))) + (pass-if (eqv? +inf.0 (* -inf.0 -5/2))) + (pass-if (eqv? +inf.0 (* -5 -inf.0))) + (pass-if (eqv? -inf.0 (* 73.1 -inf.0))) + (pass-if (eqv? +inf.0 (* -9.2 -inf.0))) + (pass-if (eqv? -inf.0 (* 5/2 -inf.0))) + (pass-if (eqv? +inf.0 (* -5/2 -inf.0))) + + (pass-if (real-nan? (* 0.0 +inf.0))) + (pass-if (real-nan? (* -0.0 +inf.0))) + (pass-if (real-nan? (* +inf.0 0.0))) + (pass-if (real-nan? (* +inf.0 -0.0))) + + (pass-if (real-nan? (* 0.0 -inf.0))) + (pass-if (real-nan? (* -0.0 -inf.0))) + (pass-if (real-nan? (* -inf.0 0.0))) + (pass-if (real-nan? (* -inf.0 -0.0))) + + (pass-if (real-nan? (* 0 +inf.0 ))) + (pass-if (real-nan? (* +inf.0 0 ))) + (pass-if (real-nan? (* 0 +inf.0+i))) + (pass-if (real-nan? (* +inf.0+i 0 ))) + + (pass-if (real-nan? (* 0 -inf.0 ))) + (pass-if (real-nan? (* -inf.0 0 ))) + (pass-if (real-nan? (* 0 -inf.0+i))) + (pass-if (real-nan? (* -inf.0+i 0 ))) + + (pass-if (imaginary-nan? (* 0 +inf.0i ))) + (pass-if (imaginary-nan? (* +inf.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1+inf.0i ))) + (pass-if (imaginary-nan? (* 1+inf.0i 0 ))) + + (pass-if (imaginary-nan? (* 0 -inf.0i ))) + (pass-if (imaginary-nan? (* -inf.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1-inf.0i ))) + (pass-if (imaginary-nan? (* 1-inf.0i 0 ))) + + (pass-if (complex-nan? (* 0 +inf.0+inf.0i ))) + (pass-if (complex-nan? (* +inf.0+inf.0i 0 ))) + + (pass-if (complex-nan? (* 0 +inf.0-inf.0i ))) + (pass-if (complex-nan? (* -inf.0+inf.0i 0 )))) + (with-test-prefix "inum * bignum" (pass-if "0 * 2^256 = 0" -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #20: Move comment about trig functions back where it belongs --] [-- Type: text/x-diff, Size: 1591 bytes --] From 85ab40130e7b48ecccd47b3b37c11385a4560691 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 15:13:29 -0500 Subject: [PATCH] Move comment about trig functions back where it belongs * libguile/numbers.c: Move a comment about the trigonometric functions next to those functions. At some point they became separated, when scm_expt was placed between them. --- libguile/numbers.c | 12 ++++++------ 1 files changed, 6 insertions(+), 6 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9ff8e41..480d326 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5495,12 +5495,6 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, } #undef FUNC_NAME -/* sin/cos/tan/asin/acos/atan - sinh/cosh/tanh/asinh/acosh/atanh - Derived from "Transcen.scm", Complex trancendental functions for SCM. - Written by Jerry D. Hedden, (C) FSF. - See the file `COPYING' for terms applying to this program. */ - SCM_DEFINE (scm_expt, "expt", 2, 0, 0, (SCM x, SCM y), "Return @var{x} raised to the power of @var{y}.") @@ -5538,6 +5532,12 @@ SCM_DEFINE (scm_expt, "expt", 2, 0, 0, } #undef FUNC_NAME +/* sin/cos/tan/asin/acos/atan + sinh/cosh/tanh/asinh/acosh/atanh + Derived from "Transcen.scm", Complex trancendental functions for SCM. + Written by Jerry D. Hedden, (C) FSF. + See the file `COPYING' for terms applying to this program. */ + SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0, (SCM z), "Compute the sine of @var{z}.") -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #21: Trigonometric functions return exact numbers in some cases --] [-- Type: text/x-diff, Size: 9503 bytes --] From 36d2e4ced3d15947524a8766c8ca0008ced6fd5b Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Wed, 26 Jan 2011 15:18:40 -0500 Subject: [PATCH] Trigonometric functions return exact numbers in some cases * libguile/numbers.c (scm_sin, scm_cos, scm_tan, scm_sinh, scm_cosh, scm_tanh, scm_asin, scm_acos, scm_sys_asinh, scm_sys_acosh, scm_sys_acosh, scm_sys_atanh, scm_atan): Return an exact result in some cases. * test-suite/tests/numbers.test: Add test cases. * NEWS: Add NEWS entry --- NEWS | 8 +++ libguile/numbers.c | 48 ++++++++++++++----- test-suite/tests/numbers.test | 102 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 143 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 9c1f32f..0375faf 100644 --- a/NEWS +++ b/NEWS @@ -80,6 +80,14 @@ was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per R5RS and R6RS, but previously it returned 4. It also now handles cases involving infinities and NaNs properly, per R6RS. +*** Trigonometric functions now return exact numbers in some cases + +scm_sin `sin', scm_cos `cos', scm_tan `tan', scm_sinh `sinh', scm_cosh +`cosh', scm_tanh `tanh', scm_asin `asin', scm_acos `acos', +scm_sys_asinh `asinh', scm_sys_acosh `acosh', scm_sys_acosh `acosh', +scm_sys_atanh `atanh' and the one-argument case of scm_atan `atan' now +return exact results in some cases. + *** New procedure: `finite?' Add scm_finite_p `finite?' from R6RS to guile core, which returns #t diff --git a/libguile/numbers.c b/libguile/numbers.c index 480d326..a0186a2 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5543,7 +5543,9 @@ SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0, "Compute the sine of @var{z}.") #define FUNC_NAME s_scm_sin { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* sin(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (sin (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -5562,7 +5564,9 @@ SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0, "Compute the cosine of @var{z}.") #define FUNC_NAME s_scm_cos { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return SCM_INUM1; /* cos(exact0) = exact1 */ + else if (scm_is_real (z)) return scm_from_double (cos (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -5581,7 +5585,9 @@ SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0, "Compute the tangent of @var{z}.") #define FUNC_NAME s_scm_tan { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* tan(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (tan (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y, w; @@ -5604,7 +5610,9 @@ SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0, "Compute the hyperbolic sine of @var{z}.") #define FUNC_NAME s_scm_sinh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* sinh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (sinh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -5623,7 +5631,9 @@ SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0, "Compute the hyperbolic cosine of @var{z}.") #define FUNC_NAME s_scm_cosh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return SCM_INUM1; /* cosh(exact0) = exact1 */ + else if (scm_is_real (z)) return scm_from_double (cosh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -5642,7 +5652,9 @@ SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0, "Compute the hyperbolic tangent of @var{z}.") #define FUNC_NAME s_scm_tanh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* tanh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (tanh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y, w; @@ -5665,7 +5677,9 @@ SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0, "Compute the arc sine of @var{z}.") #define FUNC_NAME s_scm_asin { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* asin(exact0) = exact0 */ + else if (scm_is_real (z)) { double w = scm_to_double (z); if (w >= -1.0 && w <= 1.0) @@ -5691,7 +5705,9 @@ SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0, "Compute the arc cosine of @var{z}.") #define FUNC_NAME s_scm_acos { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1))) + return SCM_INUM0; /* acos(exact1) = exact0 */ + else if (scm_is_real (z)) { double w = scm_to_double (z); if (w >= -1.0 && w <= 1.0) @@ -5723,7 +5739,9 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0, { if (SCM_UNBNDP (y)) { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* atan(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (atan (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { @@ -5754,7 +5772,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0, "Compute the inverse hyperbolic sine of @var{z}.") #define FUNC_NAME s_scm_sys_asinh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* asinh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (asinh (scm_to_double (z))); else if (scm_is_number (z)) return scm_log (scm_sum (z, @@ -5770,7 +5790,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0, "Compute the inverse hyperbolic cosine of @var{z}.") #define FUNC_NAME s_scm_sys_acosh { - if (scm_is_real (z) && scm_to_double (z) >= 1.0) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1))) + return SCM_INUM0; /* acosh(exact1) = exact0 */ + else if (scm_is_real (z) && scm_to_double (z) >= 1.0) return scm_from_double (acosh (scm_to_double (z))); else if (scm_is_number (z)) return scm_log (scm_sum (z, @@ -5786,7 +5808,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0, "Compute the inverse hyperbolic tangent of @var{z}.") #define FUNC_NAME s_scm_sys_atanh { - if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* atanh(exact0) = exact0 */ + else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0) return scm_from_double (atanh (scm_to_double (z))); else if (scm_is_number (z)) return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z), diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index e812658..8854a25 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3310,25 +3310,121 @@ ;;; +;;; sin +;;; + +(with-test-prefix "sin" + (pass-if (eqv? 0 (sin 0))) + (pass-if (eqv? 0.0 (sin 0.0))) + (pass-if (eqv-loosely? 1.0 (sin 1.57))) + (pass-if (eqv-loosely? +1.175i (sin +i))) + (pass-if (real-nan? (sin +nan.0))) + (pass-if (real-nan? (sin +inf.0))) + (pass-if (real-nan? (sin -inf.0)))) + +;;; +;;; cos +;;; + +(with-test-prefix "cos" + (pass-if (eqv? 1 (cos 0))) + (pass-if (eqv? 1.0 (cos 0.0))) + (pass-if (eqv-loosely? 0.0 (cos 1.57))) + (pass-if (eqv-loosely? 1.543 (cos +i))) + (pass-if (real-nan? (cos +nan.0))) + (pass-if (real-nan? (cos +inf.0))) + (pass-if (real-nan? (cos -inf.0)))) + +;;; +;;; tan +;;; + +(with-test-prefix "tan" + (pass-if (eqv? 0 (tan 0))) + (pass-if (eqv? 0.0 (tan 0.0))) + (pass-if (eqv-loosely? 1.0 (tan 0.785))) + (pass-if (eqv-loosely? +0.76i (tan +i))) + (pass-if (real-nan? (tan +nan.0))) + (pass-if (real-nan? (tan +inf.0))) + (pass-if (real-nan? (tan -inf.0)))) + +;;; +;;; asin +;;; + +(with-test-prefix "asin" + (pass-if (complex-nan? (asin +nan.0))) + (pass-if (eqv? 0 (asin 0))) + (pass-if (eqv? 0.0 (asin 0.0)))) + +;;; +;;; acos +;;; + +(with-test-prefix "acos" + (pass-if (complex-nan? (acos +nan.0))) + (pass-if (eqv? 0 (acos 1))) + (pass-if (eqv? 0.0 (acos 1.0)))) + +;;; +;;; atan +;;; +;;; FIXME: add tests for two-argument atan +;;; +(with-test-prefix "atan" + (pass-if (real-nan? (atan +nan.0))) + (pass-if (eqv? 0 (atan 0))) + (pass-if (eqv? 0.0 (atan 0.0))) + (pass-if (eqv-loosely? 1.57 (atan +inf.0))) + (pass-if (eqv-loosely? -1.57 (atan -inf.0)))) + +;;; +;;; sinh +;;; + +(with-test-prefix "sinh" + (pass-if (= 0 (sinh 0))) + (pass-if (= 0.0 (sinh 0.0)))) + +;;; +;;; cosh +;;; + +(with-test-prefix "cosh" + (pass-if (= 1 (cosh 0))) + (pass-if (= 1.0 (cosh 0.0)))) + +;;; +;;; tanh +;;; + +(with-test-prefix "tanh" + (pass-if (= 0 (tanh 0))) + (pass-if (= 0.0 (tanh 0.0)))) + +;;; ;;; asinh ;;; (with-test-prefix "asinh" - (pass-if (= 0 (asinh 0)))) + (pass-if (= 0 (asinh 0))) + (pass-if (= 0.0 (asinh 0.0)))) ;;; ;;; acosh ;;; (with-test-prefix "acosh" - (pass-if (= 0 (acosh 1)))) + (pass-if (= 0 (acosh 1))) + (pass-if (= 0.0 (acosh 1.0)))) ;;; ;;; atanh ;;; (with-test-prefix "atanh" - (pass-if (= 0 (atanh 0)))) + (pass-if (= 0 (atanh 0))) + (pass-if (= 0.0 (atanh 0.0)))) ;;; ;;; make-rectangular -- 1.5.6.5 ^ permalink raw reply related [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-26 22:46 ` Mark H Weaver @ 2011-01-27 22:06 ` Mark H Weaver 2011-01-28 12:19 ` Andy Wingo 2011-01-27 22:32 ` Mark H Weaver 2011-01-28 13:46 ` Andy Wingo 2 siblings, 1 reply; 24+ messages in thread From: Mark H Weaver @ 2011-01-27 22:06 UTC (permalink / raw) To: guile-devel I'm having second thoughts about two of the patches: * Patch 0010: `inf?' and `nan?' throw exceptions when applied to non-numbers Previously, these predicates would return #f in that case. I tend to prefer strictness, but perhaps backward compatibility is more important than strictness here. What do you think? * Patch 0018: Exact 0 times infinity or a NaN yields a NaN Previously, exact 0 times anything yields exact 0. This patch makes exact 0 times any _finite_ number yield an exact 0, but makes exact 0 times an infinity or NaN yield a NaN. This is a mistake. A computation involving inexact arguments is permitted to produce an exact answer only if the same answer would be produced regardless of the value of the inexact arguments. R6RS provides these examples, and gives us choices: (* 0 +inf.0) ==> 0 or +nan.0 (* 0 +nan.0) ==> 0 or +nan.0 (* 1.0 0) ==> 0 or 0.0 But the choices are linked. (* 0 n) may produce an exact 0 only if the answer is exact 0 for _any_ value of n (including infinities or NaNs). On the other hand, if we decide that the three cases above should return an exact 0, then we are on mathematically questionable grounds. Consider: (/ 0.0) ==> +inf.0 (required by R6RS) (* 0 +inf.0) ==> 0 (one of two choices, per R6RS) (* 0 (/ 0.0)) ==> 0 (/ 0 0.0) ==> +nan.0 (required by R6RS) The inconsistency of the last two cases does not sit well with me, but in order to eliminate this inconsistency, we must concede that exact 0 times any inexact number must produce an inexact result. I am leaning toward the following: (* 0 +inf.0) ==> +nan.0 (* 0 +nan.0) ==> +nan.0 (* 0 1.0) ==> 1.0 (* 0 0.0) ==> 0.0 What do you think? Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-27 22:06 ` Mark H Weaver @ 2011-01-28 12:19 ` Andy Wingo 2011-01-29 0:05 ` Mark H Weaver 0 siblings, 1 reply; 24+ messages in thread From: Andy Wingo @ 2011-01-28 12:19 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel Hi Mark, On Thu 27 Jan 2011 23:06, Mark H Weaver <mhw@netris.org> writes: > I'm having second thoughts about two of the patches: > > * Patch 0010: `inf?' and `nan?' throw exceptions when applied to > non-numbers > > Previously, these predicates would return #f in that case. I tend to > prefer strictness, but perhaps backward compatibility is more important > than strictness here. What do you think? I think that certainly when it comes to numbers, strictness is good. In particular the r6rs says: (zero? z) procedure (positive? x) procedure (negative? x) procedure (odd? n) procedure (even? n) procedure (finite? x) procedure (infinite? x) procedure (nan? x) procedure The name of the argument indicates the type, as noted earlier in the report. `z' is a complex number, `x' is a real, and `n' is an integer. It is an error to pass a non-integer to even?. It is also an error to pass a non-real to infinite?. (Note that the domain of first 5 predicates is specified in R5RS as well.) Given that the R5RS does not discuss infinities, and they were only added in Guile 1.8 (I believe), I think we have some room for change. We should change to the R6RS semantics, I think. > I am leaning toward the following: > > (* 0 +inf.0) ==> +nan.0 > (* 0 +nan.0) ==> +nan.0 > (* 0 1.0) ==> 1.0 ==> 0.0, you mean. > (* 0 0.0) ==> 0.0 > > What do you think? I think your suggestion is a good one. But I don't really know what I'm talking about ;-) Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-28 12:19 ` Andy Wingo @ 2011-01-29 0:05 ` Mark H Weaver 2011-01-29 11:29 ` Andy Wingo 0 siblings, 1 reply; 24+ messages in thread From: Mark H Weaver @ 2011-01-29 0:05 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: > I think that certainly when it comes to numbers, strictness is good. In > particular the r6rs says: > > (zero? z) procedure > (positive? x) procedure > (negative? x) procedure > (odd? n) procedure > (even? n) procedure > (finite? x) procedure > (infinite? x) procedure > (nan? x) procedure > > The name of the argument indicates the type, as noted earlier in the > report. `z' is a complex number, `x' is a real, and `n' is an integer. > It is an error to pass a non-integer to even?. It is also an error to > pass a non-real to infinite?. Are you reading the final version of R6RS, or a draft? The above paragraph is not present at: http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html Instead, there is this paragraph: > These numerical predicates test a number object for a particular > property, returning #t or #f. The zero? procedure tests if the number > object is = to zero, positive? tests whether it is greater than zero, > negative? tests whether it is less than zero, odd? tests whether it is > odd, even? tests whether it is even, finite? tests whether it is not > an infinity and not a NaN, infinite? tests whether it is an infinity, > nan? tests whether it is a NaN. I interpreted the above text to mean that those predicates could be applied to any number object. Can you find anywhere in the final R6RS where it states that the variable names indicate the domain of those predicates? > (Note that the domain of first 5 predicates is specified in R5RS as > well.) That is certainly true. Thanks for pointing that out, I had forgotten that the formal variable names were significant. I agree with the domains of the first 5 predicates as specified in R5RS. However, I strongly believe that finite?, infinite?, and nan? should be applicable to non-real complex numbers. They would clearly be useful as such, otherwise those working with complex numbers will have to reimplement them. Can you show me some text from R6RS Final that explicitly states that those formal variable names indicate the domain? Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 0:05 ` Mark H Weaver @ 2011-01-29 11:29 ` Andy Wingo 0 siblings, 0 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-29 11:29 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Sat 29 Jan 2011 01:05, Mark H Weaver <mhw@netris.org> writes: > Andy Wingo <wingo@pobox.com> writes: >> I think that certainly when it comes to numbers, strictness is good. In >> particular the r6rs says: >> >> (zero? z) procedure >> (positive? x) procedure >> (negative? x) procedure >> (odd? n) procedure >> (even? n) procedure >> (finite? x) procedure >> (infinite? x) procedure >> (nan? x) procedure >> >> The name of the argument indicates the type, as noted earlier in the >> report. `z' is a complex number, `x' is a real, and `n' is an integer. >> It is an error to pass a non-integer to even?. It is also an error to >> pass a non-real to infinite?. > > Are you reading the final version of R6RS, or a draft? The above > paragraph is not present at: > > http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html It is hidden here: http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-9.html#node_sec_6.2 For succinctness, the report follows the convention that if a parameter name is also the name of a type, then the corresponding argument must be of the named type. For example, the header line for vector-ref given above dictates that the first argument to vector-ref must be a vector. The following naming conventions imply type restrictions: obj any object z complex number object x real number object y real number object q rational number object n integer object k exact non-negative integer object bool boolean (#f or #t) octet exact integer object in {0, ..., 255} byte exact integer object in { - 128, ..., 127} char character (see section 11.11) pair pair (see section 11.9) vector vector (see section 11.13) string string (see section 11.12) condition condition (see library section on “Conditions”) bytevector bytevector (see library chapter on “Bytevectors”) proc procedure (see section 1.6) Other type restrictions are expressed through parameter-naming conventions that are described in specific chapters. For example, library chapter on “Arithmetic” uses a number of special parameter variables for the various subsets of the numbers. With the listed type restrictions, it is the programmer’s responsibility to ensure that the corresponding argument is of the specified type. It is the implementation’s responsibility to check for that type. > However, I strongly believe that finite?, infinite?, and nan? should be > applicable to non-real complex numbers. They would clearly be useful as > such, otherwise those working with complex numbers will have to > reimplement them. Dunno. Is inf? true if either of the components of a complex number are inf? If that is the case, as you had it, shouldn't finite? be true if either component is finite? Users of complex numbers have to choose what they mean when they ask inf? of a number. I think that's the intention of the report. Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-26 22:46 ` Mark H Weaver 2011-01-27 22:06 ` Mark H Weaver @ 2011-01-27 22:32 ` Mark H Weaver 2011-01-28 13:46 ` Andy Wingo 2 siblings, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-27 22:32 UTC (permalink / raw) To: guile-devel Also hold off on patch 0014, which implements R6RS div/mod/div0/mod0. I've decided to implement them in C instead. Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-26 22:46 ` Mark H Weaver 2011-01-27 22:06 ` Mark H Weaver 2011-01-27 22:32 ` Mark H Weaver @ 2011-01-28 13:46 ` Andy Wingo 2011-01-28 14:44 ` Noah Lavine 2011-01-29 8:20 ` Mark H Weaver 2 siblings, 2 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-28 13:46 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Wed 26 Jan 2011 23:46, Mark H Weaver <mhw@netris.org> writes: > Attached is an improved version of my first 20 patches of numerics > bugfixes and changes for improved R6RS (and in some cases, R5RS!) > standards compliance. The first seven patches are unchanged from my > last post, but I rebased them and they're not very large, so I include > them here for completeness. I applied up to patch 12, I think, and at that point some changes I put in stopped making the others apply cleanly, so git-am balked. Dunno why it didn't do the three-way thing. In any case, please resubmit the rest when you are ready. Thanks! Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-28 13:46 ` Andy Wingo @ 2011-01-28 14:44 ` Noah Lavine 2011-01-28 15:55 ` Andy Wingo 2011-01-29 8:20 ` Mark H Weaver 1 sibling, 1 reply; 24+ messages in thread From: Noah Lavine @ 2011-01-28 14:44 UTC (permalink / raw) To: Andy Wingo; +Cc: Mark H Weaver, guile-devel Hello all, I hope to not derail this much (if at all), but I just did some checking, and I believe the following proposal was accepted as R7RS' integer division functions. So it might be worth making Guile's like that if we can. http://trac.sacrideo.us/wg/wiki/DivisionRiastradh Noah On Fri, Jan 28, 2011 at 8:46 AM, Andy Wingo <wingo@pobox.com> wrote: > On Wed 26 Jan 2011 23:46, Mark H Weaver <mhw@netris.org> writes: > >> Attached is an improved version of my first 20 patches of numerics >> bugfixes and changes for improved R6RS (and in some cases, R5RS!) >> standards compliance. The first seven patches are unchanged from my >> last post, but I rebased them and they're not very large, so I include >> them here for completeness. > > I applied up to patch 12, I think, and at that point some changes I put > in stopped making the others apply cleanly, so git-am balked. Dunno why > it didn't do the three-way thing. In any case, please resubmit the rest > when you are ready. Thanks! > > Andy > -- > http://wingolog.org/ > > ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-28 14:44 ` Noah Lavine @ 2011-01-28 15:55 ` Andy Wingo 0 siblings, 0 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-28 15:55 UTC (permalink / raw) To: Noah Lavine; +Cc: Mark H Weaver, guile-devel On Fri 28 Jan 2011 15:44, Noah Lavine <noah.b.lavine@gmail.com> writes: > I hope to not derail this much (if at all), but I just did some > checking, and I believe the following proposal was accepted as R7RS' > integer division functions. So it might be worth making Guile's like > that if we can. > > http://trac.sacrideo.us/wg/wiki/DivisionRiastradh Good point! I believe *that* was actually the conclusion I came to. Thank you for reminding me :) Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-28 13:46 ` Andy Wingo 2011-01-28 14:44 ` Noah Lavine @ 2011-01-29 8:20 ` Mark H Weaver 2011-01-29 17:42 ` Andy Wingo ` (2 more replies) 1 sibling, 3 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-29 8:20 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel [-- Attachment #1: Type: text/plain, Size: 371 bytes --] Andy Wingo <wingo@pobox.com> writes: > I applied up to patch 12, I think, [...] Great, thanks! Here's another batch which should now apply cleanly. This includes an efficient implementation of the R6RS division operations along with documentation and extensive tests. The code has many paths, so I was careful to include tests for all of them. Best, Mark [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #2: Remove useless test and fix spelling errors --] [-- Type: text/x-diff, Size: 1887 bytes --] From 457f9ce87af2e15438662eb4ec4caf7b7a4aa4d1 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Fri, 28 Jan 2011 19:13:47 -0500 Subject: [PATCH] Remove useless test and fix spelling errors * test-suite/tests/numbers.test: Remove test for lazy reduction bit of fractions, which was never implemented. Fix some spelling errors. --- test-suite/tests/numbers.test | 20 ++++---------------- 1 files changed, 4 insertions(+), 16 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index f53cb34..4f30f6c 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -318,15 +318,15 @@ (pass-if (not (finite? +inf.0))) (pass-if (not (finite? -inf.0))) (pass-if-exception - "complex numbers not in doman of finite?" + "complex numbers not in domain of finite?" exception:wrong-type-arg (finite? +inf.0+1i)) (pass-if-exception - "complex numbers not in doman of finite? (2)" + "complex numbers not in domain of finite? (2)" exception:wrong-type-arg (finite? +1+inf.0i)) (pass-if-exception - "complex numbers not in doman of finite? (3)" + "complex numbers not in domain of finite? (3)" exception:wrong-type-arg (finite? +1+1i)) (pass-if (finite? 3+0i)) @@ -351,7 +351,7 @@ ;; (pass-if (inf? (/ 1.0 0.0)) ;; (pass-if (inf? (/ 1 0.0)) (pass-if-exception - "complex numbers not in doman of inf?" + "complex numbers not in domain of inf?" exception:wrong-type-arg (inf? +1+inf.0i)) (pass-if (inf? +inf.0+0i)) @@ -3386,15 +3386,3 @@ (pass-if "-100i swings back to 45deg down" (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) - -;; -;; equal? -;; - - -(with-test-prefix "equal?" - (pass-if - - ;; lazy reduction bit for rationals should not affect equal? - (equal? 1/2 ((lambda (x) (denominator x) x) 1/2)))) - -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #3: `equal?' and `eqv?' are now equivalent for numbers --] [-- Type: text/x-diff, Size: 12665 bytes --] From 3afeb53165c69f95120336a5b6cbb83a810be1e9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Fri, 28 Jan 2011 19:57:41 -0500 Subject: [PATCH] `equal?' and `eqv?' are now equivalent for numbers Change `equal?' to work like `eqv?' for numbers. Previously they worked differently in some cases, e.g. when comparing signed zeroes or NaNs. For example, (equal? 0.0 -0.0) returned #t but (eqv? 0.0 -0.0) returned #f, and (equal? +nan.0 +nan.0) returned #f but (eqv? +nan.0 +nan.0) returned #t. * libguile/numbers.c (scm_real_equalp, scm_bigequal, scm_complex_equalp, scm_i_fraction_equalp): Move to eq.c. * libguile/eq.c (scm_real_equalp): Compare flonums using real_eqv instead of ==, so that NaNs are now considered equal, and to distinguish signed zeroes. (scm_complex_equalp): Compare real and imaginary components using real_eqv instead of ==, so that NaNs are now considered equal, and to distinguish signed zeroes. (scm_bigequal): Use scm_i_bigcmp instead of duplicating it. (real_eqv): Test for NaNs using isnan(x) instead of (x != x), and use SCM_UNLIKELY for optimization. (scm_eqv_p): Use scm_bigequal, scm_real_equalp, scm_complex_equalp, and scm_i_fraction_equalp to compare numbers, instead of inline code. Those predicates now do what scm_eqv_p formerly did internally. Replace if statements with switch statements, as is done in scm_equal_p. Remove useless code to check equality of fractions with different SCM_CELL_TYPEs; this was for a tentative "lazy reduction bit" which was never developed. (scm_eqv_p, scm_equal_p): Remove useless code to check equality between inexact reals and non-real complex numbers with zero imaginary part. Such numbers do not exist, because the current code is careful to never create them. * test-suite/tests/numbers.test: Add test cases for `eqv?' and `equal?'. Change existing test case for `(equal? +nan.0 +nan.0)' to expect #t instead of #f. * NEWS: Add NEWS entries. --- NEWS | 15 ++++++ libguile/eq.c | 106 ++++++++++++++++++++--------------------- libguile/numbers.c | 34 ------------- test-suite/tests/numbers.test | 86 +++++++++++++++++++++++++++++++++- 4 files changed, 152 insertions(+), 89 deletions(-) diff --git a/NEWS b/NEWS index 9938204..2979849 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,21 @@ Changes in 1.9.15 (since the 1.9.14 prerelease): ** Changes and bugfixes in numerics code +*** `eqv?' and `equal?' now compare numbers equivalently + +scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for +numeric values, per R5RS. Previously, equal? worked differently, +e.g. `(equal? 0.0 -0.0)' returned #t but `(eqv? 0.0 -0.0)' returned #f, +and `(equal? +nan.0 +nan.0)' returned #f but `(eqv? +nan.0 +nan.0)' +returned #t. + +*** `(equal? +nan.0 +nan.0)' now returns #t + +Previously, `(equal? +nan.0 +nan.0)' returned #f, although +`(let ((x +nan.0)) (equal? x x))' and `(eqv? +nan.0 +nan.0)' +both returned #t. R5RS requires that `equal?' behave like +`eqv?' when comparing numbers. + *** Infinities are no longer integers. Following the R6RS, infinities (+inf.0 and -inf.0) are no longer diff --git a/libguile/eq.c b/libguile/eq.c index 7502559..00abdd8 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -118,7 +118,40 @@ scm_eq_p (SCM x, SCM y) static int real_eqv (double x, double y) { - return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y); + return !memcmp (&x, &y, sizeof(double)) + || (SCM_UNLIKELY (isnan (x)) && SCM_UNLIKELY (isnan (y))); +} + +SCM +scm_real_equalp (SCM x, SCM y) +{ + return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), + SCM_REAL_VALUE (y))); +} + +SCM +scm_bigequal (SCM x, SCM y) +{ + return scm_from_bool (scm_i_bigcmp (x, y) == 0); +} + +SCM +scm_complex_equalp (SCM x, SCM y) +{ + return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), + SCM_COMPLEX_REAL (y)) + && real_eqv (SCM_COMPLEX_IMAG (x), + SCM_COMPLEX_IMAG (y))); +} + +SCM +scm_i_fraction_equalp (SCM x, SCM y) +{ + return scm_from_bool + (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_NUMERATOR (y))) + && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), + SCM_FRACTION_DENOMINATOR (y)))); } static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest); @@ -166,48 +199,26 @@ SCM scm_eqv_p (SCM x, SCM y) return SCM_BOOL_F; if (SCM_IMP (y)) return SCM_BOOL_F; - /* this ensures that types and scm_length are the same. */ + /* this ensures that types and scm_length are the same. */ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) + return SCM_BOOL_F; + switch (SCM_TYP7 (x)) { - /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), - but this checks the entire type word, so fractions may be accidentally - flagged here as unequal. Perhaps I should use the 4th double_cell word? - */ - - /* treat mixes of real and complex types specially */ - if (SCM_INEXACTP (x)) - { - if (SCM_REALP (x)) - return scm_from_bool (SCM_COMPLEXP (y) - && real_eqv (SCM_REAL_VALUE (x), - SCM_COMPLEX_REAL (y)) - && SCM_COMPLEX_IMAG (y) == 0.0); - else - return scm_from_bool (SCM_REALP (y) - && real_eqv (SCM_COMPLEX_REAL (x), - SCM_REAL_VALUE (y)) - && SCM_COMPLEX_IMAG (x) == 0.0); - } - - if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) - return scm_i_fraction_equalp (x, y); - return SCM_BOOL_F; - } - if (SCM_NUMP (x)) - { - if (SCM_BIGP (x)) { - return scm_from_bool (scm_i_bigcmp (x, y) == 0); - } else if (SCM_REALP (x)) { - return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); - } else if (SCM_FRACTIONP (x)) { - return scm_i_fraction_equalp (x, y); - } else { /* complex */ - return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x), - SCM_COMPLEX_REAL (y)) - && real_eqv (SCM_COMPLEX_IMAG (x), - SCM_COMPLEX_IMAG (y))); - } + default: + break; + case scm_tc7_number: + switch SCM_TYP16 (x) + { + case scm_tc16_big: + return scm_bigequal (x, y); + case scm_tc16_real: + return scm_real_equalp (x, y); + case scm_tc16_complex: + return scm_complex_equalp (x, y); + case scm_tc16_fraction: + return scm_i_fraction_equalp (x, y); + } } return SCM_BOOL_F; } @@ -309,19 +320,6 @@ scm_equal_p (SCM x, SCM y) /* This ensures that types and scm_length are the same. */ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { - /* treat mixes of real and complex types specially */ - if (SCM_INEXACTP (x) && SCM_INEXACTP (y)) - { - if (SCM_REALP (x)) - return scm_from_bool (SCM_COMPLEXP (y) - && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y) - && SCM_COMPLEX_IMAG (y) == 0.0); - else - return scm_from_bool (SCM_REALP (y) - && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) - && SCM_COMPLEX_IMAG (x) == 0.0); - } - /* Vectors can be equal to one-dimensional arrays. */ if (scm_is_array (x) && scm_is_array (y)) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9998ab7..8513fea 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3249,40 +3249,6 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, /*** END strs->nums ***/ -SCM -scm_bigequal (SCM x, SCM y) -{ - int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - return scm_from_bool (0 == result); -} - -SCM -scm_real_equalp (SCM x, SCM y) -{ - return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); -} - -SCM -scm_complex_equalp (SCM x, SCM y) -{ - return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y) - && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)); -} - -SCM -scm_i_fraction_equalp (SCM x, SCM y) -{ - if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x), - SCM_FRACTION_NUMERATOR (y))) - || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x), - SCM_FRACTION_DENOMINATOR (y)))) - return SCM_BOOL_F; - else - return SCM_BOOL_T; -} - - SCM_DEFINE (scm_number_p, "number?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is a number, @code{#f}\n" diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 4f30f6c..d116b6f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1605,12 +1605,24 @@ (with-test-prefix "equal?" (pass-if (documented? equal?)) + + ;; The following test will fail on platforms + ;; without distinct signed zeroes 0.0 and -0.0. + (pass-if (not (equal? 0.0 -0.0))) + (pass-if (equal? 0 0)) (pass-if (equal? 7 7)) (pass-if (equal? -7 -7)) (pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max))) (pass-if (equal? (- fixnum-min 1) (- fixnum-min 1))) + (pass-if (equal? 0.0 0.0)) + (pass-if (equal? -0.0 -0.0)) (pass-if (not (equal? 0 1))) + (pass-if (not (equal? 0 0.0))) + (pass-if (not (equal? 1 1.0))) + (pass-if (not (equal? 0.0 0))) + (pass-if (not (equal? 1.0 1))) + (pass-if (not (equal? -1.0 -1))) (pass-if (not (equal? fixnum-max (+ 1 fixnum-max)))) (pass-if (not (equal? (+ 1 fixnum-max) fixnum-max))) (pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max)))) @@ -1631,7 +1643,10 @@ (pass-if (not (equal? (- (ash 1 1024)) -inf.0))) (pass-if (not (equal? -inf.0 (- (ash 1 1024))))) - (pass-if (not (equal? +nan.0 +nan.0))) + (pass-if (equal? +nan.0 +nan.0)) + (pass-if (equal? +nan.0 +nan.0)) + (pass-if (not (equal? +nan.0 0.0+nan.0i))) + (pass-if (not (equal? 0 +nan.0))) (pass-if (not (equal? +nan.0 0))) (pass-if (not (equal? 1 +nan.0))) @@ -1655,6 +1670,75 @@ (pass-if (not (equal? +nan.0 (ash 3 1023))))) ;;; +;;; eqv? +;;; + +(with-test-prefix "eqv?" + (pass-if (documented? eqv?)) + + ;; The following test will fail on platforms + ;; without distinct signed zeroes 0.0 and -0.0. + (pass-if (not (eqv? 0.0 -0.0))) + + (pass-if (eqv? 0 0)) + (pass-if (eqv? 7 7)) + (pass-if (eqv? -7 -7)) + (pass-if (eqv? (+ 1 fixnum-max) (+ 1 fixnum-max))) + (pass-if (eqv? (- fixnum-min 1) (- fixnum-min 1))) + (pass-if (eqv? 0.0 0.0)) + (pass-if (eqv? -0.0 -0.0)) + (pass-if (not (eqv? 0 1))) + (pass-if (not (eqv? 0 0.0))) + (pass-if (not (eqv? 1 1.0))) + (pass-if (not (eqv? 0.0 0))) + (pass-if (not (eqv? 1.0 1))) + (pass-if (not (eqv? -1.0 -1))) + (pass-if (not (eqv? fixnum-max (+ 1 fixnum-max)))) + (pass-if (not (eqv? (+ 1 fixnum-max) fixnum-max))) + (pass-if (not (eqv? (+ 1 fixnum-max) (+ 2 fixnum-max)))) + (pass-if (not (eqv? fixnum-min (- fixnum-min 1)))) + (pass-if (not (eqv? (- fixnum-min 1) fixnum-min))) + (pass-if (not (eqv? (- fixnum-min 1) (- fixnum-min 2)))) + (pass-if (not (eqv? (+ fixnum-max 1) (- fixnum-min 1)))) + + (pass-if (not (eqv? (ash 1 256) +inf.0))) + (pass-if (not (eqv? +inf.0 (ash 1 256)))) + (pass-if (not (eqv? (ash 1 256) -inf.0))) + (pass-if (not (eqv? -inf.0 (ash 1 256)))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make + ;; sure we've avoided that + (pass-if (not (eqv? (ash 1 1024) +inf.0))) + (pass-if (not (eqv? +inf.0 (ash 1 1024)))) + (pass-if (not (eqv? (- (ash 1 1024)) -inf.0))) + (pass-if (not (eqv? -inf.0 (- (ash 1 1024))))) + + (pass-if (eqv? +nan.0 +nan.0)) + (pass-if (not (eqv? +nan.0 0.0+nan.0i))) + + (pass-if (not (eqv? 0 +nan.0))) + (pass-if (not (eqv? +nan.0 0))) + (pass-if (not (eqv? 1 +nan.0))) + (pass-if (not (eqv? +nan.0 1))) + (pass-if (not (eqv? -1 +nan.0))) + (pass-if (not (eqv? +nan.0 -1))) + + (pass-if (not (eqv? (ash 1 256) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 1 256)))) + (pass-if (not (eqv? (- (ash 1 256)) +nan.0))) + (pass-if (not (eqv? +nan.0 (- (ash 1 256))))) + + (pass-if (not (eqv? (ash 1 8192) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 1 8192)))) + (pass-if (not (eqv? (- (ash 1 8192)) +nan.0))) + (pass-if (not (eqv? +nan.0 (- (ash 1 8192))))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make + ;; sure we've avoided that + (pass-if (not (eqv? (ash 3 1023) +nan.0))) + (pass-if (not (eqv? +nan.0 (ash 3 1023))))) + +;;; ;;; = ;;; -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #4: Infinities and NaNs are no longer rational --] [-- Type: text/x-diff, Size: 11536 bytes --] From ee5315abcbd527613caea504f738136d0e58274e Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Fri, 28 Jan 2011 23:32:20 -0500 Subject: [PATCH] Infinities and NaNs are no longer rational * libguile/numbers.c (scm_rational_p): Return #f for infinities and NaNs, per R6RS. Previously it returned #t for real infinities and NaNs. They are still considered real by scm_real `real?' however, per R6RS. Also simplify the code. (scm_real_p): New implementation to reflect the fact that the rationals and reals are no longer the same set. Previously it just called scm_rational_p. (scm_integer_p): Simplify the code. * test-suite/tests/numbers.test: Add test cases for `rational?' and `real?' applied to infinities and NaNs. * doc/ref/api-data.texi (Real and Rational Numbers): Update docs to reflect the fact that infinities and NaNs are no longer rational, and that `real?' no longer implies `rational?'. Improve discussion of infinities and NaNs. * NEWS: Add NEWS entries, and combine with an earlier entry about infinities no longer being integers. --- NEWS | 18 +++++++--- doc/ref/api-data.texi | 73 ++++++++++++++++++++++------------------- libguile/numbers.c | 40 +++++++--------------- test-suite/tests/numbers.test | 12 ++++++- 4 files changed, 76 insertions(+), 67 deletions(-) diff --git a/NEWS b/NEWS index 2979849..5651b17 100644 --- a/NEWS +++ b/NEWS @@ -27,11 +27,6 @@ Previously, `(equal? +nan.0 +nan.0)' returned #f, although both returned #t. R5RS requires that `equal?' behave like `eqv?' when comparing numbers. -*** Infinities are no longer integers. - -Following the R6RS, infinities (+inf.0 and -inf.0) are no longer -considered to be integers. - *** `expt' and `integer-expt' changes when the base is 0 While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still @@ -40,6 +35,19 @@ integer-expt. This is more correct, and conforming to R6RS, but seems to be incompatible with R5RS, which would return 0 for all non-zero values of N. +*** Infinities are no longer integers, nor rationals + +scm_integer_p `integer?' and scm_rational_p `rational?' now return #f +for infinities, per R6RS. Previously they returned #t for real +infinities. The real infinities and NaNs are still considered real by +scm_real `real?' however, per R6RS. + +*** NaNs are no longer rationals + +scm_rational_p `rational?' now returns #f for NaN values, per R6RS. +Previously it returned #t for real NaN values. They are still +considered real by scm_real `real?' however, per R6RS. + *** `inf?' and `nan?' now throw exceptions for non-reals The domain of `inf?' and `nan?' is the real numbers. Guile now signals diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index a0ab258..4256e18 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -492,10 +492,10 @@ are not rational, for example @m{\sqrt2, the square root of 2}, and @m{\pi,pi}. Guile can represent both exact and inexact rational numbers, but it -can not represent irrational numbers. Exact rationals are represented -by storing the numerator and denominator as two exact integers. -Inexact rationals are stored as floating point numbers using the C -type @code{double}. +cannot represent precise finite irrational numbers. Exact rationals are +represented by storing the numerator and denominator as two exact +integers. Inexact rationals are stored as floating point numbers using +the C type @code{double}. Exact rationals are written as a fraction of integers. There must be no whitespace around the slash: @@ -518,26 +518,41 @@ example: 4.0 @end lisp -The limited precision of Guile's encoding means that any ``real'' number -in Guile can be written in a rational form, by multiplying and then dividing -by sufficient powers of 10 (or in fact, 2). For example, -@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided by -100000000000000000. In Guile's current incarnation, therefore, the -@code{rational?} and @code{real?} predicates are equivalent. - - -Dividing by an exact zero leads to a error message, as one might -expect. However, dividing by an inexact zero does not produce an -error. Instead, the result of the division is either plus or minus -infinity, depending on the sign of the divided number. +The limited precision of Guile's encoding means that any finite ``real'' +number in Guile can be written in a rational form, by multiplying and +then dividing by sufficient powers of 10 (or in fact, 2). For example, +@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided +by 100000000000000000. In Guile's current incarnation, therefore, the +@code{rational?} and @code{real?} predicates are equivalent for finite +numbers. -The infinities are written @samp{+inf.0} and @samp{-inf.0}, -respectively. This syntax is also recognized by @code{read} as an -extension to the usual Scheme syntax. The infinities are considered to -be inexact, non-integer values. -Dividing zero by zero yields something that is not a number at all: -@samp{+nan.0}. This is the special `not a number' value. +Dividing by an exact zero leads to a error message, as one might expect. +However, dividing by an inexact zero does not produce an error. +Instead, the result of the division is either plus or minus infinity, +depending on the sign of the divided number and the sign of the zero +divisor (some platforms support signed zeroes @samp{-0.0} and +@samp{+0.0}; @samp{0.0} is the same as @samp{+0.0}). + +Dividing zero by an inexact zero yields a @acronym{NaN} (`not a number') +value, although they are actually considered numbers by Scheme. +Attempts to compare a @acronym{NaN} value with any number (including +itself) using @code{=}, @code{<}, @code{>}, @code{<=} or @code{>=} +always returns @code{#f}. Although a @acronym{NaN} value is not +@code{=} to itself, it is both @code{eqv?} and @code{equal?} to itself +and other @acronym{NaN} values. However, the preferred way to test for +them is by using @code{nan?}. + +The real @acronym{NaN} values and infinities are written @samp{+nan.0}, +@samp{+inf.0} and @samp{-inf.0}. This syntax is also recognized by +@code{read} as an extension to the usual Scheme syntax. These special +values are considered by Scheme to be inexact real numbers but not +rational. Note that non-real complex numbers may also contain +infinities or @acronym{NaN} values in their real or imaginary parts. To +test a real number to see if it is infinite, a @acronym{NaN} value, or +neither, use @code{inf?}, @code{nan?}, or @code{finite?}, respectively. +Every real number in Scheme belongs to precisely one of those three +classes. On platforms that follow @acronym{IEEE} 754 for their floating point arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values @@ -545,13 +560,6 @@ are implemented using the corresponding @acronym{IEEE} 754 values. They behave in arithmetic operations like @acronym{IEEE} 754 describes it, i.e., @code{(= +nan.0 +nan.0)} @result{} @code{#f}. -While @samp{+nan.0} is not @code{=} to itself, it is @code{eqv?} to -itself. - -To test for the special values, use the functions @code{inf?} and -@code{nan?}. To test for numbers than are neither infinite nor a NaN, -use @code{finite?}. - @deffn {Scheme Procedure} real? obj @deffnx {C Function} scm_real_p (obj) Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note @@ -566,9 +574,6 @@ Return @code{#t} if @var{x} is a rational number, @code{#f} otherwise. Note that the set of integer values forms a subset of the set of rational numbers, i. e. the predicate will also be fulfilled if @var{x} is an integer number. - -Since Guile can not represent irrational numbers, every number -satisfying @code{real?} also satisfies @code{rational?} in Guile. @end deffn @deffn {Scheme Procedure} rationalize x eps @@ -607,12 +612,12 @@ NaN, @code{#f} otherwise. @deffn {Scheme Procedure} nan @deffnx {C Function} scm_nan () -Return NaN. +Return @samp{+nan.0}, a @acronym{NaN} value. @end deffn @deffn {Scheme Procedure} inf @deffnx {C Function} scm_inf () -Return Inf. +Return @samp{+inf.0}, positive infinity. @end deffn @deffn {Scheme Procedure} numerator x diff --git a/libguile/numbers.c b/libguile/numbers.c index 8513fea..608cf7a 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3281,8 +3281,8 @@ SCM_DEFINE (scm_real_p, "real?", 1, 0, 0, "fulfilled if @var{x} is an integer number.") #define FUNC_NAME s_scm_real_p { - /* we can't represent irrational numbers. */ - return scm_rational_p (x); + return scm_from_bool + (SCM_I_INUMP (x) || SCM_REALP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)); } #undef FUNC_NAME @@ -3294,18 +3294,12 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0, "fulfilled if @var{x} is an integer number.") #define FUNC_NAME s_scm_rational_p { - if (SCM_I_INUMP (x)) - return SCM_BOOL_T; - else if (SCM_IMP (x)) - return SCM_BOOL_F; - else if (SCM_BIGP (x)) - return SCM_BOOL_T; - else if (SCM_FRACTIONP (x)) + if (SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)) return SCM_BOOL_T; else if (SCM_REALP (x)) - /* due to their limited precision, all floating point numbers are - rational as well. */ - return SCM_BOOL_T; + /* due to their limited precision, finite floating point numbers are + rational as well. (finite means neither infinity nor a NaN) */ + return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x))); else return SCM_BOOL_F; } @@ -3317,23 +3311,15 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, "else.") #define FUNC_NAME s_scm_integer_p { - double r; - if (SCM_I_INUMP (x)) - return SCM_BOOL_T; - if (SCM_IMP (x)) - return SCM_BOOL_F; - if (SCM_BIGP (x)) + if (SCM_I_INUMP (x) || SCM_BIGP (x)) return SCM_BOOL_T; - if (!SCM_INEXACTP (x)) - return SCM_BOOL_F; - if (SCM_COMPLEXP (x)) - return SCM_BOOL_F; - r = SCM_REAL_VALUE (x); - if (isinf (r)) + else if (SCM_REALP (x)) + { + double val = SCM_REAL_VALUE (x); + return scm_from_bool (!isinf (val) && (val == floor (val))); + } + else return SCM_BOOL_F; - if (r == floor (r)) - return SCM_BOOL_T; - return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index d116b6f..36e3128 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1505,6 +1505,11 @@ (pass-if (real? (+ 1 fixnum-max))) (pass-if (real? (- 1 fixnum-min))) (pass-if (real? 1.3)) + (pass-if (real? +inf.0)) + (pass-if (real? -inf.0)) + (pass-if (real? +nan.0)) + (pass-if (not (real? +inf.0-inf.0i))) + (pass-if (not (real? +nan.0+nan.0i))) (pass-if (not (real? 3+4i))) (pass-if (not (real? #\a))) (pass-if (not (real? "a"))) @@ -1515,7 +1520,7 @@ (pass-if (not (real? (current-input-port))))) ;;; -;;; rational? (same as real? right now) +;;; rational? ;;; (with-test-prefix "rational?" @@ -1526,6 +1531,11 @@ (pass-if (rational? (+ 1 fixnum-max))) (pass-if (rational? (- 1 fixnum-min))) (pass-if (rational? 1.3)) + (pass-if (not (rational? +inf.0))) + (pass-if (not (rational? -inf.0))) + (pass-if (not (rational? +nan.0))) + (pass-if (not (rational? +inf.0-inf.0i))) + (pass-if (not (rational? +nan.0+nan.0i))) (pass-if (not (rational? 3+4i))) (pass-if (not (rational? #\a))) (pass-if (not (rational? "a"))) -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #5: Implement R6RS `real-valued?', `rational-valued?', `integer-valued?' --] [-- Type: text/x-diff, Size: 6369 bytes --] From b2d9e082b5740d6f722533d4ce30f3fbda955a9b Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Fri, 28 Jan 2011 23:42:01 -0500 Subject: [PATCH] Implement R6RS `real-valued?', `rational-valued?', `integer-valued?' * module/rnrs/base.scm (real-valued?, rational-valued?, integer-valued?): Implement in compliance with R6RS. * test-suite/tests/r6rs-base.test: Add test cases for `real-valued?', `rational-valued?', and `integer-valued?'. * NEWS: Add NEWS entries. --- NEWS | 4 ++ module/rnrs/base.scm | 19 +++++---- test-suite/tests/r6rs-base.test | 89 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 103 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index 5651b17..f45795e 100644 --- a/NEWS +++ b/NEWS @@ -76,6 +76,10 @@ by scheme, despite their name). throws exceptions for non-numbers. (Note that NaNs _are_ considered numbers by scheme, despite their name). +**** `real-valued?', `rational-valued?' and `integer-valued?' changes + +These predicates are now implemented in accordance with R6RS. + ** New reader option: `hungry-eol-escapes' Guile's string syntax is more compatible with R6RS when the diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index c7579c3..04a7e23 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -102,14 +102,17 @@ (define (exact-integer-sqrt x) (let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e))) - ;; These definitions should be revisited, since the behavior of Guile's - ;; implementations of `integer?', `rational?', and `real?' (exported from this - ;; library) is not entirely consistent with R6RS's requirements for those - ;; functions. - - (define integer-valued? integer?) - (define rational-valued? rational?) - (define real-valued? real?) + (define (real-valued? x) + (and (complex? x) + (zero? (imag-part x)))) + + (define (rational-valued? x) + (and (real-valued? x) + (rational? (real-part x)))) + + (define (integer-valued? x) + (and (rational-valued? x) + (= x (floor (real-part x))))) (define (vector-for-each proc . vecs) (apply for-each (cons proc (map vector->list vecs)))) diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test index a3603a1..1509b04 100644 --- a/test-suite/tests/r6rs-base.test +++ b/test-suite/tests/r6rs-base.test @@ -1,6 +1,6 @@ ;;; r6rs-base.test --- Test suite for R6RS (rnrs base) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -85,3 +85,90 @@ (pass-if "vector-map simple" (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3))))) +(with-test-prefix "real-valued?" + (pass-if (real-valued? +nan.0)) + (pass-if (real-valued? +nan.0+0i)) + (pass-if (real-valued? +nan.0+0.0i)) + (pass-if (real-valued? +inf.0)) + (pass-if (real-valued? -inf.0)) + (pass-if (real-valued? +inf.0+0.0i)) + (pass-if (real-valued? -inf.0-0.0i)) + (pass-if (real-valued? 3)) + (pass-if (real-valued? -2.5)) + (pass-if (real-valued? -2.5+0i)) + (pass-if (real-valued? -2.5+0.0i)) + (pass-if (real-valued? -2.5-0i)) + (pass-if (real-valued? #e1e10)) + (pass-if (real-valued? 1e200)) + (pass-if (real-valued? 1e200+0.0i)) + (pass-if (real-valued? 6/10)) + (pass-if (real-valued? 6/10+0.0i)) + (pass-if (real-valued? 6/10+0i)) + (pass-if (real-valued? 6/3)) + (pass-if (not (real-valued? 3+i))) + (pass-if (not (real-valued? -2.5+0.01i))) + (pass-if (not (real-valued? +nan.0+0.01i))) + (pass-if (not (real-valued? +nan.0+nan.0i))) + (pass-if (not (real-valued? +inf.0-0.01i))) + (pass-if (not (real-valued? +0.01i))) + (pass-if (not (real-valued? -inf.0i)))) + +(with-test-prefix "rational-valued?" + (pass-if (not (rational-valued? +nan.0))) + (pass-if (not (rational-valued? +nan.0+0i))) + (pass-if (not (rational-valued? +nan.0+0.0i))) + (pass-if (not (rational-valued? +inf.0))) + (pass-if (not (rational-valued? -inf.0))) + (pass-if (not (rational-valued? +inf.0+0.0i))) + (pass-if (not (rational-valued? -inf.0-0.0i))) + (pass-if (rational-valued? 3)) + (pass-if (rational-valued? -2.5)) + (pass-if (rational-valued? -2.5+0i)) + (pass-if (rational-valued? -2.5+0.0i)) + (pass-if (rational-valued? -2.5-0i)) + (pass-if (rational-valued? #e1e10)) + (pass-if (rational-valued? 1e200)) + (pass-if (rational-valued? 1e200+0.0i)) + (pass-if (rational-valued? 6/10)) + (pass-if (rational-valued? 6/10+0.0i)) + (pass-if (rational-valued? 6/10+0i)) + (pass-if (rational-valued? 6/3)) + (pass-if (not (rational-valued? 3+i))) + (pass-if (not (rational-valued? -2.5+0.01i))) + (pass-if (not (rational-valued? +nan.0+0.01i))) + (pass-if (not (rational-valued? +nan.0+nan.0i))) + (pass-if (not (rational-valued? +inf.0-0.01i))) + (pass-if (not (rational-valued? +0.01i))) + (pass-if (not (rational-valued? -inf.0i)))) + +(with-test-prefix "integer-valued?" + (pass-if (not (integer-valued? +nan.0))) + (pass-if (not (integer-valued? +nan.0+0i))) + (pass-if (not (integer-valued? +nan.0+0.0i))) + (pass-if (not (integer-valued? +inf.0))) + (pass-if (not (integer-valued? -inf.0))) + (pass-if (not (integer-valued? +inf.0+0.0i))) + (pass-if (not (integer-valued? -inf.0-0.0i))) + (pass-if (integer-valued? 3)) + (pass-if (integer-valued? 3.0)) + (pass-if (integer-valued? 3+0i)) + (pass-if (integer-valued? 3+0.0i)) + (pass-if (integer-valued? 8/4)) + (pass-if (integer-valued? #e1e10)) + (pass-if (integer-valued? 1e200)) + (pass-if (integer-valued? 1e200+0.0i)) + (pass-if (not (integer-valued? -2.5))) + (pass-if (not (integer-valued? -2.5+0i))) + (pass-if (not (integer-valued? -2.5+0.0i))) + (pass-if (not (integer-valued? -2.5-0i))) + (pass-if (not (integer-valued? 6/10))) + (pass-if (not (integer-valued? 6/10+0.0i))) + (pass-if (not (integer-valued? 6/10+0i))) + (pass-if (not (integer-valued? 3+i))) + (pass-if (not (integer-valued? -2.5+0.01i))) + (pass-if (not (integer-valued? +nan.0+0.01i))) + (pass-if (not (integer-valued? +nan.0+nan.0i))) + (pass-if (not (integer-valued? +inf.0-0.01i))) + (pass-if (not (integer-valued? +0.01i))) + (pass-if (not (integer-valued? -inf.0i)))) + -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #6: Add SCM_LIKELY and SCM_UNLIKELY for optimization --] [-- Type: text/x-diff, Size: 4974 bytes --] From 3fdddf143b231b989c78c3f7875d367eb42e72cd Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Fri, 28 Jan 2011 23:58:02 -0500 Subject: [PATCH] Add SCM_LIKELY and SCM_UNLIKELY for optimization * libguile/numbers.c (scm_abs, scm_quotient, scm_remainder, scm_modulo): Add SCM_LIKELY and SCM_UNLIKELY in several places for optimization. (scm_remainder): Add comment about C99 "%" semantics. Strip away a redundant set of braces. --- libguile/numbers.c | 67 ++++++++++++++++++++++++++------------------------- 1 files changed, 34 insertions(+), 33 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 608cf7a..0fae4cb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -728,7 +728,7 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, "Return the absolute value of @var{x}.") #define FUNC_NAME { - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { scm_t_inum xx = SCM_I_INUM (x); if (xx >= 0) @@ -774,18 +774,18 @@ SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); SCM scm_quotient (SCM x, SCM y) { - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { scm_t_inum xx = SCM_I_INUM (x); - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_quotient); else { scm_t_inum z = xx / yy; - if (SCM_FIXABLE (z)) + if (SCM_LIKELY (SCM_FIXABLE (z))) return SCM_I_MAKINUM (z); else return scm_i_inum2big (z); @@ -809,12 +809,12 @@ scm_quotient (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_quotient); - else if (yy == 1) + else if (SCM_UNLIKELY (yy == 1)) return x; else { @@ -858,15 +858,18 @@ SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); SCM scm_remainder (SCM x, SCM y) { - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_remainder); else { + /* C99 specifies that "%" is the remainder corresponding to a + quotient rounded towards zero, and that's also traditional + for machine division, so z here should be well defined. */ scm_t_inum z = SCM_I_INUM (x) % yy; return SCM_I_MAKINUM (z); } @@ -889,10 +892,10 @@ scm_remainder (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_remainder); else { @@ -931,13 +934,13 @@ SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo); SCM scm_modulo (SCM x, SCM y) { - if (SCM_I_INUMP (x)) + if (SCM_LIKELY (SCM_I_INUMP (x))) { scm_t_inum xx = SCM_I_INUM (x); - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_modulo); else { @@ -1008,10 +1011,10 @@ scm_modulo (SCM x, SCM y) } else if (SCM_BIGP (x)) { - if (SCM_I_INUMP (y)) + if (SCM_LIKELY (SCM_I_INUMP (y))) { scm_t_inum yy = SCM_I_INUM (y); - if (yy == 0) + if (SCM_UNLIKELY (yy == 0)) scm_num_overflow (s_modulo); else { @@ -1029,22 +1032,20 @@ scm_modulo (SCM x, SCM y) } else if (SCM_BIGP (y)) { - { - SCM result = scm_i_mkbig (); - int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); - SCM pos_y = scm_i_clonebig (y, y_sgn >= 0); - mpz_mod (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (pos_y)); + SCM result = scm_i_mkbig (); + int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); + SCM pos_y = scm_i_clonebig (y, y_sgn >= 0); + mpz_mod (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (pos_y)); - scm_remember_upto_here_1 (x); - if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) - mpz_add (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (y), - SCM_I_BIG_MPZ (result)); - scm_remember_upto_here_2 (y, pos_y); - return scm_i_normbig (result); - } + scm_remember_upto_here_1 (x); + if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) + mpz_add (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (y), + SCM_I_BIG_MPZ (result)); + scm_remember_upto_here_2 (y, pos_y); + return scm_i_normbig (result); } else SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); -- 1.5.6.5 [-- Warning: decoded text below may be mangled, UTF-8 assumed --] [-- Attachment #7: Implement efficient R6RS `div', `mod', et al --] [-- Type: text/x-diff, Size: 60957 bytes --] From a1dda78005b13c4b9dfa97b636f21e62dd3b0f38 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw@netris.org> Date: Sat, 29 Jan 2011 02:36:02 -0500 Subject: [PATCH] Implement efficient R6RS `div', `mod', et al * libguile/numbers.c (scm_div, scm_mod, scm_div_and_mod, scm_div0, scm_mod0, scm_div0_and_mod0): New extensible procedures `div', `mod', `div-and-mod', `div0', `mod0', `div0-and-mod0'. (scm_i_inexact_div, scm_i_inexact_mod, scm_i_inexact_div_and_mod, scm_i_inexact_div0, scm_i_inexact_mod0, scm_i_inexact_div0_and_mod0, scm_i_slow_exact_div, scm_i_slow_exact_mod, scm_i_slow_exact_div_and_mod, scm_i_slow_exact_div, scm_i_slow_exact_mod, scm_i_slow_exact_div_and_mod, scm_i_bigint_div0, scm_i_bigint_mod0, scm_i_bigint_div0_and_mod0): New internal static procedures, not intended to be used except by scm_div, scm_mod, scm_div_and_mod, scm_div0, scm_mod0, and scm_div0_and_mod0. * libguile/numbers.h: Add function prototypes. * module/rnrs/base.scm: Remove incorrect stub implementations of `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * module/rnrs/arithmetic/fixnums.scm (fxdiv, fxmod, fxdiv-and-mod, fxdiv0, fxmod0, fxdiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. (fx+/carry): Remove unneeded calls to `inexact->exact'. * module/rnrs/arithmetic/flonums.scm (fldiv, flmod, fldiv-and-mod, fldiv0, flmod0, fldiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. Remove unneeded calls to `inexact->exact' and `exact->inexact' * test-suite/tests/numbers.test: (test-eqv?): New internal predicate for comparing numerical outputs with expected values. Add extensive test code for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * test-suite/tests/r6rs-arithmetic-fixnums.test: Fix some broken test cases, and remove `unresolved' test markers for `fxdiv', `fxmod', `fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'. * test-suite/tests/r6rs-arithmetic-flonums.test: Remove `unresolved' test markers for `fldiv', `flmod', `fldiv-and-mod', `fldiv0', `flmod0', and `fldiv0-and-mod0'. * doc/ref/api-data.texi (Arithmetic): Document `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. (Operations on Integer Values): Add cross-references to `div', `mod', et al, from `quotient', `remainder', and `modulo'. * doc/ref/r6rs.texi (rnrs base): Remove stub descriptions for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. Instead, cross reference to their descriptions in the core arithmetic section. * NEWS: Add NEWS entry. --- NEWS | 16 + doc/ref/api-data.texi | 67 ++ doc/ref/r6rs.texi | 19 +- libguile/numbers.c | 1172 ++++++++++++++++++++++++- libguile/numbers.h | 6 + module/rnrs/arithmetic/fixnums.scm | 23 +- module/rnrs/arithmetic/flonums.scm | 31 +- module/rnrs/base.scm | 17 - test-suite/tests/numbers.test | 166 ++++- test-suite/tests/r6rs-arithmetic-fixnums.test | 23 +- test-suite/tests/r6rs-arithmetic-flonums.test | 9 +- 11 files changed, 1457 insertions(+), 92 deletions(-) diff --git a/NEWS b/NEWS index f45795e..085f2b9 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,22 @@ Changes in 1.9.15 (since the 1.9.14 prerelease): ** Changes and bugfixes in numerics code +**** New procedures: `div', `mod', `div-and-mod' et al + +Added efficient R6RS division operations to Guile core. These +procedures each accept two real numbers X and Y, where Y must be +non-zero. `div' returns an integer Q and `mod' returns a real R such +that X = R + Q * Y and 0 <= R < abs(Y). `div-and-mod' returns both Q +and R, and is more efficient than calling `div' and `mod' separately. +`div0', `mod0', and `div0-and-mod0' are similar except that +-abs(Y/2) <= R < abs(Y/2). + +**** `div0', `mod0', and `div0-and-mod0' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). R6RS states that (div0-and-mod0 123 -10) should +return -12 and 3, but previously it returned -12 and -7. + *** `eqv?' and `equal?' now compare numbers equivalently scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 4256e18..41702a9 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -897,6 +897,9 @@ sign as @var{n}. In all cases quotient and remainder satisfy (remainder 13 4) @result{} 1 (remainder -13 4) @result{} -1 @end lisp + +See also @code{div}, @code{mod} and related operations in +@ref{Arithmetic}. @end deffn @c begin (texi-doc-string "guile" "modulo") @@ -911,6 +914,9 @@ sign as @var{d}. (modulo 13 -4) @result{} -3 (modulo -13 -4) @result{} -1 @end lisp + +See also @code{div}, @code{mod} and related operations in +@ref{Arithmetic}. @end deffn @c begin (texi-doc-string "guile" "gcd") @@ -1130,6 +1136,12 @@ Returns the magnitude or angle of @var{z} as a @code{double}. @rnindex ceiling @rnindex truncate @rnindex round +@rnindex div +@rnindex mod +@rnindex div-and-mod +@rnindex div0 +@rnindex mod0 +@rnindex div0-and-mod0 The C arithmetic functions below always takes two arguments, while the Scheme functions can take an arbitrary number. When you need to @@ -1229,6 +1241,61 @@ respectively, but these functions take and return @code{double} values. @end deftypefn +@deffn {Scheme Procedure} div x y +@deffnx {Scheme Procedure} mod x y +@deffnx {Scheme Procedure} div-and-mod x y +@deffnx {C Function} scm_div (x y) +@deffnx {C Function} scm_mod (x y) +@deffnx {C Function} scm_div_and_mod (x y) +These procedures implement number-theoretic division. + +Each accepts two real numbers @var{x} and @var{y}, where @var{y} is +non-zero. @code{div} returns an integer @var{q} and @code{mod} returns +a real @var{r} such that @math{@var{x} = @var{r} + @var{q}*@var{y}} and +@math{0 <= @var{r} < abs(@var{y})}. @code{div-and-mod} returns both +values, and is more efficient than calling @code{div} and @code{mod} +separately. + +@lisp +(div 123 10) @result{} 12 +(mod 123 10) @result{} 3 +(div-and-mod 123 10) @result{} 12 and 3 +(div-and-mod 123 -10) @result{} -12 and 3 +(div-and-mod -123 10) @result{} -13 and 7 +(div-and-mod -123 -10) @result{} 13 and 7 +(div-and-mod -123.2 -63.5) @result{} 2.0 and 3.8 +(div-and-mod 125/7 -10/7) @result{} -12 and 5/7 +@end lisp +@end deffn + +@deffn {Scheme Procedure} div0 x y +@deffnx {Scheme Procedure} mod0 x y +@deffnx {Scheme Procedure} div0-and-mod0 x y +@deffnx {C Function} scm_div0 (x y) +@deffnx {C Function} scm_mod0 (x y) +@deffnx {C Function} scm_div0_and_mod0 (x y) +These procedures are similar to @code{div}, @code{mod}, and +@code{div-and-mod}, except that @code{mod0} returns values that lie +within a half-open interval centered on zero. + +Precisely, @code{div0} returns an integer @var{q} and @code{mod0} +returns a real @var{r} such that @math{@var{x} = @var{r} + +@var{q}*@var{y}} and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}. +@code{div0-and-mod0} returns both values, and is more efficient than +calling @code{div0} and @code{mod0} separately. + +@lisp +(div0 123 10) @result{} 12 +(mod0 123 10) @result{} 3 +(div0-and-mod0 123 10) @result{} 12 and 3 +(div0-and-mod0 123 -10) @result{} -12 and 3 +(div0-and-mod0 -123 10) @result{} -12 and -3 +(div0-and-mod0 -123 -10) @result{} 12 and -3 +(div0-and-mod0 -123.2 -63.5) @result{} 2.0 and 3.8 +(div0-and-mod0 125/7 -10/7) @result{} -13 and -5/7 +@end lisp +@end deffn + @node Scientific @subsubsection Scientific Functions diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 5fee65f..6439478 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2010 +@c Copyright (C) 2010, 2011 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -461,24 +461,13 @@ grouped below by the existing manual sections to which they correspond. @deffnx {Scheme Procedure} floor x @deffnx {Scheme Procedure} ceiling x @deffnx {Scheme Procedure} round x -@xref{Arithmetic}, for documentation. -@end deffn - -@deffn {Scheme Procedure} div x1 x2 +@deffnx {Scheme Procedure} div x1 x2 @deffnx {Scheme Procedure} mod x1 x2 @deffnx {Scheme Procedure} div-and-mod x1 x2 -These procedures implement number-theoretic division. - -@code{div-and-mod} returns two values, the respective results of -@code{(div x1 x2)} and @code{(mod x1 x2)}. -@end deffn - -@deffn {Scheme Procedure} div0 x1 x2 +@deffnx {Scheme Procedure} div0 x1 x2 @deffnx {Scheme Procedure} mod0 x1 x2 @deffnx {Scheme Procedure} div0-and-mod0 x1 x2 -These procedures are similar to @code{div}, @code{mod}, and -@code{div-and-mod}, except that @code{mod0} returns values that lie -within a half-open interval centered on zero. +@xref{Arithmetic}, for documentation. @end deffn @deffn {Scheme Procedure} exact-integer-sqrt k diff --git a/libguile/numbers.c b/libguile/numbers.c index 0fae4cb..5ade135 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -105,6 +105,7 @@ typedef scm_t_signed_bits scm_t_inum; static SCM flo0; +static SCM exactly_one_half; #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) @@ -1054,6 +1055,1175 @@ scm_modulo (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); } +static SCM scm_i_inexact_div (double x, double y); +static SCM scm_i_slow_exact_div (SCM x, SCM y); + +SCM_GPROC (s_div, "div", 2, 0, 0, scm_div, g_div); +/* "Return q = @var{x} div @var{y}, where x = r + q*y,\n" + * "q is an integer and 0 <= r < abs(y)." + * "@lisp\n" + * "(div 123 10) @result{} 12\n" + * "(div 123 -10) @result{} -12\n" + * "(div -123 10) @result{} -13\n" + * "(div -123 -10) @result{} 13\n" + * "@end lisp" + */ +SCM +scm_div (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + if (xx < 0 && xx < qq * yy) + { + if (yy > 0) + qq--; + else + qq++; + } + return SCM_I_MAKINUM (qq); + } + } + else if (SCM_BIGP (y)) + { + if (SCM_I_INUM (x) >= 0) + return SCM_INUM0; + else + return SCM_I_MAKINUM (- mpz_sgn (SCM_I_BIG_MPZ (y))); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div (x, y); + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div); + else + { + SCM q = scm_i_mkbig (); + if (yy > 0) + mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy); + else + { + mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (x); + return scm_i_normbig (q); + } + } + else if (SCM_BIGP (y)) + { + SCM q = scm_i_mkbig (); + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + mpz_fdiv_q (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + else + mpz_cdiv_q (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (q); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div (x, y); + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + else + return scm_i_inexact_div (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG1, s_div); +} + +static SCM +scm_i_inexact_div (double x, double y) +{ + if (SCM_LIKELY (y > 0)) + return scm_from_double (floor(x / y)); + else if (SCM_LIKELY (y < 0)) + return scm_from_double (ceil(x / y)); + else if (y == 0) + scm_num_overflow (s_div); /* or should we return a NaN? */ + else + return scm_nan (); +} + +/* Compute exact div the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG1, s_div); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div, x, y, SCM_ARG2, s_div); + else if (scm_is_true (scm_positive_p (y))) + return scm_floor (scm_divide (x, y)); + else if (scm_is_true (scm_negative_p (y))) + return scm_ceiling (scm_divide (x, y)); + else + scm_num_overflow (s_div); +} + +static SCM scm_i_inexact_mod (double x, double y); +static SCM scm_i_slow_exact_mod (SCM x, SCM y); + +SCM_GPROC (s_mod, "mod", 2, 0, 0, scm_mod, g_mod); +/* "Return r = @var{x} mod @var{y}, where x = r + q*y,\n" + * "q is an integer and 0 <= r < abs(y)." + * "@lisp\n" + * "(mod 123 10) @result{} 3\n" + * "(mod 123 -10) @result{} 3\n" + * "(mod -123 10) @result{} 7\n" + * "(mod -123 -10) @result{} 7\n" + * "@end lisp" + */ +SCM +scm_mod (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod); + else + { + scm_t_inum rr = SCM_I_INUM (x) % yy; + if (rr >= 0) + return SCM_I_MAKINUM (rr); + else if (yy > 0) + return SCM_I_MAKINUM (rr + yy); + else + return SCM_I_MAKINUM (rr - yy); + } + } + else if (SCM_BIGP (y)) + { + scm_t_inum xx = SCM_I_INUM (x); + if ((xx == SCM_MOST_NEGATIVE_FIXNUM) && + (0 == mpz_cmp_ui (SCM_I_BIG_MPZ (y), + - SCM_MOST_NEGATIVE_FIXNUM))) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + scm_remember_upto_here_1 (y); + return SCM_INUM0; + } + else if (xx >= 0) + return x; + else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + SCM r = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + return scm_i_normbig (r); + } + else + { + SCM r = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r)); + return scm_i_normbig (r); + } + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod); + else + { + scm_t_inum rr; + if (yy < 0) + yy = - yy; + rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + { + SCM r = scm_i_mkbig (); + mpz_mod (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (r); + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + else + return scm_i_inexact_mod (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_mod (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_mod (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG1, s_mod); +} + +static SCM +scm_i_inexact_mod (double x, double y) +{ + double q; + + /* Although it would be more efficient to use fmod here, we can't + because it would in some cases produce results inconsistent with + scm_i_inexact_div, such that x != r + q * y (not even close). In + particular, when x is very close to a multiple of y, then r might + be either 0.0 or abs(y)-epsilon, but those two cases must + correspond with different choices of q. If r = 0.0 then q must be + x/y, and if r = abs(y) then q must be (x-r)/y. If div chooses one + way and mod chooses the other, it would be bad. This problem + actually happened with (div 130.0 10/7) and (mod 130.0 10/7) on one + platform. */ + if (SCM_LIKELY (y > 0)) + q = floor(x / y); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y); + else if (y == 0) + scm_num_overflow (s_mod); /* or should we return a NaN? */ + else + return scm_nan (); + return scm_from_double (x - q * y); +} + +/* Compute exact mod the slow way: x-y*(x div y) + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_mod (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG1, s_mod); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod, x, y, SCM_ARG2, s_mod); + else if (scm_is_true (scm_positive_p (y))) + return scm_difference + (x, scm_product (y, scm_floor (scm_divide (x, y)))); + else if (scm_is_true (scm_negative_p (y))) + return scm_difference + (x, scm_product (y, scm_ceiling (scm_divide (x, y)))); + else + scm_num_overflow (s_mod); +} + + +static SCM scm_i_inexact_div_and_mod (double x, double y); +static SCM scm_i_slow_exact_div_and_mod (SCM x, SCM y); + +SCM_GPROC (s_div_and_mod, "div-and-mod", 2, 0, 0, + scm_div_and_mod, g_div_and_mod); +/* "Return q and r, where x = r + q*y," + * "q is an integer, and 0 <= r < abs(y)." + * "@lisp\n" + * "(div-and-mod 123 10) @result{} 12 and 3\n" + * "(div-and-mod 123 -10) @result{} -12 and 3\n" + * "(div-and-mod -123 10) @result{} -13 and 7\n" + * "(div-and-mod -123 -10) @result{} 13 and 7\n" + * "@end lisp" + */ +SCM +scm_div_and_mod (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div_and_mod); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (rr < 0) + { + if (yy > 0) + { rr += yy; qq--; } + else + { rr -= yy; qq++; } + } + return scm_values (scm_list_2 (SCM_I_MAKINUM (qq), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + { + scm_t_inum xx = SCM_I_INUM (x); + if (xx >= 0) + return scm_values (scm_list_2 (SCM_INUM0, x)); + else if ((xx == SCM_MOST_NEGATIVE_FIXNUM) && + (0 == mpz_cmp_ui (SCM_I_BIG_MPZ (y), + - SCM_MOST_NEGATIVE_FIXNUM))) + { + /* Special case: x == fixnum-min && y == abs (fixnum-min) */ + scm_remember_upto_here_1 (y); + return scm_values + (scm_list_2 (SCM_I_MAKINUM (-1), SCM_INUM0)); + } + else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + SCM r = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + return scm_values + (scm_list_2 (SCM_I_MAKINUM (-1), scm_i_normbig (r))); + } + else + { + SCM r = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); + scm_remember_upto_here_1 (y); + mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r)); + return scm_values (scm_list_2 (SCM_INUM1, scm_i_normbig (r))); + } + } + else if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div_and_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div_and_mod); + else + { + SCM q = scm_i_mkbig (); + SCM r = scm_i_mkbig (); + if (yy > 0) + mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), yy); + else + { + mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), -yy); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + } + scm_remember_upto_here_1 (x); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); + } + } + else if (SCM_BIGP (y)) + { + SCM q = scm_i_mkbig (); + SCM r = scm_i_mkbig (); + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + else + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (scm_i_big2dbl (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div_and_mod (x, y); + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + else + return scm_i_inexact_div_and_mod (SCM_REAL_VALUE (x), + scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div_and_mod (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div_and_mod (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG1, s_div_and_mod); +} + +static SCM +scm_i_inexact_div_and_mod (double x, double y) +{ + double q, r; + + if (SCM_LIKELY (y > 0)) + q = floor(x / y); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y); + else if (y == 0) + scm_num_overflow (s_div_and_mod); /* or should we return a NaN? */ + else + q = guile_NaN; + r = x - q * y; + return scm_values (scm_list_2 (scm_from_double (q), + scm_from_double (r))); +} + +/* Compute exact div and mod the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div_and_mod (SCM x, SCM y) +{ + SCM q, r; + + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG1, s_div_and_mod); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div_and_mod, x, y, SCM_ARG2, s_div_and_mod); + else if (scm_is_true (scm_positive_p (y))) + q = scm_floor (scm_divide (x, y)); + else if (scm_is_true (scm_negative_p (y))) + q = scm_ceiling (scm_divide (x, y)); + else + scm_num_overflow (s_div_and_mod); + r = scm_difference (x, scm_product (q, y)); + return scm_values (scm_list_2 (q, r)); +} + +static SCM scm_i_inexact_div0 (double x, double y); +static SCM scm_i_bigint_div0 (SCM x, SCM y); +static SCM scm_i_slow_exact_div0 (SCM x, SCM y); + +SCM_GPROC (s_div0, "div0", 2, 0, 0, scm_div0, g_div0); +/* "Return q = @var{x} div0 @var{y}, where x = r + q*y,\n" + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(div0 123 10) @result{} 12\n" + * "(div0 123 -10) @result{} -12\n" + * "(div0 -123 10) @result{} -12\n" + * "(div0 -123 -10) @result{} 12\n" + * "@end lisp" + */ +SCM +scm_div0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + qq++; + } + else + { + if (rr >= (1 - yy) / 2) + qq--; + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + qq--; + } + else + { + if (rr < yy / 2) + qq++; + } + } + return SCM_I_MAKINUM (qq); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_div0 */ + return scm_i_bigint_div0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div0 (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0); + else + { + SCM q = scm_i_mkbig (); + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + else + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + if (rr < yy / 2) + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + return scm_i_normbig (q); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_div0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_div0 (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + else + return scm_i_inexact_div0 (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG1, s_div0); +} + +static SCM +scm_i_inexact_div0 (double x, double y) +{ + if (SCM_LIKELY (y > 0)) + return scm_from_double (floor(x / y + 0.5)); + else if (SCM_LIKELY (y < 0)) + return scm_from_double (ceil(x / y - 0.5)); + else if (y == 0) + scm_num_overflow (s_div0); /* or should we return a NaN? */ + else + return scm_nan (); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_div0 (SCM x, SCM y) +{ + SCM q, r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + q = scm_i_mkbig (); + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y)/2 */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + else + { + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + } + scm_remember_upto_here_2 (r, min_r); + return scm_i_normbig (q); +} + +/* Compute exact div0 the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div0 (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG1, s_div0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0, x, y, SCM_ARG2, s_div0); + else if (scm_is_true (scm_positive_p (y))) + return scm_floor (scm_sum (scm_divide (x, y), exactly_one_half)); + else if (scm_is_true (scm_negative_p (y))) + return scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half)); + else + scm_num_overflow (s_div0); +} + +static SCM scm_i_inexact_mod0 (double x, double y); +static SCM scm_i_bigint_mod0 (SCM x, SCM y); +static SCM scm_i_slow_exact_mod0 (SCM x, SCM y); + +SCM_GPROC (s_mod0, "mod0", 2, 0, 0, scm_mod0, g_mod0); +/* "Return r = @var{x} mod0 @var{y}, where x = r + q*y,\n" + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(mod0 123 10) @result{} 3\n" + * "(mod0 123 -10) @result{} 3\n" + * "(mod0 -123 10) @result{} -3\n" + * "(mod0 -123 -10) @result{} -3\n" + * "@end lisp" + */ +SCM +scm_mod0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum rr = xx % yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + rr -= yy; + } + else + { + if (rr >= (1 - yy) / 2) + rr += yy; + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + rr += yy; + } + else + { + if (rr < yy / 2) + rr -= yy; + } + } + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_mod0 */ + return scm_i_bigint_mod0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_mod0 (SCM_I_INUM (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_mod0); + else + { + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + rr += yy; + } + else + { + rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + if (rr < yy / 2) + rr -= yy; + } + return SCM_I_MAKINUM (rr); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_mod0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_mod0 (scm_i_big2dbl (x), SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + else + return scm_i_inexact_mod0 (SCM_REAL_VALUE (x), scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_mod0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_mod0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG1, s_mod0); +} + +static SCM +scm_i_inexact_mod0 (double x, double y) +{ + double q; + + /* Although it would be more efficient to use fmod here, we can't + because it would in some cases produce results inconsistent with + scm_i_inexact_div0, such that x != r + q * y (not even close). In + particular, when x-y/2 is very close to a multiple of y, then r + might be either -abs(y/2) or abs(y/2)-epsilon, but those two cases + must correspond with different choices of q. If div0 chooses one + way and mod0 chooses the other, it would be bad. */ + if (SCM_LIKELY (y > 0)) + q = floor(x / y + 0.5); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y - 0.5); + else if (y == 0) + scm_num_overflow (s_mod0); /* or should we return a NaN? */ + else + return scm_nan (); + return scm_from_double (x - q * y); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_mod0 (SCM x, SCM y) +{ + SCM r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y)/2 */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_r (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_add (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + else + { + mpz_fdiv_r (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + mpz_sub (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + scm_remember_upto_here_2 (x, y); + return scm_i_normbig (r); +} + +/* Compute exact mod0 the slow way: x-y*(x div0 y) + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_mod0 (SCM x, SCM y) +{ + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG1, s_mod0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_mod0, x, y, SCM_ARG2, s_mod0); + else if (scm_is_true (scm_positive_p (y))) + return scm_difference + (x, scm_product (y, scm_floor (scm_sum (scm_divide (x, y), + exactly_one_half)))); + else if (scm_is_true (scm_negative_p (y))) + return scm_difference + (x, scm_product (y, scm_ceiling (scm_difference (scm_divide (x, y), + exactly_one_half)))); + else + scm_num_overflow (s_mod0); +} + + +static SCM scm_i_inexact_div0_and_mod0 (double x, double y); +static SCM scm_i_bigint_div0_and_mod0 (SCM x, SCM y); +static SCM scm_i_slow_exact_div0_and_mod0 (SCM x, SCM y); + +SCM_GPROC (s_div0_and_mod0, "div0-and-mod0", 2, 0, 0, + scm_div0_and_mod0, g_div0_and_mod0); +/* "Return q and r, where x = r + q*y," + * "q is an integer and -abs(y/2) <= r < abs(y/2)." + * "@lisp\n" + * "(div0-and-mod0 123 10) @result{} 12 and 3\n" + * "(div0-and-mod0 123 -10) @result{} -12 and 3\n" + * "(div0-and-mod0 -123 10) @result{} -12 and -3\n" + * "(div0-and-mod0 -123 -10) @result{} 12 and -3\n" + * "@end lisp" + */ +SCM +scm_div0_and_mod0 (SCM x, SCM y) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0_and_mod0); + else + { + scm_t_inum xx = SCM_I_INUM (x); + scm_t_inum qq = xx / yy; + scm_t_inum rr = xx - qq * yy; + if (SCM_LIKELY (xx > 0)) + { + if (SCM_LIKELY (yy > 0)) + { + if (rr >= (yy + 1) / 2) + { qq++; rr -= yy; } + } + else + { + if (rr >= (1 - yy) / 2) + { qq--; rr += yy; } + } + } + else + { + if (SCM_LIKELY (yy > 0)) + { + if (rr < -yy / 2) + { qq--; rr += yy; } + } + else + { + if (rr < yy / 2) + { qq++; rr -= yy; } + } + } + return scm_values (scm_list_2 (SCM_I_MAKINUM (qq), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + { + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_div0_and_mod0 */ + return scm_i_bigint_div0_and_mod0 + (scm_i_long2big (SCM_I_INUM (x)), y); + } + else if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (SCM_I_INUM (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0_and_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + } + else if (SCM_BIGP (x)) + { + if (SCM_LIKELY (SCM_I_INUMP (y))) + { + scm_t_inum yy = SCM_I_INUM (y); + if (SCM_UNLIKELY (yy == 0)) + scm_num_overflow (s_div0_and_mod0); + else + { + SCM q = scm_i_mkbig (); + scm_t_inum rr; + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (yy > 0) + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), yy); + scm_remember_upto_here_1 (x); + if (rr < -yy / 2) + { + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + rr += yy; + } + } + else + { + rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (x), -yy); + scm_remember_upto_here_1 (x); + mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); + if (rr < yy / 2) + { + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + rr -= yy; + } + } + return scm_values (scm_list_2 (scm_i_normbig (q), + SCM_I_MAKINUM (rr))); + } + } + else if (SCM_BIGP (y)) + return scm_i_bigint_div0_and_mod0 (x, y); + else if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (scm_i_big2dbl (x), + SCM_REAL_VALUE (y)); + else if (SCM_FRACTIONP (y)) + return scm_i_slow_exact_div0_and_mod0 (x, y); + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + } + else if (SCM_REALP (x)) + { + if (!(SCM_REALP (y) || SCM_I_INUMP (y) || + SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + else + return scm_i_inexact_div0_and_mod0 (SCM_REAL_VALUE (x), + scm_to_double (y)); + } + else if (SCM_FRACTIONP (x)) + { + if (SCM_REALP (y)) + return scm_i_inexact_div0_and_mod0 (scm_i_fraction2double (x), + SCM_REAL_VALUE (y)); + else + return scm_i_slow_exact_div0_and_mod0 (x, y); + } + else + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG1, s_div0_and_mod0); +} + +static SCM +scm_i_inexact_div0_and_mod0 (double x, double y) +{ + double q, r; + + if (SCM_LIKELY (y > 0)) + q = floor(x / y + 0.5); + else if (SCM_LIKELY (y < 0)) + q = ceil(x / y - 0.5); + else if (y == 0) + scm_num_overflow (s_div0_and_mod0); /* or should we return a NaN? */ + else + q = guile_NaN; + r = x - q * y; + return scm_values (scm_list_2 (scm_from_double (q), + scm_from_double (r))); +} + +/* Assumes that both x and y are bigints, though + x might be able to fit into a fixnum. */ +static SCM +scm_i_bigint_div0_and_mod0 (SCM x, SCM y) +{ + SCM q, r, min_r; + + /* Note that x might be small enough to fit into a + fixnum, so we must not let it escape into the wild */ + q = scm_i_mkbig (); + r = scm_i_mkbig (); + + /* min_r will eventually become -abs(y/2) */ + min_r = scm_i_mkbig (); + mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r), + SCM_I_BIG_MPZ (y), 1); + + /* Arrange for rr to initially be non-positive, + because that simplifies the test to see + if it is within the needed bounds. */ + if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) + { + mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + { + mpz_sub_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + mpz_add (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + } + else + { + mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); + if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0) + { + mpz_add_ui (SCM_I_BIG_MPZ (q), + SCM_I_BIG_MPZ (q), 1); + mpz_sub (SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (r), + SCM_I_BIG_MPZ (y)); + } + } + scm_remember_upto_here_2 (x, y); + return scm_values (scm_list_2 (scm_i_normbig (q), + scm_i_normbig (r))); +} + +/* Compute exact div0 and mod0 the slow way. + We use this only if both arguments are exact, + and at least one of them is a fraction */ +static SCM +scm_i_slow_exact_div0_and_mod0 (SCM x, SCM y) +{ + SCM q, r; + + if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG1, s_div0_and_mod0); + else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) + SCM_WTA_DISPATCH_2 (g_div0_and_mod0, x, y, SCM_ARG2, s_div0_and_mod0); + else if (scm_is_true (scm_positive_p (y))) + q = scm_floor (scm_sum (scm_divide (x, y), exactly_one_half)); + else if (scm_is_true (scm_negative_p (y))) + q = scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half)); + else + scm_num_overflow (s_div0_and_mod0); + r = scm_difference (x, scm_product (q, y)); + return scm_values (scm_list_2 (q, r)); +} + + SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1, (SCM x, SCM y, SCM rest), "Return the greatest common divisor of all parameter values.\n" @@ -5356,8 +6526,6 @@ SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0, } #undef FUNC_NAME -static SCM exactly_one_half; - SCM_DEFINE (scm_round_number, "round", 1, 0, 0, (SCM x), "Round the number @var{x} towards the nearest integer. " diff --git a/libguile/numbers.h b/libguile/numbers.h index 740dc80..4cc6095 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -177,6 +177,12 @@ SCM_API SCM scm_abs (SCM x); SCM_API SCM scm_quotient (SCM x, SCM y); SCM_API SCM scm_remainder (SCM x, SCM y); SCM_API SCM scm_modulo (SCM x, SCM y); +SCM_API SCM scm_div (SCM x, SCM y); +SCM_API SCM scm_mod (SCM x, SCM y); +SCM_API SCM scm_div_and_mod (SCM x, SCM y); +SCM_API SCM scm_div0 (SCM x, SCM y); +SCM_API SCM scm_mod0 (SCM x, SCM y); +SCM_API SCM scm_div0_and_mod0 (SCM x, SCM y); SCM_API SCM scm_gcd (SCM x, SCM y); SCM_API SCM scm_lcm (SCM n1, SCM n2); SCM_API SCM scm_logand (SCM n1, SCM n2); diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index c1f3571..befbe9d 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -1,6 +1,6 @@ ;;; fixnums.scm --- The R6RS fixnums arithmetic library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -175,40 +175,33 @@ (define (fxdiv fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (div fx1 fx2))) r)) + (div fx1 fx2)) (define (fxmod fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (mod fx1 fx2))) r)) + (mod fx1 fx2)) (define (fxdiv-and-mod fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) (div-and-mod fx1 fx2)) (define (fxdiv0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (div0 fx1 fx2))) r)) + (div0 fx1 fx2)) (define (fxmod0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (let ((r (mod0 fx1 fx2))) r)) + (mod0 fx1 fx2)) (define (fxdiv0-and-mod0 fx1 fx2) (assert-fixnum fx1 fx2) - (if (zero? fx2) (raise (make-assertion-violation))) - (call-with-values (lambda () (div0-and-mod0 fx1 fx2)) - (lambda (q r) (values q r)))) + (div0-and-mod0 fx1 fx2)) (define (fx+/carry fx1 fx2 fx3) (assert-fixnum fx1 fx2 fx3) (let* ((s (+ fx1 fx2 fx3)) - (s0 (mod0 s (inexact->exact (expt 2 (fixnum-width))))) - (s1 (div0 s (inexact->exact (expt 2 (fixnum-width)))))) + (s0 (mod0 s (expt 2 (fixnum-width)))) + (s1 (div0 s (expt 2 (fixnum-width))))) (values s0 s1))) (define (fx-/carry fx1 fx2 fx3) diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index 4fadbd0..b65c294 100644 --- a/module/rnrs/arithmetic/flonums.scm +++ b/module/rnrs/arithmetic/flonums.scm @@ -1,6 +1,6 @@ ;;; flonums.scm --- The R6RS flonums arithmetic library -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -127,40 +127,27 @@ (define (fldiv-and-mod fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (call-with-values (lambda () (div-and-mod fx1 fx2)) - (lambda (div mod) (values (exact->inexact div) - (exact->inexact mod)))))) + (div-and-mod fl1 fl2)) (define (fldiv fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (exact->inexact (quotient fx1 fx2)))) + (div fl1 fl2)) (define (flmod fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (exact->inexact (modulo fx1 fx2)))) + (mod fl1 fl2)) (define (fldiv0-and-mod0 fl1 fl2) (assert-iflonum fl1 fl2) - (if (zero? fl2) (raise (make-assertion-violation))) - (let* ((fx1 (inexact->exact fl1)) - (fx2 (inexact->exact fl2))) - (call-with-values (lambda () (div0-and-mod0 fx1 fx2)) - (lambda (q r) (values (real->flonum q) (real->flonum r)))))) + (div0-and-mod0 fl1 fl2)) (define (fldiv0 fl1 fl2) - (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q))) + (assert-iflonum fl1 fl2) + (div0 fl1 fl2)) (define (flmod0 fl1 fl2) - (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r))) + (assert-iflonum fl1 fl2) + (mod0 fl1 fl2)) (define (flnumerator fl) (assert-flonum fl) diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 04a7e23..37c574a 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -74,8 +74,6 @@ syntax-rules identifier-syntax) (import (rename (except (guile) error raise) - (quotient div) - (modulo mod) (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) @@ -119,21 +117,6 @@ (define (vector-map proc . vecs) (list->vector (apply map (cons proc (map vector->list vecs))))) - (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r))) - - (define (div0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q))) - - (define (mod0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r))) - - (define (div0-and-mod0 x y) - (call-with-values (lambda () (div-and-mod x y)) - (lambda (q r) - (cond ((< r (abs (/ y 2))) (values q r)) - ((negative? y) (values (- q 1) (+ r y))) - (else (values (+ q 1) (+ r y))))))) - (define raise (@ (rnrs exceptions) raise)) (define condition diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 36e3128..c89b98a 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -17,7 +17,8 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib) - #:use-module (ice-9 documentation)) + #:use-module (ice-9 documentation) + #:use-module (srfi srfi-11)) ; let-values ;;; ;;; miscellaneous @@ -92,6 +93,35 @@ (negative? obj) (inf? obj))) +;; +;; Tolerance used by test-eqv? for inexact numbers. +;; +(define test-epsilon 1e-10) + +;; +;; 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. +;; +(define (test-eqv? x y) + (cond ((real? x) + (and (real? y) (test-real-eqv? x y))) + ((complex? x) + (and (not (real? y)) + (test-real-eqv? (real-part x) (real-part y)) + (test-real-eqv? (imag-part x) (imag-part y)))) + (else (eqv? x y)))) + +;; Auxiliary predicate used by test-eqv? +(define (test-real-eqv? x y) + (cond ((or (exact? x) (zero? x) (nan? x) (inf? x)) + (eqv? x y)) + (else (and (inexact? y) (> test-epsilon (abs (- x y))))))) + (define const-e 2.7182818284590452354) (define const-e^2 7.3890560989306502274) (define const-1/e 0.3678794411714423215) @@ -3480,3 +3510,137 @@ (pass-if "-100i swings back to 45deg down" (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) +;;; +;;; div +;;; mod +;;; div-and-mod +;;; div0 +;;; mod0 +;;; div0-and-mod0 +;;; + +(with-test-prefix "Number-theoretic division" + + ;; Tests that (lo <= x < hi), + ;; but allowing for imprecision + ;; if x is inexact. + (define (test-within-range? lo hi x) + (if (exact? x) + (and (<= lo x) (< x hi)) + (let ((lo (- lo test-epsilon)) + (hi (+ hi test-epsilon))) + (<= lo x hi)))) + + (define (safe-div x y) + (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) + ((zero? y) (throw 'divide-by-zero)) + ((nan? y) (nan)) + ((positive? y) (floor (/ x y))) + ((negative? y) (ceiling (/ x y))) + (else (throw 'unknown-problem)))) + + (define (safe-mod x y) + (- x (* y (safe-div x y)))) + + (define (safe-div-and-mod x y) + (let ((q (safe-div x y)) + (r (safe-mod 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-div-and-mod-is-broken (list x y q r)) + (values q r)))) + + (define (safe-div0 x y) + (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) + ((zero? y) (throw 'divide-by-zero)) + ((nan? y) (nan)) + ((positive? y) (floor (+ 1/2 (/ x y)))) + ((negative? y) (ceiling (+ -1/2 (/ x y)))) + (else (throw 'unknown-problem)))) + + (define (safe-mod0 x y) + (- x (* y (safe-div0 x y)))) + + (define (safe-div0-and-mod0 x y) + (let ((q (safe-div0 x y)) + (r (safe-mod0 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-div0-and-mod0-is-broken (list x y q r)) + (values q r)))) + + (define test-numerators + (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) + (* 123 (+ 1 most-positive-fixnum)) (* 125 (+ 1 most-positive-fixnum)) (* 127 (+ 1 most-positive-fixnum)) + (* 130 (+ 1 most-positive-fixnum)) (* 3 (+ 1 most-positive-fixnum)) (* 5 (+ 1 most-positive-fixnum)) + (* 10 (+ 1 most-positive-fixnum)) + (* -123 (+ 1 most-positive-fixnum)) (* -125 (+ 1 most-positive-fixnum)) (* -127 (+ 1 most-positive-fixnum)) + (* -130 (+ 1 most-positive-fixnum)) (* -3 (+ 1 most-positive-fixnum)) (* -5 (+ 1 most-positive-fixnum)) + (* -10 (+ 1 most-positive-fixnum)) + (* 123 (+ 2 most-positive-fixnum)) (* 125 (+ 2 most-positive-fixnum)) (* 127 (+ 2 most-positive-fixnum)) + (* 130 (+ 2 most-positive-fixnum)) (* 3 (+ 2 most-positive-fixnum)) (* 5 (+ 2 most-positive-fixnum)) + (* 10 (+ 2 most-positive-fixnum)) + (* -123 (+ 2 most-positive-fixnum)) (* -125 (+ 2 most-positive-fixnum)) (* -127 (+ 2 most-positive-fixnum)) + (* -130 (+ 2 most-positive-fixnum)) (* -3 (+ 2 most-positive-fixnum)) (* -5 (+ 2 most-positive-fixnum)) + (* -10 (+ 2 most-positive-fixnum)))) + + (define test-denominators + (list 10 5 10/7 127/2 10.0 63.5 + -10 -5 -10/7 -127/2 -10.0 -63.5 + +inf.0 -inf.0 +nan.0 most-negative-fixnum + (+ 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)) + + (with-test-prefix "div" (do-tests-1 'div div safe-div)) + (with-test-prefix "mod" (do-tests-1 'mod mod safe-mod)) + (with-test-prefix "div-and-mod" + (do-tests-2 'div-and-mod + div-and-mod + safe-div-and-mod)) + + (with-test-prefix "div0" (do-tests-1 'div0 div0 safe-div0)) + (with-test-prefix "mod0" (do-tests-1 'mod0 mod0 safe-mod0)) + (with-test-prefix "div0-and-mod0" + (do-tests-2 'div0-and-mod0 + div0-and-mod0 + safe-div0-and-mod0))) diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index fed72eb..d39d544 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -1,6 +1,6 @@ ;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -121,32 +121,25 @@ (pass-if "simple" (call-with-values (lambda () (fxdiv-and-mod 123 10)) (lambda (d m) - (or (and (fx=? d 12) (fx=? m 3)) - (throw 'unresolved)))))) + (and (fx=? d 12) (fx=? m 3)))))) -(with-test-prefix "fxdiv" - (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved)))) - -(with-test-prefix "fxmod" - (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved)))) +(with-test-prefix "fxdiv" (pass-if "simple" (fx=? (fxdiv -123 10) -13))) +(with-test-prefix "fxmod" (pass-if "simple" (fx=? (fxmod -123 10) 7))) (with-test-prefix "fxdiv0-and-mod0" (pass-if "simple" (call-with-values (lambda () (fxdiv0-and-mod0 -123 10)) (lambda (d m) - (or (and (fx=? d 12) (fx=? m -3)) - (throw 'unresolved)))))) - -(with-test-prefix "fxdiv0" - (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved)))) + (and (fx=? d -12) (fx=? m -3)))))) -(with-test-prefix "fxmod0" - (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved)))) +(with-test-prefix "fxdiv0" (pass-if "simple" (fx=? (fxdiv0 -123 10) -12))) +(with-test-prefix "fxmod0" (pass-if "simple" (fx=? (fxmod0 -123 10) -3))) ;; Without working div and mod implementations and without any example results ;; from the spec, I have no idea what the results of these functions should ;; be. -juliang +;; UPDATE: div and mod implementations are now working properly -mhw (with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved))) diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test index 873447b..af9dbbf 100644 --- a/test-suite/tests/r6rs-arithmetic-flonums.test +++ b/test-suite/tests/r6rs-arithmetic-flonums.test @@ -1,6 +1,6 @@ ;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -195,14 +195,13 @@ (pass-if "simple" (call-with-values (lambda () (fldiv0-and-mod0 -123.0 10.0)) (lambda (div mod) - (or (and (fl=? div -12.0) (fl=? mod -3.0)) - (throw 'unresolved)))))) + (and (fl=? div -12.0) (fl=? mod -3.0)))))) (with-test-prefix "fldiv0" - (pass-if "simple" (or (fl=? (fldiv0 -123.0 10.0) -12.0) (throw 'unresolved)))) + (pass-if "simple" (fl=? (fldiv0 -123.0 10.0) -12.0))) (with-test-prefix "flmod0" - (pass-if "simple" (or (fl=? (flmod0 -123.0 10.0) -3.0) (throw 'unresolved)))) + (pass-if "simple" (fl=? (flmod0 -123.0 10.0) -3.0))) (with-test-prefix "flnumerator" (pass-if "simple" (fl=? (flnumerator 0.5) 1.0)) -- 1.5.6.5 ^ permalink raw reply related [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 8:20 ` Mark H Weaver @ 2011-01-29 17:42 ` Andy Wingo 2011-01-29 20:20 ` Mark H Weaver 2011-01-29 17:50 ` Andy Wingo 2011-01-30 12:12 ` Andy Wingo 2 siblings, 1 reply; 24+ messages in thread From: Andy Wingo @ 2011-01-29 17:42 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel Hi Mark, On Sat 29 Jan 2011 09:20, Mark H Weaver <mhw@netris.org> writes: > Andy Wingo <wingo@pobox.com> writes: > > if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) > + return SCM_BOOL_F; Doesn't this prevent 1.0+0.0i from being eqv or equal to 1.0 ? Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 17:42 ` Andy Wingo @ 2011-01-29 20:20 ` Mark H Weaver 2011-01-30 11:48 ` Andy Wingo 0 siblings, 1 reply; 24+ messages in thread From: Mark H Weaver @ 2011-01-29 20:20 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: >> if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) >> + return SCM_BOOL_F; > > Doesn't this prevent 1.0+0.0i from being eqv or equal to 1.0 ? No, because 1.0+0.0i never exists in the current code. At the top of numbers.c it says: > /* General assumptions: > * All objects satisfying SCM_COMPLEXP() have a non-zero complex component. and I have found this to be true. scm_c_make_rectangular is the primitive function that creates complex numbers, and it returns a real number if the imaginary part is zero. All other functions call it directly or indirectly. I know this well because I made a patch to allow the creation of complex numbers with inexact 0.0 imaginary part. In fact, I purposefully arranged for (eqv? 1.0+0.0i) to evaluate to #f, for the same reason that (eqv? 0.0 0) evaluates to #f. According to R6RS, a number is real only if its imaginary part is both zero and exact. Therefore, the imaginary part of any real number is an exact 0, otherwise it wouldn't be real. But the imaginary part of 1.0+0.0i is clearly an _inexact_ zero. R6RS explicitly states that eqv? returns #f if one number is exact and the other is inexact. So (eqv? 0.0 0) must be #f, and has been. The only remaining assumption here is that (eqv? z1 z2) works by comparing the real and imaginary parts component-wise using eqv?. If you agree with this, then it follows that any complex number, even one with an inexact zero imaginary part, must be unequal to _any_ real number. However, regardless of whether or not you agree with all this, the fact remains that currently, Guile never creates non-real complex numbers with zero imaginary part. So the patch is safe. Best, Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 20:20 ` Mark H Weaver @ 2011-01-30 11:48 ` Andy Wingo 0 siblings, 0 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-30 11:48 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Sat 29 Jan 2011 21:20, Mark H Weaver <mhw@netris.org> writes: > Andy Wingo <wingo@pobox.com> writes: >>> if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) >>> + return SCM_BOOL_F; >> >> Doesn't this prevent 1.0+0.0i from being eqv or equal to 1.0 ? > > No, because 1.0+0.0i never exists in the current code. Ah, so we don't have any back-compatibility to preserve here; cool. > it follows that any complex number, even one with an inexact zero > imaginary part, must be unequal to _any_ real number. I can't presume to have a deep understanding of math, but I do interpret the R6RS as supporting your arguments, so no problem. Thanks for humoring me with an explanation :) Cheers, Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 8:20 ` Mark H Weaver 2011-01-29 17:42 ` Andy Wingo @ 2011-01-29 17:50 ` Andy Wingo 2011-01-29 20:36 ` Mark H Weaver 2011-01-29 22:24 ` Mark H Weaver 2011-01-30 12:12 ` Andy Wingo 2 siblings, 2 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-29 17:50 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Sat 29 Jan 2011 09:20, Mark H Weaver <mhw@netris.org> writes: > * libguile/numbers.c (scm_div, scm_mod, scm_div_and_mod, scm_div0, > scm_mod0, scm_div0_and_mod0): New extensible procedures `div', `mod', > `div-and-mod', `div0', `mod0', `div0-and-mod0'. I wonder; should we use Taylor Campbell's names? From http://trac.sacrideo.us/wg/wiki/DivisionRiastradh. I am inclined to think so. It doesn't seem to me that there is any special reason to take the R6RS names here. What do you think? Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 17:50 ` Andy Wingo @ 2011-01-29 20:36 ` Mark H Weaver 2011-01-29 22:24 ` Mark H Weaver 1 sibling, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-29 20:36 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: >> * libguile/numbers.c (scm_div, scm_mod, scm_div_and_mod, scm_div0, >> scm_mod0, scm_div0_and_mod0): New extensible procedures `div', `mod', >> `div-and-mod', `div0', `mod0', `div0-and-mod0'. > > I wonder; should we use Taylor Campbell's names? From > http://trac.sacrideo.us/wg/wiki/DivisionRiastradh. I am inclined to > think so. It doesn't seem to me that there is any special reason to > take the R6RS names here. > > What do you think? Yeah, I think you're right. Although I find `div' and `mod' to be the most useful integer division operators, and will always bind them to short names in my programs, I worry that existing code out there may bind `div' and `mod' to something else, and that would probably be bad. I'll take care of it. Best, Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 17:50 ` Andy Wingo 2011-01-29 20:36 ` Mark H Weaver @ 2011-01-29 22:24 ` Mark H Weaver 2011-01-30 6:02 ` Commentary: R6RS div0-and-mod0 vs Taylor's `round/' Mark H Weaver 2011-01-30 11:50 ` [PATCH] First batch of numerics changes Andy Wingo 1 sibling, 2 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-29 22:24 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: > On Sat 29 Jan 2011 09:20, Mark H Weaver <mhw@netris.org> writes: > >> * libguile/numbers.c (scm_div, scm_mod, scm_div_and_mod, scm_div0, >> scm_mod0, scm_div0_and_mod0): New extensible procedures `div', `mod', >> `div-and-mod', `div0', `mod0', `div0-and-mod0'. > > I wonder; should we use Taylor Campbell's names? From > http://trac.sacrideo.us/wg/wiki/DivisionRiastradh. I am inclined to > think so. It doesn't seem to me that there is any special reason to > take the R6RS names here. I forgot to ask before: what names do you think we should use for div0, mod0, and div0-and-mod0? Taylor Campbell didn't name those. Thanks, Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Commentary: R6RS div0-and-mod0 vs Taylor's `round/' 2011-01-29 22:24 ` Mark H Weaver @ 2011-01-30 6:02 ` Mark H Weaver 2011-01-30 11:50 ` [PATCH] First batch of numerics changes Andy Wingo 1 sibling, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-30 6:02 UTC (permalink / raw) To: guile-devel Hello all, I decided to search for the rationale for the R6RS `div0-and-mod0' set of operators. Here's what I found from Will Clinger: http://srfi.schemers.org/srfi-77/mail-archive/msg00505.html What I take from this is that the designers of the R6RS division operators placed emphasis on the range of the remainder, to make it as compact and predictable as possible. The rounding policy of the quotient is considered unimportant; it must be whatever makes the remainder fit in the specified range. In the case of integer inputs with divisor D, both `mod' and `mod0' produce exactly D possible values, and that set of values depends only on the magnitude of D, not on the sign of N or D. In contrast, Taylor Campbell's proposal puts all emphasis on the rounding policy of his quotient operators, with the range of remainders considered secondary. http://trac.sacrideo.us/wg/wiki/DivisionRiastradh A case in point is Taylor's `round/' operator, which is _almost_ identical to the R6RS `div0-and-mod0'. They only time they produce different results is when the quotient is exactly half-way between two integers, and for integer arguments this can happen only when D is even. In this case, Taylor chooses to round to the even integer, and this implies that the set of possible remainders is not D but rather D+1. Another way to look at it is as follows: if you set D to some fixed integer and look at the output of (mod N D) as N loops over all the integers, then both R6RS `mod' and `mod0' will simply cycle through exactly D possible outputs. However, `round-remainder' does not quite do this when D is even. It will mostly cycle through its outputs, except for the two most extreme values, which are hit only half as often as all the others. Each time around the cycle, it will alternate which one it hits. Basically, the minimum value of `mod0' has been split into two different values in `round-remainder', increasing the total number of possible values from D to D+1. Personally, I think this is a poorly designed set of division operators. For those who are curious, given the contraints on `mod0's output range, `div0's rounding policy turns out to be as follows: half-integer quotients are rounded toward +inf when the divisor D is positive, and toward -inf when D is negative. Personally, I think that `div0-and-mod0' is far superior to `round/', because I think the range of remainders is much more important than how one rounds the half-integer quotients. As for the difference between R6RS `div-and-mod' (Taylor's `euclidean/') and `floor/', I don't think it matters much. In the cases I know of where the set of remainder values is important, D is generally positive, in which case `floor/' and `euclidean/' are the same. Taylor's `truncate/' (the same as R5RS quotient and remainder, as well as the C operators `/' and `%') have a different problem. If you use the outputs of % to index into a table, typically the divisor D is fixed but the dividend N may be less predictable. In this case you must be careful that the dividend N does not change sign. If it does, the remainder will change sign. This is a possible source of bugs. In some rare cases `truncate/' may truly be what you want, but in my experience, `euclidean/' is the most generally useful, and `floor/' is almost as good. The primary advantage to `truncate/' is that it is what most processors (and thus C) supports directly, and thus it can be implemented much more efficiently than the other division operators. Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 22:24 ` Mark H Weaver 2011-01-30 6:02 ` Commentary: R6RS div0-and-mod0 vs Taylor's `round/' Mark H Weaver @ 2011-01-30 11:50 ` Andy Wingo 1 sibling, 0 replies; 24+ messages in thread From: Andy Wingo @ 2011-01-30 11:50 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Sat 29 Jan 2011 23:24, Mark H Weaver <mhw@netris.org> writes: > I forgot to ask before: what names do you think we should use for div0, > mod0, and div0-and-mod0? Taylor Campbell didn't name those. I think he considered these a mistake, and it seems the R7RS will probably agree, so perhaps we can continue to have these implemented in Scheme, in the R6RS modules. Regards, Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-29 8:20 ` Mark H Weaver 2011-01-29 17:42 ` Andy Wingo 2011-01-29 17:50 ` Andy Wingo @ 2011-01-30 12:12 ` Andy Wingo 2011-01-30 16:33 ` Mark H Weaver 2 siblings, 1 reply; 24+ messages in thread From: Andy Wingo @ 2011-01-30 12:12 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel On Sat 29 Jan 2011 09:20, Mark H Weaver <mhw@netris.org> writes: > @@ -728,7 +728,7 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, > "Return the absolute value of @var{x}.") > #define FUNC_NAME > { > - if (SCM_I_INUMP (x)) > + if (SCM_LIKELY (SCM_I_INUMP (x))) > { > scm_t_inum xx = SCM_I_INUM (x); > if (xx >= 0) Is this really likely the case? Probably not. I'm going to hold off on this patch, unless you really want it in. I applied the other four in your series, though not including the div0 one. Thanks for the patches! Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-30 12:12 ` Andy Wingo @ 2011-01-30 16:33 ` Mark H Weaver 0 siblings, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-30 16:33 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: > On Sat 29 Jan 2011 09:20, Mark H Weaver <mhw@netris.org> writes: > >> @@ -728,7 +728,7 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, >> "Return the absolute value of @var{x}.") >> #define FUNC_NAME >> { >> - if (SCM_I_INUMP (x)) >> + if (SCM_LIKELY (SCM_I_INUMP (x))) >> { >> scm_t_inum xx = SCM_I_INUM (x); >> if (xx >= 0) > > Is this really likely the case? Probably not. I'm going to hold off on > this patch, unless you really want it in. Well, my thinking there was that floating-point operations in Guile are probably very slow anyway, since they require heap allocations (right?), so a few mispredicted branches are probably not going to make much difference there. I felt that the fixnum case should get the fast path. However, you may be right that abs(x) is rarely used on exact integers. I just submitted a new version of this patch with that hunk skipped. Thanks! Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-26 16:32 [PATCH] First batch of numerics changes Mark H Weaver 2011-01-26 18:07 ` Mark H Weaver 2011-01-26 22:46 ` Mark H Weaver @ 2011-01-28 11:41 ` Andy Wingo 2011-01-28 23:36 ` Mark H Weaver 2 siblings, 1 reply; 24+ messages in thread From: Andy Wingo @ 2011-01-28 11:41 UTC (permalink / raw) To: Mark H Weaver; +Cc: guile-devel Hi Mark, On Wed 26 Jan 2011 17:32, Mark H Weaver <mhw@netris.org> writes: I don't understand this change: > From c42d03050ea0f96556e73e405e530b78bb85aba7 Mon Sep 17 00:00:00 2001 > From: Mark H Weaver <mhw@netris.org> > Date: Wed, 26 Jan 2011 02:56:20 -0500 > Subject: [PATCH] Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p > > * libguile/eq.c (scm_equal_p): Add a special case for fractions with > differing SCM_CELL_TYPE, which might nonetheless be considered equal > (due to the use of 0x10000 as a flag), to scm_equal_p. This code > was already present in scm_eqv_p. > > (scm_eqv_p): Move comment (regarding special case for fractions) > next to the corresponding code. > --- > libguile/eq.c | 19 +++++++++++++------ > 1 files changed, 13 insertions(+), 6 deletions(-) > > diff --git a/libguile/eq.c b/libguile/eq.c > index 7502559..dc548b8 100644 > @@ -322,6 +322,13 @@ scm_equal_p (SCM x, SCM y) > && SCM_COMPLEX_IMAG (x) == 0.0); > } > > + /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer), > + but this checks the entire type word, so fractions may be accidentally > + flagged here as unequal. Perhaps I should use the 4th double_cell word? > + */ > + if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y)) > + return scm_i_fraction_equalp (x, y); > + > /* Vectors can be equal to one-dimensional arrays. > */ > if (scm_is_array (x) && scm_is_array (y)) In what case would two fractions ever not have the same SCM_CELL_TYPE ? I don't understand this discussion of flags. AFAICS fractions have their own tc16, and no flags are ever set. Furthermore I would think that the `if (SCM_NUMP (x))' block in scm_eqv_p could use a switch statement instead of a bunch of ifs. Regards, Andy -- http://wingolog.org/ ^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] First batch of numerics changes 2011-01-28 11:41 ` Andy Wingo @ 2011-01-28 23:36 ` Mark H Weaver 0 siblings, 0 replies; 24+ messages in thread From: Mark H Weaver @ 2011-01-28 23:36 UTC (permalink / raw) To: Andy Wingo; +Cc: guile-devel Andy Wingo <wingo@pobox.com> writes: > I don't understand this change: > >> From c42d03050ea0f96556e73e405e530b78bb85aba7 Mon Sep 17 00:00:00 2001 >> From: Mark H Weaver <mhw@netris.org> >> Date: Wed, 26 Jan 2011 02:56:20 -0500 >> Subject: [PATCH] Add case for fractions with differing SCM_CELL_TYPE to scm_equal_p >> >> * libguile/eq.c (scm_equal_p): Add a special case for fractions with >> differing SCM_CELL_TYPE, which might nonetheless be considered equal >> (due to the use of 0x10000 as a flag), to scm_equal_p. This code >> was already present in scm_eqv_p. To be honest, I didn't investigate until now. I just wanted to make `equal?' act the same as `eqv?' for numbers, and it seemed prudent to copy that code over. I didn't consider the possibility that the code was useless, but now I see that it should be removed from both places. > In what case would two fractions ever not have the same SCM_CELL_TYPE ? > I don't understand this discussion of flags. AFAICS fractions have their > own tc16, and no flags are ever set. Judging from the following test case at the end of numbers.test, I guess there was a tentative plan to implement a "lazy reduction bit" for fractions, presumably meaning that they would not be reduced to lowest terms until the first time their numerator or denominator was accessed. > (with-test-prefix "equal?" > (pass-if > > ;; lazy reduction bit for rationals should not affect equal? > (equal? 1/2 ((lambda (x) (denominator x) x) 1/2)))) However, from looking at the code for handling fractions, it is clear that this plan was never implemented. I will submit a patch to get rid of that cruft. > Furthermore I would think that the `if (SCM_NUMP (x))' block in > scm_eqv_p could use a switch statement instead of a bunch of ifs. Agreed, I will do it. Mark ^ permalink raw reply [flat|nested] 24+ messages in thread
end of thread, other threads:[~2011-01-30 16:33 UTC | newest] Thread overview: 24+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2011-01-26 16:32 [PATCH] First batch of numerics changes Mark H Weaver 2011-01-26 18:07 ` Mark H Weaver 2011-01-26 22:46 ` Mark H Weaver 2011-01-27 22:06 ` Mark H Weaver 2011-01-28 12:19 ` Andy Wingo 2011-01-29 0:05 ` Mark H Weaver 2011-01-29 11:29 ` Andy Wingo 2011-01-27 22:32 ` Mark H Weaver 2011-01-28 13:46 ` Andy Wingo 2011-01-28 14:44 ` Noah Lavine 2011-01-28 15:55 ` Andy Wingo 2011-01-29 8:20 ` Mark H Weaver 2011-01-29 17:42 ` Andy Wingo 2011-01-29 20:20 ` Mark H Weaver 2011-01-30 11:48 ` Andy Wingo 2011-01-29 17:50 ` Andy Wingo 2011-01-29 20:36 ` Mark H Weaver 2011-01-29 22:24 ` Mark H Weaver 2011-01-30 6:02 ` Commentary: R6RS div0-and-mod0 vs Taylor's `round/' Mark H Weaver 2011-01-30 11:50 ` [PATCH] First batch of numerics changes Andy Wingo 2011-01-30 12:12 ` Andy Wingo 2011-01-30 16:33 ` Mark H Weaver 2011-01-28 11:41 ` Andy Wingo 2011-01-28 23:36 ` Mark H Weaver
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).