https://gcc.gnu.org/g:9c91c880bf3158d54be74614a050838b5448042c
commit r17-4577-g9c91c880bf3158d54be74614a050838b5448042c Author: Eric Botcazou <[email protected]> Date: Tue Sep 22 21:10:00 2026 +0200 Ada: Fix finalization not performed correctly with mutably tagged types 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. gcc/ada/ * 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. Diff: --- gcc/ada/einfo.ads | 27 +++--- gcc/ada/exp_ch3.adb | 27 +++++- gcc/ada/exp_ch5.adb | 186 ++++++++++++++++++++---------------- gcc/ada/exp_ch6.adb | 4 +- gcc/ada/exp_ch7.adb | 29 +++--- gcc/ada/exp_util.adb | 10 +- gcc/ada/freeze.adb | 35 +++---- gcc/ada/gen_il-gen-gen_entities.adb | 4 +- gcc/ada/mutably_tagged.adb | 6 +- gcc/ada/mutably_tagged.ads | 7 +- gcc/ada/sem_ch12.adb | 6 +- gcc/ada/sem_ch3.adb | 27 ++++-- gcc/ada/sem_util.adb | 16 +++- 13 files changed, 227 insertions(+), 157 deletions(-) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 73d684890eee..c69aec8baf7f 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 5372b8a7435d..c57949eb425b 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 cf4733317497..63c6cb9798ac 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 1441aa828388..caa2e1e7d3c3 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 11c86895aa16..338a5de8057c 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 f4bcd18dab75..d587fb16c8f4 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 c5156715d6e2..28214ab2614e 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 3a085e8c5322..65fb5dc958f0 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 971e9de95286..446b7405032d 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 2ffc3ce824c8..7c6c2f44b4d3 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 a87dde1868bd..ba757e766c8f 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 8f44ac7c6df9..c204fe6ea052 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 b196a6cee7dc..96839b8bf172 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
