[PATCH] Fix the R6RS exact-integer-sqrt and import into core guile

[Mark H Weaver]

exact-integer-sqrt is broken.  It is now implemented in (rnrs base) by
doing an inexact sqrt and coercing the answer to exact.  This fails
badly for large integers:

  scheme@(guile-user)> (use-modules ((rnrs base) #:version (6)))
  scheme@(guile-user)> (exact-integer-sqrt (expt 10 50))
  $1 = 10000000000000000905969664
  $2 = -18119393280000000820781032088272896

This patch adds a proper implementation to guile core, which does this:

  scheme@(guile-user)> (exact-integer-sqrt (expt 10 50))
  $1 = 10000000000000000000000000
  $2 = 0

I'd like to push this to stable-2.0.  Any objections?

   Best,
    Mark


>From 0bd8c303c81b2fbb3ed9d9641e0d2cccc80c6336 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 6 Apr 2011 15:09:42 -0400
Subject: [PATCH] Fix the R6RS exact-integer-sqrt and import into core guile

* libguile/numbers.c (scm_exact_integer_sqrt): New C procedure to
  compute exact integer square root and remainder.
  (scm_i_exact_integer_sqrt): New Scheme procedure `exact-integer-sqrt'
  from the R6RS, imported into core guile.

* libguile/numbers.h: Add prototypes.

* module/rnrs/base.scm: Remove broken stub implementation, which would
  fail badly when applied to large integers.

* doc/ref/api-data.texi: Add documentation.

* doc/ref/r6rs.texi: Change documentation for `exact-integer-sqrt' to a
  stub that xrefs the core docs, as is done for other operations
  available in core.

* test-suite/tests/numbers.test: Add tests.

* NEWS: Add news entries.
---
 NEWS                          |   15 +++++++++
 doc/ref/api-data.texi         |   12 +++++++
 doc/ref/r6rs.texi             |    6 +---
 libguile/numbers.c            |   64 +++++++++++++++++++++++++++++++++++++++++
 libguile/numbers.h            |    2 +
 module/rnrs/base.scm          |    3 --
 test-suite/tests/numbers.test |   48 ++++++++++++++++++++++++++++++
 7 files changed, 142 insertions(+), 8 deletions(-)

diff --git a/NEWS b/NEWS
index b53386a..206153a 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,21 @@ See the end for copying conditions.
 Please send Guile bug reports to address@hidden
 
 
+Changes in 2.0.1 (since 2.0.0):
+
+* New procedures (see the manual for details)
+
+** exact-integer-sqrt, imported into core from (rnrs base)
+
+* Bugs fixed
+
+** exact-integer-sqrt now handles large integers correctly
+
+exact-integer-sqrt now works correctly when applied to very large
+integers (too large to be precisely represented by a C double).
+It has also been imported into core from (rnrs base).
+
+
 Changes in 2.0.0 (changes since the 1.8.x series):
 
 * New modules (see the manual for details)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 2b407ea..760039a 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -959,6 +959,18 @@ Return @var{n} raised to the integer exponent
 @end lisp
 @end deffn
 
address@hidden {Scheme Procedure} {} exact-integer-sqrt @var{k}
address@hidden {C Function} void scm_exact_integer_sqrt (SCM @var{k}, SCM 
address@hidden, SCM address@hidden)
+Return two exact non-negative integers @var{s} and @var{r}
+such that @address@hidden = @var{s}^2 + @var{r}} and
address@hidden@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.
+An error is raised if @var{k} is not an exact non-negative integer.
+
address@hidden
+(exact-integer-sqrt 10) @result{} 3 and 1
address@hidden lisp
address@hidden deftypefn
+
 @node Comparison
 @subsubsection Comparison Predicates
 @rnindex zero?
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index 8f89286..bc569ed 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -379,6 +379,7 @@ grouped below by the existing manual sections to which they 
correspond.
 @deffnx {Scheme Procedure} even? n
 @deffnx {Scheme Procedure} gcd x ...
 @deffnx {Scheme Procedure} lcm x ...
address@hidden {Scheme Procedure} exact-integer-sqrt k
 @xref{Integer Operations}, for documentation.
 @end deffn
 
@@ -525,11 +526,6 @@ This is a consequence of the requirement that
 @end lisp
 @end deffn
 
address@hidden {Scheme Procedure} exact-integer-sqrt k
-This procedure returns two nonnegative integer objects @code{s} and 
address@hidden such that k = s^2 + r and k < (s + 1)^2.
address@hidden deffn
-
 @deffn {Scheme Procedure} real-valued? obj
 @deffnx {Scheme Procedure} rational-valued? obj
 @deffnx {Scheme Procedure} integer-valued? obj
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 427e772..3c6990a 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -9555,6 +9555,70 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
+           (SCM k),
+           "Return two exact non-negative integers @var{s} and @var{r}\n"
+           "such that @address@hidden = @var{s}^2 + @var{r}} and\n"
+           "@address@hidden <= @var{k} < (@var{s} + 1)^2}.\n"
+           "An error is raised if @var{k} is not an exact non-negative 
integer.\n"
+           "\n"
+           "@lisp\n"
+           "(exact-integer-sqrt 10) @result{} 3 and 1\n"
+           "@end lisp")
+#define FUNC_NAME s_scm_i_exact_integer_sqrt
+{
+  SCM s, r;
+
+  scm_exact_integer_sqrt (k, &s, &r);
+  return scm_values (scm_list_2 (s, r));
+}
+#undef FUNC_NAME
+
+void
+scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
+{
+  if (SCM_LIKELY (SCM_I_INUMP (k)))
+    {
+      scm_t_inum kk = SCM_I_INUM (k);
+      scm_t_inum uu = kk;
+      scm_t_inum ss;
+
+      if (SCM_LIKELY (kk > 0))
+       {
+         do
+           {
+             ss = uu;
+             uu = (ss + kk/ss) / 2;
+           } while (uu < ss);
+         *sp = SCM_I_MAKINUM (ss);
+         *rp = SCM_I_MAKINUM (kk - ss*ss);
+       }
+      else if (SCM_LIKELY (kk == 0))
+       *sp = *rp = SCM_INUM0;
+      else
+       scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+                               "exact non-negative integer");
+    }
+  else if (SCM_LIKELY (SCM_BIGP (k)))
+    {
+      SCM s, r;
+
+      if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
+       scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+                               "exact non-negative integer");
+      s = scm_i_mkbig ();
+      r = scm_i_mkbig ();
+      mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
+      scm_remember_upto_here_1 (k);
+      *sp = scm_i_normbig (s);
+      *rp = scm_i_normbig (r);
+    }
+  else
+    scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+                           "exact non-negative integer");
+}
+
+
 SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
                       (SCM z),
        "Return the square root of @var{z}.  Of the two possible roots\n"
diff --git a/libguile/numbers.h b/libguile/numbers.h
index ab96981..d985830 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -289,6 +289,7 @@ SCM_API SCM scm_log (SCM z);
 SCM_API SCM scm_log10 (SCM z);
 SCM_API SCM scm_exp (SCM z);
 SCM_API SCM scm_sqrt (SCM z);
+SCM_API void scm_exact_integer_sqrt (SCM k, SCM *s, SCM *r);
 
 SCM_INTERNAL SCM scm_i_min (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_max (SCM x, SCM y, SCM rest);
@@ -296,6 +297,7 @@ SCM_INTERNAL SCM scm_i_sum (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_difference (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_product (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_divide (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_exact_integer_sqrt (SCM k);
 
 /* bignum internal functions */
 SCM_INTERNAL SCM scm_i_mkbig (void);
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 2f5a218..b9dddab 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -103,9 +103,6 @@
        (let ((sym (car syms)))
          (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
 
- (define (exact-integer-sqrt x)
-   (let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
-
  (define (real-valued? x)
    (and (complex? x)
         (zero? (imag-part x))))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 9584294..d2165b4 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -4542,6 +4542,54 @@
              (lognot #x-100000000000000000000000000000000))))
 
 ;;;
+;;; exact-integer-sqrt
+;;;
+
+(with-test-prefix "exact-integer-sqrt"
+  (define (non-negative-exact-integer? k)
+    (and (integer? k) (exact? k) (>= k 0)))
+
+  (define (test k)
+    (pass-if k (let-values (((s r) (exact-integer-sqrt k)))
+                 (and (non-negative-exact-integer? s)
+                      (non-negative-exact-integer? r)
+                      (= k (+ r (* s s)))
+                      (< k (* (1+ s) (1+ s)))))))
+
+  (define (test-wrong-type-arg k)
+    (pass-if-exception k exception:wrong-type-arg
+                       (let-values (((s r) (exact-integer-sqrt k)))
+                         #t)))
+
+  (pass-if (documented? exact-integer-sqrt))
+
+  (pass-if-exception "no args" exception:wrong-num-args
+    (exact-integer-sqrt))
+  (pass-if-exception "two args" exception:wrong-num-args
+    (exact-integer-sqrt 123 456))
+
+  (test 0)
+  (test 1)
+  (test 9)
+  (test 10)
+  (test fixnum-max)
+  (test (1+ fixnum-max))
+  (test (* fixnum-max fixnum-max))
+  (test (+ 1 (* fixnum-max fixnum-max)))
+  (test (expt 10 100))
+  (test (+ 3 (expt 10 100)))
+
+  (test-wrong-type-arg -1)
+  (test-wrong-type-arg 1/9)
+  (test-wrong-type-arg fixnum-min)
+  (test-wrong-type-arg (1- fixnum-min))
+  (test-wrong-type-arg 1.0)
+  (test-wrong-type-arg 1.5)
+  (test-wrong-type-arg "foo")
+  (test-wrong-type-arg 'foo))
+
+
+;;;
 ;;; sqrt
 ;;;
 
-- 
1.7.1