einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias.

2008-05-26  Javier Miranda  <miranda@adacore.com>

	* einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias.
	(Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias.
	(Is_Internal): Adding documentation on internal entities that have
 	attribute Interface_Alias (old attribute Abstract_Interface_Alias)

	* einfo.adb (Abstract_Interface_Alias): Renamed as Interface_Alias.
	(Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias.
 	Added assertion to force entities with this attribute to have
 	attribute Is_Internal set to True.
	(Next_Tag_Component): Simplify assertion using attribute Is_Tag.

	* sem_ch3.adb (Derive_Interface_Subprograms): This subprogram has been
 	renamed as Derive_Progenitor_Subprograms. In addition, its code is
 	a new implementation.
	(Add_Interface_Tag_Components): Remove special management of
	synchronized interfaces.
	(Analyze_Interface_Declaration): Minor reformating
	(Build_Derived_Record_Type): Minor reformating
	(Check_Abstract_Overriding): Avoid reporting error in case of abstract
 	predefined primitive inherited from interface type because the body of
 	internally generated predefined primitives of tagged types are generated
 	later by Freeze_Type
	(Derive_Subprogram): Avoid generating an internal name if the parent
 	subprogram overrides an interface primitive.
	(Derive_Subprograms): New implementation that keeps separate the
 	management of tagged types not implementing interfaces, from tagged
 	types that implement interfaces.
	(Is_Progenitor): New implementation.
	(Process_Full_View): Add documentation
	(Record_Type_Declaration): Replace call to Derive_Interface_Subprograms
 	by call to Derive_Progenitor_Subprograms.

	* sem_ch6.ads (Is_Interface_Conformant): New subprogram.
	(Check_Subtype_Conformant, Subtype_Conformant): Adding new argument
 	Skip_Controlling_Formals.

	* sem_ch6.adb (Is_Interface_Conformant): New subprogram.
	(Check_Conventions): New implementation. Remove local subprogram
 	Skip_Check. Remove formal Search_From of routine Check_Convention.
	(Check_Subtype_Conformant, Subtype_Conformant): Adding new argument
 	Skip_Controlling_Formals.
	(New_Overloaded_Entity): Enable addition of predefined dispatching
 	operations.

	* sem_disp.ads
	(Find_Primitive_Covering_Interface): New subprogram.

	* sem_disp.adb (Check_Dispatching_Operation): Disable registering
 	the task body procedure as a primitive of the corresponding tagged
 	type.
	(Check_Operation_From_Private_Type): Avoid adding twice an entity
 	to the list of primitives.
	(Find_Primitive_Covering_Interface): New subprogram.
	(Override_Dispatching_Operation): Add documentation.

	* sem_type.adb (Covers): Minor reformatings

	* sem_util.ads (Collect_Abstract_Interfaces): Renamed as
	Collect_Interfaces.
 	Rename formal.
	(Has_Abstract_Interfaces): Renamed as Has_Interfaces.
	(Implements_Interface): New subprogram.
	(Is_Parent): Removed.
	(Primitive_Names_Match): New subprogram.
	(Remove_Homonym): Moved here from Derive_Interface_Subprograms.
	(Ultimate_Alias): New subprogram.

	* sem_util.adb (Collect_Abstract_Interfaces): Renamed as
	Collect_Interfaces.
 	Remove special management for synchronized types. Rename formal. Remove
 	internal subprograms Interface_Present_In_Parent and Add_Interface.
	(Has_Abstract_Interfaces): Renamed as Has_Interfaces. Replace assertion
 	on non-record types by code to return false in such case.
	(Implements_Interface): New subprogram.
	(Is_Parent): Removed. No special management is now required for
 	synchronized types covering interfaces.
	(Primitive_Names_Match): New subprogram.
	(Remove_Homonym): Moved here from Derive_Interface_Subprograms.
	(Ultimate_Alias): New subprogram.

	* exp_ch3.adb (Add_Internal_Interface_Entities): New subprogram.
 	Add internal entities associated with secondary dispatch tables to
 	the list of tagged type primitives that are not interfaces.
	(Freeze_Record_Type): Add new call to Add_Internal_Interface_Entities
	(Make_Predefined_Primitive_Specs): Code reorganization to improve
 	the management of predefined equality operator. In addition, if
 	the type has an equality function corresponding with a primitive
 	defined in an interface type, the inherited equality is abstract
 	as well, and no body can be created for it.

	* exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved from
 	exp_util to exp_disp.
	(Is_Predefined_Interface_Primitive): New subprogram. Returns True if
 	an entity corresponds with one of the predefined primitives required
 	to implement interfaces.
	Update copyright notice.

	* exp_disp.adb (Set_All_DT_Position): Add assertion. Exclude from the
 	final check on abstract subprograms all the primitives associated with
 	interface primitives because they must be visible in the public and
 	private part.
	(Write_DT): Use Find_Dispatching_Type to locate the name of the
	interface type. This allows the use of this routine, for debugging
	purposes, when the tagged type is not fully decorated.
	(Is_Predefined_Dispatching_Operation): Moved from exp_util to exp_disp.
 	Factorize code calling new subprogram Is_Predefined_Interface_Primitive.
	(Is_Predefined_Interface_Primitive): New subprogram. Returns True if an
 	entity corresponds with one of the predefined primitives required to
 	implement interfaces.

	* exp_util.adb (Find_Interface_ADT): New implementation
	(Find_Interface): Removed.

	* sprint.adb (Sprint_Node_Actual): Generate missing output for the
 	list of interfaces associated with nodes
	N_Formal_Derived_Type_Definition and N_Private_Extension_Declaration.

From-SVN: r135923

1 files changed, 31 insertions, 300 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index c6b61d5..058c549 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1386,73 +1386,8 @@ package body Exp_Util is
      (T     : Entity_Id;
       Iface : Entity_Id) return Elmt_Id
    is
-      ADT   : Elmt_Id;
-      Found : Boolean   := False;
-      Typ   : Entity_Id := T;
-
-      procedure Find_Secondary_Table (Typ : Entity_Id);
-      --  Internal subprogram used to recursively climb to the ancestors
-
-      --------------------------
-      -- Find_Secondary_Table --
-      --------------------------
-
-      procedure Find_Secondary_Table (Typ : Entity_Id) is
-         AI_Elmt : Elmt_Id;
-         AI      : Node_Id;
-
-      begin
-         pragma Assert (Typ /= Iface);
-
-         --  Climb to the ancestor (if any) handling synchronized interface
-         --  derivations and private types
-
-         if Is_Concurrent_Record_Type (Typ) then
-            declare
-               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
-
-            begin
-               if Is_Non_Empty_List (Iface_List) then
-                  Find_Secondary_Table (Etype (First (Iface_List)));
-               end if;
-            end;
-
-         elsif Present (Full_View (Etype (Typ))) then
-            if Full_View (Etype (Typ)) /= Typ then
-               Find_Secondary_Table (Full_View (Etype (Typ)));
-            end if;
-
-         elsif Etype (Typ) /= Typ then
-            Find_Secondary_Table (Etype (Typ));
-         end if;
-
-         --  Traverse the list of interfaces implemented by the type
-
-         if not Found
-           and then 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;
-
-               --  Document what is going on here, why four Next's???
-
-               Next_Elmt (ADT);
-               Next_Elmt (ADT);
-               Next_Elmt (ADT);
-               Next_Elmt (ADT);
-               Next_Elmt (AI_Elmt);
-            end loop;
-         end if;
-      end Find_Secondary_Table;
-
-   --  Start of processing for Find_Interface_ADT
+      ADT : Elmt_Id;
+      Typ : Entity_Id := T;
 
    begin
       pragma Assert (Is_Interface (Iface));
@@ -1481,11 +1416,23 @@ package body Exp_Util is
         (not Is_Class_Wide_Type (Typ)
           and then Ekind (Typ) /= E_Incomplete_Type);
 
-      ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
-      pragma Assert (Present (Node (ADT)));
-      Find_Secondary_Table (Typ);
-      pragma Assert (Found);
-      return ADT;
+      if Is_Ancestor (Iface, Typ) then
+         return First_Elmt (Access_Disp_Table (Typ));
+
+      else
+         ADT :=
+           Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
+         while Present (ADT)
+           and then Present (Related_Type (Node (ADT)))
+           and then Related_Type (Node (ADT)) /= Iface
+           and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
+         loop
+            Next_Elmt (ADT);
+         end loop;
+
+         pragma Assert (Present (Related_Type (Node (ADT))));
+         return ADT;
+      end if;
    end Find_Interface_ADT;
 
    ------------------------
@@ -1500,14 +1447,6 @@ package body Exp_Util is
       Found  : Boolean   := False;
       Typ    : Entity_Id := T;
 
-      Is_Primary_Tag : Boolean := False;
-
-      Is_Sync_Typ : Boolean := False;
-      --  In case of non concurrent-record-types each parent-type has the
-      --  tags associated with the interface types that are not implemented
-      --  by the ancestors; concurrent-record-types have their whole list of
-      --  interface tags (and this case requires some special management).
-
       procedure Find_Tag (Typ : Entity_Id);
       --  Internal subprogram used to recursively climb to the ancestors
 
@@ -1524,32 +1463,15 @@ package body Exp_Util is
          --  therefore shares the main tag.
 
          if Typ = Iface then
-            if Is_Sync_Typ then
-               Is_Primary_Tag := True;
-            else
-               pragma Assert
-                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-               AI_Tag := First_Tag_Component (Typ);
-            end if;
-
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := First_Tag_Component (Typ);
             Found  := True;
             return;
          end if;
 
-         --  Handle synchronized interface derivations
-
-         if Is_Concurrent_Record_Type (Typ) then
-            declare
-               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
-            begin
-               if Is_Non_Empty_List (Iface_List) then
-                  Find_Tag (Etype (First (Iface_List)));
-               end if;
-            end;
-
          --  Climb to the root type handling private types
 
-         elsif Present (Full_View (Etype (Typ))) then
+         if Present (Full_View (Etype (Typ))) then
             if Full_View (Etype (Typ)) /= Typ then
                Find_Tag (Full_View (Etype (Typ)));
             end if;
@@ -1561,19 +1483,16 @@ package body Exp_Util is
          --  Traverse the list of interfaces implemented by the type
 
          if not Found
-           and then Present (Abstract_Interfaces (Typ))
-           and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+           and then Present (Interfaces (Typ))
+           and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
          then
             --  Skip the tag associated with the primary table
 
-            if not Is_Sync_Typ then
-               pragma Assert
-                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
-               pragma Assert (Present (AI_Tag));
-            end if;
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+            pragma Assert (Present (AI_Tag));
 
-            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+            AI_Elmt := First_Elmt (Interfaces (Typ));
             while Present (AI_Elmt) loop
                AI := Node (AI_Elmt);
 
@@ -1624,149 +1543,10 @@ package body Exp_Util is
          Typ := Non_Limited_View (Typ);
       end if;
 
-      if not Is_Concurrent_Record_Type (Typ) then
-         Find_Tag (Typ);
-         pragma Assert (Found);
-         return AI_Tag;
-
-      --  Concurrent record types
-
-      else
-         Is_Sync_Typ := True;
-         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
-         Find_Tag (Typ);
-         pragma Assert (Found);
-
-         if Is_Primary_Tag then
-            return First_Tag_Component (Typ);
-         else
-            return AI_Tag;
-         end if;
-      end if;
-   end Find_Interface_Tag;
-
-   --------------------
-   -- Find_Interface --
-   --------------------
-
-   function Find_Interface
-     (T      : Entity_Id;
-      Comp   : Entity_Id) return Entity_Id
-   is
-      AI_Tag : Entity_Id;
-      Found  : Boolean := False;
-      Iface  : Entity_Id;
-      Typ    : Entity_Id := T;
-
-      Is_Sync_Typ : Boolean := False;
-      --  In case of non concurrent-record-types each parent-type has the
-      --  tags associated with the interface types that are not implemented
-      --  by the ancestors; concurrent-record-types have their whole list of
-      --  interface tags (and this case requires some special management).
-
-      procedure Find_Iface (Typ : Entity_Id);
-      --  Internal subprogram used to recursively climb to the ancestors
-
-      ----------------
-      -- Find_Iface --
-      ----------------
-
-      procedure Find_Iface (Typ : Entity_Id) is
-         AI_Elmt : Elmt_Id;
-
-      begin
-         --  Climb to the root type
-
-         --  Handle synchronized interface derivations
-
-         if Is_Concurrent_Record_Type (Typ) then
-            declare
-               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
-            begin
-               if Is_Non_Empty_List (Iface_List) then
-                  Find_Iface (Etype (First (Iface_List)));
-               end if;
-            end;
-
-         --  Handle the common case
-
-         elsif Etype (Typ) /= Typ then
-            pragma Assert (not Present (Full_View (Etype (Typ))));
-            Find_Iface (Etype (Typ));
-         end if;
-
-         --  Traverse the list of interfaces implemented by the type
-
-         if not Found
-           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 not Is_Sync_Typ then
-               pragma Assert
-                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
-               pragma Assert (Present (AI_Tag));
-            end if;
-
-            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
-            while Present (AI_Elmt) loop
-               if AI_Tag = Comp then
-                  Iface := Node (AI_Elmt);
-                  Found := True;
-                  return;
-               end if;
-
-               AI_Tag := Next_Tag_Component (AI_Tag);
-               Next_Elmt (AI_Elmt);
-            end loop;
-         end if;
-      end Find_Iface;
-
-   --  Start of processing for Find_Interface
-
-   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 Is_Concurrent_Type (Typ) then
-         Typ := Corresponding_Record_Type (Typ);
-      end if;
-
-      if Is_Class_Wide_Type (Typ) then
-         Typ := Etype (Typ);
-      end if;
-
-      --  Handle entities from the limited view
-
-      if Ekind (Typ) = E_Incomplete_Type then
-         pragma Assert (Present (Non_Limited_View (Typ)));
-         Typ := Non_Limited_View (Typ);
-      end if;
-
-      if Is_Concurrent_Record_Type (Typ) then
-         Is_Sync_Typ := True;
-         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
-      end if;
-
-      Find_Iface (Typ);
+      Find_Tag (Typ);
       pragma Assert (Found);
-      return Iface;
-   end Find_Interface;
+      return AI_Tag;
+   end Find_Interface_Tag;
 
    ------------------
    -- Find_Prim_Op --
@@ -3062,55 +2842,6 @@ package body Exp_Util is
         and then Is_Library_Level_Entity (Typ);
    end Is_Library_Level_Tagged_Type;
 
-   -----------------------------------------
-   -- Is_Predefined_Dispatching_Operation --
-   -----------------------------------------
-
-   function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean
-   is
-      TSS_Name : TSS_Name_Type;
-
-   begin
-      if not Is_Dispatching_Operation (E) then
-         return False;
-      end if;
-
-      Get_Name_String (Chars (E));
-
-      --  Most predefined primitives have internally generated names. Equality
-      --  must be treated differently; the predefined operation is recognized
-      --  as a homogeneous binary operator that returns Boolean.
-
-      if Name_Len > TSS_Name_Type'Last then
-         TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
-                                     .. Name_Len));
-         if Chars (E)        = Name_uSize
-           or else Chars (E) = Name_uAlignment
-           or else TSS_Name  = TSS_Stream_Read
-           or else TSS_Name  = TSS_Stream_Write
-           or else TSS_Name  = TSS_Stream_Input
-           or else TSS_Name  = TSS_Stream_Output
-           or else
-             (Chars (E) = Name_Op_Eq
-                and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
-           or else Chars (E) = Name_uAssign
-           or else TSS_Name  = TSS_Deep_Adjust
-           or else TSS_Name  = TSS_Deep_Finalize
-           or else (Ada_Version >= Ada_05
-                      and then (Chars (E) = Name_uDisp_Asynchronous_Select
-                        or else Chars (E) = Name_uDisp_Conditional_Select
-                        or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
-                        or else Chars (E) = Name_uDisp_Get_Task_Id
-                        or else Chars (E) = Name_uDisp_Requeue
-                        or else Chars (E) = Name_uDisp_Timed_Select))
-         then
-            return True;
-         end if;
-      end if;
-
-      return False;
-   end Is_Predefined_Dispatching_Operation;
-
    ----------------------------------
    -- Is_Possibly_Unaligned_Object --
    ----------------------------------