https://gcc.gnu.org/g:40a4f3dead623db86bc8f7255cbe524701f4aeb0
commit r15-7931-g40a4f3dead623db86bc8f7255cbe524701f4aeb0
Author: Gaius Mulley <gaiusm...@gmail.com>
Date: Mon Mar 10 17:37:41 2025 +0000
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 <gaiusm...@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2GCCDeclare.def | 9 +++++
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 27 +++++++++++++++
gcc/m2/gm2-compiler/M2GenGCC.mod | 43 ++++++++++++++++++------
gcc/m2/gm2-gcc/m2expr.cc | 17 +++++++++-
gcc/m2/gm2-gcc/m2expr.def | 9 +++++
gcc/m2/gm2-gcc/m2expr.h | 1 +
gcc/testsuite/gm2/sets/run/pass/simplepacked.mod | 9 +++--
7 files changed, 101 insertions(+), 14 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.def
b/gcc/m2/gm2-compiler/M2GCCDeclare.def
index 8179a66326df..1d87d6b212af 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.def
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.def
@@ -92,6 +92,15 @@ PROCEDURE DeclareConstructor (tokenno: CARDINAL; quad:
CARDINAL; sym: CARDINAL)
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
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 0de9ff7f2214..7dcf439985a1 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -1900,6 +1900,33 @@ BEGIN
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 bba77ff12e11..761e79bef295 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,
@@ -4809,12 +4810,38 @@ BEGIN
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 83709595de6c..42ea4fa9f5bd 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 b71f8f140764..e9f48b813c71 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 82d6ad84e2dd..d4771e3266fd 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 5a76b311da88..4cc598baca4b 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") ;
