mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Remove support for allowing exact numbers to be divided by zero

Browse source 
* libguile/numbers.c: We require IEEE infinities and NaN so there is no
case in which ALLOW_DIVIDE_BY_ZERO would not be defined.
(scm_divide, scm_tan, scm_tanh, scm_log, scm_log10): Always throw on
overflow for divide by exact zero, never throw for divide by inexact
zero.
This commit is contained in:
Andy Wingo 2022-01-04 21:21:02 +01:00
parent 9179525a05
commit 3e08c9cec0
1 changed files with 18 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

120
libguile/numbers.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2016,2018-2021 /* Copyright 1995-2016,2018-2022
Free Software Foundation, Inc. Free Software Foundation, Inc.
Portions Copyright 1990-1993 by AT&T Bell Laboratories and Bellcore. Portions Copyright 1990-1993 by AT&T Bell Laboratories and Bellcore.
@ -5549,12 +5549,6 @@ scm_product (SCM x, SCM y)
return product (x, y); return product (x, y);
} }
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
|| (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
#define ALLOW_DIVIDE_BY_ZERO
/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
#endif
/* The code below for complex division is adapted from the GNU /* The code below for complex division is adapted from the GNU
libstdc++, which adapted it from f2c's libF77, and is subject to libstdc++, which adapted it from f2c's libF77, and is subject to
this copyright: */ this copyright: */
@ -5616,25 +5610,15 @@ scm_divide (SCM x, SCM y)
scm_t_inum xx = SCM_I_INUM (x); scm_t_inum xx = SCM_I_INUM (x);
if (xx == 1 || xx == -1) if (xx == 1 || xx == -1)
return x; return x;
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
else if (xx == 0) else if (xx == 0)
scm_num_overflow (s_divide); scm_num_overflow (s_divide);
#endif
else else
return scm_i_make_ratio_already_reduced (SCM_INUM1, x); return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
} }
else if (SCM_BIGP (x)) else if (SCM_BIGP (x))
return scm_i_make_ratio_already_reduced (SCM_INUM1, x); return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
else if (SCM_REALP (x)) else if (SCM_REALP (x))
{ return scm_i_from_double (1.0 / SCM_REAL_VALUE (x));
double xx = SCM_REAL_VALUE (x);
#ifndef ALLOW_DIVIDE_BY_ZERO
if (xx == 0.0)
scm_num_overflow (s_divide);
else
#endif
return scm_i_from_double (1.0 / xx);
}
else if (SCM_COMPLEXP (x)) else if (SCM_COMPLEXP (x))
{ {
double r = SCM_COMPLEX_REAL (x); double r = SCM_COMPLEX_REAL (x);
@ -5666,13 +5650,7 @@ scm_divide (SCM x, SCM y)
{ {
scm_t_inum yy = SCM_I_INUM (y); scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0) if (yy == 0)
{ scm_num_overflow (s_divide);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
scm_num_overflow (s_divide);
#else
return scm_i_from_double ((double) xx / (double) yy);
#endif
}
else if (xx % yy != 0) else if (xx % yy != 0)
return scm_i_make_ratio (x, y); return scm_i_make_ratio (x, y);
else else
@ -5687,18 +5665,10 @@ scm_divide (SCM x, SCM y)
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
return scm_i_make_ratio (x, y); return scm_i_make_ratio (x, y);
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ /* FIXME: Precision may be lost here due to:
double yy = SCM_REAL_VALUE (y); (1) The cast from 'scm_t_inum' to 'double'
#ifndef ALLOW_DIVIDE_BY_ZERO (2) Double rounding */
if (yy == 0.0) return scm_i_from_double ((double) xx / SCM_REAL_VALUE (y));
scm_num_overflow (s_divide);
else
#endif
/* FIXME: Precision may be lost here due to:
(1) The cast from 'scm_t_inum' to 'double'
(2) Double rounding */
return scm_i_from_double ((double) xx / yy);
}
else if (SCM_COMPLEXP (y)) else if (SCM_COMPLEXP (y))
{ {
a = xx; a = xx;
@ -5733,15 +5703,7 @@ scm_divide (SCM x, SCM y)
{ {
scm_t_inum yy = SCM_I_INUM (y); scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0) if (yy == 0)
{ scm_num_overflow (s_divide);
#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
}
else if (yy == 1) else if (yy == 1)
return x; return x;
else else
@ -5787,17 +5749,9 @@ scm_divide (SCM x, SCM y)
return scm_i_make_ratio (x, y); return scm_i_make_ratio (x, y);
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ /* FIXME: Precision may be lost here due to:
double yy = SCM_REAL_VALUE (y); (1) scm_i_big2dbl (2) Double rounding */
#ifndef ALLOW_DIVIDE_BY_ZERO return scm_i_from_double (scm_i_big2dbl (x) / SCM_REAL_VALUE (y));
if (yy == 0.0)
scm_num_overflow (s_divide);
else
#endif
/* FIXME: Precision may be lost here due to:
(1) scm_i_big2dbl (2) Double rounding */
return scm_i_from_double (scm_i_big2dbl (x) / yy);
}
else if (SCM_COMPLEXP (y)) else if (SCM_COMPLEXP (y))
{ {
a = scm_i_big2dbl (x); a = scm_i_big2dbl (x);
@ -5815,11 +5769,9 @@ scm_divide (SCM x, SCM y)
if (SCM_I_INUMP (y)) if (SCM_I_INUMP (y))
{ {
scm_t_inum yy = SCM_I_INUM (y); scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0) if (yy == 0)
scm_num_overflow (s_divide); scm_num_overflow (s_divide);
else else
#endif
/* FIXME: Precision may be lost here due to: /* FIXME: Precision may be lost here due to:
(1) The cast from 'scm_t_inum' to 'double' (1) The cast from 'scm_t_inum' to 'double'
(2) Double rounding */ (2) Double rounding */
@ -5835,15 +5787,7 @@ scm_divide (SCM x, SCM y)
return scm_i_from_double (rx / dby); return scm_i_from_double (rx / dby);
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ return scm_i_from_double (rx / SCM_REAL_VALUE (y));
double yy = SCM_REAL_VALUE (y);
#ifndef ALLOW_DIVIDE_BY_ZERO
if (yy == 0.0)
scm_num_overflow (s_divide);
else
#endif
return scm_i_from_double (rx / yy);
}
else if (SCM_COMPLEXP (y)) else if (SCM_COMPLEXP (y))
{ {
a = rx; a = rx;
@ -5861,11 +5805,9 @@ scm_divide (SCM x, SCM y)
if (SCM_I_INUMP (y)) if (SCM_I_INUMP (y))
{ {
scm_t_inum yy = SCM_I_INUM (y); scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0) if (yy == 0)
scm_num_overflow (s_divide); scm_num_overflow (s_divide);
else else
#endif
{ {
/* FIXME: Precision may be lost here due to: /* FIXME: Precision may be lost here due to:
(1) The conversion from 'scm_t_inum' to double (1) The conversion from 'scm_t_inum' to double
@ -5886,12 +5828,7 @@ scm_divide (SCM x, SCM y)
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ {
double yy = SCM_REAL_VALUE (y); double yy = SCM_REAL_VALUE (y);
#ifndef ALLOW_DIVIDE_BY_ZERO return scm_c_make_rectangular (rx / yy, ix / yy);
if (yy == 0.0)
scm_num_overflow (s_divide);
else
#endif
return scm_c_make_rectangular (rx / yy, ix / yy);
} }
else if (SCM_COMPLEXP (y)) else if (SCM_COMPLEXP (y))
{ {
@ -5926,11 +5863,9 @@ scm_divide (SCM x, SCM y)
if (SCM_I_INUMP (y)) if (SCM_I_INUMP (y))
{ {
scm_t_inum yy = SCM_I_INUM (y); scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0) if (yy == 0)
scm_num_overflow (s_divide); scm_num_overflow (s_divide);
else else
#endif
return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x), return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
scm_product (SCM_FRACTION_DENOMINATOR (x), y)); scm_product (SCM_FRACTION_DENOMINATOR (x), y));
} }
@ -5940,18 +5875,11 @@ scm_divide (SCM x, SCM y)
scm_product (SCM_FRACTION_DENOMINATOR (x), y)); scm_product (SCM_FRACTION_DENOMINATOR (x), y));
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
{ /* FIXME: Precision may be lost here due to:
double yy = SCM_REAL_VALUE (y); (1) The conversion from fraction to double
#ifndef ALLOW_DIVIDE_BY_ZERO (2) Double rounding */
if (yy == 0.0) return scm_i_from_double (scm_i_fraction2double (x) /
scm_num_overflow (s_divide); SCM_REAL_VALUE (y));
else
#endif
/* FIXME: Precision may be lost here due to:
(1) The conversion from fraction to double
(2) Double rounding */
return scm_i_from_double (scm_i_fraction2double (x) / yy);
}
else if (SCM_COMPLEXP (y)) else if (SCM_COMPLEXP (y))
{ {
/* FIXME: Precision may be lost here due to: /* FIXME: Precision may be lost here due to:
@ -6195,10 +6123,6 @@ SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
x = 2.0 * SCM_COMPLEX_REAL (z); x = 2.0 * SCM_COMPLEX_REAL (z);
y = 2.0 * SCM_COMPLEX_IMAG (z); y = 2.0 * SCM_COMPLEX_IMAG (z);
w = cos (x) + cosh (y); w = cos (x) + cosh (y);
#ifndef ALLOW_DIVIDE_BY_ZERO
if (w == 0.0)
scm_num_overflow (s_scm_tan);
#endif
return scm_c_make_rectangular (sin (x) / w, sinh (y) / w); return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
} }
else else
@ -6262,10 +6186,6 @@ SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
x = 2.0 * SCM_COMPLEX_REAL (z); x = 2.0 * SCM_COMPLEX_REAL (z);
y = 2.0 * SCM_COMPLEX_IMAG (z); y = 2.0 * SCM_COMPLEX_IMAG (z);
w = cosh (x) + cos (y); w = cosh (x) + cos (y);
#ifndef ALLOW_DIVIDE_BY_ZERO
if (w == 0.0)
scm_num_overflow (s_scm_tanh);
#endif
return scm_c_make_rectangular (sinh (x) / w, sin (y) / w); return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
} }
else else
@ -7363,10 +7283,8 @@ SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
return log_of_shifted_double (SCM_REAL_VALUE (z), 0); return log_of_shifted_double (SCM_REAL_VALUE (z), 0);
else if (SCM_I_INUMP (z)) else if (SCM_I_INUMP (z))
{ {
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (scm_is_eq (z, SCM_INUM0)) if (scm_is_eq (z, SCM_INUM0))
scm_num_overflow (s_scm_log); scm_num_overflow (s_scm_log);
#endif
return log_of_shifted_double (SCM_I_INUM (z), 0); return log_of_shifted_double (SCM_I_INUM (z), 0);
} }
else if (SCM_BIGP (z)) else if (SCM_BIGP (z))
@ -7402,10 +7320,8 @@ SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0,
} }
else if (SCM_REALP (z) || SCM_I_INUMP (z)) else if (SCM_REALP (z) || SCM_I_INUMP (z))
{ {
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (scm_is_eq (z, SCM_INUM0)) if (scm_is_eq (z, SCM_INUM0))
scm_num_overflow (s_scm_log10); scm_num_overflow (s_scm_log10);
#endif
{ {
double re = scm_to_double (z); double re = scm_to_double (z);
double l = log10 (fabs (re)); double l = log10 (fabs (re));