* [PATCH] Miscellaneous fixes and improvements
@ 2011-02-10 21:01 Mark H Weaver
2011-02-12 11:35 ` Andy Wingo
0 siblings, 1 reply; 2+ messages in thread
From: Mark H Weaver @ 2011-02-10 21:01 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 291 bytes --]
Hello all,
Here are some miscellaneous fixes. The only non-trivial patch here is
the last one, which includes (among other things) another rework of the
testing framework for number-theoretic division operators.
More sigificant patches are on the way after this.
Best,
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Bump copyright date in REPL version string --]
[-- Type: text/x-diff, Size: 896 bytes --]
From 884d3ef84d2256fbf149dfa057a845f424ee8e62 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 14:12:12 -0500
Subject: [PATCH] Bump copyright date in REPL version string
* module/system/repl/common.scm (*version*): Add 2011 to copyright
date range.
---
module/system/repl/common.scm | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index e03bf93..5405bb8 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -36,7 +36,7 @@
(define *version*
(format #f "GNU Guile ~A
-Copyright (C) 1995-2010 Free Software Foundation, Inc.
+Copyright (C) 1995-2011 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Fix mistake in comment in tags.h --]
[-- Type: text/x-diff, Size: 1353 bytes --]
From 0ac06209456175b73b565b2a94a0b097cdd4891b Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 14:15:52 -0500
Subject: [PATCH] Fix mistake in comment in tags.h
* libguile/tags.h: Fix comment in discussion of data representation.
tc3-code #0b110 indicates a small integer and #0b100 indicates a
non-integer immediate. Previously, these were reversed.
---
libguile/tags.h | 4 ++--
1 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/libguile/tags.h b/libguile/tags.h
index 9e0e305..39d2eaa 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -258,8 +258,8 @@ typedef scm_t_uintptr scm_t_bits;
*
* If the cell holds a scheme pair, then we already know that the first
* scm_t_bits variable of the cell will hold a scheme object with one of the
- * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b100
- * (small integer), #b110 (non-integer immediate). All these tc3-codes have
+ * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b110
+ * (small integer), #b100 (non-integer immediate). All these tc3-codes have
* in common, that their least significant bit is #b0. This fact is used by
* the garbage collector to identify cells that hold pairs. The remaining
* tc3-codes are assigned as follows: #b001 (class instance or, more
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Fix extensibility of 1-argument atan --]
[-- Type: text/x-diff, Size: 989 bytes --]
From 724a8e49fb46fd525b4d82ffaa71d3fd18975ff9 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 14:24:39 -0500
Subject: [PATCH] Fix extensibility of 1-argument atan
* libguile/numbers.c (scm_atan): Call SCM_WTA_DISPATCH_1 instead of
SCM_WTA_DISPATCH_2 if the second argument is unbound. Arguably,
SCM_WTA_DISPATCH_* should handle that case gracefully, but currently
it doesn't.
---
libguile/numbers.c | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index bd9870f..e4e5140 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -7025,7 +7025,7 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
scm_c_make_rectangular (0, 2));
}
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ SCM_WTA_DISPATCH_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
}
else if (scm_is_real (z))
{
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: Add comment about handling of exactness specifiers --]
[-- Type: text/x-diff, Size: 3651 bytes --]
From 84256f94221ec31f0b8140c7da826ae5bc1494d8 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 14:35:02 -0500
Subject: [PATCH] Add comment about handling of exactness specifiers
* libguile/numbers.c: Add discussion on the handling of exactness
specifiers to the comment above the string-to-number conversion
functions.
---
libguile/numbers.c | 35 ++++++++++++++++++++++++++++++++---
1 files changed, 32 insertions(+), 3 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index e4e5140..1aed0c2 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -3834,14 +3834,15 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
* in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
* <uinteger R>, ...) that are used to build up numbers in the grammar. Some
* points should be noted about the implementation:
+ *
* * Each function keeps a local index variable 'idx' that points at the
* current position within the parsed string. The global index is only
* updated if the function could parse the corresponding syntactic unit
* successfully.
+ *
* * Similarly, the functions keep track of indicators of inexactness ('#',
- * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
- * global exactness information is only updated after each part has been
- * successfully parsed.
+ * '.' or exponents) using local variables ('hash_seen', 'x').
+ *
* * Sequences of digits are parsed into temporary variables holding fixnums.
* Only if these fixnums would overflow, the result variables are updated
* using the standard functions scm_add, scm_product, scm_divide etc. Then,
@@ -3850,6 +3851,34 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
* digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
* and the result was computed as 12345 * 100000 + 67890. In other words,
* only every five digits two bignum operations were performed.
+ *
+ * Notes on the handling of exactness specifiers:
+ *
+ * When parsing non-real complex numbers, we apply exactness specifiers on
+ * per-component basis, as is done in PLT Scheme. For complex numbers
+ * written in rectangular form, exactness specifiers are applied to the
+ * real and imaginary parts before calling scm_make_rectangular. For
+ * complex numbers written in polar form, exactness specifiers are applied
+ * to the magnitude and angle before calling scm_make_polar.
+ *
+ * There are two kinds of exactness specifiers: forced and implicit. A
+ * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
+ * the entire number, and applies to both components of a complex number.
+ * "#e" causes each component to be made exact, and "#i" causes each
+ * component to be made inexact. If no forced exactness specifier is
+ * present, then the exactness of each component is determined
+ * independently by the presence or absence of a decimal point or hash mark
+ * within that component. If a decimal point or hash mark is present, the
+ * component is made inexact, otherwise it is made exact.
+ *
+ * After the exactness specifiers have been applied to each component, they
+ * are passed to either scm_make_rectangular or scm_make_polar to produce
+ * the final result. Note that this will result in a real number if the
+ * imaginary part, magnitude, or angle is an exact 0.
+ *
+ * For example, (string->number "#i5.0+0i") does the equivalent of:
+ *
+ * (make-rectangular (exact->inexact 5) (exact->inexact 0))
*/
enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
--
1.5.6.5
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: Fixes and improvements to number-theoretic division operators --]
[-- Type: text/x-diff, Size: 23400 bytes --]
From 65ede1a8ea1d1ba91f892c17a35642b86f92fa26 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 10 Feb 2011 15:40:57 -0500
Subject: [PATCH] Fixes and improvements to number-theoretic division operators
* libguile/numbers.c (scm_euclidean_quotient, scm_euclidean_divide,
scm_centered_quotient, scm_centered_divide): Fix bug in inum/inum
case, where (quotient most-negative-fixnum -1) would not be converted
to a bignum.
(scm_euclidean_quotient): Be more anal-retentive about calling
scm_remember_upto_here_1 after mpz_sgn, (even though mpz_sgn is
documented as being implemented as a macro and certainly won't
do any allocation). It's better to be safe than sorry here.
(scm_euclidean_quotient, scm_centered_quotient): In the bignum/inum
case, check if the divisor is 1, since this will allow us to avoid
allocating a new bignum.
(scm_euclidean_divide, scm_centered_quotient, scm_centered_divide):
When computing the intermediate truncated quotient (xx / yy) and
remainder, use (xx % yy) instead of (xx - qq * yy), on the theory that
the compiler is more likely to handle this case intelligently and
maybe combine the operations.
(scm_euclidean_divide): In the bignum/inum case, we know that the
remainder will fit in an fixnum, so don't bother allocating a bignum
for it.
(scm_euclidean_quotient, scm_euclidean_remainder,
scm_euclidean_divide, scm_centered_quotient, scm_centered_remainder,
scm_centered_divide): Minor stylistic changes.
* test-suite/tests/numbers.test: Rework testing framework for
number-theoretic division operators to be more efficient and
comprehensive in its testing of code paths and problem cases.
---
libguile/numbers.c | 100 +++++++++-------
test-suite/tests/numbers.test | 261 +++++++++++++++++++++++------------------
2 files changed, 205 insertions(+), 156 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 1aed0c2..05840ef 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1089,6 +1089,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
{
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);
@@ -1096,7 +1097,6 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
scm_num_overflow (s_scm_euclidean_quotient);
else
{
- scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum qq = xx / yy;
if (xx < qq * yy)
{
@@ -1105,19 +1105,25 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else
qq++;
}
- return SCM_I_MAKINUM (qq);
+ if (SCM_LIKELY (SCM_FIXABLE (qq)))
+ return SCM_I_MAKINUM (qq);
+ else
+ return scm_i_inum2big (qq);
}
}
else if (SCM_BIGP (y))
{
- if (SCM_I_INUM (x) >= 0)
+ if (xx >= 0)
return SCM_INUM0;
else
- return SCM_I_MAKINUM (- mpz_sgn (SCM_I_BIG_MPZ (y)));
+ {
+ 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
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
@@ -1131,6 +1137,8 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
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 ();
@@ -1246,6 +1254,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
{
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);
@@ -1253,7 +1262,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
scm_num_overflow (s_scm_euclidean_remainder);
else
{
- scm_t_inum rr = SCM_I_INUM (x) % yy;
+ scm_t_inum rr = xx % yy;
if (rr >= 0)
return SCM_I_MAKINUM (rr);
else if (yy > 0)
@@ -1264,7 +1273,6 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
}
else if (SCM_BIGP (y))
{
- scm_t_inum xx = SCM_I_INUM (x);
if (xx >= 0)
return x;
else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
@@ -1284,8 +1292,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
}
}
else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_remainder
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
@@ -1420,6 +1427,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
{
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);
@@ -1427,9 +1435,10 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
scm_num_overflow (s_scm_euclidean_divide);
else
{
- scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum qq = xx / yy;
- scm_t_inum rr = xx - qq * yy;
+ scm_t_inum rr = xx % yy;
+ SCM q;
+
if (rr < 0)
{
if (yy > 0)
@@ -1437,13 +1446,15 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
else
{ rr -= yy; qq++; }
}
- return scm_values (scm_list_2 (SCM_I_MAKINUM (qq),
- SCM_I_MAKINUM (rr)));
+ 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))
{
- scm_t_inum xx = SCM_I_INUM (x);
if (xx >= 0)
return scm_values (scm_list_2 (SCM_INUM0, x));
else if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
@@ -1464,8 +1475,7 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
}
}
else if (SCM_REALP (y))
- return scm_i_inexact_euclidean_divide
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
@@ -1482,19 +1492,19 @@ SCM_PRIMITIVE_GENERIC (scm_euclidean_divide, "euclidean/", 2, 0, 0,
else
{
SCM q = scm_i_mkbig ();
- SCM r = scm_i_mkbig ();
+ scm_t_inum rr;
if (yy > 0)
- mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
- SCM_I_BIG_MPZ (x), yy);
+ rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
+ 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);
+ 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);
return scm_values (scm_list_2 (scm_i_normbig (q),
- scm_i_normbig (r)));
+ SCM_I_MAKINUM (rr)));
}
}
else if (SCM_BIGP (y))
@@ -1607,6 +1617,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
{
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);
@@ -1614,9 +1625,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
scm_num_overflow (s_scm_centered_quotient);
else
{
- scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum qq = xx / yy;
- scm_t_inum rr = xx - qq * yy;
+ scm_t_inum rr = xx % yy;
if (SCM_LIKELY (xx > 0))
{
if (SCM_LIKELY (yy > 0))
@@ -1643,19 +1653,20 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
qq++;
}
}
- return SCM_I_MAKINUM (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_centered_quotient */
- return scm_i_bigint_centered_quotient
- (scm_i_long2big (SCM_I_INUM (x)), y);
+ return scm_i_bigint_centered_quotient (scm_i_long2big (xx), y);
}
else if (SCM_REALP (y))
- return scm_i_inexact_centered_quotient
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
@@ -1669,6 +1680,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
scm_t_inum yy = SCM_I_INUM (y);
if (SCM_UNLIKELY (yy == 0))
scm_num_overflow (s_scm_centered_quotient);
+ else if (SCM_UNLIKELY (yy == 1))
+ return x;
else
{
SCM q = scm_i_mkbig ();
@@ -1833,6 +1846,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
{
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);
@@ -1840,7 +1854,6 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
scm_num_overflow (s_scm_centered_remainder);
else
{
- scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum rr = xx % yy;
if (SCM_LIKELY (xx > 0))
{
@@ -1875,12 +1888,10 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
{
/* Pass a denormalized bignum version of x (even though it
can fit in a fixnum) to scm_i_bigint_centered_remainder */
- return scm_i_bigint_centered_remainder
- (scm_i_long2big (SCM_I_INUM (x)), y);
+ return scm_i_bigint_centered_remainder (scm_i_long2big (xx), y);
}
else if (SCM_REALP (y))
- return scm_i_inexact_centered_remainder
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
@@ -2062,6 +2073,7 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
{
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);
@@ -2069,9 +2081,10 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
scm_num_overflow (s_scm_centered_divide);
else
{
- scm_t_inum xx = SCM_I_INUM (x);
scm_t_inum qq = xx / yy;
- scm_t_inum rr = xx - qq * yy;
+ scm_t_inum rr = xx % yy;
+ SCM q;
+
if (SCM_LIKELY (xx > 0))
{
if (SCM_LIKELY (yy > 0))
@@ -2098,20 +2111,21 @@ SCM_PRIMITIVE_GENERIC (scm_centered_divide, "centered/", 2, 0, 0,
{ qq++; rr -= yy; }
}
}
- return scm_values (scm_list_2 (SCM_I_MAKINUM (qq),
- SCM_I_MAKINUM (rr)));
+ 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_centered_divide */
- return scm_i_bigint_centered_divide
- (scm_i_long2big (SCM_I_INUM (x)), y);
+ return scm_i_bigint_centered_divide (scm_i_long2big (xx), y);
}
else if (SCM_REALP (y))
- return scm_i_inexact_centered_divide
- (SCM_I_INUM (x), SCM_REAL_VALUE (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);
else
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 1c4630e..f738189 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -4116,6 +4116,7 @@
(pass-if "-100i swings back to 45deg down"
(eqv-loosely? +7.071-7.071i (sqrt -100.0i))))
+
;;;
;;; euclidean/
;;; euclidean-quotient
@@ -4127,130 +4128,164 @@
(with-test-prefix "Number-theoretic division"
- ;; Tests that (lo <= x < hi),
+ ;; Tests that (lo <1 x <2 hi),
;; but allowing for imprecision
;; if x is inexact.
- (define (test-within-range? lo hi x)
+ (define (test-within-range? lo <1 x <2 hi)
(if (exact? x)
- (and (<= lo x) (< x hi))
+ (and (<1 lo x) (<2 x hi))
(let ((lo (- lo test-epsilon))
(hi (+ hi test-epsilon)))
(<= lo x hi))))
- ;; (cartesian-product-map list '(a b) '(1 2))
- ;; ==> ((a 1) (a 2) (b 1) (b 2))
- (define (cartesian-product-map f . lsts)
- (define (cartmap rev-head lsts)
- (if (null? lsts)
- (list (apply f (reverse rev-head)))
- (append-map (lambda (x) (cartmap (cons x rev-head) (cdr lsts)))
- (car lsts))))
- (cartmap '() lsts))
-
- (define (cartesian-product-for-each f . lsts)
- (define (cartfor rev-head lsts)
- (if (null? lsts)
- (apply f (reverse rev-head))
- (for-each (lambda (x) (cartfor (cons x rev-head) (cdr lsts)))
- (car lsts))))
- (cartfor '() lsts))
-
- (define (safe-euclidean-quotient x y)
- (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
- ((zero? y) (throw 'divide-by-zero))
- ((nan? y) (nan))
- ((positive? y) (floor (/ x y)))
- ((negative? y) (ceiling (/ x y)))
- (else (throw 'unknown-problem))))
-
- (define (safe-euclidean-remainder x y)
- (let ((q (safe-euclidean-quotient x y)))
- (- x (* y q))))
-
(define (valid-euclidean-answer? x y q r)
- (if (and (finite? x) (finite? y))
- (and (eq? (exact? q)
- (exact? r)
- (and (exact? x) (exact? y)))
- (integer? q)
- (test-eqv? r (- x (* q y)))
- (test-within-range? 0 (abs y) r))
- (and (test-eqv? q (safe-euclidean-quotient x y))
- (test-eqv? r (safe-euclidean-remainder x y)))))
-
- (define (safe-centered-quotient x y)
- (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
- ((zero? y) (throw 'divide-by-zero))
- ((nan? y) (nan))
- ((positive? y) (floor (+ 1/2 (/ x y))))
- ((negative? y) (ceiling (+ -1/2 (/ x y))))
- (else (throw 'unknown-problem))))
-
- (define (safe-centered-remainder x y)
- (let ((q (safe-centered-quotient x y)))
- (- x (* y q))))
+ (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)
+ (test-within-range? 0 <= r < (abs y)))
+ (test-eqv? q (/ x y)))))
(define (valid-centered-answer? x y q r)
- (if (and (finite? x) (finite? y))
- (and (eq? (exact? q)
- (exact? r)
- (and (exact? x) (exact? y)))
- (integer? q)
- (test-eqv? r (- x (* q y)))
- (test-within-range? (* -1/2 (abs y))
- (* +1/2 (abs y))
- r))
- (and (test-eqv? q (safe-centered-quotient x y))
- (test-eqv? r (safe-centered-remainder x y)))))
-
- (define test-numerators
- (append (cartesian-product-map * '(1 -1)
- '(123 125 127 130 3 5 10
- 123.2 125.0 127.2 130.0
- 123/7 125/7 127/7 130/7))
- (cartesian-product-map * '(1 -1)
- '(123 125 127 130 3 5 10)
- (list 1
- (+ 1 most-positive-fixnum)
- (+ 2 most-positive-fixnum)))
- (list 0 +0.0 -0.0 +inf.0 -inf.0 +nan.0
- most-negative-fixnum
- (1+ most-positive-fixnum)
- (1- most-negative-fixnum))))
-
- (define test-denominators
- (list 10 5 10/7 127/2 10.0 63.5
- -10 -5 -10/7 -127/2 -10.0 -63.5
- +inf.0 -inf.0 +nan.0 most-negative-fixnum
- (+ 1 most-positive-fixnum) (+ -1 most-negative-fixnum)
- (+ 2 most-positive-fixnum) (+ -2 most-negative-fixnum)))
+ (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)
+ (test-within-range?
+ (* -1/2 (abs y)) <= r < (* +1/2 (abs y))))
+ (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))))))
+
+ (define (run-division-tests quo+rem quo rem valid-answer?)
+ (define (test n d)
+ (run-test (list n d) #t
+ (lambda ()
+ (let-values (((q r) (quo+rem n d)))
+ (and (test-eqv? q (quo n d))
+ (test-eqv? r (rem n d))
+ (valid-answer? n d q r))))))
+ (define (test+/- n d)
+ (test n d )
+ (test n (- d))
+ (cond ((not (zero? n))
+ (test (- n) d )
+ (test (- n) (- d)))))
+
+ (define (test-for-exception n d exception)
+ (let ((name (list n d)))
+ (pass-if-exception name exception (quo+rem n d))
+ (pass-if-exception name exception (quo n d))
+ (pass-if-exception name exception (rem n d))))
+
+ (run-test "documented?" #t
+ (lambda ()
+ (and (documented? quo+rem)
+ (documented? quo)
+ (documented? rem))))
+
+ (with-test-prefix "inum / inum"
+ (with-test-prefix "fixnum-min / -1"
+ (test fixnum-min -1))
+ (for '((1 2 5 10)) ;; denominators
+ (lambda (d)
+ (for '((0 1 2 5 10)) ;; multiples
+ (lambda (m)
+ (for '((-2 -1 0 1 2 3 4 5 7 10
+ 12 15 16 19 20)) ;; offsets
+ (lambda (b)
+ (test+/- (+ b (* m d))
+ d))))))))
+
+ (with-test-prefix "inum / big"
+ (with-test-prefix "fixnum-min / -fixnum-min"
+ (test fixnum-min (- fixnum-min)))
+ (with-test-prefix "fixnum-max / (2*fixnum-max)"
+ (test+/- fixnum-max (* 2 fixnum-max)))
+ (for `((0 1 2 10 ,(1- fixnum-max) ,fixnum-max))
+ (lambda (n)
+ (test n (1+ fixnum-max))
+ (test (- n) (1+ fixnum-max))
+ (test n (1- fixnum-min))
+ (test (- n) (1- fixnum-min)))))
+
+ (with-test-prefix "big / inum"
+ (with-test-prefix "-fixnum-min / fixnum-min"
+ (test (- fixnum-min) fixnum-min))
+ (for '((1 4 5 10)) ;; denominators
+ (lambda (d)
+ (for `((1 2 5 ,@(if (even? d)
+ '(1/2 3/2 5/2)
+ '()))) ;; multiples
+ (lambda (m)
+ (for '((-2 -1 0 1 2)) ;; offsets
+ (lambda (b)
+ (test+/- (+ b (* m d big))
+ d))))))))
+
+ (with-test-prefix "big / big"
+ (for `((,big ,(1+ big))) ;; denominators
+ (lambda (d)
+ (for `((1 2 5 ,@(if (even? d)
+ '(1/2 3/2 5/2)
+ '()))) ;; multiples
+ (lambda (m)
+ (for '((-2 -1 0 1 2)) ;; offsets
+ (lambda (b)
+ (test+/- (+ b (* m d))
+ d))))))))
+
+ (with-test-prefix "inexact"
+ (for '((0.5 1.5 2.25 5.75)) ;; denominators
+ (lambda (d)
+ (for '((0 1 2 5 1/2 3/2 5/2)) ;; multiples
+ (lambda (m)
+ (for '((-2 -1 0 1 2)) ;; offsets
+ (lambda (b)
+ (test+/- (+ b (* m d))
+ d))))))))
+
+ (with-test-prefix "fractions"
+ (for '((1/10 16/3 10/7)) ;; denominators
+ (lambda (d)
+ (for '((0 1 2 5 1/2 3/2 5/2)) ;; multiples
+ (lambda (m)
+ (for '((-2/9 -1/11 0 1/3 2/3)) ;; offsets
+ (lambda (b)
+ (test+/- (+ b (* m d))
+ d))))))))
+
+ (with-test-prefix "mixed types"
+ (for `((10 ,big 12.0 10/7 +inf.0 -inf.0 +nan.0)) ;; denominators
+ (lambda (d)
+ (for `((25 ,(* 3/2 big) 130.0 15/7
+ 0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators
+ (lambda (n)
+ (test+/- n d))))))
+
+ (with-test-prefix "divide by zero"
+ (for `((0 0.0 +0.0)) ;; denominators
+ (lambda (d)
+ (for `((15 ,(* 3/2 big) 18.0 33/7
+ 0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators
+ (lambda (n)
+ (test-for-exception
+ n d exception:numerical-overflow)))))))
(with-test-prefix "euclidean/"
- (pass-if (documented? euclidean/))
- (pass-if (documented? euclidean-quotient))
- (pass-if (documented? euclidean-remainder))
-
- (cartesian-product-for-each
- (lambda (n d)
- (run-test (list 'euclidean/ n d) #t
- (lambda ()
- (let-values (((q r) (euclidean/ n d)))
- (and (test-eqv? q (euclidean-quotient n d))
- (test-eqv? r (euclidean-remainder n d))
- (valid-euclidean-answer? n d q r))))))
- test-numerators test-denominators))
+ (run-division-tests euclidean/
+ euclidean-quotient
+ euclidean-remainder
+ valid-euclidean-answer?))
(with-test-prefix "centered/"
- (pass-if (documented? centered/))
- (pass-if (documented? centered-quotient))
- (pass-if (documented? centered-remainder))
-
- (cartesian-product-for-each
- (lambda (n d)
- (run-test (list 'centered/ n d) #t
- (lambda ()
- (let-values (((q r) (centered/ n d)))
- (and (test-eqv? q (centered-quotient n d))
- (test-eqv? r (centered-remainder n d))
- (valid-centered-answer? n d q r))))))
- test-numerators test-denominators)))
+ (run-division-tests centered/
+ centered-quotient
+ centered-remainder
+ valid-centered-answer?)))
--
1.5.6.5
^ permalink raw reply related [flat|nested] 2+ messages in thread
* Re: [PATCH] Miscellaneous fixes and improvements
2011-02-10 21:01 [PATCH] Miscellaneous fixes and improvements Mark H Weaver
@ 2011-02-12 11:35 ` Andy Wingo
0 siblings, 0 replies; 2+ messages in thread
From: Andy Wingo @ 2011-02-12 11:35 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
On Thu 10 Feb 2011 22:01, Mark H Weaver <mhw@netris.org> writes:
> Here are some miscellaneous fixes. The only non-trivial patch here is
> the last one, which includes (among other things) another rework of the
> testing framework for number-theoretic division operators.
Applied, thanks.
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2011-02-12 11:35 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-02-10 21:01 [PATCH] Miscellaneous fixes and improvements Mark H Weaver
2011-02-12 11:35 ` Andy Wingo
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).