[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 --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 2d7962c..446c796 100644 (file)
--- 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 9d01cfc..0c809f5 100644 (file)
--- 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 3b736ca..d35f0ad 100644 (file)
--- 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 9ed1939..bded8ab 100644 (file)
--- 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 427d4a3..bcc1212 100644 (file)
--- 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 0766482..7ce39f4 100644 (file)
--- 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 18702f3..a3bd95b 100644 (file)
--- 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 2f0585a..3c3d600 100644 (file)
--- 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 0e75bb4..cda7870 100644 (file)
--- 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;