mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
Simplify scm_product, use integer lib
* libguile/numbers.c (scm_product): Remove need for s_product defines. Call out to product, as appropriate. (product): New helper. * libguile/integers.h: * libguile/integers.c (scm_integer_mul_ii): (scm_integer_mul_zi): (scm_integer_mul_zz): New internal functions.
This commit is contained in:
Andy Wingo
parent
c096670d38
commit
9179525a05
3 changed files with 160 additions and 202 deletions
|
|
@ -2603,3 +2603,58 @@ scm_integer_sub_zz (struct scm_bignum *x, struct scm_bignum *y)
|
||||||
{
|
{
|
||||||
return scm_integer_add_zz (x, negate_bignum (clone_bignum (y)));
|
return scm_integer_add_zz (x, negate_bignum (clone_bignum (y)));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
scm_integer_mul_ii (scm_t_inum x, scm_t_inum y)
|
||||||
|
{
|
||||||
|
#if SCM_I_FIXNUM_BIT < 32
|
||||||
|
int64_t k = x * (int64_t) y;
|
||||||
|
if (SCM_FIXABLE (k))
|
||||||
|
return SCM_I_MAKINUM (k);
|
||||||
|
#else
|
||||||
|
if (x == 0)
|
||||||
|
return SCM_INUM0;
|
||||||
|
scm_t_inum ax = (x > 0) ? x : -x;
|
||||||
|
scm_t_inum ay = (y > 0) ? y : -y;
|
||||||
|
if (SCM_MOST_POSITIVE_FIXNUM / ax >= ay)
|
||||||
|
return SCM_I_MAKINUM (x * y);
|
||||||
|
#endif
|
||||||
|
|
||||||
|
// FIXME: Use mpn_mul with two-limb result to avoid allocating.
|
||||||
|
return scm_integer_mul_zi (long_to_bignum (x), y);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
scm_integer_mul_zi (struct scm_bignum *x, scm_t_inum y)
|
||||||
|
{
|
||||||
|
switch (y)
|
||||||
|
{
|
||||||
|
case -1:
|
||||||
|
return scm_integer_negate_z (x);
|
||||||
|
case 0:
|
||||||
|
return SCM_INUM0;
|
||||||
|
case 1:
|
||||||
|
return scm_from_bignum (x);
|
||||||
|
default:
|
||||||
|
{
|
||||||
|
mpz_t result, zx;
|
||||||
|
mpz_init (result);
|
||||||
|
alias_bignum_to_mpz (x, zx);
|
||||||
|
mpz_mul_si (result, zx, y);
|
||||||
|
scm_remember_upto_here_1 (x);
|
||||||
|
return take_mpz (result);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
scm_integer_mul_zz (struct scm_bignum *x, struct scm_bignum *y)
|
||||||
|
{
|
||||||
|
mpz_t result, zx, zy;
|
||||||
|
mpz_init (result);
|
||||||
|
alias_bignum_to_mpz (x, zx);
|
||||||
|
alias_bignum_to_mpz (y, zy);
|
||||||
|
mpz_mul (result, zx, zy);
|
||||||
|
scm_remember_upto_here_2 (x, y);
|
||||||
|
return take_mpz (result);
|
||||||
|
}
|
||||||
|
|
|
||||||
|
|
@ -180,6 +180,10 @@ SCM_INTERNAL SCM scm_integer_sub_iz (scm_t_inum x, struct scm_bignum *y);
|
||||||
SCM_INTERNAL SCM scm_integer_sub_zi (struct scm_bignum *x, scm_t_inum y);
|
SCM_INTERNAL SCM scm_integer_sub_zi (struct scm_bignum *x, scm_t_inum y);
|
||||||
SCM_INTERNAL SCM scm_integer_sub_zz (struct scm_bignum *x, struct scm_bignum *y);
|
SCM_INTERNAL SCM scm_integer_sub_zz (struct scm_bignum *x, struct scm_bignum *y);
|
||||||
|
|
||||||
|
SCM_INTERNAL SCM scm_integer_mul_ii (scm_t_inum x, scm_t_inum y);
|
||||||
|
SCM_INTERNAL SCM scm_integer_mul_zi (struct scm_bignum *x, scm_t_inum y);
|
||||||
|
SCM_INTERNAL SCM scm_integer_mul_zz (struct scm_bignum *x, struct scm_bignum *y);
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#endif /* SCM_INTEGERS_H */
|
#endif /* SCM_INTEGERS_H */
|
||||||
|
|
|
||||||
|
|
@ -5417,6 +5417,91 @@ SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
static SCM
|
||||||
|
product (SCM x, SCM y)
|
||||||
|
{
|
||||||
|
if (SCM_I_INUMP (x))
|
||||||
|
{
|
||||||
|
if (scm_is_eq (x, SCM_I_MAKINUM (-1)))
|
||||||
|
return negate (y);
|
||||||
|
else if (SCM_I_INUMP (y))
|
||||||
|
return scm_integer_mul_ii (SCM_I_INUM (x), SCM_I_INUM (y));
|
||||||
|
else if (SCM_BIGP (y))
|
||||||
|
return scm_integer_mul_zi (scm_bignum (y), SCM_I_INUM (x));
|
||||||
|
else if (SCM_REALP (y))
|
||||||
|
return scm_i_from_double (SCM_I_INUM (x) * SCM_REAL_VALUE (y));
|
||||||
|
else if (SCM_COMPLEXP (y))
|
||||||
|
return scm_c_make_rectangular (SCM_I_INUM (x) * SCM_COMPLEX_REAL (y),
|
||||||
|
SCM_I_INUM (x) * SCM_COMPLEX_IMAG (y));
|
||||||
|
else if (SCM_FRACTIONP (y))
|
||||||
|
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
|
||||||
|
SCM_FRACTION_DENOMINATOR (y));
|
||||||
|
abort (); /* Unreachable. */
|
||||||
|
}
|
||||||
|
else if (SCM_BIGP (x))
|
||||||
|
{
|
||||||
|
if (SCM_BIGP (y))
|
||||||
|
return scm_integer_mul_zz (scm_bignum (x), scm_bignum (y));
|
||||||
|
else if (SCM_REALP (y))
|
||||||
|
return scm_from_double (scm_integer_to_double_z (scm_bignum (x))
|
||||||
|
* SCM_REAL_VALUE (y));
|
||||||
|
else if (SCM_COMPLEXP (y))
|
||||||
|
{
|
||||||
|
double z = scm_integer_to_double_z (scm_bignum (x));
|
||||||
|
return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
|
||||||
|
z * SCM_COMPLEX_IMAG (y));
|
||||||
|
}
|
||||||
|
else if (SCM_FRACTIONP (y))
|
||||||
|
return scm_i_make_ratio (product (x, SCM_FRACTION_NUMERATOR (y)),
|
||||||
|
SCM_FRACTION_DENOMINATOR (y));
|
||||||
|
else
|
||||||
|
return product (y, x);
|
||||||
|
}
|
||||||
|
else if (SCM_REALP (x))
|
||||||
|
{
|
||||||
|
if (SCM_REALP (y))
|
||||||
|
return scm_i_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
|
||||||
|
else if (SCM_COMPLEXP (y))
|
||||||
|
return scm_c_make_rectangular
|
||||||
|
(SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
|
||||||
|
SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
|
||||||
|
else if (SCM_FRACTIONP (y))
|
||||||
|
return scm_i_from_double
|
||||||
|
(SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
|
||||||
|
else
|
||||||
|
return product (y, x);
|
||||||
|
}
|
||||||
|
else if (SCM_COMPLEXP (x))
|
||||||
|
{
|
||||||
|
if (SCM_COMPLEXP (y))
|
||||||
|
{
|
||||||
|
double rx = SCM_COMPLEX_REAL (x), ry = SCM_COMPLEX_REAL (y);
|
||||||
|
double ix = SCM_COMPLEX_IMAG (x), iy = SCM_COMPLEX_IMAG (y);
|
||||||
|
return scm_c_make_rectangular (rx * ry - ix * iy, rx * iy + ix * ry);
|
||||||
|
}
|
||||||
|
else if (SCM_FRACTIONP (y))
|
||||||
|
{
|
||||||
|
double yy = scm_i_fraction2double (y);
|
||||||
|
return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
|
||||||
|
yy * SCM_COMPLEX_IMAG (x));
|
||||||
|
}
|
||||||
|
else
|
||||||
|
return product (y, x);
|
||||||
|
}
|
||||||
|
else if (SCM_FRACTIONP (x))
|
||||||
|
{
|
||||||
|
if (SCM_FRACTIONP (y))
|
||||||
|
/* a/b * c/d = ac / bd */
|
||||||
|
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
|
||||||
|
SCM_FRACTION_NUMERATOR (y)),
|
||||||
|
scm_product (SCM_FRACTION_DENOMINATOR (x),
|
||||||
|
SCM_FRACTION_DENOMINATOR (y)));
|
||||||
|
else
|
||||||
|
return product (y, x);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
abort (); /* Unreachable. */
|
||||||
|
}
|
||||||
|
|
||||||
SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
|
SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
|
||||||
(SCM x, SCM y, SCM rest),
|
(SCM x, SCM y, SCM rest),
|
||||||
|
|
@ -5433,221 +5518,35 @@ SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
#define s_product s_scm_i_product
|
|
||||||
#define g_product g_scm_i_product
|
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
scm_product (SCM x, SCM y)
|
scm_product (SCM x, SCM y)
|
||||||
{
|
{
|
||||||
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
|
if (SCM_UNBNDP (y))
|
||||||
{
|
{
|
||||||
if (SCM_UNBNDP (x))
|
if (SCM_UNBNDP (x))
|
||||||
return SCM_I_MAKINUM (1L);
|
return SCM_I_MAKINUM (1L);
|
||||||
else if (SCM_NUMBERP (x))
|
else if (SCM_NUMBERP (x))
|
||||||
return x;
|
return x;
|
||||||
else
|
else
|
||||||
return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
|
return scm_wta_dispatch_1 (g_scm_i_product, x, SCM_ARG1,
|
||||||
|
s_scm_i_product);
|
||||||
}
|
}
|
||||||
|
|
||||||
if (SCM_LIKELY (SCM_I_INUMP (x)))
|
/* This is pretty gross! But (* 1 X) is apparently X in Guile, for
|
||||||
{
|
any type of X, even a pair. */
|
||||||
scm_t_inum xx;
|
if (scm_is_eq (x, SCM_INUM1))
|
||||||
|
|
||||||
xinum:
|
|
||||||
xx = SCM_I_INUM (x);
|
|
||||||
|
|
||||||
switch (xx)
|
|
||||||
{
|
|
||||||
case 1:
|
|
||||||
/* exact1 is the universal multiplicative identity */
|
|
||||||
return y;
|
return y;
|
||||||
break;
|
if (scm_is_eq (y, SCM_INUM1))
|
||||||
case 0:
|
return x;
|
||||||
/* exact0 times a fixnum is exact0: optimize this case */
|
|
||||||
if (SCM_LIKELY (SCM_I_INUMP (y)))
|
|
||||||
return SCM_INUM0;
|
|
||||||
/* if the other argument is inexact, the result is inexact,
|
|
||||||
and we must do the multiplication in order to handle
|
|
||||||
infinities and NaNs properly. */
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
return scm_i_from_double (0.0 * SCM_REAL_VALUE (y));
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y),
|
|
||||||
0.0 * SCM_COMPLEX_IMAG (y));
|
|
||||||
/* we've already handled inexact numbers,
|
|
||||||
so y must be exact, and we return exact0 */
|
|
||||||
else if (SCM_NUMP (y))
|
|
||||||
return SCM_INUM0;
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (SCM_LIKELY (SCM_I_INUMP (y)))
|
if (!SCM_NUMBERP (x))
|
||||||
{
|
return scm_wta_dispatch_2 (g_scm_i_product, x, y, SCM_ARG1,
|
||||||
scm_t_inum yy = SCM_I_INUM (y);
|
s_scm_i_product);
|
||||||
#if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
|
if (!SCM_NUMBERP (y))
|
||||||
int64_t kk = xx * (int64_t) yy;
|
return scm_wta_dispatch_2 (g_scm_i_product, x, y, SCM_ARG2,
|
||||||
if (SCM_FIXABLE (kk))
|
s_scm_i_product);
|
||||||
return SCM_I_MAKINUM (kk);
|
|
||||||
#else
|
return product (x, y);
|
||||||
scm_t_inum axx = (xx > 0) ? xx : -xx;
|
|
||||||
scm_t_inum ayy = (yy > 0) ? yy : -yy;
|
|
||||||
if (SCM_MOST_POSITIVE_FIXNUM / axx >= ayy)
|
|
||||||
return SCM_I_MAKINUM (xx * yy);
|
|
||||||
#endif
|
|
||||||
else
|
|
||||||
{
|
|
||||||
SCM result = scm_i_inum2big (xx);
|
|
||||||
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
|
|
||||||
return scm_i_normbig (result);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else if (SCM_BIGP (y))
|
|
||||||
{
|
|
||||||
/* There is one bignum which, when multiplied by negative one,
|
|
||||||
becomes a non-zero fixnum: (1+ most-positive-fixum). Since
|
|
||||||
we know the type of X and Y are numbers, delegate this
|
|
||||||
special case to scm_difference. */
|
|
||||||
if (xx == -1)
|
|
||||||
return scm_difference (y, SCM_UNDEFINED);
|
|
||||||
else
|
|
||||||
{
|
|
||||||
SCM result = scm_i_mkbig ();
|
|
||||||
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
|
|
||||||
scm_remember_upto_here_1 (y);
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
return scm_i_from_double (xx * SCM_REAL_VALUE (y));
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
|
|
||||||
xx * SCM_COMPLEX_IMAG (y));
|
|
||||||
else if (SCM_FRACTIONP (y))
|
|
||||||
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
|
|
||||||
SCM_FRACTION_DENOMINATOR (y));
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
}
|
|
||||||
else if (SCM_BIGP (x))
|
|
||||||
{
|
|
||||||
if (SCM_I_INUMP (y))
|
|
||||||
{
|
|
||||||
SCM_SWAP (x, y);
|
|
||||||
goto xinum;
|
|
||||||
}
|
|
||||||
else if (SCM_BIGP (y))
|
|
||||||
{
|
|
||||||
SCM result = scm_i_mkbig ();
|
|
||||||
mpz_mul (SCM_I_BIG_MPZ (result),
|
|
||||||
SCM_I_BIG_MPZ (x),
|
|
||||||
SCM_I_BIG_MPZ (y));
|
|
||||||
scm_remember_upto_here_2 (x, y);
|
|
||||||
return result;
|
|
||||||
}
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
{
|
|
||||||
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
|
|
||||||
scm_remember_upto_here_1 (x);
|
|
||||||
return scm_i_from_double (result);
|
|
||||||
}
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
{
|
|
||||||
double z = mpz_get_d (SCM_I_BIG_MPZ (x));
|
|
||||||
scm_remember_upto_here_1 (x);
|
|
||||||
return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
|
|
||||||
z * SCM_COMPLEX_IMAG (y));
|
|
||||||
}
|
|
||||||
else if (SCM_FRACTIONP (y))
|
|
||||||
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
|
|
||||||
SCM_FRACTION_DENOMINATOR (y));
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
}
|
|
||||||
else if (SCM_REALP (x))
|
|
||||||
{
|
|
||||||
if (SCM_I_INUMP (y))
|
|
||||||
{
|
|
||||||
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);
|
|
||||||
scm_remember_upto_here_1 (y);
|
|
||||||
return scm_i_from_double (result);
|
|
||||||
}
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
return scm_i_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
|
|
||||||
SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
|
|
||||||
else if (SCM_FRACTIONP (y))
|
|
||||||
return scm_i_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
}
|
|
||||||
else if (SCM_COMPLEXP (x))
|
|
||||||
{
|
|
||||||
if (SCM_I_INUMP (y))
|
|
||||||
{
|
|
||||||
SCM_SWAP (x, y);
|
|
||||||
goto xinum;
|
|
||||||
}
|
|
||||||
else if (SCM_BIGP (y))
|
|
||||||
{
|
|
||||||
double z = mpz_get_d (SCM_I_BIG_MPZ (y));
|
|
||||||
scm_remember_upto_here_1 (y);
|
|
||||||
return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x),
|
|
||||||
z * SCM_COMPLEX_IMAG (x));
|
|
||||||
}
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
|
|
||||||
SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
{
|
|
||||||
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
|
|
||||||
- SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
|
|
||||||
SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
|
|
||||||
+ SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
|
|
||||||
}
|
|
||||||
else if (SCM_FRACTIONP (y))
|
|
||||||
{
|
|
||||||
double yy = scm_i_fraction2double (y);
|
|
||||||
return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
|
|
||||||
yy * SCM_COMPLEX_IMAG (x));
|
|
||||||
}
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
}
|
|
||||||
else if (SCM_FRACTIONP (x))
|
|
||||||
{
|
|
||||||
if (SCM_I_INUMP (y))
|
|
||||||
return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
|
|
||||||
SCM_FRACTION_DENOMINATOR (x));
|
|
||||||
else if (SCM_BIGP (y))
|
|
||||||
return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
|
|
||||||
SCM_FRACTION_DENOMINATOR (x));
|
|
||||||
else if (SCM_REALP (y))
|
|
||||||
return scm_i_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
|
|
||||||
else if (SCM_COMPLEXP (y))
|
|
||||||
{
|
|
||||||
double xx = scm_i_fraction2double (x);
|
|
||||||
return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
|
|
||||||
xx * SCM_COMPLEX_IMAG (y));
|
|
||||||
}
|
|
||||||
else if (SCM_FRACTIONP (y))
|
|
||||||
/* a/b * c/d = ac / bd */
|
|
||||||
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
|
|
||||||
SCM_FRACTION_NUMERATOR (y)),
|
|
||||||
scm_product (SCM_FRACTION_DENOMINATOR (x),
|
|
||||||
SCM_FRACTION_DENOMINATOR (y)));
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
|
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue