a68: fix bit-shift standard operators [PR algol68/123959]

In Standard Algol 68:

- ABS (b) < bits_width results in the expected result.
- ABS (b) = bits_width results in all bits set to zero.
- ABS (b) > bits_width is undefined.

In GNU algol 68:

- ABS (b) < bits_width results in the expected result.
- ABS (b) >= bits_width results in all bits set to zero.

Our behavior is:

1. Conformant and backwards compatible.

2. Matches well with the similar extension of skip of integral, bits,
   real, etc values to always yield zeroes.

3. Intuitive.

This patch fixes the lowering of the standard operators SHR and SHL
accordingly, including an update for the manual and a few tests.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
gcc/algol68/ChangeLog

	PR algol68/123959
	* a68.h: Expand prototype of a68_bits_shift to get a node argument
	for location purposes.
	* a68-low-bits.cc (a68_bits_shift): Implement RR compatible
	semantics.
	* a68-low-prelude.cc (a68_lower_shl3): Fix call to a68_bit_shift.
	(a68_lower_shr3): Likewise.
	* ga68.texi (Bits operators): Fix documentation of SHR and SHL.

gcc/testsuite/ChangeLog

	PR algol68/123959
	* algol68/execute/bits-shift-1.a68: New test.
	* algol68/execute/bits-shift-2.a68: Likewise.
	* algol68/execute/bits-shift-3.a68: Likewise.

diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc
index cfe84fbff33c5bb7ba5dd1e9f570c261c184f6e6..7ec058ee1b0632b0435092aec0657fe83723709d 100644 (file)
--- a/gcc/algol68/a68-low-bits.cc
+++ b/gcc/algol68/a68-low-bits.cc
@@ -258,25 +258,37 @@ a68_bits_subset (tree bits1, tree bits2)
                      bits2);
 }
 
-/* Rotate the bits in BITS SHIFT bits to the left if SHIFT is positive, or ABS
-   (SHIFT) bits to the right if SHIFT is negative.
+/* Rotate the bits in BITS according to the value of SHIFT:
 
-   A run-time error is raised if the count overflows the BITS value.  */
+   - If ABS(SHIFT) >= bits_width, the result is all bits clear.
+   - If SHIFT is positive, BITS gets shifted SHIFT bits to the right.
+   - If SHIFT is negative, BITS gets shifted ABS(SHIFT) bits to the left.
+*/
 
 tree
-a68_bits_shift (tree shift, tree bits)
+a68_bits_shift (NODE_T *p, tree shift, tree bits)
 {
   shift = save_expr (shift);
   bits = save_expr (bits);
-  return fold_build3 (COND_EXPR,
-                     TREE_TYPE (bits),
-                     fold_build2 (GE_EXPR, TREE_TYPE (shift),
-                                  shift, build_int_cst (TREE_TYPE (shift), 0)),
-                     fold_build2 (LSHIFT_EXPR, TREE_TYPE (bits),
-                                  bits, shift),
-                     fold_build2 (RSHIFT_EXPR, TREE_TYPE (bits),
-                                  bits,
-                                  fold_build1 (ABS_EXPR, TREE_TYPE (shift), shift)));
+
+  tree shift_type = TREE_TYPE (shift);
+  tree bits_type = TREE_TYPE (bits);
+  tree abs_shift = save_expr (fold_build1 (ABS_EXPR, TREE_TYPE (shift), shift));
+
+  tree shifted_right = fold_build2 (RSHIFT_EXPR, bits_type, bits, abs_shift);
+  tree shifted_left = fold_build2 (LSHIFT_EXPR, bits_type, bits, abs_shift);
+
+  tree shifted_bits = fold_build3 (COND_EXPR, TREE_TYPE (bits),
+                                  fold_build2 (GE_EXPR, shift_type,
+                                               shift, build_zero_cst (shift_type)),
+                                  shifted_right, shifted_left);
+
+  return fold_build3_loc (a68_get_node_location (p),
+                         COND_EXPR,
+                         TREE_TYPE (bits),
+                         fold_build2 (LT_EXPR, TREE_TYPE (abs_shift),
+                                      abs_shift, a68_bits_width (bits_type)),
+                         shifted_bits, build_zero_cst (bits_type));
 }
 
 /* Given two bits values, build an expression that calculates whether A = B.  */

diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
index 9bc03cff48f2f09556edac284484d02936e46424..44abd5fe74d353ac536bee8eb9bdfa17ded24cd8 100644 (file)
--- a/gcc/algol68/a68-low-prelude.cc
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -1085,7 +1085,9 @@ a68_lower_shl3 (NODE_T *p, LOW_CTX_T ctx)
 {
   tree bits = a68_lower_tree (SUB (p), ctx);
   tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
-  return a68_bits_shift (shift, bits);
+  return a68_bits_shift (p,
+                        fold_build1 (NEGATE_EXPR, TREE_TYPE (shift), shift),
+                        bits);
 }
 
 tree
@@ -1093,9 +1095,7 @@ a68_lower_shr3 (NODE_T *p, LOW_CTX_T ctx)
 {
   tree bits = a68_lower_tree (SUB (p), ctx);
   tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
-  return a68_bits_shift (fold_build1 (NEGATE_EXPR,
-                                     TREE_TYPE (shift), shift),
-                        bits);
+  return a68_bits_shift (p, shift, bits);
 }
 
 tree

diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 3e3442f668ab5d21b7b05d6a2b1fd72d05c9d965..9dcb14600a2d3c168ed554dc5306a76161f1c651 100644 (file)
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -534,7 +534,7 @@ tree a68_bits_ior (tree bits1, tree bits2);
 tree a68_bits_xor (tree bits1, tree bits2);
 tree a68_bits_elem (NODE_T *p, tree pos, tree bits);
 tree a68_bits_subset (tree bits1, tree bits2);
-tree a68_bits_shift (tree shift, tree bits);
+tree a68_bits_shift (NODE_T *p, tree shift, tree bits);
 tree a68_bits_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
 tree a68_bits_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
 tree a68_bits_set (MOID_T *m, tree bits, tree numbit, location_t loc = UNKNOWN_LOCATION);

diff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi
index 1d40530c3f4fa9a5adebcd2194da35104c5f71a4..811f34f7d9f3ab8a378747119817b8dff8c17e03 100644 (file)
--- a/gcc/algol68/ga68.texi
+++ b/gcc/algol68/ga68.texi
@@ -2799,16 +2799,22 @@ in the elements of the given bits operands.
 
 @deftypefn Operator {} {@B{SHL}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
 @deftypefnx Operator {} {@B{UP}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
-Dyadic operator that yields the given bits operand shifted @code{n}
-positions to the left.  Extra elements introduced on the right are
-initialized to @code{@B{false}}.
+Dyadic operator that yields the given bits operand shifted @code{ABS
+n} positions to the left if @code{n >= 0} or @code{ABS n} positions to
+the right if @code{n < 0}.  Extra elements introduced on the right or
+left are initialized to @code{@B{false}}.  If @code{ABS n >
+L_bits_width} then the resulting bits value has all bits set to
+@code{false}.
 @end deftypefn
 
 @deftypefn Operator {} {@B{SHR}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
 @deftypefnx Operator {} {@B{DOWN}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
-Dyadic operator that yields the given bits operand shifted @code{n}
-positions to the right.  Extra elements introduced on the left are
-initialized to @code{@B{false}}.
+Dyadic operator that yields the given bits operand shifted @code{ABS
+n} positions to the right if @code{n >= 0} or @code{ABS n} positions
+to the left if @code{n < 0}.  Extra elements introduced on the right
+or left are initialized to @code{@B{false}}.  If @code{ABS n >
+L_bits_width} then the resulting bits value has all bits set to
+@code{false}.
 @end deftypefn
 
 @subsection Relational

diff --git a/gcc/testsuite/algol68/execute/bits-shift-1.a68 b/gcc/testsuite/algol68/execute/bits-shift-1.a68
new file mode 100644 (file)
index 0000000..9e3220d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-shift-1.a68
@@ -0,0 +1,9 @@
+begin int first_bit = 2**31;
+      int myshift = 29;
+
+      bits b1 = BIN (first_bit) SHR 29;
+      bits b2 = BIN (first_bit) SHR myshift;
+
+      assert (b1 = 2r100);
+      assert (b2 = 2r100)
+end

diff --git a/gcc/testsuite/algol68/execute/bits-shift-2.a68 b/gcc/testsuite/algol68/execute/bits-shift-2.a68
new file mode 100644 (file)
index 0000000..e946b97
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-shift-2.a68
@@ -0,0 +1,26 @@
+{ Shifting by L_bits_width results in all bits being zero. }
+
+begin assert (short short 16rffff SHR short_short_bits_width = short short 16r0);
+      assert (short 16rffff SHR short_bits_width = short 16r0);
+      assert (16rffff SHR bits_width = 16r0);
+      assert (long 16rffff SHR long_bits_width = long 16r0);
+      assert (long long 16rffff SHR long_long_bits_width = long long 16r0);
+
+      assert (short short 16rffff SHR -short_short_bits_width = short short 16r0);
+      assert (short 16rffff SHR -short_bits_width = short 16r0);
+      assert (16rffff SHR -bits_width = 16r0);
+      assert (long 16rffff SHR -long_bits_width = long 16r0);
+      assert (long long 16rffff SHR -long_long_bits_width = long long 16r0);
+
+      assert (short short 16rffff SHL short_short_bits_width = short short 16r0);
+      assert (short 16rffff SHL short_bits_width = short 16r0);
+      assert (16rffff SHL bits_width = 16r0);
+      assert (long 16rffff SHL long_bits_width = long 16r0);
+      assert (long long 16rffff SHL long_long_bits_width = long long 16r0);
+
+      assert (short short 16rffff SHL -short_short_bits_width = short short 16r0);
+      assert (short 16rffff SHL -short_bits_width = short 16r0);
+      assert (16rffff SHL -bits_width = 16r0);
+      assert (long 16rffff SHL -long_bits_width = long 16r0);
+      assert (long long 16rffff SHL -long_long_bits_width = long long 16r0)
+end

diff --git a/gcc/testsuite/algol68/execute/bits-shift-3.a68 b/gcc/testsuite/algol68/execute/bits-shift-3.a68
new file mode 100644 (file)
index 0000000..b4536dc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-shift-3.a68
@@ -0,0 +1,26 @@
+{ Shifting by > L_bits_width results in all bits being zero. }
+
+begin assert (short short 16rffff SHR (short_short_bits_width + 1) = short short 16r0);
+      assert (short 16rffff SHR (short_bits_width + 1) = short 16r0);
+      assert (16rffff SHR (bits_width + 1) = 16r0);
+      assert (long 16rffff SHR (long_bits_width + 1) = long 16r0);
+      assert (long long 16rffff SHR (long_long_bits_width + 1) = long long 16r0);
+
+      assert (short short 16rffff SHR -(short_short_bits_width + 1) = short short 16r0);
+      assert (short 16rffff SHR -(short_bits_width + 1) = short 16r0);
+      assert (16rffff SHR -(bits_width + 1) = 16r0);
+      assert (long 16rffff SHR -(long_bits_width + 1) = long 16r0);
+      assert (long long 16rffff SHR -(long_long_bits_width + 1) = long long 16r0);
+
+      assert (short short 16rffff SHL (short_short_bits_width + 1) = short short 16r0);
+      assert (short 16rffff SHL (short_bits_width + 1) = short 16r0);
+      assert (16rffff SHL (bits_width + 1) = 16r0);
+      assert (long 16rffff SHL (long_bits_width + 1) = long 16r0);
+      assert (long long 16rffff SHL (long_long_bits_width + 1) = long long 16r0);
+
+      assert (short short 16rffff SHL -(short_short_bits_width + 1) = short short 16r0);
+      assert (short 16rffff SHL -(short_bits_width + 1) = short 16r0);
+      assert (16rffff SHL -(bits_width + 1) = 16r0);
+      assert (long 16rffff SHL -(long_bits_width + 1) = long 16r0);
+      assert (long long 16rffff SHL -(long_long_bits_width + 1) = long long 16r0)
+end