[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Gracefully handle huge shift counts in 'ash' and
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 01/01: Gracefully handle huge shift counts in 'ash' and 'round-ash'. |
Date: |
Sun, 14 Oct 2018 03:29:10 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit 011aec7e240ef987931548d90c53e6692c85d01c
Author: Mark H Weaver <address@hidden>
Date: Sun Oct 14 03:18:35 2018 -0400
Gracefully handle huge shift counts in 'ash' and 'round-ash'.
Fixes <https://bugs.gnu.org/32644>.
Reported by Stefan Israelsson Tampe <address@hidden>.
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.
---
libguile/numbers.c | 34 +++++++++++++++++++++++++++++++---
test-suite/tests/numbers.test | 24 ++++++++++++++++++++++--
2 files changed, 53 insertions(+), 5 deletions(-)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 3e035d2..afe5e55 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -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);
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index a0403a1..4e0bc82 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -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))