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 <[email protected]> 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
