From d4dfb0056252fbc272a0b15fb9f9697deab3f954 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Fri, 29 Sep 2017 13:48:57 +0000 Subject: [PATCH] exp_ch6.adb (Expand_Call_Helper): Handle case of build-in-place functions returning nonlimited types. 2017-09-29 Bob Duff * exp_ch6.adb (Expand_Call_Helper): Handle case of build-in-place functions returning nonlimited types. Allow for qualified expressions and type conversions. (Expand_N_Extended_Return_Statement): Correct the computation of Func_Bod to allow for child units. (Expand_Simple_Function_Return): Remove assumption that b-i-p implies limited (initialization of In_Place_Expansion), and implies >= Ada 2005. (Is_Build_In_Place_Result_Type): New function to accompany Is_Build_In_Place_Function and Is_Build_In_Place_Function_Call, because sometimes we just have the type on our hands, not the function. For now, does the same thing as the old version, so build-in-place is disabled for nonlimited types, except that you can use -gnatd.9 to enable it. * exp_ch6.ads (Is_Build_In_Place_Result_Type): New function to accompany Is_Build_In_Place_Function and Is_Build_In_Place_Function_Call, because sometimes we just have the type on our hands, not the function. (Make_Build_In_Place_Call_In_...): Handle nonlimited build-in-place cases. (Make_Build_In_Place_Call_In_Object_Declaration): Remove the questionable code at the end that was setting the Etype. * exp_aggr.adb (Is_Build_In_Place_Aggregate_Return): New function to determine whether "return (...agg...);" is returning from a build-in-place function. (Initialize_Ctrl_Array_Component, Initialize_Ctrl_Record_Component): Remove assumption that b-i-p implies limited (initialization of In_Place_Expansion). (Build_Record_Aggr_Code): AI-287: fix comment; it can't be wrapped in an unchecked conversion. Add assertions. (Convert_Aggr_In_Object_Decl): Establish_Transient_Scope -- no need for secondary stack here, just because the type needs finalization. That code is obsolete. (Convert_To_Assignments): Only set Unc_Decl if Nkind (N) = N_Aggregate. For "return (...agg...);" don't assume b-i-p implies limited. Needs_Finalization does not imply secondary stack. (Expand_Array_Aggregate): Named notation. Reverse the sense of Component_OK_For_Backend -- more readability with fewer double negatives. * exp_attr.adb (Expand_N_Attribute_Reference): Remove assumptions that b-i-p implies >= Ada 2005. * exp_ch3.adb (Expand_N_Object_Declaration): Remove assumptions that b-i-p implies >= Ada 2005. Remove Adjust if we're building the return object of an extended return statement in place. * exp_ch4.adb (Expand_Allocator_Expression, Expand_N_Indexed_Component, Expand_N_Selected_Component, Expand_N_Slice): Remove assumptions that b-i-p implies >= Ada 2005. * exp_ch5.adb (Expand_N_Assignment_Statement): Remove assumption that b-i-p implies >= Ada 2005. * exp_ch7.adb: Comment fix. * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Remove assumptions that b-i-p implies >= Ada 2005. * exp_disp.adb (Expand_Interface_Actuals): Remove assumptions that b-i-p implies >= Ada 2005. * exp_util.adb (Build_Allocate_Deallocate_Proc): Look at Storage_Pool (Expr), in case Pool_Id is not set. (Initialized_By_Aliased_BIP_Func_Call): Handle case where the call is qualified or converted. (Is_Secondary_Stack_BIP_Func_Call): Don't check if Nkind (Selector_Name (Param)) = N_Identifier; that's all it could be. * sinfo.ads: Comment fixes. * snames.ads-tmpl: Comment fixes. * debug.adb: Add flag gnatd.9, to enable the build-in-place machinery. From-SVN: r253290 --- gcc/ada/ChangeLog | 66 +++++++++++ gcc/ada/debug.adb | 5 +- gcc/ada/exp_aggr.adb | 146 +++++++++++++----------- gcc/ada/exp_attr.adb | 13 +-- gcc/ada/exp_ch3.adb | 32 +++--- gcc/ada/exp_ch4.adb | 46 ++------ gcc/ada/exp_ch5.adb | 12 +- gcc/ada/exp_ch6.adb | 240 +++++++++++++++++++++------------------- gcc/ada/exp_ch6.ads | 35 +++--- gcc/ada/exp_ch7.adb | 2 +- gcc/ada/exp_ch8.adb | 13 +-- gcc/ada/exp_disp.adb | 4 +- gcc/ada/exp_util.adb | 12 +- gcc/ada/sinfo.ads | 6 +- gcc/ada/snames.ads-tmpl | 2 +- 15 files changed, 356 insertions(+), 278 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8b566a7cbce..c71ad27325b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,69 @@ +2017-09-29 Bob Duff + + * exp_ch6.adb (Expand_Call_Helper): Handle case of build-in-place + functions returning nonlimited types. Allow for qualified expressions + and type conversions. + (Expand_N_Extended_Return_Statement): Correct the computation of + Func_Bod to allow for child units. + (Expand_Simple_Function_Return): Remove assumption that b-i-p implies + limited (initialization of In_Place_Expansion), and implies >= Ada + 2005. + (Is_Build_In_Place_Result_Type): New function to accompany + Is_Build_In_Place_Function and Is_Build_In_Place_Function_Call, because + sometimes we just have the type on our hands, not the function. For + now, does the same thing as the old version, so build-in-place is + disabled for nonlimited types, except that you can use -gnatd.9 to + enable it. + * exp_ch6.ads (Is_Build_In_Place_Result_Type): New function to + accompany Is_Build_In_Place_Function and + Is_Build_In_Place_Function_Call, because sometimes we just have the + type on our hands, not the function. + (Make_Build_In_Place_Call_In_...): Handle nonlimited build-in-place + cases. + (Make_Build_In_Place_Call_In_Object_Declaration): Remove the + questionable code at the end that was setting the Etype. + * exp_aggr.adb (Is_Build_In_Place_Aggregate_Return): New function to + determine whether "return (...agg...);" is returning from a + build-in-place function. + (Initialize_Ctrl_Array_Component, Initialize_Ctrl_Record_Component): + Remove assumption that b-i-p implies limited (initialization of + In_Place_Expansion). + (Build_Record_Aggr_Code): AI-287: fix comment; it can't be wrapped in + an unchecked conversion. Add assertions. + (Convert_Aggr_In_Object_Decl): Establish_Transient_Scope -- no need for + secondary stack here, just because the type needs finalization. That + code is obsolete. + (Convert_To_Assignments): Only set Unc_Decl if Nkind (N) = N_Aggregate. + For "return (...agg...);" don't assume b-i-p implies limited. + Needs_Finalization does not imply secondary stack. + (Expand_Array_Aggregate): Named notation. Reverse the sense of + Component_OK_For_Backend -- more readability with fewer double + negatives. + * exp_attr.adb (Expand_N_Attribute_Reference): Remove assumptions that + b-i-p implies >= Ada 2005. + * exp_ch3.adb (Expand_N_Object_Declaration): Remove assumptions that + b-i-p implies >= Ada 2005. Remove Adjust if we're building the return + object of an extended return statement in place. + * exp_ch4.adb (Expand_Allocator_Expression, Expand_N_Indexed_Component, + Expand_N_Selected_Component, Expand_N_Slice): Remove assumptions that + b-i-p implies >= Ada 2005. + * exp_ch5.adb (Expand_N_Assignment_Statement): Remove assumption that + b-i-p implies >= Ada 2005. + * exp_ch7.adb: Comment fix. + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Remove + assumptions that b-i-p implies >= Ada 2005. + * exp_disp.adb (Expand_Interface_Actuals): Remove assumptions that + b-i-p implies >= Ada 2005. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Look at Storage_Pool + (Expr), in case Pool_Id is not set. + (Initialized_By_Aliased_BIP_Func_Call): Handle case where the call is + qualified or converted. + (Is_Secondary_Stack_BIP_Func_Call): Don't check if Nkind (Selector_Name + (Param)) = N_Identifier; that's all it could be. + * sinfo.ads: Comment fixes. + * snames.ads-tmpl: Comment fixes. + * debug.adb: Add flag gnatd.9, to enable the build-in-place machinery. + 2017-09-29 Justin Squirek * sem_ch8.adb (Mark_Use_Clauses): Add recursive call to properly handle diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 77afd4b8c98..25d08399220 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -163,7 +163,7 @@ package body Debug is -- d.6 Do not avoid declaring unreferenced types in C code -- d.7 -- d.8 - -- d.9 + -- d.9 Enable build-in-place for nonlimited types -- Debug flags for binder (GNATBIND) @@ -820,6 +820,9 @@ package body Debug is -- referenced by the generated C code. This debug flag restores the -- output of all the types. + -- d.9 Enable build-in-place for function calls returning some nonlimited + -- types. + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 0d6d3d14c9d..972f6d58c4c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -175,6 +175,10 @@ package body Exp_Aggr is -- Local subprograms for Record Aggregate Expansion -- ------------------------------------------------------ + function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean; + -- True if N is an aggregate (possibly qualified or converted) that is + -- being returned from a build-in-place function. + function Build_Record_Aggr_Code (N : Node_Id; Typ : Entity_Id; @@ -186,10 +190,9 @@ package body Exp_Aggr is -- types. procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); - -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the - -- aggregate (which can only be a record type, this procedure is only used - -- for record types). Transform the given aggregate into a sequence of - -- assignments performed component by component. + -- Transform a record aggregate into a sequence of assignments performed + -- component by component. N is an N_Aggregate or N_Extension_Aggregate. + -- Typ is the type of the record aggregate. procedure Expand_Record_Aggregate (N : Node_Id; @@ -762,10 +765,10 @@ package body Exp_Aggr is -- Checks 5 (if the component type is tagged, then we may need to do -- tag adjustments. Perhaps this should be refined to check for any -- component associations that actually need tag adjustment, similar - -- to the test in Component_Not_OK_For_Backend for record aggregates - -- with tagged components, but not clear whether it's worthwhile ???; - -- in the case of virtual machines (no Tagged_Type_Expansion), object - -- tags are handled implicitly). + -- to the test in Component_OK_For_Backend for record aggregates with + -- tagged components, but not clear whether it's worthwhile ???; in the + -- case of virtual machines (no Tagged_Type_Expansion), object tags are + -- handled implicitly). if Is_Tagged_Type (Component_Type (Typ)) and then Tagged_Type_Expansion @@ -1347,7 +1350,7 @@ package body Exp_Aggr is In_Place_Expansion := Nkind (Expr) = N_Function_Call - and then not Is_Limited_Type (Comp_Typ); + and then not Is_Build_In_Place_Result_Type (Comp_Typ); -- The initialization expression is a controlled function call. -- Perform in-place removal of side effects to avoid creating a @@ -2831,7 +2834,7 @@ package body Exp_Aggr is In_Place_Expansion := Nkind (Init_Expr) = N_Function_Call - and then not Is_Limited_Type (Comp_Typ); + and then not Is_Build_In_Place_Result_Type (Comp_Typ); -- The initialization expression is a controlled function call. -- Perform in-place removal of side effects to avoid creating a @@ -2967,7 +2970,10 @@ package body Exp_Aggr is -- [Deep_]Adjust (Rec_Comp); - if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then + if Finalization_OK + and then not Is_Limited_Type (Comp_Typ) + and then not Is_Build_In_Place_Function_Call (Init_Expr) + then Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Rec_Comp), @@ -3229,12 +3235,8 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): If the ancestor part is an aggregate of -- limited type, a recursive call expands the ancestor. Note that -- in the limited case, the ancestor part must be either a - -- function call (possibly qualified, or wrapped in an unchecked - -- conversion) or aggregate (definitely qualified). - - -- The ancestor part can also be a function call (that may be - -- transformed into an explicit dereference) or a qualification - -- of one such. + -- function call (possibly qualified) or aggregate (definitely + -- qualified). elsif Is_Limited_Type (Etype (Ancestor)) and then Nkind_In (Unqualify (Ancestor), N_Aggregate, @@ -3330,6 +3332,7 @@ package body Exp_Aggr is if Needs_Finalization (Etype (Ancestor)) and then not Is_Limited_Type (Etype (Ancestor)) + and then not Is_Build_In_Place_Function_Call (Ancestor) then Adj_Call := Make_Adjust_Call @@ -3351,6 +3354,10 @@ package body Exp_Aggr is Check_Ancestor_Discriminants (Init_Typ); end if; end if; + + pragma Assert (Nkind (N) = N_Extension_Aggregate); + pragma Assert + (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark)); end; -- Generate assignments of hidden discriminants. If the base type is @@ -4073,10 +4080,7 @@ package body Exp_Aggr is and then Ekind (Current_Scope) /= E_Return_Statement and then not Is_Limited_Type (Typ) then - Establish_Transient_Scope - (Aggr, - Sec_Stack => - Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); + Establish_Transient_Scope (Aggr, Sec_Stack => False); end if; declare @@ -4121,6 +4125,25 @@ package body Exp_Aggr is -- Convert_To_Assignments -- ---------------------------- + function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + begin + while Nkind (P) = N_Qualified_Expression loop + P := Parent (P); + end loop; + + if Nkind (P) = N_Simple_Return_Statement then + null; + elsif Nkind (Parent (P)) = N_Extended_Return_Statement then + P := Parent (P); + else + return False; + end if; + + return Is_Build_In_Place_Function + (Return_Applies_To (Return_Statement_Entity (P))); + end Is_Build_In_Place_Aggregate_Return; + procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); T : Entity_Id; @@ -4134,6 +4157,7 @@ package body Exp_Aggr is Parent_Node : Node_Id; begin + pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); pragma Assert (Is_Record_Type (Typ)); @@ -4141,10 +4165,9 @@ package body Exp_Aggr is Parent_Kind := Nkind (Parent_Node); if Parent_Kind = N_Qualified_Expression then - - -- Check if we are in a unconstrained declaration because in this + -- Check if we are in an unconstrained declaration because in this -- case the current delayed expansion mechanism doesn't work when - -- the declared object size depend on the initializing expr. + -- the declared object size depends on the initializing expr. Parent_Node := Parent (Parent_Node); Parent_Kind := Nkind (Parent_Node); @@ -4152,8 +4175,9 @@ package body Exp_Aggr is if Parent_Kind = N_Object_Declaration then Unc_Decl := not Is_Entity_Name (Object_Definition (Parent_Node)) - or else Has_Discriminants - (Entity (Object_Definition (Parent_Node))) + or else (Nkind (N) = N_Aggregate + and then Has_Discriminants + (Entity (Object_Definition (Parent_Node)))) or else Is_Class_Wide_Type (Entity (Object_Definition (Parent_Node))); end if; @@ -4195,11 +4219,7 @@ package body Exp_Aggr is -- finalization of the return object (which is built in place -- within the caller's scope). - or else - (Is_Limited_View (Typ) - and then - (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement - or else Nkind (Parent_Node) = N_Simple_Return_Statement)) + or else Is_Build_In_Place_Aggregate_Return (N) then Set_Expansion_Delayed (N); return; @@ -4214,7 +4234,7 @@ package body Exp_Aggr is -- Should the condition be more restrictive ??? if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then - Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ)); + Establish_Transient_Scope (N, Sec_Stack => False); end if; -- If the aggregate is nonlimited, create a temporary. If it is limited @@ -6111,8 +6131,7 @@ package body Exp_Aggr is -- for default initialization, e.g. with Initialize_Scalars. if Requires_Transient_Scope (Typ) then - Establish_Transient_Scope - (N, Sec_Stack => Has_Controlled_Component (Typ)); + Establish_Transient_Scope (N, Sec_Stack => False); end if; if Has_Default_Init_Comps (N) then @@ -6251,7 +6270,7 @@ package body Exp_Aggr is if Ekind (Current_Scope) = E_Loop and then Nkind (Parent (Parent (N))) = N_Allocator then - Establish_Transient_Scope (N, False); + Establish_Transient_Scope (N, Sec_Stack => False); end if; Insert_Action (N, Tmp_Decl); @@ -6646,13 +6665,13 @@ package body Exp_Aggr is -- If the ancestor part is an expression, add a component association for -- the parent field. If the type of the ancestor part is not the direct - -- parent of the expected type, build recursively the needed ancestors. - -- If the ancestor part is a subtype_mark, replace aggregate with a decla- - -- ration for a temporary of the expected type, followed by individual - -- assignments to the given components. + -- parent of the expected type, build recursively the needed ancestors. + -- If the ancestor part is a subtype_mark, replace aggregate with a + -- declaration for a temporary of the expected type, followed by + -- individual assignments to the given components. procedure Expand_N_Extension_Aggregate (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); A : constant Node_Id := Ancestor_Part (N); Typ : constant Entity_Id := Etype (N); @@ -6709,7 +6728,7 @@ package body Exp_Aggr is Static_Components : Boolean := True; -- Flag to indicate whether all components are compile-time known, -- and the aggregate can be constructed statically and handled by - -- the back-end. + -- the back-end. Set to False by Component_OK_For_Backend. procedure Build_Back_End_Aggregate; -- Build a proper aggregate to be handled by the back-end @@ -6722,7 +6741,7 @@ package body Exp_Aggr is -- This returns true for N_Aggregate with Compile_Time_Known_Aggregate -- set and constants whose expression is such an aggregate, recursively. - function Component_Not_OK_For_Backend return Boolean; + function Component_OK_For_Backend return Boolean; -- Check for presence of a component which makes it impossible for the -- backend to process the aggregate, thus requiring the use of a series -- of assignment statements. Cases checked for are a nested aggregate @@ -6741,6 +6760,9 @@ package body Exp_Aggr is -- in order to minimize elaboration code. This is one case where the -- semantics of Ada complicate the analysis and lead to anomalies in -- the gcc back-end if the aggregate is not expanded into assignments. + -- + -- NOTE: This sets the global Static_Components to False in most, but + -- not all, cases when it returns False. function Has_Per_Object_Constraint (L : List_Id) return Boolean; -- Return True if any element of L has Has_Per_Object_Constraint set. @@ -7043,7 +7065,7 @@ package body Exp_Aggr is -- The ancestor part may be a nested aggregate that has -- delayed expansion: recheck now. - if Component_Not_OK_For_Backend then + if not Component_OK_For_Backend then Convert_To_Assignments (N, Typ); end if; end; @@ -7110,17 +7132,17 @@ package body Exp_Aggr is end Compile_Time_Known_Composite_Value; - ---------------------------------- - -- Component_Not_OK_For_Backend -- - ---------------------------------- + ------------------------------ + -- Component_OK_For_Backend -- + ------------------------------ - function Component_Not_OK_For_Backend return Boolean is + function Component_OK_For_Backend return Boolean is C : Node_Id; Expr_Q : Node_Id; begin if No (Comps) then - return False; + return True; end if; C := First (Comps); @@ -7130,7 +7152,7 @@ package body Exp_Aggr is -- and component is not ready for backend. if Box_Present (C) then - return True; + return False; end if; if Nkind (Expression (C)) = N_Qualified_Expression then @@ -7139,7 +7161,7 @@ package body Exp_Aggr is Expr_Q := Expression (C); end if; - -- Return true if the aggregate has any associations for tagged + -- Return False if the aggregate has any associations for tagged -- components that may require tag adjustment. -- These are cases where the source expression may have a tag that @@ -7156,36 +7178,36 @@ package body Exp_Aggr is and then Tagged_Type_Expansion then Static_Components := False; - return True; + return False; elsif Is_Delayed_Aggregate (Expr_Q) then Static_Components := False; - return True; + return False; elsif Possible_Bit_Aligned_Component (Expr_Q) then Static_Components := False; - return True; + return False; elsif Modify_Tree_For_C and then Nkind (C) = N_Component_Association and then Has_Per_Object_Constraint (Choices (C)) then Static_Components := False; - return True; + return False; elsif Modify_Tree_For_C and then Nkind (Expr_Q) = N_Identifier and then Is_Array_Type (Etype (Expr_Q)) then Static_Components := False; - return True; + return False; elsif Modify_Tree_For_C and then Nkind (Expr_Q) = N_Type_Conversion and then Is_Array_Type (Etype (Expr_Q)) then Static_Components := False; - return True; + return False; end if; if Is_Elementary_Type (Etype (Expr_Q)) then @@ -7199,15 +7221,15 @@ package body Exp_Aggr is if Is_Private_Type (Etype (Expr_Q)) and then Has_Discriminants (Etype (Expr_Q)) then - return True; + return False; end if; end if; Next (C); end loop; - return False; - end Component_Not_OK_For_Backend; + return True; + end Component_OK_For_Backend; ------------------------------- -- Has_Per_Object_Constraint -- @@ -7297,7 +7319,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-318-2): We need to convert to assignments if components -- are build-in-place function calls. The assignments will each turn -- into a build-in-place function call. If components are all static, - -- we can pass the aggregate to the backend regardless of limitedness. + -- we can pass the aggregate to the back end regardless of limitedness. -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. @@ -7314,7 +7336,7 @@ package body Exp_Aggr is Convert_To_Assignments (N, Typ); elsif not Size_Known_At_Compile_Time (Typ) - or else Component_Not_OK_For_Backend + or else not Component_OK_For_Backend or else not Static_Components then Convert_To_Assignments (N, Typ); @@ -7349,7 +7371,7 @@ package body Exp_Aggr is -- Check components - elsif Component_Not_OK_For_Backend then + elsif not Component_OK_For_Backend then Convert_To_Assignments (N, Typ); -- If an ancestor is private, some components are not inherited and we diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 9afb23be02e..552cd0295b5 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1753,23 +1753,16 @@ package body Exp_Attr is -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- -- place function, then a temporary return object needs to be created - -- and access to it must be passed to the function. Currently we limit - -- such functions to those with inherently limited result subtypes, but - -- eventually we plan to expand the functions that are treated as - -- build-in-place to include other composite result types. + -- and access to it must be passed to the function. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Pref) - then + if Is_Build_In_Place_Function_Call (Pref) then Make_Build_In_Place_Call_In_Anonymous_Context (Pref); -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix -- containing build-in-place function calls whose returned object covers -- interface types. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (Pref)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 39ad94a3437..0198e3e5f7e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6299,9 +6299,7 @@ package body Exp_Ch3 is -- plan to expand the allowed forms of functions that are treated as -- build-in-place. - elsif Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Expr_Q) - then + elsif Is_Build_In_Place_Function_Call (Expr_Q) then Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); -- The previous call expands the expression initializing the @@ -6317,9 +6315,7 @@ package body Exp_Ch3 is -- in-place object to reference the secondary dispatch table of a -- covered interface type. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q); -- The previous call expands the expression initializing the @@ -6617,13 +6613,19 @@ package body Exp_Ch3 is -- the target is adjusted after the copy and attached to the -- finalization list. However, no adjustment is done in the case -- where the object was initialized by a call to a function whose - -- result is built in place, since no copy occurred. (Eventually - -- we plan to support in-place function results for some cases - -- of nonlimited types. ???) Similarly, no adjustment is required - -- if we are going to rewrite the object declaration into a - -- renaming declaration. + -- result is built in place, since no copy occurred. Similarly, no + -- adjustment is required if we are going to rewrite the object + -- declaration into a renaming declaration. + + if Is_Build_In_Place_Result_Type (Typ) + and then Nkind (Parent (N)) = N_Extended_Return_Statement + and then not Is_Definite_Subtype + (Etype (Return_Applies_To + (Return_Statement_Entity (Parent (N))))) + then + null; - if Needs_Finalization (Typ) + elsif Needs_Finalization (Typ) and then not Is_Limited_View (Typ) and then not Rewrite_As_Renaming then @@ -6755,9 +6757,9 @@ package body Exp_Ch3 is end if; end if; - -- Cases where the back end cannot handle the initialization directly - -- In such cases, we expand an assignment that will be appropriately - -- handled by Expand_N_Assignment_Statement. + -- Cases where the back end cannot handle the initialization + -- directly. In such cases, we expand an assignment that will + -- be appropriately handled by Expand_N_Assignment_Statement. -- The exclusion of the unconstrained case is wrong, but for now it -- is too much trouble ??? diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 61d00aa68d3..0fe189b8a40 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -793,14 +793,9 @@ package body Exp_Ch4 is -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the allocated object - -- must be passed to the function. Currently we limit such functions - -- to those with constrained limited result subtypes, but eventually - -- we plan to expand the allowed forms of functions that are treated - -- as build-in-place. + -- must be passed to the function. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Exp) - then + if Is_Build_In_Place_Function_Call (Exp) then Make_Build_In_Place_Call_In_Allocator (N, Exp); Apply_Accessibility_Check (N, Built_In_Place => True); return; @@ -812,9 +807,7 @@ package body Exp_Ch4 is -- in-place object to reference the secondary dispatch table of a -- covered interface type. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (Exp)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); Apply_Accessibility_Check (N, Built_In_Place => True); return; @@ -1223,14 +1216,9 @@ package body Exp_Ch4 is -- Ada 2005 (AI-318-02): If the initialization expression is a call -- to a build-in-place function, then access to the allocated object - -- must be passed to the function. Currently we limit such functions - -- to those with constrained limited result subtypes, but eventually - -- we plan to expand the allowed forms of functions that are treated - -- as build-in-place. + -- must be passed to the function. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Exp) - then + if Is_Build_In_Place_Function_Call (Exp) then Make_Build_In_Place_Call_In_Allocator (N, Exp); end if; end if; @@ -6572,18 +6560,14 @@ package body Exp_Ch4 is -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place -- function, then additional actuals must be passed. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (P) - then + if Is_Build_In_Place_Function_Call (P) then Make_Build_In_Place_Call_In_Anonymous_Context (P); -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix -- containing build-in-place function calls whose returned object covers -- interface types. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (P)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (P)) then Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); end if; @@ -10221,18 +10205,14 @@ package body Exp_Ch4 is -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place -- function, then additional actuals must be passed. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (P) - then + if Is_Build_In_Place_Function_Call (P) then Make_Build_In_Place_Call_In_Anonymous_Context (P); -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix -- containing build-in-place function calls whose returned object covers -- interface types. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (P)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (P)) then Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); end if; @@ -10587,18 +10567,14 @@ package body Exp_Ch4 is -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place -- function, then additional actuals must be passed. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Pref) - then + if Is_Build_In_Place_Function_Call (Pref) then Make_Build_In_Place_Call_In_Anonymous_Context (Pref); -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix -- containing build-in-place function calls whose returned object covers -- interface types. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (Pref)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 933d33bd32a..5846874fc30 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2390,13 +2390,13 @@ package body Exp_Ch5 is end; end if; - -- Build-in-place function call case. Note that we're not yet doing - -- build-in-place for user-written assignment statements (the assignment - -- here came from an aggregate.) + -- Build-in-place function call case. This is for assignment statements + -- that come from aggregate component associations or from init procs. + -- User-written assignment statements with b-i-p calls are handled + -- elsewhere. - elsif Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Rhs) - then + elsif Is_Build_In_Place_Function_Call (Rhs) then + pragma Assert (not Comes_From_Source (N)); Make_Build_In_Place_Call_In_Assignment (N, Rhs); elsif Is_Tagged_Type (Typ) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2ee1c7879c6..5fcd1f587cd 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2252,6 +2252,9 @@ package body Exp_Ch6 is procedure Expand_Call (N : Node_Id) is Post_Call : List_Id; begin + pragma Assert + (Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement, + N_Entry_Call_Statement)); Expand_Call_Helper (N, Post_Call); Insert_Post_Call_Actions (N, Post_Call); end Expand_Call; @@ -4327,29 +4330,30 @@ package body Exp_Ch6 is -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then - if not Is_Limited_View (Etype (Subp)) - and then - (No (First_Formal (Subp)) - or else - not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) - then - Expand_Ctrl_Function_Call (Call_Node); - -- Build-in-place function calls which appear in anonymous contexts -- need a transient scope to ensure the proper finalization of the -- intermediate result after its use. - elsif Is_Build_In_Place_Function_Call (Call_Node) + if Is_Build_In_Place_Function_Call (Call_Node) and then - Nkind_In (Parent (Call_Node), N_Attribute_Reference, - N_Function_Call, - N_Indexed_Component, - N_Object_Renaming_Declaration, - N_Procedure_Call_Statement, - N_Selected_Component, - N_Slice) + Nkind_In (Parent (Unqual_Conv (Call_Node)), + N_Attribute_Reference, + N_Function_Call, + N_Indexed_Component, + N_Object_Renaming_Declaration, + N_Procedure_Call_Statement, + N_Selected_Component, + N_Slice) then Establish_Transient_Scope (Call_Node, Sec_Stack => True); + + elsif not Is_Build_In_Place_Function_Call (Call_Node) + and then + (No (First_Formal (Subp)) + or else + not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) + then + Expand_Ctrl_Function_Call (Call_Node); end if; end if; end Expand_Call_Helper; @@ -4756,6 +4760,12 @@ package body Exp_Ch6 is Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); end if; + if Nkind (Func_Bod) = N_Function_Specification then + Func_Bod := Parent (Func_Bod); -- one more level for child units + end if; + + pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body); + -- Create a flag to track the function state Flag_Id := Make_Temporary (Loc, 'F'); @@ -4781,8 +4791,7 @@ package body Exp_Ch6 is -- Build a simple_return_statement that returns the return object when -- there is a statement sequence, or no expression, or the result will -- be built in place. Note however that we currently do this for all - -- composite cases, even though nonlimited composite results are not yet - -- built in place (though we plan to do so eventually). + -- composite cases, even though not all are built in place. if Present (HSS) or else Is_Composite_Type (Ret_Typ) @@ -6385,8 +6394,8 @@ package body Exp_Ch6 is end if; -- For the case of a simple return that does not come from an extended - -- return, in the case of Ada 2005 where we are returning a limited - -- type, we rewrite "return ;" to be: + -- return, in the case of build-in-place, we rewrite "return + -- ;" to be: -- return _anon_ : := @@ -6414,9 +6423,13 @@ package body Exp_Ch6 is -- class-wide interface type, which is not a limited type, even though -- the type of the expression may be. + pragma Assert + (Comes_From_Extended_Return_Statement (N) + or else not Is_Build_In_Place_Function_Call (Exp) + or else Is_Build_In_Place_Function (Scope_Id)); + if not Comes_From_Extended_Return_Statement (N) - and then Is_Limited_View (Etype (Expression (N))) - and then Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function (Scope_Id) and then not Debug_Flag_Dot_L -- The functionality of interface thunks is simple and it is always @@ -6494,7 +6507,7 @@ package body Exp_Ch6 is -- type that requires special processing (indicated by the fact that -- it requires a cleanup scope for the secondary stack case). - if Is_Limited_View (Exptyp) + if Is_Build_In_Place_Function (Scope_Id) or else Is_Limited_Interface (Exptyp) then null; @@ -7186,6 +7199,24 @@ package body Exp_Ch6 is return False; end Has_Unconstrained_Access_Discriminants; + ----------------------------------- + -- Is_Build_In_Place_Result_Type -- + ----------------------------------- + + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is + begin + -- In Ada 2005 all functions with an inherently limited return type + -- must be handled using a build-in-place profile, including the case + -- of a function with a limited interface result, where the function + -- may return objects of nonlimited descendants. + + if Is_Limited_View (Typ) then + return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; + else + return Debug_Flag_Dot_9; + end if; + end Is_Build_In_Place_Result_Type; + -------------------------------- -- Is_Build_In_Place_Function -- -------------------------------- @@ -7216,19 +7247,9 @@ package body Exp_Ch6 is -- intended to be compatible with the other language, but the build- -- in place machinery can ensure that the object is not copied. - if Has_Foreign_Convention (E) then - return False; - - -- In Ada 2005 all functions with an inherently limited return type - -- must be handled using a build-in-place profile, including the case - -- of a function with a limited interface result, where the function - -- may return objects of nonlimited descendants. - - else - return Is_Limited_View (Etype (E)) - and then Ada_Version >= Ada_2005 - and then not Debug_Flag_Dot_L; - end if; + return Is_Build_In_Place_Result_Type (Etype (E)) + and then not Has_Foreign_Convention (E) + and then not Debug_Flag_Dot_L; else return False; @@ -7256,34 +7277,33 @@ package body Exp_Ch6 is -- may end up with a call that is neither resolved to an entity, nor -- an indirect call. - if not Expander_Active then + if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then return False; end if; - if Nkind (Exp_Node) /= N_Function_Call then - return False; - - else - if Is_Entity_Name (Name (Exp_Node)) then - Function_Id := Entity (Name (Exp_Node)); + if Is_Entity_Name (Name (Exp_Node)) then + Function_Id := Entity (Name (Exp_Node)); - -- In the case of an explicitly dereferenced call, use the subprogram - -- type generated for the dereference. + -- In the case of an explicitly dereferenced call, use the subprogram + -- type generated for the dereference. - elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then - Function_Id := Etype (Name (Exp_Node)); + elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Exp_Node)); - -- This may be a call to a protected function. + -- This may be a call to a protected function. - elsif Nkind (Name (Exp_Node)) = N_Selected_Component then - Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); + elsif Nkind (Name (Exp_Node)) = N_Selected_Component then + Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); - else - raise Program_Error; - end if; - - return Is_Build_In_Place_Function (Function_Id); + else + raise Program_Error; end if; + + declare + Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); + begin + return Result; + end; end Is_Build_In_Place_Function_Call; ----------------------- @@ -7693,16 +7713,9 @@ package body Exp_Ch6 is Func_Call := Expression (Func_Call); end if; - -- If the call has already been processed to add build-in-place actuals - -- then return. This should not normally occur in an allocator context, - -- but we add the protection as a defensive measure. - - if Is_Expanded_Build_In_Place_Call (Func_Call) then - return; - end if; - -- Mark the call as processed as a build-in-place call + pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); Set_Is_Expanded_Build_In_Place_Call (Func_Call); Loc := Sloc (Function_Call); @@ -7727,6 +7740,8 @@ package body Exp_Ch6 is Return_Obj_Access := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Access, Acc_Type); + Set_Can_Never_Be_Null (Acc_Type, False); + -- It gets initialized to null, so we can't have that. -- When the result subtype is constrained, the return object is -- allocated on the caller side, and access to it is passed to the @@ -7738,7 +7753,6 @@ package body Exp_Ch6 is -- the characteristics of the full view. if Is_Constrained (Underlying_Type (Result_Subt)) then - -- Replace the initialized allocator of form "new T'(Func (...))" -- with an uninitialized allocator of form "new T", where T is the -- result subtype of the called function. The call to the function @@ -8051,7 +8065,7 @@ package body Exp_Ch6 is Lhs : constant Node_Id := Name (Assign); Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Func_Id : Entity_Id; - Loc : Source_Ptr; + Loc : constant Source_Ptr := Sloc (Function_Call); Obj_Decl : Node_Id; Obj_Id : Entity_Id; Ptr_Typ : Entity_Id; @@ -8060,20 +8074,11 @@ package body Exp_Ch6 is Result_Subt : Entity_Id; begin - -- If the call has already been processed to add build-in-place actuals - -- then return. This should not normally occur in an assignment context, - -- but we add the protection as a defensive measure. - - if Is_Expanded_Build_In_Place_Call (Func_Call) then - return; - end if; - -- Mark the call as processed as a build-in-place call + pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); Set_Is_Expanded_Build_In_Place_Call (Func_Call); - Loc := Sloc (Function_Call); - if Is_Entity_Name (Name (Func_Call)) then Func_Id := Entity (Name (Func_Call)); @@ -8131,6 +8136,13 @@ package body Exp_Ch6 is New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); + -- Add a conversion if it's the wrong type + + if Etype (New_Expr) /= Ptr_Typ then + New_Expr := Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Ptr_Typ, Loc), New_Expr); + end if; + Obj_Id := Make_Temporary (Loc, 'R', New_Expr); Set_Etype (Obj_Id, Ptr_Typ); Set_Is_Known_Non_Null (Obj_Id); @@ -8165,6 +8177,7 @@ package body Exp_Ch6 is Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; Pool_Actual : Node_Id; + Designated_Type : Entity_Id; Ptr_Typ : Entity_Id; Ptr_Typ_Decl : Node_Id; Pass_Caller_Acc : Boolean := False; @@ -8172,16 +8185,9 @@ package body Exp_Ch6 is Result_Subt : Entity_Id; begin - -- If the call has already been processed to add build-in-place actuals - -- then return. This should not normally occur in an object declaration, - -- but we add the protection as a defensive measure. - - if Is_Expanded_Build_In_Place_Call (Func_Call) then - return; - end if; - -- Mark the call as processed as a build-in-place call + pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); Set_Is_Expanded_Build_In_Place_Call (Func_Call); if Is_Entity_Name (Name (Func_Call)) then @@ -8208,6 +8214,15 @@ package body Exp_Ch6 is -- access type must be declared before we establish a transient -- scope, so that it receives the proper accessibility level. + if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) + and then not Is_Interface (Etype (Defining_Identifier (Obj_Decl))) + and then not Is_Class_Wide_Type (Etype (Function_Call)) + then + Designated_Type := Etype (Defining_Identifier (Obj_Decl)); + else + Designated_Type := Etype (Function_Call); + end if; + Ptr_Typ := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -8216,7 +8231,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => - New_Occurrence_Of (Etype (Function_Call), Loc))); + New_Occurrence_Of (Designated_Type, Loc))); -- The access type and its accompanying object must be inserted after -- the object declaration in the constrained case, so that the @@ -8238,15 +8253,10 @@ package body Exp_Ch6 is -- Force immediate freezing of Ptr_Typ because Res_Decl will be -- elaborated in an inner (transient) scope and thus won't cause - -- freezing by itself. + -- freezing by itself. It's not an itype, but it needs to be frozen + -- inside the current subprogram (see Freeze_Outside in freeze.adb). - declare - Ptr_Typ_Freeze_Ref : constant Node_Id := - New_Occurrence_Of (Ptr_Typ, Loc); - begin - Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl); - Freeze_Expression (Ptr_Typ_Freeze_Ref); - end; + Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl); -- If the object is a return object of an enclosing build-in-place -- function, then the implicit build-in-place parameters of the @@ -8424,13 +8434,25 @@ package body Exp_Ch6 is Set_Etype (Def_Id, Ptr_Typ); Set_Is_Known_Non_Null (Def_Id); - Res_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), - Expression => - Make_Reference (Loc, Relocate_Node (Func_Call))); + if Nkind (Function_Call) = N_Type_Conversion then + Res_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Ptr_Typ, Loc), + Make_Reference (Loc, Relocate_Node (Func_Call)))); + else + Res_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), + Expression => + Make_Reference (Loc, Relocate_Node (Func_Call))); + end if; Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); @@ -8475,7 +8497,8 @@ package body Exp_Ch6 is Rewrite (Obj_Decl, Make_Object_Renaming_Declaration (Obj_Loc, Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), - Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc), + Subtype_Mark => + New_Occurrence_Of (Designated_Type, Obj_Loc), Name => Call_Deref)); Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); @@ -8495,18 +8518,6 @@ package body Exp_Ch6 is (Obj_Decl, Original_Node (Obj_Decl)); end if; end; - - -- If the object entity has a class-wide Etype, then we need to change - -- it to the result subtype of the function call, because otherwise the - -- object will be class-wide without an explicit initialization and - -- won't be allocated properly by the back end. It seems unclean to make - -- such a revision to the type at this point, and we should try to - -- improve this treatment when build-in-place functions with class-wide - -- results are implemented. ??? - - if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then - Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt); - end if; end Make_Build_In_Place_Call_In_Object_Declaration; ------------------------------------------------- @@ -9225,6 +9236,11 @@ package body Exp_Ch6 is -- Start of processing for Unqual_BIP_Iface_Function_Call begin + if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then + -- Can happen for X'Elab_Spec in the binder-generated file. + return Empty; + end if; + return Unqual_BIP_Function_Call (Expr); end Unqual_BIP_Iface_Function_Call; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index c4fc3bc8588..530f615b63b 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -117,25 +117,30 @@ package Exp_Ch6 is -- The returned node is the root of the procedure body which will replace -- the original function body, which is not needed for the C program. + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if functions returning the type use + -- build-in-place protocols. For inherently limited types, this must be + -- True in >= Ada 2005, and must be False in Ada 95. For other types, it + -- can be True or False, and the decision should be based on efficiency, + -- and should be the same for all language versions, so that mixed-dialect + -- programs will work. + -- + -- For inherently limited types in Ada 2005, True means that calls will + -- actually be build-in-place in all cases. For other types, build-in-place + -- will be used when possible, but we need to make a copy at the call site + -- in some cases, notably assignment statements. + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic - -- function, or access-to-function type whose result must be built in - -- place; otherwise returns False. For Ada 2005, this is currently - -- restricted to the set of functions whose result subtype is an inherently - -- limited type. In Ada 95, this must be False for inherently limited - -- result types (but currently returns False for all Ada 95 functions). - -- Eventually we plan to support build-in-place for nonlimited types. - -- Build-in-place is usually more efficient for large things, and less - -- efficient for small things. However, we never use build-in-place if the - -- convention is other than Ada, because that would disturb mixed-language - -- programs. Note that for the non-inherently-limited cases, we must make - -- the same decision for Ada 95 and 2005, so that mixed-dialect programs - -- will work. + -- function, or access-to-function type for which + -- Is_Build_In_Place_Result_Type is True. However, we never use + -- build-in-place if the convention is other than Ada, because that would + -- disturb mixed-language programs. function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function - -- that requires handling as a build-in-place call or is a qualified - -- expression applied to such a call; otherwise returns False. + -- that requires handling as a build-in-place call (possibly qualified or + -- converted). function Is_Null_Procedure (Subp : Entity_Id) return Boolean; -- Predicate to recognize stubbed procedures and null procedures, which @@ -212,7 +217,7 @@ package Exp_Ch6 is (Obj_Decl : Node_Id; Function_Call : Node_Id); -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that - -- occurs as the expression initializing an object declaration by passsing + -- occurs as the expression initializing an object declaration by passing -- access to the declared object as an additional parameter of the function -- call. Function_Call must denote an expression containing a BIP function -- call and an enclosing call to Ada.Tags.Displace to displace the pointer diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 2ca42de1939..07fd33ce465 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4057,7 +4057,7 @@ package body Exp_Ch7 is -- This procedure is called each time a transient block has to be inserted -- that is to say for each call to a function with unconstrained or tagged - -- result. It creates a new scope on the stack scope in order to enclose + -- result. It creates a new scope on the scope stack in order to enclose -- all transient variables generated. procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index ba0f7c291c1..08c68058994 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -176,23 +176,16 @@ package body Exp_Ch8 is -- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in- -- place function, then a temporary return object needs to be created - -- and access to it must be passed to the function. Currently we limit - -- such functions to those with inherently limited result subtypes, but - -- eventually we plan to expand the functions that are treated as - -- build-in-place to include other composite result types. + -- and access to it must be passed to the function. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Nam) - then + if Is_Build_In_Place_Function_Call (Nam) then Make_Build_In_Place_Call_In_Anonymous_Context (Nam); -- Ada 2005 (AI-318-02): Specialization of previous case for renaming -- containing build-in-place function calls whose returned object covers -- interface types. - elsif Ada_Version >= Ada_2005 - and then Present (Unqual_BIP_Iface_Function_Call (Nam)) - then + elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam); end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 6719f2e6b6e..97ac138e898 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1640,9 +1640,7 @@ package body Exp_Disp is -- interface conversion, so if this is a BIP call then we need -- to handle it now. - if Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Actual) - then + if Is_Build_In_Place_Function_Call (Actual) then Make_Build_In_Place_Call_In_Anonymous_Context (Actual); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c9650ce10a4..1d64a3add34 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -649,7 +649,11 @@ package body Exp_Util is -- Do not process allocations on / deallocations from the secondary -- stack. - elsif Is_RTE (Pool_Id, RE_SS_Pool) then + elsif Is_RTE (Pool_Id, RE_SS_Pool) + or else + (Nkind (Expr) = N_Allocator + and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)) + then return; -- Optimize the case where we are using the default Global_Pool_Object, @@ -7857,6 +7861,8 @@ package body Exp_Util is Call := Prefix (Call); end if; + Call := Unqual_Conv (Call); + if Is_Build_In_Place_Function_Call (Call) then declare Access_Nam : Name_Id := No_Name; @@ -8679,9 +8685,7 @@ package body Exp_Util is Param := First (Parameter_Associations (Call)); while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then + if Nkind (Param) = N_Parameter_Association then Formal := Selector_Name (Param); Actual := Explicit_Actual_Parameter (Param); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 87b65424f4d..0c4dfdf3910 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1372,9 +1372,9 @@ package Sinfo is -- up. For nested aggregates the expansion is delayed until the enclosing -- aggregate itself is expanded, e.g. in the context of a declaration. To -- delay it we set this flag. This is done to avoid creating a temporary - -- for each level of a nested aggregates, and also to prevent the + -- for each level of a nested aggregate, and also to prevent the -- premature generation of constraint checks. This is also a requirement - -- if we want to generate the proper attachment to the internal + -- if we want to generate the proper attachment to the internal???? -- finalization lists (for record with controlled components). Top down -- expansion of aggregates is also used for in-place array aggregate -- assignment or initialization. When the full context is known, the @@ -2917,7 +2917,7 @@ package Sinfo is -- case the front end must generate an extra temporary and initialize -- this temporary as required (the temporary itself is not atomic). - -- Note: there is not node kind for object definition. Instead, the + -- Note: there is no node kind for object definition. Instead, the -- corresponding field holds a subtype indication, an array type -- definition, or (Ada 2005, AI-406) an access definition. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 717225d846d..5fcf365b058 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -328,7 +328,7 @@ package Snames is -- Operator Symbol entries. The actual names have an upper case O at the -- start in place of the Op_ prefix (e.g. the actual name that corresponds - -- to Name_Op_Abs is "Oabs". + -- to Name_Op_Abs is "Oabs"). First_Operator_Name : constant Name_Id := N + $; Name_Op_Abs : constant Name_Id := N + $; -- "abs" -- 2.30.2