public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-4556] PR modula2/111675 Incorrect packed record field value passed to a procedure
@ 2023-10-11 12:27 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2023-10-11 12:27 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:2b783fe2e8103d97db7c5d6c1514ba16091f39f6
commit r14-4556-g2b783fe2e8103d97db7c5d6c1514ba16091f39f6
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Wed Oct 11 13:26:47 2023 +0100
PR modula2/111675 Incorrect packed record field value passed to a procedure
This patch allows a packed field to be extracted and passed to a
procedure. It ensures that the subrange type is the same for both the
procedure and record field. It also extends the <* bytealignment (0) *>
to cover packed subrange types.
gcc/m2/ChangeLog:
PR modula2/111675
* gm2-compiler/M2CaseList.mod (appendTree): Replace
InitStringCharStar with InitString.
* gm2-compiler/M2GCCDeclare.mod: Import AreConstantsEqual.
(DeclareSubrange): Add zero alignment test and call
BuildSmallestTypeRange if necessary.
(WalkSubrangeDependants): Walk the align expression.
(IsSubrangeDependants): Test the align expression.
* gm2-compiler/M2Quads.mod (BuildStringAdrParam): Correct end name.
* gm2-compiler/P2SymBuild.mod (BuildTypeAlignment): Allow subranges
to be zero aligned (packed).
* gm2-compiler/SymbolTable.mod (Subrange): Add Align field.
(MakeSubrange): Set Align to NulSym.
(PutAlignment): Assign Subrange.Align to align.
(GetAlignment): Return Subrange.Align.
* gm2-gcc/m2expr.cc (noBitsRequired): Rewrite.
(calcNbits): Rename ...
(m2expr_calcNbits): ... to this and test for negative values.
(m2expr_BuildTBitSize): Replace calcNBits with m2expr_calcNbits.
* gm2-gcc/m2expr.def (calcNbits): Export.
* gm2-gcc/m2expr.h (m2expr_calcNbits): New prototype.
* gm2-gcc/m2type.cc (noBitsRequired): Remove.
(m2type_BuildSmallestTypeRange): Call m2expr_calcNbits.
(m2type_BuildSubrangeType): Create range_type from
build_range_type (type, lowval, highval).
gcc/testsuite/ChangeLog:
PR modula2/111675
* gm2/extensions/run/pass/packedrecord3.mod: New test.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2CaseList.mod | 2 +-
gcc/m2/gm2-compiler/M2GCCDeclare.mod | 38 +++++++++++++----
gcc/m2/gm2-compiler/M2Quads.mod | 2 +-
gcc/m2/gm2-compiler/P2SymBuild.mod | 23 +++++-----
gcc/m2/gm2-compiler/SymbolTable.mod | 12 ++++--
gcc/m2/gm2-gcc/m2expr.cc | 13 +++---
gcc/m2/gm2-gcc/m2expr.def | 8 ++++
gcc/m2/gm2-gcc/m2expr.h | 2 +-
gcc/m2/gm2-gcc/m2type.cc | 23 +---------
.../gm2/extensions/run/pass/packedrecord3.mod | 49 ++++++++++++++++++++++
10 files changed, 118 insertions(+), 54 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2CaseList.mod b/gcc/m2/gm2-compiler/M2CaseList.mod
index b7155e30692..9a5dab4ea9d 100644
--- a/gcc/m2/gm2-compiler/M2CaseList.mod
+++ b/gcc/m2/gm2-compiler/M2CaseList.mod
@@ -975,7 +975,7 @@ BEGIN
appendString (InitStringChar ("'"))
END
ELSE
- appendString (InitStringCharStar ('CHR (')) ;
+ appendString (InitString ('CHR (')) ;
appendString (InitStringCharStar (CSTIntToString (value))) ;
appendString (InitStringChar (')'))
END
diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
index 87ca0da1eaf..c8c390ca122 100644
--- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod
+++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod
@@ -186,7 +186,7 @@ FROM m2type IMPORT MarkFunctionReferenced, BuildStartRecord, BuildStartVarient,
FROM m2convert IMPORT BuildConvert ;
FROM m2expr IMPORT BuildSub, BuildLSL, BuildTBitSize, BuildAdd, BuildDivTrunc, BuildModTrunc,
- BuildSize, TreeOverflow,
+ BuildSize, TreeOverflow, AreConstantsEqual,
GetPointerZero, GetIntegerZero, GetIntegerOne ;
FROM m2block IMPORT RememberType, pushGlobalScope, popGlobalScope, pushFunctionScope, popFunctionScope,
@@ -3518,15 +3518,28 @@ PROCEDURE DeclareSubrange (sym: CARDINAL) : Tree ;
VAR
type,
gccsym : Tree ;
+ align,
high, low: CARDINAL ;
location: location_t ;
BEGIN
location := TokenToLocation (GetDeclaredMod (sym)) ;
GetSubrange (sym, high, low) ;
- (* type := BuildSmallestTypeRange (location, Mod2Gcc(low), Mod2Gcc(high)) ; *)
- type := Mod2Gcc (GetSType (sym)) ;
+ align := GetAlignment (sym) ;
+ IF align # NulSym
+ THEN
+ IF AreConstantsEqual (GetIntegerZero (location), Mod2Gcc (align))
+ THEN
+ type := BuildSmallestTypeRange (location, Mod2Gcc (low), Mod2Gcc (high))
+ ELSE
+ MetaError1 ('a non-zero alignment in a subrange type {%1Wa} is currently not implemented and will be ignored',
+ sym) ;
+ type := Mod2Gcc (GetSType (sym))
+ END
+ ELSE
+ type := Mod2Gcc (GetSType (sym))
+ END ;
gccsym := BuildSubrangeType (location,
- KeyToCharStar (GetFullSymName(sym)),
+ KeyToCharStar (GetFullSymName (sym)),
type, Mod2Gcc (low), Mod2Gcc (high)) ;
RETURN gccsym
END DeclareSubrange ;
@@ -5314,8 +5327,8 @@ END WalkEnumerationDependants ;
PROCEDURE WalkSubrangeDependants (sym: CARDINAL; p: WalkAction) ;
VAR
- type,
- high, low: CARDINAL ;
+ type, align,
+ high, low : CARDINAL ;
BEGIN
GetSubrange(sym, high, low) ;
CheckResolveSubrange (sym) ;
@@ -5326,7 +5339,12 @@ BEGIN
END ;
(* low and high are not types but constants and they are resolved by M2GenGCC *)
p(low) ;
- p(high)
+ p(high) ;
+ align := GetAlignment (sym) ;
+ IF align # NulSym
+ THEN
+ p(align)
+ END
END WalkSubrangeDependants ;
@@ -5338,6 +5356,7 @@ END WalkSubrangeDependants ;
PROCEDURE IsSubrangeDependants (sym: CARDINAL; q: IsAction) : BOOLEAN ;
VAR
result : BOOLEAN ;
+ align,
type,
high, low: CARDINAL ;
BEGIN
@@ -5358,6 +5377,11 @@ BEGIN
THEN
result := FALSE
END ;
+ align := GetAlignment(sym) ;
+ IF (align#NulSym) AND (NOT q(align))
+ THEN
+ result := FALSE
+ END ;
RETURN( result )
END IsSubrangeDependants ;
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index f3a5c05a15a..02a7db4efc2 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -2594,7 +2594,7 @@ BEGIN
PushTtok (m2strnul, tok) ;
PushT (1) ;
BuildAdrFunction
-END BuildAdrFunction ;
+END BuildStringAdrParam ;
(*
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index 71f6b1c82c6..a2e3eb1cce9 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -1018,25 +1018,26 @@ VAR
type,
align : CARDINAL ;
BEGIN
- PopT(alignment) ;
- IF alignment=MakeKey('bytealignment')
+ PopT (alignment) ;
+ IF alignment = MakeKey ('bytealignment')
THEN
- PopT(align) ;
- PopT(type) ;
- IF align#NulSym
+ PopT (align) ;
+ PopT (type) ;
+ IF align # NulSym
THEN
- IF IsRecord(type) OR IsRecordField(type) OR IsType(type) OR IsArray(type) OR IsPointer(type)
+ IF IsRecord (type) OR IsRecordField (type) OR IsType (type) OR
+ IsArray (type) OR IsPointer( type) OR IsSubrange (type)
THEN
- PutAlignment(type, align)
+ PutAlignment (type, align)
ELSE
- MetaError1('not allowed to add an alignment attribute to type {%1ad}', type)
+ MetaError1 ('not allowed to add an alignment attribute to type {%1ad}', type)
END
END
- ELSIF alignment#NulName
+ ELSIF alignment # NulName
THEN
- WriteFormat1('unknown type alignment attribute, %a', alignment)
+ WriteFormat1 ('unknown type alignment attribute, %a', alignment)
ELSE
- PopT(type)
+ PopT (type)
END
END BuildTypeAlignment ;
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index dc41c125525..2414517dd3d 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -280,6 +280,7 @@ TYPE
Size : PtrToValue ; (* Size of subrange type. *)
Type : CARDINAL ; (* Index to type symbol for *)
(* the type of subrange. *)
+ Align : CARDINAL ; (* Alignment for this type. *)
ConstLitTree: SymbolTree ; (* constants of this type. *)
packedInfo : PackedInfo ; (* the equivalent packed type *)
oafamily : CARDINAL ; (* The oafamily for this sym *)
@@ -6152,6 +6153,7 @@ BEGIN
(* ConstExpression. *)
Type := NulSym ; (* Index to a type. Determines *)
(* the type of subrange. *)
+ Align := NulSym ; (* The alignment of this type. *)
InitPacked(packedInfo) ; (* not packed and no equivalent *)
InitTree(ConstLitTree) ; (* constants of this type. *)
Size := InitValue() ; (* Size determines the type size *)
@@ -14600,10 +14602,11 @@ BEGIN
RecordFieldSym: RecordField.Align := align |
TypeSym : Type.Align := align |
ArraySym : Array.Align := align |
- PointerSym : Pointer.Align := align
+ PointerSym : Pointer.Align := align |
+ SubrangeSym : Subrange.Align := align
ELSE
- InternalError ('expecting record, field, pointer, type or an array symbol')
+ InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
END
END
END PutAlignment ;
@@ -14628,10 +14631,11 @@ BEGIN
ArraySym : RETURN( Array.Align ) |
PointerSym : RETURN( Pointer.Align ) |
VarientFieldSym: RETURN( GetAlignment(VarientField.Parent) ) |
- VarientSym : RETURN( GetAlignment(Varient.Parent) )
+ VarientSym : RETURN( GetAlignment(Varient.Parent) ) |
+ SubrangeSym : RETURN( Subrange.Align )
ELSE
- InternalError ('expecting record, field, pointer, type or an array symbol')
+ InternalError ('expecting record, field, pointer, type, subrange or an array symbol')
END
END
END GetAlignment ;
diff --git a/gcc/m2/gm2-gcc/m2expr.cc b/gcc/m2/gm2-gcc/m2expr.cc
index 32222d25615..bb56a572320 100644
--- a/gcc/m2/gm2-gcc/m2expr.cc
+++ b/gcc/m2/gm2-gcc/m2expr.cc
@@ -2758,13 +2758,10 @@ noBitsRequired (tree values)
{
int bits = tree_floor_log2 (values);
- if (integer_pow2p (values))
- return m2decl_BuildIntegerConstant (bits + 1);
- else
- return m2decl_BuildIntegerConstant (bits + 1);
+ return m2decl_BuildIntegerConstant (bits + 1);
}
-/* getMax return the result of max(a, b). */
+/* getMax return the result of max (a, b). */
static tree
getMax (tree a, tree b)
@@ -2778,8 +2775,8 @@ getMax (tree a, tree b)
/* calcNbits return the smallest number of bits required to
represent: min..max. */
-static tree
-calcNbits (location_t location, tree min, tree max)
+tree
+m2expr_calcNbits (location_t location, tree min, tree max)
{
int negative = false;
tree t = testLimits (location, m2type_GetIntegerType (), min, max);
@@ -2832,7 +2829,7 @@ m2expr_BuildTBitSize (location_t location, tree type)
TYPE_MAX_VALUE (type), false);
min = m2convert_BuildConvert (location, m2type_GetIntegerType (),
TYPE_MIN_VALUE (type), false);
- return calcNbits (location, min, max);
+ return m2expr_calcNbits (location, min, max);
case BOOLEAN_TYPE:
return m2expr_GetIntegerOne (location);
default:
diff --git a/gcc/m2/gm2-gcc/m2expr.def b/gcc/m2/gm2-gcc/m2expr.def
index e8027a6ca55..e1ae799a7db 100644
--- a/gcc/m2/gm2-gcc/m2expr.def
+++ b/gcc/m2/gm2-gcc/m2expr.def
@@ -721,4 +721,12 @@ PROCEDURE ConstantExpressionWarning (value: Tree) ;
PROCEDURE BuildAddAddress (location: location_t; op1, op2: Tree) : Tree ;
+(*
+ calcNbits - return the smallest number of bits required to
+ represent: min..max.
+*)
+
+PROCEDURE calcNbits (location: location_t; min, max: Tree) : Tree ;
+
+
END m2expr.
diff --git a/gcc/m2/gm2-gcc/m2expr.h b/gcc/m2/gm2-gcc/m2expr.h
index d15f00b58d6..bf5e0b81d57 100644
--- a/gcc/m2/gm2-gcc/m2expr.h
+++ b/gcc/m2/gm2-gcc/m2expr.h
@@ -240,7 +240,7 @@ EXTERN tree m2expr_BuildAddAddress (location_t location, tree op1, tree op2);
EXTERN tree m2expr_BuildRDiv (location_t location, tree op1, tree op2,
bool needconvert);
EXTERN int m2expr_GetCstInteger (tree cst);
-
+EXTERN tree m2expr_calcNbits (location_t location, tree min, tree max);
EXTERN void m2expr_init (location_t location);
#undef EXTERN
diff --git a/gcc/m2/gm2-gcc/m2type.cc b/gcc/m2/gm2-gcc/m2type.cc
index 86edde50b72..f6a0f073b4d 100644
--- a/gcc/m2/gm2-gcc/m2type.cc
+++ b/gcc/m2/gm2-gcc/m2type.cc
@@ -894,22 +894,6 @@ m2type_GetCardinalAddressType (void)
return m2_cardinal_address_type_node;
}
-/* noBitsRequired returns the number of bits required to contain,
- values. How many bits are required to represent all numbers
- between: 0..values-1 */
-
-static tree
-noBitsRequired (tree values)
-{
- int bits = tree_floor_log2 (values);
-
- if (integer_pow2p (values))
- /* remember we start counting from zero. */
- return m2decl_BuildIntegerConstant (bits);
- else
- return m2decl_BuildIntegerConstant (bits + 1);
-}
-
#if 0
/* build_set_type creates a set type from the, domain, [low..high].
The values low..high all have type, range_type. */
@@ -1118,9 +1102,7 @@ m2type_BuildSmallestTypeRange (location_t location, tree low, tree high)
m2assert_AssertLocation (location);
low = fold (low);
high = fold (high);
- bits = fold (noBitsRequired (
- m2expr_BuildAdd (location, m2expr_BuildSub (location, high, low, false),
- m2expr_GetIntegerOne (location), false)));
+ bits = fold (m2expr_calcNbits (location, low, high));
return build_m2_specific_size_type (location, INTEGER_TYPE,
TREE_INT_CST_LOW (bits),
tree_int_cst_sgn (low) < 0);
@@ -2519,8 +2501,7 @@ m2type_BuildSubrangeType (location_t location, char *name, tree type,
error ("high bound for the subrange has overflowed");
/* First build a type with the base range. */
- range_type = build_range_type (type, TYPE_MIN_VALUE (type),
- TYPE_MAX_VALUE (type));
+ range_type = build_range_type (type, lowval, highval);
TYPE_UNSIGNED (range_type) = TYPE_UNSIGNED (type);
#if 0
diff --git a/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod b/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod
new file mode 100644
index 00000000000..627f9b6239a
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod
@@ -0,0 +1,49 @@
+MODULE packedrecord3 ; (*!m2iso+gm2*)
+
+FROM libc IMPORT printf, exit ;
+
+TYPE
+ subrange = [0..63] <* bytealignment (0) *> ;
+
+ packedrec = RECORD
+ <* bytealignment (0) *>
+ bool: BOOLEAN ;
+ col : (white, black) ;
+ sub : subrange ;
+ END ;
+
+
+VAR
+ global: subrange ;
+ pr : packedrec ;
+
+
+PROCEDURE test (s: subrange; level: CARDINAL) ;
+BEGIN
+ IF s # global
+ THEN
+ printf ("failed to pass %d into test\n", ORD (s)) ;
+ exit (1)
+ END ;
+ IF level > 0
+ THEN
+ test (s, level-1)
+ END
+END test ;
+
+
+BEGIN
+ IF SIZE (pr) # 1
+ THEN
+ printf ("test failed as SIZE (pr) should be 1 not %d\n", SIZE (pr)) ;
+ exit (1)
+ END ;
+ FOR global := MIN (subrange) TO MAX (subrange) DO
+ test (global, 2)
+ END ;
+ FOR global := MIN (subrange) TO MAX (subrange) DO
+ pr.bool := FALSE ;
+ pr.sub := global ;
+ test (pr.sub, 2)
+ END
+END packedrecord3.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-10-11 12:27 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-10-11 12:27 [gcc r14-4556] PR modula2/111675 Incorrect packed record field value passed to a procedure Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).