2005-11-14 Ed Schonberg <schonberg@adacore.com>

	    Javier Miranda  <miranda@adacore.com>

	* sem_ch3.ads, sem_ch3.adb (Build_Discriminal): Add link to original
	discriminant.
	(Build_Private_Derived_Type): The entity of the created full view of the
	derived type does not come from source. If after installing the private
	declarations of the parent scope the parent is still private, use its
	full view to construct the full declaration of the derived type.
	(Build_Derived_Record_Type): Relax the condition that controls the
	execution of the check that verifies that the partial view and
	the full view agree in the set of implemented interfaces. In
	addition, this test now only takes into account the progenitors.
	(Derive_Interface_Subprograms): No need to derive subprograms
	of ancestors that are interfaces.
	(Derive_Subprograms): Remove formal No_Predefined_Prims and the
	associated code.
	Change name Is_Package to Is_Package_Or_Generic_Package
	(Complete_Subprograms_Derivation): Handle the case in which the full
	view is a transitive derivation of the ancestor of the partial view.
	(Process_Full_View): Rename local subprogram Find_Interface_In_
	Descendant to Find_Ancestor_Interface to leave the code more clear.
	Remove wrong code that avoids the generation of an error message
	when the immediate ancestor of the partial view is an interface.
	In addition some minor reorganization of the code has been done to
	leave it more clear.
	(Analyze_Type_Declaration): If type has previous incomplete tagged
	partial view, inherit properly its primitive operations.
	(Collect_Interfaces): Make public, for analysis of formal
	interfaces.
	(Analyze_Interface_Declaration): New procedure for use for regular and
	formal interface declarations.
	(Build_Derived_Record_Type): Add support for private types to the code
	that checks if a tagged type implements abstract interfaces.
	(Check_Aliased_Component_Type): The test applies in the spec of an
	instance as well.
	(Access_Type_Declaration): Clean up declaration of malformed type
	declared as an access to its own classwide type, to prevent cascaded
	crash.
	(Collect_Interfaces): For private extensions and for derived task types
	and derived protected types, the parent may be an interface that must
	be included in the interface list.
	(Access_Definition): If the designated type is an interface that may
	contain tasks, create Master_Id for it before analyzing the expression
	of the declaration, which may be an allocator.
	(Record_Type_Declaration): Set properly the interface kind, for use
	in allocators, the creation of master id's for task interfaces, etc.



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

2 files changed, 261 insertions, 194 deletions

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index adefc6a4b59..a799427e013 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -171,14 +171,6 @@ package body Sem_Ch3 is
    --  False is for an implicit derived full type for a type derived from a
    --  private type (see Build_Derived_Type).
 
-   procedure Collect_Interfaces
-     (N            : Node_Id;
-      Derived_Type : Entity_Id);
-   --  Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
-   --  Collect the list of interfaces that are not already implemented by the
-   --  ancestors. This is the list of interfaces for which we must provide
-   --  additional tag components.
-
    procedure Complete_Subprograms_Derivation
      (Partial_View : Entity_Id;
       Derived_Type : Entity_Id);
@@ -799,6 +791,20 @@ package body Sem_Ch3 is
          Set_Has_Delayed_Freeze (Current_Scope);
       end if;
 
+      --  Ada 2005: if the designated type is an interface that may contain
+      --  tasks, create a Master entity for the declaration. This must be done
+      --  before expansion of the full declaration, because the declaration
+      --  may include an expression that is an allocator, whose expansion needs
+      --  the proper Master for the created tasks.
+
+      if Nkind (Related_Nod) = N_Object_Declaration
+         and then Expander_Active
+         and then Is_Interface (Desig_Type)
+         and then Is_Limited_Record (Desig_Type)
+      then
+         Build_Class_Wide_Master (Anon_Type);
+      end if;
+
       return Anon_Type;
    end Access_Definition;
 
@@ -985,6 +991,10 @@ package body Sem_Ch3 is
       then
          Error_Msg_N
            ("access type cannot designate its own classwide type", S);
+
+         --  Clean up indication of tagged status to prevent cascaded errors
+
+         Set_Is_Tagged_Type (T, False);
       end if;
 
       Set_Etype (T, T);
@@ -1584,6 +1594,33 @@ package body Sem_Ch3 is
       Set_Is_Pure (T, F);
    end Analyze_Incomplete_Type_Decl;
 
+   -----------------------------------
+   -- Analyze_Interface_Declaration --
+   -----------------------------------
+
+   procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
+   begin
+      Set_Is_Tagged_Type      (T);
+
+      Set_Is_Limited_Record   (T, Limited_Present (Def)
+                                   or else Task_Present (Def)
+                                   or else Protected_Present (Def)
+                                   or else Synchronized_Present (Def));
+
+      --  Type is abstract if full declaration carries keyword, or if
+      --  previous partial view did.
+
+      Set_Is_Abstract  (T);
+      Set_Is_Interface (T);
+
+      Set_Is_Limited_Interface      (T, Limited_Present (Def));
+      Set_Is_Protected_Interface    (T, Protected_Present (Def));
+      Set_Is_Synchronized_Interface (T, Synchronized_Present (Def));
+      Set_Is_Task_Interface         (T, Task_Present (Def));
+      Set_Abstract_Interfaces       (T, New_Elmt_List);
+      Set_Primitive_Operations      (T, New_Elmt_List);
+   end Analyze_Interface_Declaration;
+
    -----------------------------
    -- Analyze_Itype_Reference --
    -----------------------------
@@ -1958,7 +1995,7 @@ package body Sem_Ch3 is
       if Constant_Present (N)
         and then No (E)
       then
-         if not Is_Package (Current_Scope) then
+         if not Is_Package_Or_Generic_Package (Current_Scope) then
             Error_Msg_N
               ("invalid context for deferred constant declaration ('R'M 7.4)",
                 N);
@@ -2589,7 +2626,7 @@ package body Sem_Ch3 is
          return;
       end if;
 
-      if (not Is_Package (Current_Scope)
+      if (not Is_Package_Or_Generic_Package (Current_Scope)
            and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
         or else In_Private_Part (Current_Scope)
 
@@ -3011,6 +3048,51 @@ package body Sem_Ch3 is
                                        or else
                                      In_Package_Body (Current_Scope));
 
+      procedure Check_Ops_From_Incomplete_Type;
+      --  If there is a tagged incomplete partial view of the type, transfer
+      --  its operations to the full view, and indicate that the type of the
+      --  controlling parameter (s) is this full view.
+
+      ------------------------------------
+      -- Check_Ops_From_Incomplete_Type --
+      ------------------------------------
+
+      procedure Check_Ops_From_Incomplete_Type is
+         Elmt   : Elmt_Id;
+         Formal : Entity_Id;
+         Op     : Entity_Id;
+
+      begin
+         if Prev /= T
+           and then Ekind (Prev) = E_Incomplete_Type
+           and then Is_Tagged_Type (Prev)
+           and then Is_Tagged_Type (T)
+         then
+            Elmt := First_Elmt (Primitive_Operations (Prev));
+            while Present (Elmt) loop
+               Op := Node (Elmt);
+               Prepend_Elmt (Op, Primitive_Operations (T));
+
+               Formal := First_Formal (Op);
+               while Present (Formal) loop
+                  if Etype (Formal) = Prev then
+                     Set_Etype (Formal, T);
+                  end if;
+
+                  Next_Formal (Formal);
+               end loop;
+
+               if Etype (Op) = Prev then
+                  Set_Etype (Op, T);
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+         end if;
+      end Check_Ops_From_Incomplete_Type;
+
+   --  Start of processing for Analyze_Type_Declaration
+
    begin
       Prev := Find_Type_Name (N);
 
@@ -3149,6 +3231,7 @@ package body Sem_Ch3 is
       --  Some common processing for all types
 
       Set_Depends_On_Private (T, Has_Private_Component (T));
+      Check_Ops_From_Incomplete_Type;
 
       --  Both the declared entity, and its anonymous base type if one
       --  was created, need freeze nodes allocated.
@@ -3787,7 +3870,8 @@ package body Sem_Ch3 is
       if Number_Dimensions (Parent_Type) = 1
         and then not Is_Limited_Type (Parent_Type)
         and then not Is_Derived_Type (Parent_Type)
-        and then not Is_Package (Scope (Base_Type (Parent_Type)))
+        and then not Is_Package_Or_Generic_Package
+                       (Scope (Base_Type (Parent_Type)))
       then
          if not Is_Constrained (Parent_Type)
            and then Is_Constrained (Derived_Type)
@@ -4438,6 +4522,7 @@ package body Sem_Ch3 is
                Full_Decl := New_Copy_Tree (N);
                Full_Der  := New_Copy (Derived_Type);
                Set_Comes_From_Source (Full_Decl, False);
+               Set_Comes_From_Source (Full_Der, False);
 
                Insert_After (N, Full_Decl);
 
@@ -4493,8 +4578,18 @@ package body Sem_Ch3 is
             --  view, the completion does not derive them anew.
 
             if not Is_Tagged_Type (Parent_Type) then
-               Build_Derived_Record_Type
-                 (Full_Decl, Parent_Type, Full_Der, False);
+
+               --  If the parent is itself derived from another private type,
+               --  installing the private declarations has not affected its
+               --  privacy status, so use its own full view explicitly.
+
+               if Is_Private_Type (Parent_Type) then
+                  Build_Derived_Record_Type
+                    (Full_Decl, Full_View (Parent_Type), Full_Der, False);
+               else
+                  Build_Derived_Record_Type
+                    (Full_Decl, Parent_Type, Full_Der, False);
+               end if;
 
             else
                --  If full view of parent is tagged, the completion
@@ -5895,113 +5990,37 @@ package body Sem_Ch3 is
                Collect_Interfaces (Type_Definition (N), Derived_Type);
             end if;
 
-            --  Check that the full view and the partial view agree
-            --  in the set of implemented interfaces
+            --  Ada 2005 (AI-251): The progenitor types specified in a private
+            --  extension declaration and the progenitor types specified in the
+            --  corresponding declaration of a record extension given in the
+            --  private part need not be the same; the only requirement is that
+            --  the private extension must be descended from each interface
+            --  from which the record extension is descended (AARM 7.3, 20.1/2)
 
-            if Has_Private_Declaration (Derived_Type)
-              and then Present (Abstract_Interfaces (Derived_Type))
-              and then not Is_Empty_Elmt_List
-                             (Abstract_Interfaces (Derived_Type))
-            then
+            if Has_Private_Declaration (Derived_Type) then
                declare
                   N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
-                  N_Full    : constant Node_Id := Parent (Derived_Type);
-
-                  Iface_Partial      : Entity_Id;
-                  Iface_Full         : Entity_Id;
-                  Num_Ifaces_Partial : Natural := 0;
-                  Num_Ifaces_Full    : Natural := 0;
-                  Same_Interfaces    : Boolean := True;
+                  Iface_Partial : Entity_Id;
 
                begin
-                  if Nkind (N_Partial) /= N_Private_Extension_Declaration then
-                     Error_Msg_N
-                       ("(Ada 2005) interfaces only allowed in private"
-                        & " extension declarations", N_Partial);
-                  end if;
-
-                  --  Count the interfaces implemented by the partial view
-
                   if Nkind (N_Partial) = N_Private_Extension_Declaration
                     and then not Is_Empty_List (Interface_List (N_Partial))
                   then
                      Iface_Partial := First (Interface_List (N_Partial));
-                     while Present (Iface_Partial) loop
-                        Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
-                        Next (Iface_Partial);
-                     end loop;
-                  end if;
-
-                  --  Take into account the case in which the partial
-                  --  view is a directly derived from an interface
-
-                  if Is_Interface (Etype
-                                   (Defining_Identifier (N_Partial)))
-                  then
-                     Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
-                  end if;
-
-                  --  Count the interfaces implemented by the full view
-
-                  if not Is_Empty_List (Interface_List
-                                        (Type_Definition (N_Full)))
-                  then
-                     Iface_Full := First (Interface_List
-                                          (Type_Definition (N_Full)));
-                     while Present (Iface_Full) loop
-                        Num_Ifaces_Full := Num_Ifaces_Full + 1;
-                        Next (Iface_Full);
-                     end loop;
-                  end if;
-
-                  --  Take into account the case in which the full
-                  --  view is a directly derived from an interface
-
-                  if Is_Interface (Etype
-                                   (Defining_Identifier (N_Full)))
-                  then
-                     Num_Ifaces_Full := Num_Ifaces_Full + 1;
-                  end if;
-
-                  if Num_Ifaces_Full > 0
-                    and then Num_Ifaces_Full = Num_Ifaces_Partial
-                  then
-                     --  Check that the full-view and the private-view have
-                     --  the same list of interfaces.
-
-                     Iface_Full := First (Interface_List
-                                           (Type_Definition (N_Full)));
-                     while Present (Iface_Full) loop
-                        Iface_Partial := First (Interface_List (N_Partial));
-                        while Present (Iface_Partial)
-                          and then Etype (Iface_Partial) /= Etype (Iface_Full)
-                        loop
-                           Next (Iface_Partial);
-                        end loop;
 
-                        --  If not found we check if the partial view is a
-                        --  direct derivation of the interface.
-
-                        if not Present (Iface_Partial)
-                             and then
-                           Etype (Tagged_Partial_View) /= Etype (Iface_Full)
+                     while Present (Iface_Partial) loop
+                        if not Interface_Present_In_Ancestor
+                                 (Derived_Type, Etype (Iface_Partial))
                         then
-                           Same_Interfaces := False;
+                           Error_Msg_N
+                             ("(Ada 2005) full type and private extension must"
+                              & " have the same progenitors", Derived_Type);
                            exit;
                         end if;
 
-                        Next (Iface_Full);
+                        Next (Iface_Partial);
                      end loop;
                   end if;
-
-                  if Num_Ifaces_Partial /= Num_Ifaces_Full
-                    or else not Same_Interfaces
-                  then
-                     Error_Msg_N
-                       ("(Ada 2005) full declaration and private declaration"
-                        & " must have the same list of interfaces",
-                        Derived_Type);
-                  end if;
                end;
             end if;
          end if;
@@ -6132,7 +6151,14 @@ package body Sem_Ch3 is
                E : Entity_Id;
 
             begin
-               E := Derived_Type;
+               --  Handle private types
+
+               if Present (Full_View (Derived_Type)) then
+                  E := Full_View (Derived_Type);
+               else
+                  E := Derived_Type;
+               end if;
+
                loop
                   if Is_Interface (E)
                     or else (Present (Abstract_Interfaces (E))
@@ -6145,11 +6171,22 @@ package body Sem_Ch3 is
 
                   exit when Etype (E) = E
 
+                     --  Handle private types
+
+                     or else (Present (Full_View (Etype (E)))
+                               and then Full_View (Etype (E)) = E)
+
                      --  Protect the frontend against wrong source
 
                     or else Etype (E) = Derived_Type;
 
-                  E := Etype (E);
+                  --  Climb to the ancestor type handling private types
+
+                  if Present (Full_View (Etype (E))) then
+                     E := Full_View (Etype (E));
+                  else
+                     E := Etype (E);
+                  end if;
                end loop;
             end;
          end if;
@@ -6168,7 +6205,7 @@ package body Sem_Ch3 is
 
             if Present (Tagged_Partial_View) then
                Derive_Subprograms
-                 (Parent_Type, Derived_Type, Predefined_Prims_Only => True);
+                 (Parent_Type, Derived_Type);
 
                Complete_Subprograms_Derivation
                  (Partial_View => Tagged_Partial_View,
@@ -6452,10 +6489,11 @@ package body Sem_Ch3 is
       then
          CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
 
-         Set_Ekind     (CR_Disc, E_In_Parameter);
-         Set_Mechanism (CR_Disc, Default_Mechanism);
-         Set_Etype     (CR_Disc, Etype (Discrim));
-         Set_CR_Discriminant (Discrim, CR_Disc);
+         Set_Ekind            (CR_Disc, E_In_Parameter);
+         Set_Mechanism        (CR_Disc, Default_Mechanism);
+         Set_Etype            (CR_Disc, Etype (Discrim));
+         Set_Discriminal_Link (CR_Disc, Discrim);
+         Set_CR_Discriminant  (Discrim, CR_Disc);
       end if;
    end Build_Discriminal;
 
@@ -7179,7 +7217,7 @@ package body Sem_Ch3 is
                if Is_Aliased (C)
                  and then Has_Discriminants (Etype (C))
                  and then not Is_Constrained (Etype (C))
-                 and then not In_Instance
+                 and then not In_Instance_Body
                  and then Ada_Version < Ada_05
                then
                   Error_Msg_N
@@ -7194,7 +7232,8 @@ package body Sem_Ch3 is
             if Has_Aliased_Components (T)
               and then Has_Discriminants (Component_Type (T))
               and then not Is_Constrained (Component_Type (T))
-              and then not In_Instance
+              and then not In_Instance_Body
+              and then Ada_Version < Ada_05
             then
                Error_Msg_N
                  ("aliased component type must be constrained ('R'M 3.6(11))",
@@ -7363,7 +7402,7 @@ package body Sem_Ch3 is
                Post_Error;
             end if;
 
-         elsif Is_Package (E) then
+         elsif Is_Package_Or_Generic_Package (E) then
             if Unit_Requires_Body (E) then
                if not Has_Completion (E)
                  and then Nkind (Parent (Unit_Declaration_Node (E))) /=
@@ -7643,6 +7682,29 @@ package body Sem_Ch3 is
 
             Next (Intf);
          end loop;
+
+      --  A type extension may be written as a derivation from an interface.
+      --  The completion will have to implement the same, or derive from a
+      --  type that implements it as well.
+
+      elsif Nkind (N) = N_Private_Extension_Declaration
+        and then Is_Interface (Etype (Derived_Type))
+      then
+         Add_Interface (Etype (Derived_Type));
+      end if;
+
+      --  Same for task and protected types, that can derive directly from
+      --  an interface (and implement additional interfaces that will be
+      --  present in the interface list of the declaration).
+
+      if Nkind (N) = N_Task_Type_Declaration
+        or else Nkind (N) = N_Protected_Type_Declaration
+        or else Nkind (N) = N_Single_Protected_Declaration
+        or else Nkind (N) = N_Single_Task_Declaration
+      then
+         if Is_Interface (Etype (Derived_Type)) then
+            Add_Interface (Etype (Derived_Type));
+         end if;
       end if;
    end Collect_Interfaces;
 
@@ -7873,6 +7935,25 @@ package body Sem_Ch3 is
       E       : Entity_Id;
 
    begin
+      --  Handle the case in which the full-view is a transitive
+      --  derivation of the ancestor of the partial view.
+
+      --   type I is interface;
+      --   type T is new I with ...
+
+      --   package H is
+      --      type DT is new I with private;
+      --   private
+      --      type DT is new T with ...
+      --   end;
+
+      if Etype (Partial_View) /= Etype (Derived_Type)
+        and then Is_Interface (Etype (Partial_View))
+        and then Is_Ancestor (Etype (Partial_View), Etype (Derived_Type))
+      then
+         return;
+      end if;
+
       if Is_Tagged_Type (Partial_View) then
          Elmt_P := First_Elmt (Primitive_Operations (Partial_View));
       else
@@ -8795,7 +8876,7 @@ package body Sem_Ch3 is
 
    --  For concurrent types, the associated record value type carries the same
    --  discriminants, so when we constrain a concurrent type, we must constrain
-   --  the value type as well.
+   --  the corresponding record type as well.
 
    procedure Constrain_Concurrent
      (Def_Id      : in out Entity_Id;
@@ -9970,10 +10051,12 @@ package body Sem_Ch3 is
          then
             AI := First_Elmt (Abstract_Interfaces (T));
             while Present (AI) loop
-               Derive_Subprograms
-                 (Parent_Type         => Node (AI),
-                  Derived_Type        => Derived_Type,
-                  No_Predefined_Prims => True);
+               if not Is_Ancestor (Node (AI), Derived_Type) then
+                  Derive_Subprograms
+                    (Parent_Type         => Node (AI),
+                     Derived_Type        => Derived_Type,
+                     No_Predefined_Prims => True);
+               end if;
 
                Next_Elmt (AI);
             end loop;
@@ -10391,8 +10474,7 @@ package body Sem_Ch3 is
      (Parent_Type           : Entity_Id;
       Derived_Type          : Entity_Id;
       Generic_Actual        : Entity_Id := Empty;
-      No_Predefined_Prims   : Boolean   := False;
-      Predefined_Prims_Only : Boolean   := False)
+      No_Predefined_Prims   : Boolean   := False)
    is
       Op_List     : constant Elist_Id :=
                       Collect_Primitive_Operations (Parent_Type);
@@ -10436,7 +10518,13 @@ package body Sem_Ch3 is
             if No_Predefined_Prims and then Is_Predef then
                null;
 
-            elsif Predefined_Prims_Only and then not Is_Predef then
+            --  We don't need to derive alias entities associated with
+            --  abstract interfaces
+
+            elsif Is_Dispatching_Operation (Subp)
+               and then Present (Alias (Subp))
+               and then Present (Abstract_Interface_Alias (Subp))
+            then
                null;
 
             elsif No (Generic_Actual) then
@@ -13098,15 +13186,15 @@ package body Sem_Ch3 is
       Full_Parent : Entity_Id;
       Full_Indic  : Node_Id;
 
-      function Find_Interface_In_Descendant
+      function Find_Ancestor_Interface
         (Typ : Entity_Id) return Entity_Id;
       --  Find an implemented interface in the derivation chain of Typ
 
-      ----------------------------------
-      -- Find_Interface_In_Descendant --
-      ----------------------------------
+      -----------------------------
+      -- Find_Ancestor_Interface --
+      -----------------------------
 
-      function Find_Interface_In_Descendant
+      function Find_Ancestor_Interface
         (Typ : Entity_Id) return Entity_Id
       is
          T : Entity_Id;
@@ -13127,7 +13215,7 @@ package body Sem_Ch3 is
          end loop;
 
          return Empty;
-      end Find_Interface_In_Descendant;
+      end Find_Ancestor_Interface;
 
    --  Start of processing for Process_Full_View
 
@@ -13180,37 +13268,36 @@ package body Sem_Ch3 is
             Iface_Def : Node_Id;
 
          begin
-            Iface := Find_Interface_In_Descendant (Full_T);
+            Iface := Find_Ancestor_Interface (Full_T);
 
             if Present (Iface) then
                Iface_Def := Type_Definition (Parent (Iface));
-            end if;
 
-            --  The full view derives from an interface descendant, but the
-            --  partial view does not share the same tagged type.
+               --  The full view derives from an interface descendant, but the
+               --  partial view does not share the same tagged type.
 
-            if Present (Iface)
-              and then Is_Tagged_Type (Priv_T)
-              and then Etype (Full_T) /= Etype (Priv_T)
-            then
-               Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
-                            "completed by a type that implements an " &
-                            "interface", Priv_T);
-            end if;
+               if Is_Tagged_Type (Priv_T)
+                 and then Etype (Priv_T) /= Etype (Full_T)
+                 and then Etype (Priv_T) /= Iface
+               then
+                  Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
+                               "completed by a type that implements an " &
+                               "interface", Priv_T);
+               end if;
 
-            --  The full view derives from a limited, protected,
-            --  synchronized or task interface descendant, but the
-            --  partial view is not labeled as limited.
+               --  The full view derives from a limited, protected,
+               --  synchronized or task interface descendant, but the
+               --  partial view is not labeled as limited.
 
-            if Present (Iface)
-              and then (Limited_Present      (Iface_Def)
-                     or Protected_Present    (Iface_Def)
-                     or Synchronized_Present (Iface_Def)
-                     or Task_Present         (Iface_Def))
-              and then not Limited_Present (Parent (Priv_T))
-            then
-               Error_Msg_N ("(Ada 2005) non-limited private type cannot be " &
-                            "completed by a limited type", Priv_T);
+               if (Limited_Present               (Iface_Def)
+                    or else Protected_Present    (Iface_Def)
+                    or else Synchronized_Present (Iface_Def)
+                    or else Task_Present         (Iface_Def))
+                 and then not Limited_Present (Parent (Priv_T))
+               then
+                  Error_Msg_N ("(Ada 2005) non-limited private type cannot be "
+                               & "completed by a limited type", Priv_T);
+               end if;
             end if;
          end;
       end if;
@@ -13242,24 +13329,9 @@ package body Sem_Ch3 is
             return;
 
          elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
-
-            --  Ada 2005 (AI-251): No error needed if the immediate
-            --  ancestor of the partial view is an interface
-            --
-            --  Example:
-            --
-            --       type PT1 is new I1 with private;
-            --    private
-            --       type PT1 is new T and I1 with null record;
-
-            if Is_Interface (Base_Type (Priv_Parent)) then
-               null;
-
-            else
-               Error_Msg_N
-                 ("parent of full type must descend from parent"
-                     & " of private extension", Full_Indic);
-            end if;
+            Error_Msg_N
+              ("parent of full type must descend from parent"
+                  & " of private extension", Full_Indic);
 
          --  Check the rules of 7.3(10): if the private extension inherits
          --  known discriminants, then the full type must also inherit those
@@ -14409,17 +14481,7 @@ package body Sem_Ch3 is
 
       else
          Is_Tagged := True;
-         Set_Is_Tagged_Type      (T);
-
-         Set_Is_Limited_Record   (T, Limited_Present (Def)
-                                      or else Task_Present (Def)
-                                      or else Protected_Present (Def));
-
-         --  Type is abstract if full declaration carries keyword, or if
-         --  previous partial view did.
-
-         Set_Is_Abstract  (T);
-         Set_Is_Interface (T);
+         Analyze_Interface_Declaration (T, Def);
       end if;
 
       --  First pass: if there are self-referential access components,
@@ -14428,10 +14490,6 @@ package body Sem_Ch3 is
 
       Check_Anonymous_Access_Types (Component_List (Def));
 
-      --  Ada 2005 (AI-251): Complete the initialization of attributes
-      --  associated with abstract interfaces and decorate the names in the
-      --  list of ancestor interfaces (if any).
-
       if Ada_Version >= Ada_05
         and then Present (Interface_List (Def))
       then
@@ -14439,6 +14497,7 @@ package body Sem_Ch3 is
             Iface     : Node_Id;
             Iface_Def : Node_Id;
             Iface_Typ : Entity_Id;
+
          begin
             Iface := First (Interface_List (Def));
             while Present (Iface) loop
@@ -14521,9 +14580,8 @@ package body Sem_Ch3 is
 
                Next (Iface);
             end loop;
-
             Set_Abstract_Interfaces (T, New_Elmt_List);
-            Collect_Interfaces (Type_Definition (N), T);
+            Collect_Interfaces (Def, T);
          end;
       end if;
 
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 608666d18e6..95354d60b27 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -62,6 +62,9 @@ package Sem_Ch3  is
    --  Called to analyze a list of declarations (in what context ???). Also
    --  performs necessary freezing actions (more description needed ???)
 
+   procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id);
+   --  Analyze an interface declaration or a formal interface declaration
+
    procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id);
    --  Default and per object expressions do not freeze their components,
    --  and must be analyzed and resolved accordingly. The analysis is
@@ -97,6 +100,15 @@ package Sem_Ch3  is
    --  rather than on the declarations that require completion in the package
    --  declaration.
 
+   procedure Collect_Interfaces
+     (N            : Node_Id;
+      Derived_Type : Entity_Id);
+   --  Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type
+   --  and Analyze_Formal_Interface_Type.
+   --  Collect the list of interfaces that are not already implemented by the
+   --  ancestors. This is the list of interfaces for which we must provide
+   --  additional tag components.
+
    procedure Derive_Subprogram
      (New_Subp     : in out Entity_Id;
       Parent_Subp  : Entity_Id;
@@ -114,8 +126,7 @@ package Sem_Ch3  is
      (Parent_Type           : Entity_Id;
       Derived_Type          : Entity_Id;
       Generic_Actual        : Entity_Id := Empty;
-      No_Predefined_Prims   : Boolean   := False;
-      Predefined_Prims_Only : Boolean   := False);
+      No_Predefined_Prims   : Boolean   := False);
    --  To complete type derivation, collect/retrieve the primitive operations
    --  of the parent type, and replace the subsidiary subtypes with the derived
    --  type, to build the specs of the inherited ops. For generic actuals, the
@@ -124,9 +135,7 @@ package Sem_Ch3  is
    --  the derived subprograms are aliased to those of the actual, not those of
    --  the ancestor. The last two params are used in case of derivation from
    --  abstract interface types: No_Predefined_Prims is used to avoid the
-   --  derivation of predefined primitives from the interface, and Predefined
-   --  Prims_Only is used to complete the derivation predefined primitives
-   --  in case of private tagged types implementing interfaces.
+   --  derivation of predefined primitives from an abstract interface.
    --
    --  Note: one might expect this to be private to the package body, but
    --  there is one rather unusual usage in package Exp_Dist.