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

Author: Gaius Mulley

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);
     }

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));
     }

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.

gcc/testsuite/gm2/pim/fail/tinyconst.mod

@@ -0,0 +1,6 @@
+MODULE tinyconst ;
+CONST
+   Int = 16 ;
+   Real = 1.0 + Int ;
+
+END tinyconst.

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.