exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the…

exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the support for abstract interface types in order to leave...

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.

From-SVN: r101694

gcc/ada/exp_ch6.adb

@@ -4062,37 +4062,157 @@ package body Exp_Ch6 is
    procedure Freeze_Subprogram (N : Node_Id) is
       Loc       : constant Source_Ptr := Sloc (N);
       E         : constant Entity_Id  := Entity (N);
-      Thunk_Id  : Entity_Id;
-      Iface_Tag : Entity_Id;
-      New_Thunk : Node_Id;
 
-   begin
-      --  When a primitive is frozen, enter its name in the corresponding
-      --  dispatch table. If the DTC_Entity field is not set this is an
-      --  overridden primitive that can be ignored. We suppress the
-      --  initialization of the dispatch table entry when Java_VM because
-      --  the dispatching mechanism is handled internally by the JVM.
+      procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
+      --  (Ada 2005): Check if the primitive E covers some interface already
+      --  implemented by some ancestor of the tagged-type associated with E
+
+      procedure Register_Interface_DT_Entry
+        (Prim                : Entity_Id;
+         Ancestor_Iface_Prim : Entity_Id := Empty);
+      --  (Ada 2005): Register an interface primitive in a secondary dispatch
+      --  table. If Prim overrides an ancestor primitive of its associated
+      --  tagged-type then Ancestor_Iface_Prim indicates the entity of that
+      --  immediate ancestor associated with the interface; otherwise Prim and
+      --  Ancestor_Iface_Prim have the same info.
+
+      -------------------------------------------
+      -- Check_Overriding_Inherited_Interfaces --
+      -------------------------------------------
+
+      procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is
+         Typ          : Entity_Id;
+         Elmt         : Elmt_Id;
+         Prim_Op      : Entity_Id;
+         Overriden_Op : Entity_Id := Empty;
 
-      if Is_Dispatching_Operation (E)
-        and then not Is_Abstract (E)
-        and then Present (DTC_Entity (E))
-        and then not Is_CPP_Class (Scope (DTC_Entity (E)))
-        and then not Java_VM
-      then
-         Check_Overriding_Operation (E);
+      begin
+         if Ada_Version < Ada_05
+           or else not Is_Overriding_Operation (E)
+           or else Is_Predefined_Dispatching_Operation (E)
+           or else Present (Alias (E))
+         then
+            return;
+         end if;
+
+         --  Get the entity associated with this primitive operation
+
+         Typ := Scope (DTC_Entity (E));
+         while Etype (Typ) /= Typ loop
+
+            --  Climb to the immediate ancestor
+
+            Typ := Etype (Typ);
 
-         --  Common case: Primitive subprogram
+            if Present (Abstract_Interfaces (Typ)) then
 
-         if not Present (Abstract_Interface_Alias (E)) then
-            Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+               --  Look for the overriden subprogram in the primary dispatch
+               --  table of the ancestor.
 
-         --  Ada 2005 (AI-251): Primitive subprogram that covers an interface
+               Overriden_Op := Empty;
+               Elmt         := First_Elmt (Primitive_Operations (Typ));
+               while Present (Elmt) loop
+                  Prim_Op := Node (Elmt);
+
+                  if DT_Position (Prim_Op) = DT_Position (E)
+                    and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
+                    and then not Present (Abstract_Interface_Alias (Prim_Op))
+                  then
+                     if Overriden_Op /= Empty then
+                        raise Program_Error;
+                     end if;
+
+                     Overriden_Op := Prim_Op;
+                  end if;
+
+                  Next_Elmt (Elmt);
+               end loop;
+
+               --  if not found this is the first overriding of some
+               --  abstract interface
+
+               if Overriden_Op /= Empty then
+                  Elmt := First_Elmt (Primitive_Operations (Typ));
+
+                  --  Find the entries associated with interfaces that are
+                  --  alias of this primitive operation in the ancestor
+
+                  while Present (Elmt) loop
+                     Prim_Op := Node (Elmt);
+
+                     if Present (Abstract_Interface_Alias (Prim_Op))
+                       and then Alias (Prim_Op) = Overriden_Op
+                     then
+                        Register_Interface_DT_Entry (E, Prim_Op);
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+               end if;
+            end if;
+         end loop;
+      end Check_Overriding_Inherited_Interfaces;
+
+      ---------------------------------
+      -- Register_Interface_DT_Entry --
+      ---------------------------------
+
+      procedure Register_Interface_DT_Entry
+        (Prim                : Entity_Id;
+         Ancestor_Iface_Prim : Entity_Id := Empty)
+      is
+         Prim_Typ     : Entity_Id;
+         Prim_Op      : Entity_Id;
+         Iface_Typ    : Entity_Id;
+         Iface_DT_Ptr : Entity_Id;
+         Iface_Tag    : Entity_Id;
+         New_Thunk    : Node_Id;
+         Thunk_Id     : Entity_Id;
+
+      begin
+         if not Present (Ancestor_Iface_Prim) then
+            Prim_Typ  := Scope (DTC_Entity (Alias (Prim)));
+            Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
+            Iface_Tag := Find_Interface_Tag
+                           (T     => Prim_Typ,
+                            Iface => Iface_Typ);
+
+            --  Generate the code of the thunk only when this primitive
+            --  operation is associated with a secondary dispatch table
+
+            if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+               Thunk_Id  := Make_Defining_Identifier (Loc,
+                              New_Internal_Name ('T'));
+               New_Thunk :=
+                 Expand_Interface_Thunk
+                   (N           => Prim,
+                    Thunk_Alias => Alias (Prim),
+                    Thunk_Id    => Thunk_Id,
+                    Iface_Tag   => Iface_Tag);
+
+               Insert_After (N, New_Thunk);
+
+               Iface_DT_Ptr :=
+                 Find_Interface_ADT
+                   (T     => Prim_Typ,
+                    Iface => Iface_Typ);
+
+               Insert_After (New_Thunk,
+                 Fill_Secondary_DT_Entry (Sloc (Prim),
+                   Prim         => Prim,
+                   Iface_DT_Ptr => Iface_DT_Ptr,
+                   Thunk_Id     => Thunk_Id));
+            end if;
 
          else
+            Iface_Typ :=
+              Scope (DTC_Entity (Abstract_Interface_Alias
+                                  (Ancestor_Iface_Prim)));
+
             Iface_Tag :=
               Find_Interface_Tag
-                (T     => Scope (DTC_Entity (Alias (E))),    -- Formal Type
-                 Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E))));
+                (T     => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))),
+                 Iface => Iface_Typ);
 
             --  Generate the thunk only if the associated tag is an interface
             --  tag. The case in which the associated tag is the primary tag
@@ -4107,12 +4227,69 @@ package body Exp_Ch6 is
                Thunk_Id  := Make_Defining_Identifier (Loc,
                               New_Internal_Name ('T'));
 
-               New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag);
+               if Present (Alias (Prim)) then
+                  Prim_Op := Alias (Prim);
+               else
+                  Prim_Op := Prim;
+               end if;
+
+               New_Thunk :=
+                 Expand_Interface_Thunk
+                   (N           => Ancestor_Iface_Prim,
+                    Thunk_Alias => Prim_Op,
+                    Thunk_Id    => Thunk_Id,
+                    Iface_Tag   => Iface_Tag);
+
+               Insert_After (N, New_Thunk);
+
+               Iface_DT_Ptr :=
+                 Find_Interface_ADT
+                   (T     => Scope (DTC_Entity (Prim_Op)),
+                    Iface => Iface_Typ);
 
                Insert_After (New_Thunk,
-                  Fill_DT_Entry (Sloc (N),
-                     Prim     => E,
-                     Thunk_Id => Thunk_Id));
+                 Fill_Secondary_DT_Entry (Sloc (Prim),
+                   Prim         => Ancestor_Iface_Prim,
+                   Iface_DT_Ptr => Iface_DT_Ptr,
+                   Thunk_Id     => Thunk_Id));
+            end if;
+         end if;
+      end Register_Interface_DT_Entry;
+
+   --  Start of processing for Freeze_Subprogram
+
+   begin
+      --  When a primitive is frozen, enter its name in the corresponding
+      --  dispatch table. If the DTC_Entity field is not set this is an
+      --  overridden primitive that can be ignored. We suppress the
+      --  initialization of the dispatch table entry when Java_VM because
+      --  the dispatching mechanism is handled internally by the JVM.
+
+      if Is_Dispatching_Operation (E)
+        and then not Is_Abstract (E)
+        and then Present (DTC_Entity (E))
+        and then not Java_VM
+        and then not Is_CPP_Class (Scope (DTC_Entity (E)))
+      then
+         Check_Overriding_Operation (E);
+
+         if Ada_Version < Ada_05 then
+            Insert_After (N,
+              Fill_DT_Entry (Sloc (N), Prim => E));
+
+         else
+            --  Ada 2005 (AI-251): Check if this entry corresponds with
+            --  a subprogram that covers an abstract interface type
+
+            if Present (Abstract_Interface_Alias (E)) then
+               Register_Interface_DT_Entry (E);
+
+            --  Common case: Primitive subprogram
+
+            else
+               Insert_After (N,
+                 Fill_DT_Entry (Sloc (N), Prim => E));
+               Check_Overriding_Inherited_Interfaces (E);
             end if;
          end if;
       end if;

gcc/ada/exp_disp.ads

@@ -55,12 +55,20 @@ package Exp_Disp is
        TSD_Prologue_Size);
 
    function Fill_DT_Entry
-     (Loc      : Source_Ptr;
-      Prim     : Entity_Id;
-      Thunk_Id : Entity_Id := Empty) return Node_Id;
+     (Loc          : Source_Ptr;
+      Prim         : Entity_Id) return Node_Id;
    --  Generate the code necessary to fill the appropriate entry of the
    --  dispatch table of Prim's controlling type with Prim's address.
 
+   function Fill_Secondary_DT_Entry
+     (Loc          : Source_Ptr;
+      Prim         : Entity_Id;
+      Thunk_Id     : Entity_Id;
+      Iface_DT_Ptr : Entity_Id) return Node_Id;
+   --  (Ada 2005): Generate the code necessary to fill the appropriate entry of
+   --  the secondary dispatch table of Prim's controlling type with Thunk_Id's
+   --  address.
+
    procedure Make_Abstract_Interface_DT
      (AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;
@@ -102,9 +110,10 @@ package Exp_Disp is
    --  secondary dispatch table
 
    function Expand_Interface_Thunk
-     (N         : Node_Id;
-      Thunk_Id  : Entity_Id;
-      Iface_Tag : Entity_Id) return Node_Id;
+     (N           : Node_Id;
+      Thunk_Alias : Node_Id;
+      Thunk_Id    : Entity_Id;
+      Iface_Tag   : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
    --  generate additional subprograms (thunks) to have a layout compatible
    --  with the C++ ABI. The thunk modifies the value of the first actual of

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