From: Javier Miranda <mira...@adacore.com>
When an array of mutably tagged class-wide types is initialized
with an array aggregate, the compiler erroneously rejects it
reporting that the type of the aggregate cannot be a
class-wide type. In addition, Program_Error is not raised at
runtime on array type or record type objects when they have
mutably tagged abstract class-wide type components that are
initialized by default.
gcc/ada/ChangeLog:
* sem_aggr.adb (Resolve_Record_Aggregate): Adjust the code to
handle mutably tagged class-wide types since they don't have
discriminants, but all class-wide types are considered to have
unknown discriminants. Initialize mutably tagged class-wide
type components calling their IP subprogram.
* exp_aggr.adb (Gen_Assign): Handle mutably tagged class-wide type
components that have an initializing qualified expression, and
mutably tagged class-wide components default initialization.
(Gen_Loop): Handle mutably tagged class-wide types.
(Gen_Assign): ditto.
(Build_Record_Aggr_Code): Default initialization of mutably tagged
class-wide types is performed by their IP subprogram.
* exp_ch3.adb (Init_Component): Generate code to raise Program_Error
in the IP subprogram of arrays when the type of their components is
a mutably tagged abstract class-wide type.
(Build_Init_Procedure): ditto for the init procedure of record types.
(Build_Init_Statements): Ensure that the type of the expression
initializing a mutably class-wide tagged type component is frozen.
(Requires_Init_Proc): Mutably tagged class-wide types require the
init-proc since it takes care of their default initialization.
* sem_util.adb (Needs_Simple_Initialization): Mutably tagged class-wide
types don't require simple initialization.
* types.ads (PE_Abstract_Type_Component): New reason for Program_Error.
* types.h (PE_Abstract_Type_Component): ditto.
* exp_ch11.adb (Get_RT_Exception_Name): Handle new reason for
Program_Error.
* libgnat/a-except.adb (Rcheck_PE_Abstract_Type_Component): New
subprogram.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 244 ++++++++++++++++++++++++++---------
gcc/ada/exp_ch11.adb | 2 +
gcc/ada/exp_ch3.adb | 57 +++++++-
gcc/ada/libgnat/a-except.adb | 18 +++
gcc/ada/sem_aggr.adb | 28 +++-
gcc/ada/sem_util.adb | 5 -
gcc/ada/types.ads | 4 +-
gcc/ada/types.h | 5 +-
8 files changed, 288 insertions(+), 75 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index a25d28d2edd..e3734a2d8c9 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1407,6 +1407,23 @@ package body Exp_Aggr is
N_Iterated_Component_Association
then
null;
+
+ -- For mutably tagged class-wide type components that have an
+ -- initializing qualified expression, the expression must be
+ -- analyzed and resolved using the type of the qualified
+ -- expression; otherwise spurious errors would be reported
+ -- because components defined in derivations of the root type
+ -- of the mutably tagged class-wide type would not be visible.
+
+ -- Resolve_Aggr_Expr has previously checked that the type of
+ -- the qualified expression is a descendant of the root type
+ -- of the mutably class-wide tagged type.
+
+ elsif Is_Mutably_Tagged_Type (Comp_Typ)
+ and then Nkind (Expr) = N_Qualified_Expression
+ then
+ Analyze_And_Resolve (Expr_Q, Etype (Expr));
+
else
Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
@@ -1440,12 +1457,54 @@ package body Exp_Aggr is
end if;
if Present (Expr) then
- Initialize_Component
- (N => N,
- Comp => Indexed_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Expr,
- Stmts => Stmts);
+
+ -- 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;
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
@@ -1459,14 +1518,21 @@ package body Exp_Aggr is
-- object creation that will invoke it otherwise.
else
- if Present (Base_Init_Proc (Ctype)) then
+ -- For mutably tagged class-wide types, default initialization is
+ -- performed by the init procedure of their root type.
+
+ if Is_Mutably_Tagged_Type (Comp_Typ) then
+ Comp_Typ := Root_Type (Comp_Typ);
+ end if;
+
+ if Present (Base_Init_Proc (Comp_Typ)) then
Check_Restriction (No_Default_Initialization, N);
if not Restriction_Active (No_Default_Initialization) then
Append_List_To (Stmts,
Build_Initialization_Call (N,
Id_Ref => Indexed_Comp,
- Typ => Ctype,
+ Typ => Comp_Typ,
With_Default_Init => True));
end if;
@@ -1475,17 +1541,17 @@ package body Exp_Aggr is
-- be analyzed and resolved before the code for initialization
-- of other components.
- if Has_Invariants (Ctype) then
- Set_Etype (Indexed_Comp, Ctype);
+ if Has_Invariants (Comp_Typ) then
+ Set_Etype (Indexed_Comp, Comp_Typ);
Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
end if;
end if;
- if Needs_Finalization (Ctype) then
+ if Needs_Finalization (Comp_Typ) then
Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype);
+ Typ => Comp_Typ);
-- Guard against a missing [Deep_]Initialize when the component
-- type was not properly frozen.
@@ -1506,9 +1572,13 @@ package body Exp_Aggr is
-- is not empty, but a default init still applies, such as for
-- Default_Value cases, in which case we won't get here. ???
- if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
+ if Has_DIC (Comp_Typ)
+ and then Present (DIC_Procedure (Comp_Typ))
+ then
Append_To (Stmts,
- Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
+ Build_DIC_Call (Loc,
+ Obj_Name => New_Copy_Tree (Indexed_Comp),
+ Typ => Comp_Typ));
end if;
end if;
@@ -1520,6 +1590,8 @@ package body Exp_Aggr is
--------------
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
+ Comp_Typ : Entity_Id;
+
Is_Iterated_Component : constant Boolean :=
Parent_Kind (Expr) = N_Iterated_Component_Association;
@@ -1575,6 +1647,12 @@ package body Exp_Aggr is
Tcopy := New_Copy_Tree (Expr);
Set_Parent (Tcopy, N);
+ Comp_Typ := Component_Type (Etype (N));
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Typ) then
+ Comp_Typ := Corresponding_Mutably_Tagged_Type (Comp_Typ);
+ end if;
+
-- For iterated_component_association analyze and resolve
-- the expression with name of the index parameter visible.
-- To manipulate scopes, we use entity of the implicit loop.
@@ -1586,8 +1664,7 @@ package body Exp_Aggr is
begin
Push_Scope (Scope (Index_Parameter));
Enter_Name (Index_Parameter);
- Analyze_And_Resolve
- (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
End_Scope;
end;
@@ -1595,7 +1672,7 @@ package body Exp_Aggr is
-- resolve the expression.
else
- Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
end if;
Expander_Mode_Restore;
@@ -2132,6 +2209,7 @@ package body Exp_Aggr is
Set_Loop_Actions (Others_Assoc, New_List);
First := False;
end if;
+
Expr := Get_Assoc_Expr (Others_Assoc);
Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
end if;
@@ -3269,54 +3347,85 @@ package body Exp_Aggr is
-- a call to the corresponding IP subprogram if available.
elsif Box_Present (Comp)
- and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
+ and then
+ (Has_Non_Null_Base_Init_Proc (Etype (Selector))
+
+ -- Default initialization of mutably tagged class-wide type
+ -- components is performed by the IP subprogram.
+
+ or else Is_Class_Wide_Equivalent_Type (Etype (Selector)))
then
- Check_Restriction (No_Default_Initialization, N);
-
- if Ekind (Selector) /= E_Discriminant then
- Generate_Finalization_Actions;
- end if;
-
- -- Ada 2005 (AI-287): If the component type has tasks then
- -- generate the activation chain and master entities (except
- -- in case of an allocator because in that case these entities
- -- are generated by Build_Task_Allocate_Block).
-
declare
- Ctype : constant Entity_Id := Etype (Selector);
- Inside_Allocator : Boolean := False;
- P : Node_Id := Parent (N);
+ Ctype : Entity_Id := Etype (Selector);
begin
- if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
- while Present (P) loop
- if Nkind (P) = N_Allocator then
- Inside_Allocator := True;
- exit;
+ if Is_Class_Wide_Equivalent_Type (Ctype) then
+ Ctype :=
+ Root_Type (Corresponding_Mutably_Tagged_Type (Ctype));
+ end if;
+
+ Check_Restriction (No_Default_Initialization, N);
+
+ if Ekind (Selector) /= E_Discriminant then
+ Generate_Finalization_Actions;
+ end if;
+
+ -- Ada 2005 (AI-287): If the component type has tasks then
+ -- generate the activation chain and master entities (except
+ -- in case of an allocator because in that case these entities
+ -- are generated by Build_Task_Allocate_Block).
+
+ declare
+ Inside_Allocator : Boolean := False;
+ P : Node_Id := Parent (N);
+
+ begin
+ if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
+ while Present (P) loop
+ if Nkind (P) = N_Allocator then
+ Inside_Allocator := True;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if not Inside_Init_Proc and not Inside_Allocator then
+ Build_Activation_Chain_Entity (N);
end if;
+ end if;
+ end;
- P := Parent (P);
- end loop;
+ if not Restriction_Active (No_Default_Initialization) then
+ Append_List_To (L,
+ Build_Initialization_Call (N,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Selector, Loc)),
+ Typ => Ctype,
+ Enclos_Type => Typ,
+ With_Default_Init => True));
- if not Inside_Init_Proc and not Inside_Allocator then
- Build_Activation_Chain_Entity (N);
+ if Is_Class_Wide_Equivalent_Type (Etype (Selector))
+ and then Is_Abstract_Type (Ctype)
+ then
+ Error_Msg_Name_1 := Chars (Selector);
+ Error_Msg_N
+ ("default initialization of abstract type "
+ & "component % not allowed??", Comp);
+ Error_Msg_N
+ ("\Program_Error will be raised at run time??", Comp);
+
+ Append_To (L,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
end if;
end if;
end;
- if not Restriction_Active (No_Default_Initialization) then
- Append_List_To (L,
- Build_Initialization_Call (N,
- Id_Ref => Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of (Selector, Loc)),
- Typ => Etype (Selector),
- Enclos_Type => Typ,
- With_Default_Init => True));
- end if;
-
-- Prepare for component assignment
elsif Ekind (Selector) /= E_Discriminant
@@ -3473,12 +3582,27 @@ package body Exp_Aggr is
end if;
end if;
- Initialize_Component
- (N => N,
- Comp => Comp_Expr,
- Comp_Typ => Etype (Selector),
- Init_Expr => Expr_Q,
- Stmts => L);
+ -- For mutably tagged class-wide components with a qualified
+ -- initializing expressions use the qualified expression as
+ -- its Init_Expr; required to avoid reporting spurious errors.
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Type)
+ and then Nkind (Expression (Comp)) = N_Qualified_Expression
+ then
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expression (Comp),
+ Stmts => L);
+ else
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
-- comment would be good here ???
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index b00e75edb2f..ee6010a7444 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -1970,6 +1970,8 @@ package body Exp_Ch11 is
when CE_Tag_Check_Failed =>
Add_Str_To_Name_Buffer ("CE_Tag_Check");
+ when PE_Abstract_Type_Component =>
+ Add_Str_To_Name_Buffer ("PE_Abstract_Type_Component");
when PE_Access_Before_Elaboration =>
Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration");
when PE_Accessibility_Check_Failed =>
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index a4e6512410a..bdadac6cc13 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -671,7 +671,8 @@ package body Exp_Ch3 is
--------------------
function Init_Component return List_Id is
- Comp : Node_Id;
+ Comp : Node_Id;
+ Result : List_Id;
begin
Comp :=
@@ -681,7 +682,7 @@ package body Exp_Ch3 is
if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
@@ -690,7 +691,7 @@ package body Exp_Ch3 is
elsif Comp_Simple_Init then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
@@ -701,7 +702,7 @@ package body Exp_Ch3 is
else
Clean_Task_Names (Comp_Type, Proc_Id);
- return
+ Result :=
Build_Initialization_Call
(N => Nod,
Id_Ref => Comp,
@@ -709,6 +710,19 @@ package body Exp_Ch3 is
In_Init_Proc => True,
Enclos_Type => A_Type);
end if;
+
+ -- Raise Program_Error in the init procedure of arrays when the type
+ -- of their components is a mutably tagged abstract class-wide type.
+
+ if Is_Class_Wide_Equivalent_Type (Component_Type (A_Type))
+ and then Is_Abstract_Type (Comp_Type)
+ then
+ Append_To (Result,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
+ return Result;
end Init_Component;
------------------------
@@ -3325,6 +3339,17 @@ package body Exp_Ch3 is
Make_Tag_Assignment_From_Type
(Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
+ -- Ensure that Program_Error is raised if a mutably class-wide
+ -- abstract tagged type is initialized by default.
+
+ if Is_Abstract_Type (Rec_Type)
+ and then Is_Mutably_Tagged_Type (Class_Wide_Type (Rec_Type))
+ then
+ Append_To (Init_Tags_List,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
-- variable size components are initialized later ---see below)
@@ -3746,6 +3771,16 @@ package body Exp_Ch3 is
-- Explicit initialization
if Present (Expression (Decl)) then
+
+ -- Ensure that the type of the expression initializing a
+ -- mutably tagged class-wide type component is frozen.
+
+ if Nkind (Expression (Decl)) = N_Qualified_Expression
+ and then Is_Class_Wide_Equivalent_Type (Etype (Id))
+ then
+ Freeze_Before (N, Etype (Expression (Decl)));
+ end if;
+
if Is_CPP_Constructor_Call (Expression (Decl)) then
Actions :=
Build_Initialization_Call
@@ -3917,6 +3952,15 @@ package body Exp_Ch3 is
Discr_Map => Discr_Map,
Init_Control_Actual => Init_Control_Actual);
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Id))
+ and then not Is_Parent
+ and then Is_Abstract_Type (Typ)
+ then
+ Append_To (Init_Call_Stmts,
+ Make_Raise_Program_Error (Comp_Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
if Is_Parent then
-- This is tricky. At first it looks like
-- we are going to end up with nested
@@ -4537,6 +4581,11 @@ package body Exp_Ch3 is
if Present (Expression (Comp_Decl))
or else Has_Non_Null_Base_Init_Proc (Typ)
or else Component_Needs_Simple_Initialization (Typ)
+
+ -- Mutably tagged class-wide types require the init-proc since
+ -- it takes care of their default initialization.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
then
return True;
end if;
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index c7766232785..d0a1d7f98e2 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -450,6 +450,8 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_CE_Tag_Check
(File : System.Address; Line : Integer);
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer);
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Accessibility_Check
@@ -542,6 +544,8 @@ package body Ada.Exceptions is
"__gnat_rcheck_CE_Range_Check");
pragma Export (C, Rcheck_CE_Tag_Check,
"__gnat_rcheck_CE_Tag_Check");
+ pragma Export (C, Rcheck_PE_Abstract_Type_Component,
+ "__gnat_rcheck_PE_Abstract_Type_Component");
pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
"__gnat_rcheck_PE_Access_Before_Elaboration");
pragma Export (C, Rcheck_PE_Accessibility_Check,
@@ -620,6 +624,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_CE_Partition_Check);
pragma No_Return (Rcheck_CE_Range_Check);
pragma No_Return (Rcheck_CE_Tag_Check);
+ pragma No_Return (Rcheck_PE_Abstract_Type_Component);
pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
pragma No_Return (Rcheck_PE_Accessibility_Check);
pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
@@ -683,6 +688,8 @@ package body Ada.Exceptions is
"expected_throw");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"expected_throw");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "expected_throw");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"expected_throw");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
@@ -775,6 +782,8 @@ package body Ada.Exceptions is
"strub", "callable");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"strub", "callable");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
@@ -885,6 +894,8 @@ package body Ada.Exceptions is
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
Rmsg_38 : constant String := "raise check failed" & NUL;
+ Rmsg_39 : constant String := "initialization of abstract type" &
+ " component not allowed" & NUL;
---------
-- AAA --
@@ -1471,6 +1482,13 @@ package body Ada.Exceptions is
Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
end Rcheck_CE_Tag_Check;
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_39'Address);
+ end Rcheck_PE_Abstract_Type_Component;
+
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer)
is
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 1bcb4b9e823..58460b8e3bb 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -6355,7 +6355,12 @@ package body Sem_Aggr is
& "has unknown discriminants", N, Typ);
end if;
- if Has_Unknown_Discriminants (Typ)
+ -- Mutably tagged class-wide types do not have discriminants;
+ -- however, all class-wide types are considered to have unknown
+ -- discriminants.
+
+ if not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
Discrim := First_Discriminant (Underlying_Record_View (Typ));
@@ -6427,7 +6432,13 @@ package body Sem_Aggr is
-- STEP 4: Set the Etype of the record aggregate
if Has_Discriminants (Typ)
- or else (Has_Unknown_Discriminants (Typ)
+
+ -- Handle types with unknown discriminants, excluding mutably tagged
+ -- class-wide types because, although they do not have discriminants,
+ -- all class-wide types are considered to have unknown discriminants.
+
+ or else (not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype (N, Typ, New_Assoc_List);
@@ -6598,7 +6609,13 @@ package body Sem_Aggr is
if Null_Present (Record_Def) then
null;
- elsif not Has_Unknown_Discriminants (Typ) then
+ -- Explicitly add here mutably class-wide types because they do
+ -- not have discriminants; however, all class-wide types are
+ -- considered to have unknown discriminants.
+
+ elsif not Has_Unknown_Discriminants (Typ)
+ or else Is_Mutably_Tagged_Type (Typ)
+ then
Gather_Components
(Base_Type (Typ),
Component_List (Record_Def),
@@ -6784,6 +6801,11 @@ package body Sem_Aggr is
Set_Has_Self_Reference (N);
elsif Needs_Simple_Initialization (Ctyp)
+
+ -- Mutably tagged class-wide type components are initialized
+ -- by the expander calling their IP subprogram.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Ctyp)
or else Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 127728ab601..af7e48b1eca 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -23200,11 +23200,6 @@ package body Sem_Util is
then
return True;
- -- Mutably tagged types require default initialization
-
- elsif Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
- return True;
-
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 21701de7699..8869d0120f9 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -947,7 +947,8 @@ package Types is
SE_Object_Too_Large, -- 35
PE_Stream_Operation_Not_Allowed, -- 36
PE_Build_In_Place_Mismatch, -- 37
- PE_Raise_Check_Failed); -- 38
+ PE_Raise_Check_Failed, -- 38
+ PE_Abstract_Type_Component); -- 39
pragma Convention (C, RT_Exception_Code);
Last_Reason_Code : constant :=
@@ -973,6 +974,7 @@ package Types is
CE_Range_Check_Failed => CE_Reason,
CE_Tag_Check_Failed => CE_Reason,
+ PE_Abstract_Type_Component => PE_Reason,
PE_Access_Before_Elaboration => PE_Reason,
PE_Accessibility_Check_Failed => PE_Reason,
PE_Address_Of_Intrinsic => PE_Reason,
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index 007dc248b2c..d0a1a04f979 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -431,7 +431,8 @@ enum RT_Exception_Code
SE_Object_Too_Large = 35,
PE_Stream_Operation_Not_Allowed = 36,
PE_Build_In_Place_Mismatch = 37,
- PE_Raise_Check_Failed = 38
+ PE_Raise_Check_Failed = 38,
+ PE_Abstract_Type_Component = 39
};
-#define LAST_REASON_CODE 38
+#define LAST_REASON_CODE 39
--
2.43.0
