From e5148da096b0cf5d9d07154361f9005717d88ed9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Wed, 8 Nov 2017 13:46:19 +0000 Subject: [PATCH] [multiple changes] 2017-11-08 Yannick Moy * sem_ch8.adb (Use_One_Type, Update_Use_Clause_Chain): Do not report about unused use-type or use-package clauses inside inlined bodies. 2017-11-08 Hristian Kirtchev * sem_elab.adb (Ensure_Prior_Elaboration): Add new parameter In_Partial_Fin along with a comment on its usage. Do not guarantee the prior elaboration of a unit when the need came from a partial finalization context. (In_Initialization_Context): Relocated to Process_Call. (Is_Partial_Finalization_Proc): New routine. (Process_Access): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Activation_Call): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Activation_Conditional_ABE_Impl): Add new parameter In_Partial_Fin along with a comment on its usage. Do not emit any ABE diagnostics when the activation occurs in a partial finalization context. (Process_Activation_Guaranteed_ABE_Impl): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Call): Add new parameter In_Partial_Fin along with a comment on its usage. A call is within a partial finalization context when it targets a finalizer or primitive [Deep_]Finalize, and the call appears in initialization actions. Pass this information down to the recursive steps of the Processing phase. (Process_Call_Ada): Add new parameter In_Partial_Fin along with a comment on its usage. Remove the guard which suppresses the generation of implicit Elaborate[_All] pragmas. This is now done in Ensure_Prior_Elaboration. (Process_Call_Conditional_ABE): Add new parameter In_Partial_Fin along with a comment on its usage. Do not emit any ABE diagnostics when the call occurs in a partial finalization context. (Process_Call_SPARK): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Instantiation): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Instantiation_Ada): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Instantiation_Conditional_ABE): Add new parameter In_Partial_Fin along with a comment on its usage. Do not emit any ABE diagnostics when the instantiation occurs in a partial finalization context. (Process_Instantiation_SPARK): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Scenario): Add new parameter In_Partial_Fin along with a comment on its usage. (Process_Single_Activation): Add new parameter In_Partial_Fin along with a comment on its usage. (Traverse_Body): Add new parameter In_Partial_Fin along with a comment on its usage. 2017-11-08 Arnaud Charlet * sem_ch13.adb: Add optional parameter to Error_Msg. 2017-11-08 Jerome Lambourg * fname.adb (Is_Internal_File_Name): Do not check the 8+3 naming schema for the Interfaces.* hierarchy as longer unit names are now allowed. 2017-11-08 Arnaud Charlet * sem_util.adb (Subprogram_Name): Emit sloc for the enclosing subprogram as well. Support more cases of entities. (Append_Entity_Name): Add some defensive code. From-SVN: r254528 --- gcc/ada/ChangeLog | 69 +++++ gcc/ada/fname.adb | 5 +- gcc/ada/sem_ch13.adb | 18 +- gcc/ada/sem_ch8.adb | 2 + gcc/ada/sem_elab.adb | 741 ++++++++++++++++++++++++++++++--------------------- gcc/ada/sem_util.adb | 61 ++++- 6 files changed, 569 insertions(+), 327 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 660211c..912de23 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,72 @@ +2017-11-08 Yannick Moy + + * sem_ch8.adb (Use_One_Type, Update_Use_Clause_Chain): Do not report + about unused use-type or use-package clauses inside inlined bodies. + +2017-11-08 Hristian Kirtchev + + * sem_elab.adb (Ensure_Prior_Elaboration): Add new parameter + In_Partial_Fin along with a comment on its usage. Do not guarantee the + prior elaboration of a unit when the need came from a partial + finalization context. + (In_Initialization_Context): Relocated to Process_Call. + (Is_Partial_Finalization_Proc): New routine. + (Process_Access): Add new parameter In_Partial_Fin along with a comment + on its usage. + (Process_Activation_Call): Add new parameter In_Partial_Fin along with + a comment on its usage. + (Process_Activation_Conditional_ABE_Impl): Add new parameter + In_Partial_Fin along with a comment on its usage. Do not emit any ABE + diagnostics when the activation occurs in a partial finalization + context. + (Process_Activation_Guaranteed_ABE_Impl): Add new parameter + In_Partial_Fin along with a comment on its usage. + (Process_Call): Add new parameter In_Partial_Fin along with a comment + on its usage. A call is within a partial finalization context when it + targets a finalizer or primitive [Deep_]Finalize, and the call appears + in initialization actions. Pass this information down to the recursive + steps of the Processing phase. + (Process_Call_Ada): Add new parameter In_Partial_Fin along with a + comment on its usage. Remove the guard which suppresses the generation + of implicit Elaborate[_All] pragmas. This is now done in + Ensure_Prior_Elaboration. + (Process_Call_Conditional_ABE): Add new parameter In_Partial_Fin along + with a comment on its usage. Do not emit any ABE diagnostics when the + call occurs in a partial finalization context. + (Process_Call_SPARK): Add new parameter In_Partial_Fin along with a + comment on its usage. + (Process_Instantiation): Add new parameter In_Partial_Fin along with a + comment on its usage. + (Process_Instantiation_Ada): Add new parameter In_Partial_Fin along + with a comment on its usage. + (Process_Instantiation_Conditional_ABE): Add new parameter + In_Partial_Fin along with a comment on its usage. Do not emit any ABE + diagnostics when the instantiation occurs in a partial finalization + context. + (Process_Instantiation_SPARK): Add new parameter In_Partial_Fin along + with a comment on its usage. + (Process_Scenario): Add new parameter In_Partial_Fin along with a + comment on its usage. + (Process_Single_Activation): Add new parameter In_Partial_Fin along + with a comment on its usage. + (Traverse_Body): Add new parameter In_Partial_Fin along with a comment + on its usage. + +2017-11-08 Arnaud Charlet + + * sem_ch13.adb: Add optional parameter to Error_Msg. + +2017-11-08 Jerome Lambourg + + * fname.adb (Is_Internal_File_Name): Do not check the 8+3 naming schema + for the Interfaces.* hierarchy as longer unit names are now allowed. + +2017-11-08 Arnaud Charlet + + * sem_util.adb (Subprogram_Name): Emit sloc for the enclosing + subprogram as well. Support more cases of entities. + (Append_Entity_Name): Add some defensive code. + 2017-11-06 Eric Botcazou * gcc-interface/misc.c (gnat_post_options): Clear warn_return_type. diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index 2bdfbf6..96d813a 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -167,8 +167,11 @@ package body Fname is is begin -- Definitely false if longer than 12 characters (8.3) + -- except for the Interfaces packages - if Fname'Length > 12 then + if Fname'Length > 12 + and then Fname (Fname'First .. Fname'First + 1) /= "i-" + then return False; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 564ff0d..ccca8b7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -14317,7 +14317,7 @@ package body Sem_Ch13 is if Source_Siz /= Target_Siz then Error_Msg ("?z?types for unchecked conversion have different sizes!", - Eloc); + Eloc, Act_Unit); if All_Errors_Mode then Error_Msg_Name_1 := Chars (Source); @@ -14353,17 +14353,17 @@ package body Sem_Ch13 is if Bytes_Big_Endian then Error_Msg ("\?z?target value will include ^ undefined " - & "low order bits!", Eloc); + & "low order bits!", Eloc, Act_Unit); else Error_Msg ("\?z?target value will include ^ undefined " - & "high order bits!", Eloc); + & "high order bits!", Eloc, Act_Unit); end if; else Error_Msg ("\?z?^ trailing bits of target value will be " - & "undefined!", Eloc); + & "undefined!", Eloc, Act_Unit); end if; else pragma Assert (Source_Siz > Target_Siz); @@ -14371,17 +14371,17 @@ package body Sem_Ch13 is if Bytes_Big_Endian then Error_Msg ("\?z?^ low order bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); else Error_Msg ("\?z?^ high order bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); end if; else Error_Msg ("\?z?^ trailing bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); end if; end if; end if; @@ -14435,10 +14435,10 @@ package body Sem_Ch13 is Error_Msg_Node_2 := D_Source; Error_Msg ("?z?alignment of & (^) is stricter than " - & "alignment of & (^)!", Eloc); + & "alignment of & (^)!", Eloc, Act_Unit); Error_Msg ("\?z?resulting access value may have invalid " - & "alignment!", Eloc); + & "alignment!", Eloc, Act_Unit); end if; end; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index bdc8aba..df176a7 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -9057,6 +9057,7 @@ package body Sem_Ch8 is and then Comes_From_Source (Curr) and then not Is_Effective_Use_Clause (Curr) and then not In_Instance + and then not In_Inlined_Body then -- We are dealing with a potentially unused use_package_clause @@ -9865,6 +9866,7 @@ package body Sem_Ch8 is and then not Spec_Reloaded_For_Body and then not In_Instance + and then not In_Inlined_Body then -- The type already has a use clause diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 8dec428..735ecf7 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -785,12 +785,15 @@ package body Sem_Elab is -- string " in SPARK" is added to the end of the message. procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - In_Task_Body : Boolean); + (N : Node_Id; + Unit_Id : Entity_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Guarantee the elaboration of unit Unit_Id with respect to the main unit. - -- N denotes the related scenario. Flag In_Task_Body should be set when the - -- need for elaboration is initiated from a task body. + -- N denotes the related scenario. Flag In_Partial_Fin should be set when + -- the need for elaboration is initiated by a partial finalization routine. + -- Flag In_Task_Body should be set when the need for prior elaboration is + -- initiated from a task body. procedure Ensure_Prior_Elaboration_Dynamic (N : Node_Id; @@ -1202,86 +1205,111 @@ package body Sem_Elab is -- Pop the top of the scenario stack. A check is made to ensure that the -- scenario being removed is the same as N. - procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean); + procedure Process_Access + (Attr : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform ABE checks and diagnostics for 'Access to entry, operator, or - -- subprogram denoted by Attr. Flag In_Task_Body should be set when the - -- processing is initiated from a task body. + -- subprogram denoted by Attr. Flag In_Partial_Fin shoud be set when the + -- processing is initiated by a partial finalization routine. Flag + -- In_Task_Body should be set when the processing is initiated from a task + -- body. generic with procedure Process_Single_Activation - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform ABE checks and diagnostics for task activation call Call -- which activates task Obj_Id. Call_Attrs are the attributes of the -- activation call. Task_Attrs are the attributes of the task type. - -- Flag In_Task_Body should be set when the processing is initiated - -- from a task body. + -- Flag In_Partial_Fin shoud be set when the processing is initiated + -- by a partial finalization routine. Flag In_Task_Body should be set + -- when the processing is initiated from a task body. procedure Process_Activation_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform ABE checks and diagnostics for activation call Call by invoking -- routine Process_Single_Activation on each task object being activated. - -- Call_Attrs are the attributes of the activation call. Flag In_Task_Body - -- should be set when the processing is initiated from a task body. + -- Call_Attrs are the attributes of the activation call. In_Partial_Fin + -- shoud be set when the processing is initiated by a partial finalization + -- routine. Flag In_Task_Body should be set when the processing is started + -- from a task body. procedure Process_Activation_Conditional_ABE_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform common conditional ABE checks and diagnostics for call Call -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs -- are the attributes of the activation call. Task_Attrs are the attributes - -- of the task type. Flag In_Task_Body should be set when the processing is - -- initiated from a task body. + -- of the task type. Flag In_Partial_Fin shoud be set when the processing + -- is initiated by a partial finalization routine. Flag In_Task_Body should + -- be set when the processing is initiated from a task body. procedure Process_Activation_Guaranteed_ABE_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Task_Body : Boolean); - -- Perform common guaranteed ABE checks and diagnostics for call Call - -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs - -- are the attributes of the activation call. Task_Attrs are the attributes - -- of the task type. Flag In_Task_Body should be set when the processing is - -- initiated from a task body. + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); + -- Perform common guaranteed ABE checks and diagnostics for call Call which + -- activates task Obj_Id ignoring the Ada or SPARK rules. Task_Attrs are + -- the attributes of the task type. The following parameters are provided + -- for compatibility and are unused. + -- + -- Call_Attrs + -- In_Partial_Fin + -- In_Task_Body procedure Process_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Top-level dispatcher for processing of calls. Perform ABE checks and -- diagnostics for call Call which invokes target Target_Id. Call_Attrs - -- are the attributes of the call. Flag In_Task_Body should be set when - -- the processing is initiated from a task body. + -- are the attributes of the call. Flag In_Partial_Fin shoud be set when + -- the processing is initiated by a partial finalization routine. Flag + -- In_Task_Body should be set when the processing is started from a task + -- body. procedure Process_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform ABE checks and diagnostics for call Call which invokes target -- Target_Id using the Ada rules. Call_Attrs are the attributes of the - -- call. Target_Attrs are attributes of the target. Flag In_Task_Body - -- should be set when the processing is initiated from a task body. + -- call. Target_Attrs are attributes of the target. Flag In_Partial_Fin + -- shoud be set when the processing is initiated by a partial finalization + -- routine. Flag In_Task_Body should be set when the processing is started + -- from a task body. procedure Process_Call_Conditional_ABE - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean); -- Perform common conditional ABE checks and diagnostics for call Call that -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are -- the attributes of the call. Target_Attrs are attributes of the target. + -- Flag In_Partial_Fin shoud be set when the processing is initiated by a + -- partial finalization routine. procedure Process_Call_Guaranteed_ABE (Call : Node_Id; @@ -1292,49 +1320,59 @@ package body Sem_Elab is -- the attributes of the call. procedure Process_Call_SPARK - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean); -- Perform ABE checks and diagnostics for call Call which invokes target -- Target_Id using the SPARK rules. Call_Attrs are the attributes of the - -- call. Target_Attrs are attributes of the target. + -- call. Target_Attrs are attributes of the target. Flag In_Partial_Fin + -- shoud be set when the processing is initiated by a partial finalization + -- routine. procedure Process_Guaranteed_ABE (N : Node_Id); -- Top level dispatcher for processing of scenarios which result in a -- guaranteed ABE. procedure Process_Instantiation - (Exp_Inst : Node_Id; - In_Task_Body : Boolean); + (Exp_Inst : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Top level dispatcher for processing of instantiations. Perform ABE -- checks and diagnostics for expanded instantiation Exp_Inst. Flag - -- In_Task_Body should be set when the processing is initiated from a - -- task body. + -- In_Partial_Fin shoud be set when the processing is initiated by a + -- partial finalization routine. Flag In_Task_Body should be set when + -- the processing is initiated from a task body. procedure Process_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Task_Body : Boolean); + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. - -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the - -- attributes of the generic. Flag In_Task_Body should be set when the - -- processing is initiated from a task body. + -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the + -- attributes of the generic. Flag In_Partial_Fin shoud be set when the + -- processing is initiated by a partial finalization routine. In_Task_Body + -- should be set when the processing is initiated from a task body. procedure Process_Instantiation_Conditional_ABE - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes); + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean); -- Perform common conditional ABE checks and diagnostics for expanded -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK -- rules. Inst is the instantiation node. Inst_Attrs are the attributes - -- of the instance. Gen_Attrs are the attributes of the generic. + -- of the instance. Gen_Attrs are the attributes of the generic. Flag + -- In_Partial_Fin shoud be set when the processing is initiated by a + -- partial finalization routine. procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id); -- Perform common guaranteed ABE checks and diagnostics for expanded @@ -1342,20 +1380,27 @@ package body Sem_Elab is -- rules. procedure Process_Instantiation_SPARK - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes); + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean); -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst -- of generic Gen_Id using the SPARK rules. Inst is the instantiation node. - -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the - -- attributes of the generic. - - procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False); + -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the + -- attributes of the generic. Flag In_Partial_Fin shoud be set when the + -- processing is initiated by a partial finalization routine. + + procedure Process_Scenario + (N : Node_Id; + In_Partial_Fin : Boolean := False; + In_Task_Body : Boolean := False); -- Top level dispatcher for processing of various elaboration scenarios. - -- Perform ABE checks and diagnostics for scenario N. Flag In_Task_Body - -- should be set when the processing is initiated from a task body. + -- Perform ABE checks and diagnostics for scenario N. Flag In_Partial_Fin + -- shoud be set when the processing is initiated by a partial finalization + -- routine. Flag In_Task_Body should be set when the processing is started + -- from a task body. procedure Process_Variable_Assignment (Asmt : Node_Id); -- Top level dispatcher for processing of variable assignments. Perform ABE @@ -1391,10 +1436,15 @@ package body Sem_Elab is pragma Inline (Static_Elaboration_Checks); -- Determine whether the static model is in effect - procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean); + procedure Traverse_Body + (N : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean); -- Inspect the declarations and statements of subprogram body N for - -- suitable elaboration scenarios and process them. Flag In_Task_Body - -- should be set when the traversal is initiated from a task body. + -- suitable elaboration scenarios and process them. Flag In_Partial_Fin + -- shoud be set when the processing is initiated by a partial finalization + -- routine. Flag In_Task_Body should be set when the traversal is initiated + -- from a task body. procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); pragma Inline (Update_Elaboration_Scenario); @@ -1996,9 +2046,10 @@ package body Sem_Elab is ------------------------------ procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - In_Task_Body : Boolean) + (N : Node_Id; + Unit_Id : Entity_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is Prag_Nam : Name_Id; @@ -2035,11 +2086,18 @@ package body Sem_Elab is Prag_Nam := Name_Elaborate_All; end if; + -- Nothing to do when the need for prior elaboration came from a partial + -- finalization routine which occurs in an initialization context. This + -- behaviour parallels that of the old ABE mechanism. + + if In_Partial_Fin then + return; + -- Nothing to do when the need for prior elaboration came from a task -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on -- task bodies) is in effect. - if Debug_Flag_Dot_Y and then In_Task_Body then + elsif Debug_Flag_Dot_Y and then In_Task_Body then return; -- Nothing to do when the unit is elaborated prior to the main unit. @@ -6253,7 +6311,11 @@ package body Sem_Elab is -- Process_Access -- -------------------- - procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean) is + procedure Process_Access + (Attr : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) + is function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; pragma Inline (Build_Access_Marker); -- Create a suitable call marker which invokes target Target_Id @@ -6340,17 +6402,19 @@ package body Sem_Elab is if Debug_Flag_Dot_O then Process_Scenario - (N => Build_Access_Marker (Target_Id), - In_Task_Body => In_Task_Body); + (N => Build_Access_Marker (Target_Id), + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); -- Otherwise ensure that the unit with the corresponding body is -- elaborated prior to the main unit. else Ensure_Prior_Elaboration - (N => Attr, - Unit_Id => Target_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); + (N => Attr, + Unit_Id => Target_Attrs.Unit_Id, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; end Process_Access; @@ -6359,9 +6423,10 @@ package body Sem_Elab is ----------------------------- procedure Process_Activation_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. @@ -6389,11 +6454,12 @@ package body Sem_Elab is Attrs => Task_Attrs); Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - In_Task_Body => In_Task_Body); + (Call => Call, + Call_Attrs => Call_Attrs, + Obj_Id => Obj_Id, + Task_Attrs => Task_Attrs, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); -- Examine the component type when the object is an array @@ -6507,11 +6573,12 @@ package body Sem_Elab is --------------------------------------------- procedure Process_Activation_Conditional_ABE_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is Check_OK : constant Boolean := not Is_Ignored_Ghost_Entity (Obj_Id) @@ -6650,12 +6717,19 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when the activation occurs in + -- a partial finalization context because this leads to confusing + -- noise. + + if In_Partial_Fin then + null; + -- ABE diagnostics are emitted only in the static model because -- there is a well-defined order to visiting scenarios. Without -- this order diagnostics appear jumbled and result in unwanted -- noise. - if Static_Elaboration_Checks then + elsif Static_Elaboration_Checks then Error_Msg_Sloc := Sloc (Call); Error_Msg_N ("??task & will be activated # before elaboration of its " @@ -6707,12 +6781,16 @@ package body Sem_Elab is else Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Task_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); + (N => Call, + Unit_Id => Task_Attrs.Unit_Id, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; - Traverse_Body (Task_Attrs.Body_Decl, In_Task_Body => True); + Traverse_Body + (N => Task_Attrs.Body_Decl, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => True); end Process_Activation_Conditional_ABE_Impl; procedure Process_Activation_Conditional_ABE is @@ -6723,13 +6801,15 @@ package body Sem_Elab is -------------------------------------------- procedure Process_Activation_Guaranteed_ABE_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is pragma Unreferenced (Call_Attrs); + pragma Unreferenced (In_Partial_Fin); pragma Unreferenced (In_Task_Body); Check_OK : constant Boolean := @@ -6868,19 +6948,108 @@ package body Sem_Elab is ------------------ procedure Process_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is + function In_Initialization_Context (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within a type init proc, + -- primitive [Deep_]Initialize, or a block created for initialization + -- purposes. + + function Is_Partial_Finalization_Proc return Boolean; + pragma Inline (Is_Partial_Finalization_Proc); + -- Determine whether call Call with target Target_Id invokes a partial + -- finalization procedure. + + ------------------------------- + -- In_Initialization_Context -- + ------------------------------- + + function In_Initialization_Context (N : Node_Id) return Boolean is + Par : Node_Id; + Spec_Id : Entity_Id; + + begin + -- Climb the parent chain looking for initialization actions + + Par := Parent (N); + while Present (Par) loop + + -- A block may be part of the initialization actions of a default + -- initialized object. + + if Nkind (Par) = N_Block_Statement + and then Is_Initialization_Block (Par) + then + return True; + + -- A subprogram body may denote an initialization routine + + elsif Nkind (Par) = N_Subprogram_Body then + Spec_Id := Unique_Defining_Entity (Par); + + -- The current subprogram body denotes a type init proc or + -- primitive [Deep_]Initialize. + + if Is_Init_Proc (Spec_Id) + or else Is_Controlled_Proc (Spec_Id, Name_Initialize) + or else Is_TSS (Spec_Id, TSS_Deep_Initialize) + then + return True; + end if; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Initialization_Context; + + ---------------------------------- + -- Is_Partial_Finalization_Proc -- + ---------------------------------- + + function Is_Partial_Finalization_Proc return Boolean is + begin + -- To qualify, the target must denote primitive [Deep_]Finalize or a + -- finalizer procedure, and the call must appear in an initialization + -- context. + + return + (Is_Controlled_Proc (Target_Id, Name_Finalize) + or else Is_Finalizer_Proc (Target_Id) + or else Is_TSS (Target_Id, TSS_Deep_Finalize)) + and then In_Initialization_Context (Call); + end Is_Partial_Finalization_Proc; + + -- Local variables + + Partial_Fin_On : Boolean; SPARK_Rules_On : Boolean; Target_Attrs : Target_Attributes; + -- Start of processing for Process_Call + begin Extract_Target_Attributes (Target_Id => Target_Id, Attrs => Target_Attrs); + -- The call occurs in a partial finalization context when a prior + -- scenario is already in that mode, or when the target denotes a + -- [Deep_]Finalize primitive or a finalizer within an initialization + -- context. + + Partial_Fin_On := In_Partial_Fin or else Is_Partial_Finalization_Proc; + -- The SPARK rules are in effect when both the call and target are -- subject to SPARK_Mode On. @@ -6954,28 +7123,30 @@ package body Sem_Elab is elsif SPARK_Rules_On and Debug_Flag_Dot_V then Process_Call_SPARK - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs); + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the Ada rules are in effect, or SPARK code is allowed to -- violate the SPARK rules. else Process_Call_Ada - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - In_Task_Body => In_Task_Body); + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + In_Partial_Fin => Partial_Fin_On, + In_Task_Body => In_Task_Body); end if; -- Inspect the target body (and barried function) for other suitable -- elaboration scenarios. - Traverse_Body (Target_Attrs.Body_Barf, In_Task_Body); - Traverse_Body (Target_Attrs.Body_Decl, In_Task_Body); + Traverse_Body (Target_Attrs.Body_Barf, Partial_Fin_On, In_Task_Body); + Traverse_Body (Target_Attrs.Body_Decl, Partial_Fin_On, In_Task_Body); end Process_Call; ---------------------- @@ -6983,67 +7154,13 @@ package body Sem_Elab is ---------------------- procedure Process_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is - function In_Initialization_Context (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N appears within a type init proc or - -- primitive [Deep_]Initialize. - - ------------------------------- - -- In_Initialization_Context -- - ------------------------------- - - function In_Initialization_Context (N : Node_Id) return Boolean is - Par : Node_Id; - Spec_Id : Entity_Id; - - begin - -- Climb the parent chain looking for initialization actions - - Par := Parent (N); - while Present (Par) loop - - -- A block may be part of the initialization actions of a default - -- initialized object. - - if Nkind (Par) = N_Block_Statement - and then Is_Initialization_Block (Par) - then - return True; - - -- A subprogram body may denote an initialization routine - - elsif Nkind (Par) = N_Subprogram_Body then - Spec_Id := Unique_Defining_Entity (Par); - - -- The current subprogram body denotes a type init proc or - -- primitive [Deep_]Initialize. - - if Is_Init_Proc (Spec_Id) - or else Is_Controlled_Proc (Spec_Id, Name_Initialize) - or else Is_TSS (Spec_Id, TSS_Deep_Initialize) - then - return True; - end if; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end In_Initialization_Context; - - -- Local variables - Check_OK : constant Boolean := not Call_Attrs.Ghost_Mode_Ignore and then not Target_Attrs.Ghost_Mode_Ignore @@ -7053,8 +7170,6 @@ package body Sem_Elab is -- target have active elaboration checks, and both are not ignored Ghost -- constructs. - -- Start of processing for Process_Call_Ada - begin -- Nothing to do for an Ada dispatching call because there are no ABE -- diagnostics for either models. ABE checks for the dynamic model are @@ -7088,10 +7203,11 @@ package body Sem_Elab is and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) then Process_Call_Conditional_ABE - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs); + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the target body is not available in this compilation or it -- resides in an external unit. Install a run-time ABE check to verify @@ -7105,35 +7221,17 @@ package body Sem_Elab is Id => Target_Attrs.Unit_Id); end if; - -- No implicit pragma Elaborate[_All] is generated when the call has - -- elaboration checks suppressed. This behaviour parallels that of the - -- old ABE mechanism. - - if not Call_Attrs.Elab_Checks_OK then - null; - - -- No implicit pragma Elaborate[_All] is generated for finalization - -- actions when primitive [Deep_]Finalize is not defined in the main - -- unit and the call appears within some initialization actions. This - -- behaviour parallels that of the old ABE mechanism. - - -- Performance note: parent traversal - - elsif (Is_Controlled_Proc (Target_Id, Name_Finalize) - or else Is_TSS (Target_Id, TSS_Deep_Finalize)) - and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) - and then In_Initialization_Context (Call) - then - null; - - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + -- Ensure that the unit with the target body is elaborated prior to the + -- main unit. The implicit Elaborate[_All] is generated only when the + -- call has elaboration checks enabled. This behaviour parallels that of + -- the old ABE mechanism. - else + if Call_Attrs.Elab_Checks_OK then Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; end Process_Call_Ada; @@ -7142,10 +7240,11 @@ package body Sem_Elab is ---------------------------------- procedure Process_Call_Conditional_ABE - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean) is Check_OK : constant Boolean := not Call_Attrs.Ghost_Mode_Ignore @@ -7186,11 +7285,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when the call occurs in a partial + -- finalization context because this leads to confusing noise. + + if In_Partial_Fin then + null; + -- ABE diagnostics are emitted only in the static model because there -- is a well-defined order to visiting scenarios. Without this order -- diagnostics appear jumbled and result in unwanted noise. - if Static_Elaboration_Checks then + elsif Static_Elaboration_Checks then Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); Error_Msg_N ("\Program_Error may be raised at run time", Call); @@ -7329,10 +7434,11 @@ package body Sem_Elab is ------------------------ procedure Process_Call_SPARK - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Partial_Fin : Boolean) is begin -- A call to a source target or to a target which emulates Ada or SPARK @@ -7376,10 +7482,11 @@ package body Sem_Elab is and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) then Process_Call_Conditional_ABE - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs); + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the target body is not available in this compilation or it -- resides in an external unit. There is no need to guarantee the prior @@ -7416,9 +7523,10 @@ package body Sem_Elab is if Is_Activation_Proc (Target_Id) then Process_Activation_Guaranteed_ABE - (Call => N, - Call_Attrs => Call_Attrs, - In_Task_Body => False); + (Call => N, + Call_Attrs => Call_Attrs, + In_Partial_Fin => False, + In_Task_Body => False); else Process_Call_Guaranteed_ABE @@ -7442,8 +7550,9 @@ package body Sem_Elab is --------------------------- procedure Process_Instantiation - (Exp_Inst : Node_Id; - In_Task_Body : Boolean) + (Exp_Inst : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is Gen_Attrs : Target_Attributes; Gen_Id : Entity_Id; @@ -7524,23 +7633,25 @@ package body Sem_Elab is elsif SPARK_Rules_On and Debug_Flag_Dot_V then Process_Instantiation_SPARK - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs); + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the Ada rules are in effect, or SPARK code is allowed to -- violate the SPARK rules. else Process_Instantiation_Ada - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - In_Task_Body => In_Task_Body); + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; end Process_Instantiation; @@ -7549,12 +7660,13 @@ package body Sem_Elab is ------------------------------- procedure Process_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Task_Body : Boolean) + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) is Check_OK : constant Boolean := not Inst_Attrs.Ghost_Mode_Ignore @@ -7591,11 +7703,12 @@ package body Sem_Elab is and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) then Process_Instantiation_Conditional_ABE - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs); + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the generic body is not available in this compilation or it -- resides in an external unit. Install a run-time ABE check to verify @@ -7616,9 +7729,10 @@ package body Sem_Elab is if Inst_Attrs.Elab_Checks_OK then Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; end Process_Instantiation_Ada; @@ -7627,11 +7741,12 @@ package body Sem_Elab is ------------------------------------------- procedure Process_Instantiation_Conditional_ABE - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes) + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean) is Check_OK : constant Boolean := not Inst_Attrs.Ghost_Mode_Ignore @@ -7676,11 +7791,17 @@ package body Sem_Elab is if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when the instantiation occurs in a + -- partial finalization context because this leads to unwanted noise. + + if In_Partial_Fin then + null; + -- ABE diagnostics are emitted only in the static model because there -- is a well-defined order to visiting scenarios. Without this order -- diagnostics appear jumbled and result in unwanted noise. - if Static_Elaboration_Checks then + elsif Static_Elaboration_Checks then Error_Msg_NE ("??cannot instantiate & before body seen", Inst, Gen_Id); Error_Msg_N ("\Program_Error may be raised at run time", Inst); @@ -7832,11 +7953,12 @@ package body Sem_Elab is --------------------------------- procedure Process_Instantiation_SPARK - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes) + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Partial_Fin : Boolean) is Req_Nam : Name_Id; @@ -7882,11 +8004,12 @@ package body Sem_Elab is and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) then Process_Instantiation_Conditional_ABE - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs); + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + In_Partial_Fin => In_Partial_Fin); -- Otherwise the generic body is not available in this compilation or -- it resides in an external unit. There is no need to guarantee the @@ -8086,7 +8209,11 @@ package body Sem_Elab is -- Process_Scenario -- ---------------------- - procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False) is + procedure Process_Scenario + (N : Node_Id; + In_Partial_Fin : Boolean := False; + In_Task_Body : Boolean := False) + is Call_Attrs : Call_Attributes; Target_Id : Entity_Id; @@ -8098,7 +8225,7 @@ package body Sem_Elab is -- 'Access if Is_Suitable_Access (N) then - Process_Access (N, In_Task_Body); + Process_Access (N, In_Partial_Fin, In_Task_Body); -- Calls @@ -8119,23 +8246,25 @@ package body Sem_Elab is if Is_Activation_Proc (Target_Id) then Process_Activation_Conditional_ABE - (Call => N, - Call_Attrs => Call_Attrs, - In_Task_Body => In_Task_Body); + (Call => N, + Call_Attrs => Call_Attrs, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); else Process_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - In_Task_Body => In_Task_Body); + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + In_Partial_Fin => In_Partial_Fin, + In_Task_Body => In_Task_Body); end if; end if; -- Instantiations elsif Is_Suitable_Instantiation (N) then - Process_Instantiation (N, In_Task_Body); + Process_Instantiation (N, In_Partial_Fin, In_Task_Body); -- Variable assignments @@ -8328,7 +8457,11 @@ package body Sem_Elab is -- Traverse_Body -- ------------------- - procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean) is + procedure Traverse_Body + (N : Node_Id; + In_Partial_Fin : Boolean; + In_Task_Body : Boolean) + is function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result; -- Determine whether arbitrary node Nod denotes a suitable scenario and -- if so, process it. @@ -8387,7 +8520,7 @@ package body Sem_Elab is -- General case elsif Is_Suitable_Scenario (Nod) then - Process_Scenario (Nod, In_Task_Body); + Process_Scenario (Nod, In_Partial_Fin, In_Task_Body); end if; return OK; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3698bbf..79c8864 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -141,7 +141,9 @@ package body Sem_Util is function Subprogram_Name (N : Node_Id) return String; -- Return the fully qualified name of the enclosing subprogram for the - -- given node N. + -- given node N, with file:line:col information appended, e.g. + -- "subp:file:line:col", corresponding to the source location of the + -- body of the subprogram. ------------------------------ -- Abstract_Interface_List -- @@ -594,6 +596,7 @@ package body Sem_Util is ----------- procedure Inner (E : Entity_Id) is + Scop : Node_Id; begin -- If entity has an internal name, skip by it, and print its scope. -- Note that we strip a final R from the name before the test; this @@ -615,21 +618,23 @@ package body Sem_Util is end if; end; + Scop := Scope (E); + -- Just print entity name if its scope is at the outer level - if Scope (E) = Standard_Standard then + if Scop = Standard_Standard then null; -- If scope comes from source, write scope and entity - elsif Comes_From_Source (Scope (E)) then - Append_Entity_Name (Temp, Scope (E)); + elsif Comes_From_Source (Scop) then + Append_Entity_Name (Temp, Scop); Append (Temp, '.'); -- If in wrapper package skip past it - elsif Is_Wrapper_Package (Scope (E)) then - Append_Entity_Name (Temp, Scope (Scope (E))); + elsif Present (Scop) and then Is_Wrapper_Package (Scop) then + Append_Entity_Name (Temp, Scope (Scop)); Append (Temp, '.'); -- Otherwise nothing to output (happens in unnamed block statements) @@ -23295,6 +23300,7 @@ package body Sem_Util is function Subprogram_Name (N : Node_Id) return String is Buf : Bounded_String; Ent : Node_Id := N; + Nod : Node_Id; begin while Present (Ent) loop @@ -23303,17 +23309,32 @@ package body Sem_Util is Ent := Defining_Unit_Name (Specification (Ent)); exit; - when N_Package_Body + when N_Subprogram_Declaration => + Nod := Corresponding_Body (Ent); + + if Present (Nod) then + Ent := Nod; + else + Ent := Defining_Unit_Name (Specification (Ent)); + end if; + + exit; + + when N_Subprogram_Instantiation + | N_Package_Body | N_Package_Specification - | N_Subprogram_Specification => Ent := Defining_Unit_Name (Ent); exit; + when N_Protected_Type_Declaration => + Ent := Corresponding_Body (Ent); + exit; + when N_Protected_Body - | N_Protected_Type_Declaration | N_Task_Body => + Ent := Defining_Identifier (Ent); exit; when others => @@ -23324,18 +23345,32 @@ package body Sem_Util is end loop; if No (Ent) then - return "unknown subprogram"; + return "unknown subprogram:unknown file:0:0"; end if; -- If the subprogram is a child unit, use its simple name to start the -- construction of the fully qualified name. if Nkind (Ent) = N_Defining_Program_Unit_Name then - Append_Entity_Name (Buf, Defining_Identifier (Ent)); - else - Append_Entity_Name (Buf, Ent); + Ent := Defining_Identifier (Ent); end if; + Append_Entity_Name (Buf, Ent); + + -- Append source location of Ent to Buf so that the string will + -- look like "subp:file:line:col". + + declare + Loc : constant Source_Ptr := Sloc (Ent); + begin + Append (Buf, ':'); + Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); + Append (Buf, ':'); + Append (Buf, Nat (Get_Logical_Line_Number (Loc))); + Append (Buf, ':'); + Append (Buf, Nat (Get_Column_Number (Loc))); + end; + return +Buf; end Subprogram_Name; -- 2.7.4