mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Limit the range of ash, round-ash count argument to INT32

Browse source 
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.
This commit is contained in:
Daniel Llorens 2021-11-04 14:52:21 +01:00
parent ffb33fd66b
commit bf9d30f3c3
2 changed files with 45 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

50
libguile/numbers.c
View file

@ -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 (n) && !SCM_BIGP (n))
SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
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),
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");
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_WRONG_TYPE_ARG (SCM_ARG1, 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 (n) && !SCM_BIGP (n))
SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
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),
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");
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_WRONG_TYPE_ARG (SCM_ARG1, n);
} else
scm_num_overflow ("round-ash");
}
#undef FUNC_NAME

5
test-suite/tests/numbers.test
View file

@ -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)