From 2b783fe2e8103d97db7c5d6c1514ba16091f39f6 Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Wed, 11 Oct 2023 13:26:47 +0100 Subject: [PATCH] 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 --- 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(-) create mode 100644 gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod 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.