* [PATCH] New division operators, and optimization for fractions
@ 2011-02-10 23:42 Mark H Weaver
2011-02-12 11:55 ` Andy Wingo
2011-02-15 10:38 ` Ludovic Courtès
0 siblings, 2 replies; 12+ messages in thread
From: Mark H Weaver @ 2011-02-10 23:42 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1218 bytes --]
Hello all,
Here are three more patches. The first adds fast implementations of the
remaining number-theoretic division operators as described in Taylor
Campbell's proposal: floor/, ceiling/, truncate/, round/, as well as the
single-valued variants. The third patch optimizes the case where both
arguments are exact and at least one is a fraction.
The second patch is needed by the third. It adds an internal C function
that extracts two values from a values object. I needed it because my
optimization for fractions works by calling the same division operator
recursively on a subproblem involving only integers, and I need a way to
extract the two values. Initially, I began to make internal versions of
the divide functions that returned their two values via parameters of
type (SCM *), but then I realized that in the cases where I dispatch
into GOOPS, I'd still need to extract from a values object.
If I've overlooked some existing mechanism for extracting multiple
values from C, or if you have a better idea, please let me know and I'll
rework the patch.
Note that these patches should be applied after the ones in my recent
post entitled "Miscellaneous fixes and improvements".
Best,
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Add four new sets of fast quotient and remainder operators --]
[-- Type: text/x-diff, Size: 87977 bytes --]
From c5cb51d82ed23c557721a6a68a38a1deb060c0ca Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 17:04:50 -0500
Subject: [PATCH] Add four new sets of fast quotient and remainder operators
* libguile/numbers.c (scm_floor_divide, scm_floor_quotient,
scm_floor_remainder, scm_ceiling_divide, scm_ceiling_quotient,
scm_ceiling_remainder, scm_truncate_divide, scm_truncate_quotient,
scm_truncate_remainder, scm_round_divide, scm_round_quotient,
scm_round_remainder): New extensible procedures `floor/',
`floor-quotient', `floor-remainder', `ceiling/', `ceiling-quotient',
`ceiling-remainder', `truncate/', `truncate-quotient',
`truncate-remainder', `round/', `round-quotient', and
`round-remainder'.
(scm_round_number, scm_floor, scm_ceiling): When applied to a
fraction, use scm_round_quotient, scm_floor_quotient and
scm_ceiling_quotient, respectively, for improved efficiency.
* libguile/numbers.h: Add function prototypes.
* test-suite/tests/numbers.test: Add tests.
* doc/ref/api-data.texi (Arithmetic): Add documentation.
* NEWS: Add NEWS entries for new division operators.
---
NEWS | 28 +
doc/ref/api-data.texi | 155 +++-
libguile/numbers.c | 2222 ++++++++++++++++++++++++++++++++++++++++-
libguile/numbers.h | 12 +
test-suite/tests/numbers.test | 75 ++-
5 files changed, 2451 insertions(+), 41 deletions(-)
diff --git a/NEWS b/NEWS
index 7912259..0b47121 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,34 @@ Changes since the 1.9.15 prerelease:
`define-once' is like Lisp's `defvar': it creates a toplevel binding,
but only if one does not exist already.
+** Added four new sets of fast quotient and remainder operators
+
+Added four new sets of fast quotient and remainder operators with
+different semantics than the R5RS operators. They support not only
+integers, but all reals, including exact rationals and inexact
+floating point numbers.
+
+These procedures accept two real numbers N and D, where the divisor D
+must be non-zero. Each set of operators computes an integer quotient
+Q and a real remainder R such that N = Q*D + R and |R| < |D|. They
+differ only in how N/D is rounded to produce Q.
+
+`floor-quotient' and `floor-remainder' compute Q and R, respectively,
+where Q has been rounded toward negative infinity. `floor/' returns
+both Q and R, and is more efficient than computing each separately.
+Note that when applied to integers, `floor-remainder' is equivalent to
+the R5RS integer-only `modulo' operator. `ceiling-quotient',
+`ceiling-remainder', and `ceiling/' are similar except that Q is
+rounded toward positive infinity.
+
+For `truncate-quotient', `truncate-remainder', and `truncate/', Q is
+rounded toward zero. Note that when applied to integers,
+`truncate-quotient' and `truncate-remainder' are equivalent to the
+R5RS integer-only operators `quotient' and `remainder'.
+
+For `round-quotient', `round-remainder', and `round/', Q is rounded to
+the nearest integer, with ties going to the nearest even integer.
+
** Improved exactness handling for complex number parsing
When parsing non-real complex numbers, exactness specifiers are now
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index fd2e7ee..7604c2c 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -907,7 +907,7 @@ sign as @var{n}. In all cases quotient and remainder satisfy
(remainder -13 4) @result{} -1
@end lisp
-See also @code{euclidean-quotient}, @code{euclidean-remainder} and
+See also @code{truncate-quotient}, @code{truncate-remainder} and
related operations in @ref{Arithmetic}.
@end deffn
@@ -924,7 +924,7 @@ sign as @var{d}.
(modulo -13 -4) @result{} -1
@end lisp
-See also @code{euclidean-quotient}, @code{euclidean-remainder} and
+See also @code{floor-quotient}, @code{floor-remainder} and
related operations in @ref{Arithmetic}.
@end deffn
@@ -1148,9 +1148,21 @@ Returns the magnitude or angle of @var{z} as a @code{double}.
@rnindex euclidean/
@rnindex euclidean-quotient
@rnindex euclidean-remainder
+@rnindex floor/
+@rnindex floor-quotient
+@rnindex floor-remainder
+@rnindex ceiling/
+@rnindex ceiling-quotient
+@rnindex ceiling-remainder
+@rnindex truncate/
+@rnindex truncate-quotient
+@rnindex truncate-remainder
@rnindex centered/
@rnindex centered-quotient
@rnindex centered-remainder
+@rnindex round/
+@rnindex round-quotient
+@rnindex round-remainder
The C arithmetic functions below always takes two arguments, while the
Scheme functions can take an arbitrary number. When you need to
@@ -1260,7 +1272,7 @@ 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
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
-@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
that when @math{@var{y} > 0}, @code{euclidean-quotient} returns
@math{floor(@var{x}/@var{y})}, otherwise it returns
@@ -1281,6 +1293,93 @@ Note that these operators are equivalent to the R6RS operators
@end lisp
@end deffn
+@deffn {Scheme Procedure} floor/ x y
+@deffnx {Scheme Procedure} floor-quotient x y
+@deffnx {Scheme Procedure} floor-remainder x y
+@deffnx {C Function} scm_floor_divide (x y)
+@deffnx {C Function} scm_floor_quotient (x y)
+@deffnx {C Function} scm_floor_remainder (x y)
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{floor-quotient} returns the
+integer @var{q} and @code{floor-remainder} returns the real number
+@var{r} such that @math{@var{q} = floor(@var{x}/@var{y})} and
+@math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{floor/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the same sign
+as @var{y}.
+
+When @var{x} and @var{y} are integers, @code{floor-quotient} is
+equivalent to the R5RS integer-only operator @code{modulo}.
+
+@lisp
+(floor-quotient 123 10) @result{} 12
+(floor-remainder 123 10) @result{} 3
+(floor/ 123 10) @result{} 12 and 3
+(floor/ 123 -10) @result{} -13 and -7
+(floor/ -123 10) @result{} -13 and 7
+(floor/ -123 -10) @result{} 12 and -3
+(floor/ -123.2 -63.5) @result{} 1.0 and -59.7
+(floor/ 16/3 -10/7) @result{} -4 and -8/21
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} ceiling/ x y
+@deffnx {Scheme Procedure} ceiling-quotient x y
+@deffnx {Scheme Procedure} ceiling-remainder x y
+@deffnx {C Function} scm_ceiling_divide (x y)
+@deffnx {C Function} scm_ceiling_quotient (x y)
+@deffnx {C Function} scm_ceiling_remainder (x y)
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{ceiling-quotient} returns the
+integer @var{q} and @code{ceiling-remainder} returns the real number
+@var{r} such that @math{@var{q} = ceiling(@var{x}/@var{y})} and
+@math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{ceiling/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the opposite sign
+of @var{y}.
+
+@lisp
+(ceiling-quotient 123 10) @result{} 13
+(ceiling-remainder 123 10) @result{} -7
+(ceiling/ 123 10) @result{} 13 and -7
+(ceiling/ 123 -10) @result{} -12 and 3
+(ceiling/ -123 10) @result{} -12 and -3
+(ceiling/ -123 -10) @result{} 13 and 7
+(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8
+(ceiling/ 16/3 -10/7) @result{} -3 and 22/21
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} truncate/ x y
+@deffnx {Scheme Procedure} truncate-quotient x y
+@deffnx {Scheme Procedure} truncate-remainder x y
+@deffnx {C Function} scm_truncate_divide (x y)
+@deffnx {C Function} scm_truncate_quotient (x y)
+@deffnx {C Function} scm_truncate_remainder (x y)
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{truncate-quotient} returns the
+integer @var{q} and @code{truncate-remainder} returns the real number
+@var{r} such that @var{q} is @math{@var{x}/@var{y}} rounded toward zero,
+and @math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{truncate/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the same sign
+as @var{x}.
+
+When @var{x} and @var{y} are integers, these operators are equivalent to
+the R5RS integer-only operators @code{quotient} and @code{remainder}.
+
+@lisp
+(truncate-quotient 123 10) @result{} 12
+(truncate-remainder 123 10) @result{} 3
+(truncate/ 123 10) @result{} 12 and 3
+(truncate/ 123 -10) @result{} -12 and 3
+(truncate/ -123 10) @result{} -12 and -3
+(truncate/ -123 -10) @result{} 12 and -3
+(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7
+(truncate/ 16/3 -10/7) @result{} -3 and 22/21
+@end lisp
+@end deffn
+
@deffn {Scheme Procedure} centered/ x y
@deffnx {Scheme Procedure} centered-quotient x y
@deffnx {Scheme Procedure} centered-remainder x y
@@ -1291,7 +1390,7 @@ 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
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
-@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
each separately.
@@ -1300,7 +1399,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
the sign of @var{y}. If @math{@var{y} > 0}, ties are rounded toward
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
@code{div0}, @code{mod0}, and @code{div0-and-mod0}.
@@ -1312,11 +1412,56 @@ Note that these operators are equivalent to the R6RS operators
(centered/ 123 -10) @result{} -12 and 3
(centered/ -123 10) @result{} -12 and -3
(centered/ -123 -10) @result{} 12 and -3
+(centered/ 125 10) @result{} 13 and -5
+(centered/ 127 10) @result{} 13 and -3
+(centered/ 135 10) @result{} 14 and -5
(centered/ -123.2 -63.5) @result{} 2.0 and 3.8
(centered/ 16/3 -10/7) @result{} -4 and -8/21
@end lisp
@end deffn
+@deffn {Scheme Procedure} round/ x y
+@deffnx {Scheme Procedure} round-quotient x y
+@deffnx {Scheme Procedure} round-remainder x y
+@deffnx {C Function} scm_round_divide (x y)
+@deffnx {C Function} scm_round_quotient (x y)
+@deffnx {C Function} scm_round_remainder (x y)
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{round-quotient} returns the
+integer @var{q} and @code{round-remainder} returns the real number
+@var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and
+@var{q} is @math{@var{x}/@var{y}} rounded to the nearest integer,
+with ties going to the nearest even integer. @code{round/}
+returns both @var{q} and @var{r}, and is more efficient than computing
+each separately.
+
+Note that @code{round/} and @code{centered/} are almost equivalent, but
+their behavior differs when @math{@var{x}/@var{y}} lies exactly half-way
+between two integers. In this case, @code{round/} chooses the nearest
+even integer, whereas @code{centered/} chooses in such a way to satisfy
+the constraint @math{-|@var{y}/2| <= @var{r} < |@var{y}/2|}, which
+is stronger than the corresponding constraint for @code{round/},
+@math{-|@var{y}/2| <= @var{r} <= |@var{y}/2|}. In particular,
+when @var{x} and @var{y} are integers, the number of possible remainders
+returned by @code{centered/} is @math{|@var{y}|}, whereas the number of
+possible remainders returned by @code{round/} is @math{|@var{y}|+1} when
+@var{y} is even.
+
+@lisp
+(round-quotient 123 10) @result{} 12
+(round-remainder 123 10) @result{} 3
+(round/ 123 10) @result{} 12 and 3
+(round/ 123 -10) @result{} -12 and 3
+(round/ -123 10) @result{} -12 and -3
+(round/ -123 -10) @result{} 12 and -3
+(round/ 125 10) @result{} 12 and 5
+(round/ 127 10) @result{} 13 and -3
+(round/ 135 10) @result{} 14 and -5
+(round/ -123.2 -63.5) @result{} 2.0 and 3.8
+(round/ 16/3 -10/7) @result{} -4 and -8/21
+@end lisp
+@end deffn
+
@node Scientific
@subsubsection Scientific Functions
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 05840ef..90e449f 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1596,6 +1596,1522 @@ scm_i_slow_exact_euclidean_divide (SCM x, SCM y)
return scm_values (scm_list_2 (q, r));
}
+static SCM scm_i_inexact_floor_quotient (double x, double y);
+static SCM scm_i_slow_exact_floor_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the floor of @math{@var{x} / @var{y}}.\n"
+ "@lisp\n"
+ "(floor-quotient 123 10) @result{} 12\n"
+ "(floor-quotient 123 -10) @result{} -13\n"
+ "(floor-quotient -123 10) @result{} -13\n"
+ "(floor-quotient -123 -10) @result{} 12\n"
+ "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
+ "(floor-quotient 16/3 -10/7) @result{} -4\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_floor_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum xx1 = xx;
+ scm_t_inum qq;
+ if (SCM_LIKELY (yy > 0))
+ {
+ if (SCM_UNLIKELY (xx < 0))
+ xx1 = xx - yy + 1;
+ }
+ else if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_quotient);
+ else if (xx > 0)
+ xx1 = xx - yy - 1;
+ qq = xx1 / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
+ else
+ return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_fdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_floor_quotient (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_floor_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (floor (x / y));
+}
+
+/* Compute exact floor_quotient the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_floor_quotient (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_floor_quotient);
+ else
+ return scm_floor (scm_divide (x, y));
+}
+
+static SCM scm_i_inexact_floor_remainder (double x, double y);
+static SCM scm_i_slow_exact_floor_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(floor-remainder 123 10) @result{} 3\n"
+ "(floor-remainder 123 -10) @result{} -7\n"
+ "(floor-remainder -123 10) @result{} 7\n"
+ "(floor-remainder -123 -10) @result{} -3\n"
+ "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
+ "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_floor_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_remainder);
+ else
+ {
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr < 0);
+ else
+ needs_adjustment = (rr > 0);
+
+ if (needs_adjustment)
+ rr += yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ {
+ if (xx < 0)
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+ }
+ else
+ return x;
+ }
+ else if (xx <= 0)
+ return x;
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_remainder);
+ else
+ {
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
+ else
+ rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_fdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_floor_remainder (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_floor_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_floor_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or y, but those two cases must
+ correspond to different choices of q. If r = 0.0 then q must be
+ x/y, and if r = y then q must be x/y-1. If quotient chooses one
+ and remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * floor (x / y));
+}
+
+/* Compute exact floor_remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_floor_remainder (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_floor_remainder);
+ else
+ return scm_difference
+ (x, scm_product (y, scm_floor (scm_divide (x, y))));
+}
+
+
+static SCM scm_i_inexact_floor_divide (double x, double y);
+static SCM scm_i_slow_exact_floor_divide (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_floor_divide, "floor/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(floor/ 123 10) @result{} 12 and 3\n"
+ "(floor/ 123 -10) @result{} -13 and -7\n"
+ "(floor/ -123 10) @result{} -13 and 7\n"
+ "(floor/ -123 -10) @result{} 12 and -3\n"
+ "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
+ "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_floor_divide
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+ SCM q;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr < 0);
+ else
+ needs_adjustment = (rr > 0);
+
+ if (needs_adjustment)
+ {
+ rr += yy;
+ qq--;
+ }
+
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ q = SCM_I_MAKINUM (qq);
+ else
+ q = scm_i_inum2big (qq);
+ return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ {
+ if (xx < 0)
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ return scm_values (scm_list_2 (SCM_I_MAKINUM (-1),
+ scm_i_normbig (r)));
+ }
+ else
+ return scm_values (scm_list_2 (SCM_INUM0, x));
+ }
+ else if (xx <= 0)
+ return scm_values (scm_list_2 (SCM_INUM0, x));
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ return scm_values (scm_list_2 (SCM_I_MAKINUM (-1),
+ scm_i_normbig (r)));
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_floor_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_floor_divide (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG1,
+ s_scm_floor_divide);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_floor_divide (double x, double y)
+{
+ double q, r;
+
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_divide); /* or return a NaN? */
+ else
+ q = floor (x / y);
+ r = x - q * y;
+ return scm_values (scm_list_2 (scm_from_double (q),
+ scm_from_double (r)));
+}
+
+/* Compute exact floor quotient and remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_floor_divide (SCM x, SCM y)
+{
+ SCM q, r;
+
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG1,
+ s_scm_floor_divide);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_floor_divide);
+ else
+ q = scm_floor (scm_divide (x, y));
+ r = scm_difference (x, scm_product (q, y));
+ return scm_values (scm_list_2 (q, r));
+}
+
+static SCM scm_i_inexact_ceiling_quotient (double x, double y);
+static SCM scm_i_slow_exact_ceiling_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the ceiling of @math{@var{x} / @var{y}}.\n"
+ "@lisp\n"
+ "(ceiling-quotient 123 10) @result{} 13\n"
+ "(ceiling-quotient 123 -10) @result{} -12\n"
+ "(ceiling-quotient -123 10) @result{} -12\n"
+ "(ceiling-quotient -123 -10) @result{} 13\n"
+ "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ceiling_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else
+ {
+ scm_t_inum xx1 = xx;
+ scm_t_inum qq;
+ if (SCM_LIKELY (yy > 0))
+ {
+ if (SCM_LIKELY (xx >= 0))
+ xx1 = xx + yy - 1;
+ }
+ else if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else if (xx < 0)
+ xx1 = xx + yy + 1;
+ qq = xx1 / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ return SCM_INUM1;
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ return SCM_INUM0;
+ }
+ else if (xx >= 0)
+ return SCM_INUM0;
+ else
+ return SCM_INUM1;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_cdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_ceiling_quotient (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_ceiling_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (ceil (x / y));
+}
+
+/* Compute exact ceiling_quotient the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_ceiling_quotient (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else
+ return scm_ceiling (scm_divide (x, y));
+}
+
+static SCM scm_i_inexact_ceiling_remainder (double x, double y);
+static SCM scm_i_slow_exact_ceiling_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(ceiling-remainder 123 10) @result{} -7\n"
+ "(ceiling-remainder 123 -10) @result{} 3\n"
+ "(ceiling-remainder -123 10) @result{} -3\n"
+ "(ceiling-remainder -123 -10) @result{} 7\n"
+ "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ceiling_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_remainder);
+ else
+ {
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr > 0);
+ else
+ needs_adjustment = (rr < 0);
+
+ if (needs_adjustment)
+ rr -= yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_i_normbig (r);
+ }
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_INUM0;
+ }
+ else
+ return x;
+ }
+ else if (xx >= 0)
+ return x;
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_i_normbig (r);
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_remainder);
+ else
+ {
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
+ else
+ rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), -yy);
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_cdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_ceiling_remainder (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_ceiling_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or -y, but those two cases must
+ correspond to different choices of q. If r = 0.0 then q must be
+ x/y, and if r = -y then q must be x/y+1. If quotient chooses one
+ and remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * ceil (x / y));
+}
+
+/* Compute exact ceiling_remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_ceiling_remainder (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_ceiling_remainder);
+ else
+ return scm_difference
+ (x, scm_product (y, scm_ceiling (scm_divide (x, y))));
+}
+
+static SCM scm_i_inexact_ceiling_divide (double x, double y);
+static SCM scm_i_slow_exact_ceiling_divide (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling_divide, "ceiling/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(ceiling/ 123 10) @result{} 13 and -7\n"
+ "(ceiling/ 123 -10) @result{} -12 and 3\n"
+ "(ceiling/ -123 10) @result{} -12 and -3\n"
+ "(ceiling/ -123 -10) @result{} 13 and 7\n"
+ "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ceiling_divide
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+ SCM q;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr > 0);
+ else
+ needs_adjustment = (rr < 0);
+
+ if (needs_adjustment)
+ {
+ rr -= yy;
+ qq++;
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ q = SCM_I_MAKINUM (qq);
+ else
+ q = scm_i_inum2big (qq);
+ return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_values (scm_list_2 (SCM_INUM1,
+ scm_i_normbig (r)));
+ }
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return scm_values (scm_list_2 (SCM_I_MAKINUM (-1),
+ SCM_INUM0));
+ }
+ else
+ return scm_values (scm_list_2 (SCM_INUM0, x));
+ }
+ else if (xx >= 0)
+ return scm_values (scm_list_2 (SCM_INUM0, x));
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_values (scm_list_2 (SCM_INUM1,
+ scm_i_normbig (r)));
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_ceiling_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_ceiling_divide (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
+ s_scm_ceiling_divide);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_ceiling_divide (double x, double y)
+{
+ double q, r;
+
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_divide); /* or return a NaN? */
+ else
+ q = ceil (x / y);
+ r = x - q * y;
+ return scm_values (scm_list_2 (scm_from_double (q),
+ scm_from_double (r)));
+}
+
+/* Compute exact ceiling quotient and remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_ceiling_divide (SCM x, SCM y)
+{
+ SCM q, r;
+
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
+ s_scm_ceiling_divide);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_ceiling_divide);
+ else
+ q = scm_ceiling (scm_divide (x, y));
+ r = scm_difference (x, scm_product (q, y));
+ return scm_values (scm_list_2 (q, r));
+}
+
+static SCM scm_i_inexact_truncate_quotient (double x, double y);
+static SCM scm_i_slow_exact_truncate_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
+ "@lisp\n"
+ "(truncate-quotient 123 10) @result{} 12\n"
+ "(truncate-quotient 123 -10) @result{} -12\n"
+ "(truncate-quotient -123 10) @result{} -12\n"
+ "(truncate-quotient -123 -10) @result{} 12\n"
+ "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
+ "(truncate-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_truncate_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_quotient);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ return SCM_INUM0;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_tdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_truncate_quotient (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_truncate_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (trunc (x / y));
+}
+
+/* Compute exact truncate_quotient the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_truncate_quotient (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_truncate_quotient);
+ else
+ return scm_truncate_number (scm_divide (x, y));
+}
+
+static SCM scm_i_inexact_truncate_remainder (double x, double y);
+static SCM scm_i_slow_exact_truncate_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(truncate-remainder 123 10) @result{} 3\n"
+ "(truncate-remainder 123 -10) @result{} 3\n"
+ "(truncate-remainder -123 10) @result{} -3\n"
+ "(truncate-remainder -123 -10) @result{} -3\n"
+ "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
+ "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_truncate_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_remainder);
+ else
+ return SCM_I_MAKINUM (xx % yy);
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_INUM0;
+ }
+ else
+ return x;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_remainder);
+ else
+ {
+ scm_t_inum rr = (mpz_tdiv_ui (SCM_I_BIG_MPZ (x),
+ (yy > 0) ? yy : -yy)
+ * mpz_sgn (SCM_I_BIG_MPZ (x)));
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_tdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_truncate_remainder (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_truncate_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or sgn(x)*|y|, but those two cases must
+ correspond to different choices of q. If quotient chooses one and
+ remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * trunc (x / y));
+}
+
+/* Compute exact truncate_remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_truncate_remainder (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_truncate_remainder);
+ else
+ return scm_difference
+ (x, scm_product (y, scm_truncate_number (scm_divide (x, y))));
+}
+
+
+static SCM scm_i_inexact_truncate_divide (double x, double y);
+static SCM scm_i_slow_exact_truncate_divide (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_truncate_divide, "truncate/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(truncate/ 123 10) @result{} 12 and 3\n"
+ "(truncate/ 123 -10) @result{} -12 and 3\n"
+ "(truncate/ -123 10) @result{} -12 and -3\n"
+ "(truncate/ -123 -10) @result{} 12 and -3\n"
+ "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
+ "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_truncate_divide
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ SCM q;
+
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ q = SCM_I_MAKINUM (qq);
+ else
+ q = scm_i_inum2big (qq);
+ return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return scm_values (scm_list_2 (SCM_I_MAKINUM (-1), SCM_INUM0));
+ }
+ else
+ return scm_values (scm_list_2 (SCM_INUM0, x));
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ rr *= mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_tdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_truncate_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_truncate_divide (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
+ s_scm_truncate_divide);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_truncate_divide (double x, double y)
+{
+ double q, r;
+
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
+ else
+ q = trunc (x / y);
+ r = x - q * y;
+ return scm_values (scm_list_2 (scm_from_double (q),
+ scm_from_double (r)));
+}
+
+/* Compute exact truncate quotient and remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_truncate_divide (SCM x, SCM y)
+{
+ SCM q, r;
+
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
+ s_scm_truncate_divide);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_truncate_divide);
+ else
+ q = scm_truncate_number (scm_divide (x, y));
+ r = scm_difference (x, scm_product (q, y));
+ return scm_values (scm_list_2 (q, r));
+}
+
static SCM scm_i_inexact_centered_quotient (double x, double y);
static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
static SCM scm_i_slow_exact_centered_quotient (SCM x, SCM y);
@@ -2306,6 +3822,670 @@ scm_i_slow_exact_centered_divide (SCM x, SCM y)
return scm_values (scm_list_2 (q, r));
}
+static SCM scm_i_inexact_round_quotient (double x, double y);
+static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
+static SCM scm_i_slow_exact_round_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
+ "with ties going to the nearest even integer.\n"
+ "@lisp\n"
+ "(round-quotient 123 10) @result{} 12\n"
+ "(round-quotient 123 -10) @result{} -12\n"
+ "(round-quotient -123 10) @result{} -12\n"
+ "(round-quotient -123 -10) @result{} 12\n"
+ "(round-quotient 125 10) @result{} 12\n"
+ "(round-quotient 127 10) @result{} 13\n"
+ "(round-quotient 135 10) @result{} 14\n"
+ "(round-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(round-quotient 16/3 -10/7) @result{} -4\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_quotient);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ qq++;
+ else if (r2 <= -ay)
+ qq--;
+ }
+ else
+ {
+ if (r2 > ay)
+ qq++;
+ else if (r2 < -ay)
+ qq--;
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_quotient */
+ return scm_i_bigint_round_quotient (scm_i_long2big (xx), y);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_1 (x);
+ if (needs_adjustment)
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_quotient (x, y);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_round_quotient (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_round_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (scm_c_round (x / y));
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static SCM
+scm_i_bigint_round_quotient (SCM x, SCM y)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+ scm_remember_upto_here_2 (x, r);
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+ scm_remember_upto_here_2 (r2, y);
+
+ if (needs_adjustment)
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+
+ return scm_i_normbig (q);
+}
+
+/* Compute exact round quotient the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_round_quotient (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_round_quotient);
+ else
+ return scm_round_number (scm_divide (x, y));
+}
+
+static SCM scm_i_inexact_round_remainder (double x, double y);
+static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
+static SCM scm_i_slow_exact_round_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
+ "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
+ "nearest integer, with ties going to the nearest\n"
+ "even integer.\n"
+ "@lisp\n"
+ "(round-remainder 123 10) @result{} 3\n"
+ "(round-remainder 123 -10) @result{} 3\n"
+ "(round-remainder -123 10) @result{} -3\n"
+ "(round-remainder -123 -10) @result{} -3\n"
+ "(round-remainder 125 10) @result{} 5\n"
+ "(round-remainder 127 10) @result{} -3\n"
+ "(round-remainder 135 10) @result{} -5\n"
+ "(round-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(round-remainder 16/3 -10/7) @result{} -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_remainder);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ rr -= yy;
+ else if (r2 <= -ay)
+ rr += yy;
+ }
+ else
+ {
+ if (r2 > ay)
+ rr -= yy;
+ else if (r2 < -ay)
+ rr += yy;
+ }
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_remainder */
+ return scm_i_bigint_round_remainder
+ (scm_i_long2big (xx), y);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_remainder);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_2 (x, q);
+ if (needs_adjustment)
+ rr -= yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_remainder (x, y);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_round_remainder (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_round_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_round_quotient, such that x != r + q * y (not even
+ close). In particular, when x-y/2 is very close to a multiple of
+ y, then r might be either -abs(y/2) or abs(y/2), but those two
+ cases must correspond to different choices of q. If quotient
+ chooses one and remainder chooses the other, it would be bad. */
+
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_remainder); /* or return a NaN? */
+ else
+ {
+ double q = scm_c_round (x / y);
+ return scm_from_double (x - q * y);
+ }
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static SCM
+scm_i_bigint_round_remainder (SCM x, SCM y)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (x);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+ scm_remember_upto_here_2 (q, r2);
+
+ if (needs_adjustment)
+ mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
+
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+}
+
+/* Compute exact round_remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_round_remainder (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_round_remainder);
+ else
+ {
+ SCM q = scm_round_number (scm_divide (x, y));
+ return scm_difference (x, scm_product (q, y));
+ }
+}
+
+
+static SCM scm_i_inexact_round_divide (double x, double y);
+static SCM scm_i_bigint_round_divide (SCM x, SCM y);
+static SCM scm_i_slow_exact_round_divide (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
+ "nearest integer, with ties going to the nearest even integer.\n"
+ "@lisp\n"
+ "(round/ 123 10) @result{} 12 and 3\n"
+ "(round/ 123 -10) @result{} -12 and 3\n"
+ "(round/ -123 10) @result{} -12 and -3\n"
+ "(round/ -123 -10) @result{} 12 and -3\n"
+ "(round/ 125 10) @result{} 12 and 5\n"
+ "(round/ 127 10) @result{} 13 and -3\n"
+ "(round/ 135 10) @result{} 14 and -5\n"
+ "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_divide
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+ SCM q;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ { qq++; rr -= yy; }
+ else if (r2 <= -ay)
+ { qq--; rr += yy; }
+ }
+ else
+ {
+ if (r2 > ay)
+ { qq++; rr -= yy; }
+ else if (r2 < -ay)
+ { qq--; rr += yy; }
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ q = SCM_I_MAKINUM (qq);
+ else
+ q = scm_i_inum2big (qq);
+ return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_divide */
+ return scm_i_bigint_round_divide
+ (scm_i_long2big (SCM_I_INUM (x)), y);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_1 (x);
+ if (needs_adjustment)
+ {
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ rr -= yy;
+ }
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ SCM_I_MAKINUM (rr)));
+ }
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_divide (x, y);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_slow_exact_round_divide (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else
+ return scm_i_slow_exact_round_divide (x, y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG1,
+ s_scm_round_divide);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_round_divide (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_divide); /* or return a NaN? */
+ else
+ {
+ double q = scm_c_round (x / y);
+ double r = x - q * y;
+ return scm_values (scm_list_2 (scm_from_double (q),
+ scm_from_double (r)));
+ }
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static SCM
+scm_i_bigint_round_divide (SCM x, SCM y)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (x);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+
+ if (needs_adjustment)
+ {
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
+ }
+
+ scm_remember_upto_here_2 (r2, y);
+ return scm_values (scm_list_2 (scm_i_normbig (q),
+ scm_i_normbig (r)));
+}
+
+/* Compute exact round quotient and remainder the slow way.
+ We use this only if both arguments are exact,
+ and at least one of them is a fraction */
+static SCM
+scm_i_slow_exact_round_divide (SCM x, SCM y)
+{
+ if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG1,
+ s_scm_round_divide);
+ else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide);
+ else if (scm_is_true (scm_zero_p (y)))
+ scm_num_overflow (s_scm_round_divide);
+ else
+ {
+ SCM q = scm_round_number (scm_divide (x, y));
+ SCM r = scm_difference (x, scm_product (q, y));
+ return scm_values (scm_list_2 (q, r));
+ }
+}
+
SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
(SCM x, SCM y, SCM rest),
@@ -6727,11 +8907,11 @@ SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
return x;
else if (SCM_REALP (x))
return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
+ else if (SCM_FRACTIONP (x))
+ return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
{
- /* OPTIMIZE-ME: Fraction case could be done more efficiently by a
- single quotient+remainder division then examining to see which way
- the rounding should go. */
SCM plus_half = scm_sum (x, exactly_one_half);
SCM result = scm_floor (plus_half);
/* Adjust so that the rounding is towards even. */
@@ -6754,22 +8934,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
else if (SCM_REALP (x))
return scm_from_double (floor (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
- {
- SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
- SCM_FRACTION_DENOMINATOR (x));
- if (scm_is_false (scm_negative_p (x)))
- {
- /* For positive x, rounding towards zero is correct. */
- return q;
- }
- else
- {
- /* For negative x, we need to return q-1 unless x is an
- integer. But fractions are never integer, per our
- assumptions. */
- return scm_difference (q, SCM_INUM1);
- }
- }
+ return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
}
@@ -6785,22 +8951,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
else if (SCM_REALP (x))
return scm_from_double (ceil (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
- {
- SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
- SCM_FRACTION_DENOMINATOR (x));
- if (scm_is_false (scm_positive_p (x)))
- {
- /* For negative x, rounding towards zero is correct. */
- return q;
- }
- else
- {
- /* For positive x, we need to return q+1 unless x is an
- integer. But fractions are never integer, per our
- assumptions. */
- return scm_sum (q, SCM_INUM1);
- }
- }
+ return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 10a4f17..66cbe63 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -181,9 +181,21 @@ SCM_API SCM scm_modulo (SCM x, SCM y);
SCM_API SCM scm_euclidean_divide (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_floor_divide (SCM x, SCM y);
+SCM_API SCM scm_floor_quotient (SCM x, SCM y);
+SCM_API SCM scm_floor_remainder (SCM x, SCM y);
+SCM_API SCM scm_ceiling_divide (SCM x, SCM y);
+SCM_API SCM scm_ceiling_quotient (SCM x, SCM y);
+SCM_API SCM scm_ceiling_remainder (SCM x, SCM y);
+SCM_API SCM scm_truncate_divide (SCM x, SCM y);
+SCM_API SCM scm_truncate_quotient (SCM x, SCM y);
+SCM_API SCM scm_truncate_remainder (SCM x, SCM y);
SCM_API SCM scm_centered_divide (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_round_divide (SCM x, SCM y);
+SCM_API SCM scm_round_quotient (SCM x, SCM y);
+SCM_API SCM scm_round_remainder (SCM x, SCM y);
SCM_API SCM scm_gcd (SCM x, SCM y);
SCM_API SCM scm_lcm (SCM n1, SCM n2);
SCM_API SCM scm_logand (SCM n1, SCM n2);
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index f738189..ef59a02 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -4148,6 +4148,42 @@
(test-within-range? 0 <= r < (abs y)))
(test-eqv? q (/ x y)))))
+ (define (valid-floor-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> y 0)
+ (test-within-range? 0 <= r < y)
+ (test-within-range? y < r <= 0)))
+ (test-eqv? q (/ x y)))))
+
+ (define (valid-ceiling-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> y 0)
+ (test-within-range? (- y) < r <= 0)
+ (test-within-range? 0 <= r < (- y))))
+ (test-eqv? q (/ x y)))))
+
+ (define (valid-truncate-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> x 0)
+ (test-within-range? 0 <= r < (abs y))
+ (test-within-range? (- (abs y)) < r <= 0)))
+ (test-eqv? q (/ x y)))))
+
(define (valid-centered-answer? x y q r)
(and (eq? (exact? q)
(exact? r)
@@ -4159,6 +4195,19 @@
(* -1/2 (abs y)) <= r < (* +1/2 (abs y))))
(test-eqv? q (/ x y)))))
+ (define (valid-round-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (let ((ay/2 (/ (abs y) 2)))
+ (if (even? q)
+ (test-within-range? (- ay/2) <= r <= ay/2)
+ (test-within-range? (- ay/2) < r < ay/2))))
+ (test-eqv? q (/ x y)))))
+
(define (for lsts f) (apply for-each f lsts))
(define big (expt 10 (1+ (inexact->exact (ceiling (log10 fixnum-max))))))
@@ -4284,8 +4333,32 @@
euclidean-remainder
valid-euclidean-answer?))
+ (with-test-prefix "floor/"
+ (run-division-tests floor/
+ floor-quotient
+ floor-remainder
+ valid-floor-answer?))
+
+ (with-test-prefix "ceiling/"
+ (run-division-tests ceiling/
+ ceiling-quotient
+ ceiling-remainder
+ valid-ceiling-answer?))
+
+ (with-test-prefix "truncate/"
+ (run-division-tests truncate/
+ truncate-quotient
+ truncate-remainder
+ valid-truncate-answer?))
+
(with-test-prefix "centered/"
(run-division-tests centered/
centered-quotient
centered-remainder
- valid-centered-answer?)))
+ valid-centered-answer?))
+
+ (with-test-prefix "round/"
+ (run-division-tests round/
+ round-quotient
+ round-remainder
+ valid-round-answer?)))
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Added internal C function to extract from values object --]
[-- Type: text/x-diff, Size: 1799 bytes --]
From a729ef1b8b1905cb6c2ec73cc9b54e2e9453a2b3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 18:03:14 -0500
Subject: [PATCH] Added internal C function to extract from values object
* libguile/values.c (scm_i_extract_values_2): New internal function
that extracts two values from a values object.
* libguile/values.h: Added prototype.
---
libguile/values.c | 18 ++++++++++++++++++
libguile/values.h | 2 ++
2 files changed, 20 insertions(+), 0 deletions(-)
diff --git a/libguile/values.c b/libguile/values.c
index 967fcd6..b9fe4cc 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -35,6 +35,24 @@
SCM scm_values_vtable;
+/* OBJ must be a values object containing exactly two values.
+ scm_i_extract_values_2 puts those two values into *p1 and *p2. */
+void
+scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
+{
+ SCM values;
+
+ SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
+ "scm_i_extract_values_2", "values");
+ values = scm_struct_ref (obj, SCM_INUM0);
+ if (!scm_is_null_or_nil (SCM_CDDR (values)))
+ scm_wrong_type_arg_msg
+ ("scm_i_extract_values_2", SCM_ARG1, obj,
+ "a values object containing exactly two values");
+ *p1 = SCM_CAR (values);
+ *p2 = SCM_CADR (values);
+}
+
static SCM
print_values (SCM obj, SCM pwps)
{
diff --git a/libguile/values.h b/libguile/values.h
index 0750aec..65ad8a1 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -30,6 +30,8 @@ SCM_API SCM scm_values_vtable;
#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
&& scm_is_eq (scm_struct_vtable (x), scm_values_vtable))
+SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
+
SCM_API SCM scm_values (SCM args);
SCM_INTERNAL void scm_init_values (void);
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Optimize division operators handling of fractions --]
[-- Type: text/x-diff, Size: 54385 bytes --]
From 5a0677e5daafa6dd10dd7612468d1ea1e38692b7 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 18:18:34 -0500
Subject: [PATCH] Optimize division operators handling of fractions
* libguile/numbers.c: (scm_euclidean_quotient, scm_euclidean_remainder,
scm_euclidean_divide, scm_floor_quotient, scm_floor_remainder,
scm_floor_divide, scm_ceiling_quotient, scm_ceiling_remainder,
scm_ceiling_divide, scm_truncate_quotient, scm_truncate_remainder,
scm_truncate_divide, scm_centered_quotient, scm_centered_remainder,
scm_centered_divide, scm_round_quotient, scm_round_remainder,
scm_round_divide): Optimize case where both arguments are exact and at
least one is a fraction, by reducing to a subproblem involving only
integers, and then adjusting the resulting remainder as needed.
---
libguile/numbers.c | 622 +++++++++++++++++++++-------------------------------
1 files changed, 249 insertions(+), 373 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 90e449f..3ef8fe5 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1070,7 +1070,7 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
#undef FUNC_NAME
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_exact_rational_euclidean_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -1125,7 +1125,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
s_scm_euclidean_quotient);
@@ -1171,7 +1171,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
return scm_i_inexact_euclidean_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
s_scm_euclidean_quotient);
@@ -1191,8 +1191,11 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_euclidean_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
+ s_scm_euclidean_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
@@ -1213,28 +1216,16 @@ scm_i_inexact_euclidean_quotient (double x, double y)
return scm_nan ();
}
-/* Compute exact euclidean_quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_euclidean_quotient (SCM x, SCM y)
+scm_i_exact_rational_euclidean_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
- s_scm_euclidean_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- else if (scm_is_true (scm_positive_p (y)))
- return scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- return scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_quotient);
+ return scm_euclidean_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_euclidean_remainder (double x, double y);
-static SCM scm_i_slow_exact_euclidean_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_euclidean_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -1294,7 +1285,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
s_scm_euclidean_remainder);
@@ -1329,7 +1320,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
return scm_i_inexact_euclidean_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
s_scm_euclidean_remainder);
@@ -1349,8 +1340,11 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_euclidean_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
+ s_scm_euclidean_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
@@ -1383,32 +1377,19 @@ scm_i_inexact_euclidean_remainder (double x, double y)
return scm_from_double (x - q * y);
}
-/* Compute exact euclidean_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_euclidean_remainder (SCM x, SCM y)
+scm_i_exact_rational_euclidean_remainder (SCM x, SCM y)
{
- SCM q;
-
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
- s_scm_euclidean_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_remainder);
- return scm_difference (x, scm_product (y, q));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_euclidean_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_euclidean_divide (double x, double y);
-static SCM scm_i_slow_exact_euclidean_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_euclidean_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
(SCM x, SCM y),
@@ -1477,7 +1458,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_divide (x, y);
+ return scm_i_exact_rational_euclidean_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide);
@@ -1525,7 +1506,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
return scm_i_inexact_euclidean_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_divide (x, y);
+ return scm_i_exact_rational_euclidean_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
s_scm_euclidean_divide);
@@ -1545,8 +1526,11 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_divide (x, y);
else
- return scm_i_slow_exact_euclidean_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
@@ -1572,32 +1556,23 @@ scm_i_inexact_euclidean_divide (double x, double y)
scm_from_double (r)));
}
-/* Compute exact euclidean quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_euclidean_divide (SCM x, SCM y)
+scm_i_exact_rational_euclidean_divide (SCM x, SCM y)
{
- SCM q, r;
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_divide);
- r = scm_difference (x, scm_product (q, y));
+ scm_i_extract_values_2
+ (scm_euclidean_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
return scm_values (scm_list_2 (q, r));
}
static SCM scm_i_inexact_floor_quotient (double x, double y);
-static SCM scm_i_slow_exact_floor_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_floor_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -1647,7 +1622,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_quotient (x, y);
+ return scm_i_exact_rational_floor_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
s_scm_floor_quotient);
@@ -1688,7 +1663,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
return scm_i_inexact_floor_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_quotient (x, y);
+ return scm_i_exact_rational_floor_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
s_scm_floor_quotient);
@@ -1708,8 +1683,11 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_floor_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_quotient (x, y);
else
- return scm_i_slow_exact_floor_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
@@ -1726,26 +1704,16 @@ scm_i_inexact_floor_quotient (double x, double y)
return scm_from_double (floor (x / y));
}
-/* Compute exact floor_quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_floor_quotient (SCM x, SCM y)
+scm_i_exact_rational_floor_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
- s_scm_floor_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_floor_quotient);
- else
- return scm_floor (scm_divide (x, y));
+ return scm_floor_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_floor_remainder (double x, double y);
-static SCM scm_i_slow_exact_floor_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_floor_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -1814,7 +1782,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_remainder (x, y);
+ return scm_i_exact_rational_floor_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
s_scm_floor_remainder);
@@ -1850,7 +1818,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
return scm_i_inexact_floor_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_remainder (x, y);
+ return scm_i_exact_rational_floor_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
s_scm_floor_remainder);
@@ -1870,8 +1838,11 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_floor_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_remainder (x, y);
else
- return scm_i_slow_exact_floor_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
@@ -1896,28 +1867,19 @@ scm_i_inexact_floor_remainder (double x, double y)
return scm_from_double (x - y * floor (x / y));
}
-/* Compute exact floor_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_floor_remainder (SCM x, SCM y)
+scm_i_exact_rational_floor_remainder (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
- s_scm_floor_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_floor_remainder);
- else
- return scm_difference
- (x, scm_product (y, scm_floor (scm_divide (x, y))));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_floor_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_floor_divide (double x, double y);
-static SCM scm_i_slow_exact_floor_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_floor_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_floor_divide, "floor/", 2, 0, 0,
(SCM x, SCM y),
@@ -1998,7 +1960,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_divide, "floor/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_divide (x, y);
+ return scm_i_exact_rational_floor_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
s_scm_floor_divide);
@@ -2042,7 +2004,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor_divide, "floor/", 2, 0, 0,
return scm_i_inexact_floor_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_floor_divide (x, y);
+ return scm_i_exact_rational_floor_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
s_scm_floor_divide);
@@ -2062,8 +2024,11 @@ SCM_PRIMITIVE_GENERIC (scm_floor_divide, "floor/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_floor_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_divide (x, y);
else
- return scm_i_slow_exact_floor_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG1,
@@ -2085,30 +2050,23 @@ scm_i_inexact_floor_divide (double x, double y)
scm_from_double (r)));
}
-/* Compute exact floor quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_floor_divide (SCM x, SCM y)
+scm_i_exact_rational_floor_divide (SCM x, SCM y)
{
- SCM q, r;
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG1,
- s_scm_floor_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_floor_divide, x, y, SCM_ARG2,
- s_scm_floor_divide);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_floor_divide);
- else
- q = scm_floor (scm_divide (x, y));
- r = scm_difference (x, scm_product (q, y));
+ scm_i_extract_values_2
+ (scm_floor_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
return scm_values (scm_list_2 (q, r));
}
static SCM scm_i_inexact_ceiling_quotient (double x, double y);
-static SCM scm_i_slow_exact_ceiling_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_ceiling_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -2178,7 +2136,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_quotient (x, y);
+ return scm_i_exact_rational_ceiling_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
s_scm_ceiling_quotient);
@@ -2219,7 +2177,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
return scm_i_inexact_ceiling_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_quotient (x, y);
+ return scm_i_exact_rational_ceiling_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
s_scm_ceiling_quotient);
@@ -2239,8 +2197,11 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_ceiling_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_quotient (x, y);
else
- return scm_i_slow_exact_ceiling_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
@@ -2257,26 +2218,16 @@ scm_i_inexact_ceiling_quotient (double x, double y)
return scm_from_double (ceil (x / y));
}
-/* Compute exact ceiling_quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_ceiling_quotient (SCM x, SCM y)
+scm_i_exact_rational_ceiling_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
- s_scm_ceiling_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_ceiling_quotient);
- else
- return scm_ceiling (scm_divide (x, y));
+ return scm_ceiling_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_ceiling_remainder (double x, double y);
-static SCM scm_i_slow_exact_ceiling_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_ceiling_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -2355,7 +2306,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_remainder (x, y);
+ return scm_i_exact_rational_ceiling_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
s_scm_ceiling_remainder);
@@ -2391,7 +2342,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
return scm_i_inexact_ceiling_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_remainder (x, y);
+ return scm_i_exact_rational_ceiling_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
s_scm_ceiling_remainder);
@@ -2411,8 +2362,11 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_ceiling_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_remainder (x, y);
else
- return scm_i_slow_exact_ceiling_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
@@ -2437,27 +2391,18 @@ scm_i_inexact_ceiling_remainder (double x, double y)
return scm_from_double (x - y * ceil (x / y));
}
-/* Compute exact ceiling_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_ceiling_remainder (SCM x, SCM y)
+scm_i_exact_rational_ceiling_remainder (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
- s_scm_ceiling_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_ceiling_remainder);
- else
- return scm_difference
- (x, scm_product (y, scm_ceiling (scm_divide (x, y))));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_ceiling_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_ceiling_divide (double x, double y);
-static SCM scm_i_slow_exact_ceiling_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_ceiling_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_ceiling_divide, "ceiling/", 2, 0, 0,
(SCM x, SCM y),
@@ -2548,7 +2493,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_divide, "ceiling/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_divide (x, y);
+ return scm_i_exact_rational_ceiling_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
s_scm_ceiling_divide);
@@ -2592,7 +2537,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_divide, "ceiling/", 2, 0, 0,
return scm_i_inexact_ceiling_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_ceiling_divide (x, y);
+ return scm_i_exact_rational_ceiling_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
s_scm_ceiling_divide);
@@ -2612,8 +2557,11 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_divide, "ceiling/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_ceiling_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_divide (x, y);
else
- return scm_i_slow_exact_ceiling_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
@@ -2635,30 +2583,23 @@ scm_i_inexact_ceiling_divide (double x, double y)
scm_from_double (r)));
}
-/* Compute exact ceiling quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_ceiling_divide (SCM x, SCM y)
+scm_i_exact_rational_ceiling_divide (SCM x, SCM y)
{
- SCM q, r;
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
- s_scm_ceiling_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
- s_scm_ceiling_divide);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_ceiling_divide);
- else
- q = scm_ceiling (scm_divide (x, y));
- r = scm_difference (x, scm_product (q, y));
+ scm_i_extract_values_2
+ (scm_ceiling_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
return scm_values (scm_list_2 (q, r));
}
static SCM scm_i_inexact_truncate_quotient (double x, double y);
-static SCM scm_i_slow_exact_truncate_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_truncate_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -2706,7 +2647,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_quotient (x, y);
+ return scm_i_exact_rational_truncate_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
s_scm_truncate_quotient);
@@ -2747,7 +2688,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
return scm_i_inexact_truncate_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_quotient (x, y);
+ return scm_i_exact_rational_truncate_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
s_scm_truncate_quotient);
@@ -2767,8 +2708,11 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_truncate_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_quotient (x, y);
else
- return scm_i_slow_exact_truncate_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
@@ -2785,26 +2729,16 @@ scm_i_inexact_truncate_quotient (double x, double y)
return scm_from_double (trunc (x / y));
}
-/* Compute exact truncate_quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_truncate_quotient (SCM x, SCM y)
+scm_i_exact_rational_truncate_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
- s_scm_truncate_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_truncate_quotient);
- else
- return scm_truncate_number (scm_divide (x, y));
+ return scm_truncate_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_truncate_remainder (double x, double y);
-static SCM scm_i_slow_exact_truncate_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_truncate_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -2848,7 +2782,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_remainder (x, y);
+ return scm_i_exact_rational_truncate_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
s_scm_truncate_remainder);
@@ -2882,7 +2816,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
return scm_i_inexact_truncate_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_remainder (x, y);
+ return scm_i_exact_rational_truncate_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
s_scm_truncate_remainder);
@@ -2902,8 +2836,11 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_truncate_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_remainder (x, y);
else
- return scm_i_slow_exact_truncate_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
@@ -2927,28 +2864,19 @@ scm_i_inexact_truncate_remainder (double x, double y)
return scm_from_double (x - y * trunc (x / y));
}
-/* Compute exact truncate_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_truncate_remainder (SCM x, SCM y)
+scm_i_exact_rational_truncate_remainder (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
- s_scm_truncate_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_truncate_remainder);
- else
- return scm_difference
- (x, scm_product (y, scm_truncate_number (scm_divide (x, y))));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_truncate_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_truncate_divide (double x, double y);
-static SCM scm_i_slow_exact_truncate_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_truncate_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_truncate_divide, "truncate/", 2, 0, 0,
(SCM x, SCM y),
@@ -3002,7 +2930,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_divide, "truncate/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_divide (x, y);
+ return scm_i_exact_rational_truncate_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
s_scm_truncate_divide);
@@ -3047,7 +2975,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_divide, "truncate/", 2, 0, 0,
return scm_i_inexact_truncate_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_truncate_divide (x, y);
+ return scm_i_exact_rational_truncate_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
s_scm_truncate_divide);
@@ -3067,8 +2995,11 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_divide, "truncate/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_truncate_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_divide (x, y);
else
- return scm_i_slow_exact_truncate_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
@@ -3090,31 +3021,24 @@ scm_i_inexact_truncate_divide (double x, double y)
scm_from_double (r)));
}
-/* Compute exact truncate quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_truncate_divide (SCM x, SCM y)
+scm_i_exact_rational_truncate_divide (SCM x, SCM y)
{
- SCM q, r;
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
- s_scm_truncate_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
- s_scm_truncate_divide);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_truncate_divide);
- else
- q = scm_truncate_number (scm_divide (x, y));
- r = scm_difference (x, scm_product (q, y));
+ scm_i_extract_values_2
+ (scm_truncate_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
return scm_values (scm_list_2 (q, r));
}
static SCM scm_i_inexact_centered_quotient (double x, double y);
static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -3184,7 +3108,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_centered_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_quotient (x, y);
+ return scm_i_exact_rational_centered_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
s_scm_centered_quotient);
@@ -3233,7 +3157,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
return scm_i_inexact_centered_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_quotient (x, y);
+ return scm_i_exact_rational_centered_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
s_scm_centered_quotient);
@@ -3253,8 +3177,11 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_centered_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_quotient (x, y);
else
- return scm_i_slow_exact_centered_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
@@ -3318,31 +3245,17 @@ scm_i_bigint_centered_quotient (SCM x, SCM y)
return scm_i_normbig (q);
}
-/* Compute exact centered quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_centered_quotient (SCM x, SCM y)
+scm_i_exact_rational_centered_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
- else if (scm_is_true (scm_positive_p (y)))
- return scm_floor (scm_sum (scm_divide (x, y),
- exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- return scm_ceiling (scm_difference (scm_divide (x, y),
- exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_quotient);
+ return scm_centered_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_centered_remainder (double x, double y);
static SCM scm_i_bigint_centered_remainder (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_centered_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -3409,7 +3322,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_centered_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_remainder (x, y);
+ return scm_i_exact_rational_centered_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
s_scm_centered_remainder);
@@ -3450,7 +3363,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
return scm_i_inexact_centered_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_remainder (x, y);
+ return scm_i_exact_rational_centered_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
s_scm_centered_remainder);
@@ -3470,8 +3383,11 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_centered_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_remainder (x, y);
else
- return scm_i_slow_exact_centered_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
@@ -3544,33 +3460,20 @@ scm_i_bigint_centered_remainder (SCM x, SCM y)
return scm_i_normbig (r);
}
-/* Compute exact centered_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_centered_remainder (SCM x, SCM y)
+scm_i_exact_rational_centered_remainder (SCM x, SCM y)
{
- SCM q;
-
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_sum (scm_divide (x, y), exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_remainder);
- return scm_difference (x, scm_product (y, q));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_centered_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_centered_divide (double x, double y);
static SCM scm_i_bigint_centered_divide (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_centered_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
(SCM x, SCM y),
@@ -3643,7 +3546,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_divide (x, y);
+ return scm_i_exact_rational_centered_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide);
@@ -3697,7 +3600,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
return scm_i_inexact_centered_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_divide (x, y);
+ return scm_i_exact_rational_centered_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide);
@@ -3708,7 +3611,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_inexact_centered_divide
(SCM_REAL_VALUE (x), scm_to_double (y));
- else
+ else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide);
}
@@ -3717,8 +3620,11 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_centered_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_divide (x, y);
else
- return scm_i_slow_exact_centered_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1,
@@ -3796,35 +3702,24 @@ scm_i_bigint_centered_divide (SCM x, SCM y)
scm_i_normbig (r)));
}
-/* Compute exact centered quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_centered_divide (SCM x, SCM y)
+scm_i_exact_rational_centered_divide (SCM x, SCM y)
{
- SCM q, r;
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1,
- s_scm_centered_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_sum (scm_divide (x, y),
- exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_difference (scm_divide (x, y),
- exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_divide);
- r = scm_difference (x, scm_product (q, y));
+ scm_i_extract_values_2
+ (scm_centered_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
return scm_values (scm_list_2 (q, r));
}
static SCM scm_i_inexact_round_quotient (double x, double y);
static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
-static SCM scm_i_slow_exact_round_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_round_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -3893,7 +3788,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_quotient (x, y);
+ return scm_i_exact_rational_round_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
s_scm_round_quotient);
@@ -3944,7 +3839,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
return scm_i_inexact_round_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_quotient (x, y);
+ return scm_i_exact_rational_round_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
s_scm_round_quotient);
@@ -3964,8 +3859,11 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_round_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_quotient (x, y);
else
- return scm_i_slow_exact_round_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
@@ -4014,27 +3912,17 @@ scm_i_bigint_round_quotient (SCM x, SCM y)
return scm_i_normbig (q);
}
-/* Compute exact round quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_round_quotient (SCM x, SCM y)
+scm_i_exact_rational_round_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
- s_scm_round_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_round_quotient);
- else
- return scm_round_number (scm_divide (x, y));
+ return scm_round_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_round_remainder (double x, double y);
static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
-static SCM scm_i_slow_exact_round_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_round_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -4104,7 +3992,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_remainder (x, y);
+ return scm_i_exact_rational_round_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
s_scm_round_remainder);
@@ -4152,7 +4040,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
return scm_i_inexact_round_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_remainder (x, y);
+ return scm_i_exact_rational_round_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
s_scm_round_remainder);
@@ -4172,8 +4060,11 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_round_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_remainder (x, y);
else
- return scm_i_slow_exact_round_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
@@ -4234,31 +4125,20 @@ scm_i_bigint_round_remainder (SCM x, SCM y)
return scm_i_normbig (r);
}
-/* Compute exact round_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_round_remainder (SCM x, SCM y)
+scm_i_exact_rational_round_remainder (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
- s_scm_round_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_round_remainder);
- else
- {
- SCM q = scm_round_number (scm_divide (x, y));
- return scm_difference (x, scm_product (q, y));
- }
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_round_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_round_divide (double x, double y);
static SCM scm_i_bigint_round_divide (SCM x, SCM y);
-static SCM scm_i_slow_exact_round_divide (SCM x, SCM y);
+static SCM scm_i_exact_rational_round_divide (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
(SCM x, SCM y),
@@ -4332,7 +4212,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_divide (x, y);
+ return scm_i_exact_rational_round_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
s_scm_round_divide);
@@ -4385,7 +4265,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
return scm_i_inexact_round_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_round_divide (x, y);
+ return scm_i_exact_rational_round_divide (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
s_scm_round_divide);
@@ -4396,7 +4276,7 @@ SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_inexact_round_divide
(SCM_REAL_VALUE (x), scm_to_double (y));
- else
+ else
SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
s_scm_round_divide);
}
@@ -4405,8 +4285,11 @@ SCM_PRIMITIVE_GENERIC (scm_round_divide, "round/", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_round_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_divide (x, y);
else
- return scm_i_slow_exact_round_divide (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide);
}
else
SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG1,
@@ -4464,26 +4347,19 @@ scm_i_bigint_round_divide (SCM x, SCM y)
scm_i_normbig (r)));
}
-/* Compute exact round quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_round_divide (SCM x, SCM y)
+scm_i_exact_rational_round_divide (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG1,
- s_scm_round_divide);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_round_divide, x, y, SCM_ARG2,
- s_scm_round_divide);
- else if (scm_is_true (scm_zero_p (y)))
- scm_num_overflow (s_scm_round_divide);
- else
- {
- SCM q = scm_round_number (scm_divide (x, y));
- SCM r = scm_difference (x, scm_product (q, y));
- return scm_values (scm_list_2 (q, r));
- }
+ SCM q, r, r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+
+ scm_i_extract_values_2
+ (scm_round_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd)),
+ &q, &r1);
+ r = scm_divide (r1, scm_product (xd, yd));
+ return scm_values (scm_list_2 (q, r));
}
--
1.5.6.5
^ permalink raw reply related [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-10 23:42 Mark H Weaver
@ 2011-02-12 11:55 ` Andy Wingo
2011-02-14 13:56 ` Ken Raeburn
2011-02-15 10:38 ` Ludovic Courtès
1 sibling, 1 reply; 12+ messages in thread
From: Andy Wingo @ 2011-02-12 11:55 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
On Fri 11 Feb 2011 00:42, Mark H Weaver <mhw@netris.org> writes:
> Here are three more patches. The first adds fast implementations of the
> remaining number-theoretic division operators as described in Taylor
> Campbell's proposal: floor/, ceiling/, truncate/, round/, as well as the
> single-valued variants. The third patch optimizes the case where both
> arguments are exact and at least one is a fraction.
Cool! It's a lot of code, but it does appear useful and tested, so I'm
inclined to merge it.
Regarding multiple values: instead of unpacking values objects (ugh),
can you instead make versions of _divide that return two values
directly, as output arguments?
You would then have to define wrappers that pack the return values into
a values object. Those wrappers could be static, if possible, so we
don't publicly expose more interfaces that return a SCM_VALUES object.
It would in the future be possible to do something much more efficient,
if we extended gsubrs to allow for multiple return values, so that
primitives could return multiple values without consing. But that's a
thought for later.
Also, does it make sense to implement quotient and remainder directly in
terms of divide? I suspect it might.
What do you think?
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
[not found] <860989.4731.qm@web114104.mail.gq1.yahoo.com>
@ 2011-02-12 20:19 ` Andy Wingo
2011-02-13 14:55 ` Mark H Weaver
0 siblings, 1 reply; 12+ messages in thread
From: Andy Wingo @ 2011-02-12 20:19 UTC (permalink / raw)
To: guile-devel
Hi list,
Mark Weaver writes in to say that his mail server crashed. The heavens
conspire against us! I'm mailing the list and bccing Mark at his
webmail (in case he is concerned about it leaking into the archives).
So this mail is really to Mark.
***
Very sorry to hear of your filesystem disasters! It never happens at a
convenient time, does it? Best of luck in pulling things together
again.
Indeed, I was reading too fast, and I guess I swallowed the second
paragraph without chewing ;) You are right, I had not considered all of
the ramifications.
I think that if I were fully reconciled to having values objects in our
API I would have no qualms with applying your patches. As it is, it
would make sense if the quotient and remainder operators were
implemented in terms of the division operators, but there are
performance problems there if we shunt things through value objects.
I am primarily concerned with the amount of work maintaining this
(excellent!) code will cause in the future. If it could be smaller
while exhibiting the same functionality and good performance that would
be great. Also, if we had an API which returned values in SCM*
arguments would be more amenable for use in the VM.
But, that's not possible now. I am just wondering if there is a
sensible way to make some kind of infrastructure investment here -- a
scm_c_call_with_n_values (SCM proc, size_t nargs, size_t nvals, SCM
*vals, SCM arg0...) that would remove the distortion that performance
concerns make on the structure of our code.
Even given all this, it might still be the right thing to do to apply
these patches, but I would like to hold off, pending Wednesday's 2.0
release. I am sorry that I am objecting to your code because of a
problem in Guile itself, but there it is.
Thanks again for your work; I hope we can reach the more perfect scheme
implementation that we dream of :) And good luck with that mail
server...
Peace,
Andy
On Sat 12 Feb 2011 20:00, Mark Weaver writes:
> Regarding your suggestion that I make versions of _divide that return
> two values via output arguments: please re-read my post. I talked
> about how I had originally started to do that, but found that it opened
> up a whole new can of worms, regarding what to do when I have to
> dispatch into GOOPS. Basically, all those calls to SCM_WTA_DISPATCH_2
> return a values object directly to the caller. We'd need to write
> new versions of those macros that unpack the values object and return
> the components via the output parameters. I'm not saying that it
> can't be done, and certainly it _should_ be done, but until we have better
> support for handling of multiple values from C, it's going to
> be a mess.
>
> Best,
> Mark
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
[not found] <595618.30923.qm@web114107.mail.gq1.yahoo.com>
@ 2011-02-12 21:54 ` Andy Wingo
2011-02-12 22:38 ` Mark Weaver
0 siblings, 1 reply; 12+ messages in thread
From: Andy Wingo @ 2011-02-12 21:54 UTC (permalink / raw)
To: Mark Weaver; +Cc: Ludovic Courtès, guile-devel
Hi Mark,
On Sat 12 Feb 2011 22:03, Mark Weaver <mark_weaver_45@yahoo.com> writes:
> I really hope you decide to at least apply the first patch for 2.0.
> They are very useful operators, and also they make the existing
> floor/ceiling/truncate/round operators a whole lot faster when applied
> to fractions. I worked very hard to get them ready for 2.0, and I
> really hope you reconsider.
Ludovic and I really appreciate your work on the numerics side of Guile.
It is wonderful to have someone as careful as you are in this area. And
it is obvious that this was not only careful work, it was a lot of it.
But do you really want these in, as they are? Look at the C API here:
SCM scm_round_divide (SCM, SCM)
It would be better if it were:
void scm_round_divide (SCM, SCM, SCM*, SCM*)
But it's not, because of our bad multiple-values story. If we are able
to reach the more appropriate API in the future, we'll have to give it
yet another name (because the right name is taken). Obviously we
couldn't do that for 2.0, because hey, that's Wednesday. But we can do
it for 2.0.1.
If you really want this API for 2.0.0, I think we can probably do it,
because this is your area. But I would like to ask you to consider what
it will be like working with this API in two years, or in five. If it's
still what you want, let me know, and I will merge it and the other
patches. (I'm not concerned about the SCM_INTERNAL values hack because
it can always be removed.). Otherwise, we have time to talk about it
for 2.0.1 :-)
Peace,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-12 21:54 ` [PATCH] New division operators, and optimization for fractions Andy Wingo
@ 2011-02-12 22:38 ` Mark Weaver
0 siblings, 0 replies; 12+ messages in thread
From: Mark Weaver @ 2011-02-12 22:38 UTC (permalink / raw)
To: Andy Wingo; +Cc: Ludovic Courtès, guile-devel
[-- Attachment #1: Type: text/plain, Size: 2277 bytes --]
Okay, I see what I need to do. I'll change the API as you suggest, and make an internal wrapper function for SCM_WTA_DISPATCH_2 that unpacks the values object returned from GOOPS and returns the values via the SCM* output parameters. I should be able to do this by Monday.
Thanks,
Mark
--- On Sat, 2/12/11, Andy Wingo <wingo@pobox.com> wrote:
From: Andy Wingo <wingo@pobox.com>
Subject: Re: [PATCH] New division operators, and optimization for fractions
To: "Mark Weaver" <mark_weaver_45@yahoo.com>
Cc: "Ludovic Courtès" <ludo@gnu.org>, "guile-devel" <guile-devel@gnu.org>
Date: Saturday, February 12, 2011, 9:54 PM
Hi Mark,
On Sat 12 Feb 2011 22:03, Mark Weaver <mark_weaver_45@yahoo.com> writes:
> I really hope you decide to at least apply the first patch for 2.0.
> They are very useful operators, and also they make the existing
> floor/ceiling/truncate/round operators a whole lot faster when applied
> to fractions. I worked very hard to get them ready for 2.0, and I
> really hope you reconsider.
Ludovic and I really appreciate your work on the numerics side of Guile.
It is wonderful to have someone as careful as you are in this area. And
it is obvious that this was not only careful work, it was a lot of it.
But do you really want these in, as they are? Look at the C API here:
SCM scm_round_divide (SCM, SCM)
It would be better if it were:
void scm_round_divide (SCM, SCM, SCM*, SCM*)
But it's not, because of our bad multiple-values story. If we are able
to reach the more appropriate API in the future, we'll have to give it
yet another name (because the right name is taken). Obviously we
couldn't do that for 2.0, because hey, that's Wednesday. But we can do
it for 2.0.1.
If you really want this API for 2.0.0, I think we can probably do it,
because this is your area. But I would like to ask you to consider what
it will be like working with this API in two years, or in five. If it's
still what you want, let me know, and I will merge it and the other
patches. (I'm not concerned about the SCM_INTERNAL values hack because
it can always be removed.). Otherwise, we have time to talk about it
for 2.0.1 :-)
Peace,
Andy
--
http://wingolog.org/
[-- Attachment #2: Type: text/html, Size: 2990 bytes --]
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-12 20:19 ` Andy Wingo
@ 2011-02-13 14:55 ` Mark H Weaver
2011-02-14 19:44 ` Andy Wingo
0 siblings, 1 reply; 12+ messages in thread
From: Mark H Weaver @ 2011-02-13 14:55 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1255 bytes --]
Hi Andy,
I have a new version of the patch set which I believe addresses all of
your (quite reasonable) concerns. The second patch changes the API of
the existing multi-valued operators as you suggest. The third optimizes
the fraction case. The fourth adds the new division operators. The
fifth optimizes the existing truncate/round/floor/ceiling unary
operators.
The sixth patch removes a lot of code, by implementing division
operators in terms of other division operators.
The other notable patch is the last one, which is unrelated to numerics,
but it addresses a problem I discovered while implementing a complex
number class in GOOPS. Suppose you define the following class within a
module:
(define-class <gcomplex> ()
(real-part #:getter real-part #:init-keyword #:real-part)
(imag-part #:getter imag-part #:init-keyword #:imag-part))
There's no way I have found to make this work correctly. If the module
exports real-part and imag-part, then those procedures will stop working
for normal complex numbers for those who import the module. If the
module does not export them, then those who import the module won't be
able to use real-part or imag-part on <gcomplex> objects. The last
patch fixes this.
Best,
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Added internal C function to extract from values object --]
[-- Type: text/x-diff, Size: 1801 bytes --]
From 0491d6f764dc76d083d184bea9a074bf47a53005 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 18:03:14 -0500
Subject: [PATCH 1/9] Added internal C function to extract from values object
* libguile/values.c (scm_i_extract_values_2): New internal function
that extracts two values from a values object.
* libguile/values.h: Added prototype.
---
libguile/values.c | 18 ++++++++++++++++++
libguile/values.h | 2 ++
2 files changed, 20 insertions(+), 0 deletions(-)
diff --git a/libguile/values.c b/libguile/values.c
index 8bbfc71..7dd9ecc 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -35,6 +35,24 @@
SCM scm_values_vtable;
+/* OBJ must be a values object containing exactly two values.
+ scm_i_extract_values_2 puts those two values into *p1 and *p2. */
+void
+scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
+{
+ SCM values;
+
+ SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
+ "scm_i_extract_values_2", "values");
+ values = scm_struct_ref (obj, SCM_INUM0);
+ if (!scm_is_null_or_nil (SCM_CDDR (values)))
+ scm_wrong_type_arg_msg
+ ("scm_i_extract_values_2", SCM_ARG1, obj,
+ "a values object containing exactly two values");
+ *p1 = SCM_CAR (values);
+ *p2 = SCM_CADR (values);
+}
+
static SCM
print_values (SCM obj, SCM pwps)
{
diff --git a/libguile/values.h b/libguile/values.h
index 0750aec..65ad8a1 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -30,6 +30,8 @@ SCM_API SCM scm_values_vtable;
#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
&& scm_is_eq (scm_struct_vtable (x), scm_values_vtable))
+SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
+
SCM_API SCM scm_values (SCM args);
SCM_INTERNAL void scm_init_values (void);
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Make divide functions return values via (SCM *) output arguments --]
[-- Type: text/x-diff, Size: 22545 bytes --]
From 9684a9503435970590e3d3af1b97b15fbcd23f8e Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 13 Feb 2011 05:47:33 -0500
Subject: [PATCH 2/9] 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.
---
doc/ref/api-data.texi | 35 ++++----
libguile/numbers.c | 247 ++++++++++++++++++++++++++++++------------------
libguile/numbers.h | 7 +-
3 files changed, 177 insertions(+), 112 deletions(-)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index fd2e7ee..6e37e9e 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1250,17 +1250,17 @@ respectively, but these functions take and return @code{double}
values.
@end deftypefn
-@deffn {Scheme Procedure} euclidean/ x y
-@deffnx {Scheme Procedure} euclidean-quotient x y
-@deffnx {Scheme Procedure} euclidean-remainder x y
-@deffnx {C Function} scm_euclidean_divide (x y)
-@deffnx {C Function} scm_euclidean_quotient (x y)
-@deffnx {C Function} scm_euclidean_remainder (x y)
+@deftypefn {Scheme Procedure} {} euclidean/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} euclidean-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} euclidean-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_euclidean_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_euclidean_quotient (SCM @var{x}, SCM @var{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
divisor @var{y} must be non-zero. @code{euclidean-quotient} returns the
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
-@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
that when @math{@var{y} > 0}, @code{euclidean-quotient} 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/ 16/3 -10/7) @result{} -3 and 22/21
@end lisp
-@end deffn
+@end deftypefn
-@deffn {Scheme Procedure} centered/ x y
-@deffnx {Scheme Procedure} centered-quotient x y
-@deffnx {Scheme Procedure} centered-remainder x y
-@deffnx {C Function} scm_centered_divide (x y)
-@deffnx {C Function} scm_centered_quotient (x y)
-@deffnx {C Function} scm_centered_remainder (x y)
+@deftypefn {Scheme Procedure} {} centered/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} centered-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} centered-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_centered_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_centered_quotient (SCM @var{x}, SCM @var{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
divisor @var{y} must be non-zero. @code{centered-quotient} returns the
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
-@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
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
the sign of @var{y}. If @math{@var{y} > 0}, ties are rounded toward
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
@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/ 16/3 -10/7) @result{} -4 and -8/21
@end lisp
-@end deffn
+@end deftypefn
@node Scientific
@subsubsection Scientific Functions
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 05840ef..8ac6412 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1069,6 +1069,29 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
}
#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_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 SCM scm_i_slow_exact_euclidean_divide (SCM x, SCM y);
+static void scm_i_inexact_euclidean_divide (double x, double 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),
"Return the integer @var{q} and the real number @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/ 16/3 -10/7) @result{} -3 and 22/21\n"
"@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)))
{
@@ -1437,8 +1474,6 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
{
scm_t_inum qq = xx / yy;
scm_t_inum rr = xx % yy;
- SCM q;
-
if (rr < 0)
{
if (yy > 0)
@@ -1447,23 +1482,27 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
{ rr -= yy; qq++; }
}
if (SCM_LIKELY (SCM_FIXABLE (qq)))
- q = SCM_I_MAKINUM (qq);
+ *qp = SCM_I_MAKINUM (qq);
else
- q = scm_i_inum2big (qq);
- return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
}
+ return;
}
else if (SCM_BIGP (y))
{
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)
{
SCM r = scm_i_mkbig ();
mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
scm_remember_upto_here_1 (y);
- return scm_values
- (scm_list_2 (SCM_I_MAKINUM (-1), scm_i_normbig (r)));
+ *qp = SCM_I_MAKINUM (-1);
+ *rp = scm_i_normbig (r);
}
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);
scm_remember_upto_here_1 (y);
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))
- 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))
- return scm_i_slow_exact_euclidean_divide (x, y);
+ return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide, qp, rp);
}
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));
}
scm_remember_upto_here_1 (x);
- return scm_values (scm_list_2 (scm_i_normbig (q),
- SCM_I_MAKINUM (rr)));
+ *qp = scm_i_normbig (q);
+ *rp = SCM_I_MAKINUM (rr);
}
+ return;
}
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),
SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
scm_remember_upto_here_2 (x, y);
- return scm_values (scm_list_2 (scm_i_normbig (q),
- scm_i_normbig (r)));
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ return;
}
else if (SCM_REALP (y))
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))
- return scm_i_slow_exact_euclidean_divide (x, y);
+ return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide, qp, rp);
}
else if (SCM_REALP (x))
{
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
SCM_BIGP (y) || SCM_FRACTIONP (y))
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
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide, qp, rp);
}
else if (SCM_FRACTIONP (x))
{
if (SCM_REALP (y))
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
- return scm_i_slow_exact_euclidean_divide (x, y);
+ return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
+ s_scm_euclidean_divide, qp, rp);
}
-#undef FUNC_NAME
-static SCM
-scm_i_inexact_euclidean_divide (double x, double y)
+static void
+scm_i_inexact_euclidean_divide (double x, double y, SCM *qp, SCM *rp)
{
double q, r;
@@ -1568,32 +1613,32 @@ scm_i_inexact_euclidean_divide (double x, double y)
else
q = guile_NaN;
r = x - q * y;
- return scm_values (scm_list_2 (scm_from_double (q),
- scm_from_double (r)));
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
}
/* Compute exact euclidean quotient and remainder the slow way.
We use this only if both arguments are exact,
and at least one of them is a fraction */
-static SCM
-scm_i_slow_exact_euclidean_divide (SCM x, SCM y)
+static void
+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)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
+ s_scm_euclidean_divide, qp, rp);
else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide);
+ return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide, qp, rp);
else if (scm_is_true (scm_positive_p (y)))
q = scm_floor (scm_divide (x, y));
else if (scm_is_true (scm_negative_p (y)))
q = scm_ceiling (scm_divide (x, y));
else
scm_num_overflow (s_scm_euclidean_divide);
- r = scm_difference (x, scm_product (q, y));
- return scm_values (scm_list_2 (q, r));
+ *qp = q;
+ *rp = scm_difference (x, scm_product (q, 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 SCM scm_i_bigint_centered_divide (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_divide (SCM x, SCM y);
+static void scm_i_inexact_centered_divide (double x, double y,
+ SCM *qp, SCM *rp);
+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),
"Return the integer @var{q} and the real number @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/ 16/3 -10/7) @result{} -4 and -8/21\n"
"@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)))
{
@@ -2083,8 +2142,6 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
{
scm_t_inum qq = xx / yy;
scm_t_inum rr = xx % yy;
- SCM q;
-
if (SCM_LIKELY (xx > 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)))
- q = SCM_I_MAKINUM (qq);
+ *qp = SCM_I_MAKINUM (qq);
else
- q = scm_i_inum2big (qq);
- return scm_values (scm_list_2 (q, SCM_I_MAKINUM (rr)));
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
}
+ return;
}
else if (SCM_BIGP (y))
{
/* Pass a denormalized bignum version of x (even though it
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))
- 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))
- return scm_i_slow_exact_centered_divide (x, y);
+ return scm_i_slow_exact_centered_divide (x, y, qp, rp);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide, qp, rp);
}
else if (SCM_BIGP (x))
{
@@ -2171,47 +2230,49 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
rr -= yy;
}
}
- return scm_values (scm_list_2 (scm_i_normbig (q),
- SCM_I_MAKINUM (rr)));
+ *qp = scm_i_normbig (q);
+ *rp = SCM_I_MAKINUM (rr);
}
+ return;
}
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))
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))
- return scm_i_slow_exact_centered_divide (x, y);
+ return scm_i_slow_exact_centered_divide (x, y, qp, rp);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide, qp, rp);
}
else if (SCM_REALP (x))
{
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
SCM_BIGP (y) || SCM_FRACTIONP (y))
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
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2
+ (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide, qp, rp);
}
else if (SCM_FRACTIONP (x))
{
if (SCM_REALP (y))
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
- return scm_i_slow_exact_centered_divide (x, y);
+ return scm_i_slow_exact_centered_divide (x, y, qp, rp);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
+ s_scm_centered_divide, qp, rp);
}
-#undef FUNC_NAME
-static SCM
-scm_i_inexact_centered_divide (double x, double y)
+static void
+scm_i_inexact_centered_divide (double x, double y, SCM *qp, SCM *rp)
{
double q, r;
@@ -2224,14 +2285,14 @@ scm_i_inexact_centered_divide (double x, double y)
else
q = guile_NaN;
r = x - q * y;
- return scm_values (scm_list_2 (scm_from_double (q),
- scm_from_double (r)));
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
}
/* Assumes that both x and y are bigints, though
x might be able to fit into a fixnum. */
-static SCM
-scm_i_bigint_centered_divide (SCM x, SCM y)
+static void
+scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{
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);
- return scm_values (scm_list_2 (scm_i_normbig (q),
- scm_i_normbig (r)));
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
}
/* Compute exact centered quotient and remainder the slow way.
We use this only if both arguments are exact,
and at least one of them is a fraction */
-static SCM
-scm_i_slow_exact_centered_divide (SCM x, SCM y)
+static void
+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)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG1,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
+ s_scm_centered_divide, qp, rp);
else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide);
+ return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide, qp, rp);
else if (scm_is_true (scm_positive_p (y)))
q = scm_floor (scm_sum (scm_divide (x, y),
exactly_one_half));
@@ -2302,8 +2363,8 @@ scm_i_slow_exact_centered_divide (SCM x, SCM y)
exactly_one_half));
else
scm_num_overflow (s_scm_centered_divide);
- r = scm_difference (x, scm_product (q, y));
- return scm_values (scm_list_2 (q, r));
+ *qp = q;
+ *rp = scm_difference (x, scm_product (q, y));
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 10a4f17..b8529a3 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -178,10 +178,10 @@ SCM_API SCM scm_abs (SCM x);
SCM_API SCM scm_quotient (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_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_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_remainder (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_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_lcm (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_logand (SCM x, SCM y, SCM rest);
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Optimize division operators handling of fractions --]
[-- Type: text/x-diff, Size: 19997 bytes --]
From 584440d5405659da56553eeb933e41ce339f8677 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 13 Feb 2011 06:04:52 -0500
Subject: [PATCH 3/9] Optimize division operators handling of fractions
* libguile/numbers.c: (scm_euclidean_quotient, scm_euclidean_remainder,
scm_euclidean_divide, scm_centered_quotient, scm_centered_remainder,
scm_centered_divide): Optimize case where both arguments are exact and
at least one is a fraction, by reducing to a subproblem involving only
integers, and then adjusting the resulting remainder as needed.
---
libguile/numbers.c | 224 ++++++++++++++++++++--------------------------------
1 files changed, 85 insertions(+), 139 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 8ac6412..e779c42 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1093,7 +1093,7 @@ two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
}
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_exact_rational_euclidean_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -1148,7 +1148,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
s_scm_euclidean_quotient);
@@ -1194,7 +1194,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
return scm_i_inexact_euclidean_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
s_scm_euclidean_quotient);
@@ -1214,8 +1214,11 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_euclidean_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_quotient (x, y);
else
- return scm_i_slow_exact_euclidean_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
+ s_scm_euclidean_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
@@ -1236,28 +1239,16 @@ scm_i_inexact_euclidean_quotient (double x, double y)
return scm_nan ();
}
-/* Compute exact euclidean_quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_euclidean_quotient (SCM x, SCM y)
+scm_i_exact_rational_euclidean_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
- s_scm_euclidean_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- else if (scm_is_true (scm_positive_p (y)))
- return scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- return scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_quotient);
+ return scm_euclidean_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_euclidean_remainder (double x, double y);
-static SCM scm_i_slow_exact_euclidean_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_euclidean_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -1317,7 +1308,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
s_scm_euclidean_remainder);
@@ -1352,7 +1343,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
return scm_i_inexact_euclidean_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
s_scm_euclidean_remainder);
@@ -1372,8 +1363,11 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_euclidean_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_remainder (x, y);
else
- return scm_i_slow_exact_euclidean_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
+ s_scm_euclidean_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
@@ -1406,33 +1400,21 @@ scm_i_inexact_euclidean_remainder (double x, double y)
return scm_from_double (x - q * y);
}
-/* Compute exact euclidean_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_euclidean_remainder (SCM x, SCM y)
+scm_i_exact_rational_euclidean_remainder (SCM x, SCM y)
{
- SCM q;
-
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
- s_scm_euclidean_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_remainder);
- return scm_difference (x, scm_product (y, q));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_euclidean_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static void scm_i_inexact_euclidean_divide (double x, double y,
SCM *qp, SCM *rp);
-static void scm_i_slow_exact_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp);
+static void scm_i_exact_rational_euclidean_divide (SCM x, SCM y,
+ SCM *qp, SCM *rp);
SCM_PRIMITIVE_GENERIC (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
(SCM x, SCM y),
@@ -1518,7 +1500,7 @@ scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
else if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
+ return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
else
return two_valued_wta_dispatch_2
(g_scm_euclidean_divide, x, y, SCM_ARG2,
@@ -1569,7 +1551,7 @@ scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
return scm_i_inexact_euclidean_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
+ return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
else
return two_valued_wta_dispatch_2
(g_scm_euclidean_divide, x, y, SCM_ARG2,
@@ -1591,8 +1573,12 @@ scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
if (SCM_REALP (y))
return scm_i_inexact_euclidean_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
else
- return scm_i_slow_exact_euclidean_divide (x, y, qp, rp);
+ return two_valued_wta_dispatch_2
+ (g_scm_euclidean_divide, x, y, SCM_ARG2,
+ s_scm_euclidean_divide, qp, rp);
}
else
return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
@@ -1617,33 +1603,22 @@ scm_i_inexact_euclidean_divide (double x, double y, SCM *qp, SCM *rp)
*rp = scm_from_double (r);
}
-/* Compute exact euclidean quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static void
-scm_i_slow_exact_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+scm_i_exact_rational_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{
- SCM q;
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide, qp, rp);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_divide (x, y));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_divide (x, y));
- else
- scm_num_overflow (s_scm_euclidean_divide);
- *qp = q;
- *rp = scm_difference (x, scm_product (q, y));
+ scm_euclidean_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
}
static SCM scm_i_inexact_centered_quotient (double x, double y);
static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
(SCM x, SCM y),
@@ -1713,7 +1688,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_centered_quotient (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_quotient (x, y);
+ return scm_i_exact_rational_centered_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
s_scm_centered_quotient);
@@ -1762,7 +1737,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
return scm_i_inexact_centered_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_quotient (x, y);
+ return scm_i_exact_rational_centered_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
s_scm_centered_quotient);
@@ -1782,8 +1757,11 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_centered_quotient
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_quotient (x, y);
else
- return scm_i_slow_exact_centered_quotient (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
@@ -1847,31 +1825,17 @@ scm_i_bigint_centered_quotient (SCM x, SCM y)
return scm_i_normbig (q);
}
-/* Compute exact centered quotient the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_centered_quotient (SCM x, SCM y)
+scm_i_exact_rational_centered_quotient (SCM x, SCM y)
{
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
- else if (scm_is_true (scm_positive_p (y)))
- return scm_floor (scm_sum (scm_divide (x, y),
- exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- return scm_ceiling (scm_difference (scm_divide (x, y),
- exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_quotient);
+ return scm_centered_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
}
static SCM scm_i_inexact_centered_remainder (double x, double y);
static SCM scm_i_bigint_centered_remainder (SCM x, SCM y);
-static SCM scm_i_slow_exact_centered_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_centered_remainder (SCM x, SCM y);
SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
(SCM x, SCM y),
@@ -1938,7 +1902,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
else if (SCM_REALP (y))
return scm_i_inexact_centered_remainder (xx, SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_remainder (x, y);
+ return scm_i_exact_rational_centered_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
s_scm_centered_remainder);
@@ -1979,7 +1943,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
return scm_i_inexact_centered_remainder
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_remainder (x, y);
+ return scm_i_exact_rational_centered_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
s_scm_centered_remainder);
@@ -1999,8 +1963,11 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
if (SCM_REALP (y))
return scm_i_inexact_centered_remainder
(scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_remainder (x, y);
else
- return scm_i_slow_exact_centered_remainder (x, y);
+ SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
@@ -2073,34 +2040,22 @@ scm_i_bigint_centered_remainder (SCM x, SCM y)
return scm_i_normbig (r);
}
-/* Compute exact centered_remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static SCM
-scm_i_slow_exact_centered_remainder (SCM x, SCM y)
+scm_i_exact_rational_centered_remainder (SCM x, SCM y)
{
- SCM q;
-
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_sum (scm_divide (x, y), exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_difference (scm_divide (x, y), exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_remainder);
- return scm_difference (x, scm_product (y, q));
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_centered_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
}
static void scm_i_inexact_centered_divide (double x, double y,
SCM *qp, SCM *rp);
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);
+static void scm_i_exact_rational_centered_divide (SCM x, SCM y,
+ SCM *qp, SCM *rp);
SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
(SCM x, SCM y),
@@ -2185,7 +2140,7 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
else if (SCM_REALP (y))
return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_divide (x, y, qp, rp);
+ return scm_i_exact_rational_centered_divide (x, y, qp, rp);
else
return two_valued_wta_dispatch_2
(g_scm_centered_divide, x, y, SCM_ARG2,
@@ -2241,7 +2196,7 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
return scm_i_inexact_centered_divide
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
else if (SCM_FRACTIONP (y))
- return scm_i_slow_exact_centered_divide (x, y, qp, rp);
+ return scm_i_exact_rational_centered_divide (x, y, qp, rp);
else
return two_valued_wta_dispatch_2
(g_scm_centered_divide, x, y, SCM_ARG2,
@@ -2253,7 +2208,7 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_inexact_centered_divide
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
- else
+ else
return two_valued_wta_dispatch_2
(g_scm_centered_divide, x, y, SCM_ARG2,
s_scm_centered_divide, qp, rp);
@@ -2263,8 +2218,12 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
if (SCM_REALP (y))
return scm_i_inexact_centered_divide
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_centered_divide (x, y, qp, rp);
else
- return scm_i_slow_exact_centered_divide (x, y, qp, rp);
+ return two_valued_wta_dispatch_2
+ (g_scm_centered_divide, x, y, SCM_ARG2,
+ s_scm_centered_divide, qp, rp);
}
else
return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
@@ -2341,30 +2300,17 @@ scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
*rp = scm_i_normbig (r);
}
-/* Compute exact centered quotient and remainder the slow way.
- We use this only if both arguments are exact,
- and at least one of them is a fraction */
static void
-scm_i_slow_exact_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+scm_i_exact_rational_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
{
- SCM q;
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
- if (!(SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x)))
- return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
- s_scm_centered_divide, qp, rp);
- else if (!(SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)))
- return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
- s_scm_centered_divide, qp, rp);
- else if (scm_is_true (scm_positive_p (y)))
- q = scm_floor (scm_sum (scm_divide (x, y),
- exactly_one_half));
- else if (scm_is_true (scm_negative_p (y)))
- q = scm_ceiling (scm_difference (scm_divide (x, y),
- exactly_one_half));
- else
- scm_num_overflow (s_scm_centered_divide);
- *qp = q;
- *rp = scm_difference (x, scm_product (q, y));
+ scm_centered_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
}
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: Add four new sets of fast quotient and remainder operators --]
[-- Type: text/x-diff, Size: 83806 bytes --]
From 847ba69f3cb9c4b6537e899159416d1c916706dc Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 13 Feb 2011 09:16:27 -0500
Subject: [PATCH 4/9] Add four new sets of fast quotient and remainder operators
* libguile/numbers.c (scm_floor_divide, scm_floor_quotient,
scm_floor_remainder, scm_ceiling_divide, scm_ceiling_quotient,
scm_ceiling_remainder, scm_truncate_divide, scm_truncate_quotient,
scm_truncate_remainder, scm_round_divide, scm_round_quotient,
scm_round_remainder): New extensible procedures `floor/',
`floor-quotient', `floor-remainder', `ceiling/', `ceiling-quotient',
`ceiling-remainder', `truncate/', `truncate-quotient',
`truncate-remainder', `round/', `round-quotient', and
`round-remainder'.
* libguile/numbers.h: Add function prototypes.
* test-suite/tests/numbers.test: Add tests.
* doc/ref/api-data.texi (Arithmetic): Add documentation.
* NEWS: Add NEWS entry.
---
NEWS | 28 +
doc/ref/api-data.texi | 148 +++-
libguile/numbers.c | 2187 +++++++++++++++++++++++++++++++++++++++++
libguile/numbers.h | 16 +
test-suite/tests/numbers.test | 75 ++-
5 files changed, 2451 insertions(+), 3 deletions(-)
diff --git a/NEWS b/NEWS
index df44517..6bebbf6 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,34 @@ instead.
`define-once' is like Lisp's `defvar': it creates a toplevel binding,
but only if one does not exist already.
+** Added four new sets of fast quotient and remainder operators
+
+Added four new sets of fast quotient and remainder operators with
+different semantics than the R5RS operators. They support not only
+integers, but all reals, including exact rationals and inexact
+floating point numbers.
+
+These procedures accept two real numbers N and D, where the divisor D
+must be non-zero. Each set of operators computes an integer quotient
+Q and a real remainder R such that N = Q*D + R and |R| < |D|. They
+differ only in how N/D is rounded to produce Q.
+
+`floor-quotient' and `floor-remainder' compute Q and R, respectively,
+where Q has been rounded toward negative infinity. `floor/' returns
+both Q and R, and is more efficient than computing each separately.
+Note that when applied to integers, `floor-remainder' is equivalent to
+the R5RS integer-only `modulo' operator. `ceiling-quotient',
+`ceiling-remainder', and `ceiling/' are similar except that Q is
+rounded toward positive infinity.
+
+For `truncate-quotient', `truncate-remainder', and `truncate/', Q is
+rounded toward zero. Note that when applied to integers,
+`truncate-quotient' and `truncate-remainder' are equivalent to the
+R5RS integer-only operators `quotient' and `remainder'.
+
+For `round-quotient', `round-remainder', and `round/', Q is rounded to
+the nearest integer, with ties going to the nearest even integer.
+
** Improved exactness handling for complex number parsing
When parsing non-real complex numbers, exactness specifiers are now
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 6e37e9e..418dc85 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -907,7 +907,7 @@ sign as @var{n}. In all cases quotient and remainder satisfy
(remainder -13 4) @result{} -1
@end lisp
-See also @code{euclidean-quotient}, @code{euclidean-remainder} and
+See also @code{truncate-quotient}, @code{truncate-remainder} and
related operations in @ref{Arithmetic}.
@end deffn
@@ -924,7 +924,7 @@ sign as @var{d}.
(modulo -13 -4) @result{} -1
@end lisp
-See also @code{euclidean-quotient}, @code{euclidean-remainder} and
+See also @code{floor-quotient}, @code{floor-remainder} and
related operations in @ref{Arithmetic}.
@end deffn
@@ -1148,9 +1148,21 @@ Returns the magnitude or angle of @var{z} as a @code{double}.
@rnindex euclidean/
@rnindex euclidean-quotient
@rnindex euclidean-remainder
+@rnindex floor/
+@rnindex floor-quotient
+@rnindex floor-remainder
+@rnindex ceiling/
+@rnindex ceiling-quotient
+@rnindex ceiling-remainder
+@rnindex truncate/
+@rnindex truncate-quotient
+@rnindex truncate-remainder
@rnindex centered/
@rnindex centered-quotient
@rnindex centered-remainder
+@rnindex round/
+@rnindex round-quotient
+@rnindex round-remainder
The C arithmetic functions below always takes two arguments, while the
Scheme functions can take an arbitrary number. When you need to
@@ -1281,6 +1293,93 @@ Note that these operators are equivalent to the R6RS operators
@end lisp
@end deftypefn
+@deftypefn {Scheme Procedure} {} floor/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} floor-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} floor-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_floor_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_floor_quotient (@var{x}, @var{y})
+@deftypefnx {C Function} SCM scm_floor_remainder (@var{x}, @var{y})
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{floor-quotient} returns the
+integer @var{q} and @code{floor-remainder} returns the real number
+@var{r} such that @math{@var{q} = floor(@var{x}/@var{y})} and
+@math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{floor/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the same sign
+as @var{y}.
+
+When @var{x} and @var{y} are integers, @code{floor-quotient} is
+equivalent to the R5RS integer-only operator @code{modulo}.
+
+@lisp
+(floor-quotient 123 10) @result{} 12
+(floor-remainder 123 10) @result{} 3
+(floor/ 123 10) @result{} 12 and 3
+(floor/ 123 -10) @result{} -13 and -7
+(floor/ -123 10) @result{} -13 and 7
+(floor/ -123 -10) @result{} 12 and -3
+(floor/ -123.2 -63.5) @result{} 1.0 and -59.7
+(floor/ 16/3 -10/7) @result{} -4 and -8/21
+@end lisp
+@end deftypefn
+
+@deftypefn {Scheme Procedure} {} ceiling/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} ceiling-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} ceiling-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_ceiling_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_ceiling_quotient (@var{x}, @var{y})
+@deftypefnx {C Function} SCM scm_ceiling_remainder (@var{x}, @var{y})
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{ceiling-quotient} returns the
+integer @var{q} and @code{ceiling-remainder} returns the real number
+@var{r} such that @math{@var{q} = ceiling(@var{x}/@var{y})} and
+@math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{ceiling/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the opposite sign
+of @var{y}.
+
+@lisp
+(ceiling-quotient 123 10) @result{} 13
+(ceiling-remainder 123 10) @result{} -7
+(ceiling/ 123 10) @result{} 13 and -7
+(ceiling/ 123 -10) @result{} -12 and 3
+(ceiling/ -123 10) @result{} -12 and -3
+(ceiling/ -123 -10) @result{} 13 and 7
+(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8
+(ceiling/ 16/3 -10/7) @result{} -3 and 22/21
+@end lisp
+@end deftypefn
+
+@deftypefn {Scheme Procedure} {} truncate/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} truncate-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} truncate-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_truncate_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_truncate_quotient (@var{x}, @var{y})
+@deftypefnx {C Function} SCM scm_truncate_remainder (@var{x}, @var{y})
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{truncate-quotient} returns the
+integer @var{q} and @code{truncate-remainder} returns the real number
+@var{r} such that @var{q} is @math{@var{x}/@var{y}} rounded toward zero,
+and @math{@var{x} = @var{q}*@var{y} + @var{r}}. @code{truncate/} returns
+both @var{q} and @var{r}, and is more efficient than computing each
+separately. Note that @var{r}, if non-zero, will have the same sign
+as @var{x}.
+
+When @var{x} and @var{y} are integers, these operators are equivalent to
+the R5RS integer-only operators @code{quotient} and @code{remainder}.
+
+@lisp
+(truncate-quotient 123 10) @result{} 12
+(truncate-remainder 123 10) @result{} 3
+(truncate/ 123 10) @result{} 12 and 3
+(truncate/ 123 -10) @result{} -12 and 3
+(truncate/ -123 10) @result{} -12 and -3
+(truncate/ -123 -10) @result{} 12 and -3
+(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7
+(truncate/ 16/3 -10/7) @result{} -3 and 22/21
+@end lisp
+@end deftypefn
+
@deftypefn {Scheme Procedure} {} centered/ @var{x} @var{y}
@deftypefnx {Scheme Procedure} {} centered-quotient @var{x} @var{y}
@deftypefnx {Scheme Procedure} {} centered-remainder @var{x} @var{y}
@@ -1313,11 +1412,56 @@ Note that these operators are equivalent to the R6RS operators
(centered/ 123 -10) @result{} -12 and 3
(centered/ -123 10) @result{} -12 and -3
(centered/ -123 -10) @result{} 12 and -3
+(centered/ 125 10) @result{} 13 and -5
+(centered/ 127 10) @result{} 13 and -3
+(centered/ 135 10) @result{} 14 and -5
(centered/ -123.2 -63.5) @result{} 2.0 and 3.8
(centered/ 16/3 -10/7) @result{} -4 and -8/21
@end lisp
@end deftypefn
+@deftypefn {Scheme Procedure} {} round/ @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} round-quotient @var{x} @var{y}
+@deftypefnx {Scheme Procedure} {} round-remainder @var{x} @var{y}
+@deftypefnx {C Function} void scm_round_divide (SCM @var{x}, SCM @var{y}, SCM *@var{q}, SCM *@var{r})
+@deftypefnx {C Function} SCM scm_round_quotient (@var{x}, @var{y})
+@deftypefnx {C Function} SCM scm_round_remainder (@var{x}, @var{y})
+These procedures accept two real numbers @var{x} and @var{y}, where the
+divisor @var{y} must be non-zero. @code{round-quotient} returns the
+integer @var{q} and @code{round-remainder} returns the real number
+@var{r} such that @math{@var{x} = @var{q}*@var{y} + @var{r}} and
+@var{q} is @math{@var{x}/@var{y}} rounded to the nearest integer,
+with ties going to the nearest even integer. @code{round/}
+returns both @var{q} and @var{r}, and is more efficient than computing
+each separately.
+
+Note that @code{round/} and @code{centered/} are almost equivalent, but
+their behavior differs when @math{@var{x}/@var{y}} lies exactly half-way
+between two integers. In this case, @code{round/} chooses the nearest
+even integer, whereas @code{centered/} chooses in such a way to satisfy
+the constraint @math{-|@var{y}/2| <= @var{r} < |@var{y}/2|}, which
+is stronger than the corresponding constraint for @code{round/},
+@math{-|@var{y}/2| <= @var{r} <= |@var{y}/2|}. In particular,
+when @var{x} and @var{y} are integers, the number of possible remainders
+returned by @code{centered/} is @math{|@var{y}|}, whereas the number of
+possible remainders returned by @code{round/} is @math{|@var{y}|+1} when
+@var{y} is even.
+
+@lisp
+(round-quotient 123 10) @result{} 12
+(round-remainder 123 10) @result{} 3
+(round/ 123 10) @result{} 12 and 3
+(round/ 123 -10) @result{} -12 and 3
+(round/ -123 10) @result{} -12 and -3
+(round/ -123 -10) @result{} 12 and -3
+(round/ 125 10) @result{} 12 and 5
+(round/ 127 10) @result{} 13 and -3
+(round/ 135 10) @result{} 14 and -5
+(round/ -123.2 -63.5) @result{} 2.0 and 3.8
+(round/ 16/3 -10/7) @result{} -4 and -8/21
+@end lisp
+@end deftypefn
+
@node Scientific
@subsubsection Scientific Functions
diff --git a/libguile/numbers.c b/libguile/numbers.c
index e779c42..9107c81 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1616,6 +1616,1537 @@ scm_i_exact_rational_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
*rp = scm_divide (r1, scm_product (xd, yd));
}
+static SCM scm_i_inexact_floor_quotient (double x, double y);
+static SCM scm_i_exact_rational_floor_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the floor of @math{@var{x} / @var{y}}.\n"
+ "@lisp\n"
+ "(floor-quotient 123 10) @result{} 12\n"
+ "(floor-quotient 123 -10) @result{} -13\n"
+ "(floor-quotient -123 10) @result{} -13\n"
+ "(floor-quotient -123 -10) @result{} 12\n"
+ "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
+ "(floor-quotient 16/3 -10/7) @result{} -4\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_floor_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum xx1 = xx;
+ scm_t_inum qq;
+ if (SCM_LIKELY (yy > 0))
+ {
+ if (SCM_UNLIKELY (xx < 0))
+ xx1 = xx - yy + 1;
+ }
+ else if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_quotient);
+ else if (xx > 0)
+ xx1 = xx - yy - 1;
+ qq = xx1 / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
+ else
+ return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_fdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_floor_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (floor (x / y));
+}
+
+static SCM
+scm_i_exact_rational_floor_quotient (SCM x, SCM y)
+{
+ return scm_floor_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
+}
+
+static SCM scm_i_inexact_floor_remainder (double x, double y);
+static SCM scm_i_exact_rational_floor_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(floor-remainder 123 10) @result{} 3\n"
+ "(floor-remainder 123 -10) @result{} -7\n"
+ "(floor-remainder -123 10) @result{} 7\n"
+ "(floor-remainder -123 -10) @result{} -3\n"
+ "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
+ "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_floor_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_remainder);
+ else
+ {
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr < 0);
+ else
+ needs_adjustment = (rr > 0);
+
+ if (needs_adjustment)
+ rr += yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ {
+ if (xx < 0)
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+ }
+ else
+ return x;
+ }
+ else if (xx <= 0)
+ return x;
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_remainder);
+ else
+ {
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
+ else
+ rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_fdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_floor_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_floor_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or y, but those two cases must
+ correspond to different choices of q. If r = 0.0 then q must be
+ x/y, and if r = y then q must be x/y-1. If quotient chooses one
+ and remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * floor (x / y));
+}
+
+static SCM
+scm_i_exact_rational_floor_remainder (SCM x, SCM y)
+{
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_floor_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
+}
+
+
+static void scm_i_inexact_floor_divide (double x, double y,
+ SCM *qp, SCM *rp);
+static void scm_i_exact_rational_floor_divide (SCM x, SCM y,
+ SCM *qp, SCM *rp);
+
+SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(floor/ 123 10) @result{} 12 and 3\n"
+ "(floor/ 123 -10) @result{} -13 and -7\n"
+ "(floor/ -123 10) @result{} -13 and 7\n"
+ "(floor/ -123 -10) @result{} 12 and -3\n"
+ "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
+ "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_floor_divide
+{
+ SCM q, r;
+
+ scm_floor_divide(x, y, &q, &r);
+ return scm_values (scm_list_2 (q, r));
+}
+#undef FUNC_NAME
+
+#define s_scm_floor_divide s_scm_i_floor_divide
+#define g_scm_floor_divide g_scm_i_floor_divide
+
+void
+scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr < 0);
+ else
+ needs_adjustment = (rr > 0);
+
+ if (needs_adjustment)
+ {
+ rr += yy;
+ qq--;
+ }
+
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ *qp = SCM_I_MAKINUM (qq);
+ else
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (sign > 0)
+ {
+ if (xx < 0)
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ *qp = SCM_I_MAKINUM (-1);
+ *rp = scm_i_normbig (r);
+ }
+ else
+ {
+ *qp = SCM_INUM0;
+ *rp = x;
+ }
+ }
+ else if (xx <= 0)
+ {
+ *qp = SCM_INUM0;
+ *rp = x;
+ }
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ *qp = SCM_I_MAKINUM (-1);
+ *rp = scm_i_normbig (r);
+ }
+ return;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide, qp, rp);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_floor_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ return;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide, qp, rp);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_floor_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide, qp, rp);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_floor_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_floor_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
+ s_scm_floor_divide, qp, rp);
+ }
+ else
+ return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
+ s_scm_floor_divide, qp, rp);
+}
+
+static void
+scm_i_inexact_floor_divide (double x, double y, SCM *qp, SCM *rp)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_floor_divide); /* or return a NaN? */
+ else
+ {
+ double q = floor (x / y);
+ double r = x - q * y;
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
+ }
+}
+
+static void
+scm_i_exact_rational_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+
+ scm_floor_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
+}
+
+static SCM scm_i_inexact_ceiling_quotient (double x, double y);
+static SCM scm_i_exact_rational_ceiling_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the ceiling of @math{@var{x} / @var{y}}.\n"
+ "@lisp\n"
+ "(ceiling-quotient 123 10) @result{} 13\n"
+ "(ceiling-quotient 123 -10) @result{} -12\n"
+ "(ceiling-quotient -123 10) @result{} -12\n"
+ "(ceiling-quotient -123 -10) @result{} 13\n"
+ "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ceiling_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else
+ {
+ scm_t_inum xx1 = xx;
+ scm_t_inum qq;
+ if (SCM_LIKELY (yy > 0))
+ {
+ if (SCM_LIKELY (xx >= 0))
+ xx1 = xx + yy - 1;
+ }
+ else if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else if (xx < 0)
+ xx1 = xx + yy + 1;
+ qq = xx1 / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ return SCM_INUM1;
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ return SCM_INUM0;
+ }
+ else if (xx >= 0)
+ return SCM_INUM0;
+ else
+ return SCM_INUM1;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_cdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_ceiling_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (ceil (x / y));
+}
+
+static SCM
+scm_i_exact_rational_ceiling_quotient (SCM x, SCM y)
+{
+ return scm_ceiling_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
+}
+
+static SCM scm_i_inexact_ceiling_remainder (double x, double y);
+static SCM scm_i_exact_rational_ceiling_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(ceiling-remainder 123 10) @result{} -7\n"
+ "(ceiling-remainder 123 -10) @result{} 3\n"
+ "(ceiling-remainder -123 10) @result{} -3\n"
+ "(ceiling-remainder -123 -10) @result{} 7\n"
+ "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ceiling_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_remainder);
+ else
+ {
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr > 0);
+ else
+ needs_adjustment = (rr < 0);
+
+ if (needs_adjustment)
+ rr -= yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_i_normbig (r);
+ }
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_INUM0;
+ }
+ else
+ return x;
+ }
+ else if (xx >= 0)
+ return x;
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ return scm_i_normbig (r);
+ }
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_remainder);
+ else
+ {
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
+ else
+ rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), -yy);
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_cdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_ceiling_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or -y, but those two cases must
+ correspond to different choices of q. If r = 0.0 then q must be
+ x/y, and if r = -y then q must be x/y+1. If quotient chooses one
+ and remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * ceil (x / y));
+}
+
+static SCM
+scm_i_exact_rational_ceiling_remainder (SCM x, SCM y)
+{
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_ceiling_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
+}
+
+static void scm_i_inexact_ceiling_divide (double x, double y,
+ SCM *qp, SCM *rp);
+static void scm_i_exact_rational_ceiling_divide (SCM x, SCM y,
+ SCM *qp, SCM *rp);
+
+SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(ceiling/ 123 10) @result{} 13 and -7\n"
+ "(ceiling/ 123 -10) @result{} -12 and 3\n"
+ "(ceiling/ -123 10) @result{} -12 and -3\n"
+ "(ceiling/ -123 -10) @result{} 13 and 7\n"
+ "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_ceiling_divide
+{
+ SCM q, r;
+
+ scm_ceiling_divide(x, y, &q, &r);
+ return scm_values (scm_list_2 (q, r));
+}
+#undef FUNC_NAME
+
+#define s_scm_ceiling_divide s_scm_i_ceiling_divide
+#define g_scm_ceiling_divide g_scm_i_ceiling_divide
+
+void
+scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ int needs_adjustment;
+
+ if (SCM_LIKELY (yy > 0))
+ needs_adjustment = (rr > 0);
+ else
+ needs_adjustment = (rr < 0);
+
+ if (needs_adjustment)
+ {
+ rr -= yy;
+ qq++;
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ *qp = SCM_I_MAKINUM (qq);
+ else
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ if (SCM_LIKELY (sign > 0))
+ {
+ if (SCM_LIKELY (xx > 0))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ *qp = SCM_INUM1;
+ *rp = scm_i_normbig (r);
+ }
+ else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ *qp = SCM_I_MAKINUM (-1);
+ *rp = SCM_INUM0;
+ }
+ else
+ {
+ *qp = SCM_INUM0;
+ *rp = x;
+ }
+ }
+ else if (xx >= 0)
+ {
+ *qp = SCM_INUM0;
+ *rp = x;
+ }
+ else
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
+ scm_remember_upto_here_1 (y);
+ mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
+ *qp = SCM_INUM1;
+ *rp = scm_i_normbig (r);
+ }
+ return;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide, qp, rp);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_ceiling_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ return;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide, qp, rp);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_ceiling_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide, qp, rp);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_ceiling_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
+ s_scm_ceiling_divide, qp, rp);
+ }
+ else
+ return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
+ s_scm_ceiling_divide, qp, rp);
+}
+
+static void
+scm_i_inexact_ceiling_divide (double x, double y, SCM *qp, SCM *rp)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_ceiling_divide); /* or return a NaN? */
+ else
+ {
+ double q = ceil (x / y);
+ double r = x - q * y;
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
+ }
+}
+
+static void
+scm_i_exact_rational_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+
+ scm_ceiling_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
+}
+
+static SCM scm_i_inexact_truncate_quotient (double x, double y);
+static SCM scm_i_exact_rational_truncate_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
+ "@lisp\n"
+ "(truncate-quotient 123 10) @result{} 12\n"
+ "(truncate-quotient 123 -10) @result{} -12\n"
+ "(truncate-quotient -123 10) @result{} -12\n"
+ "(truncate-quotient -123 -10) @result{} 12\n"
+ "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
+ "(truncate-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_truncate_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_quotient);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ return SCM_INUM0;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ if (yy > 0)
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ mpz_tdiv_q (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (q);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_truncate_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (scm_c_truncate (x / y));
+}
+
+static SCM
+scm_i_exact_rational_truncate_quotient (SCM x, SCM y)
+{
+ return scm_truncate_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
+}
+
+static SCM scm_i_inexact_truncate_remainder (double x, double y);
+static SCM scm_i_exact_rational_truncate_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(truncate-remainder 123 10) @result{} 3\n"
+ "(truncate-remainder 123 -10) @result{} 3\n"
+ "(truncate-remainder -123 10) @result{} -3\n"
+ "(truncate-remainder -123 -10) @result{} -3\n"
+ "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
+ "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_truncate_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_remainder);
+ else
+ return SCM_I_MAKINUM (xx % yy);
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_INUM0;
+ }
+ else
+ return x;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_remainder);
+ else
+ {
+ scm_t_inum rr = (mpz_tdiv_ui (SCM_I_BIG_MPZ (x),
+ (yy > 0) ? yy : -yy)
+ * mpz_sgn (SCM_I_BIG_MPZ (x)));
+ scm_remember_upto_here_1 (x);
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM r = scm_i_mkbig ();
+ mpz_tdiv_r (SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_truncate_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
+ close). In particular, when x is very close to a multiple of y,
+ then r might be either 0.0 or sgn(x)*|y|, but those two cases must
+ correspond to different choices of q. If quotient chooses one and
+ remainder chooses the other, it would be bad. */
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
+ else
+ return scm_from_double (x - y * scm_c_truncate (x / y));
+}
+
+static SCM
+scm_i_exact_rational_truncate_remainder (SCM x, SCM y)
+{
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_truncate_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
+}
+
+
+static void scm_i_inexact_truncate_divide (double x, double y,
+ SCM *qp, SCM *rp);
+static void scm_i_exact_rational_truncate_divide (SCM x, SCM y,
+ SCM *qp, SCM *rp);
+
+SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
+ "@lisp\n"
+ "(truncate/ 123 10) @result{} 12 and 3\n"
+ "(truncate/ 123 -10) @result{} -12 and 3\n"
+ "(truncate/ -123 10) @result{} -12 and -3\n"
+ "(truncate/ -123 -10) @result{} 12 and -3\n"
+ "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
+ "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_truncate_divide
+{
+ SCM q, r;
+
+ scm_truncate_divide(x, y, &q, &r);
+ return scm_values (scm_list_2 (q, r));
+}
+#undef FUNC_NAME
+
+#define s_scm_truncate_divide s_scm_i_truncate_divide
+#define g_scm_truncate_divide g_scm_i_truncate_divide
+
+void
+scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ *qp = SCM_I_MAKINUM (qq);
+ else
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
+ && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ *qp = SCM_I_MAKINUM (-1);
+ *rp = SCM_INUM0;
+ }
+ else
+ {
+ *qp = SCM_INUM0;
+ *rp = x;
+ }
+ return;
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2
+ (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide, qp, rp);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_truncate_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ if (yy > 0)
+ rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ else
+ {
+ rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ }
+ rr *= mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ *qp = scm_i_normbig (q);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM q = scm_i_mkbig ();
+ SCM r = scm_i_mkbig ();
+ mpz_tdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2
+ (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide, qp, rp);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_truncate_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
+ else
+ return two_valued_wta_dispatch_2
+ (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide, qp, rp);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_truncate_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2
+ (g_scm_truncate_divide, x, y, SCM_ARG2,
+ s_scm_truncate_divide, qp, rp);
+ }
+ else
+ return two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
+ s_scm_truncate_divide, qp, rp);
+}
+
+static void
+scm_i_inexact_truncate_divide (double x, double y, SCM *qp, SCM *rp)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
+ else
+ {
+ double q, r, q1;
+ /* FIXME: Use trunc, after it has been imported from gnulib */
+ q1 = x / y;
+ q = (q1 >= 0) ? floor (q1) : ceil (q1);
+ r = x - q * y;
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
+ }
+}
+
+static void
+scm_i_exact_rational_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+
+ scm_truncate_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
+}
+
static SCM scm_i_inexact_centered_quotient (double x, double y);
static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
@@ -2313,6 +3844,662 @@ scm_i_exact_rational_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
*rp = scm_divide (r1, scm_product (xd, yd));
}
+static SCM scm_i_inexact_round_quotient (double x, double y);
+static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
+static SCM scm_i_exact_rational_round_quotient (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
+ "with ties going to the nearest even integer.\n"
+ "@lisp\n"
+ "(round-quotient 123 10) @result{} 12\n"
+ "(round-quotient 123 -10) @result{} -12\n"
+ "(round-quotient -123 10) @result{} -12\n"
+ "(round-quotient -123 -10) @result{} 12\n"
+ "(round-quotient 125 10) @result{} 12\n"
+ "(round-quotient 127 10) @result{} 13\n"
+ "(round-quotient 135 10) @result{} 14\n"
+ "(round-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(round-quotient 16/3 -10/7) @result{} -4\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_quotient
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_quotient);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ qq++;
+ else if (r2 <= -ay)
+ qq--;
+ }
+ else
+ {
+ if (r2 > ay)
+ qq++;
+ else if (r2 < -ay)
+ qq--;
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_quotient */
+ return scm_i_bigint_round_quotient (scm_i_long2big (xx), y);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_1 (x);
+ if (needs_adjustment)
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ return scm_i_normbig (q);
+ }
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_quotient (x, y);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_quotient
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_quotient
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_quotient (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_round_quotient (double x, double y)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
+ else
+ return scm_from_double (scm_c_round (x / y));
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static SCM
+scm_i_bigint_round_quotient (SCM x, SCM y)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+ scm_remember_upto_here_2 (x, r);
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+ scm_remember_upto_here_2 (r2, y);
+
+ if (needs_adjustment)
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+
+ return scm_i_normbig (q);
+}
+
+static SCM
+scm_i_exact_rational_round_quotient (SCM x, SCM y)
+{
+ return scm_round_quotient
+ (scm_product (scm_numerator (x), scm_denominator (y)),
+ scm_product (scm_numerator (y), scm_denominator (x)));
+}
+
+static SCM scm_i_inexact_round_remainder (double x, double y);
+static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
+static SCM scm_i_exact_rational_round_remainder (SCM x, SCM y);
+
+SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
+ "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
+ "nearest integer, with ties going to the nearest\n"
+ "even integer.\n"
+ "@lisp\n"
+ "(round-remainder 123 10) @result{} 3\n"
+ "(round-remainder 123 -10) @result{} 3\n"
+ "(round-remainder -123 10) @result{} -3\n"
+ "(round-remainder -123 -10) @result{} -3\n"
+ "(round-remainder 125 10) @result{} 5\n"
+ "(round-remainder 127 10) @result{} -3\n"
+ "(round-remainder 135 10) @result{} -5\n"
+ "(round-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(round-remainder 16/3 -10/7) @result{} -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_round_remainder
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_remainder);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ rr -= yy;
+ else if (r2 <= -ay)
+ rr += yy;
+ }
+ else
+ {
+ if (r2 > ay)
+ rr -= yy;
+ else if (r2 < -ay)
+ rr += yy;
+ }
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_remainder */
+ return scm_i_bigint_round_remainder
+ (scm_i_long2big (xx), y);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_remainder);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_2 (x, q);
+ if (needs_adjustment)
+ rr -= yy;
+ return SCM_I_MAKINUM (rr);
+ }
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_remainder (x, y);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_remainder
+ (SCM_REAL_VALUE (x), scm_to_double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_remainder
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_remainder (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
+}
+#undef FUNC_NAME
+
+static SCM
+scm_i_inexact_round_remainder (double x, double y)
+{
+ /* Although it would be more efficient to use fmod here, we can't
+ because it would in some cases produce results inconsistent with
+ scm_i_inexact_round_quotient, such that x != r + q * y (not even
+ close). In particular, when x-y/2 is very close to a multiple of
+ y, then r might be either -abs(y/2) or abs(y/2), but those two
+ cases must correspond to different choices of q. If quotient
+ chooses one and remainder chooses the other, it would be bad. */
+
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_remainder); /* or return a NaN? */
+ else
+ {
+ double q = scm_c_round (x / y);
+ return scm_from_double (x - q * y);
+ }
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static SCM
+scm_i_bigint_round_remainder (SCM x, SCM y)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (x);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+ scm_remember_upto_here_2 (q, r2);
+
+ if (needs_adjustment)
+ mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
+
+ scm_remember_upto_here_1 (y);
+ return scm_i_normbig (r);
+}
+
+static SCM
+scm_i_exact_rational_round_remainder (SCM x, SCM y)
+{
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+ SCM r1 = scm_round_remainder (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd));
+ return scm_divide (r1, scm_product (xd, yd));
+}
+
+
+static void scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp);
+static void scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
+static void scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
+
+SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
+ "nearest integer, with ties going to the nearest even integer.\n"
+ "@lisp\n"
+ "(round/ 123 10) @result{} 12 and 3\n"
+ "(round/ 123 -10) @result{} -12 and 3\n"
+ "(round/ -123 10) @result{} -12 and -3\n"
+ "(round/ -123 -10) @result{} 12 and -3\n"
+ "(round/ 125 10) @result{} 12 and 5\n"
+ "(round/ 127 10) @result{} 13 and -3\n"
+ "(round/ 135 10) @result{} 14 and -5\n"
+ "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_round_divide
+{
+ SCM q, r;
+
+ scm_round_divide(x, y, &q, &r);
+ return scm_values (scm_list_2 (q, r));
+}
+#undef FUNC_NAME
+
+#define s_scm_round_divide s_scm_i_round_divide
+#define g_scm_round_divide g_scm_i_round_divide
+
+void
+scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_inum xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_divide);
+ else
+ {
+ scm_t_inum qq = xx / yy;
+ scm_t_inum rr = xx % yy;
+ scm_t_inum ay = yy;
+ scm_t_inum r2 = 2 * rr;
+
+ if (SCM_LIKELY (yy < 0))
+ {
+ ay = -ay;
+ r2 = -r2;
+ }
+
+ if (qq & 1L)
+ {
+ if (r2 >= ay)
+ { qq++; rr -= yy; }
+ else if (r2 <= -ay)
+ { qq--; rr += yy; }
+ }
+ else
+ {
+ if (r2 > ay)
+ { qq++; rr -= yy; }
+ else if (r2 < -ay)
+ { qq--; rr += yy; }
+ }
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ *qp = SCM_I_MAKINUM (qq);
+ else
+ *qp = scm_i_inum2big (qq);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* Pass a denormalized bignum version of x (even though it
+ can fit in a fixnum) to scm_i_bigint_round_divide */
+ return scm_i_bigint_round_divide
+ (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
+ }
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide, qp, rp);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ scm_t_inum yy = SCM_I_INUM (y);
+ if (SCM_UNLIKELY (yy == 0))
+ scm_num_overflow (s_scm_round_divide);
+ else
+ {
+ SCM q = scm_i_mkbig ();
+ scm_t_inum rr;
+ int needs_adjustment;
+
+ if (yy > 0)
+ {
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), yy);
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr >= yy);
+ else
+ needs_adjustment = (2*rr > yy);
+ }
+ else
+ {
+ rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
+ SCM_I_BIG_MPZ (x), -yy);
+ mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (2*rr <= yy);
+ else
+ needs_adjustment = (2*rr < yy);
+ }
+ scm_remember_upto_here_1 (x);
+ if (needs_adjustment)
+ {
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ rr -= yy;
+ }
+ *qp = scm_i_normbig (q);
+ *rp = SCM_I_MAKINUM (rr);
+ }
+ return;
+ }
+ else if (SCM_BIGP (y))
+ return scm_i_bigint_round_divide (x, y, qp, rp);
+ else if (SCM_REALP (y))
+ return scm_i_inexact_round_divide
+ (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide, qp, rp);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_REALP (y) || SCM_I_INUMP (y) ||
+ SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_inexact_round_divide
+ (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide, qp, rp);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_REALP (y))
+ return scm_i_inexact_round_divide
+ (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
+ else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
+ return scm_i_exact_rational_round_divide (x, y, qp, rp);
+ else
+ return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
+ s_scm_round_divide, qp, rp);
+ }
+ else
+ return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
+ s_scm_round_divide, qp, rp);
+}
+
+static void
+scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp)
+{
+ if (SCM_UNLIKELY (y == 0))
+ scm_num_overflow (s_scm_round_divide); /* or return a NaN? */
+ else
+ {
+ double q = scm_c_round (x / y);
+ double r = x - q * y;
+ *qp = scm_from_double (q);
+ *rp = scm_from_double (r);
+ }
+}
+
+/* Assumes that both x and y are bigints, though
+ x might be able to fit into a fixnum. */
+static void
+scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ SCM q, r, r2;
+ int cmp, needs_adjustment;
+
+ /* Note that x might be small enough to fit into a
+ fixnum, so we must not let it escape into the wild */
+ q = scm_i_mkbig ();
+ r = scm_i_mkbig ();
+ r2 = scm_i_mkbig ();
+
+ mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
+ SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (x);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
+
+ cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
+ if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
+ needs_adjustment = (cmp >= 0);
+ else
+ needs_adjustment = (cmp > 0);
+
+ if (needs_adjustment)
+ {
+ mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
+ mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
+ }
+
+ scm_remember_upto_here_2 (r2, y);
+ *qp = scm_i_normbig (q);
+ *rp = scm_i_normbig (r);
+}
+
+static void
+scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
+{
+ SCM r1;
+ SCM xd = scm_denominator (x);
+ SCM yd = scm_denominator (y);
+
+ scm_round_divide (scm_product (scm_numerator (x), yd),
+ scm_product (scm_numerator (y), xd),
+ qp, &r1);
+ *rp = scm_divide (r1, scm_product (xd, yd));
+}
+
SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
(SCM x, SCM y, SCM rest),
diff --git a/libguile/numbers.h b/libguile/numbers.h
index b8529a3..bc2d4f2 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -181,9 +181,21 @@ SCM_API SCM scm_modulo (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_remainder (SCM x, SCM y);
+SCM_API void scm_floor_divide (SCM x, SCM y, SCM *q, SCM *r);
+SCM_API SCM scm_floor_quotient (SCM x, SCM y);
+SCM_API SCM scm_floor_remainder (SCM x, SCM y);
+SCM_API void scm_ceiling_divide (SCM x, SCM y, SCM *q, SCM *r);
+SCM_API SCM scm_ceiling_quotient (SCM x, SCM y);
+SCM_API SCM scm_ceiling_remainder (SCM x, SCM y);
+SCM_API void scm_truncate_divide (SCM x, SCM y, SCM *q, SCM *r);
+SCM_API SCM scm_truncate_quotient (SCM x, SCM y);
+SCM_API SCM scm_truncate_remainder (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_remainder (SCM x, SCM y);
+SCM_API void scm_round_divide (SCM x, SCM y, SCM *q, SCM *r);
+SCM_API SCM scm_round_quotient (SCM x, SCM y);
+SCM_API SCM scm_round_remainder (SCM x, SCM y);
SCM_API SCM scm_gcd (SCM x, SCM y);
SCM_API SCM scm_lcm (SCM n1, SCM n2);
SCM_API SCM scm_logand (SCM n1, SCM n2);
@@ -200,7 +212,11 @@ SCM_API SCM scm_logcount (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_floor_divide (SCM x, SCM y);
+SCM_INTERNAL SCM scm_i_ceiling_divide (SCM x, SCM y);
+SCM_INTERNAL SCM scm_i_truncate_divide (SCM x, SCM y);
SCM_INTERNAL SCM scm_i_centered_divide (SCM x, SCM y);
+SCM_INTERNAL SCM scm_i_round_divide (SCM x, SCM y);
SCM_INTERNAL SCM scm_i_gcd (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_lcm (SCM x, SCM y, SCM rest);
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index f738189..ef59a02 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -4148,6 +4148,42 @@
(test-within-range? 0 <= r < (abs y)))
(test-eqv? q (/ x y)))))
+ (define (valid-floor-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> y 0)
+ (test-within-range? 0 <= r < y)
+ (test-within-range? y < r <= 0)))
+ (test-eqv? q (/ x y)))))
+
+ (define (valid-ceiling-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> y 0)
+ (test-within-range? (- y) < r <= 0)
+ (test-within-range? 0 <= r < (- y))))
+ (test-eqv? q (/ x y)))))
+
+ (define (valid-truncate-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (if (> x 0)
+ (test-within-range? 0 <= r < (abs y))
+ (test-within-range? (- (abs y)) < r <= 0)))
+ (test-eqv? q (/ x y)))))
+
(define (valid-centered-answer? x y q r)
(and (eq? (exact? q)
(exact? r)
@@ -4159,6 +4195,19 @@
(* -1/2 (abs y)) <= r < (* +1/2 (abs y))))
(test-eqv? q (/ x y)))))
+ (define (valid-round-answer? x y q r)
+ (and (eq? (exact? q)
+ (exact? r)
+ (and (exact? x) (exact? y)))
+ (test-eqv? r (- x (* q y)))
+ (if (and (finite? x) (finite? y))
+ (and (integer? q)
+ (let ((ay/2 (/ (abs y) 2)))
+ (if (even? q)
+ (test-within-range? (- ay/2) <= r <= ay/2)
+ (test-within-range? (- ay/2) < r < ay/2))))
+ (test-eqv? q (/ x y)))))
+
(define (for lsts f) (apply for-each f lsts))
(define big (expt 10 (1+ (inexact->exact (ceiling (log10 fixnum-max))))))
@@ -4284,8 +4333,32 @@
euclidean-remainder
valid-euclidean-answer?))
+ (with-test-prefix "floor/"
+ (run-division-tests floor/
+ floor-quotient
+ floor-remainder
+ valid-floor-answer?))
+
+ (with-test-prefix "ceiling/"
+ (run-division-tests ceiling/
+ ceiling-quotient
+ ceiling-remainder
+ valid-ceiling-answer?))
+
+ (with-test-prefix "truncate/"
+ (run-division-tests truncate/
+ truncate-quotient
+ truncate-remainder
+ valid-truncate-answer?))
+
(with-test-prefix "centered/"
(run-division-tests centered/
centered-quotient
centered-remainder
- valid-centered-answer?)))
+ valid-centered-answer?))
+
+ (with-test-prefix "round/"
+ (run-division-tests round/
+ round-quotient
+ round-remainder
+ valid-round-answer?)))
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: Optimize truncate, round, floor, and ceiling --]
[-- Type: text/x-diff, Size: 17665 bytes --]
From 92dd2c4df82b8425fbd3d1359c749be3a21b743f Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 13 Feb 2011 07:14:57 -0500
Subject: [PATCH 5/9] Optimize truncate, round, floor, and ceiling
* libguile/numbers.c (scm_c_truncate): Use ceil (x) instead of
-floor (-x).
(scm_truncate_number): Implement directly instead of by checking the
sign and using scm_floor or scm_ceiling. Use scm_truncate_quotient
for fractions. Make extensible, so that new number types implemented
in GOOPS will be able to do the job more efficiently, since it is
often easier to implement truncate than floor or ceiling.
(scm_round_number): Optimize fractions case by using
scm_round_quotient. Make extensible, so that new number types
implemented in GOOPS will be able to do the job efficiently.
(scm_floor, scm_ceiling): Optimize fractions case by using
scm_floor_quotient and scm_ceiling_quotient, respectively.
* test-suite/tests/numbers.test: Add test cases.
---
libguile/numbers.c | 87 +++------
test-suite/tests/numbers.test | 412 ++++++++++++++++++++++++++++++++++++++++-
2 files changed, 432 insertions(+), 67 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 9107c81..40a3ee3 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -8851,8 +8851,9 @@ scm_c_truncate (double x)
return trunc (x);
#else
if (x < 0.0)
- return -floor (-x);
- return floor (x);
+ return ceil (x);
+ else
+ return floor (x);
#endif
}
@@ -8898,43 +8899,41 @@ scm_c_round (double x)
: result);
}
-SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0,
- (SCM x),
- "Round the number @var{x} towards zero.")
+SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards zero.")
#define FUNC_NAME s_scm_truncate_number
{
- if (scm_is_false (scm_negative_p (x)))
- return scm_floor (x);
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_from_double (scm_c_truncate (SCM_REAL_VALUE (x)));
+ else if (SCM_FRACTIONP (x))
+ return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
- return scm_ceiling (x);
+ SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, SCM_ARG1,
+ s_scm_truncate_number);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
- (SCM x),
- "Round the number @var{x} towards the nearest integer. "
- "When it is exactly halfway between two integers, "
- "round towards the even one.")
+SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards the nearest integer. "
+ "When it is exactly halfway between two integers, "
+ "round towards the even one.")
#define FUNC_NAME s_scm_round_number
{
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return x;
else if (SCM_REALP (x))
return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
+ else if (SCM_FRACTIONP (x))
+ return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
- {
- /* OPTIMIZE-ME: Fraction case could be done more efficiently by a
- single quotient+remainder division then examining to see which way
- the rounding should go. */
- SCM plus_half = scm_sum (x, exactly_one_half);
- SCM result = scm_floor (plus_half);
- /* Adjust so that the rounding is towards even. */
- if (scm_is_true (scm_num_eq_p (plus_half, result))
- && scm_is_true (scm_odd_p (result)))
- return scm_difference (result, SCM_INUM1);
- else
- return result;
- }
+ SCM_WTA_DISPATCH_1 (g_scm_round_number, x, SCM_ARG1,
+ s_scm_round_number);
}
#undef FUNC_NAME
@@ -8948,22 +8947,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
else if (SCM_REALP (x))
return scm_from_double (floor (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
- {
- SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
- SCM_FRACTION_DENOMINATOR (x));
- if (scm_is_false (scm_negative_p (x)))
- {
- /* For positive x, rounding towards zero is correct. */
- return q;
- }
- else
- {
- /* For negative x, we need to return q-1 unless x is an
- integer. But fractions are never integer, per our
- assumptions. */
- return scm_difference (q, SCM_INUM1);
- }
- }
+ return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
}
@@ -8979,22 +8964,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
else if (SCM_REALP (x))
return scm_from_double (ceil (SCM_REAL_VALUE (x)));
else if (SCM_FRACTIONP (x))
- {
- SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
- SCM_FRACTION_DENOMINATOR (x));
- if (scm_is_false (scm_positive_p (x)))
- {
- /* For negative x, rounding towards zero is correct. */
- return q;
- }
- else
- {
- /* For positive x, we need to return q+1 unless x is an
- integer. But fractions are never integer, per our
- assumptions. */
- return scm_sum (q, SCM_INUM1);
- }
- }
+ return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
else
SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index ef59a02..1f2ee03 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -3307,6 +3307,284 @@
(= (/ 25+125i 4+3i) 19.0+17.0i))))
;;;
+;;; floor
+;;;
+
+(with-test-prefix "floor"
+ (pass-if (= 1 (floor 1.75)))
+ (pass-if (= 1 (floor 1.5)))
+ (pass-if (= 1 (floor 1.25)))
+ (pass-if (= 0 (floor 0.75)))
+ (pass-if (= 0 (floor 0.5)))
+ (pass-if (= 0 (floor 0.0)))
+ (pass-if (= -1 (floor -0.5)))
+ (pass-if (= -2 (floor -1.25)))
+ (pass-if (= -2 (floor -1.5)))
+
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (floor 0))
+ (exact? (floor 0))))
+
+ (pass-if "1"
+ (and (= 1 (floor 1))
+ (exact? (floor 1))))
+
+ (pass-if "-1"
+ (and (= -1 (floor -1))
+ (exact? (floor -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (floor x))
+ (exact? (floor x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (floor x))
+ (exact? (floor x))))))
+
+ (with-test-prefix "frac"
+ (define (=exact x y)
+ (and (= x y)
+ (exact? y)))
+
+ (pass-if (=exact -3 (floor -7/3)))
+ (pass-if (=exact -2 (floor -5/3)))
+ (pass-if (=exact -2 (floor -4/3)))
+ (pass-if (=exact -1 (floor -2/3)))
+ (pass-if (=exact -1 (floor -1/3)))
+ (pass-if (=exact 0 (floor 1/3)))
+ (pass-if (=exact 0 (floor 2/3)))
+ (pass-if (=exact 1 (floor 4/3)))
+ (pass-if (=exact 1 (floor 5/3)))
+ (pass-if (=exact 2 (floor 7/3)))
+
+ (pass-if (=exact -3 (floor -17/6)))
+ (pass-if (=exact -3 (floor -16/6)))
+ (pass-if (=exact -3 (floor -15/6)))
+ (pass-if (=exact -3 (floor -14/6)))
+ (pass-if (=exact -3 (floor -13/6)))
+ (pass-if (=exact -2 (floor -11/6)))
+ (pass-if (=exact -2 (floor -10/6)))
+ (pass-if (=exact -2 (floor -9/6)))
+ (pass-if (=exact -2 (floor -8/6)))
+ (pass-if (=exact -2 (floor -7/6)))
+ (pass-if (=exact -1 (floor -5/6)))
+ (pass-if (=exact -1 (floor -4/6)))
+ (pass-if (=exact -1 (floor -3/6)))
+ (pass-if (=exact -1 (floor -2/6)))
+ (pass-if (=exact -1 (floor -1/6)))
+ (pass-if (=exact 0 (floor 1/6)))
+ (pass-if (=exact 0 (floor 2/6)))
+ (pass-if (=exact 0 (floor 3/6)))
+ (pass-if (=exact 0 (floor 4/6)))
+ (pass-if (=exact 0 (floor 5/6)))
+ (pass-if (=exact 1 (floor 7/6)))
+ (pass-if (=exact 1 (floor 8/6)))
+ (pass-if (=exact 1 (floor 9/6)))
+ (pass-if (=exact 1 (floor 10/6)))
+ (pass-if (=exact 1 (floor 11/6)))
+ (pass-if (=exact 2 (floor 13/6)))
+ (pass-if (=exact 2 (floor 14/6)))
+ (pass-if (=exact 2 (floor 15/6)))
+ (pass-if (=exact 2 (floor 16/6)))
+ (pass-if (=exact 2 (floor 17/6))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (floor 0.0))
+ (inexact? (floor 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (floor 1.0))
+ (inexact? (floor 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (floor -1.0))
+ (inexact? (floor -1.0))))
+
+ (pass-if "-3.1"
+ (and (= -4.0 (floor -3.1))
+ (inexact? (floor -3.1))))
+
+ (pass-if "3.1"
+ (and (= 3.0 (floor 3.1))
+ (inexact? (floor 3.1))))
+
+ (pass-if "3.9"
+ (and (= 3.0 (floor 3.9))
+ (inexact? (floor 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -4.0 (floor -3.9))
+ (inexact? (floor -3.9))))
+
+ (pass-if "1.5"
+ (and (= 1.0 (floor 1.5))
+ (inexact? (floor 1.5))))
+
+ (pass-if "2.5"
+ (and (= 2.0 (floor 2.5))
+ (inexact? (floor 2.5))))
+
+ (pass-if "3.5"
+ (and (= 3.0 (floor 3.5))
+ (inexact? (floor 3.5))))
+
+ (pass-if "-1.5"
+ (and (= -2.0 (floor -1.5))
+ (inexact? (floor -1.5))))
+
+ (pass-if "-2.5"
+ (and (= -3.0 (floor -2.5))
+ (inexact? (floor -2.5))))
+
+ (pass-if "-3.5"
+ (and (= -4.0 (floor -3.5))
+ (inexact? (floor -3.5))))))
+
+;;;
+;;; ceiling
+;;;
+
+(with-test-prefix "ceiling"
+ (pass-if (= 2 (ceiling 1.75)))
+ (pass-if (= 2 (ceiling 1.5)))
+ (pass-if (= 2 (ceiling 1.25)))
+ (pass-if (= 1 (ceiling 0.75)))
+ (pass-if (= 1 (ceiling 0.5)))
+ (pass-if (= 0 (ceiling 0.0)))
+ (pass-if (= 0 (ceiling -0.5)))
+ (pass-if (= -1 (ceiling -1.25)))
+ (pass-if (= -1 (ceiling -1.5)))
+
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (ceiling 0))
+ (exact? (ceiling 0))))
+
+ (pass-if "1"
+ (and (= 1 (ceiling 1))
+ (exact? (ceiling 1))))
+
+ (pass-if "-1"
+ (and (= -1 (ceiling -1))
+ (exact? (ceiling -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (ceiling x))
+ (exact? (ceiling x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (ceiling x))
+ (exact? (ceiling x))))))
+
+ (with-test-prefix "frac"
+ (define (=exact x y)
+ (and (= x y)
+ (exact? y)))
+
+ (pass-if (=exact -2 (ceiling -7/3)))
+ (pass-if (=exact -1 (ceiling -5/3)))
+ (pass-if (=exact -1 (ceiling -4/3)))
+ (pass-if (=exact 0 (ceiling -2/3)))
+ (pass-if (=exact 0 (ceiling -1/3)))
+ (pass-if (=exact 1 (ceiling 1/3)))
+ (pass-if (=exact 1 (ceiling 2/3)))
+ (pass-if (=exact 2 (ceiling 4/3)))
+ (pass-if (=exact 2 (ceiling 5/3)))
+ (pass-if (=exact 3 (ceiling 7/3)))
+
+ (pass-if (=exact -2 (ceiling -17/6)))
+ (pass-if (=exact -2 (ceiling -16/6)))
+ (pass-if (=exact -2 (ceiling -15/6)))
+ (pass-if (=exact -2 (ceiling -14/6)))
+ (pass-if (=exact -2 (ceiling -13/6)))
+ (pass-if (=exact -1 (ceiling -11/6)))
+ (pass-if (=exact -1 (ceiling -10/6)))
+ (pass-if (=exact -1 (ceiling -9/6)))
+ (pass-if (=exact -1 (ceiling -8/6)))
+ (pass-if (=exact -1 (ceiling -7/6)))
+ (pass-if (=exact 0 (ceiling -5/6)))
+ (pass-if (=exact 0 (ceiling -4/6)))
+ (pass-if (=exact 0 (ceiling -3/6)))
+ (pass-if (=exact 0 (ceiling -2/6)))
+ (pass-if (=exact 0 (ceiling -1/6)))
+ (pass-if (=exact 1 (ceiling 1/6)))
+ (pass-if (=exact 1 (ceiling 2/6)))
+ (pass-if (=exact 1 (ceiling 3/6)))
+ (pass-if (=exact 1 (ceiling 4/6)))
+ (pass-if (=exact 1 (ceiling 5/6)))
+ (pass-if (=exact 2 (ceiling 7/6)))
+ (pass-if (=exact 2 (ceiling 8/6)))
+ (pass-if (=exact 2 (ceiling 9/6)))
+ (pass-if (=exact 2 (ceiling 10/6)))
+ (pass-if (=exact 2 (ceiling 11/6)))
+ (pass-if (=exact 3 (ceiling 13/6)))
+ (pass-if (=exact 3 (ceiling 14/6)))
+ (pass-if (=exact 3 (ceiling 15/6)))
+ (pass-if (=exact 3 (ceiling 16/6)))
+ (pass-if (=exact 3 (ceiling 17/6))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (ceiling 0.0))
+ (inexact? (ceiling 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (ceiling 1.0))
+ (inexact? (ceiling 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (ceiling -1.0))
+ (inexact? (ceiling -1.0))))
+
+ (pass-if "-3.1"
+ (and (= -3.0 (ceiling -3.1))
+ (inexact? (ceiling -3.1))))
+
+ (pass-if "3.1"
+ (and (= 4.0 (ceiling 3.1))
+ (inexact? (ceiling 3.1))))
+
+ (pass-if "3.9"
+ (and (= 4.0 (ceiling 3.9))
+ (inexact? (ceiling 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -3.0 (ceiling -3.9))
+ (inexact? (ceiling -3.9))))
+
+ (pass-if "1.5"
+ (and (= 2.0 (ceiling 1.5))
+ (inexact? (ceiling 1.5))))
+
+ (pass-if "2.5"
+ (and (= 3.0 (ceiling 2.5))
+ (inexact? (ceiling 2.5))))
+
+ (pass-if "3.5"
+ (and (= 4.0 (ceiling 3.5))
+ (inexact? (ceiling 3.5))))
+
+ (pass-if "-1.5"
+ (and (= -1.0 (ceiling -1.5))
+ (inexact? (ceiling -1.5))))
+
+ (pass-if "-2.5"
+ (and (= -2.0 (ceiling -2.5))
+ (inexact? (ceiling -2.5))))
+
+ (pass-if "-3.5"
+ (and (= -3.0 (ceiling -3.5))
+ (inexact? (ceiling -3.5))))))
+
+;;;
;;; truncate
;;;
@@ -3319,7 +3597,131 @@
(pass-if (= 0 (truncate 0.0)))
(pass-if (= 0 (truncate -0.5)))
(pass-if (= -1 (truncate -1.25)))
- (pass-if (= -1 (truncate -1.5))))
+ (pass-if (= -1 (truncate -1.5)))
+
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (truncate 0))
+ (exact? (truncate 0))))
+
+ (pass-if "1"
+ (and (= 1 (truncate 1))
+ (exact? (truncate 1))))
+
+ (pass-if "-1"
+ (and (= -1 (truncate -1))
+ (exact? (truncate -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (truncate x))
+ (exact? (truncate x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (truncate x))
+ (exact? (truncate x))))))
+
+ (with-test-prefix "frac"
+ (define (=exact x y)
+ (and (= x y)
+ (exact? y)))
+
+ (pass-if (=exact -2 (truncate -7/3)))
+ (pass-if (=exact -1 (truncate -5/3)))
+ (pass-if (=exact -1 (truncate -4/3)))
+ (pass-if (=exact 0 (truncate -2/3)))
+ (pass-if (=exact 0 (truncate -1/3)))
+ (pass-if (=exact 0 (truncate 1/3)))
+ (pass-if (=exact 0 (truncate 2/3)))
+ (pass-if (=exact 1 (truncate 4/3)))
+ (pass-if (=exact 1 (truncate 5/3)))
+ (pass-if (=exact 2 (truncate 7/3)))
+
+ (pass-if (=exact -2 (truncate -17/6)))
+ (pass-if (=exact -2 (truncate -16/6)))
+ (pass-if (=exact -2 (truncate -15/6)))
+ (pass-if (=exact -2 (truncate -14/6)))
+ (pass-if (=exact -2 (truncate -13/6)))
+ (pass-if (=exact -1 (truncate -11/6)))
+ (pass-if (=exact -1 (truncate -10/6)))
+ (pass-if (=exact -1 (truncate -9/6)))
+ (pass-if (=exact -1 (truncate -8/6)))
+ (pass-if (=exact -1 (truncate -7/6)))
+ (pass-if (=exact 0 (truncate -5/6)))
+ (pass-if (=exact 0 (truncate -4/6)))
+ (pass-if (=exact 0 (truncate -3/6)))
+ (pass-if (=exact 0 (truncate -2/6)))
+ (pass-if (=exact 0 (truncate -1/6)))
+ (pass-if (=exact 0 (truncate 1/6)))
+ (pass-if (=exact 0 (truncate 2/6)))
+ (pass-if (=exact 0 (truncate 3/6)))
+ (pass-if (=exact 0 (truncate 4/6)))
+ (pass-if (=exact 0 (truncate 5/6)))
+ (pass-if (=exact 1 (truncate 7/6)))
+ (pass-if (=exact 1 (truncate 8/6)))
+ (pass-if (=exact 1 (truncate 9/6)))
+ (pass-if (=exact 1 (truncate 10/6)))
+ (pass-if (=exact 1 (truncate 11/6)))
+ (pass-if (=exact 2 (truncate 13/6)))
+ (pass-if (=exact 2 (truncate 14/6)))
+ (pass-if (=exact 2 (truncate 15/6)))
+ (pass-if (=exact 2 (truncate 16/6)))
+ (pass-if (=exact 2 (truncate 17/6))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (truncate 0.0))
+ (inexact? (truncate 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (truncate 1.0))
+ (inexact? (truncate 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (truncate -1.0))
+ (inexact? (truncate -1.0))))
+
+ (pass-if "-3.1"
+ (and (= -3.0 (truncate -3.1))
+ (inexact? (truncate -3.1))))
+
+ (pass-if "3.1"
+ (and (= 3.0 (truncate 3.1))
+ (inexact? (truncate 3.1))))
+
+ (pass-if "3.9"
+ (and (= 3.0 (truncate 3.9))
+ (inexact? (truncate 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -3.0 (truncate -3.9))
+ (inexact? (truncate -3.9))))
+
+ (pass-if "1.5"
+ (and (= 1.0 (truncate 1.5))
+ (inexact? (truncate 1.5))))
+
+ (pass-if "2.5"
+ (and (= 2.0 (truncate 2.5))
+ (inexact? (truncate 2.5))))
+
+ (pass-if "3.5"
+ (and (= 3.0 (truncate 3.5))
+ (inexact? (truncate 3.5))))
+
+ (pass-if "-1.5"
+ (and (= -1.0 (truncate -1.5))
+ (inexact? (truncate -1.5))))
+
+ (pass-if "-2.5"
+ (and (= -2.0 (truncate -2.5))
+ (inexact? (truncate -2.5))))
+
+ (pass-if "-3.5"
+ (and (= -3.0 (truncate -3.5))
+ (inexact? (truncate -3.5))))))
;;;
;;; round
@@ -3568,14 +3970,6 @@
(= 1.0 (exact->inexact (/ (1+ big) big))))))
;;;
-;;; floor
-;;;
-
-;;;
-;;; ceiling
-;;;
-
-;;;
;;; expt
;;;
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: Reduce code size of division operators --]
[-- Type: text/x-diff, Size: 27258 bytes --]
From 3992239334cd34418d3e2c84292ac51a0cec48a9 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 13 Feb 2011 07:25:28 -0500
Subject: [PATCH 6/9] Reduce code size of division operators
* libguile/numbers.c (scm_quotient): Reimplement in terms of
scm_truncate_quotient.
(scm_remainder): Reimplement in terms of scm_truncate_remainder.
(scm_modulo): Reimplement in terms of scm_floor_remainder.
(scm_euclidean_quotient, scm_euclidean_remainder,
scm_euclidean_divide): Reimplement in terms of floor and ceiling.
Make them non-extensible, because there is no need; they will work
with any objects that implement the floor and ceiling division
operators, and that can be tested using `negative?'.
---
libguile/numbers.c | 798 ++++------------------------------------------------
1 files changed, 62 insertions(+), 736 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 40a3ee3..81d689d 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -788,73 +788,10 @@ SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0,
"Return the quotient of the numbers @var{x} and @var{y}.")
#define FUNC_NAME s_scm_quotient
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
+ if (SCM_LIKELY (SCM_I_INUMP (x)) || SCM_LIKELY (SCM_BIGP (x)))
{
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_quotient);
- else
- {
- scm_t_inum z = xx / yy;
- if (SCM_LIKELY (SCM_FIXABLE (z)))
- return SCM_I_MAKINUM (z);
- else
- return scm_i_inum2big (z);
- }
- }
- else if (SCM_BIGP (y))
- {
- if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
- && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0))
- {
- /* Special case: x == fixnum-min && y == abs (fixnum-min) */
- scm_remember_upto_here_1 (y);
- return SCM_I_MAKINUM (-1);
- }
- else
- return SCM_INUM0;
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_quotient);
- else if (SCM_UNLIKELY (yy == 1))
- return x;
- else
- {
- SCM result = scm_i_mkbig ();
- if (yy < 0)
- {
- mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- - yy);
- mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
- }
- else
- mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM result = scm_i_mkbig ();
- mpz_tdiv_q (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (result);
- }
+ if (SCM_LIKELY (SCM_I_INUMP (y)) || SCM_LIKELY (SCM_BIGP (y)))
+ return scm_truncate_quotient (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
}
@@ -872,64 +809,10 @@ SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_remainder
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_remainder);
- else
- {
- /* C99 specifies that "%" is the remainder corresponding to a
- quotient rounded towards zero, and that's also traditional
- for machine division, so z here should be well defined. */
- scm_t_inum z = SCM_I_INUM (x) % yy;
- return SCM_I_MAKINUM (z);
- }
- }
- else if (SCM_BIGP (y))
- {
- if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
- && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
- - SCM_MOST_NEGATIVE_FIXNUM) == 0))
- {
- /* Special case: x == fixnum-min && y == abs (fixnum-min) */
- scm_remember_upto_here_1 (y);
- return SCM_INUM0;
- }
- else
- return x;
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
- }
- else if (SCM_BIGP (x))
+ if (SCM_LIKELY (SCM_I_INUMP (x)) || SCM_LIKELY (SCM_BIGP (x)))
{
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_remainder);
- else
- {
- SCM result = scm_i_mkbig ();
- if (yy < 0)
- yy = - yy;
- mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM result = scm_i_mkbig ();
- mpz_tdiv_r (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (result);
- }
+ if (SCM_LIKELY (SCM_I_INUMP (y)) || SCM_LIKELY (SCM_BIGP (y)))
+ return scm_truncate_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
}
@@ -948,119 +831,10 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_modulo
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_modulo);
- else
- {
- /* C99 specifies that "%" is the remainder corresponding to a
- quotient rounded towards zero, and that's also traditional
- for machine division, so z here should be well defined. */
- scm_t_inum z = xx % yy;
- scm_t_inum result;
-
- if (yy < 0)
- {
- if (z > 0)
- result = z + yy;
- else
- result = z;
- }
- else
- {
- if (z < 0)
- result = z + yy;
- else
- result = z;
- }
- return SCM_I_MAKINUM (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
- {
- mpz_t z_x;
- SCM result;
-
- if (sgn_y < 0)
- {
- SCM pos_y = scm_i_clonebig (y, 0);
- /* do this after the last scm_op */
- mpz_init_set_si (z_x, xx);
- result = pos_y; /* re-use this bignum */
- mpz_mod (SCM_I_BIG_MPZ (result),
- z_x,
- SCM_I_BIG_MPZ (pos_y));
- scm_remember_upto_here_1 (pos_y);
- }
- else
- {
- result = scm_i_mkbig ();
- /* do this after the last scm_op */
- mpz_init_set_si (z_x, xx);
- mpz_mod (SCM_I_BIG_MPZ (result),
- z_x,
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_1 (y);
- }
-
- if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
- mpz_add (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (y),
- SCM_I_BIG_MPZ (result));
- scm_remember_upto_here_1 (y);
- /* and do this before the next one */
- mpz_clear (z_x);
- return scm_i_normbig (result);
- }
- }
- else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
- }
- else if (SCM_BIGP (x))
+ if (SCM_LIKELY (SCM_I_INUMP (x)) || SCM_LIKELY (SCM_BIGP (x)))
{
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_modulo);
- else
- {
- SCM result = scm_i_mkbig ();
- mpz_mod_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- (yy < 0) ? - yy : yy);
- scm_remember_upto_here_1 (x);
- if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
- mpz_sub_ui (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (result),
- - yy);
- return scm_i_normbig (result);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM result = scm_i_mkbig ();
- int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
- SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
- mpz_mod (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (pos_y));
-
- scm_remember_upto_here_1 (x);
- if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
- mpz_add (SCM_I_BIG_MPZ (result),
- SCM_I_BIG_MPZ (y),
- SCM_I_BIG_MPZ (result));
- scm_remember_upto_here_2 (y, pos_y);
- return scm_i_normbig (result);
- }
+ if (SCM_LIKELY (SCM_I_INUMP (y)) || SCM_LIKELY (SCM_BIGP (y)))
+ return scm_floor_remainder (x, y);
else
SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
}
@@ -1092,528 +866,80 @@ two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
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_exact_rational_euclidean_quotient (SCM x, SCM y);
-
-SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
- (SCM x, SCM y),
- "Return the integer @var{q} such that\n"
- "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "where @math{0 <= @var{r} < abs(@var{y})}.\n"
- "@lisp\n"
- "(euclidean-quotient 123 10) @result{} 12\n"
- "(euclidean-quotient 123 -10) @result{} -12\n"
- "(euclidean-quotient -123 10) @result{} -13\n"
- "(euclidean-quotient -123 -10) @result{} 13\n"
- "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
- "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
- "@end lisp")
+SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} such that\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "where @math{0 <= @var{r} < abs(@var{y})}.\n"
+ "@lisp\n"
+ "(euclidean-quotient 123 10) @result{} 12\n"
+ "(euclidean-quotient 123 -10) @result{} -12\n"
+ "(euclidean-quotient -123 10) @result{} -13\n"
+ "(euclidean-quotient -123 -10) @result{} 13\n"
+ "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
+ "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
+ "@end lisp")
#define FUNC_NAME s_scm_euclidean_quotient
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_quotient);
- else
- {
- scm_t_inum qq = xx / yy;
- if (xx < qq * yy)
- {
- if (yy > 0)
- qq--;
- else
- qq++;
- }
- if (SCM_LIKELY (SCM_FIXABLE (qq)))
- return SCM_I_MAKINUM (qq);
- else
- return scm_i_inum2big (qq);
- }
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- return SCM_INUM0;
- else
- {
- scm_t_inum qq = - mpz_sgn (SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_1 (y);
- return SCM_I_MAKINUM (qq);
- }
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient (xx, SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_quotient);
- else if (SCM_UNLIKELY (yy == 1))
- return x;
- else
- {
- SCM q = scm_i_mkbig ();
- if (yy > 0)
- mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
- else
- {
- mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
- mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
- }
- scm_remember_upto_here_1 (x);
- return scm_i_normbig (q);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM q = scm_i_mkbig ();
- if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- mpz_fdiv_q (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- else
- mpz_cdiv_q (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (q);
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_quotient
- (SCM_REAL_VALUE (x), scm_to_double (y));
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_quotient
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_quotient (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG2,
- s_scm_euclidean_quotient);
- }
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_quotient, x, y, SCM_ARG1,
- s_scm_euclidean_quotient);
+ return scm_ceiling_quotient (x, y);
}
#undef FUNC_NAME
-static SCM
-scm_i_inexact_euclidean_quotient (double x, double y)
-{
- if (SCM_LIKELY (y > 0))
- return scm_from_double (floor (x / y));
- else if (SCM_LIKELY (y < 0))
- return scm_from_double (ceil (x / y));
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_quotient); /* or return a NaN? */
- else
- return scm_nan ();
-}
-
-static SCM
-scm_i_exact_rational_euclidean_quotient (SCM x, SCM y)
-{
- return scm_euclidean_quotient
- (scm_product (scm_numerator (x), scm_denominator (y)),
- scm_product (scm_numerator (y), scm_denominator (x)));
-}
-
-static SCM scm_i_inexact_euclidean_remainder (double x, double y);
-static SCM scm_i_exact_rational_euclidean_remainder (SCM x, SCM y);
-
-SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
- (SCM x, SCM y),
- "Return the real number @var{r} such that\n"
- "@math{0 <= @var{r} < abs(@var{y})} and\n"
- "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "for some integer @var{q}.\n"
- "@lisp\n"
- "(euclidean-remainder 123 10) @result{} 3\n"
- "(euclidean-remainder 123 -10) @result{} 3\n"
- "(euclidean-remainder -123 10) @result{} 7\n"
- "(euclidean-remainder -123 -10) @result{} 7\n"
- "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
- "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
- "@end lisp")
+SCM_DEFINE (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the real number @var{r} such that\n"
+ "@math{0 <= @var{r} < abs(@var{y})} and\n"
+ "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "for some integer @var{q}.\n"
+ "@lisp\n"
+ "(euclidean-remainder 123 10) @result{} 3\n"
+ "(euclidean-remainder 123 -10) @result{} 3\n"
+ "(euclidean-remainder -123 10) @result{} 7\n"
+ "(euclidean-remainder -123 -10) @result{} 7\n"
+ "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
+ "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
+ "@end lisp")
#define FUNC_NAME s_scm_euclidean_remainder
{
- if (SCM_LIKELY (SCM_I_INUMP (x)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_remainder);
- else
- {
- scm_t_inum rr = xx % yy;
- if (rr >= 0)
- return SCM_I_MAKINUM (rr);
- else if (yy > 0)
- return SCM_I_MAKINUM (rr + yy);
- else
- return SCM_I_MAKINUM (rr - yy);
- }
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- return x;
- else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- {
- SCM r = scm_i_mkbig ();
- mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- return scm_i_normbig (r);
- }
- else
- {
- SCM r = scm_i_mkbig ();
- mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
- return scm_i_normbig (r);
- }
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder (xx, SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_remainder);
- else
- {
- scm_t_inum rr;
- if (yy < 0)
- yy = -yy;
- rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
- scm_remember_upto_here_1 (x);
- return SCM_I_MAKINUM (rr);
- }
- }
- else if (SCM_BIGP (y))
- {
- SCM r = scm_i_mkbig ();
- mpz_mod (SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x),
- SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- return scm_i_normbig (r);
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_remainder
- (SCM_REAL_VALUE (x), scm_to_double (y));
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_remainder (x, y);
- else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG2,
- s_scm_euclidean_remainder);
- }
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_euclidean_remainder, x, y, SCM_ARG1,
- s_scm_euclidean_remainder);
+ return scm_ceiling_remainder (x, y);
}
#undef FUNC_NAME
-static SCM
-scm_i_inexact_euclidean_remainder (double x, double y)
-{
- double q;
-
- /* Although it would be more efficient to use fmod here, we can't
- because it would in some cases produce results inconsistent with
- scm_i_inexact_euclidean_quotient, such that x != q * y + r (not
- even close). In particular, when x is very close to a multiple of
- y, then r might be either 0.0 or abs(y)-epsilon, but those two
- cases must correspond to different choices of q. If r = 0.0 then q
- must be x/y, and if r = abs(y) then q must be (x-r)/y. If quotient
- chooses one and remainder chooses the other, it would be bad. This
- problem was observed with x = 130.0 and y = 10/7. */
- if (SCM_LIKELY (y > 0))
- q = floor (x / y);
- else if (SCM_LIKELY (y < 0))
- q = ceil (x / y);
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_remainder); /* or return a NaN? */
- else
- return scm_nan ();
- return scm_from_double (x - q * y);
-}
-
-static SCM
-scm_i_exact_rational_euclidean_remainder (SCM x, SCM y)
-{
- SCM xd = scm_denominator (x);
- SCM yd = scm_denominator (y);
- SCM r1 = scm_euclidean_remainder (scm_product (scm_numerator (x), yd),
- scm_product (scm_numerator (y), xd));
- return scm_divide (r1, scm_product (xd, yd));
-}
-
-
-static void scm_i_inexact_euclidean_divide (double x, double y,
- SCM *qp, SCM *rp);
-static void scm_i_exact_rational_euclidean_divide (SCM x, SCM y,
- SCM *qp, SCM *rp);
-
-SCM_PRIMITIVE_GENERIC (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
- (SCM x, SCM y),
- "Return the integer @var{q} and the real number @var{r}\n"
- "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
- "and @math{0 <= @var{r} < abs(@var{y})}.\n"
- "@lisp\n"
- "(euclidean/ 123 10) @result{} 12 and 3\n"
- "(euclidean/ 123 -10) @result{} -12 and 3\n"
- "(euclidean/ -123 10) @result{} -13 and 7\n"
- "(euclidean/ -123 -10) @result{} 13 and 7\n"
- "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
- "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
- "@end lisp")
+SCM_DEFINE (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the integer @var{q} and the real number @var{r}\n"
+ "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
+ "and @math{0 <= @var{r} < abs(@var{y})}.\n"
+ "@lisp\n"
+ "(euclidean/ 123 10) @result{} 12 and 3\n"
+ "(euclidean/ 123 -10) @result{} -12 and 3\n"
+ "(euclidean/ -123 10) @result{} -13 and 7\n"
+ "(euclidean/ -123 -10) @result{} 13 and 7\n"
+ "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
+ "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
+ "@end lisp")
#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));
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_i_floor_divide (x, y);
+ else
+ return scm_i_ceiling_divide (x, y);
}
#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)))
- {
- scm_t_inum xx = SCM_I_INUM (x);
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_divide);
- else
- {
- scm_t_inum qq = xx / yy;
- scm_t_inum rr = xx % yy;
- if (rr < 0)
- {
- if (yy > 0)
- { rr += yy; qq--; }
- else
- { rr -= yy; qq++; }
- }
- if (SCM_LIKELY (SCM_FIXABLE (qq)))
- *qp = SCM_I_MAKINUM (qq);
- else
- *qp = scm_i_inum2big (qq);
- *rp = SCM_I_MAKINUM (rr);
- }
- return;
- }
- else if (SCM_BIGP (y))
- {
- if (xx >= 0)
- {
- *qp = SCM_INUM0;
- *rp = x;
- }
- else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- {
- SCM r = scm_i_mkbig ();
- mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- *qp = SCM_I_MAKINUM (-1);
- *rp = scm_i_normbig (r);
- }
- else
- {
- SCM r = scm_i_mkbig ();
- mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
- scm_remember_upto_here_1 (y);
- mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
- *qp = SCM_INUM1;
- *rp = scm_i_normbig (r);
- }
- return;
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide (xx, SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_BIGP (x))
- {
- if (SCM_LIKELY (SCM_I_INUMP (y)))
- {
- scm_t_inum yy = SCM_I_INUM (y);
- if (SCM_UNLIKELY (yy == 0))
- scm_num_overflow (s_scm_euclidean_divide);
- else
- {
- SCM q = scm_i_mkbig ();
- scm_t_inum rr;
- if (yy > 0)
- rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x), yy);
- else
- {
- rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
- SCM_I_BIG_MPZ (x), -yy);
- mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
- }
- scm_remember_upto_here_1 (x);
- *qp = scm_i_normbig (q);
- *rp = SCM_I_MAKINUM (rr);
- }
- return;
- }
- else if (SCM_BIGP (y))
- {
- SCM q = scm_i_mkbig ();
- SCM r = scm_i_mkbig ();
- if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
- mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
- else
- mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
- scm_remember_upto_here_2 (x, y);
- *qp = scm_i_normbig (q);
- *rp = scm_i_normbig (r);
- return;
- }
- else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide
- (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_REALP (x))
- {
- if (SCM_REALP (y) || SCM_I_INUMP (y) ||
- SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_inexact_euclidean_divide
- (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
- else if (SCM_FRACTIONP (x))
- {
- if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide
- (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
- else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
- return scm_i_exact_rational_euclidean_divide (x, y, qp, rp);
- else
- return two_valued_wta_dispatch_2
- (g_scm_euclidean_divide, x, y, SCM_ARG2,
- s_scm_euclidean_divide, qp, rp);
- }
+ if (scm_is_false (scm_negative_p (y)))
+ return scm_floor_divide (x, y, qp, rp);
else
- return two_valued_wta_dispatch_2 (g_scm_euclidean_divide, x, y, SCM_ARG1,
- s_scm_euclidean_divide, qp, rp);
-}
-
-static void
-scm_i_inexact_euclidean_divide (double x, double y, SCM *qp, SCM *rp)
-{
- double q, r;
-
- if (SCM_LIKELY (y > 0))
- q = floor (x / y);
- else if (SCM_LIKELY (y < 0))
- q = ceil (x / y);
- else if (y == 0)
- scm_num_overflow (s_scm_euclidean_divide); /* or return a NaN? */
- else
- q = guile_NaN;
- r = x - q * y;
- *qp = scm_from_double (q);
- *rp = scm_from_double (r);
-}
-
-static void
-scm_i_exact_rational_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
-{
- SCM r1;
- SCM xd = scm_denominator (x);
- SCM yd = scm_denominator (y);
-
- scm_euclidean_divide (scm_product (scm_numerator (x), yd),
- scm_product (scm_numerator (y), xd),
- qp, &r1);
- *rp = scm_divide (r1, scm_product (xd, yd));
+ return scm_ceiling_divide (x, y, qp, rp);
}
static SCM scm_i_inexact_floor_quotient (double x, double y);
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #8: Slight optimization for scm_equal_p --]
[-- Type: text/x-diff, Size: 1463 bytes --]
From 97b4468e7759aed6f9d289f03e517ff362127c31 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 19:38:49 -0500
Subject: [PATCH 7/9] Slight optimization for scm_equal_p
* libguile/eq.c (scm_equal_p): Move SCM_STRUCTP check within the default
case of the SCM_TYP7 switch statement, for optimization.
---
libguile/eq.c | 16 ++++++++--------
1 files changed, 8 insertions(+), 8 deletions(-)
diff --git a/libguile/eq.c b/libguile/eq.c
index 99b3488..11dce99 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -332,6 +332,14 @@ scm_equal_p (SCM x, SCM y)
switch (SCM_TYP7 (x))
{
default:
+ /* Check equality between structs of equal type (see cell-type test above). */
+ if (SCM_STRUCTP (x))
+ {
+ if (SCM_INSTANCEP (x))
+ goto generic_equal;
+ else
+ return scm_i_struct_equalp (x, y);
+ }
break;
case scm_tc7_number:
switch SCM_TYP16 (x)
@@ -349,14 +357,6 @@ scm_equal_p (SCM x, SCM y)
case scm_tc7_wvect:
return scm_i_vector_equal_p (x, y);
}
- /* Check equality between structs of equal type (see cell-type test above). */
- if (SCM_STRUCTP (x))
- {
- if (SCM_INSTANCEP (x))
- goto generic_equal;
- else
- return scm_i_struct_equalp (x, y);
- }
/* Otherwise just return false. Dispatching to the generic is the wrong thing
here, as we can hit this case for any two objects of the same type that we
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #9: Make SCM_NUMP and SCM_NUMBERP more extensible --]
[-- Type: text/x-diff, Size: 1346 bytes --]
From 261b557202542dce281ef09ee939b70eeadaee11 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 19:04:05 -0500
Subject: [PATCH 8/9] Make SCM_NUMP and SCM_NUMBERP more extensible
* libguile/numbers.h (SCM_NUMP, SCM_NUMBERP): Mask out more bits in the
cell type field when doing the comparison, in order to accept future
numeric types that have not yet been implemented. This should allow
us to add more core numeric types without breaking ABI compatibility.
As a bonus, these macros are now more efficient.
---
libguile/numbers.h | 4 +---
1 files changed, 1 insertions(+), 3 deletions(-)
diff --git a/libguile/numbers.h b/libguile/numbers.h
index bc2d4f2..ab96981 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -138,9 +138,7 @@ typedef scm_t_int32 scm_t_wchar;
#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
#define SCM_NUMP(x) (!SCM_IMP(x) \
- && (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \
- || ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number)))
-/* 0xfcff (#b1100) for 0 free, 1 big, 2 real, 3 complex, then 0xfbff (#b1011) for 4 fraction */
+ && ((0x00ff & SCM_CELL_TYPE (x)) == scm_tc7_number))
#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
--
1.7.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #10: Allow GOOPS getters to add methods to primitive generics --]
[-- Type: text/x-diff, Size: 1688 bytes --]
From 5f1d36475883316a1830596302dd26172a86d9d7 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sat, 12 Feb 2011 05:43:17 -0500
Subject: [PATCH 9/9] Allow GOOPS getters to add methods to primitive generics
* module/oop/goops.scm (ensure-generic): If the old definition of a
desired getter is a primitive generic, let the new method be added to
it instead of creating a fresh new generic.
(ensure-accessor): Modify as necessary to keep the old behavior.
Maybe something more optimal can be done here, but it's not yet
obvious to me how to do it.
---
module/oop/goops.scm | 8 ++++++--
1 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 70bf375..2801aa2 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -391,7 +391,8 @@
#:default (procedure old-definition)
#:setter (setter old-definition)))
((procedure? old-definition)
- (make <generic> #:name name #:default old-definition))
+ (if (generic-capability? old-definition) old-definition
+ (make <generic> #:name name #:default old-definition)))
(else (make <generic> #:name name)))))
;; same semantics as <generic>
@@ -428,7 +429,10 @@
#:default (procedure proc)
#:setter (ensure-generic (setter proc) name)))
((procedure? proc)
- (ensure-accessor (ensure-generic proc name) name))
+ (ensure-accessor (if (generic-capability? proc)
+ (make <generic> #:name name #:default proc)
+ (ensure-generic proc name))
+ name))
(else
(make-accessor name)))))
--
1.7.1
^ permalink raw reply related [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-12 11:55 ` Andy Wingo
@ 2011-02-14 13:56 ` Ken Raeburn
2011-02-14 18:17 ` Mark H Weaver
0 siblings, 1 reply; 12+ messages in thread
From: Ken Raeburn @ 2011-02-14 13:56 UTC (permalink / raw)
To: Andy Wingo; +Cc: Mark H Weaver, guile-devel
On Feb 12, 2011, at 06:55, Andy Wingo wrote:
> Regarding multiple values: instead of unpacking values objects (ugh),
> can you instead make versions of _divide that return two values
> directly, as output arguments?
Or maybe a function returning a struct of two SCM fields (or a single array-of-2 field)? Granted, it doesn't extend as nicely to gsubrs returning arbitrary numbers of values, since you need a struct type per number-of-values, but it sounds like two is all that's needed here.
Ken
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-14 13:56 ` Ken Raeburn
@ 2011-02-14 18:17 ` Mark H Weaver
0 siblings, 0 replies; 12+ messages in thread
From: Mark H Weaver @ 2011-02-14 18:17 UTC (permalink / raw)
To: Ken Raeburn; +Cc: Andy Wingo, guile-devel
Ken Raeburn <raeburn@raeburn.org> writes:
> On Feb 12, 2011, at 06:55, Andy Wingo wrote:
>> Regarding multiple values: instead of unpacking values objects (ugh),
>> can you instead make versions of _divide that return two values
>> directly, as output arguments?
>
> Or maybe a function returning a struct of two SCM fields (or a single
> array-of-2 field)?
I believe the main motivation for avoiding values objects is to avoid
heap allocation, which your idea would also require.
Best,
Mark
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-13 14:55 ` Mark H Weaver
@ 2011-02-14 19:44 ` Andy Wingo
0 siblings, 0 replies; 12+ messages in thread
From: Andy Wingo @ 2011-02-14 19:44 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
On Sun 13 Feb 2011 15:55, Mark H Weaver <mhw@netris.org> writes:
> I have a new version of the patch set which I believe addresses all of
> your (quite reasonable) concerns. The second patch changes the API of
> the existing multi-valued operators as you suggest. The third optimizes
> the fraction case. The fourth adds the new division operators. The
> fifth optimizes the existing truncate/round/floor/ceiling unary
> operators.
>
> The sixth patch removes a lot of code, by implementing division
> operators in terms of other division operators.
>
> The other notable patch is the last one, which is unrelated to numerics,
> but it addresses a problem I discovered while implementing a complex
> number class in GOOPS. Suppose you define the following class within a
> module:
>
> (define-class <gcomplex> ()
> (real-part #:getter real-part #:init-keyword #:real-part)
> (imag-part #:getter imag-part #:init-keyword #:imag-part))
>
> There's no way I have found to make this work correctly. If the module
> exports real-part and imag-part, then those procedures will stop working
> for normal complex numbers for those who import the module. If the
> module does not export them, then those who import the module won't be
> able to use real-part or imag-part on <gcomplex> objects. The last
> patch fixes this.
Thanks for the patches; applied. And thanks for the prompt feedback!
Cheers,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-10 23:42 Mark H Weaver
2011-02-12 11:55 ` Andy Wingo
@ 2011-02-15 10:38 ` Ludovic Courtès
2011-02-15 11:43 ` Mark H Weaver
1 sibling, 1 reply; 12+ messages in thread
From: Ludovic Courtès @ 2011-02-15 10:38 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Hi Mark,
This patch series seems to break compilation on i686-linux-gnu:
http://hydra.nixos.org/build/913079
The relevant part of the log is:
Running numbers.test
FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (130.0 10/7)
FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (130.0 -10/7)
FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (-130.0 10/7)
FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (-130.0 -10/7)
The suspected patches are:
http://git.savannah.gnu.org/cgit/guile.git/diff/?id=7017846b2b34e4ec3fd402c6c02ff40e90d256b5&id2=1fa6ac0014bd2b26b4eeb985ef123ba6cd4468e6
Can you look into it?
If you don’t have time, I’ll revert some of this for 2.0.0.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-15 10:38 ` Ludovic Courtès
@ 2011-02-15 11:43 ` Mark H Weaver
2011-02-15 14:49 ` Ludovic Courtès
0 siblings, 1 reply; 12+ messages in thread
From: Mark H Weaver @ 2011-02-15 11:43 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 694 bytes --]
ludo@gnu.org (Ludovic Courtès) writes:
> This patch series seems to break compilation on i686-linux-gnu:
>
> http://hydra.nixos.org/build/913079
>
> The relevant part of the log is:
>
> Running numbers.test
> FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (130.0 10/7)
> FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (130.0 -10/7)
> FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (-130.0 10/7)
> FAIL: numbers.test: Number-theoretic division: truncate/: mixed types: (-130.0 -10/7)
The following patch should fix it.
Best,
Mark
PS: Thanks for importing log1p so quickly!
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Use trunc in scm_i_inexact_truncate_divide --]
[-- Type: text/x-diff, Size: 1115 bytes --]
From 4a9c388d3c837244e358916beda59d4634121723 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 15 Feb 2011 06:10:06 -0500
Subject: [PATCH] Use trunc in scm_i_inexact_truncate_divide
* libguile/numbers.c (scm_i_inexact_truncate_divide): Use trunc instead
of floor and ceil. Important for consistency with
scm_truncate_quotient and scm_truncate_remainder.
---
libguile/numbers.c | 7 ++-----
1 files changed, 2 insertions(+), 5 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 59d8e74..7c4ea1b 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2450,11 +2450,8 @@ scm_i_inexact_truncate_divide (double x, double y, SCM *qp, SCM *rp)
scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
else
{
- double q, r, q1;
- /* FIXME: Use trunc, after it has been imported from gnulib */
- q1 = x / y;
- q = (q1 >= 0) ? floor (q1) : ceil (q1);
- r = x - q * y;
+ double q = trunc (x / y);
+ double r = x - q * y;
*qp = scm_from_double (q);
*rp = scm_from_double (r);
}
--
1.7.1
^ permalink raw reply related [flat|nested] 12+ messages in thread
* Re: [PATCH] New division operators, and optimization for fractions
2011-02-15 11:43 ` Mark H Weaver
@ 2011-02-15 14:49 ` Ludovic Courtès
0 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2011-02-15 14:49 UTC (permalink / raw)
To: guile-devel
Hi Mark,
Mark H Weaver <mhw@netris.org> writes:
> The following patch should fix it.
It apparently does, thanks!
http://hydra.nixos.org/jobset/gnu/guile-master
Ludo’.
^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2011-02-15 14:49 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
[not found] <595618.30923.qm@web114107.mail.gq1.yahoo.com>
2011-02-12 21:54 ` [PATCH] New division operators, and optimization for fractions Andy Wingo
2011-02-12 22:38 ` Mark Weaver
[not found] <860989.4731.qm@web114104.mail.gq1.yahoo.com>
2011-02-12 20:19 ` Andy Wingo
2011-02-13 14:55 ` Mark H Weaver
2011-02-14 19:44 ` Andy Wingo
2011-02-10 23:42 Mark H Weaver
2011-02-12 11:55 ` Andy Wingo
2011-02-14 13:56 ` Ken Raeburn
2011-02-14 18:17 ` Mark H Weaver
2011-02-15 10:38 ` Ludovic Courtès
2011-02-15 11:43 ` Mark H Weaver
2011-02-15 14:49 ` Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).