mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Simplify implementation of min, max

Browse source 
* libguile/numbers.c (scm_max, scm_min): Lean more on scm_is_less_than.
This commit is contained in:
Andy Wingo 2022-01-04 14:42:13 +01:00
parent f507c97380
commit 281aed8aa0
1 changed files with 47 additions and 283 deletions
Download patch file Download diff file Expand all files Collapse all files

330
libguile/numbers.c
View file

@ -5025,172 +5025,43 @@ SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
} }
#undef FUNC_NAME #undef FUNC_NAME
#define s_max s_scm_i_max
#define g_max g_scm_i_max
SCM SCM
scm_max (SCM x, SCM y) scm_max (SCM x, SCM y)
{ {
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
{ {
if (SCM_UNBNDP (x)) if (SCM_UNBNDP (x))
return scm_wta_dispatch_0 (g_max, s_max); return scm_wta_dispatch_0 (g_scm_i_max, s_scm_i_max);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) else if (scm_is_real (x))
return x; return x;
else else
return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max); return scm_wta_dispatch_1 (g_scm_i_max, x, SCM_ARG1, s_scm_i_max);
} }
if (SCM_I_INUMP (x)) if (!scm_is_real (x))
{ return scm_wta_dispatch_2 (g_scm_i_max, x, y, SCM_ARG1, s_scm_i_max);
scm_t_inum xx = SCM_I_INUM (x); if (!scm_is_real (y))
if (SCM_I_INUMP (y)) return scm_wta_dispatch_2 (g_scm_i_max, x, y, SCM_ARG2, s_scm_i_max);
{
scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? y : x;
}
else if (SCM_BIGP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return (sgn < 0) ? x : y;
}
else if (SCM_REALP (y))
{
double xxd = xx;
double yyd = SCM_REAL_VALUE (y);
if (xxd > yyd) if (scm_is_exact (x) && scm_is_exact (y))
return scm_i_from_double (xxd); return scm_is_less_than (x, y) ? y : x;
/* If y is a NaN, then "==" is false and we return the NaN */
else if (SCM_LIKELY (!(xxd == yyd)))
return y;
/* Handle signed zeroes properly */
else if (xx == 0)
return flo0;
else
return y;
}
else if (SCM_FRACTIONP (y))
{
use_less:
return (scm_is_false (scm_less_p (x, y)) ? x : y);
}
else
return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
scm_remember_upto_here_1 (x);
return (sgn < 0) ? y : x;
}
else if (SCM_BIGP (y))
{
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
scm_remember_upto_here_2 (x, y);
return (cmp > 0) ? x : y;
}
else if (SCM_REALP (y))
{
/* if y==NaN then xx>yy is false, so we return the NaN y */
double xx, yy;
big_real:
xx = scm_i_big2dbl (x);
yy = SCM_REAL_VALUE (y);
return (xx > yy ? scm_i_from_double (xx) : y);
}
else if (SCM_FRACTIONP (y))
{
goto use_less;
}
else
return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
{
scm_t_inum yy = SCM_I_INUM (y);
double xxd = SCM_REAL_VALUE (x);
double yyd = yy;
if (yyd > xxd) x = SCM_REALP (x) ? x : scm_exact_to_inexact (x);
return scm_i_from_double (yyd); y = SCM_REALP (y) ? y : scm_exact_to_inexact (y);
/* If x is a NaN, then "==" is false and we return the NaN */ double xx = SCM_REAL_VALUE (x);
else if (SCM_LIKELY (!(xxd == yyd))) double yy = SCM_REAL_VALUE (y);
return x; if (isnan (xx))
/* Handle signed zeroes properly */ return x;
else if (yy == 0) if (isnan (yy))
return flo0; return y;
else if (xx < yy)
return x; return y;
} if (xx > yy)
else if (SCM_BIGP (y)) return x;
{ // Distinguish -0.0 from 0.0.
SCM_SWAP (x, y); return (copysign (1.0, xx) < 0) ? y : x;
goto big_real;
}
else if (SCM_REALP (y))
{
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
/* For purposes of max: nan > +inf.0 > everything else,
per the R6RS errata */
if (xx > yy)
return x;
else if (SCM_LIKELY (xx < yy))
return y;
/* If neither (xx > yy) nor (xx < yy), then
either they're equal or one is a NaN */
else if (SCM_UNLIKELY (xx != yy))
return (xx != xx) ? x : y; /* Return the NaN */
/* xx == yy, but handle signed zeroes properly */
else if (copysign (1.0, yy) < 0.0)
return x;
else
return y;
}
else if (SCM_FRACTIONP (y))
{
double yy = scm_i_fraction2double (y);
double xx = SCM_REAL_VALUE (x);
return (xx < yy) ? scm_i_from_double (yy) : x;
}
else
return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_FRACTIONP (x))
{
if (SCM_I_INUMP (y))
{
goto use_less;
}
else if (SCM_BIGP (y))
{
goto use_less;
}
else if (SCM_REALP (y))
{
double xx = scm_i_fraction2double (x);
/* if y==NaN then ">" is false, so we return the NaN y */
return (xx > SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{
goto use_less;
}
else
return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else
return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
} }
SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1, SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
(SCM x, SCM y, SCM rest), (SCM x, SCM y, SCM rest),
"Return the minimum of all parameter values.") "Return the minimum of all parameter values.")
@ -5205,148 +5076,41 @@ SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
} }
#undef FUNC_NAME #undef FUNC_NAME
#define s_min s_scm_i_min
#define g_min g_scm_i_min
SCM SCM
scm_min (SCM x, SCM y) scm_min (SCM x, SCM y)
{ {
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
{ {
if (SCM_UNBNDP (x)) if (SCM_UNBNDP (x))
return scm_wta_dispatch_0 (g_min, s_min); return scm_wta_dispatch_0 (g_scm_i_min, s_scm_i_min);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x)) else if (scm_is_real (x))
return x; return x;
else else
return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min); return scm_wta_dispatch_1 (g_scm_i_min, x, SCM_ARG1, s_scm_i_min);
} }
if (SCM_I_INUMP (x)) if (!scm_is_real (x))
{ return scm_wta_dispatch_2 (g_scm_i_min, x, y, SCM_ARG1, s_scm_i_min);
scm_t_inum xx = SCM_I_INUM (x); if (!scm_is_real (y))
if (SCM_I_INUMP (y)) return scm_wta_dispatch_2 (g_scm_i_min, x, y, SCM_ARG2, s_scm_i_min);
{
scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? x : y;
}
else if (SCM_BIGP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return (sgn < 0) ? y : x;
}
else if (SCM_REALP (y))
{
double z = xx;
/* if y==NaN then "<" is false and we return NaN */
return (z < SCM_REAL_VALUE (y)) ? scm_i_from_double (z) : y;
}
else if (SCM_FRACTIONP (y))
{
use_less:
return (scm_is_false (scm_less_p (x, y)) ? y : x);
}
else
return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
scm_remember_upto_here_1 (x);
return (sgn < 0) ? x : y;
}
else if (SCM_BIGP (y))
{
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
scm_remember_upto_here_2 (x, y);
return (cmp > 0) ? y : x;
}
else if (SCM_REALP (y))
{
/* if y==NaN then xx<yy is false, so we return the NaN y */
double xx, yy;
big_real:
xx = scm_i_big2dbl (x);
yy = SCM_REAL_VALUE (y);
return (xx < yy ? scm_i_from_double (xx) : y);
}
else if (SCM_FRACTIONP (y))
{
goto use_less;
}
else
return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
{
double z = SCM_I_INUM (y);
/* if x==NaN then "<" is false and we return NaN */
return (z < SCM_REAL_VALUE (x)) ? scm_i_from_double (z) : x;
}
else if (SCM_BIGP (y))
{
SCM_SWAP (x, y);
goto big_real;
}
else if (SCM_REALP (y))
{
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
/* For purposes of min: nan < -inf.0 < everything else, if (scm_is_exact (x) && scm_is_exact (y))
per the R6RS errata */ return scm_is_less_than (x, y) ? x : y;
if (xx < yy)
return x; x = SCM_REALP (x) ? x : scm_exact_to_inexact (x);
else if (SCM_LIKELY (xx > yy)) y = SCM_REALP (y) ? y : scm_exact_to_inexact (y);
return y; double xx = SCM_REAL_VALUE (x);
/* If neither (xx < yy) nor (xx > yy), then double yy = SCM_REAL_VALUE (y);
either they're equal or one is a NaN */ if (isnan (xx))
else if (SCM_UNLIKELY (xx != yy)) return x;
return (xx != xx) ? x : y; /* Return the NaN */ if (isnan (yy))
/* xx == yy, but handle signed zeroes properly */ return y;
else if (copysign (1.0, xx) < 0.0) if (xx < yy)
return x; return x;
else if (xx > yy)
return y; return y;
} // Distinguish -0.0 from 0.0.
else if (SCM_FRACTIONP (y)) return (copysign (1.0, xx) < 0) ? x : y;
{
double yy = scm_i_fraction2double (y);
double xx = SCM_REAL_VALUE (x);
return (yy < xx) ? scm_i_from_double (yy) : x;
}
else
return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_FRACTIONP (x))
{
if (SCM_I_INUMP (y))
{
goto use_less;
}
else if (SCM_BIGP (y))
{
goto use_less;
}
else if (SCM_REALP (y))
{
double xx = scm_i_fraction2double (x);
/* if y==NaN then "<" is false, so we return the NaN y */
return (xx < SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{
goto use_less;
}
else
return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
} }