mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Mark H Weaver 2011-04-06 15:09:42 -04:00
parent b1e13fb530
commit 882c89636a
7 changed files with 142 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

15
NEWS
View file

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

12
doc/ref/api-data.texi
View file

@ -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?

6
doc/ref/r6rs.texi
View file

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

64
libguile/numbers.c
View file

@ -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"

2
libguile/numbers.h
View file

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

3
module/rnrs/base.scm
View file

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

48
test-suite/tests/numbers.test
View file

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