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

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.

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

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