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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8f28a3c..74372c0 100644 (file)
--- 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 b7f31c3..42ef7e0 100644 (file)
--- 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 d1a6974..6e0efe1 100644 (file)
--- 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;