diff options
author | Mark H Weaver <mhw@netris.org> | 2018-10-14 05:24:14 -0400 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-05-23 16:09:41 +0200 |
commit | e6100f64bbab1b2bac085c0ea5250163197df4a9 (patch) | |
tree | 8308a2db2fb87ea9f865e1ba332b8c20fb9a3589 | |
parent | e4c5f73f94b276c7d62463907365cc1277a1c450 (diff) | |
download | guile-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.c | 16 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 10 |
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 |