sem_type.ads, [...] (Is_Ancestor): Addition of a new formal (Use_Full_View) which permits this routine to climb...

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* sem_type.ads, sem_type.adb (Is_Ancestor): Addition of a new formal
	(Use_Full_View) which permits this routine to climb through the
	ancestors using the full-view of private parents.
	* sem_util.adb (Collect_Interfaces_Info, Implements_Interface): Set
	Use_Full_View to true in calls to Is_Ancestor.
	* sem_disp.adb (Override_Dispatching_Operation): Set Use_Full_View to
	true in call to Is_Ancestor.
	* exp_ch3.adb (Build_Offset_To_Top_Functions, Initialize_Tag): Set
	Use_Full_View to true in call to Is_Ancestor.
	* exp_ch7.adb (Controller_Component): Set Use_Full_View to true in
	call to Is_Ancestor.
	* exp_ch4.adb (Expand_N_Type_Conversion, Tagged_Membership): Set
	Use_Full_View to true in calls to Is_Ancestor.
	* exp_disp.adb (Expand_Interface_Actuals, Make_Secondary_DT, Make_DT,
	Make_Select_Specific_Data_Table, Register_Primitive,
	Set_All_DT_Position): Set Use_Full_View to true in calls to Is_Ancestor.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Set Use_Full_View
	to true in call to Is_Ancestor.
	* exp_util.adb (Find_Interface_ADT, Find_Interface_Tag): Set
	Use_Full_View to true in calls to Is_Ancestor.
	* exp_cg.adb
	(Write_Call_Info): Set Use_Full_View to true in call to Is_Ancestor.
	(Write_Type_Info): Set Use_Full_View to true in call to Is_Ancestor.

From-SVN: r177087

12 files changed, 105 insertions, 37 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8702efb..8a82c45 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,29 @@
+2011-08-02  Javier Miranda  <miranda@adacore.com>
+
+	* sem_type.ads, sem_type.adb (Is_Ancestor): Addition of a new formal
+	(Use_Full_View) which permits this routine to climb through the
+	ancestors using the full-view of private parents.
+	* sem_util.adb (Collect_Interfaces_Info, Implements_Interface): Set
+	Use_Full_View to true in calls to Is_Ancestor.
+	* sem_disp.adb (Override_Dispatching_Operation): Set Use_Full_View to
+	true in call to Is_Ancestor.
+	* exp_ch3.adb (Build_Offset_To_Top_Functions, Initialize_Tag): Set
+	Use_Full_View to true in call to Is_Ancestor.
+	* exp_ch7.adb (Controller_Component): Set Use_Full_View to true in
+	call to Is_Ancestor.
+	* exp_ch4.adb (Expand_N_Type_Conversion, Tagged_Membership): Set
+	Use_Full_View to true in calls to Is_Ancestor.
+	* exp_disp.adb (Expand_Interface_Actuals, Make_Secondary_DT, Make_DT,
+	Make_Select_Specific_Data_Table, Register_Primitive,
+	Set_All_DT_Position): Set Use_Full_View to true in calls to Is_Ancestor.
+	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Set Use_Full_View
+	to true in call to Is_Ancestor.
+	* exp_util.adb (Find_Interface_ADT, Find_Interface_Tag): Set
+	Use_Full_View to true in calls to Is_Ancestor.
+	* exp_cg.adb
+	(Write_Call_Info): Set Use_Full_View to true in call to Is_Ancestor.
+	(Write_Type_Info): Set Use_Full_View to true in call to Is_Ancestor.
+
 2011-08-02  Robert Dewar  <dewar@adacore.com>
 
 	* gnat_rm.texi: Minor reformatting.
diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb
index 4f96664..e5f618f 100644
--- a/gcc/ada/exp_cg.adb
+++ b/gcc/ada/exp_cg.adb
@@ -478,7 +478,8 @@ package body Exp_CG is
         and then
           Is_Ancestor
             (Find_Dispatching_Type (Ultimate_Alias (Prim)),
-             Root_Type (Ctrl_Typ))
+             Root_Type (Ctrl_Typ),
+             Use_Full_View => True)
       then
          --  This is a special case in which we generate in the ci file the
          --  slot number of the renaming primitive (i.e. Base2) but instead of
@@ -616,7 +617,8 @@ package body Exp_CG is
          if Present (Overridden_Operation (Prim))
            and then
              Is_Ancestor
-               (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ)
+               (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
+                Use_Full_View => True)
          then
             Write_Char (',');
             Write_Int
@@ -642,7 +644,8 @@ package body Exp_CG is
 
                   if Present (Int_Alias)
                     and then
-                      not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ)
+                      not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
+                                       Use_Full_View => True)
                     and then (Alias (Prim_Op)) = Prim
                   then
                      Write_Char (',');
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index c1e83bb..7eb6c99 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2220,7 +2220,9 @@ package body Exp_Ch3 is
             --  If the interface is a parent of Rec_Type it shares the primary
             --  dispatch table and hence there is no need to build the function
 
-            if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type) then
+            if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type,
+                                Use_Full_View => True)
+            then
                Build_Offset_To_Top_Function (Iface_Comp);
             end if;
 
@@ -7297,7 +7299,7 @@ package body Exp_Ch3 is
          --  Initialize the pointer to the secondary DT associated with the
          --  interface.
 
-         if not Is_Ancestor (Iface, Typ) then
+         if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
             Append_To (Stmts_List,
               Make_Assignment_Statement (Loc,
                 Name =>
@@ -7394,7 +7396,7 @@ package body Exp_Ch3 is
             --  Don't need to set any value if this interface shares
             --  the primary dispatch table.
 
-            if not Is_Ancestor (Iface, Typ) then
+            if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
                Append_To (Stmts_List,
                  Build_Set_Static_Offset_To_Top (Loc,
                    Iface_Tag    => New_Reference_To (Iface_Tag, Loc),
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index a0c4104..c8ba5e5 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -8628,7 +8628,8 @@ package body Exp_Ch4 is
                if Is_Class_Wide_Type (Actual_Op_Typ)
                  and then Actual_Op_Typ /= Actual_Targ_Typ
                  and then Root_Op_Typ /= Actual_Targ_Typ
-                 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
+                 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
+                                       Use_Full_View => True)
                then
                   Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
                   Make_Conversion := True;
@@ -10461,7 +10462,8 @@ package body Exp_Ch4 is
          --    Obj1 in Iface'Class;  --  Compile time error
 
          if not Is_Class_Wide_Type (Left_Type)
-           and then (Is_Ancestor (Etype (Right_Type), Left_Type)
+           and then (Is_Ancestor (Etype (Right_Type), Left_Type,
+                                  Use_Full_View => True)
                        or else (Is_Interface (Etype (Right_Type))
                                  and then Interface_Present_In_Ancestor
                                            (Typ   => Left_Type,
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b6b8c85..97ec568 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -911,7 +911,9 @@ package body Exp_Ch7 is
 
             --  Otherwise record the outermost one and continue looking
 
-            elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then
+            elsif Res = Empty
+              or else Is_Ancestor (Res_Scop, Comp_Scop, Use_Full_View => True)
+            then
                Res      := Comp;
                Res_Scop := Comp_Scop;
             end if;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index f2d5ccd..07444e7 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1435,7 +1435,9 @@ package body Exp_Disp is
             --  a parent of the type of the actual because in this case the
             --  interface primitives are located in the primary dispatch table.
 
-            elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
+            elsif Is_Ancestor (Formal_Typ, Actual_Typ,
+                               Use_Full_View => True)
+            then
                null;
 
             --  Implicit conversion to the class-wide formal type to force
@@ -1494,7 +1496,9 @@ package body Exp_Disp is
             --  a parent of the type of the actual because in this case the
             --  interface primitives are located in the primary dispatch table.
 
-            elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
+            elsif Is_Ancestor (Formal_DDT, Actual_DDT,
+                               Use_Full_View => True)
+            then
                null;
 
             else
@@ -4090,7 +4094,8 @@ package body Exp_Disp is
                      --  Tagged_Type. Otherwise the DT associated with the
                      --  interface is the primary DT.
 
-                    and then not Is_Ancestor (Iface, Typ)
+                    and then not Is_Ancestor (Iface, Typ,
+                                              Use_Full_View => True)
                   then
                      if not Build_Thunks then
                         Prim_Pos :=
@@ -5087,7 +5092,7 @@ package body Exp_Disp is
             begin
                AI := First_Elmt (Typ_Ifaces);
                while Present (AI) loop
-                  if Is_Ancestor (Node (AI), Typ) then
+                  if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
                      Sec_DT_Tag :=
                        New_Reference_To (DT_Ptr, Loc);
                   else
@@ -5098,7 +5103,8 @@ package body Exp_Disp is
 
                      while Is_Tag (Node (Elmt))
                         and then not
-                          Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
+                          Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
+                                       Use_Full_View => True)
                      loop
                         pragma Assert (Has_Thunks (Node (Elmt)));
                         Next_Elmt (Elmt);
@@ -6182,7 +6188,8 @@ package body Exp_Disp is
             if Present (Interface_Alias (Prim))
               and then not
                 Is_Ancestor
-                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+                   Use_Full_View => True)
               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
             then
                Prim_Pos := DT_Position (Alias (Prim));
@@ -6983,7 +6990,7 @@ package body Exp_Disp is
          --  No action needed for interfaces that are ancestors of Typ because
          --  their primitives are located in the primary dispatch table.
 
-         if Is_Ancestor (Iface_Typ, Tag_Typ) then
+         if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
             return L;
 
          --  No action needed for primitives located in the C++ part of the
@@ -6999,7 +7006,7 @@ package body Exp_Disp is
 
          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
-         if not Is_Ancestor (Iface_Typ, Tag_Typ)
+         if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
            and then Present (Thunk_Code)
          then
             --  Generate the code necessary to fill the appropriate entry of
@@ -7357,7 +7364,8 @@ package body Exp_Disp is
 
             elsif Present (Interface_Alias (Prim))
               and then Is_Ancestor
-                         (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+                         (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+                          Use_Full_View => True)
             then
                pragma Assert (DT_Position (Prim) = No_Uint
                  and then Present (DTC_Entity (Interface_Alias (Prim))));
@@ -7379,7 +7387,8 @@ package body Exp_Disp is
               and then Chars (Prim) = Chars (Alias (Prim))
               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
               and then Is_Ancestor
-                         (Find_Dispatching_Type (Alias (Prim)), Typ)
+                         (Find_Dispatching_Type (Alias (Prim)), Typ,
+                          Use_Full_View => True)
               and then Present (DTC_Entity (Alias (Prim)))
             then
                E := Alias (Prim);
@@ -7445,7 +7454,8 @@ package body Exp_Disp is
             --  Check if this entry will be placed in the primary DT
 
             if Is_Ancestor
-                (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
+                 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
+                  Use_Full_View => True)
             then
                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 977e335..4a300b8 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -231,7 +231,9 @@ package body Exp_Intr is
          --  If the result type is not parent of Tag_Arg then we need to
          --  locate the tag of the secondary dispatch table.
 
-         if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
+         if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
+                             Use_Full_View => True)
+         then
             pragma Assert (not Is_Interface (Etype (Tag_Arg)));
 
             Iface_Tag :=
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 48e2283..74e916f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1501,7 +1501,7 @@ package body Exp_Util is
         (not Is_Class_Wide_Type (Typ)
           and then Ekind (Typ) /= E_Incomplete_Type);
 
-      if Is_Ancestor (Iface, Typ) then
+      if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
          return First_Elmt (Access_Disp_Table (Typ));
 
       else
@@ -1510,7 +1510,8 @@ package body Exp_Util is
          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)))
+           and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
+                                     Use_Full_View => True)
          loop
             Next_Elmt (ADT);
          end loop;
@@ -1576,7 +1577,9 @@ package body Exp_Util is
             while Present (AI_Elmt) loop
                AI := Node (AI_Elmt);
 
-               if AI = Iface or else Is_Ancestor (Iface, AI) then
+               if AI = Iface
+                 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
+               then
                   Found := True;
                   return;
                end if;
@@ -1628,7 +1631,7 @@ package body Exp_Util is
       --  If the interface is an ancestor of the type, then it shared the
       --  primary dispatch table.
 
-      if Is_Ancestor (Iface, Typ) then
+      if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
          pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
          return First_Tag_Component (Typ);
 
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 450716b..55c1d32 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -2087,7 +2087,7 @@ package body Sem_Disp is
         and then Etype (Tagged_Type) /= Tagged_Type
         and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
         and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
-                                  Tagged_Type)
+                                  Tagged_Type, Use_Full_View => True)
         and then not Implements_Interface
                        (Etype (Tagged_Type),
                         Find_Dispatching_Type (Alias (Prev_Op)))
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 08d273e..2e0eb7a 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2564,7 +2564,11 @@ package body Sem_Type is
    -- Is_Ancestor --
    -----------------
 
-   function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
+   function Is_Ancestor
+     (T1            : Entity_Id;
+      T2            : Entity_Id;
+      Use_Full_View : Boolean := False) return Boolean
+   is
       BT1 : Entity_Id;
       BT2 : Entity_Id;
       Par : Entity_Id;
@@ -2624,14 +2628,14 @@ package body Sem_Type is
             then
                return True;
 
+            --  Climb to the ancestor type
+
             elsif Etype (Par) /= Par then
 
-               --  If this is a private type and its parent is an interface
-               --  then use the parent of the full view (which is a type that
-               --  implements such interface)
+               --  Use the full-view of private types (if allowed)
 
-               if Is_Private_Type (Par)
-                 and then Is_Interface (Etype (Par))
+               if Use_Full_View
+                 and then Is_Private_Type (Par)
                  and then Present (Full_View (Par))
                then
                   Par := Etype (Full_View (Par));
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 83d4bb9..40e4c60 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -217,9 +217,23 @@ package Sem_Type is
    --  but conceptually the resolution of the actual takes place in the
    --  enclosing context and no special disambiguation rules should be applied.
 
-   function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
+   function Is_Ancestor
+     (T1            : Entity_Id;
+      T2            : Entity_Id;
+      Use_Full_View : Boolean := False) return Boolean;
    --  T1 is a tagged type (not class-wide). Verify that it is one of the
-   --  ancestors of type T2 (which may or not be class-wide).
+   --  ancestors of type T2 (which may or not be class-wide). If Use_Full_View
+   --  is True then the full-view of private parents is used when climbing
+   --  through the parents of T2.
+   --
+   --  Note: For analysis purposes the flag Use_Full_View must be set to False
+   --  (otherwise we break the privacy contract since this routine returns true
+   --  for hidden ancestors of private types). For expansion purposes this flag
+   --  is generally set to True since the expander must know with precision the
+   --  ancestors of a tagged type. For example, if a private type derives from
+   --  an interface type then the interface may not be an ancestor of its full
+   --  view since the full-view is only required to cover the interface (RM 7.3
+   --  (7.3/2))) and this knowledge affects construction of dispatch tables.
 
    function Is_Progenitor
      (Iface : Entity_Id;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index f401f94..6645688 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1687,7 +1687,7 @@ package body Sem_Util is
          --  Associate the primary tag component and the primary dispatch table
          --  with all the interfaces that are parents of T
 
-         if Is_Ancestor (Iface, T) then
+         if Is_Ancestor (Iface, T, Use_Full_View => True) then
             Append_Elmt (First_Tag_Component (T), Components_List);
             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
 
@@ -1700,7 +1700,7 @@ package body Sem_Util is
                Comp_Iface := Related_Type (Node (Comp_Elmt));
 
                if Comp_Iface = Iface
-                 or else Is_Ancestor (Iface, Comp_Iface)
+                 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
                then
                   Append_Elmt (Node (Comp_Elmt), Components_List);
                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
@@ -5504,7 +5504,7 @@ package body Sem_Util is
 
       Elmt := First_Elmt (Ifaces_List);
       while Present (Elmt) loop
-         if Is_Ancestor (Node (Elmt), Typ)
+         if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
            and then Exclude_Parents
          then
             null;