[COMMITTED] a68: add SET and CLEAR operators for L bits
Jose E. Marchesi
jemarch@gnu.org
Fri Jan 30 13:33:52 GMT 2026
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.
---
gcc/algol68/a68-low-bits.cc | 72 +++++++++++++++++++
gcc/algol68/a68-low-prelude.cc | 16 +++++
gcc/algol68/a68-parser-prelude.cc | 22 ++++++
gcc/algol68/a68.h | 4 ++
gcc/algol68/ga68.texi | 12 ++++
.../algol68/execute/bits-clear-1.a68 | 30 ++++++++
gcc/testsuite/algol68/execute/bits-set-1.a68 | 30 ++++++++
7 files changed, 186 insertions(+)
create mode 100644 gcc/testsuite/algol68/execute/bits-clear-1.a68
create mode 100644 gcc/testsuite/algol68/execute/bits-set-1.a68
diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc
index 465969f9ade..6a272ca633d 100644
--- 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 170da5a5c3c..3a1db5e7f65 100644
--- 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 b28df455aa2..bf58c4039c3 100644
--- 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 2df79474ea1..f4ee6a1faf9 100644
--- 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 64d9b316d58..00085c74133 100644
--- 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
index 00000000000..8c5502737dc
--- /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
index 00000000000..eac8d6883f7
--- /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
--
2.39.5
More information about the Algol68
mailing list