From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 417D83851A88; Tue, 5 Jul 2022 08:30:34 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 417D83851A88 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-1488] [Ada] Misc cleanup related to finalization X-Act-Checkin: gcc X-Git-Author: Bob Duff X-Git-Refname: refs/heads/master X-Git-Oldrev: 824211e18b96dc56d3a530b31aa16cded2c941eb X-Git-Newrev: dba077902daf195da0e5bbac33a1f34bc6b20367 Message-Id: <20220705083034.417D83851A88@sourceware.org> Date: Tue, 5 Jul 2022 08:30:34 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Tue, 05 Jul 2022 08:30:34 -0000 https://gcc.gnu.org/g:dba077902daf195da0e5bbac33a1f34bc6b20367 commit r13-1488-gdba077902daf195da0e5bbac33a1f34bc6b20367 Author: Bob Duff Date: Mon Jun 6 13:22:39 2022 -0400 [Ada] Misc cleanup related to finalization This patch cleans up some code issues found while working on finalization, and adds some debugging aids. gcc/ada/ * exp_ch7.adb: Change two constants Is_Protected_Body and Is_Prot_Body to be Is_Protected_Subp_Body; these are not true for protected bodies, but for protected subprogram bodies. (Expand_Cleanup_Actions): No need to search for Activation_Chain_Entity; just use Activation_Chain_Entity. * sem_ch8.adb (Find_Direct_Name): Use Entyp constant. * atree.adb, atree.ads, atree.h, nlists.adb, nlists.ads (Parent): Provide nonoverloaded versions of Parent, so that they can be easily found in the debugger. * debug_a.adb, debug_a.ads: Clarify that we're talking about the -gnatda switch; switches are case sensitive. Print out the Chars field if appropriate, which makes it easier to find things in the output. (Debug_Output_Astring): Simplify. Also fix an off-by-one bug ("for I in Vbars'Length .." should have been "for I in Vbars'Length + 1 .."). Before, it was printing Debug_A_Depth + 1 '|' characters if Debug_A_Depth > Vbars'Length. Diff: --- gcc/ada/atree.adb | 8 ++++---- gcc/ada/atree.ads | 12 ++++++++++-- gcc/ada/atree.h | 2 +- gcc/ada/debug_a.adb | 32 +++++++++++++++++-------------- gcc/ada/debug_a.ads | 14 +++++++------- gcc/ada/exp_ch7.adb | 55 +++++++++++++++++++---------------------------------- gcc/ada/nlists.adb | 8 ++++---- gcc/ada/nlists.ads | 12 ++++++++++-- gcc/ada/sem_ch8.adb | 2 +- 9 files changed, 75 insertions(+), 70 deletions(-) diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 2d7962c96b1..446c7960ada 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1966,7 +1966,7 @@ package body Atree is end if; end Paren_Count; - function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is + function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is begin pragma Assert (Present (N)); @@ -1975,7 +1975,7 @@ package body Atree is else return Node_Or_Entity_Id (Link (N)); end if; - end Parent; + end Node_Parent; ------------- -- Present -- @@ -2292,12 +2292,12 @@ package body Atree is -- Set_Parent -- ---------------- - procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is + procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is begin pragma Assert (Present (N)); pragma Assert (not In_List (N)); Set_Link (N, Union_Id (Val)); - end Set_Parent; + end Set_Node_Parent; ------------------------ -- Set_Reporting_Proc -- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 9d01cfca140..0c809f56435 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -446,10 +446,15 @@ package Atree is -- Tests given Id for equality with the Empty node. This allows notations -- like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty". - function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; + function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id; + pragma Inline (Node_Parent); + function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id + renames Node_Parent; pragma Inline (Parent); -- Returns the parent of a node if the node is not a list member, or else -- the parent of the list containing the node if the node is a list member. + -- Parent has the same name as the one in Nlists; Node_Parent can be used + -- more easily in the debugger. function Paren_Count (N : Node_Id) return Nat; pragma Inline (Paren_Count); @@ -465,7 +470,10 @@ package Atree is -- Note that this routine is used only in very peculiar cases. In normal -- cases, the Original_Node link is set by calls to Rewrite. - procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id); + procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id); + pragma Inline (Set_Node_Parent); + procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) + renames Set_Node_Parent; pragma Inline (Set_Parent); procedure Set_Paren_Count (N : Node_Id; Val : Nat); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 3b736caa499..d35f0ad8b08 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -35,7 +35,7 @@ extern "C" { #endif -#define Parent atree__parent +#define Parent atree__node_parent extern Node_Id Parent (Node_Id); #define Original_Node atree__original_node diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb index 9ed193914a8..bded8ab9a83 100644 --- a/gcc/ada/debug_a.adb +++ b/gcc/ada/debug_a.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Debug; use Debug; +with Namet; use Namet; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinput; use Sinput; @@ -33,7 +34,7 @@ with Output; use Output; package body Debug_A is Debug_A_Depth : Natural := 0; - -- Output for the debug A flag is preceded by a sequence of vertical bar + -- Output for the -gnatda switch is preceded by a sequence of vertical bar -- characters corresponding to the recursion depth of the actions being -- recorded (analysis, expansion, resolution and evaluation of nodes) -- This variable records the depth. @@ -66,7 +67,7 @@ package body Debug_A is procedure Debug_A_Entry (S : String; N : Node_Id) is begin - -- Output debugging information if -gnatda flag set + -- Output debugging information if -gnatda switch set if Debug_Flag_A then Debug_Output_Astring; @@ -77,6 +78,19 @@ package body Debug_A is Write_Location (Sloc (N)); Write_Str (" "); Write_Str (Node_Kind'Image (Nkind (N))); + + -- Print the Chars field, if appropriate + + case Nkind (N) is + when N_Has_Chars => + Write_Str (" """); + if Present (Chars (N)) then + Write_Str (Get_Name_String (Chars (N))); + end if; + Write_Str (""""); + when others => null; + end case; + Write_Eol; end if; @@ -115,7 +129,7 @@ package body Debug_A is end if; end loop; - -- Output debugging information if -gnatda flag set + -- Output debugging information if -gnatda switch set if Debug_Flag_A then Debug_Output_Astring; @@ -132,18 +146,8 @@ package body Debug_A is -------------------------- procedure Debug_Output_Astring is - Vbars : constant String := "|||||||||||||||||||||||||"; begin - if Debug_A_Depth > Vbars'Length then - for I in Vbars'Length .. Debug_A_Depth loop - Write_Char ('|'); - end loop; - - Write_Str (Vbars); - - else - Write_Str (Vbars (1 .. Debug_A_Depth)); - end if; + Write_Str ((1 .. Debug_A_Depth => '|')); end Debug_Output_Astring; end Debug_A; diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads index 427d4a3f4ae..bcc1212a6d2 100644 --- a/gcc/ada/debug_a.ads +++ b/gcc/ada/debug_a.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ --- This package contains data and subprograms to support the A debug switch +-- This package contains data and subprograms to support the -gnatda switch -- that is used to generate output showing what node is being analyzed, -- resolved, evaluated, or expanded. @@ -44,18 +44,18 @@ package Debug_A is -- Generates a message prefixed by a sequence of bars showing the nesting -- depth (depth increases by 1 for a Debug_A_Entry call and is decreased -- by the corresponding Debug_A_Exit call). Then the string is output - -- (analyzing, expanding etc), followed by the node number and its kind. - -- This output is generated only if the debug A flag is set. If the debug - -- A flag is not set, then no output is generated. This call also sets the - -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This - -- is done unconditionally, whether or not the debug A flag is set. + -- (analyzing, expanding etc), followed by information about the node. + -- This output is generated only if the -gnatda switch is set. If that + -- switch is not set, then no output is generated. This call also sets the + -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This is + -- done unconditionally, whether or not the switch is set. procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String); pragma Inline (Debug_A_Exit); -- Generates the corresponding termination message. The message is preceded -- by a sequence of bars, followed by the string S, the node number, and -- a trailing comment (e.g. " (already evaluated)"). This output is - -- generated only if the debug A flag is set. If the debug A flag is not + -- generated only if the -gnatda switch is set. If that switch is not -- set, then no output is generated. This call also resets the value in -- Atree.Current_Error_Node to what it was before the corresponding call -- to Debug_A_Entry. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 07664822791..7ce39f4da98 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -867,19 +867,16 @@ package body Exp_Ch7 is Additional_Cleanup : List_Id) return List_Id is Is_Asynchronous_Call : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Asynchronous_Call_Block (N); - Is_Master : constant Boolean := - Nkind (N) /= N_Entry_Body - and then Is_Task_Master (N); - Is_Protected_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); - Is_Task_Allocation : constant Boolean := - Nkind (N) = N_Block_Statement - and then Is_Task_Allocation_Block (N); - Is_Task_Body : constant Boolean := - Nkind (Original_Node (N)) = N_Task_Body; + Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); + Is_Master : constant Boolean := + Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + Is_Task_Allocation : constant Boolean := + Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); + Is_Task_Body : constant Boolean := + Nkind (Original_Node (N)) = N_Task_Body; Loc : constant Source_Ptr := Sloc (N); Stmts : constant List_Id := New_List; @@ -905,7 +902,7 @@ package body Exp_Ch7 is -- NOTE: The generated code references _object, a parameter to the -- procedure. - elsif Is_Protected_Body then + elsif Is_Protected_Subp_Body then declare Spec : constant Node_Id := Parent (Corresponding_Spec (N)); Conc_Typ : Entity_Id := Empty; @@ -3695,9 +3692,9 @@ package body Exp_Ch7 is -------------------------- procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is - Is_Prot_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); -- Determine whether N denotes the protected version of a subprogram -- which belongs to a protected type. @@ -3733,7 +3730,7 @@ package body Exp_Ch7 is -- end; -- end Prot_SubpP; - if Is_Prot_Body then + if Is_Protected_Subp_Body then HSS := Handled_Statement_Sequence (Last (Statements (HSS))); end if; @@ -5745,24 +5742,12 @@ package body Exp_Ch7 is if Is_Task_Allocation then declare - Chain : constant Entity_Id := Activation_Chain_Entity (N); - Decl : Node_Id; - + Chain_Decl : constant N_Object_Declaration_Id := + Parent (Activation_Chain_Entity (N)); + pragma Assert (List_Containing (Chain_Decl) = Decls); begin - Decl := First (Decls); - while Nkind (Decl) /= N_Object_Declaration - or else Defining_Identifier (Decl) /= Chain - loop - Next (Decl); - - -- A task allocation block should always include a _chain - -- declaration. - - pragma Assert (Present (Decl)); - end loop; - - Remove (Decl); - Prepend_To (New_Decls, Decl); + Remove (Chain_Decl); + Prepend_To (New_Decls, Chain_Decl); end; end if; diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 18702f3a5e9..a3bd95b3b79 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -1013,12 +1013,12 @@ package body Nlists is -- Parent -- ------------ - function Parent (List : List_Id) return Node_Or_Entity_Id is + function List_Parent (List : List_Id) return Node_Or_Entity_Id is begin pragma Assert (Present (List)); pragma Assert (List <= Lists.Last); return Lists.Table (List).Parent; - end Parent; + end List_Parent; ---------- -- Pick -- @@ -1442,12 +1442,12 @@ package body Nlists is -- Set_Parent -- ---------------- - procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is + procedure Set_List_Parent (List : List_Id; Node : Node_Or_Entity_Id) is begin pragma Assert (not Locked); pragma Assert (List <= Lists.Last); Lists.Table (List).Parent := Node; - end Set_Parent; + end Set_List_Parent; -------------- -- Set_Prev -- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 2f0585a1b60..3c3d6004ea5 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -348,13 +348,21 @@ package Nlists is -- Called to unlock list contents when assertions are enabled; if -- assertions are not enabled calling this subprogram has no effect. - function Parent (List : List_Id) return Node_Or_Entity_Id; + function List_Parent (List : List_Id) return Node_Or_Entity_Id; + pragma Inline (List_Parent); + function Parent (List : List_Id) return Node_Or_Entity_Id + renames List_Parent; pragma Inline (Parent); -- Node lists may have a parent in the same way as a node. The function -- accesses the Parent value, which is either Empty when a list header -- is first created, or the value that has been set by Set_Parent. + -- Parent has the same name as the one in Atree; List_Parent can be used + -- more easily in the debugger. - procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id); + procedure Set_List_Parent (List : List_Id; Node : Node_Or_Entity_Id); + pragma Inline (Set_List_Parent); + procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) + renames Set_List_Parent; pragma Inline (Set_Parent); -- Sets the parent field of the given list to reference the given node diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0e75bb4ab63..cda787063eb 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6082,7 +6082,7 @@ package body Sem_Ch8 is -- If not that special case, then just reset the Etype else - Set_Etype (N, Etype (Entity (N))); + Set_Etype (N, Entyp); end if; end; end if;