Define left/right shift by negative to mean the reverse shift

Coverity CIDs 104765 and 104766

While at it, also define shifting by more than wordsize in bits to be
zero, except that undef 'use integer' (use IVs) right overshift for
negative shiftees means -1.  (This is another corner where C leaves
things undefined.  A common behavior is "shift by modulo worbits",
so that e.g. 1 >> 64 == 1 >> (64 % 64) == 1 >> 0, but this is completely
accidental.)  (Coverity didn't flag this, harder to detect statically.)

Discussion thread at
http://www.nntp.perl.org/group/perl.perl5.porters/2015/06/msg228842.html

2 files changed, 98 insertions, 9 deletions

diff --git a/pp.c b/pp.c
index af2270e131..1e46dd1d20 100644
--- a/pp.c
+++ b/pp.c
@@ -1905,6 +1905,37 @@ PP(pp_subtract)
     }
 }
 
+#define IV_BITS (IVSIZE * 8)
+
+static UV S_uv_shift(UV uv, int shift, bool left)
+{
+   if (shift < 0) {
+       shift = -shift;
+       left = !left;
+   }
+   if (shift >= IV_BITS) {
+       return 0;
+   }
+   return left ? uv << shift : uv >> shift;
+}
+
+static IV S_iv_shift(IV iv, int shift, bool left)
+{
+   if (shift < 0) {
+       shift = -shift;
+       left = !left;
+   }
+   if (shift >= IV_BITS) {
+       return iv < 0 ? -1 : 0;
+   }
+   return left ? iv << shift : iv >> shift;
+}
+
+#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
+#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
+#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
+#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
+
 PP(pp_left_shift)
 {
     dSP; dATARGET; SV *svl, *svr;
@@ -1914,12 +1945,10 @@ PP(pp_left_shift)
     {
       const IV shift = SvIV_nomg(svr);
       if (PL_op->op_private & HINT_INTEGER) {
-	const IV i = SvIV_nomg(svl);
-	SETi(i << shift);
+          SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
       }
       else {
-	const UV u = SvUV_nomg(svl);
-	SETu(u << shift);
+	  SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
       }
       RETURN;
     }
@@ -1934,12 +1963,10 @@ PP(pp_right_shift)
     {
       const IV shift = SvIV_nomg(svr);
       if (PL_op->op_private & HINT_INTEGER) {
-	const IV i = SvIV_nomg(svl);
-	SETi(i >> shift);
+	  SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
       }
       else {
-	const UV u = SvUV_nomg(svl);
-	SETu(u >> shift);
+          SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
       }
       RETURN;
     }
diff --git a/t/op/bop.t b/t/op/bop.t
index 8acd3b2afd..a7adea8ca5 100644
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -15,7 +15,7 @@ BEGIN {
 # If you find tests are failing, please try adding names to tests to track
 # down where the failure is, and supply your new names as a patch.
 # (Just-in-time test naming)
-plan tests => 192 + (10*13*2) + 5;
+plan tests => 192 + (10*13*2) + 5 + 25;
 
 # numerics
 ok ((0xdead & 0xbeef) == 0x9ead);
@@ -586,3 +586,65 @@ $^A .= new version ~$_ for eval sprintf('"\\x%02x"', 0xff - ord("1")),
                            $::IS_EBCDIC ? v13 : v205, # 255 - ord('2')
                            eval sprintf('"\\x%02x"', 0xff - ord("3"));
 is $^A, "123", '~v0 clears vstring magic on retval';
+
+{
+    my $w = $Config::Config{ivsize} * 8;
+
+    fail("unexpected w $w") unless $w == 32 || $w == 64;
+
+    is(1 << 1, 2, "UV 1 left shift 1");
+    is(1 >> 1, 0, "UV 1 right shift 1");
+
+    is(0x7b << -4, 0x007, "UV left negative shift == right shift");
+    is(0x7b >> -4, 0x7b0, "UV right negative shift == left shift");
+
+    is(0x7b <<  0, 0x07b, "UV left  zero shift == identity");
+    is(0x7b >>  0, 0x07b, "UV right zero shift == identity");
+
+    is(0x0 << -1, 0x0, "zero left  negative shift == zero");
+    is(0x0 >> -1, 0x0, "zero right negative shift == zero");
+
+    cmp_ok(1 << $w - 1, '==', 2 ** ($w - 1), # not is() because NV stringify.
+       "UV left $w - 1 shift == 2 ** ($w - 1)");
+    is(1 << $w,     0, "UV left shift $w     == zero");
+    is(1 << $w + 1, 0, "UV left shift $w + 1 == zero");
+
+    is(1 >> $w - 1, 0, "UV right shift $w - 1 == zero");
+    is(1 >> $w,     0, "UV right shift $w     == zero");
+    is(1 >> $w + 1, 0, "UV right shift $w + 1 == zero");
+
+    # Negative shiftees get promoted to UVs before shifting.  This is
+    # not necessarily the ideal behavior, but that is what is happening.
+    if ($w == 64) {
+        no warnings "portable";
+        is(-1 << 1, 0xFFFF_FFFF_FFFF_FFFE, "neg UV (sic) left shift");
+        is(-1 >> 1, 0x7FFF_FFFF_FFFF_FFFF, "neg UV (sic) right right");
+    } elsif ($w == 32) {
+        no warnings "portable";
+        is(-1 << 1, 0xFFFF_FFFE, "neg left shift");
+        is(-1 >> 1, 0x7FFF_FFFF, "neg right right");
+    }
+
+    {
+        # 'use integer' means use IVs instead of UVs.
+        use integer;
+
+        is(1 << 1, 2, "IV 1 left shift 1");
+        is(1 >> 1, 0, "IV 1 right shift 1");
+
+        # Even for negative for IVs, left shift is multiplication.
+        is(-1 <<      1, -2, "IV -1 left shift       1 == -2");
+
+        # But right shift displays the stuckiness to -1.
+        is(-1 >>      1, -1, "IV -1 right shift      1 == -1");
+
+        # As for UVs, negative shifting means the reverse shift.
+        is(-1 <<     -1, -1, "IV -1 left shift      -1 == -1");
+        is(-1 >>     -1, -2, "IV -1 right shift     -1 == -2");
+
+        # Test also at and around wordsize, expect stuckiness to -1.
+        is(-1 >> $w - 1, -1, "IV -1 right shift $w - 1 == -1");
+        is(-1 >> $w,     -1, "IV -1 right shift $w     == -1");
+        is(-1 >> $w + 1, -1, "IV -1 right shift $w + 1 == -1");
+    }
+}