PR modula2/118998 Rotate of a packetset causes different types to binary operator...

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 <gaiusmod2@gmail.com>

diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 7c2a6f1cb5a94588e2248c993f44aa6543c2297c..83709595de6c2e8df443eb984397f2328cb84e13 100644 (file)
--- 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 0f6d35a710e42f0dc6acea221ce18166c8c9e3d8..d7f5a4187c8ffd329b1b977f8b7872ce11de7625 100644 (file)
--- 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 (file)
index 0000000..bc31494
--- /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 (file)
index 0000000..566190c
--- /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 (file)
index 0000000..5a76b31
--- /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.