https://gcc.gnu.org/g:1b43154b90be6a2f691b98d4e395c07ac6c7045c
commit r15-7845-g1b43154b90be6a2f691b98d4e395c07ac6c7045c
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Wed Mar 5 23:01:45 2025 +0000
PR modula2/118998 Rotate of a packetset causes different types to binary
operator error
This patch allow a packedset to be rotated by the system module intrinsic
procedure function. It ensures that both operands to the tree rotate are
of the same type. In turn the result will be the same type and the
assignment into the designator (of the same set type) will succeed.
gcc/m2/ChangeLog:
PR modula2/118998
* gm2-gcc/m2expr.cc (m2expr_BuildLRotate): Convert nBits
to the return type.
(m2expr_BuildRRotate): Ditto.
(m2expr_BuildLogicalRotate): Convert op3 to an integer type.
Replace op3 aith rotateCount.
Negate rotateCount if it is negative and call rotate right.
* gm2-gcc/m2pp.cc (m2pp_bit_and_expr): New function.
(m2pp_binary_function): Ditto.
(m2pp_simple_expression): BIT_AND_EXPR new case clause.
LROTATE_EXPR ditto.
RROTATE_EXPR ditto.
gcc/testsuite/ChangeLog:
PR modula2/118998
* gm2/iso/pass/testrotate.mod: New test.
* gm2/pim/fail/tinyconst.mod: New test.
* gm2/sets/run/pass/simplepacked.mod: New test.
Signed-off-by: Gaius Mulley <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-gcc/m2expr.cc | 13 ++---
gcc/m2/gm2-gcc/m2pp.cc | 32 ++++++++++++
gcc/testsuite/gm2/iso/pass/testrotate.mod | 11 +++++
gcc/testsuite/gm2/pim/fail/tinyconst.mod | 6 +++
gcc/testsuite/gm2/sets/run/pass/simplepacked.mod | 62 ++++++++++++++++++++++++
5 files changed, 118 insertions(+), 6 deletions(-)
diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 7c2a6f1cb5a9..83709595de6c 100644
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -673,6 +673,7 @@ m2expr_BuildLRotate (location_t location, tree op1, tree
nBits,
op1 = m2expr_FoldAndStrip (op1);
nBits = m2expr_FoldAndStrip (nBits);
+ nBits = m2convert_BuildConvert (location, TREE_TYPE (op1), nBits,
needconvert);
t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, nBits, needconvert);
return m2expr_FoldAndStrip (t);
}
@@ -688,6 +689,7 @@ m2expr_BuildRRotate (location_t location, tree op1, tree
nBits,
op1 = m2expr_FoldAndStrip (op1);
nBits = m2expr_FoldAndStrip (nBits);
+ nBits = m2convert_BuildConvert (location, TREE_TYPE (op1), nBits,
needconvert);
t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, nBits, needconvert);
return m2expr_FoldAndStrip (t);
}
@@ -801,18 +803,17 @@ m2expr_BuildLogicalRotate (location_t location, tree op1,
tree op2, tree op3,
{
char *labelElseName = createUniqueLabel ();
char *labelEndName = createUniqueLabel ();
- tree is_less = m2expr_BuildLessThan (location,
- m2convert_ToInteger (location, op3),
+ tree rotateCount = m2convert_ToInteger (location, op3);
+ tree is_less = m2expr_BuildLessThan (location, rotateCount,
m2expr_GetIntegerZero (location));
m2statement_DoJump (location, is_less, NULL, labelElseName);
- res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
+ res = m2expr_BuildLRLn (location, op2, rotateCount, nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_BuildGoto (location, labelEndName);
m2statement_DeclareLabel (location, labelElseName);
- res = m2expr_BuildLRRn (location, op2,
- m2expr_BuildNegate (location, op3, needconvert),
- nBits, needconvert);
+ rotateCount = m2expr_BuildNegate (location, rotateCount, needconvert);
+ res = m2expr_BuildLRRn (location, op2, rotateCount, nBits, needconvert);
m2statement_BuildAssignmentTree (location, op1, res);
m2statement_DeclareLabel (location, labelEndName);
}
diff --git a/gcc/m2/gm2-gcc/m2pp.cc b/gcc/m2/gm2-gcc/m2pp.cc
index 0f6d35a710e4..d7f5a4187c8f 100644
--- a/gcc/m2/gm2-gcc/m2pp.cc
+++ b/gcc/m2/gm2-gcc/m2pp.cc
@@ -1922,6 +1922,14 @@ m2pp_bit_ior_expr (pretty *s, tree t)
m2pp_binary (s, t, "|");
}
+/* m2pp_bit_and_expr generate a C style bit and. */
+
+static void
+m2pp_bit_and_expr (pretty *s, tree t)
+{
+ m2pp_binary (s, t, "&");
+}
+
/* m2pp_truth_expr. */
static void
@@ -1938,6 +1946,21 @@ m2pp_truth_expr (pretty *s, tree t, const char *op)
m2pp_print (s, ")");
}
+/* m2pp_binary_function handle GCC expression tree as a function. */
+
+static void
+m2pp_binary_function (pretty *s, tree t, const char *funcname)
+{
+ m2pp_print (s, funcname);
+ m2pp_needspace (s);
+ m2pp_print (s, "(");
+ m2pp_expression (s, TREE_OPERAND (t, 0));
+ m2pp_print (s, ",");
+ m2pp_needspace (s);
+ m2pp_expression (s, TREE_OPERAND (t, 1));
+ m2pp_print (s, ")");
+}
+
/* m2pp_simple_expression handle GCC expression tree. */
static void
@@ -2085,12 +2108,21 @@ m2pp_simple_expression (pretty *s, tree t)
case BIT_IOR_EXPR:
m2pp_bit_ior_expr (s, t);
break;
+ case BIT_AND_EXPR:
+ m2pp_bit_and_expr (s, t);
+ break;
case TRUTH_ANDIF_EXPR:
m2pp_truth_expr (s, t, "AND");
break;
case TRUTH_ORIF_EXPR:
m2pp_truth_expr (s, t, "OR");
break;
+ case LROTATE_EXPR:
+ m2pp_binary_function (s, t, "LROTATE");
+ break;
+ case RROTATE_EXPR:
+ m2pp_binary_function (s, t, "RROTATE");
+ break;
default:
m2pp_unknown (s, __FUNCTION__, get_tree_code_name (code));
}
diff --git a/gcc/testsuite/gm2/iso/pass/testrotate.mod
b/gcc/testsuite/gm2/iso/pass/testrotate.mod
new file mode 100644
index 000000000000..bc314944c7a7
--- /dev/null
+++ b/gcc/testsuite/gm2/iso/pass/testrotate.mod
@@ -0,0 +1,11 @@
+MODULE testrotate ;
+
+IMPORT SYSTEM;
+
+VAR
+ v: PACKEDSET OF [0..31];
+ i: INTEGER;
+BEGIN
+ i := 3;
+ v := SYSTEM.ROTATE (v, i);
+END testrotate.
diff --git a/gcc/testsuite/gm2/pim/fail/tinyconst.mod
b/gcc/testsuite/gm2/pim/fail/tinyconst.mod
new file mode 100644
index 000000000000..566190c73329
--- /dev/null
+++ b/gcc/testsuite/gm2/pim/fail/tinyconst.mod
@@ -0,0 +1,6 @@
+MODULE tinyconst ;
+CONST
+ Int = 16 ;
+ Real = 1.0 + Int ;
+
+END tinyconst.
\ No newline at end of file
diff --git a/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
b/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
new file mode 100644
index 000000000000..5a76b311da88
--- /dev/null
+++ b/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
@@ -0,0 +1,62 @@
+MODULE simplepacked ;
+
+FROM libc IMPORT printf, exit ;
+FROM SYSTEM IMPORT TBITSIZE, ROTATE ;
+
+TYPE
+ settype = SET OF [0..8] ;
+ psettype = PACKEDSET OF [0..8] ;
+
+
+PROCEDURE assert (cond: BOOLEAN; line: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF NOT cond
+ THEN
+ printf ("assert failed %s at line %d\n", message, line) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testset ;
+VAR
+ a, b: settype ;
+BEGIN
+ a := settype {1} ;
+ b := a ;
+ (* assert (TBITSIZE (a) = 4, __LINE__, "TBITSIZE = 4") ; *)
+ assert (a = b, __LINE__, "comparision between variable sets") ;
+ assert (a = settype {1}, __LINE__, "comparision between variable and
constant sets") ;
+ assert (b = settype {1}, __LINE__, "comparision between variable and
constant sets") ;
+ assert (settype {1} = settype {1}, __LINE__, "comparision between constant
sets") ;
+ assert (settype {1} # settype {2}, __LINE__, "comparision between constant
sets") ;
+ assert (ROTATE (settype {1}, 1) = ROTATE (settype {1}, 1), __LINE__,
"comparision between constant rotated sets") ;
+ assert (ROTATE (settype {1}, 1) # ROTATE (settype {2}, 1), __LINE__,
"comparision between constant rotated sets") ;
+ assert (ROTATE (a, 1) = settype {2}, __LINE__, "comparision between rotated
variable and constant sets") ;
+ assert (ROTATE (a, -1) = settype {0}, __LINE__, "comparision between
rotated variable and constant sets") ;
+END testset ;
+
+
+PROCEDURE testpset ;
+VAR
+ a, b: psettype ;
+BEGIN
+ a := psettype {1} ;
+ b := a ;
+ (* assert (TBITSIZE (a) = 4, __LINE__, "TBITSIZE = 4 packed set") ; *)
+ assert (a = b, __LINE__, "comparision between variable packed sets") ;
+ assert (a = psettype {1}, __LINE__, "comparision between variable and
constant packed sets") ;
+ assert (b = psettype {1}, __LINE__, "comparision between variable and
constant packed sets") ;
+ assert (psettype {1} = psettype {1}, __LINE__, "comparision between
constant packed sets") ;
+ assert (psettype {1} # psettype {2}, __LINE__, "comparision between
constant packed sets") ;
+ assert (ROTATE (psettype {1}, 1) = ROTATE (psettype {1}, 1), __LINE__,
"comparision between constant rotated packed sets") ;
+ assert (ROTATE (psettype {1}, 1) # ROTATE (psettype {2}, 1), __LINE__,
"comparision between constant rotated packed sets") ;
+ assert (ROTATE (a, 1) = psettype {2}, __LINE__, "comparision between
rotated variable and constant packed sets") ;
+ assert (ROTATE (a, -1) = settype {0}, __LINE__, "comparision between
rotated variable and constant packed sets") ;
+END testpset ;
+
+
+BEGIN
+ testset ;
+ testpset
+END simplepacked.
