2010-06-14 Ed Schonberg <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): if derived type is an
	anonymous base generated when the parent is a constrained discriminated
	type, propagate interface list to first subtype because it may appear
	in a current instance within the extension part of the derived type
	declaration, and its own subtype declaration has not been elaborated
	yet.
	* exp_disp.adb (Build_Interface_Thunk): Use base type of formal to
	determine whether it has the controlling type.



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

3 files changed, 41 insertions, 4 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8f28a3cf1a0..74372c0026c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2010-06-14  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Build_Derived_Record_Type): if derived type is an
+	anonymous base generated when the parent is a constrained discriminated
+	type, propagate interface list to first subtype because it may appear
+	in a current instance within the extension part of the derived type
+	declaration, and its own subtype declaration has not been elaborated
+	yet.
+	* exp_disp.adb (Build_Interface_Thunk): Use base type of formal to
+	determine whether it has the controlling type.
+
 2010-06-14  Jerome Lambourg  <lambourg@adacore.com>
 
 	* exp_ch11.adb (Expand_N_Raise_Statement): Make sure that the explicit
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index b7f31c36c4a..42ef7e06ac9 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1528,14 +1528,19 @@ package body Exp_Disp is
       Formal        := First (Formals);
       while Present (Formal) loop
 
-         --  Handle concurrent types
+         --  Handle concurrent types.
 
          if Ekind (Target_Formal) = E_In_Parameter
            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
          then
             Ftyp := Directly_Designated_Type (Etype (Target_Formal));
          else
-            Ftyp := Etype (Target_Formal);
+
+            --  if the parent is a constrained discriminated type. the
+            --  primitive operation will have been defined on a first subtype.
+            --  for proper matching with controlling type, use base type.
+
+            Ftyp := Base_Type (Etype (Target_Formal));
          end if;
 
          if Is_Concurrent_Type (Ftyp) then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index d1a69740379..6e0efe1fd30 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3750,10 +3750,10 @@ package body Sem_Ch3 is
       if Present (Generic_Parent_Type (N))
         and then
           (Nkind
-             (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
+            (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
             or else Nkind
               (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
-                /=  N_Formal_Private_Type_Definition)
+                /= N_Formal_Private_Type_Definition)
       then
          if Is_Tagged_Type (Id) then
 
@@ -7356,6 +7356,27 @@ package body Sem_Ch3 is
                   Exclude_Parents => True);
 
                Set_Interfaces (Derived_Type, Ifaces_List);
+
+               --  If the derived type is the anonymous type created for
+               --  a declaration whose parent has a constraint, propagate
+               --  the interface list to the source type. This must be done
+               --  prior to the completion of the analysis of the source type
+               --  because the components in the extension may contain current
+               --  instances whose legality depends on some ancestor.
+
+               if Is_Itype (Derived_Type) then
+                  declare
+                     Def : constant Node_Id :=
+                       Associated_Node_For_Itype (Derived_Type);
+                  begin
+                     if Present (Def)
+                       and then Nkind (Def) = N_Full_Type_Declaration
+                     then
+                        Set_Interfaces
+                          (Defining_Identifier (Def), Ifaces_List);
+                     end if;
+                  end;
+               end if;
             end;
          end if;