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.

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));
+}

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)
 {

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.  */

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);

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
 

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