diff options
author | Daniel Llorens <lloda@sarc.name> | 2021-11-04 14:52:21 +0100 |
---|---|---|
committer | Daniel Llorens <lloda@sarc.name> | 2021-11-05 10:26:43 +0100 |
commit | bf9d30f3c3fd03cb37d604f1927e9ce5c699338b (patch) | |
tree | a69d13af304256fd260ee706dbd666d090ab647b | |
parent | ffb33fd66bba30f6a3e554be644fcaf269d39f05 (diff) | |
download | guile-bf9d30f3c3fd03cb37d604f1927e9ce5c699338b.tar.gz |
Limit the range of ash, round-ash count argument to INT32
This avoids gmp aborting e.g. with (ash 1 (expt 2 37)). The new limit is
such that (ash 1 (expt 30)) is accepted but (ash 1 (expt 31)) throws.
Fixes https://bugs.gnu.org/48150
* libguile/numbers.c (ash, round-ash): As stated.
* test-suite/tests/numbers.test: Test a case known to make gmp abort before.
-rw-r--r-- | libguile/numbers.c | 96 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 5 |
2 files changed, 45 insertions, 56 deletions
diff --git a/libguile/numbers.c b/libguile/numbers.c index 18bd22dbb..bb19a1575 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5110,35 +5110,28 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_ash { - if (SCM_I_INUMP (n) || SCM_BIGP (n)) - { - long bits_to_shift; - - if (SCM_I_INUMP (count)) /* fast path, not strictly needed */ - bits_to_shift = SCM_I_INUM (count); - else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX)) - /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be - negated without overflowing. */ - 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))) - return SCM_INUM0; - else - scm_num_overflow ("ash"); - - if (bits_to_shift > 0) - 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 - return n; - } - else + if (!SCM_I_INUMP (n) && !SCM_BIGP (n)) SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + + 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))) + return SCM_INUM0; + else if (scm_is_signed_integer (count, INT32_MIN + 1, INT32_MAX)) { + /* We exclude MIN to ensure that 'bits_to_shift' can be + negated without overflowing, if INT32_MIN happens to be LONG_MIN */ + long bits_to_shift = scm_to_long (count); + if (bits_to_shift > 0) + 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 + return n; + } else + scm_num_overflow ("ash"); } #undef FUNC_NAME @@ -5164,34 +5157,27 @@ SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_round_ash { - if (SCM_I_INUMP (n) || SCM_BIGP (n)) - { - long bits_to_shift; - - if (SCM_I_INUMP (count)) /* fast path, not strictly needed */ - bits_to_shift = SCM_I_INUM (count); - else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX)) - /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be - negated without overflowing. */ - bits_to_shift = scm_to_long (count); - 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"); - - 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 - return n; - } - else + if (!SCM_I_INUMP (n) && !SCM_BIGP (n)) SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + + 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 if (scm_is_signed_integer (count, INT32_MIN + 1, INT32_MAX)) { + /* We exclude MIN to ensure that 'bits_to_shift' can be + negated without overflowing, if INT32_MIN happens to be LONG_MIN */ + long bits_to_shift = scm_to_long (count); + 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 + return n; + } else + scm_num_overflow ("round-ash"); } #undef FUNC_NAME diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 8f644874d..51263f0ac 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -5466,7 +5466,10 @@ (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))))) + (ash-variant 123 (expt 2 1000))) + (pass-if-exception "Shift large enough to cause gmp abort in 3.0.7" + exception:numerical-overflow + (ash-variant 1 (expt 2 37))))) (test-ash-variant 'ash ash floor #f) (test-ash-variant 'round-ash round-ash round #t) |