From fb9dd1c7c32efd0c90c21070ed7dabc9006ef1ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Thu, 19 Oct 2017 23:08:29 +0000 Subject: [PATCH] [multiple changes] 2017-10-19 Bob Duff * exp_util.adb: (Process_Statements_For_Controlled_Objects): Clarify which node kinds can legitimately be ignored, and raise Program_Error for others. 2017-10-19 Hristian Kirtchev * sem_elab.adb (Compilation_Unit): Handle the case of a subprogram instantiation that acts as a compilation unit. (Find_Code_Unit): Reimplemented. (Find_Top_Unit): Reimplemented. (Find_Unit_Entity): New routine. (Process_Instantiation_SPARK): Correct the elaboration requirement a package instantiation imposes on a unit. 2017-10-19 Bob Duff * exp_ch6.adb (Is_Build_In_Place_Result_Type): Enable build-in-place for a narrow set of controlled types. 2017-10-19 Eric Botcazou * sinput.ads (Line_Start): Add pragma Inline. * widechar.ads (Is_Start_Of_Wide_Char): Likewise. 2017-10-19 Bob Duff * exp_attr.adb (Expand_N_Attribute_Reference): Disable Make_Build_In_Place_Call_... for F(...)'Old, where F(...) is a build-in-place function call so that the temp is declared in the right place. From-SVN: r253915 --- gcc/ada/ChangeLog | 33 ++++++++++++++++++ gcc/ada/exp_attr.adb | 14 +++++++- gcc/ada/exp_ch6.adb | 56 ++++++++++++++++++++++--------- gcc/ada/exp_util.adb | 8 ++++- gcc/ada/sem_elab.adb | 80 +++++++++++++++++++++++++++++++++++--------- gcc/ada/sinput.ads | 2 ++ gcc/ada/widechar.ads | 5 ++- 7 files changed, 164 insertions(+), 34 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2139cbf4d86..21337393b72 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2017-10-19 Bob Duff + + * exp_util.adb: (Process_Statements_For_Controlled_Objects): Clarify + which node kinds can legitimately be ignored, and raise Program_Error + for others. + +2017-10-19 Hristian Kirtchev + + * sem_elab.adb (Compilation_Unit): Handle the case of a subprogram + instantiation that acts as a compilation unit. + (Find_Code_Unit): Reimplemented. + (Find_Top_Unit): Reimplemented. + (Find_Unit_Entity): New routine. + (Process_Instantiation_SPARK): Correct the elaboration requirement a + package instantiation imposes on a unit. + +2017-10-19 Bob Duff + + * exp_ch6.adb (Is_Build_In_Place_Result_Type): Enable build-in-place + for a narrow set of controlled types. + +2017-10-19 Eric Botcazou + + * sinput.ads (Line_Start): Add pragma Inline. + * widechar.ads (Is_Start_Of_Wide_Char): Likewise. + +2017-10-19 Bob Duff + + * exp_attr.adb (Expand_N_Attribute_Reference): Disable + Make_Build_In_Place_Call_... for F(...)'Old, where F(...) is a + build-in-place function call so that the temp is declared in the right + place. + 2017-10-18 Eric Botcazou * gcc-interface/misc.c (gnat_tree_size): Move around. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 719699566e4..55c6ec6f662 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1756,7 +1756,19 @@ package body Exp_Attr is -- and access to it must be passed to the function. if Is_Build_In_Place_Function_Call (Pref) then - Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + + -- If attribute is 'Old, the context is a postcondition, and + -- the temporary must go in the corresponding subprogram, not + -- the postcondition function or any created blocks, as when + -- the attribute appears in a quantified expression. This is + -- handled below in the expansion of the attribute. + + if Attribute_Name (Parent (Pref)) = Name_Old then + null; + + else + Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + end if; -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix -- containing build-in-place function calls whose returned object covers diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4e229c452a4..c5cea3e6aaf 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7240,34 +7240,58 @@ package body Exp_Ch6 is if Is_Limited_View (Typ) then return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; else --- if Debug_Flag_Dot_9 then - if True then - return False; -- ???disable bip for nonlimited types - end if; - if Has_Interfaces (Typ) then return False; end if; - -- For T'Class, return True if it's True for the corresponding - -- specific type. This is necessary because a class-wide function - -- might say "return F (...)", where F returns the corresponding - -- specific type. - - if Is_Class_Wide_Type (Typ) then - return Is_Build_In_Place_Result_Type (Etype (Typ)); - end if; - declare T : Entity_Id := Typ; begin - if Present (Underlying_Type (Typ)) then + -- For T'Class, return True if it's True for T. This is necessary + -- because a class-wide function might say "return F (...)", where + -- F returns the corresponding specific type. + + if Is_Class_Wide_Type (Typ) then + T := Etype (Typ); + end if; + + -- If this is a generic formal type in an instance, return True if + -- it's True for the generic actual type. + + if Nkind (Parent (Typ)) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Parent (Typ))) + then + T := Entity (Subtype_Indication (Parent (Typ))); + + if Present (Full_View (T)) then + T := Full_View (T); + end if; + + elsif Present (Underlying_Type (Typ)) then T := Underlying_Type (Typ); end if; declare - Result : constant Boolean := Is_Controlled (T); + Result : Boolean; begin + -- ???For now, enable build-in-place for a very narrow set of + -- controlled types. Change "if True" to "if False" to + -- experiment more controlled types. Eventually, we would + -- like to enable build-in-place for all tagged types, all + -- types that need finalization, and all caller-unknown-size + -- types. We will eventually use Debug_Flag_Dot_9 to disable + -- build-in-place for nonlimited types. + +-- if Debug_Flag_Dot_9 then + if True then + Result := Is_Controlled (T) + and then Present (Enclosing_Subprogram (T)) + and then not Is_Compilation_Unit (Enclosing_Subprogram (T)) + and then Ekind (Enclosing_Subprogram (T)) = E_Procedure; + else + Result := Is_Controlled (T); + end if; + return Result; end; end; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index d8ac4f8cea2..4d6ec05a24f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10817,8 +10817,14 @@ package body Exp_Util is Analyze (Block); end if; - when others => + -- Could be e.g. a loop that was transformed into a block or null + -- statement. Do nothing for terminate alternatives. + + when N_Block_Statement | N_Null_Statement | N_Terminate_Alternative => null; + + when others => + raise Program_Error; end case; end Process_Statements_For_Controlled_Objects; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 7f9ce089d4a..3dcba585cff 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -159,7 +159,7 @@ package body Sem_Elab is -- -- - Instantiations -- - -- - References to variables + -- - Reads of variables -- -- - Task activation -- @@ -175,7 +175,7 @@ package body Sem_Elab is -- -- - For instantiations, the target is the generic template -- - -- - For references to variables, the target is the variable + -- - For reads of variables, the target is the variable -- -- - For task activation, the target is the task body -- @@ -883,6 +883,10 @@ package body Sem_Elab is -- is obtained by logically unwinding instantiations and subunits when N -- resides within one. + function Find_Unit_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Find_Unit_Entity); + -- Return the entity of unit N + function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; pragma Inline (First_Formal_Type); -- Return the type of subprogram Subp_Id's first formal parameter. If the @@ -1904,7 +1908,20 @@ package body Sem_Elab is Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); end if; - if Nkind (Comp_Unit) = N_Subunit then + -- Handle the case where a subprogram instantiation which acts as a + -- compilation unit is expanded into an anonymous package that wraps + -- the instantiated subprogram. + + if Nkind (Comp_Unit) = N_Package_Specification + and then Nkind_In (Original_Node (Parent (Comp_Unit)), + N_Function_Instantiation, + N_Procedure_Instantiation) + then + Comp_Unit := Parent (Parent (Comp_Unit)); + + -- Handle the case where the compilation unit is a subunit + + elsif Nkind (Comp_Unit) = N_Subunit then Comp_Unit := Parent (Comp_Unit); end if; @@ -2933,10 +2950,8 @@ package body Sem_Elab is -------------------- function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is - N_Unit : constant Node_Id := Unit (Cunit (Get_Code_Unit (N))); - begin - return Defining_Entity (N_Unit, Concurrent_Subunit => True); + return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); end Find_Code_Unit; --------------------------- @@ -3405,12 +3420,47 @@ package body Sem_Elab is ------------------- function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is - N_Unit : constant Node_Id := Unit (Cunit (Get_Top_Level_Code_Unit (N))); - begin - return Defining_Entity (N_Unit, Concurrent_Subunit => True); + return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); end Find_Top_Unit; + ---------------------- + -- Find_Unit_Entity -- + ---------------------- + + function Find_Unit_Entity (N : Node_Id) return Entity_Id is + Context : constant Node_Id := Parent (N); + Orig_N : constant Node_Id := Original_Node (N); + + begin + -- The unit denotes a package body of an instantiation which acts as + -- a compilation unit. The proper entity is that of the package spec. + + if Nkind (N) = N_Package_Body + and then Nkind (Orig_N) = N_Package_Instantiation + and then Nkind (Context) = N_Compilation_Unit + then + return Corresponding_Spec (N); + + -- The unit denotes an anonymous package created to wrap a subprogram + -- instantiation which acts as a compilation unit. The proper entity is + -- that of the "related instance". + + elsif Nkind (N) = N_Package_Declaration + and then Nkind_In (Orig_N, N_Function_Instantiation, + N_Procedure_Instantiation) + and then Nkind (Context) = N_Compilation_Unit + then + return + Related_Instance (Defining_Entity (N, Concurrent_Subunit => True)); + + -- Otherwise the proper entity is the defining entity + + else + return Defining_Entity (N, Concurrent_Subunit => True); + end if; + end Find_Unit_Entity; + ----------------------- -- First_Formal_Type -- ----------------------- @@ -5335,8 +5385,8 @@ package body Sem_Elab is -- in a great number of contexts. To determine whether a reference is -- a read, it is more practical to find out whether it is a write. - -- A reference is a write when appearing immediately on the left-hand - -- side of an assignment. + -- A reference is a write when it appears immediately on the left- + -- hand side of an assignment. if Nkind (Context) = N_Assignment_Statement and then Name (Context) = Ref @@ -7796,9 +7846,9 @@ package body Sem_Elab is -- ABE ramifications of the instantiation. if Nkind (Inst) = N_Package_Instantiation then - Req_Nam := Name_Elaborate; - else Req_Nam := Name_Elaborate_All; + else + Req_Nam := Name_Elaborate; end if; Meet_Elaboration_Requirement @@ -8155,10 +8205,10 @@ package body Sem_Elab is -- listed below are not considered. The categories are: -- 'Access for entries, operators, and subprograms + -- Assignments to variables -- Calls (includes task activation) -- Instantiations - -- Variable assignments - -- Variable references + -- Reads of variables elsif Is_Suitable_Access (N) or else Is_Suitable_Variable_Assignment (N) diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index bde59b131dd..ecbe83cdd88 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -755,6 +755,8 @@ private pragma Inline (Num_Source_Files); pragma Inline (Num_Source_Lines); + pragma Inline (Line_Start); + No_Instance_Id : constant Instance_Id := 0; ------------------------- diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads index a6e8293ae5d..3d2f9170976 100644 --- a/gcc/ada/widechar.ads +++ b/gcc/ada/widechar.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -95,4 +95,7 @@ package Widechar is P : Source_Ptr) return Boolean; -- Determines if S (P) is the start of a wide character sequence +private + pragma Inline (Is_Start_Of_Wide_Char); + end Widechar; -- 2.30.2