PR modula2/119192 ICE if TBITSIZE is used in an expression

This patch fixes an ICE which will occur is TBITSIZE is used
within an expression.

gcc/m2/ChangeLog:

	PR modula2/119192
	* gm2-compiler/M2GCCDeclare.def (TryDeclareType): New procedure.
	* gm2-compiler/M2GCCDeclare.mod (IsAnyType): New procedure.
	(TryDeclareType): Ditto.
	* gm2-compiler/M2GenGCC.mod (FoldTBitsize): New procedure.
	(FoldStandardFunction): Call FoldTBitsize.
	* gm2-gcc/m2expr.cc (BuildTBitSize): Improve comment.
	(m2expr_BuildSystemTBitSize): New function.
	* gm2-gcc/m2expr.def (BuildSystemTBitSize): New procedure
	function.
	* gm2-gcc/m2expr.h (m2expr_BuildSystemTBitSize): New function
	prototype.

gcc/testsuite/ChangeLog:

	PR modula2/119192
	* gm2/sets/run/pass/simplepacked.mod: Uncomment asserts.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

7 files changed, 101 insertions, 14 deletions

diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.def b/gcc/m2/gm2-compiler/M2GCCDeclare.def
index 8179a66..1d87d6b 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.def
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.def
@@ -93,6 +93,15 @@ PROCEDURE TryDeclareConstant (tokenno: CARDINAL; sym: CARDINAL) ;
 
 
 (*
+   TryDeclareType - try and declare a type.  If sym is a
+                    type try and declare it, if we cannot
+                    then enter it into the to do list.
+*)
+
+PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ;
+
+
+(*
    TryDeclareConstructor - try and declare a constructor.  If, sym, is a
                            constructor try and declare it, if we cannot
                            then enter it into the to do list.
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 0de9ff7..7dcf439 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -1901,6 +1901,33 @@ END TryDeclareConstant ;
 
 
 (*
+   IsAnyType - return TRUE if sym is any Modula-2 type.
+*)
+
+PROCEDURE IsAnyType (sym: CARDINAL) : BOOLEAN ;
+BEGIN
+   RETURN (IsRecord(sym) OR IsType(sym) OR IsRecordField(sym) OR
+           IsPointer(sym) OR IsArray(sym) OR IsSet (sym) OR IsEnumeration (sym) OR
+           IsPointer (sym))
+END IsAnyType ;
+
+
+(*
+   TryDeclareType - try and declare a type.  If sym is a
+                    type try and declare it, if we cannot
+                    then enter it into the to do list.
+*)
+
+PROCEDURE TryDeclareType (tokenno: CARDINAL; type: CARDINAL) ;
+BEGIN
+   IF (type#NulSym) AND IsAnyType (type)
+   THEN
+      TraverseDependants (type)
+   END
+END TryDeclareType ;
+
+
+(*
    DeclareConstant - checks to see whether, sym, is a constant and
                      declares the constant to gcc.
 *)
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index bba77ff..761e79b 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -61,7 +61,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
                         ForeachProcedureDo,
                         ForeachInnerModuleDo,
                         ForeachLocalSymDo,
-			GetLType,
+			GetLType, GetDType,
                         GetType, GetNth, GetNthParamAny,
                         SkipType, SkipTypeAndSubrange,
                         GetUnboundedHighOffset,
@@ -148,7 +148,7 @@ FROM M2ALU IMPORT PtrToValue,
                   ConvertToType ;
 
 FROM M2GCCDeclare IMPORT WalkAction,
-                         DeclareConstant, TryDeclareConstant,
+                         DeclareConstant, TryDeclareConstant, TryDeclareType,
                          DeclareConstructor, TryDeclareConstructor,
                          StartDeclareScope, EndDeclareScope,
                          PromoteToString, PromoteToCString, DeclareLocalVariable,
@@ -194,7 +194,8 @@ FROM m2expr IMPORT GetIntegerZero, GetIntegerOne,
                    BuildLogicalOr, BuildLogicalAnd, BuildSymmetricDifference,
                    BuildLogicalDifference,
                    BuildLogicalShift, BuildLogicalRotate,
-                   BuildNegate, BuildNegateCheck, BuildAddr, BuildSize, BuildTBitSize,
+                   BuildNegate, BuildNegateCheck, BuildAddr, BuildSize,
+                   BuildTBitSize, BuildSystemTBitSize,
                    BuildOffset, BuildOffset1,
                    BuildLessThan, BuildGreaterThan,
                    BuildLessThanOrEqual, BuildGreaterThanOrEqual,
@@ -4810,11 +4811,37 @@ END FoldBuiltinTypeInfo ;
 
 
 (*
+   FoldTBitsize - attempt to fold the standard function SYSTEM.TBITSIZE
+                  quadruple.  If the quadruple is folded it is removed.
+*)
+
+PROCEDURE FoldTBitsize  (tokenno: CARDINAL; p: WalkAction;
+                         quad: CARDINAL;
+                         op1, op2, op3: CARDINAL) ;
+VAR
+   type    : CARDINAL ;
+   location: location_t ;
+BEGIN
+   location := TokenToLocation(tokenno) ;
+   TryDeclareType (tokenno, op3) ;
+   type := GetDType (op3) ;
+   IF CompletelyResolved (type)
+   THEN
+      AddModGcc (op1, BuildSystemTBitSize (location, Mod2Gcc (type))) ;
+      p (op1) ;
+      NoChange := FALSE ;
+      SubQuad (quad)
+   END
+END FoldTBitsize ;
+
+
+(*
    FoldStandardFunction - attempts to fold a standard function.
 *)
 
 PROCEDURE FoldStandardFunction (tokenno: CARDINAL; p: WalkAction;
-                                quad: CARDINAL; op1, op2, op3: CARDINAL) ;
+                                quad: CARDINAL;
+                                op1, op2, op3: CARDINAL) ;
 VAR
    s       : String ;
    type,
@@ -4940,13 +4967,7 @@ BEGIN
       END
    ELSIF op2=TBitSize
    THEN
-      IF GccKnowsAbout(op3)
-      THEN
-         AddModGcc(op1, BuildTBitSize(location, Mod2Gcc(op3))) ;
-         p(op1) ;
-         NoChange := FALSE ;
-         SubQuad(quad)
-      END
+      FoldTBitsize (tokenno, p, quad, op1, op2, op3)
    ELSE
       InternalError ('only expecting LENGTH, CAP, ABS, IM, RE')
    END
diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 8370959..42ea4fa 100644
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -2818,7 +2818,9 @@ m2expr_calcNbits (location_t location, tree min, tree max)
   return t;
 }
 
-/* BuildTBitSize return the minimum number of bits to represent, type.  */
+/* BuildTBitSize return the minimum number of bits to represent type.
+   This function is called internally by cc1gm2 to calculate the bits
+   size of a type and is used to position record fields.  */
 
 tree
 m2expr_BuildTBitSize (location_t location, tree type)
@@ -2849,6 +2851,19 @@ m2expr_BuildTBitSize (location_t location, tree type)
     }
 }
 
+/* BuildSystemTBitSize return the minimum number of bits to represent type.
+   This function is called when evaluating SYSTEM.TBITSIZE.  */
+
+tree
+m2expr_BuildSystemTBitSize (location_t location, tree type)
+{
+  enum tree_code code = TREE_CODE (type);
+  m2assert_AssertLocation (location);
+  if (code == TYPE_DECL)
+    return m2expr_BuildTBitSize (location, TREE_TYPE (type));
+  return TYPE_SIZE (type);
+}
+
 /* BuildSize build a SIZE function expression and returns the tree.  */
 
 tree
diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def
index b71f8f1..e9f48b8 100644
--- a/gcc/m2/gm2-gcc/m2expr.def
+++ b/gcc/m2/gm2-gcc/m2expr.def
@@ -745,4 +745,13 @@ PROCEDURE OverflowZType (location: location_t;
 PROCEDURE BuildCondIfExpression (condition, type, left, right: tree) : tree ;
 
 
+(*
+   BuildSystemTBitSize - return the minimum number of bits to represent type.
+                         This function is called when evaluating
+                         SYSTEM.TBITSIZE.
+*)
+
+PROCEDURE BuildSystemTBitSize (location: location_t; type: tree) : tree ;
+
+
 END m2expr.
diff --git a/gcc/m2/gm2-gcc/m2expr.h b/gcc/m2/gm2-gcc/m2expr.h
index 82d6ad8..d4771e3 100644
--- a/gcc/m2/gm2-gcc/m2expr.h
+++ b/gcc/m2/gm2-gcc/m2expr.h
@@ -245,6 +245,7 @@ EXTERN int m2expr_GetCstInteger (tree cst);
 EXTERN tree m2expr_calcNbits (location_t location, tree min, tree max);
 EXTERN bool m2expr_OverflowZType (location_t location, const char *str,
 				  unsigned int base, bool issueError);
+EXTERN tree m2expr_BuildSystemTBitSize (location_t location, tree type);
 EXTERN void m2expr_init (location_t location);
 
 #undef EXTERN
diff --git a/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod b/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
index 5a76b31..4cc598b 100644
--- a/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
+++ b/gcc/testsuite/gm2/sets/run/pass/simplepacked.mod
@@ -24,7 +24,10 @@ VAR
 BEGIN
    a := settype {1} ;
    b := a ;
-   (* assert (TBITSIZE (a) = 4, __LINE__, "TBITSIZE = 4") ; *)
+   (* Assumes that the bitset will be contained in <= 64 bits, most likely
+      32.  But probably safe to assume <= 64 bits for some time.  *)
+   printf ("TBITSIZE (a) = %d\n", TBITSIZE (a));
+   assert (TBITSIZE (a) <= 64, __LINE__, "TBITSIZE <= 64") ;
    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") ;
@@ -43,7 +46,9 @@ VAR
 BEGIN
    a := psettype {1} ;
    b := a ;
-   (* assert (TBITSIZE (a) = 4, __LINE__, "TBITSIZE = 4 packed set") ; *)
+   (* Packed set should be stored in a BYTE.  *)
+   printf ("TBITSIZE (a) = %d\n", TBITSIZE (a));
+   assert (TBITSIZE (a) <= 32, __LINE__, "TBITSIZE <= 32 ( 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") ;