sem_aggr.adb, [...] (Valid_Ancestor): Resolve confusion between partial and full views of an ancestor of the context...

2008-08-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb, sem_type.adb, exp_ch9.ads, einfo.ads,
	exp_ch6.adb, exp_aggr.adb (Valid_Ancestor): Resolve
	confusion between partial and full views of an ancestor of the context
	type when the parent is a private extension declared in a parent unit,
	and full views are available for the context type.

From-SVN: r139269

1 files changed, 23 insertions, 12 deletions

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index d16b7d6..13ab96c 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2155,20 +2155,31 @@ package body Sem_Aggr is
 
       begin
          Imm_Type := Base_Type (Typ);
-         while Is_Derived_Type (Imm_Type)
-           and then Etype (Imm_Type) /= Base_Type (A_Type)
-         loop
-            Imm_Type := Etype (Base_Type (Imm_Type));
+         while Is_Derived_Type (Imm_Type) loop
+            if Etype (Imm_Type) = Base_Type (A_Type) then
+               return True;
+
+            --  The base type of the parent type may appear as  a private
+            --  extension if it is declared as such in a parent unit of
+            --  the current one. For consistency of the subsequent analysis
+            --  use the partial view for the ancestor part.
+
+            elsif Is_Private_Type (Etype (Imm_Type))
+              and then Present (Full_View (Etype (Imm_Type)))
+              and then Base_Type (A_Type) = Full_View (Etype (Imm_Type))
+            then
+               A_Type := Etype (Imm_Type);
+               return True;
+
+            else
+               Imm_Type := Etype (Base_Type (Imm_Type));
+            end if;
          end loop;
 
-         if not Is_Derived_Type (Base_Type (Typ))
-           or else Etype (Imm_Type) /= Base_Type (A_Type)
-         then
-            Error_Msg_NE ("expect ancestor type of &", A, Typ);
-            return False;
-         else
-            return True;
-         end if;
+         --  If previous loop did not find a proper ancestor, report error.
+
+         Error_Msg_NE ("expect ancestor type of &", A, Typ);
+         return False;
       end Valid_Ancestor_Type;
 
    --  Start of processing for Resolve_Extension_Aggregate