summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2018-10-14 05:24:14 -0400
committerAndy Wingo <wingo@pobox.com>2019-05-23 16:09:41 +0200
commite6100f64bbab1b2bac085c0ea5250163197df4a9 (patch)
tree8308a2db2fb87ea9f865e1ba332b8c20fb9a3589
parente4c5f73f94b276c7d62463907365cc1277a1c450 (diff)
downloadguile-e6100f64bbab1b2bac085c0ea5250163197df4a9.tar.gz
Fix 'round-ash' of negative integers by huge right shift counts.
This is a followup to commit 011aec7e240ef987931548d90c53e6692c85d01c. When rounding, right shifting a negative integer by a huge shift count results in 0, not -1. * libguile/numbers.c: Add top-level 'verify' to ensure that the assumptions in 'scm_ash' and 'scm_round_ash' are valid. (scm_round_ash): In the case that handles huge right shifts, require that the shift count _exceeds_ the integer length, and return 0 instead of -1. * test-suite/tests/numbers.test: Adjust tests accordingly.
-rw-r--r--libguile/numbers.c16
-rw-r--r--test-suite/tests/numbers.test10
2 files changed, 15 insertions, 11 deletions
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 67295f95c..21dcdb62c 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -91,6 +91,11 @@ verify (FLT_RADIX == 2);
/* Make sure that scm_t_inum fits within a SCM value. */
verify (sizeof (scm_t_inum) <= sizeof (scm_t_bits));
+/* Several functions below assume that fixnums fit within a long, and
+ furthermore that there is some headroom to spare for other operations
+ without overflowing. */
+verify (SCM_I_FIXNUM_BIT <= SCM_LONG_BIT - 2);
+
#define scm_from_inum(x) (scm_from_signed_integer (x))
/* Test an inum to see if it can be converted to a double without loss
@@ -5127,12 +5132,11 @@ SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
bits_to_shift = SCM_I_INUM (count);
else if (scm_is_signed_integer (count, LONG_MIN, LONG_MAX))
bits_to_shift = scm_to_long (count);
- else if (scm_is_false (scm_positive_p (scm_sum (scm_integer_length (n),
- count))))
- /* Huge right shift that eliminates all but the sign bit */
- return scm_is_false (scm_negative_p (n))
- ? SCM_INUM0 : SCM_I_MAKINUM (-1);
- else if (scm_is_true (scm_zero_p (n)))
+ else if (scm_is_true (scm_negative_p (scm_sum (scm_integer_length (n),
+ count)))
+ || scm_is_true (scm_zero_p (n)))
+ /* If N is zero, or the right shift count exceeds the integer
+ length, the result is zero. */
return SCM_INUM0;
else
scm_num_overflow ("round-ash");
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 4e0bc82e5..8cecb06ad 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -5377,7 +5377,7 @@
;;;
(let ()
- (define (test-ash-variant name ash-variant round-variant)
+ (define (test-ash-variant name ash-variant round-variant rounded?)
(with-test-prefix name
(define (test n count)
(pass-if (list n count)
@@ -5434,17 +5434,17 @@
0
(ash-variant 123 (- (expt 2 1000))))
(pass-if-equal "Huge right shift of negative integer"
- -1
+ (if rounded? 0 -1)
(ash-variant -123 (- (expt 2 1000))))
(pass-if-equal "Huge right shift of -1"
- -1
+ (if rounded? 0 -1)
(ash-variant -1 (- (expt 2 1000))))
(pass-if-exception "Huge left shift of non-zero => numerical overflow"
exception:numerical-overflow
(ash-variant 123 (expt 2 1000)))))
- (test-ash-variant 'ash ash floor)
- (test-ash-variant 'round-ash round-ash round))
+ (test-ash-variant 'ash ash floor #f)
+ (test-ash-variant 'round-ash round-ash round #t))
;;;
;;; regressions