a68: add SET and CLEAR operators for L bits

This commit adds two more operators to the extended standard prelude
that work on L bits values.

Tests and documention included.

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

	* ga68.texi (POSIX files): Document SET and CLEAR operators.
	* a68.h: Prototypes for a68_bits_set, a68_bits_clear,
	a68_lower_set3 and a68_lower_clear3.
	* a68-low-bits.cc (a68_bits_set): New function.
	(a68_bits_clear): Likewise.
	* a68-low-prelude.cc (a68_lower_set3): Likewise.
	(a68_lower_clear3): Likewise.
	* a68-parser-prelude.cc (gnu_prelude): Declare operators SET and
	CLEAR and their priorities.

gcc/testsuite/ChangeLog

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

diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc
index 465969f9ade14bf40a5f12958fc3a93c41244f33..6a272ca633d1cbbe40b5fe24f5ac19b2ad48093e 100644 (file)
--- a/gcc/algol68/a68-low-bits.cc
+++ b/gcc/algol68/a68-low-bits.cc
@@ -295,3 +295,75 @@ a68_bits_ne (tree a, tree b, location_t loc)
 {
   return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
 }
+
+/* Set 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
+   this is a nop. */
+
+tree
+a68_bits_set (MOID_T *m, tree bits, tree numbit, location_t loc)
+{
+  tree bits_type = CTYPE (m);
+  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_int_cst (int_type, 1));
+  tree mask = fold_build2 (BIT_IOR_EXPR, bits_type,
+                          bits,
+                          fold_build2 (LSHIFT_EXPR,
+                                       bits_type,
+                                       build_int_cst (bits_type, 1),
+                                       numbit_minus_one));
+  tree res = fold_build2 (BIT_IOR_EXPR, bits_type, bits, mask);
+  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,
+                         bits_type,
+                         in_range, res, bits);
+}
+
+/* Clear 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
+   this is a nop. */
+
+tree
+a68_bits_clear (MOID_T *m, tree bits, tree numbit, location_t loc)
+{
+  tree bits_type = CTYPE (m);
+  tree int_type = TREE_TYPE (numbit);
+
+  bits = save_expr (bits);
+  numbit = save_expr (numbit);
+
+  tree mask = fold_build1 (BIT_NOT_EXPR,
+                          bits_type,
+                          fold_build2 (LSHIFT_EXPR,
+                                       bits_type,
+                                       build_int_cst (bits_type, 1),
+                                       fold_build2 (MINUS_EXPR,
+                                                    int_type,
+                                                    numbit,
+                                                    build_int_cst (int_type, 1))));
+  tree res = fold_build2 (BIT_AND_EXPR, bits_type, bits, mask);
+  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,
+                         bits_type,
+                         in_range, res, bits);
+}

diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
index 170da5a5c3cd329b54225a157c29e7b0df85dd99..3a1db5e7f65de6207866325d394b558310762125 100644 (file)
--- a/gcc/algol68/a68-low-prelude.cc
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -750,6 +750,22 @@ a68_lower_elems3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_convert (CTYPE (MOID (p)), elems (p, multiple, dim));
 }
 
+tree
+a68_lower_set3 (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_set (MOID (p), op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_clear3 (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_clear (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 b28df455aa2aeb2332a0dd533f39562a6aab51db..bf58c4039c3373270dcea08581da2411e9f347e6 100644 (file)
--- a/gcc/algol68/a68-parser-prelude.cc
+++ b/gcc/algol68/a68-parser-prelude.cc
@@ -1315,6 +1315,8 @@ gnu_prelude (void)
   MOID_T *m = NO_MOID;
   /* Priorities.  */
   a68_prio ("ELEMS", 8);
+  a68_prio ("SET", 7);
+  a68_prio ("CLEAR", 7);
   /* Identifiers.  */
   a68_idf (A68_EXT, "infinity", M_REAL, a68_lower_infinity);
   a68_idf (A68_EXT, "minusinfinity", M_REAL, a68_lower_minusinfinity);
@@ -1364,6 +1366,26 @@ gnu_prelude (void)
   a68_op (A68_EXT, "ELEMS", m, a68_lower_elems2);
   m = a68_proc (M_INT, M_INT, M_ROWS, NO_MOID);
   a68_op (A68_EXT, "ELEMS", m, a68_lower_elems3);
+  /* SHORT SHORT BITS operators.  */
+  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);
+  /* 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);
+  /* 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);
+  /* 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);
+  /* 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);
 }
 
 /* POSIX prelude.  */

diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 2df79474ea1be54e3df79aab2555bad1d288697c..f4ee6a1faf9bb84fef21aa06838255915e39e406 100644 (file)
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -537,6 +537,8 @@ tree a68_bits_subset (tree bits1, tree bits2);
 tree a68_bits_shift (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);
+tree a68_bits_clear (MOID_T *m, tree bits, tree numbit, location_t loc = UNKNOWN_LOCATION);
 
 /* a68-low_bools.cc  */
 
@@ -1070,6 +1072,8 @@ tree a68_lower_shortenreal2 (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_random (NODE_T *p, LOW_CTX_T ctx);
 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_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 64d9b316d58fb677cec053ac266a914bfdd77d92..00085c74133a86c1063e367c3489a1a6c8839c09 100644 (file)
--- a/gcc/algol68/ga68.texi
+++ b/gcc/algol68/ga68.texi
@@ -3037,6 +3037,18 @@ Dyadic operator that yields the bit exclusive-or operation of the
 given bits arguments.
 @end deftypefn
 
+@deftypefn Operator {} {@B{set}} {= (@B{l} @B{bits} b, @B{int} n) @B{l} @B{bits}}
+Dyadic operator that sets the @code{n}th least significant bit in
+@code{@B{b}}.  If @code{n} is not in the range @code{[1,L_bits_width]}
+then the operator yields @B{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{clear}} {= (@B{l} @B{bits} b, @B{int} n) @B{l} @B{bits}}
+Dyadic operator that clears the @code{n}th least significant bit in
+@code{@B{b}}.  If @code{n} is not in the range @code{[1,L_bits_width]}
+then the operator yields @B{b}.
+@end deftypefn
+
 @node Extended math procedures
 @section Extended math procedures
 

diff --git a/gcc/testsuite/algol68/execute/bits-clear-1.a68 b/gcc/testsuite/algol68/execute/bits-clear-1.a68
new file mode 100644 (file)
index 0000000..8c55027
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-clear-1.a68
@@ -0,0 +1,30 @@
+begin (short short bits a = short short 16rf;
+       assert (a CLEAR (short_short_bits_width + 1) = a);
+       assert (a CLEAR -1 = a);
+       assert (a CLEAR short_short_bits_width = short short 16rf);
+       assert (a CLEAR 1 CLEAR 2 = BIN short short 12));
+
+      (short bits a = short 16rf;
+       assert (a CLEAR (short_bits_width + 1) = a);
+       assert (a CLEAR -1 = a);
+       assert (a CLEAR short_bits_width = short 16rf);
+       assert (a CLEAR 1 CLEAR 2 = BIN short 12));
+
+      (bits a = 16rf;
+       assert (a CLEAR (bits_width + 1) = a);
+       assert (a CLEAR -1 = a);
+       assert (a CLEAR bits_width = 16rf);
+       assert (a CLEAR 1 CLEAR 2 = BIN 12));
+
+      (long bits a = long 16rf;
+       assert (a CLEAR (long_bits_width + 1) = a);
+       assert (a CLEAR -1 = a);
+       assert (a CLEAR long_bits_width = long 16rf);
+       assert (a CLEAR 1 CLEAR 2 = BIN long 12));
+
+      (long long bits a = long long 16rf;
+       assert (a CLEAR (long_long_bits_width + 1) = a);
+       assert (a CLEAR -1 = a);
+       assert (a CLEAR long_long_bits_width = long long 16rf);
+       assert (a CLEAR 1 CLEAR 2 = BIN long long 12))
+end

diff --git a/gcc/testsuite/algol68/execute/bits-set-1.a68 b/gcc/testsuite/algol68/execute/bits-set-1.a68
new file mode 100644 (file)
index 0000000..eac8d68
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bits-set-1.a68
@@ -0,0 +1,30 @@
+begin (short short bits a = short short 16r0;
+       assert (a SET (short_short_bits_width + 1) = a);
+       assert (a SET -1 = a);
+       assert (a SET short_short_bits_width = short short 16r1 SHL (short_short_bits_width-1));
+       assert (a SET 1 SET 2 = BIN short short 3));
+
+      (short bits a = short 16r0;
+       assert (a SET (short_bits_width + 1) = a);
+       assert (a SET -1 = a);
+       assert (a SET short_bits_width = short 16r1 SHL (short_bits_width-1));
+       assert (a SET 1 SET 2 = BIN short 3));
+
+      (bits a = 16r0;
+       assert (a SET (bits_width + 1) = a);
+       assert (a SET -1 = a);
+       assert (a SET bits_width = 16r1 SHL (bits_width-1));
+       assert (a SET 1 SET 2 = BIN 3));
+
+      (long bits a = long 16r0;
+       assert (a SET (long_bits_width + 1) = a);
+       assert (a SET -1 = a);
+       assert (a SET long_bits_width = long 16r1 SHL (long_bits_width-1));
+       assert (a SET 1 SET 2 = BIN long 3));
+
+      (long long bits a = long long 16r0;
+       assert (a SET (long_long_bits_width + 1) = a);
+       assert (a SET -1 = a);
+       assert (a SET long_long_bits_width = long long 16r1 SHL (long_long_bits_width-1));
+       assert (a SET 1 SET 2 = BIN long long 3))
+end