1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00

Make divide functions return values via (SCM *) output arguments

* libguile/numbers.c (scm_euclidean_divide, scm_centered_divide): Change
  API to return two values via output arguments of type (SCM *), instead
  of packing into a values object.

  (scm_i_euclidean_divide, scm_i_centered_divide): New internal wrappers
  that call the above functions and pack the result into a values
  object.

* libguile/numbers.h: Change prototypes to reflect new API.

* doc/ref/api-data.h (Arithmetic): Update manual.
This commit is contained in:
Mark H Weaver 2011-02-13 05:47:33 -05:00 committed by Andy Wingo
parent a85c1f93f0
commit 5fbf680be9
3 changed files with 177 additions and 112 deletions

View file

@ -1250,17 +1250,17 @@ respectively, but these functions take and return @code{double}
values. values.
@end deftypefn @end deftypefn
@deffn {Scheme Procedure} euclidean/ x y @deftypefn {Scheme Procedure} {} euclidean/ @var{x} @var{y}
@deffnx {Scheme Procedure} euclidean-quotient x y @deftypefnx {Scheme Procedure} {} euclidean-quotient @var{x} @var{y}
@deffnx {Scheme Procedure} euclidean-remainder x y @deftypefnx {Scheme Procedure} {} euclidean-remainder @var{x} @var{y}
@deffnx {C Function} scm_euclidean_divide (x y) @deftypefnx {C Function} void scm_euclidean_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
@deffnx {C Function} scm_euclidean_quotient (x y) @deftypefnx {C Function} SCM scm_euclidean_quotient (SCM @var{x}, SCM @var{y})
@deffnx {C Function} scm_euclidean_remainder (x y) @deftypefnx {C Function} SCM scm_euclidean_remainder (SCM @var{x}, SCM @var{y})
These procedures accept two real numbers @var{x} and @var{y}, where the These procedures accept two real numbers @var{x} and @var{y}, where the
divisor @var{y} must be non-zero. @code{euclidean-quotient} returns the divisor @var{y} must be non-zero. @code{euclidean-quotient} returns the
integer @var{q} and @code{euclidean-remainder} returns the real number integer @var{q} and @code{euclidean-remainder} returns the real number
@var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and @var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and
@math{0 <= @var{r} < abs(@var{y})}. @code{euclidean/} returns both @var{q} and @math{0 <= @var{r} < |@var{y}|}. @code{euclidean/} returns both @var{q} and
@var{r}, and is more efficient than computing each separately. Note @var{r}, and is more efficient than computing each separately. Note
that when @math{@var{y} > 0}, @code{euclidean-quotient} returns that when @math{@var{y} > 0}, @code{euclidean-quotient} returns
@math{floor(@var{x}/@var{y})}, otherwise it returns @math{floor(@var{x}/@var{y})}, otherwise it returns
@ -1279,19 +1279,19 @@ Note that these operators are equivalent to the R6RS operators
(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8 (euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8
(euclidean/ 16/3 -10/7) @result{} -3 and 22/21 (euclidean/ 16/3 -10/7) @result{} -3 and 22/21
@end lisp @end lisp
@end deffn @end deftypefn
@deffn {Scheme Procedure} centered/ x y @deftypefn {Scheme Procedure} {} centered/ @var{x} @var{y}
@deffnx {Scheme Procedure} centered-quotient x y @deftypefnx {Scheme Procedure} {} centered-quotient @var{x} @var{y}
@deffnx {Scheme Procedure} centered-remainder x y @deftypefnx {Scheme Procedure} {} centered-remainder @var{x} @var{y}
@deffnx {C Function} scm_centered_divide (x y) @deftypefnx {C Function} void scm_centered_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
@deffnx {C Function} scm_centered_quotient (x y) @deftypefnx {C Function} SCM scm_centered_quotient (SCM @var{x}, SCM @var{y})
@deffnx {C Function} scm_centered_remainder (x y) @deftypefnx {C Function} SCM scm_centered_remainder (SCM @var{x}, SCM @var{y})
These procedures accept two real numbers @var{x} and @var{y}, where the These procedures accept two real numbers @var{x} and @var{y}, where the
divisor @var{y} must be non-zero. @code{centered-quotient} returns the divisor @var{y} must be non-zero. @code{centered-quotient} returns the
integer @var{q} and @code{centered-remainder} returns the real number integer @var{q} and @code{centered-remainder} returns the real number
@var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and @var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and
@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}. @code{centered/} @math{-|@var{y}/2| <= @var{r} < |@var{y}/2|}. @code{centered/}
returns both @var{q} and @var{r}, and is more efficient than computing returns both @var{q} and @var{r}, and is more efficient than computing
each separately. each separately.
@ -1300,7 +1300,8 @@ rounded to the nearest integer. When @math{@var{x}/@var{y}} lies
exactly half-way between two integers, the tie is broken according to exactly half-way between two integers, the tie is broken according to
the sign of @var{y}. If @math{@var{y} > 0}, ties are rounded toward the sign of @var{y}. If @math{@var{y} > 0}, ties are rounded toward
positive infinity, otherwise they are rounded toward negative infinity. positive infinity, otherwise they are rounded toward negative infinity.
This is a consequence of the requirement that @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}. This is a consequence of the requirement that
@math{-|@var{y}/2| <= @var{r} < |@var{y}/2|}.
Note that these operators are equivalent to the R6RS operators Note that these operators are equivalent to the R6RS operators
@code{div0}, @code{mod0}, and @code{div0-and-mod0}. @code{div0}, @code{mod0}, and @code{div0-and-mod0}.
@ -1315,7 +1316,7 @@ Note that these operators are equivalent to the R6RS operators
(centered/ -123.2 -63.5) @result{} 2.0 and 3.8 (centered/ -123.2 -63.5) @result{} 2.0 and 3.8
(centered/ 16/3 -10/7) @result{} -4 and -8/21 (centered/ 16/3 -10/7) @result{} -4 and -8/21
@end lisp @end lisp
@end deffn @end deftypefn
@node Scientific @node Scientific
@subsubsection Scientific Functions @subsubsection Scientific Functions

View file

@ -1069,6 +1069,29 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
/* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
two-valued functions. It is called from primitive generics that take
two arguments and return two values, when the core procedure is
unable to handle the given argument types. If there are GOOPS
methods for this primitive generic, it dispatches to GOOPS and, if
successful, expects two values to be returned, which are placed in
*rp1 and *rp2. If there are no GOOPS methods, it throws a
wrong-type-arg exception.
FIXME: This obviously belongs somewhere else, but until we decide on
the right API, it is here as a static function, because it is needed
by the *_divide functions below.
*/
static void
two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
const char *subr, SCM *rp1, SCM *rp2)
{
if (SCM_UNPACK (gf))
scm_i_extract_values_2 (scm_call_generic_2 (gf, a1, a2), rp1, rp2);
else
scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
}
static SCM scm_i_inexact_euclidean_quotient (double x, double y); static SCM scm_i_inexact_euclidean_quotient (double x, double y);
static SCM scm_i_slow_exact_euclidean_quotient (SCM x, SCM y); static SCM scm_i_slow_exact_euclidean_quotient (SCM x, SCM y);
@ -1407,10 +1430,11 @@ scm_i_slow_exact_euclidean_remainder (SCM x, SCM y)
} }
static SCM scm_i_inexact_euclidean_divide (double x, double y); static void scm_i_inexact_euclidean_divide (double x, double y,
static SCM scm_i_slow_exact_euclidean_divide (SCM x, SCM y); SCM *qp, SCM *rp);
static void scm_i_slow_exact_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp);
SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0, SCM_PRIMITIVE_GENERIC (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
(SCM x, SCM y), (SCM x, SCM y),
"Return the integer @var{q} and the real number @var{r}\n" "Return the integer @var{q} and the real number @var{r}\n"
"such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n" "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
@ -1423,7 +1447,20 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
"(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n" "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
"(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n" "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_euclidean_divide #define FUNC_NAME s_scm_i_euclidean_divide
{
SCM q, r;
scm_euclidean_divide(x, y, &q, &r);
return scm_values (scm_list_2 (q, r));
}
#undef FUNC_NAME
#define s_scm_euclidean_divide s_scm_i_euclidean_divide
#define g_scm_euclidean_divide g_scm_i_euclidean_divide
void
scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{ {
if (SCM_LIKELY (SCM_I_INUMP (x))) if (SCM_LIKELY (SCM_I_INUMP (x)))
{ {
@ -1437,8 +1474,6 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
{ {
scm_t_inum qq = xx / yy; scm_t_inum qq = xx / yy;
scm_t_inum rr = xx % yy; scm_t_inum rr = xx % yy;
SCM q;
if (rr < 0) if (rr < 0)
{ {
if (yy > 0) if (yy > 0)
@ -1447,23 +1482,27 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
{ rr -= yy; qq++; } { rr -= yy; qq++; }
} }
if (SCM_LIKELY (SCM_FIXABLE (qq))) if (SCM_LIKELY (SCM_FIXABLE (qq)))
q = SCM_I_MAKINUM (qq); *qp = SCM_I_MAKINUM (qq);
else else
q = scm_i_inum2big (qq); *qp = scm_i_inum2big (qq);
return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr))); *rp = SCM_I_MAKINUM (rr);
} }
return;
} }
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ {
if (xx >= 0) if (xx >= 0)
return scm_values (scm_list_2 (SCM_INUM0, x)); {
*qp = SCM_INUM0;
*rp = x;
}
else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0) else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
{ {
SCM r = scm_i_mkbig (); SCM r = scm_i_mkbig ();
mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
scm_remember_upto_here_1 (y); scm_remember_upto_here_1 (y);
return scm_values *qp = SCM_I_MAKINUM (-1);
(scm_list_2 (SCM_I_MAKINUM (-1), scm_i_normbig (r))); *rp = scm_i_normbig (r);
} }
else else
{ {
@ -1471,16 +1510,19 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx); mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
scm_remember_upto_here_1 (y); scm_remember_upto_here_1 (y);
mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r)); mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
return scm_values (scm_list_2 (SCM_INUM1, scm_i_normbig (r))); *qp = SCM_INUM1;
*rp = scm_i_normbig (r);
} }
return;
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y)); return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y)) else if (SCM_FRACTIONP (y))
return scm_i_slow_exact_euclidean_divide (x, y); return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_euclidean_divide); (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide, qp, rp);
} }
else if (SCM_BIGP (x)) else if (SCM_BIGP (x))
{ {
@ -1503,9 +1545,10 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q)); mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
} }
scm_remember_upto_here_1 (x); scm_remember_upto_here_1 (x);
return scm_values (scm_list_2 (scm_i_normbig (q), *qp = scm_i_normbig (q);
SCM_I_MAKINUM (rr))); *rp = SCM_I_MAKINUM (rr);
} }
return;
} }
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ {
@ -1518,44 +1561,46 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r), mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
scm_remember_upto_here_2 (x, y); scm_remember_upto_here_2 (x, y);
return scm_values (scm_list_2 (scm_i_normbig (q), *qp = scm_i_normbig (q);
scm_i_normbig (r))); *rp = scm_i_normbig (r);
return;
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide return scm_i_inexact_euclidean_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y)); (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y)) else if (SCM_FRACTIONP (y))
return scm_i_slow_exact_euclidean_divide (x, y); return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_euclidean_divide); (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide, qp, rp);
} }
else if (SCM_REALP (x)) else if (SCM_REALP (x))
{ {
if (SCM_REALP (y) || SCM_I_INUMP (y) || if (SCM_REALP (y) || SCM_I_INUMP (y) ||
SCM_BIGP (y) || SCM_FRACTIONP (y)) SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_inexact_euclidean_divide return scm_i_inexact_euclidean_divide
(SCM_REAL_VALUE (x), scm_to_double (y)); (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_euclidean_divide); (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide, qp, rp);
} }
else if (SCM_FRACTIONP (x)) else if (SCM_FRACTIONP (x))
{ {
if (SCM_REALP (y)) if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide return scm_i_inexact_euclidean_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y)); (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
else else
return scm_i_slow_exact_euclidean_divide (x, y); return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
} }
else else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1, return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
s_scm_euclidean_divide); s_scm_euclidean_divide, qp, rp);
} }
#undef FUNC_NAME
static SCM static void
scm_i_inexact_euclidean_divide (double x, double y) scm_i_inexact_euclidean_divide (double x, double y, SCM *qp, SCM *rp)
{ {
double q, r; double q, r;
@ -1568,32 +1613,32 @@ scm_i_inexact_euclidean_divide (double x, double y)
else else
q = guile_NaN; q = guile_NaN;
r = x - q * y; r = x - q * y;
return scm_values (scm_list_2 (scm_from_double (q), *qp = scm_from_double (q);
scm_from_double (r))); *rp = scm_from_double (r);
} }
/* Compute exact euclidean quotient and remainder the slow way. /* Compute exact euclidean quotient and remainder the slow way.
We use this only if both arguments are exact, We use this only if both arguments are exact,
and at least one of them is a fraction */ and at least one of them is a fraction */
static SCM static void
scm_i_slow_exact_euclidean_divide (SCM x, SCM y) scm_i_slow_exact_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{ {
SCM q, r; SCM q;
if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1, return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
s_scm_euclidean_divide); s_scm_euclidean_divide, qp, rp);
else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide); s_scm_euclidean_divide, qp, rp);
else if (scm_is_true (scm_positive_p (y))) else if (scm_is_true (scm_positive_p (y)))
q = scm_floor (scm_divide (x, y)); q = scm_floor (scm_divide (x, y));
else if (scm_is_true (scm_negative_p (y))) else if (scm_is_true (scm_negative_p (y)))
q = scm_ceiling (scm_divide (x, y)); q = scm_ceiling (scm_divide (x, y));
else else
scm_num_overflow (s_scm_euclidean_divide); scm_num_overflow (s_scm_euclidean_divide);
r = scm_difference (x, scm_product (q, y)); *qp = q;
return scm_values (scm_list_2 (q, r)); *rp = scm_difference (x, scm_product (q, y));
} }
static SCM scm_i_inexact_centered_quotient (double x, double y); static SCM scm_i_inexact_centered_quotient (double x, double y);
@ -2052,11 +2097,12 @@ scm_i_slow_exact_centered_remainder (SCM x, SCM y)
} }
static SCM scm_i_inexact_centered_divide (double x, double y); static void scm_i_inexact_centered_divide (double x, double y,
static SCM scm_i_bigint_centered_divide (SCM x, SCM y); SCM *qp, SCM *rp);
static SCM scm_i_slow_exact_centered_divide (SCM x, SCM y); static void scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp);
static void scm_i_slow_exact_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp);
SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0, SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
(SCM x, SCM y), (SCM x, SCM y),
"Return the integer @var{q} and the real number @var{r}\n" "Return the integer @var{q} and the real number @var{r}\n"
"such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n" "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
@ -2069,7 +2115,20 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
"(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n" "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
"(centered/ 16/3 -10/7) @result{} -4 and -8/21\n" "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_centered_divide #define FUNC_NAME s_scm_i_centered_divide
{
SCM q, r;
scm_centered_divide(x, y, &q, &r);
return scm_values (scm_list_2 (q, r));
}
#undef FUNC_NAME
#define s_scm_centered_divide s_scm_i_centered_divide
#define g_scm_centered_divide g_scm_i_centered_divide
void
scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{ {
if (SCM_LIKELY (SCM_I_INUMP (x))) if (SCM_LIKELY (SCM_I_INUMP (x)))
{ {
@ -2083,8 +2142,6 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
{ {
scm_t_inum qq = xx / yy; scm_t_inum qq = xx / yy;
scm_t_inum rr = xx % yy; scm_t_inum rr = xx % yy;
SCM q;
if (SCM_LIKELY (xx > 0)) if (SCM_LIKELY (xx > 0))
{ {
if (SCM_LIKELY (yy > 0)) if (SCM_LIKELY (yy > 0))
@ -2112,25 +2169,27 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
} }
} }
if (SCM_LIKELY (SCM_FIXABLE (qq))) if (SCM_LIKELY (SCM_FIXABLE (qq)))
q = SCM_I_MAKINUM (qq); *qp = SCM_I_MAKINUM (qq);
else else
q = scm_i_inum2big (qq); *qp = scm_i_inum2big (qq);
return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr))); *rp = SCM_I_MAKINUM (rr);
} }
return;
} }
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ {
/* Pass a denormalized bignum version of x (even though it /* Pass a denormalized bignum version of x (even though it
can fit in a fixnum) to scm_i_bigint_centered_divide */ can fit in a fixnum) to scm_i_bigint_centered_divide */
return scm_i_bigint_centered_divide (scm_i_long2big (xx), y); return scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
} }
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y)); return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y)) else if (SCM_FRACTIONP (y))
return scm_i_slow_exact_centered_divide (x, y); return scm_i_slow_exact_centered_divide (x, y, qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_centered_divide); (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide, qp, rp);
} }
else if (SCM_BIGP (x)) else if (SCM_BIGP (x))
{ {
@ -2171,47 +2230,49 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
rr -= yy; rr -= yy;
} }
} }
return scm_values (scm_list_2 (scm_i_normbig (q), *qp = scm_i_normbig (q);
SCM_I_MAKINUM (rr))); *rp = SCM_I_MAKINUM (rr);
} }
return;
} }
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
return scm_i_bigint_centered_divide (x, y); return scm_i_bigint_centered_divide (x, y, qp, rp);
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_i_inexact_centered_divide return scm_i_inexact_centered_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y)); (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y)) else if (SCM_FRACTIONP (y))
return scm_i_slow_exact_centered_divide (x, y); return scm_i_slow_exact_centered_divide (x, y, qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_centered_divide); (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide, qp, rp);
} }
else if (SCM_REALP (x)) else if (SCM_REALP (x))
{ {
if (SCM_REALP (y) || SCM_I_INUMP (y) || if (SCM_REALP (y) || SCM_I_INUMP (y) ||
SCM_BIGP (y) || SCM_FRACTIONP (y)) SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_inexact_centered_divide return scm_i_inexact_centered_divide
(SCM_REAL_VALUE (x), scm_to_double (y)); (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
else else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2
s_scm_centered_divide); (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide, qp, rp);
} }
else if (SCM_FRACTIONP (x)) else if (SCM_FRACTIONP (x))
{ {
if (SCM_REALP (y)) if (SCM_REALP (y))
return scm_i_inexact_centered_divide return scm_i_inexact_centered_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y)); (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
else else
return scm_i_slow_exact_centered_divide (x, y); return scm_i_slow_exact_centered_divide (x, y, qp, rp);
} }
else else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1, return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
s_scm_centered_divide); s_scm_centered_divide, qp, rp);
} }
#undef FUNC_NAME
static SCM static void
scm_i_inexact_centered_divide (double x, double y) scm_i_inexact_centered_divide (double x, double y, SCM *qp, SCM *rp)
{ {
double q, r; double q, r;
@ -2224,14 +2285,14 @@ scm_i_inexact_centered_divide (double x, double y)
else else
q = guile_NaN; q = guile_NaN;
r = x - q * y; r = x - q * y;
return scm_values (scm_list_2 (scm_from_double (q), *qp = scm_from_double (q);
scm_from_double (r))); *rp = scm_from_double (r);
} }
/* Assumes that both x and y are bigints, though /* Assumes that both x and y are bigints, though
x might be able to fit into a fixnum. */ x might be able to fit into a fixnum. */
static SCM static void
scm_i_bigint_centered_divide (SCM x, SCM y) scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{ {
SCM q, r, min_r; SCM q, r, min_r;
@ -2276,24 +2337,24 @@ scm_i_bigint_centered_divide (SCM x, SCM y)
} }
} }
scm_remember_upto_here_2 (x, y); scm_remember_upto_here_2 (x, y);
return scm_values (scm_list_2 (scm_i_normbig (q), *qp = scm_i_normbig (q);
scm_i_normbig (r))); *rp = scm_i_normbig (r);
} }
/* Compute exact centered quotient and remainder the slow way. /* Compute exact centered quotient and remainder the slow way.
We use this only if both arguments are exact, We use this only if both arguments are exact,
and at least one of them is a fraction */ and at least one of them is a fraction */
static SCM static void
scm_i_slow_exact_centered_divide (SCM x, SCM y) scm_i_slow_exact_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{ {
SCM q, r; SCM q;
if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))) if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1, return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
s_scm_centered_divide); s_scm_centered_divide, qp, rp);
else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))) else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2, return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide); s_scm_centered_divide, qp, rp);
else if (scm_is_true (scm_positive_p (y))) else if (scm_is_true (scm_positive_p (y)))
q = scm_floor (scm_sum (scm_divide (x, y), q = scm_floor (scm_sum (scm_divide (x, y),
exactly_one_half)); exactly_one_half));
@ -2302,8 +2363,8 @@ scm_i_slow_exact_centered_divide (SCM x, SCM y)
exactly_one_half)); exactly_one_half));
else else
scm_num_overflow (s_scm_centered_divide); scm_num_overflow (s_scm_centered_divide);
r = scm_difference (x, scm_product (q, y)); *qp = q;
return scm_values (scm_list_2 (q, r)); *rp = scm_difference (x, scm_product (q, y));
} }

View file

@ -178,10 +178,10 @@ SCM_API SCM scm_abs (SCM x);
SCM_API SCM scm_quotient (SCM x, SCM y); SCM_API SCM scm_quotient (SCM x, SCM y);
SCM_API SCM scm_remainder (SCM x, SCM y); SCM_API SCM scm_remainder (SCM x, SCM y);
SCM_API SCM scm_modulo (SCM x, SCM y); SCM_API SCM scm_modulo (SCM x, SCM y);
SCM_API SCM scm_euclidean_divide (SCM x, SCM y); SCM_API void scm_euclidean_divide (SCM x, SCM y, SCM *q, SCM *r);
SCM_API SCM scm_euclidean_quotient (SCM x, SCM y); SCM_API SCM scm_euclidean_quotient (SCM x, SCM y);
SCM_API SCM scm_euclidean_remainder (SCM x, SCM y); SCM_API SCM scm_euclidean_remainder (SCM x, SCM y);
SCM_API SCM scm_centered_divide (SCM x, SCM y); SCM_API void scm_centered_divide (SCM x, SCM y, SCM *q, SCM *r);
SCM_API SCM scm_centered_quotient (SCM x, SCM y); SCM_API SCM scm_centered_quotient (SCM x, SCM y);
SCM_API SCM scm_centered_remainder (SCM x, SCM y); SCM_API SCM scm_centered_remainder (SCM x, SCM y);
SCM_API SCM scm_gcd (SCM x, SCM y); SCM_API SCM scm_gcd (SCM x, SCM y);
@ -199,6 +199,9 @@ SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end);
SCM_API SCM scm_logcount (SCM n); SCM_API SCM scm_logcount (SCM n);
SCM_API SCM scm_integer_length (SCM n); SCM_API SCM scm_integer_length (SCM n);
SCM_INTERNAL SCM scm_i_euclidean_divide (SCM x, SCM y);
SCM_INTERNAL SCM scm_i_centered_divide (SCM x, SCM y);
SCM_INTERNAL SCM scm_i_gcd (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_gcd (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_lcm (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_lcm (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_logand (SCM x, SCM y, SCM rest); SCM_INTERNAL SCM scm_i_logand (SCM x, SCM y, SCM rest);