diff options
author | Mark H Weaver <mhw@netris.org> | 2011-04-06 15:09:42 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2011-04-09 16:11:49 -0400 |
commit | 882c89636a2a4afa26cff17c7cdbc1d8c1cb2745 (patch) | |
tree | 7e713f3a5fc0521fca326a160794021d05d315ad | |
parent | b1e13fb530e0f80334862e440860c054b61dbdd0 (diff) | |
download | guile-882c89636a2a4afa26cff17c7cdbc1d8c1cb2745.tar.gz |
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.
-rw-r--r-- | NEWS | 15 | ||||
-rw-r--r-- | doc/ref/api-data.texi | 12 | ||||
-rw-r--r-- | doc/ref/r6rs.texi | 6 | ||||
-rw-r--r-- | libguile/numbers.c | 64 | ||||
-rw-r--r-- | libguile/numbers.h | 2 | ||||
-rw-r--r-- | module/rnrs/base.scm | 3 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 48 |
7 files changed, 142 insertions, 8 deletions
@@ -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) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 2b407ea99..760039a32 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 +@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? diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index 8f8928659..bc569ed69 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 ... +@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 diff --git a/libguile/numbers.c b/libguile/numbers.c index b4f224240..74753812b 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 @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" diff --git a/libguile/numbers.h b/libguile/numbers.h index ab96981c6..d98583039 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 2f5a218de..b9dddab0b 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 d94b6a14e..b1f3d8bc0 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4547,6 +4547,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 ;;; |