From: Bob Duff Date: Fri, 22 Aug 2008 12:59:45 +0000 (+0000) Subject: exp_ch5.adb, [...]: Rename... X-Git-Tag: releases/gcc-4.4.0~2952 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=048e5cef65a7c108ba7a2b16ca12ba70b9759527;p=thirdparty%2Fgcc.git exp_ch5.adb, [...]: Rename... 2008-08-22 Bob Duff * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb, exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, exp_intr.adb, exp_ch3.adb: Rename: Exp_Ch7.Controlled_Type => Needs_Finalization Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type => Has_Controlled_Parts (Has_Some_Controlled_Component): Fix bug in array case. From-SVN: r139452 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4a02aa9a27e6..1ae24d8238a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2008-08-22 Bob Duff + + * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb, + exp_ch4.adb, exp_ch6.ads, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, + exp_intr.adb, exp_ch3.adb: Rename: + Exp_Ch7.Controlled_Type => Needs_Finalization + Exp_Ch7.CW_Or_Controlled_Type => CW_Or_Has_Controlled_Part + Exp_Ch5.Expand_N_Extended_Return_Statement.Controlled_Type => + Has_Controlled_Parts + (Has_Some_Controlled_Component): Fix bug in array case. + 2008-08-22 Robert Dewar * sem_ch8.adb: Minor reformatting diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e8b1e732e2bc..c81e401381dc 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -973,7 +973,7 @@ package body Exp_Aggr is if Present (Flist) then F := New_Copy_Tree (Flist); - elsif Present (Etype (N)) and then Controlled_Type (Etype (N)) then + elsif Present (Etype (N)) and then Needs_Finalization (Etype (N)) then if Is_Entity_Name (Into) and then Present (Scope (Entity (Into))) then @@ -1137,7 +1137,7 @@ package body Exp_Aggr is Expression => Make_Null (Loc))); end if; - if Controlled_Type (Ctype) then + if Needs_Finalization (Ctype) then Append_List_To (L, Make_Init_Call ( Ref => New_Copy_Tree (Indexed_Comp), @@ -1159,7 +1159,7 @@ package body Exp_Aggr is Name => Indexed_Comp, Expression => New_Copy_Tree (Expr)); - if Present (Comp_Type) and then Controlled_Type (Comp_Type) then + if Present (Comp_Type) and then Needs_Finalization (Comp_Type) then Set_No_Ctrl_Actions (A); -- If this is an aggregate for an array of arrays, each @@ -1223,7 +1223,7 @@ package body Exp_Aggr is -- inner finalization actions). if Present (Comp_Type) - and then Controlled_Type (Comp_Type) + and then Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) and then (not Is_Array_Type (Comp_Type) @@ -2167,7 +2167,7 @@ package body Exp_Aggr is -- proper scope is the scope of the target rather than the -- potentially transient current scope. - if Controlled_Type (Typ) then + if Needs_Finalization (Typ) then -- The current aggregate belongs to an allocator which creates -- an object through an anonymous access type or acts as the root @@ -2645,7 +2645,7 @@ package body Exp_Aggr is -- Call Adjust manually - if Controlled_Type (Etype (A)) + if Needs_Finalization (Etype (A)) and then not Is_Limited_Type (Etype (A)) then Append_List_To (Assign, @@ -2854,7 +2854,7 @@ package body Exp_Aggr is -- The controller is the one of the parent type defining the -- component (in case of inherited components). - if Controlled_Type (Comp_Type) then + if Needs_Finalization (Comp_Type) then Internal_Final_List := Make_Selected_Component (Loc, Prefix => Convert_To ( @@ -3027,7 +3027,7 @@ package body Exp_Aggr is -- Attach_To_Final_List (tmp.comp, -- comp_typ (tmp)._record_controller.f) - if Controlled_Type (Comp_Type) + if Needs_Finalization (Comp_Type) and then not Is_Limited_Type (Comp_Type) then Append_List_To (L, @@ -4961,7 +4961,7 @@ package body Exp_Aggr is or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration - and then Controlled_Type (Typ)) + and then Needs_Finalization (Typ)) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 57cb43ee34ce..8596a9b15b90 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -732,7 +732,7 @@ package body Exp_Ch3 is -- in any case no point in inlining such complex init procs. if not Has_Task (Proc_Id) - and then not Controlled_Type (Proc_Id) + and then not Needs_Finalization (Proc_Id) then Set_Is_Inlined (Proc_Id); end if; @@ -1581,7 +1581,7 @@ package body Exp_Ch3 is Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then @@ -1865,7 +1865,7 @@ package body Exp_Ch3 is Kind := Nkind (Expression (N)); end if; - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) and then not Is_Inherently_Limited_Type (Typ) then @@ -3145,7 +3145,7 @@ package body Exp_Ch3 is if not Is_Concurrent_Type (Rec_Type) and then not Has_Task (Rec_Type) - and then not Controlled_Type (Rec_Type) + and then not Needs_Finalization (Rec_Type) then Set_Is_Inlined (Proc_Id); end if; @@ -4188,7 +4188,7 @@ package body Exp_Ch3 is -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. - if not Controlled_Type (Typ) + if not Needs_Finalization (Typ) or else No_Initialization (N) then null; @@ -4526,7 +4526,7 @@ package body Exp_Ch3 is -- we plan to support in-place function results for some cases -- of nonlimited types. ???) - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then not BIP_Call then @@ -5001,7 +5001,7 @@ package body Exp_Ch3 is end if; elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; @@ -5517,7 +5517,7 @@ package body Exp_Ch3 is Set_Has_Controlled_Component (Def_Id); elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) + and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) then if No (Flist) then Flist := Add_Final_Chain (Def_Id); @@ -6144,7 +6144,7 @@ package body Exp_Ch3 is then null; - elsif (Controlled_Type (Desig_Type) + elsif (Needs_Finalization (Desig_Type) and then Convention (Desig_Type) /= Convention_Java and then Convention (Desig_Type) /= Convention_CIL) or else @@ -6168,7 +6168,7 @@ package body Exp_Ch3 is or else (Is_Array_Type (Desig_Type) and then not Is_Frozen (Desig_Type) - and then Controlled_Type (Component_Type (Desig_Type))) + and then Needs_Finalization (Component_Type (Desig_Type))) -- The designated type has controlled anonymous access -- discriminants. @@ -7842,7 +7842,7 @@ package body Exp_Ch3 is null; elsif Etype (Tag_Typ) = Tag_Typ - or else Controlled_Type (Tag_Typ) + or else Needs_Finalization (Tag_Typ) -- Ada 2005 (AI-251): We must also generate these subprograms if -- the immediate ancestor is an interface to ensure the correct diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c0c20416276d..808005474b05 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -575,7 +575,7 @@ package body Exp_Ch4 is -- Start of processing for Expand_Allocator_Expression begin - if Is_Tagged_Type (T) or else Controlled_Type (T) then + if Is_Tagged_Type (T) or else Needs_Finalization (T) then -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the allocated object @@ -669,7 +669,7 @@ package body Exp_Ch4 is Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -717,7 +717,7 @@ package body Exp_Ch4 is -- Inherit the final chain to ensure that the expansion of the -- aggregate is correct in case of controlled types - if Controlled_Type (Directly_Designated_Type (PtrT)) then + if Needs_Finalization (Directly_Designated_Type (PtrT)) then Set_Associated_Final_Chain (Def_Id, Associated_Final_Chain (PtrT)); end if; @@ -739,7 +739,7 @@ package body Exp_Ch4 is Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -835,8 +835,8 @@ package body Exp_Ch4 is Insert_Action (N, Tag_Assign); end if; - if Controlled_Type (DesigT) - and then Controlled_Type (T) + if Needs_Finalization (DesigT) + and then Needs_Finalization (T) then declare Attach : Node_Id; @@ -868,7 +868,7 @@ package body Exp_Ch4 is -- Normal case, not a secondary stack allocation else - if Controlled_Type (T) + if Needs_Finalization (T) and then Ekind (PtrT) = E_Anonymous_Access_Type then -- Create local finalization list for access parameter @@ -3502,7 +3502,7 @@ package body Exp_Ch4 is Parameter_Associations => Args)); end if; - if Controlled_Type (T) then + if Needs_Finalization (T) then -- Postpone the generation of a finalization call for the -- current allocator if it acts as a coextension. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 3964ed157c1c..0eb681df4087 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -728,7 +728,7 @@ package body Exp_Ch5 is -- Cases where either Forwards_OK or Backwards_OK is true if Forwards_OK (N) or else Backwards_OK (N) then - if Controlled_Type (Component_Type (L_Type)) + if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) @@ -862,7 +862,7 @@ package body Exp_Ch5 is Right_Opnd => Cright_Lo); end if; - if Controlled_Type (Component_Type (L_Type)) + if Needs_Finalization (Component_Type (L_Type)) and then Base_Type (L_Type) = Base_Type (R_Type) and then Ndim = 1 and then not No_Ctrl_Actions (N) @@ -1775,7 +1775,7 @@ package body Exp_Ch5 is return; elsif Is_Tagged_Type (Typ) - or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ)) + or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) then Tagged_Case : declare L : List_Id := No_List; @@ -1937,7 +1937,7 @@ package body Exp_Ch5 is -- If no restrictions on aborts, protect the whole assignment -- for controlled objects as per 9.8(11). - if Controlled_Type (Typ) + if Needs_Finalization (Typ) and then Expand_Ctrl_Actions and then Abort_Allowed then @@ -2381,9 +2381,9 @@ package body Exp_Ch5 is Result : Node_Id; Exp : Node_Id; - function Controlled_Type (Typ : Entity_Id) return Boolean; + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; -- Determine whether type Typ is controlled or contains a controlled - -- component. + -- subcomponent. function Move_Activation_Chain return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain @@ -2399,16 +2399,16 @@ package body Exp_Ch5 is -- From finalization list of the return statement -- To finalization list passed in by the caller - --------------------- - -- Controlled_Type -- - --------------------- + -------------------------- + -- Has_Controlled_Parts -- + -------------------------- - function Controlled_Type (Typ : Entity_Id) return Boolean is + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is begin return Is_Controlled (Typ) or else Has_Controlled_Component (Typ); - end Controlled_Type; + end Has_Controlled_Parts; --------------------------- -- Move_Activation_Chain -- @@ -2542,13 +2542,13 @@ package body Exp_Ch5 is if Is_Build_In_Place and then - (Controlled_Type (Parent_Function_Typ) + (Has_Controlled_Parts (Parent_Function_Typ) or else (Is_Class_Wide_Type (Parent_Function_Typ) and then - Controlled_Type (Root_Type (Parent_Function_Typ))) - or else Controlled_Type (Etype (Return_Object_Entity)) + Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) + or else Has_Controlled_Parts (Etype (Return_Object_Entity)) or else (Present (Exp) - and then Controlled_Type (Etype (Exp)))) + and then Has_Controlled_Parts (Etype (Exp)))) then Append_To (Statements, Move_Final_List); end if; @@ -3850,7 +3850,7 @@ package body Exp_Ch5 is and then (not Is_Array_Type (Exptyp) or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) - or else CW_Or_Controlled_Type (Utyp)) + or else CW_Or_Has_Controlled_Part (Utyp)) and then Nkind (Exp) = N_Function_Call then Set_By_Ref (N); @@ -3873,7 +3873,7 @@ package body Exp_Ch5 is -- controlled (by the virtue of restriction No_Finalization) because -- gigi is not able to properly allocate class-wide types. - elsif CW_Or_Controlled_Type (Utyp) then + elsif CW_Or_Has_Controlled_Part (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); Temp : constant Entity_Id := @@ -4221,7 +4221,7 @@ package body Exp_Ch5 is L : constant Node_Id := Name (N); T : constant Entity_Id := Underlying_Type (Etype (L)); - Ctrl_Act : constant Boolean := Controlled_Type (T) + Ctrl_Act : constant Boolean := Needs_Finalization (T) and then not No_Ctrl_Actions (N); Save_Tag : constant Boolean := Is_Tagged_Type (T) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4c3f3da63f94..145a39dad85b 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -391,21 +391,20 @@ package body Exp_Ch6 is Final_List_Actual : Node_Id; Final_List_Formal : Node_Id; Is_Ctrl_Result : constant Boolean := - Controlled_Type + Needs_Finalization (Underlying_Type (Etype (Function_Id))); begin -- No such extra parameter is needed if there are no controlled parts. - -- The test for Controlled_Type accounts for class-wide results (which - -- potentially have controlled parts, even if the root type doesn't), - -- and the test for a tagged result type is needed because calls to - -- such a function can in general occur in dispatching contexts, which - -- must be treated the same as a call to class-wide functions. Both of - -- these situations require that a finalization list be passed. - - if not Is_Ctrl_Result - and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) - then + -- The test for Needs_Finalization accounts for class-wide results + -- (which potentially have controlled parts, even if the root type + -- doesn't), and the test for a tagged result type is needed because + -- calls to such a function can in general occur in dispatching + -- contexts, which must be treated the same as a call to class-wide + -- functions. Both of these situations require that a finalization list + -- be passed. + + if not Needs_BIP_Final_List (Function_Id) then return; end if; @@ -3034,7 +3033,7 @@ package body Exp_Ch6 is -- If the return type is limited the context is an initialization -- and different processing applies. - if Controlled_Type (Etype (Subp)) + if Needs_Finalization (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp)) and then not Is_Limited_Interface (Etype (Subp)) then @@ -4276,7 +4275,7 @@ package body Exp_Ch6 is elsif Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Spec_Id); end if; end; @@ -4903,7 +4902,7 @@ package body Exp_Ch6 is begin if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); end if; end; @@ -5592,4 +5591,19 @@ package body Exp_Ch6 is end if; end Make_Build_In_Place_Call_In_Object_Declaration; + function Needs_BIP_Final_List (E : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (E)); + Result_Subt : constant Entity_Id := Underlying_Type (Etype (E)); + begin + -- We need the BIP_Final_List if the result type needs finalization. We + -- also need it for tagged types, even if not class-wide, because some + -- type extension might need finalization, and all overriding functions + -- must have the same calling conventions. However, if there is a + -- pragma Restrictions (No_Finalization), we never need this parameter. + + return (Needs_Finalization (Result_Subt) + or else Is_Tagged_Type (Underlying_Type (Result_Subt))) + and then not Restriction_Active (No_Finalization); + end Needs_BIP_Final_List; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index d69f9d01322c..df5b9eb3f71a 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -161,4 +161,9 @@ package Exp_Ch6 is -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression -- node applied to such a function call. + function Needs_BIP_Final_List (E : Entity_Id) return Boolean; + pragma Precondition (Is_Build_In_Place_Function (E)); + -- Ada 2005 (AI-318-02): Returns True if the function needs the + -- BIP_Final_List implicit parameter. + end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index fb0f7dcb021d..f05ad7157f87 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -846,11 +846,11 @@ package body Exp_Ch7 is end if; end Check_Visibly_Controlled; - --------------------- - -- Controlled_Type -- - --------------------- + ------------------------ + -- Needs_Finalization -- + ------------------------ - function Controlled_Type (T : Entity_Id) return Boolean is + function Needs_Finalization (T : Entity_Id) return Boolean is function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; -- If type is not frozen yet, check explicitly among its components, @@ -875,7 +875,7 @@ package body Exp_Ch7 is while Present (Comp) loop if not Is_Type (Comp) - and then Controlled_Type (Etype (Comp)) + and then Needs_Finalization (Etype (Comp)) then return True; end if; @@ -886,7 +886,7 @@ package body Exp_Ch7 is return False; elsif Is_Array_Type (Rec) then - return Is_Controlled (Component_Type (Rec)); + return Needs_Finalization (Component_Type (Rec)); else return Has_Controlled_Component (Rec); @@ -896,7 +896,7 @@ package body Exp_Ch7 is end if; end Has_Some_Controlled_Component; - -- Start of processing for Controlled_Type + -- Start of processing for Needs_Finalization begin -- Class-wide types must be treated as controlled because they may @@ -910,18 +910,18 @@ package body Exp_Ch7 is or else Is_Controlled (T) or else Has_Some_Controlled_Component (T) or else (Is_Concurrent_Type (T) - and then Present (Corresponding_Record_Type (T)) - and then Controlled_Type (Corresponding_Record_Type (T))); - end Controlled_Type; + and then Present (Corresponding_Record_Type (T)) + and then Needs_Finalization (Corresponding_Record_Type (T))); + end Needs_Finalization; - --------------------------- - -- CW_Or_Controlled_Type -- - --------------------------- + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- - function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is begin - return Is_Class_Wide_Type (T) or else Controlled_Type (T); - end CW_Or_Controlled_Type; + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; -------------------------- -- Controller_Component -- @@ -2038,7 +2038,7 @@ package body Exp_Ch7 is null; elsif Scope (Original_Record_Component (Comp)) = E - and then Controlled_Type (Etype (Comp)) + and then Needs_Finalization (Etype (Comp)) then return True; end if; @@ -3429,7 +3429,7 @@ package body Exp_Ch7 is -- and the actual should be finalized on return from the call ??? if Nkind (N) = N_Object_Renaming_Declaration - and then Controlled_Type (Etype (Defining_Identifier (N))) + and then Needs_Finalization (Etype (Defining_Identifier (N))) then null; @@ -3439,7 +3439,7 @@ package body Exp_Ch7 is N_Selected_Component, N_Indexed_Component) and then - Controlled_Type + Needs_Finalization (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) then null; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 8e93b13c83a6..213b4eed542b 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -57,14 +57,19 @@ package Exp_Ch7 is function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' - function Controlled_Type (T : Entity_Id) return Boolean; - -- True if T potentially needs finalization actions - - function CW_Or_Controlled_Type (T : Entity_Id) return Boolean; - -- True if T is either a potentially controlled type or a class-wide type. - -- Note that in normal mode, class-wide types are potentially controlled so - -- this function is different from Controlled_Type only under restrictions - -- No_Finalization. + function Needs_Finalization (T : Entity_Id) return Boolean; + -- True if T potentially needs finalization actions. True if T is + -- controlled, or has subcomponents. Also True if T is a class-wide type, + -- because some type extension might add controlled subcomponents, except + -- that if pragma Restrictions (No_Finalization) applies, this is False for + -- class-wide types. + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; + -- True if T is a class-wide type, or if it has controlled parts ("part" + -- means T or any of its subcomponents). This is the same as + -- Needs_Finalization, except when pragma Restrictions (No_Finalization) + -- applies, in which case we know that class-wide objects do not contain + -- controlled parts. function Find_Final_List (E : Entity_Id; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index a33bf0472a2e..d3f9334a6079 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -815,7 +815,7 @@ package body Exp_Intr is -- Processing for pointer to controlled type - if Controlled_Type (Desig_T) then + if Needs_Finalization (Desig_T) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 09850f644d4d..8e367e1d79d2 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4533,7 +4533,7 @@ package body Exp_Util is elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then not Safe_Unchecked_Type_Conversion (Exp) then - if CW_Or_Controlled_Type (Exp_Type) then + if CW_Or_Has_Controlled_Part (Exp_Type) then -- Use a renaming to capture the expression, rather than create -- a controlled temporary. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0abbb034750b..f77e1e709609 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -518,7 +518,7 @@ package body Freeze is -- the address expression must be a constant. if (No (Expression (Decl)) - and then not Controlled_Type (Typ) + and then not Needs_Finalization (Typ) and then (not Has_Non_Null_Base_Init_Proc (Typ) or else Is_Imported (E))) @@ -547,7 +547,7 @@ package body Freeze is end if; if not Error_Posted (Expr) - and then not Controlled_Type (Typ) + and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); end if; @@ -1381,7 +1381,7 @@ package body Freeze is elsif Is_Access_Type (E) and then Comes_From_Source (E) and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type - and then Controlled_Type (Designated_Type (E)) + and then Needs_Finalization (Designated_Type (E)) and then No (Associated_Final_Chain (E)) then Build_Final_List (Parent (E), E); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 23de8b608543..9a319d992a4c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3118,7 +3118,7 @@ package body Sem_Ch6 is -- actions interfere in complex ways with inlining. elsif Ekind (Subp) = E_Function - and then Controlled_Type (Etype (Subp)) + and then Needs_Finalization (Etype (Subp)) then Cannot_Inline ("cannot inline & (controlled return type)?", N, Subp); @@ -3927,7 +3927,7 @@ package body Sem_Ch6 is if Is_Inherently_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; end; @@ -5268,13 +5268,9 @@ package body Sem_Ch6 is -- returns. This is true even if we are able to get away with -- having 'in out' parameters, which are normally illegal for -- functions. This formal is also needed when the function has - -- a tagged result, because generally such functions can be called - -- in a dispatching context and such calls must be handled like - -- calls to class-wide functions. + -- a tagged result. - if Controlled_Type (Result_Subt) - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) - then + if Needs_BIP_Final_List (E) then Discard := Add_Extra_Formal (E, RTE (RE_Finalizable_Ptr_Ptr),