mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Gracefully handle huge shift counts in 'ash' and 'round-ash'.

Browse source 
Fixes <https://bugs.gnu.org/32644>.
Reported by Stefan Israelsson Tampe <stefan.itampe@gmail.com>.

The need for this arose because the type inferrer for 'ursh' sometimes
passes (- 1 (expt 2 64)) as the second argument to 'ash'.

* libguile/numbers.c (scm_ash, scm_round_ash): Gracefully handle several
cases where the shift count does not fit in a C 'long'.
* test-suite/tests/numbers.test: Add tests.
This commit is contained in:
Mark H Weaver 2018-10-14 03:18:35 -04:00
parent fe73fedab4
commit 011aec7e24
2 changed files with 53 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

34
libguile/numbers.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995-2016 Free Software Foundation, Inc.
/* Copyright (C) 1995-2016, 2018 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@ -5067,7 +5067,21 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
{
if (SCM_I_INUMP (n) || SCM_BIGP (n))
{
long bits_to_shift = scm_to_long (count);
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, 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)))
return SCM_INUM0;
else
scm_num_overflow ("ash");
if (bits_to_shift > 0)
return left_shift_exact_integer (n, bits_to_shift);
@ -5105,7 +5119,21 @@ SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
{
if (SCM_I_INUMP (n) || SCM_BIGP (n))
{
long bits_to_shift = scm_to_long (count);
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, 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)))
return SCM_INUM0;
else
scm_num_overflow ("round-ash");
if (bits_to_shift > 0)
return left_shift_exact_integer (n, bits_to_shift);

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

@ -1,6 +1,6 @@
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2003-2006, 2009-2013,
;;;; 2015 Free Software Foundation, Inc.
;;;; 2015, 2018 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -5421,7 +5421,27 @@
(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)))))
(list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min)))
;; Huge shift counts
(pass-if-equal "Huge left shift of 0"
0
(ash-variant 0 (expt 2 1000)))
(pass-if-equal "Huge right shift of 0"
0
(ash-variant 0 (- (expt 2 1000))))
(pass-if-equal "Huge right shift of positive integer"
0
(ash-variant 123 (- (expt 2 1000))))
(pass-if-equal "Huge right shift of negative integer"
-1
(ash-variant -123 (- (expt 2 1000))))
(pass-if-equal "Huge right shift of -1"
-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))