@@ -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 --
@@ -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);
@@ -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
@@ -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;
@@ -23,7 +23,7 @@
-- --
------------------------------------------------------------------------------
+-- 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.
@@ -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;
@@ -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 --
@@ -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
@@ -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;
This patch cleans up some code issues found while working on finalization, and adds some debugging aids. Tested on x86_64-pc-linux-gnu, committed on trunk 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.