https://gcc.gnu.org/g:92491369652cb738287fbe31295e4ef0a8e6c394
commit r16-2335-g92491369652cb738287fbe31295e4ef0a8e6c394
Author: Javier Miranda <mira...@adacore.com>
Date: Tue Jun 17 13:09:11 2025 +0000
ada: Array aggregates of mutably tagged objects (part 2)
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.
Diff:
---
gcc/ada/exp_aggr.adb | 68 +++++++++++++---------------------------------------
1 file changed, 17 insertions(+), 51 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 9ff69ec81301..bdb4c8556f2e 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -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);
