VladPolskiy/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2025-07-21 23:52:54 +00:00
Code Issues Packages Projects Releases Wiki Activity

ada: Array aggregates of mutably tagged objects (part 2)

Browse Source 
gcc/ada/ChangeLog:

	* exp_aggr.adb (Gen_Assign): Code cleanup.
	(Initialize_Component): Do not adjust the tag when the type of
	the aggregate components is a mutably tagged type.
This commit is contained in:
Javier Miranda
2025-06-17 13:09:11 +00:00
committed by Marc Poulhiès
parent 9e33097738
commit 9249136965
1 changed files with 17 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
gcc/ada/exp_aggr.adb
View File

@ -1457,54 +1457,12 @@ package body Exp_Aggr is
end if;
if Present (Expr) then
-- For mutably tagged abstract class-wide types, we rely on the
-- type of the initializing expression to initialize the tag of
-- each array component.
-- Generate:
-- expr_type!(Indexed_Comp) := expr;
-- expr_type!(Indexed_Comp)._tag := expr_type'Tag;
if Is_Mutably_Tagged_Type (Comp_Typ)
and then Is_Abstract_Type (Root_Type (Comp_Typ))
then
declare
Expr_Type : Entity_Id;
begin
if Nkind (Expr) in N_Has_Etype
and then Present (Etype (Expr))
then
Expr_Type := Etype (Expr);
elsif Nkind (Expr) = N_Qualified_Expression then
Analyze (Subtype_Mark (Expr));
Expr_Type := Etype (Subtype_Mark (Expr));
-- Unsupported case
else
pragma Assert (False);
raise Program_Error;
end if;
Initialize_Component
(N => N,
Comp => Unchecked_Convert_To (Expr_Type,
Indexed_Comp),
Comp_Typ => Expr_Type,
Init_Expr => Expr,
Stmts => Stmts);
end;
else
Initialize_Component
(N => N,
Comp => Indexed_Comp,
Comp_Typ => Comp_Typ,
Init_Expr => Expr,
Stmts => Stmts);
end if;
Initialize_Component
(N => N,
Comp => Indexed_Comp,
Comp_Typ => Comp_Typ,
Init_Expr => Expr,
Stmts => Stmts);
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
@ -1519,10 +1477,10 @@ package body Exp_Aggr is
else
-- For mutably tagged class-wide types, default initialization is
-- performed by the init procedure of their root type.
-- performed by the init procedure of their specific type.
if Is_Mutably_Tagged_Type (Comp_Typ) then
Comp_Typ := Root_Type (Comp_Typ);
Comp_Typ := Find_Specific_Type (Comp_Typ);
end if;
if Present (Base_Init_Proc (Comp_Typ)) then
@ -8864,7 +8822,15 @@ package body Exp_Aggr is
else
Set_No_Ctrl_Actions (Init_Stmt);
if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
if Tagged_Type_Expansion
and then Is_Tagged_Type (Comp_Typ)
-- Cannot adjust the tag when the expected type of the component is
-- a mutably tagged (and therefore class-wide) type; each component
-- of the aggregate has the tag of its initializing expression.
and then not Is_Mutably_Tagged_Type (Comp_Typ)
then
declare
Typ : Entity_Id := Underlying_Type (Comp_Typ);