From: Mark H Weaver <mhw@netris.org>
To: guile-devel@gnu.org
Subject: Re: [PATCH] First batch of numerics changes
Date: Wed, 26 Jan 2011 17:46:25 -0500 [thread overview]
Message-ID: <87tygv4726.fsf@yeeloong.netris.org> (raw)
In-Reply-To: <87lj2762xc.fsf@yeeloong.netris.org> (Mark H. Weaver's message of "Wed, 26 Jan 2011 11:32:47 -0500")
[-- 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
next prev parent reply other threads:[~2011-01-26 22:46 UTC|newest]
Thread overview: 24+ messages / expand[flat|nested] mbox.gz Atom feed top
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 [this message]
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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87tygv4726.fsf@yeeloong.netris.org \
--to=mhw@netris.org \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).