a68: add TEST operator for bits to expanded prelude

This patch adds support for a TEST operator for L bits.  Documentation
and tests are included.

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

	* a68.h: Prototypes for a68_bits_test and a68_lower_test3.
	* a68-low-bits.cc (a68_bits_test): New function.
	* a68-low-prelude.cc (a68_lower_test3): Likewise.
	* a68-parser-prelude.cc (gnu_prelude): Declare TEST operators and
	their priority.
	* ga68.texi (Extended bits operators): New section.

gcc/testsuite/ChangeLog

	* algol68/execute/bits-test-1.a68: New test.

diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc
index 6a272ca633d1cbbe40b5fe24f5ac19b2ad48093e..16205fa6351cef46946127c1d5c1adc74024201d 100644 (file)
--- a/gcc/algol68/a68-low-bits.cc
+++ b/gcc/algol68/a68-low-bits.cc
@@ -367,3 +367,43 @@ a68_bits_clear (MOID_T *m, tree bits, tree numbit, location_t loc)
                          bits_type,
                          in_range, res, bits);
 }
+
+/* Test the bit NUMBIT in BITS.
+
+   NUMBIT is one based and counts bits from least significative to most
+   significative, i.e. from "right" to "left".  If NUMBIT is not in range then
+   the operator yields false.  */
+
+tree
+a68_bits_test (MOID_T *m ATTRIBUTE_UNUSED,
+              tree bits, tree numbit, location_t loc)
+{
+  tree bits_type = TREE_TYPE (bits);
+  tree int_type = TREE_TYPE (numbit);
+
+  bits = save_expr (bits);
+  numbit = save_expr (numbit);
+
+  tree numbit_minus_one = fold_build2 (MINUS_EXPR, int_type,
+                                      numbit, build_one_cst (int_type));
+  tree mask = fold_build2 (BIT_AND_EXPR, bits_type,
+                          bits,
+                          fold_build2 (LSHIFT_EXPR,
+                                       bits_type,
+                                       build_one_cst (bits_type),
+                                       fold_convert (bits_type, numbit_minus_one)));
+  tree res = fold_build2 (NE_EXPR,
+                         a68_bool_type,
+                         fold_build2 (BIT_AND_EXPR, bits_type, bits, mask),
+                         build_int_cst (bits_type, 0));
+  tree in_range = fold_build2 (TRUTH_AND_EXPR,
+                              int_type,
+                              fold_build2 (GE_EXPR, int_type,
+                                           numbit, build_int_cst (int_type, 1)),
+                              fold_build2 (LE_EXPR, int_type,
+                                           numbit, a68_bits_width (bits_type)));
+
+  return fold_build3_loc (loc, COND_EXPR,
+                         a68_bool_type,
+                         in_range, res, build_zero_cst (a68_bool_type));
+}

diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
index 3a1db5e7f65de6207866325d394b558310762125..331e865ffffab838723d34d78fc98a4994a1c793 100644 (file)
--- a/gcc/algol68/a68-low-prelude.cc
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -766,6 +766,14 @@ a68_lower_clear3 (NODE_T *p, LOW_CTX_T ctx)
   return a68_bits_clear (MOID (p), op1, op2, a68_get_node_location (p));
 }
 
+tree
+a68_lower_test3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_test (MOID (p), op1, op2, a68_get_node_location (p));
+}
+
 tree
 a68_lower_pow_int (NODE_T *p, LOW_CTX_T ctx)
 {

diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc
index bf58c4039c3373270dcea08581da2411e9f347e6..1184da333de89bcb5cc496301885a0473bb1f55f 100644 (file)
--- a/gcc/algol68/a68-parser-prelude.cc
+++ b/gcc/algol68/a68-parser-prelude.cc
@@ -1317,6 +1317,7 @@ gnu_prelude (void)
   a68_prio ("ELEMS", 8);
   a68_prio ("SET", 7);
   a68_prio ("CLEAR", 7);
+  a68_prio ("TEST", 7);
   /* Identifiers.  */
   a68_idf (A68_EXT, "infinity", M_REAL, a68_lower_infinity);
   a68_idf (A68_EXT, "minusinfinity", M_REAL, a68_lower_minusinfinity);
@@ -1370,22 +1371,32 @@ gnu_prelude (void)
   m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_INT, NO_MOID);
   a68_op (A68_EXT, "SET", m, a68_lower_set3);
   a68_op (A68_EXT, "CLEAR", m, a68_lower_clear3);
+  m = a68_proc (M_BOOL, M_SHORT_SHORT_BITS, M_INT, NO_MOID);
+  a68_op (A68_EXT, "TEST", m, a68_lower_test3);
   /* SHORT BITS operators.  */
   m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_INT, NO_MOID);
   a68_op (A68_EXT, "SET", m, a68_lower_set3);
   a68_op (A68_EXT, "CLEAR", m, a68_lower_clear3);
+  m = a68_proc (M_BOOL, M_SHORT_BITS, M_INT, NO_MOID);
+  a68_op (A68_EXT, "TEST", m, a68_lower_test3);
   /* BITS operators.  */
   m = a68_proc (M_BITS, M_BITS, M_INT, NO_MOID);
   a68_op (A68_EXT, "SET", m, a68_lower_set3);
   a68_op (A68_EXT, "CLEAR", m, a68_lower_clear3);
+  m = a68_proc (M_BOOL, M_BITS, M_INT, NO_MOID);
+  a68_op (A68_EXT, "TEST", m, a68_lower_test3);
   /* LONG BITS operators.  */
   m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_INT, NO_MOID);
   a68_op (A68_EXT, "SET", m, a68_lower_set3);
   a68_op (A68_EXT, "CLEAR", m, a68_lower_clear3);
+  m = a68_proc (M_BOOL, M_LONG_BITS, M_INT, NO_MOID);
+  a68_op (A68_EXT, "TEST", m, a68_lower_test3);
   /* LONG LONG BITS operators.  */
   m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_INT, NO_MOID);
   a68_op (A68_EXT, "SET", m, a68_lower_set3);
   a68_op (A68_EXT, "CLEAR", m, a68_lower_clear3);
+  m = a68_proc (M_BOOL, M_LONG_LONG_BITS, M_INT, NO_MOID);
+  a68_op (A68_EXT, "TEST", m, a68_lower_test3);
 }
 
 /* POSIX prelude.  */

diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index f4ee6a1faf9bb84fef21aa06838255915e39e406..cb8bcef4950367b7c040f4f0a0dbe6db68338bbc 100644 (file)
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -539,6 +539,7 @@ 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);
 tree a68_bits_clear (MOID_T *m, tree bits, tree numbit, location_t loc = UNKNOWN_LOCATION);
+tree a68_bits_test (MOID_T *m, tree bits, tree numbit, location_t loc = UNKNOWN_LOCATION);
 
 /* a68-low_bools.cc  */
 
@@ -1074,6 +1075,7 @@ tree a68_lower_longrandom (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_longlongrandom (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_set3 (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_clear3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_test3 (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_posixargc (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_posixargv (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_posixputchar (NODE_T *p, LOW_CTX_T ctx);

diff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi
index 00085c74133a86c1063e367c3489a1a6c8839c09..1d40530c3f4fa9a5adebcd2194da35104c5f71a4 100644 (file)
--- a/gcc/algol68/ga68.texi
+++ b/gcc/algol68/ga68.texi
@@ -3049,6 +3049,12 @@ Dyadic operator that clears the @code{n}th least significant bit in
 then the operator yields @B{b}.
 @end deftypefn
 
+@deftypefn Operator {} {@B{test}} {= (@B{l} @B{bits} b, @B{int} n) @B{bool}}
+Dyadic operator that tests whether the @code{n}th least significant
+bit in @code{@B{b}} is set. If @code{n} is not in the range
+@code{1,L_bits_width]} then the operator yields @B{false}.
+@end deftypefn
+
 @node Extended math procedures
 @section Extended math procedures
 

diff --git a/gcc/testsuite/algol68/execute/bits-test-1.a68 b/gcc/testsuite/algol68/execute/bits-test-1.a68
new file mode 100644 (file)
index 0000000..6ffd7fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-test-1.a68
@@ -0,0 +1,5 @@
+begin assert (NOT (16rff TEST 9));
+      assert (NOT (16rff TEST 0));
+      assert (NOT (16rff TEST -1));
+      assert (2r100 TEST 3)
+end