Descendants of a mutably tagged type may have controlled components, unless
the No_Controlled_Parts aspect is specified alongside the Size'Class aspect,
but their finalization is not correctly performed by the implementation.
The change also prevents finalization boilerplate code from being generated
for class-wide objects of regular tagged types when the No_Controlled_Parts
aspect is specified.
It also contains a couple of fixes for Might_Have_Tasks and Find_Type_Name.
Tested on x86-64/Linux, applied on the mainline.
2026-09-22 Eric Botcazou <[email protected]>
* gen_il-gen-gen_entities.adb (Type_Kind): Set Base_Type_Only for
Is_Mutably_Tagged_Type flag. Move Class_Wide_Equivalent_Type to...
(Class_Wide_Kind): ...here.
* einfo.ads (Class_Wide_Equivalent_Type): Adjust description.
(Is_Controlled_Active): Likewise.
(Is_Controlled): Likewise.
(Is_Mutably_Tagged_Type): Likewise.
* exp_ch3.adb (Expand_N_Full_Type_Declaration): Use an assignment to
initialize an object of a mutably tagged type whose initial value is
not the result of a function call.
* exp_ch5.adb (Expand_N_Assignment_Statement): Do not dispatch to an
_assign primitive for an initialization even in the class-wide case.
For mutably tagged types, assign the tag unconditionally.
(Make_Tag_Ctrl_Assignment): Deal with mutably tagged types.
* exp_ch6.adb (Might_Have_Tasks): Invoke Has_Enabled_Aspect on the
root type for a class-wide type.
* exp_ch7.adb: Add clauses for Mutably_Tagged package.
(Make_Adjust_Call): Deal with mutably tagged types.
(Make_Final_Call): Likewise.
(Make_Init_Call): Likewise.
* exp_util.adb: Add clauses for Mutably_Tagged package.
(Finalize_Address): Deal with mutably tagged types.
(Make_CW_Equivalent_Type): Adjust comment.
* freeze.adb (Freeze_Record_Type): Invoke Needs_Finalization on the
type of the components to compute the Has_Controlled_Component flag.
* mutably_tagged.ads (Get_Corresponding_Tagged_Type_If_Present):
Adjust description.
* mutably_tagged.adb (Is_Mutably_Tagged_CW_Equivalent_Type): Test
Is_Mutably_Tagged_Type on the class-wide type of the parent subtype.
* sem_ch3.adb (Find_Type_Name): Do not set the Is_Internal flag on
the completion of an incomplete type.
(Record_Type_Definition): Invoke Needs_Finalization on the type of
the components to compute the Has_Controlled_Component flag.
* sem_ch12.adb (Validate_Private_Type_Instance): Test the
Is_Mutably_Tagged_Type flag instead of Class_Wide_Equivalent_Type.
(Instantiate_Type): Likewise.
* sem_util.adb (Needs_Finalization): Return False for a class-wide
type if the root type has the No_Controlled_Parts aspect, and return
True for a mutably tagged class-wide equivalent type unless the root
type has the No_Controlled_Parts aspect.
--
Eric Botcazoudiff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 73d684890ee..c69aec8baf7 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -650,9 +650,9 @@ package Einfo is
-- the corresponding implicitly declared class-wide type. For a
-- class-wide type, returns itself. Set to Empty for untagged types.
--- Class_Wide_Equivalent_Type
--- Defined in all type entities. Used to store an internally generated
--- class-wide equivalent type for an associated mutably tagged type.
+-- Class_Wide_Equivalent_Type [base type only]
+-- Defined in class-wide types. Used to store an internally generated
+-- class-wide equivalent type for a mutably tagged type.
-- Cloned_Subtype
-- Defined in E_Record_Subtype and E_Class_Wide_Subtype entities.
@@ -2603,17 +2603,16 @@ package Einfo is
-- that the constructed subtype itself will be constrained.
-- Is_Controlled_Active [base type only]
--- Defined in all type entities. Indicates that the type is controlled,
--- i.e. has been declared with the Finalizable or the Destructor aspect
--- or has inherited the aspect from an ancestor. Can only be set for
--- record types, tagged or untagged.
--- System.Finalization_Root.Root_Controlled is an example of the former
--- case while Ada.Finalization.Controlled and
+-- Defined in all types. Set only for record types, tagged or untagged.
+-- Indicates that the type is controlled, i.e. has been declared with
+-- the Finalizable or the Destructor aspect, or has inherited one of the
+-- aspects from an ancestor. System.Finalization_Root.Root_Controlled is
+-- an example of the former case, while Ada.Finalization.Controlled and
-- Ada.Finalization.Limited_Controlled are examples of the latter.
-- Is_Controlled (synth) [base type only]
--- Defined in all type entities. Set if Is_Controlled_Active is set for
--- the type, and Disable_Controlled is not set.
+-- Defined in all type entities. Set if both Is_Controlled_Active is set
+-- and Disable_Controlled is not set for the type.
-- Is_Controlling_Formal
-- Defined in all Formal_Kind entities. Marks the controlling parameters
@@ -3117,8 +3116,8 @@ package Einfo is
-- Is_Modular_Integer_Type (synthesized)
-- Applies to all entities. True if entity is a modular integer type
--- Is_Mutably_Tagged_Type
--- Defined in all type entities. Used to signify that a given type is a
+-- Is_Mutably_Tagged_Type [base type only]
+-- Defined in all types and subtypes. Set to indicate that the type is a
-- "mutably tagged" class-wide type where 'Size'Class has been specified.
-- Is_Non_Static_Subtype
@@ -5173,6 +5172,7 @@ package Einfo is
-- Is_Frozen
-- Is_Generic_Actual_Type
-- Is_Independent
+ -- Is_Mutably_Tagged_Type (base type only)
-- Is_Non_Static_Subtype
-- Is_Packed (base type only)
-- Is_Private_Composite
@@ -5354,6 +5354,7 @@ package Einfo is
-- Direct_Primitive_Operations
-- Cloned_Subtype (subtype case only)
-- First_Entity
+ -- Class_Wide_Equivalent_Type (base type only)
-- Equivalent_Type (always Empty for type)
-- Non_Limited_View
-- Last_Entity
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 5372b8a7435..c57949eb425 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6994,8 +6994,7 @@ package body Exp_Ch3 is
if Ekind (Etype (Comp)) /= E_Void
and then Is_Mutably_Tagged_Type (Etype (Comp))
then
- Set_Etype
- (Comp, Class_Wide_Equivalent_Type (Etype (Comp)));
+ Set_Etype (Comp, Class_Wide_Equivalent_Type (Etype (Comp)));
end if;
Next_Entity (Comp);
end loop;
@@ -8672,6 +8671,28 @@ package body Exp_Ch3 is
and then OK_To_Rename_Ref (Prefix (Expr_Q))
and then not Special_Ret_Obj));
+ -- If the object is of a mutably tagged type and is initialized
+ -- by something other than a function call, do the initialization
+ -- as an assignment so that only the bits present in the initial
+ -- value are copied.
+
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
+ and then Nkind (Expr_Q) /= N_Function_Call
+ and then not Rewrite_As_Renaming
+ then
+ declare
+ Stat : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression => Relocate_Node (Expr));
+ begin
+ Set_Assignment_OK (Name (Stat));
+ Set_No_Finalize_Actions (Stat);
+ Insert_Action_After (Init_After, Stat);
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
+ end;
+
-- If the type needs finalization and is not inherently limited,
-- then the target is adjusted after the copy and attached to the
-- finalization list. However, no adjustment is needed in the case
@@ -8683,7 +8704,7 @@ package body Exp_Ch3 is
-- Similarly, no adjustment is needed if we are going to rewrite
-- the object declaration into a renaming declaration.
- if Needs_Finalization (Typ)
+ elsif Needs_Finalization (Typ)
and then not Is_Inherently_Limited_Type (Typ)
and then Nkind (Expr_Q) /= N_Function_Call
and then not Is_Two_Pass_Aggregate (Expr_Q)
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index cf473331749..63c6cb9798a 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2480,7 +2480,7 @@ package body Exp_Ch5 is
begin
-- Handle chains of renamings
- Ent := Name (N);
+ Ent := Lhs;
while Nkind (Ent) in N_Has_Entity
and then Present (Entity (Ent))
and then Is_Object (Entity (Ent))
@@ -2967,18 +2967,18 @@ package body Exp_Ch5 is
-- If dispatching assignment, we need to dispatch to _assign
- if Is_Class_Wide_Type (Typ)
+ if (Is_Class_Wide_Type (Typ) and then Expand_Ctrl_Actions)
-- If the type is tagged, we may as well use the predefined
-- primitive assignment. This avoids inlining a lot of code
-- and in the class-wide case, the assignment is replaced
-- by a dispatching call to _assign. It is suppressed in the
-- case of assignments created by the expander that correspond
- -- to initializations, where we do want to copy the tag
- -- (Expand_Ctrl_Actions flag is set False in this case). It is
- -- also suppressed if restriction No_Dispatching_Calls is in
- -- force because in that case predefined primitives are not
- -- generated.
+ -- to initializations, where we do not want to finalize the
+ -- target (Expand_Ctrl_Actions is set to False in this case).
+ -- It is also suppressed if restriction No_Dispatching_Calls
+ -- is in force because in that case predefined primitives are
+ -- not generated.
or else (Is_Tagged_Type (Typ)
and then Chars (Current_Scope) /= Name_uAssign
@@ -3015,13 +3015,70 @@ package body Exp_Ch5 is
L := New_List;
- -- In case of assignment to a class-wide tagged type, before
- -- the assignment we generate run-time check to ensure that
- -- the tags of source and target match.
+ -- Handle assignment of a mutably tagged type
- if not Tag_Checks_Suppressed (Typ)
+ if Is_Mutably_Tagged_Type (Typ) then
+ declare
+ Lhs_Tag : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
+
+ Rhs_Tag : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
+
+ begin
+ -- Create a tag check when we have the extra
+ -- constrained formal and it is true (meaning we
+ -- are not dealing with a mutably tagged object).
+
+ if not Tag_Checks_Suppressed (Typ)
+ and then Is_Entity_Name (Lhs)
+ and then Is_Formal (Entity (Lhs))
+ and then Present (Extra_Constrained (Entity (Lhs)))
+ then
+ Append_To (L,
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of
+ (Extra_Constrained (Entity (Lhs)), Loc),
+ Then_Statements => New_List (
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Lhs_Tag,
+ Right_Opnd => Rhs_Tag),
+ Reason => CE_Tag_Check_Failed))));
+ end if;
+
+ -- Generate a tag assignment before the actual
+ -- assignment so we dispatch to the proper
+ -- assign version.
+
+ Append_To (L,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag)),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag))));
+ end;
+
+ -- For the assignment of a regular class-wide type, generate
+ -- a run-time check to ensure that the tag of the source and
+ -- that of the target match.
+
+ elsif not Tag_Checks_Suppressed (Typ)
and then Is_Class_Wide_Type (Typ)
- and then Is_Tagged_Type (Typ)
and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
then
declare
@@ -3029,18 +3086,7 @@ package body Exp_Ch5 is
Rhs_Tag : Node_Id;
begin
- if not Is_Interface (Typ) then
- Lhs_Tag :=
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag));
- Rhs_Tag :=
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag));
- else
+ if Is_Interface (Typ) then
-- Displace the pointer to the base of the objects
-- applying 'Address, which is later expanded into
-- a call to RE_Base_Address.
@@ -3059,66 +3105,26 @@ package body Exp_Ch5 is
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Attribute_Name => Name_Address)));
- end if;
-
- -- Handle assignment to a mutably tagged type
-
- if Is_Mutably_Tagged_Conversion (Lhs)
- or else Is_Mutably_Tagged_Type (Typ)
- or else Is_Mutably_Tagged_Type (Etype (Lhs))
- then
- -- Create a tag check when we have the extra
- -- constrained formal and it is true (meaning we
- -- are not dealing with a mutably tagged object).
-
- if Is_Entity_Name (Name (N))
- and then Is_Formal (Entity (Name (N)))
- and then Present
- (Extra_Constrained (Entity (Name (N))))
- then
- Append_To (L,
- Make_If_Statement (Loc,
- Condition =>
- New_Occurrence_Of
- (Extra_Constrained
- (Entity (Name (N))), Loc),
- Then_Statements => New_List (
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => Lhs_Tag,
- Right_Opnd => Rhs_Tag),
- Reason => CE_Tag_Check_Failed))));
- end if;
-
- -- Generate a tag assignment before the actual
- -- assignment so we dispatch to the proper
- -- assign version.
-
- Append_To (L,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag)),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag))));
-
- -- Otherwise generate a normal tag check
-
else
- Append_To (L,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => Lhs_Tag,
- Right_Opnd => Rhs_Tag),
- Reason => CE_Tag_Check_Failed));
+ Lhs_Tag :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
+ Rhs_Tag :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
end if;
+
+ Append_To (L,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Lhs_Tag,
+ Right_Opnd => Rhs_Tag),
+ Reason => CE_Tag_Check_Failed));
end;
end if;
@@ -3147,7 +3153,7 @@ package body Exp_Ch5 is
end;
end;
- -- Untagged case
+ -- Untagged case, or initialization in tagged case
else
declare
@@ -6494,13 +6500,16 @@ package body Exp_Ch5 is
Ctrl_Act : constant Boolean := Needs_Finalization (T)
and then not No_Ctrl_Actions (N)
and then not No_Finalize_Actions (N);
+ Mute_Tag : constant Boolean := Is_Mutably_Tagged_CW_Equivalent_Type (T);
Save_Tag : constant Boolean := Is_Tagged_Type (T)
and then not Comp_Asn
+ and then not Mute_Tag
and then not No_Ctrl_Actions (N)
and then not No_Finalize_Actions (N)
and then Tagged_Type_Expansion;
Set_Tag : constant Boolean := Is_Tagged_Type (T)
and then not Comp_Asn
+ and then not Mute_Tag
and then not No_Ctrl_Actions (N)
and then Tagged_Type_Expansion;
Adj_Call : Node_Id;
@@ -6580,6 +6589,17 @@ package body Exp_Ch5 is
if Comp_Asn then
Set_Analyzed (New_N, False);
Set_Componentwise_Assignment (New_N, True);
+
+ -- If this is an assignment of a mutably tagged type, we need to assign
+ -- only the bits present in the source, so we strip a conversion to the
+ -- mutably tagged type so as to expose the source to the code generator.
+
+ elsif Mute_Tag
+ and then Nkind (Expression (N)) in N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ and then Etype (Expression (N)) = Corresponding_Mutably_Tagged_Type (T)
+ then
+ Rewrite (Expression (New_N), Expression (Expression (N)));
end if;
Append_To (Res, New_N);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 1441aa82838..caa2e1e7d3c 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9682,8 +9682,8 @@ package body Exp_Ch6 is
and then (Has_Task (Typ)
or else (Is_Class_Wide_Type (Typ)
and then Is_Limited_Record (Typ)
- and then not Has_Aspect
- (Etype (Typ), Aspect_No_Task_Parts)));
+ and then not Has_Enabled_Aspect
+ (Root_Type (Typ), Aspect_No_Task_Parts)));
end Might_Have_Tasks;
----------------------------
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 11c86895aa1..338a5de8057 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -46,6 +46,7 @@ with Freeze; use Freeze;
with GNAT_CUDA; use GNAT_CUDA;
with Inline; use Inline;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
@@ -5508,7 +5509,7 @@ package body Exp_Ch7 is
if Is_Class_Wide_Type (Typ) then
Utyp := Root_Type (Typ);
else
- Utyp := Typ;
+ Utyp := Get_Corresponding_Tagged_Type_If_Present (Typ);
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
@@ -7892,7 +7893,7 @@ package body Exp_Ch7 is
Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
else
- Utyp := Typ;
+ Utyp := Get_Corresponding_Tagged_Type_If_Present (Typ);
Atyp := Typ;
end if;
@@ -8469,7 +8470,7 @@ package body Exp_Ch7 is
else
Is_Conc := False;
- Utyp := Typ;
+ Utyp := Get_Corresponding_Tagged_Type_If_Present (Typ);
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
@@ -8500,22 +8501,28 @@ package body Exp_Ch7 is
-- [Deep_]Initialize primitive to call.
-- If Typ is protected then no additional processing is needed either.
- if No (Utyp)
- or else Is_Protected_Type (Typ)
- then
+ if No (Utyp) or else Is_Protected_Type (Typ) then
return Empty;
end if;
- -- Select the appropriate version of initialize
+ -- Select the appropriate version of Initialize
if Has_Controlled_Component (Utyp) then
Proc := TSS (Utyp, TSS_Deep_Initialize);
- elsif Is_Mutably_Tagged_Type (Utyp) then
- Proc := Find_Controlled_Prim_Op (Etype (Utyp), Name_Initialize);
- Check_Visibly_Controlled (Initialize_Case, Etype (Typ), Proc, Ref);
- else
+
+ -- Derivations from [Limited_]Controlled
+
+ elsif Is_Controlled (Utyp) then
Proc := Find_Controlled_Prim_Op (Utyp, Name_Initialize);
Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
+
+ -- Mutably tagged types without controlled parts in the root type
+
+ elsif Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
+ return Empty;
+
+ else
+ raise Program_Error;
end if;
-- If initialization procedure for an array of controlled objects is
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f4bcd18dab7..d587fb16c8f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -41,6 +41,7 @@ with Ghost; use Ghost;
with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
+with Mutably_Tagged; use Mutably_Tagged;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
@@ -6302,7 +6303,8 @@ package body Exp_Util is
function Finalize_Address (Typ : Entity_Id) return Entity_Id is
Btyp : constant Entity_Id := Base_Type (Typ);
- Utyp : Entity_Id := Typ;
+ Utyp : Entity_Id :=
+ Get_Corresponding_Mutably_Tagged_Type_If_Present (Typ);
begin
-- Handle protected class-wide or task class-wide types
@@ -10730,10 +10732,10 @@ package body Exp_Util is
end if;
-- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
- -- treatment for this type. In particular, even though _parent's type
+ -- treatment for this type. In particular, even though _Parent's type
-- is a controlled type or contains controlled components, we do not
- -- want to set Has_Controlled_Component on it to avoid making it gain
- -- an unwanted _controller component.
+ -- want to set Has_Controlled_Component on the equivalent type because
+ -- we do not want to build internal controlled primitives for it.
Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index c5156715d6e..28214ab2614 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -5035,7 +5035,7 @@ package body Freeze is
-- Accumulates total Esize values of all elementary components. Used
-- for processing of Implicit_Packing.
- Final_Storage_Only : Boolean := True;
+ Final_Storage_Only : Boolean;
-- Used to compute the Finalize_Storage_Only flag
Placed_Component : Boolean := False;
@@ -5043,7 +5043,7 @@ package body Freeze is
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
- Relaxed_Finalization : Boolean := True;
+ Relaxed_Finalization : Boolean;
-- Used to compute the Has_Relaxed_Finalization flag
Sized_Component_Total_RM_Size : Uint := Uint_0;
@@ -5830,6 +5830,17 @@ package body Freeze is
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
+ -- Initialize Final_Storage_Only and Relaxed_Finalization from the
+ -- current state if we have inherited controlled components.
+
+ if Has_Controlled_Component (Rec) then
+ Final_Storage_Only := Finalize_Storage_Only (Rec);
+ Relaxed_Finalization := Has_Relaxed_Finalization (Rec);
+ else
+ Final_Storage_Only := True;
+ Relaxed_Finalization := True;
+ end if;
+
-- Check for tasks, protected and controlled components, unchecked
-- unions, and type invariants.
@@ -5837,22 +5848,12 @@ package body Freeze is
while Present (Comp) loop
Propagate_Concurrent_Flags (Rec, Etype (Comp));
- -- Do not set Has_Controlled_Component on a class-wide
- -- equivalent type. See Make_CW_Equivalent_Type.
+ -- Do not set Has_Controlled_Component on a CW equivalent type,
+ -- see Exp_Util.Make_CW_Equivalent_Type.
if not Is_Class_Wide_Equivalent_Type (Rec)
- and then
- (Has_Controlled_Component (Etype (Comp))
- or else
- (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else
- (Is_Protected_Type (Etype (Comp))
- and then
- Present (Corresponding_Record_Type (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type (Etype (Comp)))))
+ and then Chars (Comp) /= Name_uParent
+ and then Needs_Finalization (Etype (Comp))
then
Set_Has_Controlled_Component (Rec);
Final_Storage_Only :=
@@ -5896,7 +5897,7 @@ package body Freeze is
-- For a type that is not directly controlled but has controlled
-- components, Finalize_Storage_Only is set if all the controlled
-- components are Finalize_Storage_Only. The same processing is
- -- appled to Has_Relaxed_Finalization.
+ -- applied to Has_Relaxed_Finalization.
if not Is_Controlled (Rec) and then Has_Controlled_Component (Rec)
then
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 3a085e8c532..65fb5dc958f 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -455,7 +455,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Associated_Node_For_Itype, Node_Id),
Sm (Can_Use_Internal_Rep, Flag, Base_Type_Only,
Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
- Sm (Class_Wide_Equivalent_Type, Node_Id),
Sm (Class_Wide_Type, Node_Id),
Sm (Contract, Node_Id),
Sm (Current_Use_Clause, Node_Id),
@@ -510,7 +509,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Generic_Actual_Type, Flag),
Sm (Is_Implicit_Full_View, Flag),
Sm (Is_Limited_Composite, Flag),
- Sm (Is_Mutably_Tagged_Type, Flag),
+ Sm (Is_Mutably_Tagged_Type, Flag, Base_Type_Only),
Sm (Is_Non_Static_Subtype, Flag),
Sm (Is_Private_Composite, Flag),
Sm (Is_RACW_Stub_Type, Flag),
@@ -752,6 +751,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Ab (Class_Wide_Kind, Aggregate_Kind,
(Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Class_Wide_Equivalent_Type, Node_Id, Base_Type_Only),
Sm (Equivalent_Type, Node_Id),
Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
diff --git a/gcc/ada/mutably_tagged.adb b/gcc/ada/mutably_tagged.adb
index 971e9de9528..446b7405032 100644
--- a/gcc/ada/mutably_tagged.adb
+++ b/gcc/ada/mutably_tagged.adb
@@ -186,13 +186,13 @@ package body Mutably_Tagged is
and then not Error_Posted (Typ)
-- Finally check Typ is a class-wide equivalent type which has an
- -- associated mutably tagged class-wide type (e.g. it is a class-wide
- -- type with a size clause).
+ -- associated mutably tagged class-wide type.
and then Is_Class_Wide_Equivalent_Type (Typ)
and then Present (Parent_Subtype (Typ))
and then Present (Class_Wide_Type (Parent_Subtype (Typ)))
- and then Has_Size_Clause (Corresponding_Mutably_Tagged_Type (Typ));
+ and then
+ Is_Mutably_Tagged_Type (Class_Wide_Type (Parent_Subtype (Typ)));
end Is_Mutably_Tagged_CW_Equivalent_Type;
--------------------------------
diff --git a/gcc/ada/mutably_tagged.ads b/gcc/ada/mutably_tagged.ads
index 2ffc3ce824c..7c6c2f44b4d 100644
--- a/gcc/ada/mutably_tagged.ads
+++ b/gcc/ada/mutably_tagged.ads
@@ -77,12 +77,11 @@ package Mutably_Tagged is
function Get_Corresponding_Tagged_Type_If_Present
(Typ : Entity_Id) return Entity_Id;
- -- Obtain the corresponding tag type associated with Typ when
- -- Typ is a mutably tagged class-wide equivalent type. Otherwise, Just
- -- return Typ.
+ -- Obtain the corresponding tagged type associated with Typ when Typ is
+ -- a mutably tagged class-wide equivalent type. Otherwise, just return Typ.
-- This function is mostly used when we need a concrete type to generate
- -- initialization for mutably tagged types.
+ -- initialization/adjustment/finalization for mutably tagged types.
function Is_Mutably_Tagged_Conversion (N : Node_Id) return Boolean;
-- Return True if expression N is an object of a mutably tagged class-wide
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index a87dde1868b..ba757e766c8 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -15720,8 +15720,8 @@ package body Sem_Ch12 is
Gen_T);
elsif not Is_Definite_Subtype (Act_T)
+ and then not Is_Mutably_Tagged_Type (Act_T)
and then Is_Definite_Subtype (A_Gen_T)
- and then No (Class_Wide_Equivalent_Type (Act_T))
and then Ada_Version >= Ada_95
then
Error_Msg_NE
@@ -15763,10 +15763,10 @@ package body Sem_Ch12 is
Act_T := Entity (Actual);
- -- Obtain the class-wide equivalent type and use it for the
+ -- Obtain the class-wide equivalent type, if any, and use it for the
-- instantiation instead of a mutably tagged type.
- if Present (Class_Wide_Equivalent_Type (Act_T)) then
+ if Is_Mutably_Tagged_Type (Act_T) then
Act_T := Class_Wide_Equivalent_Type (Act_T);
end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 8f44ac7c6df..c204fe6ea05 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -18866,7 +18866,6 @@ package body Sem_Ch3 is
Set_Full_View (Prev, Id);
Append_Entity (Id, Current_Scope);
Set_Is_Public (Id, Is_Public (Prev));
- Set_Is_Internal (Id);
New_Id := Prev;
-- If the incomplete view is tagged, a class_wide type has been
@@ -23436,8 +23435,8 @@ package body Sem_Ch3 is
procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
Component : Entity_Id;
- Final_Storage_Only : Boolean := True;
- Relaxed_Finalization : Boolean := True;
+ Final_Storage_Only : Boolean;
+ Relaxed_Finalization : Boolean;
T : Entity_Id;
begin
@@ -23447,6 +23446,17 @@ package body Sem_Ch3 is
T := Prev_T;
end if;
+ -- Initialize Final_Storage_Only and Relaxed_Finalization from the
+ -- current state if we have inherited controlled components.
+
+ if Has_Controlled_Component (T) then
+ Final_Storage_Only := Finalize_Storage_Only (T);
+ Relaxed_Finalization := Has_Relaxed_Finalization (T);
+ else
+ Final_Storage_Only := True;
+ Relaxed_Finalization := True;
+ end if;
+
Set_Is_Not_Self_Hidden (T);
-- Ada 2005: Check whether an explicit "limited" is present in a derived
@@ -23511,13 +23521,12 @@ package body Sem_Ch3 is
if Ekind (Component) /= E_Component then
null;
- -- Do not set Has_Controlled_Component on a class-wide equivalent
- -- type. See Make_CW_Equivalent_Type.
+ -- Do not set Has_Controlled_Component on a CW equivalent type,
+ -- see Exp_Util.Make_CW_Equivalent_Type.
elsif not Is_Class_Wide_Equivalent_Type (T)
- and then (Has_Controlled_Component (Etype (Component))
- or else (Chars (Component) /= Name_uParent
- and then Is_Controlled (Etype (Component))))
+ and then Chars (Component) /= Name_uParent
+ and then Needs_Finalization (Etype (Component))
then
Set_Has_Controlled_Component (T);
Final_Storage_Only :=
@@ -23534,7 +23543,7 @@ package body Sem_Ch3 is
-- For a type that is not directly controlled but has controlled
-- components, Finalize_Storage_Only is set if all the controlled
-- components are Finalize_Storage_Only. The same processing is
- -- appled to Has_Relaxed_Finalization.
+ -- applied to Has_Relaxed_Finalization.
if not Is_Controlled (T) and then Has_Controlled_Component (T) then
Set_Finalize_Storage_Only (T, Final_Storage_Only);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b196a6cee7d..96839b8bf17 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -23824,9 +23824,19 @@ package body Sem_Util is
return False;
-- Class-wide types are treated as controlled because derivations from
- -- the root type may introduce controlled components.
-
- elsif Is_Class_Wide_Type (Typ) then
+ -- the root type may introduce controlled components, unless the root
+ -- type is declared with the No_Controlled_Parts aspect.
+
+ elsif (Is_Class_Wide_Type (Typ)
+ and then not
+ Has_Enabled_Aspect
+ (Root_Type (Typ), Aspect_No_Controlled_Parts))
+ or else (Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
+ and then not
+ Has_Enabled_Aspect
+ (Root_Type (Corresponding_Mutably_Tagged_Type (Typ)),
+ Aspect_No_Controlled_Parts))
+ then
return True;
-- Concurrent types are controlled as long as their corresponding record
