From 1b43154b90be6a2f691b98d4e395c07ac6c7045c Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Wed, 5 Mar 2025 23:01:45 +0000 Subject: [PATCH] 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 --- 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 ++ .../gm2/sets/run/pass/simplepacked.mod | 62 +++++++++++++++++++ 5 files changed, 118 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gm2/iso/pass/testrotate.mod create mode 100644 gcc/testsuite/gm2/pim/fail/tinyconst.mod create mode 100644 gcc/testsuite/gm2/sets/run/pass/simplepacked.mod diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc index 7c2a6f1cb5a..83709595de6 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 0f6d35a710e..d7f5a4187c8 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 00000000000..bc314944c7a --- /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 00000000000..566190c7332 --- /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 00000000000..5a76b311da8 --- /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.