diff --git a/libguile/numbers.c b/libguile/numbers.c index 3e035d226..afe5e558a 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 a0403a118..4e0bc82e5 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))