summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2022-01-04 14:42:13 +0100
committerAndy Wingo <wingo@pobox.com>2022-01-13 09:37:16 +0100
commit281aed8aa0562d0a3da5f9e28c63ffbcc4ecee86 (patch)
treea0c3bdd1eb4cd98443aae6f480670216c37ab97f /libguile
parentf507c97380b1ac51d963b300f0b52e5edf329ff4 (diff)
downloadguile-281aed8aa0562d0a3da5f9e28c63ffbcc4ecee86.tar.gz
Simplify implementation of min, max
* libguile/numbers.c (scm_max, scm_min): Lean more on scm_is_less_than.
Diffstat (limited to 'libguile')
-rw-r--r--libguile/numbers.c330
1 files changed, 47 insertions, 283 deletions
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 54d2f0a51..60421fcb0 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5025,172 +5025,43 @@ SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
}
#undef FUNC_NAME
-#define s_max s_scm_i_max
-#define g_max g_scm_i_max
-
SCM
scm_max (SCM x, SCM y)
{
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- return scm_wta_dispatch_0 (g_max, s_max);
- else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
+ return scm_wta_dispatch_0 (g_scm_i_max, s_scm_i_max);
+ else if (scm_is_real (x))
return x;
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))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_I_INUMP (y))
- {
- 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)
- return scm_i_from_double (xxd);
- /* 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 (!scm_is_real (x))
+ return scm_wta_dispatch_2 (g_scm_i_max, x, y, SCM_ARG1, s_scm_i_max);
+ if (!scm_is_real (y))
+ return scm_wta_dispatch_2 (g_scm_i_max, x, y, SCM_ARG2, s_scm_i_max);
- if (yyd > xxd)
- return scm_i_from_double (yyd);
- /* If x is a NaN, then "==" is false and we return the NaN */
- else if (SCM_LIKELY (!(xxd == yyd)))
- return x;
- /* Handle signed zeroes properly */
- else if (yy == 0)
- return flo0;
- else
- return 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);
+ if (scm_is_exact (x) && scm_is_exact (y))
+ return scm_is_less_than (x, y) ? y : x;
- /* 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);
+ x = SCM_REALP (x) ? x : scm_exact_to_inexact (x);
+ y = SCM_REALP (y) ? y : scm_exact_to_inexact (y);
+ double xx = SCM_REAL_VALUE (x);
+ double yy = SCM_REAL_VALUE (y);
+ if (isnan (xx))
+ return x;
+ if (isnan (yy))
+ return y;
+ if (xx < yy)
+ return y;
+ if (xx > yy)
+ return x;
+ // Distinguish -0.0 from 0.0.
+ return (copysign (1.0, xx) < 0) ? y : x;
}
-
SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return the minimum of all parameter values.")
@@ -5205,148 +5076,41 @@ SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
}
#undef FUNC_NAME
-#define s_min s_scm_i_min
-#define g_min g_scm_i_min
-
SCM
scm_min (SCM x, SCM y)
{
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- return scm_wta_dispatch_0 (g_min, s_min);
- else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
+ return scm_wta_dispatch_0 (g_scm_i_min, s_scm_i_min);
+ else if (scm_is_real (x))
return x;
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))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_I_INUMP (y))
- {
- 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);
+ if (!scm_is_real (x))
+ return scm_wta_dispatch_2 (g_scm_i_min, x, y, SCM_ARG1, s_scm_i_min);
+ if (!scm_is_real (y))
+ return scm_wta_dispatch_2 (g_scm_i_min, x, y, SCM_ARG2, s_scm_i_min);
- /* For purposes of min: 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, xx) < 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 (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);
+ if (scm_is_exact (x) && scm_is_exact (y))
+ return scm_is_less_than (x, y) ? x : y;
+
+ x = SCM_REALP (x) ? x : scm_exact_to_inexact (x);
+ y = SCM_REALP (y) ? y : scm_exact_to_inexact (y);
+ double xx = SCM_REAL_VALUE (x);
+ double yy = SCM_REAL_VALUE (y);
+ if (isnan (xx))
+ return x;
+ if (isnan (yy))
+ return y;
+ if (xx < yy)
+ return x;
+ if (xx > yy)
+ return y;
+ // Distinguish -0.0 from 0.0.
+ return (copysign (1.0, xx) < 0) ? x : y;
}