From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] round-ash, a rounding arithmetic shift operator Date: Tue, 15 Feb 2011 04:49:18 -0500 Message-ID: <87vd0l631d.fsf@netris.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1297763383 27047 80.91.229.12 (15 Feb 2011 09:49:43 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Tue, 15 Feb 2011 09:49:43 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Feb 15 10:49:39 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PpHXM-0007hB-MU for guile-devel@m.gmane.org; Tue, 15 Feb 2011 10:49:38 +0100 Original-Received: from localhost ([127.0.0.1]:50328 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PpHXL-0004IS-Vt for guile-devel@m.gmane.org; Tue, 15 Feb 2011 04:49:36 -0500 Original-Received: from [140.186.70.92] (port=46470 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PpHXH-0004IJ-Ee for guile-devel@gnu.org; Tue, 15 Feb 2011 04:49:33 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PpHXF-0007wb-1v for guile-devel@gnu.org; Tue, 15 Feb 2011 04:49:31 -0500 Original-Received: from world.peace.net ([216.204.32.208]:54923) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PpHXE-0007wE-Ku for guile-devel@gnu.org; Tue, 15 Feb 2011 04:49:28 -0500 Original-Received: from ip68-9-118-38.ri.ri.cox.net ([68.9.118.38] helo=freedomincluded) by world.peace.net with esmtpa (Exim 4.69) (envelope-from ) id 1PpHX6-00069l-Bx; Tue, 15 Feb 2011 04:49:20 -0500 Original-Received: from mhw by freedomincluded with local (Exim 4.69) (envelope-from ) id 1PpHX5-0001W6-2x; Tue, 15 Feb 2011 04:49:19 -0500 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 216.204.32.208 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:11631 Archived-At: --=-=-= The first patch is trivial, but there for the sake of correctness. The second patch adds round-ash, a rounding arithmetic shift operator. (round-ash n count) ==> (round (* n (expt 2 count))) but it's implemented much more efficiently than that, and requires that both n and count are exact integers. It cannot be implemented very efficiently in scheme, and I needed it to normalize floating-point significands using the default IEEE rounding mode. I think it probably has wider utility. It would be great to have it in 2.0. Any chance? Mark --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-Fix-comment-above-number-theoretic-division-tests.patch Content-Description: Fix comment above number-theoretic division tests >From 24504319b81aeabd5ac7967ed4f69428b8a5fbea Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 14 Feb 2011 18:18:52 -0500 Subject: [PATCH 1/2] Fix comment above number-theoretic division tests * test-suite/tests/numbers.test: Fix comment. --- test-suite/tests/numbers.test | 14 ++++++++++++++ 1 files changed, 14 insertions(+), 0 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 1f2ee03..9e9728f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4512,12 +4512,26 @@ ;;; +;;; Tests for number-theoretic division operators: +;;; ;;; euclidean/ ;;; euclidean-quotient ;;; euclidean-remainder +;;; floor/ +;;; floor-quotient +;;; floor-remainder +;;; ceiling/ +;;; ceiling-quotient +;;; ceiling-remainder +;;; truncate/ +;;; truncate-quotient +;;; truncate-remainder ;;; centered/ ;;; centered-quotient ;;; centered-remainder +;;; round/ +;;; round-quotient +;;; round-remainder ;;; (with-test-prefix "Number-theoretic division" -- 1.7.1 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0002-Add-round-ash-a-rounding-arithmetic-shift-operator.patch Content-Description: Add `round-ash', a rounding arithmetic shift operator >From d702946bcd1af2581e980387914b1086480564e6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 14 Feb 2011 23:25:13 -0500 Subject: [PATCH 2/2] Add `round-ash', a rounding arithmetic shift operator * libguile/numbers.c (left_shift_exact_integer, floor_right_shift_exact_integer, round_right_shift_exact_integer): New internal static functions to efficiently compute n * 2^count, floor(n / 2^count), and round(n / 2^count), respectively, for exact integer N and positive exact integer COUNT. Used to combine the implementations of `ash' and `round-ash' with minimal code duplication. (scm_ash): Reimplement in terms of left_shift_exact_integer and floor_right_shift_exact_integer. Note that this function efficiently computes floor(n * 2^count). (scm_round_ash): New procedure to efficiently compute round(n * 2^count), for exact integers N and COUNT. Implemented in terms of left_shift_exact_integer and round_right_shift_exact_integer. * libguile/numbers.h: Add prototype for scm_round_ash. Change the name of scm_ash's second formal parameter from `cnt' to `count'. * test-suite/tests/numbers.test (round-ash, ash): Add new unified testing framework for `ash' and `round-ash'. Previously, the tests for `ash' were not very comprehensive; for example, they did not include a single test where the number to be shifted was a bignum. * doc/ref/api-data.texi (Bitwise Operations): Add documentation for `round-ash'. Improve documentation for `ash'. * NEWS: Add NEWS entry. --- NEWS | 12 ++ doc/ref/api-data.texi | 44 ++++++-- libguile/numbers.c | 230 ++++++++++++++++++++++++++++------------- libguile/numbers.h | 3 +- test-suite/tests/numbers.test | 114 +++++++++------------ 5 files changed, 251 insertions(+), 152 deletions(-) diff --git a/NEWS b/NEWS index 6bebbf6..e473644 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,18 @@ instead. `define-once' is like Lisp's `defvar': it creates a toplevel binding, but only if one does not exist already. +** New procedure: `round-ash', a rounding arithmetic shift operator + +round-ash is similar to ash, the arithmetic shift operator, except +that round-ash rounds to the nearest integer, with ties going to the +nearest even integer, whereas ash rounds toward negative infinity. + +Note that: (round-ash N COUNT) = round(N * 2^COUNT), +compared with: (ash N COUNT) = floor(N * 2^COUNT), + +except that round-ash and ash are computed more efficiently, and +require that N and COUNT be exact integers. + ** Added four new sets of fast quotient and remainder operators Added four new sets of fast quotient and remainder operators with diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 5bef926..8f7c35a 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1659,19 +1659,16 @@ starts from 0 for the least significant bit. @end lisp @end deffn -@deffn {Scheme Procedure} ash n cnt -@deffnx {C Function} scm_ash (n, cnt) -Return @var{n} shifted left by @var{cnt} bits, or shifted right if -@var{cnt} is negative. This is an ``arithmetic'' shift. - -This is effectively a multiplication by @m{2^{cnt}, 2^@var{cnt}}, and -when @var{cnt} is negative it's a division, rounded towards negative -infinity. (Note that this is not the same rounding as @code{quotient} -does.) +@deffn {Scheme Procedure} ash n count +@deffnx {C Function} scm_ash (n, count) +Return @math{floor(@var{n} * 2^@var{count})}, but computed +more efficiently. @var{n} and @var{count} must be exact +integers. -With @var{n} viewed as an infinite precision twos complement, -@code{ash} means a left shift introducing zero bits, or a right shift -dropping bits. +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{ash} means a left shift introducing zero bits +when @var{count} is positive, or a right shift dropping bits +when @var{count} is negative. This is an ``arithmetic'' shift. @lisp (number->string (ash #b1 3) 2) @result{} "1000" @@ -1682,6 +1679,29 @@ dropping bits. @end lisp @end deffn +@deffn {Scheme Procedure} round-ash n count +@deffnx {C Function} scm_round_ash (n, count) +Return @math{round(@var{n} * 2^@var{count})}, but computed +more efficiently. @var{n} and @var{count} must be exact +integers. + +With @var{n} viewed as an infinite-precision twos-complement +integer, @code{round-ash} means a left shift introducing zero +bits when @var{count} is positive, or a right shift rounding +to the nearest integer (with ties going to the nearest even +integer) when @var{count} is negative. This is a rounded +``arithmetic'' shift. + +@lisp +(number->string (round-ash #b1 3) 2) @result{} \"1000\" +(number->string (round-ash #b1010 -1) 2) @result{} \"101\" +(number->string (round-ash #b1010 -2) 2) @result{} \"10\" +(number->string (round-ash #b1011 -2) 2) @result{} \"11\" +(number->string (round-ash #b1101 -2) 2) @result{} \"11\" +(number->string (round-ash #b1110 -2) 2) @result{} \"100\" +@end lisp +@end deffn + @deffn {Scheme Procedure} logcount n @deffnx {C Function} scm_logcount (n) Return the number of bits in integer @var{n}. If @var{n} is diff --git a/libguile/numbers.c b/libguile/numbers.c index 59d8e74..a87b27b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4682,19 +4682,122 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0, } #undef FUNC_NAME +/* n must be an exact integer, and count > 0. + Returns n * 2^count. */ +static SCM +left_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will always + overflow a non-zero fixnum. For smaller shifts we check the + bits going into positions above SCM_I_FIXNUM_BIT-1. If they're + all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. + Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - + count)". */ + + if (nn == 0) + return n; + else if (count < SCM_I_FIXNUM_BIT-1 && + ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1) + <= 1)) + { + return SCM_I_MAKINUM (nn << count); + } + else + { + SCM result = scm_i_inum2big (nn); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), + count); + return result; + } + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return result; + } + else + scm_syserror ("left_shift_exact_integer"); +} + +/* n must be an exact integer, and count > 0. + Returns floor(n / 2^count). */ +static SCM +floor_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + + if (count >= SCM_I_FIXNUM_BIT) + return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1)); + else + return SCM_I_MAKINUM (SCM_SRS (nn, count)); + } + else if (SCM_BIGP (n)) + { + SCM result = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), + count); + scm_remember_upto_here_1 (n); + return scm_i_normbig (result); + } + else + scm_syserror ("floor_right_shift_exact_integer"); +} + +/* n must be an exact integer, and count > 0. + Returns round(n / 2^count). */ +static SCM +round_right_shift_exact_integer (SCM n, long count) +{ + if (SCM_I_INUMP (n)) + { + scm_t_inum nn = SCM_I_INUM (n); + scm_t_inum qq = SCM_SRS (nn, count); + + if (count >= SCM_I_FIXNUM_BIT) + return SCM_INUM0; + else if (0 == (nn & (1L << (count-1)))) + return SCM_I_MAKINUM (qq); /* round down */ + else if (nn & ((1L << (count-1)) - 1)) + return SCM_I_MAKINUM (qq + 1); /* round up */ + else + return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */ + } + else if (SCM_BIGP (n)) + { + SCM q = scm_i_mkbig (); + mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count); + if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1)) + { + if ((mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1) || + (mpz_odd_p (SCM_I_BIG_MPZ (q)))) + mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1); + } + scm_remember_upto_here_1 (n); + return scm_i_normbig (q); + } + else + scm_syserror ("round_right_shift_exact_integer"); +} + SCM_DEFINE (scm_ash, "ash", 2, 0, 0, - (SCM n, SCM cnt), - "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n" - "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n" - "\n" - "This is effectively a multiplication by 2^@var{cnt}, and when\n" - "@var{cnt} is negative it's a division, rounded towards negative\n" - "infinity. (Note that this is not the same rounding as\n" - "@code{quotient} does.)\n" + (SCM n, SCM count), + "Return @math{floor(@var{n} * 2^@var{count})}, but computed\n" + "more efficiently. @var{n} and @var{count} must be exact\n" + "integers.\n" "\n" - "With @var{n} viewed as an infinite precision twos complement,\n" - "@code{ash} means a left shift introducing zero bits, or a right\n" - "shift dropping bits.\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{ash} means a left shift introducing zero bits\n" + "when @var{count} is positive, or a right shift dropping bits\n" + "when @var{count} is negative. This is an ``arithmetic'' shift.\n" "\n" "@lisp\n" "(number->string (ash #b1 3) 2) @result{} \"1000\"\n" @@ -4705,79 +4808,58 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ash { - long bits_to_shift; - bits_to_shift = scm_to_long (cnt); - - if (SCM_I_INUMP (n)) + if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - scm_t_inum nn = SCM_I_INUM (n); + long bits_to_shift = scm_to_long (count); if (bits_to_shift > 0) - { - /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always - overflow a non-zero fixnum. For smaller shifts we check the - bits going into positions above SCM_I_FIXNUM_BIT-1. If they're - all 0s for nn>=0, or all 1s for nn<0 then there's no overflow. - Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - - bits_to_shift)". */ - - if (nn == 0) - return n; - - if (bits_to_shift < SCM_I_FIXNUM_BIT-1 - && ((scm_t_bits) - (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) - <= 1)) - { - return SCM_I_MAKINUM (nn << bits_to_shift); - } - else - { - SCM result = scm_i_inum2big (nn); - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), - bits_to_shift); - return result; - } - } + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return floor_right_shift_exact_integer (n, -bits_to_shift); else - { - bits_to_shift = -bits_to_shift; - if (bits_to_shift >= SCM_LONG_BIT) - return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1)); - else - return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift)); - } - + return n; } - else if (SCM_BIGP (n)) - { - SCM result; + else + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); +} +#undef FUNC_NAME - if (bits_to_shift == 0) - return n; +SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0, + (SCM n, SCM count), + "Return @math{round(@var{n} * 2^@var{count})}, but computed\n" + "more efficiently. @var{n} and @var{count} must be exact\n" + "integers.\n" + "\n" + "With @var{n} viewed as an infinite-precision twos-complement\n" + "integer, @code{round-ash} means a left shift introducing zero\n" + "bits when @var{count} is positive, or a right shift rounding\n" + "to the nearest integer (with ties going to the nearest even\n" + "integer) when @var{count} is negative. This is a rounded\n" + "``arithmetic'' shift.\n" + "\n" + "@lisp\n" + "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n" + "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n" + "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n" + "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n" + "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n" + "@end lisp") +#define FUNC_NAME s_scm_round_ash +{ + if (SCM_I_INUMP (n) || SCM_BIGP (n)) + { + long bits_to_shift = scm_to_long (count); - result = scm_i_mkbig (); - if (bits_to_shift >= 0) - { - mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - bits_to_shift); - return result; - } + if (bits_to_shift > 0) + return left_shift_exact_integer (n, bits_to_shift); + else if (SCM_LIKELY (bits_to_shift < 0)) + return round_right_shift_exact_integer (n, -bits_to_shift); else - { - /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so - we have to allocate a bignum even if the result is going to be a - fixnum. */ - mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), - -bits_to_shift); - return scm_i_normbig (result); - } - + return n; } else - { - SCM_WRONG_TYPE_ARG (SCM_ARG1, n); - } + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); } #undef FUNC_NAME diff --git a/libguile/numbers.h b/libguile/numbers.h index ab96981..16d351e 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -204,7 +204,8 @@ SCM_API SCM scm_logbit_p (SCM n1, SCM n2); SCM_API SCM scm_lognot (SCM n); SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m); SCM_API SCM scm_integer_expt (SCM z1, SCM z2); -SCM_API SCM scm_ash (SCM n, SCM cnt); +SCM_API SCM scm_ash (SCM n, SCM count); +SCM_API SCM scm_round_ash (SCM n, SCM count); SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end); SCM_API SCM scm_logcount (SCM n); SCM_API SCM scm_integer_length (SCM n); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 9e9728f..7a75780 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -201,71 +201,6 @@ (eqv? -2305843009213693953 (1- -2305843009213693952)))) ;;; -;;; ash -;;; - -(with-test-prefix "ash" - - (pass-if "documented?" - (documented? ash)) - - (pass-if (eqv? 0 (ash 0 0))) - (pass-if (eqv? 0 (ash 0 1))) - (pass-if (eqv? 0 (ash 0 1000))) - (pass-if (eqv? 0 (ash 0 -1))) - (pass-if (eqv? 0 (ash 0 -1000))) - - (pass-if (eqv? 1 (ash 1 0))) - (pass-if (eqv? 2 (ash 1 1))) - (pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128))) - (pass-if (eqv? 0 (ash 1 -1))) - (pass-if (eqv? 0 (ash 1 -1000))) - - (pass-if (eqv? -1 (ash -1 0))) - (pass-if (eqv? -2 (ash -1 1))) - (pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128))) - (pass-if (eqv? -1 (ash -1 -1))) - (pass-if (eqv? -1 (ash -1 -1000))) - - (pass-if (eqv? -3 (ash -3 0))) - (pass-if (eqv? -6 (ash -3 1))) - (pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128))) - (pass-if (eqv? -2 (ash -3 -1))) - (pass-if (eqv? -1 (ash -3 -1000))) - - (pass-if (eqv? -6 (ash -23 -2))) - - (pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0))) - (pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1))) - (pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2))) - (pass-if - (eqv? (* most-positive-fixnum 340282366920938463463374607431768211456) - (ash most-positive-fixnum 128))) - (pass-if (eqv? (quotient most-positive-fixnum 2) - (ash most-positive-fixnum -1))) - (pass-if (eqv? 0 (ash most-positive-fixnum -1000))) - - (let ((mpf4 (quotient most-positive-fixnum 4))) - (pass-if (eqv? (* 2 mpf4) (ash mpf4 1))) - (pass-if (eqv? (* 4 mpf4) (ash mpf4 2))) - (pass-if (eqv? (* 8 mpf4) (ash mpf4 3)))) - - (pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0))) - (pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1))) - (pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2))) - (pass-if - (eqv? (* most-negative-fixnum 340282366920938463463374607431768211456) - (ash most-negative-fixnum 128))) - (pass-if (eqv? (quotient-floor most-negative-fixnum 2) - (ash most-negative-fixnum -1))) - (pass-if (eqv? -1 (ash most-negative-fixnum -1000))) - - (let ((mnf4 (quotient-floor most-negative-fixnum 4))) - (pass-if (eqv? (* 2 mnf4) (ash mnf4 1))) - (pass-if (eqv? (* 4 mnf4) (ash mnf4 2))) - (pass-if (eqv? (* 8 mnf4) (ash mnf4 3))))) - -;;; ;;; exact? ;;; @@ -4770,3 +4705,52 @@ round-quotient round-remainder valid-round-answer?))) + +;;; +;;; ash +;;; round-ash +;;; + +(let () + (define (test-ash-variant name ash-variant round-variant) + (with-test-prefix name + (define (test n count) + (pass-if (list n count) + (eqv? (ash-variant n count) + (round-variant (* n (expt 2 count)))))) + + (pass-if "documented?" + (documented? ash-variant)) + + (for-each (lambda (n) + (for-each (lambda (count) (test n count)) + '(-1000 -3 -2 -1 0 1 2 3 1000))) + (list 0 1 3 23 -1 -3 -23 + fixnum-max + (1+ fixnum-max) + (1- fixnum-max) + (* fixnum-max 4) + (quotient fixnum-max 4) + fixnum-min + (1+ fixnum-min) + (1- fixnum-min) + (* fixnum-min 4) + (quotient fixnum-min 4))) + + (do ((count -2 (1- count)) + (vals '(1 3 5 7 9 11) + (map (lambda (n) (* 2 n)) vals))) + ((> (car vals) (* 2 fixnum-max)) 'done) + (for-each (lambda (n) + (test n count) + (test (- n) count)) + vals)) + + ;; Test rounding + (for-each (lambda (base) + (for-each (lambda (offset) (test (+ base offset) -3)) + '(#b11001 #b11100 #b11101 #b10001 #b10100 #b10101))) + (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min))))) + + (test-ash-variant 'ash ash floor) + (test-ash-variant 'round-ash round-ash round)) -- 1.7.1 --=-=-=--