From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 14 Dec 2018 16:48:00 +0000 (+0000)
Subject: Avoid undefined behaviour with large right shifts.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~35^2~12
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a828e08e88c3e6553e6d2988ce44b0cd3d675093;p=mit-scheme.git

Avoid undefined behaviour with large right shifts.
---

diff --git a/src/microcode/artutl.c b/src/microcode/artutl.c
index d3d666a32..114bd0542 100644
--- a/src/microcode/artutl.c
+++ b/src/microcode/artutl.c
@@ -696,6 +696,8 @@ integer_shift_right (SCHEME_OBJECT n, unsigned long m)
   if (FIXNUM_P (n))
     {
       long n1 = (FIXNUM_TO_LONG (n));
+      if (m >= (CHAR_BIT * (sizeof (n1))))
+	return (LONG_TO_FIXNUM ((n1 < 0) ? (-1) : 0));
       return (LONG_TO_FIXNUM ((n1 < 0) ? (~ ((~n1) >> m)) : (n1 >> m)));
     }
   else
diff --git a/tests/runtime/test-integer-bits.scm b/tests/runtime/test-integer-bits.scm
index 531d08d9e..8f1991521 100644
--- a/tests/runtime/test-integer-bits.scm
+++ b/tests/runtime/test-integer-bits.scm
@@ -466,6 +466,4 @@ USA.
 
 (define-test 'SHIFT-RIGHT/TOO-MANY
   (lambda ()
-    (expect-failure
-     (lambda ()
-       (assert-= (shift-right (identity-procedure 1234567) 100) 0)))))
\ No newline at end of file
+    (assert-= (shift-right (identity-procedure 1234567) 100) 0)))
\ No newline at end of file