procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR modula2/111675 Incorrect packed record field value passed to a procedure

Browse source 
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>
This commit is contained in:
Gaius Mulley 2023-10-11 13:26:47 +01:00
parent f6c5e247b2
commit 2b783fe2e8
10 changed files with 118 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gcc/m2/gm2-compiler/M2CaseList.mod
View file

@ -975,7 +975,7 @@ BEGIN
appendString (InitStringChar ("'"))
END
ELSE
appendString (InitStringCharStar ('CHR (')) ;
appendString (InitString ('CHR (')) ;
appendString (InitStringCharStar (CSTIntToString (value))) ;
appendString (InitStringChar (')'))
END

38
gcc/m2/gm2-compiler/M2GCCDeclare.mod
View file

@ -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 ;

2
gcc/m2/gm2-compiler/M2Quads.mod
View file

@ -2594,7 +2594,7 @@ BEGIN
PushTtok (m2strnul, tok) ;
PushT (1) ;
BuildAdrFunction
END BuildAdrFunction ;
END BuildStringAdrParam ;
(*

23
gcc/m2/gm2-compiler/P2SymBuild.mod
View file

@ -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 ;

12
gcc/m2/gm2-compiler/SymbolTable.mod
View file

@ -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 ;

13
gcc/m2/gm2-gcc/m2expr.cc
View file

@ -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:

8
gcc/m2/gm2-gcc/m2expr.def
View file

@ -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.

2
gcc/m2/gm2-gcc/m2expr.h
View file

@ -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

23
gcc/m2/gm2-gcc/m2type.cc
View file

@ -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

49
gcc/testsuite/gm2/extensions/run/pass/packedrecord3.mod Normal file
View file

@ -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.