OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Misc cleanup related to finalization

Browse Source 
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.
This commit is contained in:
Bob Duff 2022-06-06 13:22:39 -04:00 committed by Pierre-Marie de Rodat
parent 824211e18b
commit dba077902d
9 changed files with 75 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/ada/atree.adb
View File

@ -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 --

12
gcc/ada/atree.ads
View File

@ -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);

2
gcc/ada/atree.h
View File

@ -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

32
gcc/ada/debug_a.adb
View File

@ -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;

14
gcc/ada/debug_a.ads
View File

@ -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.

55
gcc/ada/exp_ch7.adb
View File

@ -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;

8
gcc/ada/nlists.adb
View File

@ -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 --

12
gcc/ada/nlists.ads
View File

@ -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

2
gcc/ada/sem_ch8.adb
View File

@ -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;