[PATCH] Fix bugs in expt and integer-expt

[Mark H Weaver]

Here's my patch to fix some bugs in expt and integer-expt.
Please review.

     Mark

>From 19a24107af814e34fe63d02478bfb9441354625e Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Thu, 4 Nov 2010 22:10:02 -0400
Subject: [PATCH] Fix bugs in expt and integer-expt

* libguile/numbers.c (expt): Fix bug that caused expt to throw an
  exception whenever the base was exact and the exponent was an
  inexact integer, e.g. (expt 5 6.0).

  (expt): Fix bug that caused expt to introduce spurious imaginary
  parts in the result when the base was an inexact negative real and
  the exponent was an integer, e.g. (expt -1.0 2)

  (integer-expt, expt): Change behavior of (integer-expt 0 -1), and
  therefore also (expt 0 -1), to return NaN, per R6RS (actually, R6RS
  says we should throw an exception or return an "unspecified number
  object", but for now we use NaN).  Formerly we returned 0, per R5RS.
  R5RS claims that 0^x=0 for all non-zero x, but that's mathematically
  incorrect, and probably an oversight.

  (integer-expt): Consistently throw a wrong-argument-type exception
  when the exponent is inexact.  Formerly, it didn't always check this
  if the base was 0, 1, or -1.

* test-suite/tests/numbers.test ("integer-expt", "expt"): Add tests.
---
 libguile/numbers.c            |   41 ++++++++++++++++++++++++++++++----
 test-suite/tests/numbers.test |   48 ++++++++++++++++++++++++++++++++++++----
 2 files changed, 79 insertions(+), 10 deletions(-)

diff --git a/libguile/numbers.c b/libguile/numbers.c
index fbc6cc8..b699843 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1780,10 +1780,20 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
   SCM acc = SCM_I_MAKINUM (1L);
 
   SCM_VALIDATE_NUMBER (SCM_ARG1, n);
+  if (!SCM_I_INUMP (k) && !SCM_BIGP (k))
+    SCM_WRONG_TYPE_ARG (2, k);
 
-  /* 0^0 == 1 according to R5RS */
-  if (scm_is_eq (n, SCM_INUM0) || scm_is_eq (n, acc))
-    return scm_is_false (scm_zero_p(k)) ? n : acc;
+  if (scm_is_true (scm_zero_p (n)))
+    {
+      if (scm_is_true (scm_zero_p (k)))  /* 0^0 == 1 per R5RS */
+       return acc;        /* return exact 1, regardless of n */
+      else if (scm_is_true (scm_positive_p (k)))
+       return n;
+      else  /* return NaN for (0 ^ k) for negative k per R6RS */
+       return scm_nan ();
+    }
+  else if (scm_is_eq (n, acc))
+    return acc;
   else if (scm_is_eq (n, SCM_I_MAKINUM (-1L)))
     return scm_is_false (scm_even_p (k)) ? n : acc;
 
@@ -5445,8 +5455,29 @@ SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
            "Return @var{x} raised to the power of @var{y}.") 
 #define FUNC_NAME s_scm_expt
 {
-  if (scm_is_true (scm_exact_p (x)) && scm_is_integer (y))
-    return scm_integer_expt (x, y);
+  if (scm_is_integer (y))
+    {
+      if (scm_is_true (scm_exact_p (y)))
+       return scm_integer_expt (x, y);
+      else
+       {
+         /* Here we handle the case where the exponent is an inexact
+            integer.  We make the exponent exact in order to use
+            scm_integer_expt, and thus avoid the spurious imaginary
+            parts that may result from round-off errors in the general
+            e^(y log x) method below (for example when squaring a large
+            negative number).  In this case, we must return an inexact
+            result for correctness.  We also make the base inexact so
+            that scm_integer_expt will use fast inexact arithmetic
+            internally.  Note that making the base inexact is not
+            sufficient to guarantee an inexact result, because
+            scm_integer_expt will return an exact 1 when the exponent
+            is 0, even if the base is inexact. */
+         return scm_exact_to_inexact
+           (scm_integer_expt (scm_exact_to_inexact (x),
+                              scm_inexact_to_exact (y)));
+       }
+    }
   else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
     {
       return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 3c3e14f..6ee4bbc 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -2889,10 +2889,32 @@
 (with-test-prefix "expt"
   (pass-if-exception "non-numeric base" exception:wrong-type-arg
                      (expt #t 0))
-  (pass-if "(= 1 (expt 0 0))" (= 1 (expt 0 0)))
-  (pass-if "(= 1 (expt 0 0.0))" (= 1 (expt 0 0.0)))
-  (pass-if "(= 1 (expt 0.0 0))" (= 1 (expt 0.0 0)))
-  (pass-if "(= 1 (expt 0.0 0.0))" (= 1 (expt 0.0 0.0))))
+  (pass-if (eqv? 1 (expt 0 0)))
+  (pass-if (eqv? 1 (expt 0.0 0)))
+  (pass-if (eqv? 1.0 (expt 0 0.0)))
+  (pass-if (eqv? 1.0 (expt 0.0 0.0)))
+  (pass-if (nan? (expt 0 -1)))
+  (pass-if (nan? (expt 0 -1.0)))
+  (pass-if (nan? (expt 0.0 -1)))
+  (pass-if (nan? (expt 0.0 -1.0)))
+  (pass-if (eqv? 0 (expt 0 3)))
+  (pass-if (= 0 (expt 0 4.0)))
+  (pass-if (eqv? 0.0 (expt 0.0 5)))
+  (pass-if (eqv? 0.0 (expt 0.0 6.0)))
+  (pass-if (eqv? -2742638075.5 (expt -2742638075.5 1)))
+  (pass-if (eqv? (* -2742638075.5 -2742638075.5)
+                 (expt -2742638075.5 2)))
+  (pass-if (eqv? 4.0 (expt -2.0 2.0)))
+  (pass-if (eqv? -1/8 (expt -2 -3)))
+  (pass-if (eqv? -0.125 (expt -2.0 -3)))
+  (pass-if (eqv? -0.125 (expt -2 -3.0)))
+  (pass-if (eqv? -0.125 (expt -2.0 -3.0)))
+  (pass-if (eqv? 0.25 (expt 2.0 -2.0)))
+  (pass-if (eqv? (* -1.0 12398 12398) (expt +12398i 2.0)))
+  (pass-if (eqv-loosely? +i (expt -1 0.5)))
+  (pass-if (eqv-loosely? +i (expt -1 1/2)))
+  (pass-if (eqv-loosely? 1.0+1.7320508075688i (expt -8 1/3))))
+
 
 ;;;
 ;;; asinh
@@ -3014,7 +3036,23 @@
   (pass-if-exception "2^-inf" exception:wrong-type-arg
     (integer-expt 2 -inf.0))
   (pass-if-exception "2^nan" exception:wrong-type-arg
-    (integer-expt 2 +nan.0)))
+    (integer-expt 2 +nan.0))
+
+  (pass-if (eqv? 1 (integer-expt 0 0)))
+  (pass-if (eqv? 1 (integer-expt 0.0 0)))
+  (pass-if (nan? (integer-expt 0 -1)))
+  (pass-if (nan? (integer-expt 0.0 -1)))
+  (pass-if (eqv? 0 (integer-expt 0 3)))
+  (pass-if (eqv? 0.0 (integer-expt 0.0 5)))
+  (pass-if (eqv? -2742638075.5 (integer-expt -2742638075.5 1)))
+  (pass-if (eqv? (* -2742638075.5 -2742638075.5)
+                 (integer-expt -2742638075.5 2)))
+  (pass-if (eqv? 4.0 (integer-expt -2.0 2)))
+  (pass-if (eqv? -1/8 (integer-expt -2 -3)))
+  (pass-if (eqv? -0.125 (integer-expt -2.0 -3)))
+  (pass-if (eqv? 0.25 (integer-expt 2.0 -2)))
+  (pass-if (eqv? (* -1.0 12398 12398) (integer-expt +12398.0i 2))))
+
 
 ;;;
 ;;; integer-length
-- 
1.5.6.5