2005-07-07 Javier Miranda <miranda@adacore.com>

	* exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type):
	Reimplementation of the support for abstract interface types in order
	to leave the code more clear and easy to maintain.

	* exp_ch6.adb (Freeze_Subprogram): Reimplementation of the support for
	abstract interface types in order to leave the code clearer and easier
	to maintain.

	* exp_disp.ads, exp_disp.adb (Fill_DT_Entry): Part of its functionality
	is now implemented by the new subprogram Fill_Secondary_DT_Entry.
	(Fill_Secondary_DT_Entry): Generate the code necessary to fill the
	appropriate entry of the secondary dispatch table.
	(Make_DT): Add code to inherit the secondary dispatch tables of
	the ancestors.

	* exp_util.adb (Find_Interface_Tag/Find_Interface_ADT): Instead of
	implementing both functionalities by means of a common routine, each
	routine has its own code.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101694 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 121 insertions, 94 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 9004213d5f2..643ed8a31e3 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -108,15 +108,6 @@ package body Exp_Util is
    --  procedure of record with task components, or for a dynamically
    --  created task that is assigned to a selected component.
 
-   procedure Find_Interface_Tag
-     (T         : Entity_Id;
-      Iface     : Entity_Id;
-      Iface_Tag : out Entity_Id;
-      Iface_ADT : out Entity_Id);
-   --  Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and
-   --  Find_Interface_Tag. Given a type T implementing the interface,
-   --  returns the corresponding Tag and Access_Disp_Table entities.
-
    function Make_CW_Equivalent_Type
      (T : Entity_Id;
       E : Node_Id) return Entity_Id;
@@ -1298,26 +1289,100 @@ package body Exp_Util is
    -- Find_Interface_Tag --
    ------------------------
 
-   procedure Find_Interface_Tag
-     (T         : Entity_Id;
-      Iface     : Entity_Id;
-      Iface_Tag : out Entity_Id;
-      Iface_ADT : out Entity_Id)
+   function Find_Interface_ADT
+     (T     : Entity_Id;
+      Iface : Entity_Id) return Entity_Id
+   is
+      ADT   : Elmt_Id;
+      Found : Boolean := False;
+      Typ   : Entity_Id := T;
+
+      procedure Find_Secondary_Table (Typ : Entity_Id);
+      --  Comment required ???
+
+      --------------------------
+      -- Find_Secondary_Table --
+      --------------------------
+
+      procedure Find_Secondary_Table (Typ : Entity_Id) is
+         AI_Elmt : Elmt_Id;
+         AI      : Node_Id;
+
+      begin
+         if Etype (Typ) /= Typ then
+            Find_Secondary_Table (Etype (Typ));
+         end if;
+
+         if Present (Abstract_Interfaces (Typ))
+           and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+         then
+            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+            while Present (AI_Elmt) loop
+               AI := Node (AI_Elmt);
+
+               if AI = Iface or else Is_Ancestor (Iface, AI) then
+                  Found := True;
+                  return;
+               end if;
+
+               Next_Elmt (ADT);
+               Next_Elmt (AI_Elmt);
+            end loop;
+         end if;
+      end Find_Secondary_Table;
+
+   --  Start of processing for Find_Interface_Tag
+
+   begin
+      --  Handle private types
+
+      if Has_Private_Declaration (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
+
+      --  Handle access types
+
+      if Is_Access_Type (Typ) then
+         Typ := Directly_Designated_Type (Typ);
+      end if;
+
+      --  Handle task and protected types implementing interfaces
+
+      if Ekind (Typ) = E_Protected_Type
+        or else Ekind (Typ) = E_Task_Type
+      then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
+      ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+      pragma Assert (Present (Node (ADT)));
+      Find_Secondary_Table (Typ);
+      pragma Assert (Found);
+      return Node (ADT);
+   end Find_Interface_ADT;
+
+   ------------------------
+   -- Find_Interface_Tag --
+   ------------------------
+
+   function Find_Interface_Tag
+     (T      : Entity_Id;
+      Iface  : Entity_Id) return Entity_Id
    is
-      AI_Tag   : Entity_Id;
-      ADT_Elmt : Elmt_Id;
-      Found    : Boolean   := False;
+      AI_Tag : Entity_Id;
+      Found  : Boolean := False;
+      Typ    : Entity_Id := T;
 
-      procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean);
-      --  This must be commented ???
+      procedure Find_Tag (Typ : in Entity_Id);
+      --  Internal subprogram used to recursively climb to the ancestors
 
       -----------------
       -- Find_AI_Tag --
       -----------------
 
-      procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is
-         T       : Entity_Id := Typ;
-         Etyp    : Entity_Id; -- := Etype (Typ); -- why is this commented ???
+      procedure Find_Tag (Typ : in Entity_Id) is
          AI_Elmt : Elmt_Id;
          AI      : Node_Id;
 
@@ -1326,60 +1391,31 @@ package body Exp_Util is
          --  therefore shares the main tag.
 
          if Typ = Iface then
-            AI_Tag    := First_Tag_Component (Typ);
-            ADT_Elmt  := First_Elmt (Access_Disp_Table (Typ));
-            Found     := True;
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := First_Tag_Component (Typ);
+            Found  := True;
             return;
          end if;
 
-         --  Handle private types
-
-         if Has_Private_Declaration (T)
-           and then Present (Full_View (T))
-         then
-            T := Full_View (T);
-         end if;
-
-         if Is_Access_Type (Typ) then
-            T := Directly_Designated_Type (T);
-
-         elsif Ekind (T) = E_Protected_Type
-           or else Ekind (T) = E_Task_Type
-         then
-            T := Corresponding_Record_Type (T);
-         end if;
-
-         Etyp := Etype (T);
-
          --  Climb to the root type
 
-         if Etyp /= Typ then
-            Find_AI_Tag (Etyp, Found);
+         if Etype (Typ) /= Typ then
+            Find_Tag (Etype (Typ));
          end if;
 
          --  Traverse the list of interfaces implemented by the type
 
          if not Found
-           and then Present (Abstract_Interfaces (T))
-           and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
+           and then Present (Abstract_Interfaces (Typ))
+           and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
          then
-            --  Skip the tag associated with the primary table (if
-            --  already placed in the record)
-
-            if Etype (Node (First_Elmt
-                              (Access_Disp_Table (T)))) = RTE (RE_Tag)
-            then
-               AI_Tag   := Next_Tag_Component (First_Tag_Component (T));
-               ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
-            else
-               AI_Tag   := First_Tag_Component (T);
-               ADT_Elmt := First_Elmt (Access_Disp_Table (T));
-            end if;
+            --  Skip the tag associated with the primary table.
 
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
             pragma Assert (Present (AI_Tag));
-            pragma Assert (Present (Node (ADT_Elmt)));
 
-            AI_Elmt  := First_Elmt (Abstract_Interfaces (T));
+            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
                AI := Node (AI_Elmt);
 
@@ -1390,47 +1426,38 @@ package body Exp_Util is
 
                AI_Tag := Next_Tag_Component (AI_Tag);
                Next_Elmt (AI_Elmt);
-               Next_Elmt (ADT_Elmt);
             end loop;
          end if;
-      end Find_AI_Tag;
+      end Find_Tag;
+
+   --  Start of processing for Find_Interface_Tag
 
    begin
-      Find_AI_Tag (T, Found);
-      pragma Assert (Found);
+      --  Handle private types
 
-      Iface_Tag := AI_Tag;
-      Iface_ADT := Node (ADT_Elmt);
-   end Find_Interface_Tag;
+      if Has_Private_Declaration (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
 
-   ------------------------
-   -- Find_Interface_Tag --
-   ------------------------
+      --  Handle access types
 
-   function Find_Interface_ADT
-     (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id
-   is
-      Iface_Tag : Entity_Id := Empty;
-      Iface_ADT : Entity_Id := Empty;
-   begin
-      Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
-      return Iface_ADT;
-   end Find_Interface_ADT;
+      if Is_Access_Type (Typ) then
+         Typ := Directly_Designated_Type (Typ);
+      end if;
 
-   ------------------------
-   -- Find_Interface_Tag --
-   ------------------------
+      --  Handle task and protected types implementing interfaces
 
-   function Find_Interface_Tag
-     (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id
-   is
-      Iface_Tag : Entity_Id := Empty;
-      Iface_ADT : Entity_Id := Empty;
-   begin
-      Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
-      return Iface_Tag;
+      if Ekind (Typ) = E_Protected_Type
+        or else Ekind (Typ) = E_Task_Type
+      then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
+      Find_Tag (Typ);
+      pragma Assert (Found);
+      return AI_Tag;
    end Find_Interface_Tag;
 
    ------------------