From c859345327b2c2858ae8a120d2b714d928b43130 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 26 May 2015 10:15:24 +0200 Subject: [PATCH] [multiple changes] 2015-05-26 Robert Dewar * aspects.ads, aspects.adb: Add aspect Disable_Controlled. * einfo.ads, einfo.adb (Disable_Controlled): New flag. (Is_Controlled_Active): New function. * exp_ch3.adb (Expand_Freeze_Record_Type): Use Is_Controlled_Active. * exp_util.adb (Needs_Finalization): Finalization not needed if Disable_Controlled set. * freeze.adb (Freeze_Array_Type): Do not set Has_Controlled_Component if the component has Disable_Controlled. (Freeze_Record_Type): ditto. * sem_ch13.adb (Decorate): Minor reformatting. (Analyze_Aspect_Specifications): Implement Disable_Controlled. * sem_ch3.adb (Analyze_Object_Declaration): Handle Disable_Controlled. (Array_Type_Declaration): ditto. (Build_Derived_Private_Type): ditto. (Build_Derived_Type): ditto. (Record_Type_Definition): ditto. * snames.ads-tmpl: Add Name_Disable_Controlled. 2015-05-26 Eric Botcazou * exp_ch6.adb (Expand_Actuals): Use a constant declaration instead of a renaming to capture the return value of a function call. (Expand_Simple_Function_Return): Call Remove_Side_Effects instead of removing side effects manually before the call to _Postconditions. From-SVN: r223667 --- gcc/ada/ChangeLog | 30 ++++++++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 3 + gcc/ada/einfo.adb | 22 ++++++- gcc/ada/einfo.ads | 16 +++++ gcc/ada/exp_ch3.adb | 7 ++- gcc/ada/exp_ch6.adb | 127 +++++++--------------------------------- gcc/ada/exp_util.adb | 8 ++- gcc/ada/freeze.adb | 4 +- gcc/ada/sem_ch13.adb | 26 ++++++-- gcc/ada/sem_ch3.adb | 43 ++++++++------ gcc/ada/snames.ads-tmpl | 1 + 12 files changed, 150 insertions(+), 138 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c0d03c39478..accd480b8f6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2015-05-26 Robert Dewar + + * aspects.ads, aspects.adb: Add aspect Disable_Controlled. + * einfo.ads, einfo.adb (Disable_Controlled): New flag. + (Is_Controlled_Active): New function. + * exp_ch3.adb (Expand_Freeze_Record_Type): Use + Is_Controlled_Active. + * exp_util.adb (Needs_Finalization): Finalization not needed + if Disable_Controlled set. + * freeze.adb (Freeze_Array_Type): Do not set + Has_Controlled_Component if the component has Disable_Controlled. + (Freeze_Record_Type): ditto. + * sem_ch13.adb (Decorate): Minor reformatting. + (Analyze_Aspect_Specifications): Implement Disable_Controlled. + * sem_ch3.adb (Analyze_Object_Declaration): Handle + Disable_Controlled. + (Array_Type_Declaration): ditto. + (Build_Derived_Private_Type): ditto. + (Build_Derived_Type): ditto. + (Record_Type_Definition): ditto. + * snames.ads-tmpl: Add Name_Disable_Controlled. + +2015-05-26 Eric Botcazou + + * exp_ch6.adb (Expand_Actuals): Use a constant declaration instead + of a renaming to capture the return value of a function call. + (Expand_Simple_Function_Return): Call Remove_Side_Effects + instead of removing side effects manually before the call to + _Postconditions. + 2015-05-26 Robert Dewar * exp_ch4.adb (Expand_N_Op_Expon): Deal with problem of wrong diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 976b89d7ec4..bf01f77a609 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -517,6 +517,7 @@ package body Aspects is Aspect_Depends => Aspect_Depends, Aspect_Dimension => Aspect_Dimension, Aspect_Dimension_System => Aspect_Dimension_System, + Aspect_Disable_Controlled => Aspect_Disable_Controlled, Aspect_Discard_Names => Aspect_Discard_Names, Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate => Aspect_Predicate, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 41fa96100dc..e2156224dee 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -171,6 +171,7 @@ package Aspects is Aspect_Asynchronous, Aspect_Atomic, Aspect_Atomic_Components, + Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, Aspect_Effective_Reads, -- GNAT Aspect_Effective_Writes, -- GNAT @@ -414,6 +415,7 @@ package Aspects is Aspect_Depends => Name_Depends, Aspect_Dimension => Name_Dimension, Aspect_Dimension_System => Name_Dimension_System, + Aspect_Disable_Controlled => Name_Disable_Controlled, Aspect_Discard_Names => Name_Discard_Names, Aspect_Dispatching_Domain => Name_Dispatching_Domain, Aspect_Dynamic_Predicate => Name_Dynamic_Predicate, @@ -704,6 +706,7 @@ package Aspects is Aspect_Depends => Never_Delay, Aspect_Dimension => Never_Delay, Aspect_Dimension_System => Never_Delay, + Aspect_Disable_Controlled => Never_Delay, Aspect_Effective_Reads => Never_Delay, Aspect_Effective_Writes => Never_Delay, Aspect_Extensions_Visible => Never_Delay, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2c9a4bab0f9..285e924c11a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -558,6 +558,7 @@ package body Einfo is -- Has_Implicit_Dereference Flag251 -- Is_Processed_Transient Flag252 + -- Disable_Controlled Flag253 -- Is_Implementation_Defined Flag254 -- Is_Predicate_Function Flag255 -- Is_Predicate_Function_M Flag256 @@ -595,7 +596,6 @@ package body Einfo is -- Is_Volatile_Full_Access Flag285 -- Needs_Typedef Flag286 - -- (unused) Flag253 -- (unused) Flag287 -- (unused) Flag288 -- (unused) Flag289 @@ -1026,6 +1026,11 @@ package body Einfo is return Node20 (Id); end Directly_Designated_Type; + function Disable_Controlled (Id : E) return B is + begin + return Flag253 (Base_Type (Id)); + end Disable_Controlled; + function Discard_Names (Id : E) return B is begin return Flag88 (Id); @@ -3941,6 +3946,12 @@ package body Einfo is Set_Node20 (Id, V); end Set_Directly_Designated_Type; + procedure Set_Disable_Controlled (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Flag253 (Id, V); + end Set_Disable_Controlled; + procedure Set_Discard_Names (Id : E; V : B := True) is begin Set_Flag88 (Id, V); @@ -7394,6 +7405,15 @@ package body Einfo is K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter; end Is_Constant_Object; + -------------------------- + -- Is_Controlled_Active -- + -------------------------- + + function Is_Controlled_Active (Id : E) return B is + begin + return Is_Controlled (Id) and then not Disable_Controlled (Id); + end Is_Controlled_Active; + -------------------- -- Is_Discriminal -- -------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b5d776991ef..1c0ee5168d6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -911,6 +911,10 @@ package Einfo is -- Designated_Type obtains this full type in the case of access to an -- incomplete type. +-- Disable_Controlled (Flag253) +-- Present in all entities. Set for controlled type (Is_Controlled flag +-- set) if the aspect Disable_Controlled is active for the type. + -- Discard_Names (Flag88) -- Defined in types and exception entities. Set if pragma Discard_Names -- applies to the entity. It is also set for declarative regions and @@ -2337,6 +2341,10 @@ package Einfo is -- i.e. is either a descendant of Ada.Finalization.Controlled or of -- Ada.Finalization.Limited_Controlled. +-- Is_Controlled_Active (synth) [base type only] +-- Defined in all type entities. Set if Is_Controlled is set for the +-- type, and Disable_Controlled is not set. + -- Is_Controlling_Formal (Flag97) -- Defined in all Formal_Kind entities. Marks the controlling parameters -- of dispatching operations. @@ -5413,6 +5421,7 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Depends_On_Private (Flag14) + -- Disable_Controlled (Flag253) -- Discard_Names (Flag88) -- Finalize_Storage_Only (Flag158) (base type only) -- From_Limited_With (Flag159) @@ -5491,6 +5500,7 @@ package Einfo is -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) -- Is_Atomic_Or_VFA (synth) + -- Is_Controlled_Active (synth) -- Predicate_Function (synth) -- Predicate_Function_M (synth) -- Root_Type (synth) @@ -6724,6 +6734,7 @@ package Einfo is function Digits_Value (Id : E) return U; function Direct_Primitive_Operations (Id : E) return L; function Directly_Designated_Type (Id : E) return E; + function Disable_Controlled (Id : E) return B; function Discard_Names (Id : E) return B; function Discriminal (Id : E) return E; function Discriminal_Link (Id : E) return E; @@ -7206,6 +7217,7 @@ package Einfo is function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; function Is_Constant_Object (Id : E) return B; + function Is_Controlled_Active (Id : E) return B; function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; function Is_External_State (Id : E) return B; @@ -7380,6 +7392,7 @@ package Einfo is procedure Set_Digits_Value (Id : E; V : U); procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Directly_Designated_Type (Id : E; V : E); + procedure Set_Disable_Controlled (Id : E; V : B := True); procedure Set_Discard_Names (Id : E; V : B := True); procedure Set_Discriminal (Id : E; V : E); procedure Set_Discriminal_Link (Id : E; V : E); @@ -8155,6 +8168,7 @@ package Einfo is pragma Inline (Digits_Value); pragma Inline (Direct_Primitive_Operations); pragma Inline (Directly_Designated_Type); + pragma Inline (Disable_Controlled); pragma Inline (Discard_Names); pragma Inline (Discriminal); pragma Inline (Discriminal_Link); @@ -8658,6 +8672,7 @@ package Einfo is pragma Inline (Set_Digits_Value); pragma Inline (Set_Direct_Primitive_Operations); pragma Inline (Set_Directly_Designated_Type); + pragma Inline (Set_Disable_Controlled); pragma Inline (Set_Discard_Names); pragma Inline (Set_Discriminal); pragma Inline (Set_Discriminal_Link); @@ -9062,6 +9077,7 @@ package Einfo is pragma Inline (Base_Type); pragma Inline (Is_Base_Type); + pragma Inline (Is_Controlled_Active); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Packed_Array); pragma Inline (Is_Subprogram_Or_Generic_Subprogram); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6223c970fca..0bb41fd8a55 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6936,9 +6936,10 @@ package body Exp_Ch3 is -- type. See Make_CW_Equivalent_Type. if not Is_Class_Wide_Equivalent_Type (Def_Id) - and then (Has_Controlled_Component (Comp_Typ) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Comp_Typ))) + and then + (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then (Is_Controlled_Active (Comp_Typ)))) then Set_Has_Controlled_Component (Def_Id); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 73ee513f6b5..e89103ce3f1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1979,7 +1979,7 @@ package body Exp_Ch6 is -- To deal with this, we replace the call by -- do - -- Tnnn : function-result-type renames function-call; + -- Tnnn : constant function-result-type := function-call; -- Post_Call actions -- in -- Tnnn; @@ -1996,10 +1996,11 @@ package body Exp_Ch6 is begin Prepend_To (Post_Call, - Make_Object_Renaming_Declaration (Loc, + Make_Object_Declaration (Loc, Defining_Identifier => Tnnn, - Subtype_Mark => New_Occurrence_Of (FRTyp, Loc), - Name => Name)); + Object_Definition => New_Occurrence_Of (FRTyp, Loc), + Constant_Present => True, + Expression => Name)); Rewrite (N, Make_Expression_With_Actions (Loc, @@ -6619,111 +6620,23 @@ package body Exp_Ch6 is if Ekind (Scope_Id) = E_Function and then Present (Postconditions_Proc (Scope_Id)) then - -- We are going to reference the returned value twice in this case, - -- once in the call to _Postconditions, and once in the actual return - -- statement, but we can't have side effects happening twice, and in - -- any case for efficiency we don't want to do the computation twice. - - -- If the returned expression is an entity name, we don't need to - -- worry since it is efficient and safe to reference it twice, that's - -- also true for literals other than string literals, and for the - -- case of X.all where X is an entity name. - - if Is_Entity_Name (Exp) - or else Nkind_In (Exp, N_Character_Literal, - N_Integer_Literal, - N_Real_Literal) - or else (Nkind (Exp) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Exp))) + -- In the case of discriminated objects, we have created a + -- constrained subtype above, and used the underlying type. This + -- transformation is post-analysis and harmless, except that now the + -- call to the post-condition will be analyzed and the type kinds + -- have to match. + + if Nkind (Exp) = N_Unchecked_Type_Conversion + and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp)) then - null; - - -- Otherwise we are going to need a temporary to capture the value - - else - declare - ExpR : Node_Id := Relocate_Node (Exp); - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); - - begin - -- In the case of discriminated objects, we have created a - -- constrained subtype above, and used the underlying type. - -- This transformation is post-analysis and harmless, except - -- that now the call to the post-condition will be analyzed and - -- type kinds have to match. - - if Nkind (ExpR) = N_Unchecked_Type_Conversion - and then - Is_Private_Type (R_Type) /= Is_Private_Type (Etype (ExpR)) - then - ExpR := Expression (ExpR); - end if; - - -- For a complex expression of an elementary type, capture - -- value in the temporary and use it as the reference. - - if Is_Elementary_Type (R_Type) then - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- If we have something we can rename, generate a renaming of - -- the object and replace the expression with a reference - - elsif Is_Object_Reference (Exp) then - Insert_Action (Exp, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Tnn, - Subtype_Mark => New_Occurrence_Of (R_Type, Loc), - Name => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Otherwise we have something like a string literal or an - -- aggregate. We could copy the value, but that would be - -- inefficient. Instead we make a reference to the value and - -- capture this reference with a renaming, the expression is - -- then replaced by a dereference of this renaming. + Rewrite (Exp, Expression (Relocate_Node (Exp))); + end if; - else - -- For now, copy the value, since the code below does not - -- seem to work correctly ??? + -- We are going to reference the returned value twice in this case, + -- once in the call to _Postconditions, and once in the actual return + -- statement, but we can't have side effects happening twice. - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Insert_Action (Exp, - -- Make_Object_Renaming_Declaration (Loc, - -- Defining_Identifier => Tnn, - -- Access_Definition => - -- Make_Access_Definition (Loc, - -- All_Present => True, - -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), - -- Name => - -- Make_Reference (Loc, - -- Prefix => Relocate_Node (Exp))), - -- Suppress => All_Checks); - - -- Rewrite (Exp, - -- Make_Explicit_Dereference (Loc, - -- Prefix => New_Occurrence_Of (Tnn, Loc))); - end if; - end; - end if; + Remove_Side_Effects (Exp); -- Generate call to _Postconditions @@ -6731,7 +6644,7 @@ package body Exp_Ch6 is Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc), - Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); + Parameter_Associations => New_List (New_Copy_Tree (Exp)))); end if; -- Ada 2005 (AI-251): If this return statement corresponds with an diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2aa6e970a4d..046b1891728 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6848,12 +6848,16 @@ package body Exp_Util is then return False; + -- Never needs finalization if Disable_Controlled set + + elsif Disable_Controlled (T) then + return False; + else -- Class-wide types are treated as controlled because derivations -- from the root type can introduce controlled components. - return - Is_Class_Wide_Type (T) + return Is_Class_Wide_Type (T) or else Is_Controlled (T) or else Has_Controlled_Component (T) or else Has_Some_Controlled_Component (T) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 64367614ede..f411e1e2770 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2226,7 +2226,7 @@ package body Freeze is -- Propagate flags for component type - if Is_Controlled (Component_Type (Arr)) + if Is_Controlled_Active (Component_Type (Arr)) or else Has_Controlled_Component (Ctyp) then Set_Has_Controlled_Component (Arr); @@ -4106,7 +4106,7 @@ package body Freeze is (Has_Controlled_Component (Etype (Comp)) or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) + and then Is_Controlled_Active (Etype (Comp))) or else (Is_Protected_Type (Etype (Comp)) and then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f9ec0ae1137..29153d7a67b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1205,8 +1205,7 @@ package body Sem_Ch13 is procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is procedure Decorate (Asp : Node_Id; Prag : Node_Id); - -- Establish linkages between an aspect and its corresponding - -- pragma. + -- Establish linkages between an aspect and its corresponding pragma procedure Insert_After_SPARK_Mode (Prag : Node_Id; @@ -1235,7 +1234,7 @@ package body Sem_Ch13 is procedure Decorate (Asp : Node_Id; Prag : Node_Id) is begin - Set_Aspect_Rep_Item (Asp, Prag); + Set_Aspect_Rep_Item (Asp, Prag); Set_Corresponding_Aspect (Prag, Asp); Set_From_Aspect_Specification (Prag); Set_Parent (Prag, Asp); @@ -3055,7 +3054,7 @@ package body Sem_Ch13 is -- Case 5: Special handling for aspects with an optional -- boolean argument. - -- In the general case, the corresponding pragma cannot be + -- In the delayed case, the corresponding pragma cannot be -- generated yet because the evaluation of the boolean needs -- to be delayed till the freeze point. @@ -3144,6 +3143,25 @@ package body Sem_Ch13 is end if; end if; + goto Continue; + + -- Disable_Controlled + + elsif A_Id = Aspect_Disable_Controlled then + if Ekind (E) /= E_Record_Type + or else not Is_Controlled (E) + then + Error_Msg_N + ("aspect % requires controlled record type", Aspect); + goto Continue; + end if; + + if not Present (Expr) + or else Is_True (Static_Boolean (Expr)) + then + Set_Disable_Controlled (E); + end if; + goto Continue; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ecd1639242f..de8b1c4add5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4386,7 +4386,7 @@ package body Sem_Ch3 is and then not Is_Constrained (Underlying_Type (T)) and then not Is_Aliased (Id) and then not Is_Class_Wide_Type (T) - and then not Is_Controlled (T) + and then not Is_Controlled_Active (T) and then not Has_Controlled_Component (Base_Type (T)) and then Expander_Active then @@ -5614,7 +5614,7 @@ package body Sem_Ch3 is Set_Packed_Array_Impl_Type (Implicit_Base, Empty); Set_Has_Controlled_Component (Implicit_Base, Has_Controlled_Component (Element_Type) - or else Is_Controlled (Element_Type)); + or else Is_Controlled_Active (Element_Type)); Set_Finalize_Storage_Only (Implicit_Base, Finalize_Storage_Only (Element_Type)); @@ -5640,7 +5640,7 @@ package body Sem_Ch3 is Set_Has_Controlled_Component (T, Has_Controlled_Component (Element_Type) or else - Is_Controlled (Element_Type)); + Is_Controlled_Active (Element_Type)); Set_Finalize_Storage_Only (T, Finalize_Storage_Only (Element_Type)); Set_Default_SSO (T); @@ -7351,16 +7351,18 @@ package body Sem_Ch3 is Error_Msg_N ("cannot add discriminants to untagged type", N); end if; - Set_Stored_Constraint (Derived_Type, No_Elist); - Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Stored_Constraint (Derived_Type, No_Elist); + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Disable_Controlled (Derived_Type, Disable_Controlled + (Parent_Type)); Set_Has_Controlled_Component - (Derived_Type, Has_Controlled_Component - (Parent_Type)); + (Derived_Type, Has_Controlled_Component + (Parent_Type)); -- Direct controlled types do not inherit Finalize_Storage_Only flag - if not Is_Controlled (Parent_Type) then + if not Is_Controlled_Active (Parent_Type) then Set_Finalize_Storage_Only (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); end if; @@ -8974,16 +8976,18 @@ package body Sem_Ch3 is begin -- Set common attributes - Set_Scope (Derived_Type, Current_Scope); + Set_Scope (Derived_Type, Current_Scope); + + Set_Etype (Derived_Type, Parent_Base); + Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); + Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base)); - Set_Etype (Derived_Type, Parent_Base); - Set_Ekind (Derived_Type, Ekind (Parent_Base)); - Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); - Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base)); + Set_Size_Info (Derived_Type, Parent_Type); + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); - Set_Size_Info (Derived_Type, Parent_Type); - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); @@ -21174,7 +21178,7 @@ package body Sem_Ch3 is end; end if; - Final_Storage_Only := not Is_Controlled (T); + Final_Storage_Only := not Is_Controlled_Active (T); -- Ada 2005: Check whether an explicit Limited is present in a derived -- type declaration. @@ -21240,7 +21244,8 @@ package body Sem_Ch3 is 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 Is_Controlled_Active + (Etype (Component)))) then Set_Has_Controlled_Component (T, True); Final_Storage_Only := diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 90745527853..b76e6295059 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -141,6 +141,7 @@ package Snames is Name_Default_Component_Value : constant Name_Id := N + $; Name_Dimension : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $; + Name_Disable_Controlled : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; -- 2.30.2