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

@@ -5,6 +5,21 @@ See the end for copying conditions.
 Please send Guile bug reports to bug-guile@gnu.org.
 
 
+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)

doc/ref/api-data.texi

@@ -959,6 +959,18 @@ Return @var{n} raised to the integer exponent
 @end lisp
 @end deffn
 
+@deftypefn {Scheme Procedure} {} exact-integer-sqrt @var{k}
+@deftypefnx {C Function} void scm_exact_integer_sqrt (SCM @var{k}, SCM *@var{s}, SCM *@var{r})
+Return two exact non-negative integers @var{s} and @var{r}
+such that @math{@var{k} = @var{s}^2 + @var{r}} and
+@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.
+An error is raised if @var{k} is not an exact non-negative integer.
+
+@lisp
+(exact-integer-sqrt 10) @result{} 3 and 1
+@end lisp
+@end deftypefn
+
 @node Comparison
 @subsubsection Comparison Predicates
 @rnindex zero?

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 ...
+@deffnx {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
 
-@deffn {Scheme Procedure} exact-integer-sqrt k
-This procedure returns two nonnegative integer objects @code{s} and 
-@code{r} such that k = s^2 + r and k < (s + 1)^2.
-@end deffn
-
 @deffn {Scheme Procedure} real-valued? obj
 @deffnx {Scheme Procedure} rational-valued? obj
 @deffnx {Scheme Procedure} integer-valued? obj

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 @math{@var{k} = @var{s}^2 + @var{r}} and\n"
+	    "@math{@var{s}^2 <= @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"

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);

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))))

test-suite/tests/numbers.test

@@ -4546,6 +4546,54 @@
   (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
 	      (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
 ;;;