fix bug in ash opcode

* libguile/vm-i-scheme.c (ash): Fix embarrassing bug in (ash 1 32).
* test-suite/tests/bit-operations.test ("bitshifts on word boundaries"):
  Add tests.

diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index ecc77bd..df31810 100644 (file)
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -287,10 +287,23 @@ VM_DEFINE_FUNCTION (157, ash, "ash", 2)
   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
     {
       if (SCM_I_INUM (y) < 0)
+        /* Right shift, will be a fixnum. */
         RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
-      else if ((SCM_I_INUM (x) << SCM_I_INUM (y)) >> SCM_I_INUM (y)
-               == SCM_I_INUM (x))
-        RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) << SCM_I_INUM (y)));
+      else
+        /* Left shift. See comments in scm_ash. */
+        {
+          long nn, bits_to_shift;
+
+          nn = SCM_I_INUM (x);
+          bits_to_shift = SCM_I_INUM (y);
+
+          if (bits_to_shift < SCM_I_FIXNUM_BIT-1
+              && ((unsigned long)
+                  (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
+                  <= 1))
+            RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
+          /* fall through */
+        }
       /* fall through */
     }
   SYNC_REGISTER ();

diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test
index 0e9df7d..e7da571 100644 (file)
--- a/test-suite/tests/bit-operations.test
+++ b/test-suite/tests/bit-operations.test
@@ -1,5 +1,5 @@
 ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009, 2010 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
@@ -362,3 +362,7 @@
             (+ fixnum-bit fixnum-bit  1) (- (ash 1 (+ fixnum-bit 1)) 1))
       (list (- fixnum-min 1) (+ fixnum-bit  1)
             (+ fixnum-bit fixnum-bit  2) (- (ash 1 (+ fixnum-bit 1)) 1))))))
+
+(with-test-prefix "bitshifts on word boundaries"
+  (pass-if (= (ash 1 32) 4294967296))
+  (pass-if (= (ash 1 64) 18446744073709551616)))