2009-07-13 Emmanuel Briot <briot@adacore.com>

	* prj-err.adb (Error_Msg): One more case where a message should be
	considered as a warning.

	* gnatcmd.adb (GNATCmd): Fix previous change, which negated a test.

2009-07-13  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze
	calling stubs in the (library level) scope of the RCI locator, where it
	is attached, not in the caller's scope.

2009-07-13  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide
	interface object declarations we delay the generation of the equivalent
	record type declarations until its expansion because there are cases in
	which they are not required.            

	* sem_util.adb (Implements_Interface): Add missing support for subtypes.

	* sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus
	addition of assertion.

	* exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide
	interface types require no equivalent constrained type declarations
	because the expanded code only references the tag component associated
	with the interface.
	(Find_Interface_Tag): Improve management of interfaces that are
	ancestors of tagged types.

	* exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of
	class-wide object declarations to add missing support to statically
	displace the pointer to the object to reference the tag component
	associated with the interface.

	* exp_disp.adb (Make_Tags) Avoid generation of internally generated
	auxiliary types associated with user-defined dispatching calls if the
	type has no user-defined primitives.



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

10 files changed, 420 insertions, 295 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7975955fccc..ac910fde2ea 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,44 @@
+2009-07-13  Emmanuel Briot  <briot@adacore.com>
+
+	* prj-err.adb (Error_Msg): One more case where a message should be
+	considered as a warning.
+
+	* gnatcmd.adb (GNATCmd): Fix previous change, which negated a test.
+
+2009-07-13  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze
+	calling stubs in the (library level) scope of the RCI locator, where it
+	is attached, not in the caller's scope.
+
+2009-07-13  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide
+	interface object declarations we delay the generation of the equivalent
+	record type declarations until its expansion because there are cases in
+	which they are not required.            
+
+	* sem_util.adb (Implements_Interface): Add missing support for subtypes.
+
+	* sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus
+	addition of assertion.
+
+	* exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide
+	interface types require no equivalent constrained type declarations
+	because the expanded code only references the tag component associated
+	with the interface.
+	(Find_Interface_Tag): Improve management of interfaces that are
+	ancestors of tagged types.
+
+	* exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of
+	class-wide object declarations to add missing support to statically
+	displace the pointer to the object to reference the tag component
+	associated with the interface.
+
+	* exp_disp.adb (Make_Tags) Avoid generation of internally generated
+	auxiliary types associated with user-defined dispatching calls if the
+	type has no user-defined primitives.
+
 2009-07-13  Vasiliy Fofanov  <fofanov@adacore.com>
 
 	* mingw32.h: Make it explicit that we need XP or later.
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index d33698d55ec..92bcc03bdab 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4497,6 +4497,196 @@ package body Exp_Ch3 is
 
             return;
 
+         --  Ada 2005 (AI-251): Rewrite the expression that initializes a
+         --  class-wide object to ensure that we copy the full object,
+         --  unless we are targetting a VM where interfaces are handled by
+         --  VM itself. Note that if the root type of Typ is an ancestor
+         --  of Expr's type, both types share the same dispatch table and
+         --  there is no need to displace the pointer.
+
+         elsif Comes_From_Source (N)
+           and then Is_Interface (Typ)
+         then
+            pragma Assert (Is_Class_Wide_Type (Typ));
+
+            if Tagged_Type_Expansion then
+               declare
+                  Iface    : constant Entity_Id := Root_Type (Typ);
+                  Expr_N   : Node_Id := Expr;
+                  Expr_Typ : Entity_Id;
+
+                  Decl_1   : Node_Id;
+                  Decl_2   : Node_Id;
+                  New_Expr : Node_Id;
+
+               begin
+                  --  If the original node of the expression was a conversion
+                  --  to this specific class-wide interface type then we
+                  --  restore the original node to generate code that
+                  --  statically displaces the pointer to the interface
+                  --  component.
+
+                  if not Comes_From_Source (Expr_N)
+                    and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+                    and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+                    and then Etype (Original_Node (Expr_N)) = Typ
+                  then
+                     Rewrite (Expr_N, Original_Node (Expression (N)));
+                  end if;
+
+                  --  Avoid expansion of redundant interface conversion
+
+                  if Is_Interface (Etype (Expr_N))
+                    and then Nkind (Expr_N) = N_Type_Conversion
+                    and then Etype (Expr_N) = Typ
+                  then
+                     Expr_N := Expression (Expr_N);
+                     Set_Expression (N, Expr_N);
+                  end if;
+
+                  Expr_Typ := Base_Type (Etype (Expr_N));
+
+                  if Is_Class_Wide_Type (Expr_Typ) then
+                     Expr_Typ := Root_Type (Expr_Typ);
+                  end if;
+
+                  --  Replace
+                  --     CW : I'Class := Obj;
+                  --  by
+                  --     Tmp : T := Obj;
+                  --     CW  : I'Class renames TiC!(Tmp.I_Tag);
+
+                  if Comes_From_Source (Expr_N)
+                    and then Nkind (Expr_N) = N_Identifier
+                    and then not Is_Interface (Expr_Typ)
+                    and then (Expr_Typ = Etype (Expr_Typ)
+                               or else not
+                              Is_Variable_Size_Record (Etype (Expr_Typ)))
+                  then
+                     Decl_1 :=
+                       Make_Object_Declaration (Loc,
+                         Defining_Identifier =>
+                           Make_Defining_Identifier (Loc,
+                             New_Internal_Name ('D')),
+                         Object_Definition =>
+                           New_Occurrence_Of (Expr_Typ, Loc),
+                         Expression =>
+                           Unchecked_Convert_To (Expr_Typ,
+                             Relocate_Node (Expr_N)));
+
+                     --  Statically reference the tag associated with the
+                     --  interface
+
+                     Decl_2 :=
+                       Make_Object_Renaming_Declaration (Loc,
+                         Defining_Identifier =>
+                           Make_Defining_Identifier (Loc,
+                             New_Internal_Name ('D')),
+                         Subtype_Mark =>
+                           New_Occurrence_Of (Typ, Loc),
+                         Name =>
+                           Unchecked_Convert_To (Typ,
+                             Make_Selected_Component (Loc,
+                               Prefix =>
+                                 New_Occurrence_Of
+                                   (Defining_Identifier (Decl_1), Loc),
+                               Selector_Name =>
+                                 New_Reference_To
+                                   (Find_Interface_Tag (Expr_Typ, Iface),
+                                    Loc))));
+
+                  --  General case:
+
+                  --  Replace
+                  --     IW : I'Class := Obj;
+                  --  by
+                  --     type Equiv_Record is record ... end record;
+                  --     implicit subtype CW is <Class_Wide_Subtype>;
+                  --     Temp : CW := CW!(Obj'Address);
+                  --     IW : I'Class renames Displace (Temp, I'Tag);
+
+                  else
+                     --  Generate the equivalent record type
+
+                     Expand_Subtype_From_Expr
+                       (N             => N,
+                        Unc_Type      => Typ,
+                        Subtype_Indic => Object_Definition (N),
+                        Exp           => Expression (N));
+
+                     if not Is_Interface (Etype (Expression (N))) then
+                        New_Expr := Relocate_Node (Expression (N));
+                     else
+                        New_Expr :=
+                          Make_Explicit_Dereference (Loc,
+                            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                              Make_Attribute_Reference (Loc,
+                                Prefix => Relocate_Node (Expression (N)),
+                                Attribute_Name => Name_Address)));
+                     end if;
+
+                     Decl_1 :=
+                       Make_Object_Declaration (Loc,
+                         Defining_Identifier =>
+                           Make_Defining_Identifier (Loc,
+                             New_Internal_Name ('D')),
+                         Object_Definition =>
+                           New_Occurrence_Of
+                            (Etype (Object_Definition (N)), Loc),
+                         Expression =>
+                           Unchecked_Convert_To
+                             (Etype (Object_Definition (N)), New_Expr));
+
+                     Decl_2 :=
+                       Make_Object_Renaming_Declaration (Loc,
+                         Defining_Identifier =>
+                           Make_Defining_Identifier (Loc,
+                             New_Internal_Name ('D')),
+                         Subtype_Mark =>
+                           New_Occurrence_Of (Typ, Loc),
+                         Name =>
+                           Unchecked_Convert_To (Typ,
+                             Make_Explicit_Dereference (Loc,
+                               Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                                 Make_Function_Call (Loc,
+                                   Name =>
+                                     New_Reference_To (RTE (RE_Displace), Loc),
+                                   Parameter_Associations => New_List (
+                                     Make_Attribute_Reference (Loc,
+                                       Prefix =>
+                                         New_Occurrence_Of
+                                          (Defining_Identifier (Decl_1), Loc),
+                                       Attribute_Name => Name_Address),
+
+                                     Unchecked_Convert_To (RTE (RE_Tag),
+                                       New_Reference_To
+                                         (Node
+                                           (First_Elmt
+                                             (Access_Disp_Table (Iface))),
+                                          Loc))))))));
+                  end if;
+
+                  Insert_Action (N, Decl_1);
+                  Rewrite (N, Decl_2);
+                  Analyze (N);
+
+                  --  Replace internal identifier of Decl_2 by the identifier
+                  --  found in the sources. We also have to exchange entities
+                  --  containing their defining identifiers to ensure the
+                  --  correct replacement of the object declaration by this
+                  --  object renaming declaration (because such definings
+                  --  identifier have been previously added by Enter_Name to
+                  --  the current scope). We must preserve the homonym chain
+                  --  of the source entity as well.
+
+                  Set_Chars (Defining_Identifier (N), Chars (Def_Id));
+                  Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
+                  Exchange_Entities (Defining_Identifier (N), Def_Id);
+               end;
+            end if;
+
+            return;
+
          else
             --  In most cases, we must check that the initial value meets any
             --  constraint imposed by the declared type. However, there is one
@@ -4530,119 +4720,6 @@ package body Exp_Ch3 is
                end if;
             end if;
 
-            --  Ada 2005 (AI-251): Rewrite the expression that initializes a
-            --  class-wide object to ensure that we copy the full object,
-            --  unless we are targetting a VM where interfaces are handled by
-            --  VM itself. Note that if the root type of Typ is an ancestor
-            --  of Expr's type, both types share the same dispatch table and
-            --  there is no need to displace the pointer.
-
-            --  Replace
-            --     CW : I'Class := Obj;
-            --  by
-            --     Temp : I'Class := I'Class (Base_Address (Obj'Address));
-            --     CW   : I'Class renames Displace (Temp, I'Tag);
-
-            if Is_Interface (Typ)
-              and then Is_Class_Wide_Type (Typ)
-              and then
-                (Is_Class_Wide_Type (Etype (Expr))
-                   or else
-                     not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
-              and then Comes_From_Source (Def_Id)
-              and then Tagged_Type_Expansion
-            then
-               declare
-                  Decl_1 : Node_Id;
-                  Decl_2 : Node_Id;
-
-               begin
-                  Decl_1 :=
-                    Make_Object_Declaration (Loc,
-                      Defining_Identifier =>
-                        Make_Defining_Identifier (Loc,
-                          New_Internal_Name ('D')),
-
-                      Object_Definition =>
-                        Make_Attribute_Reference (Loc,
-                          Prefix =>
-                            New_Occurrence_Of
-                              (Root_Type (Etype (Def_Id)), Loc),
-                          Attribute_Name => Name_Class),
-
-                      Expression =>
-                        Unchecked_Convert_To
-                          (Class_Wide_Type (Root_Type (Etype (Def_Id))),
-                            Make_Explicit_Dereference (Loc,
-                              Unchecked_Convert_To (RTE (RE_Tag_Ptr),
-                                Make_Function_Call (Loc,
-                                  Name =>
-                                    New_Reference_To (RTE (RE_Base_Address),
-                                                      Loc),
-                                  Parameter_Associations => New_List (
-                                    Make_Attribute_Reference (Loc,
-                                      Prefix         => Relocate_Node (Expr),
-                                      Attribute_Name => Name_Address)))))));
-
-                  Insert_Action (N, Decl_1);
-
-                  Decl_2 :=
-                    Make_Object_Renaming_Declaration (Loc,
-                      Defining_Identifier =>
-                        Make_Defining_Identifier (Loc,
-                          New_Internal_Name ('D')),
-
-                      Subtype_Mark =>
-                        Make_Attribute_Reference (Loc,
-                          Prefix =>
-                            New_Occurrence_Of
-                              (Root_Type (Etype (Def_Id)), Loc),
-                          Attribute_Name => Name_Class),
-
-                      Name =>
-                        Unchecked_Convert_To (
-                          Class_Wide_Type (Root_Type (Etype (Def_Id))),
-                          Make_Explicit_Dereference (Loc,
-                            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
-                              Make_Function_Call (Loc,
-                                Name =>
-                                  New_Reference_To (RTE (RE_Displace), Loc),
-
-                                Parameter_Associations => New_List (
-                                  Make_Attribute_Reference (Loc,
-                                    Prefix =>
-                                      New_Reference_To
-                                        (Defining_Identifier (Decl_1), Loc),
-                                    Attribute_Name => Name_Address),
-
-                                  Unchecked_Convert_To (RTE (RE_Tag),
-                                    New_Reference_To
-                                      (Node
-                                        (First_Elmt
-                                          (Access_Disp_Table
-                                             (Root_Type (Typ)))),
-                                       Loc))))))));
-
-                  Rewrite (N, Decl_2);
-                  Analyze (N);
-
-                  --  Replace internal identifier of Decl_2 by the identifier
-                  --  found in the sources. We also have to exchange entities
-                  --  containing their defining identifiers to ensure the
-                  --  correct replacement of the object declaration by this
-                  --  object renaming declaration (because such definings
-                  --  identifier have been previously added by Enter_Name to
-                  --  the current scope). We must preserve the homonym chain
-                  --  of the source entity as well.
-
-                  Set_Chars (Defining_Identifier (N), Chars (Def_Id));
-                  Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
-                  Exchange_Entities (Defining_Identifier (N), Def_Id);
-
-                  return;
-               end;
-            end if;
-
             --  If the type is controlled and not inherently limited, then
             --  the target is adjusted after the copy and attached to the
             --  finalization list. However, no adjustment is done in the case
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 54f66919cb8..99f918b7477 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6118,64 +6118,71 @@ package body Exp_Disp is
          end loop;
       end if;
 
-      --  3) At the end of Access_Disp_Table we add the entity of an access
-      --     type declaration. It is used by Build_Get_Prim_Op_Address to
-      --     expand dispatching calls through the primary dispatch table.
+      --  3) At the end of Access_Disp_Table, if the type has user-defined
+      --     primitives, we add the entity of an access type declaration that
+      --     is used by Build_Get_Prim_Op_Address to expand dispatching calls
+      --     through the primary dispatch table.
+
+      if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
+         Analyze_List (Result);
 
       --     Generate:
       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
       --       type Typ_DT_Acc is access Typ_DT;
 
-      declare
-         Name_DT_Prims     : constant Name_Id :=
-                               New_External_Name (Tname, 'G');
-         Name_DT_Prims_Acc : constant Name_Id :=
-                               New_External_Name (Tname, 'H');
-         DT_Prims          : constant Entity_Id :=
-                               Make_Defining_Identifier (Loc, Name_DT_Prims);
-         DT_Prims_Acc      : constant Entity_Id :=
-                               Make_Defining_Identifier (Loc,
-                                 Name_DT_Prims_Acc);
-      begin
-         Append_To (Result,
-           Make_Full_Type_Declaration (Loc,
-             Defining_Identifier => DT_Prims,
-             Type_Definition =>
-               Make_Constrained_Array_Definition (Loc,
-                 Discrete_Subtype_Definitions => New_List (
-                   Make_Range (Loc,
-                     Low_Bound  => Make_Integer_Literal (Loc, 1),
-                     High_Bound => Make_Integer_Literal (Loc,
-                                    DT_Entry_Count
-                                      (First_Tag_Component (Typ))))),
-                 Component_Definition =>
-                   Make_Component_Definition (Loc,
-                     Subtype_Indication =>
-                       New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
+      else
+         declare
+            Name_DT_Prims     : constant Name_Id :=
+                                  New_External_Name (Tname, 'G');
+            Name_DT_Prims_Acc : constant Name_Id :=
+                                  New_External_Name (Tname, 'H');
+            DT_Prims          : constant Entity_Id :=
+                                  Make_Defining_Identifier (Loc,
+                                    Name_DT_Prims);
+            DT_Prims_Acc      : constant Entity_Id :=
+                                  Make_Defining_Identifier (Loc,
+                                    Name_DT_Prims_Acc);
+         begin
+            Append_To (Result,
+              Make_Full_Type_Declaration (Loc,
+                Defining_Identifier => DT_Prims,
+                Type_Definition =>
+                  Make_Constrained_Array_Definition (Loc,
+                    Discrete_Subtype_Definitions => New_List (
+                      Make_Range (Loc,
+                        Low_Bound  => Make_Integer_Literal (Loc, 1),
+                        High_Bound => Make_Integer_Literal (Loc,
+                                       DT_Entry_Count
+                                         (First_Tag_Component (Typ))))),
+                    Component_Definition =>
+                      Make_Component_Definition (Loc,
+                        Subtype_Indication =>
+                          New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
 
-         Append_To (Result,
-           Make_Full_Type_Declaration (Loc,
-             Defining_Identifier => DT_Prims_Acc,
-             Type_Definition =>
-                Make_Access_To_Object_Definition (Loc,
-                  Subtype_Indication =>
-                    New_Occurrence_Of (DT_Prims, Loc))));
+            Append_To (Result,
+              Make_Full_Type_Declaration (Loc,
+                Defining_Identifier => DT_Prims_Acc,
+                Type_Definition =>
+                   Make_Access_To_Object_Definition (Loc,
+                     Subtype_Indication =>
+                       New_Occurrence_Of (DT_Prims, Loc))));
 
-         Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
+            Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
 
-         --  Analyze the resulting list and suppress the generation of the
-         --  Init_Proc associated with the above array declaration because
-         --  we never use such type in object declarations; this type is only
-         --  used to simplify the expansion associated with dispatching calls.
+            --  Analyze the resulting list and suppress the generation of the
+            --  Init_Proc associated with the above array declaration because
+            --  this type is never used in object declarations. It is only used
+            --  to simplify the expansion associated with dispatching calls.
 
-         Analyze_List (Result);
-         Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+            Analyze_List (Result);
+            Set_Suppress_Init_Proc (Base_Type (DT_Prims));
 
-         --  Mark entity of dispatch table. Required by the backend to handle
-         --  the properly.
+            --  Mark entity of dispatch table. Required by the back end to
+            --  handle them properly.
 
-         Set_Is_Dispatch_Table_Entity (DT_Prims);
-      end;
+            Set_Is_Dispatch_Table_Entity (DT_Prims);
+         end;
+      end if;
 
       Set_Ekind        (DT_Ptr, E_Constant);
       Set_Is_Tag       (DT_Ptr);
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index f13c8a45eef..d975657f4a1 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -2755,11 +2755,11 @@ package body Exp_Dist is
    ---------------------------------------------
 
    procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
+      Loc               : constant Source_Ptr := Sloc (N);
       Called_Subprogram : constant Entity_Id  := Entity (Name (N));
       RCI_Package       : constant Entity_Id  := Scope (Called_Subprogram);
-      Loc               : constant Source_Ptr := Sloc (N);
-      RCI_Locator       : Node_Id;
-      RCI_Cache         : Entity_Id;
+      RCI_Locator_Decl  : Node_Id;
+      RCI_Locator       : Entity_Id;
       Calling_Stubs     : Node_Id;
       E_Calling_Stubs   : Entity_Id;
 
@@ -2767,41 +2767,35 @@ package body Exp_Dist is
       E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
 
       if E_Calling_Stubs = Empty then
-         RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
-
-         if RCI_Cache = Empty then
-            RCI_Locator :=
-              RCI_Package_Locator
-                (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
-            Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
-
-            --  The RCI_Locator package is inserted at the top level in the
-            --  current unit, and must appear in the proper scope, so that it
-            --  is not prematurely removed by the GCC back-end.
+         RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
 
-            declare
-               Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
-
-            begin
-               if Ekind (Scop) = E_Package_Body then
-                  Push_Scope (Spec_Entity (Scop));
+         --  The RCI_Locator package and calling stub are is inserted at the
+         --  top level in the current unit, and must appear in the proper scope
+         --  so that it is not prematurely removed by the GCC back end.
 
-               elsif Ekind (Scop) = E_Subprogram_Body then
-                  Push_Scope
-                     (Corresponding_Spec (Unit_Declaration_Node (Scop)));
-
-               else
-                  Push_Scope (Scop);
-               end if;
-
-               Analyze (RCI_Locator);
-               Pop_Scope;
-            end;
+         declare
+            Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+         begin
+            if Ekind (Scop) = E_Package_Body then
+               Push_Scope (Spec_Entity (Scop));
+            elsif Ekind (Scop) = E_Subprogram_Body then
+               Push_Scope
+                 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+            else
+               Push_Scope (Scop);
+            end if;
+         end;
 
-            RCI_Cache   := Defining_Unit_Name (RCI_Locator);
+         if RCI_Locator = Empty then
+            RCI_Locator_Decl :=
+              RCI_Package_Locator
+                (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+            Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
+            Analyze (RCI_Locator_Decl);
+            RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
 
          else
-            RCI_Locator := Parent (RCI_Cache);
+            RCI_Locator_Decl := Parent (RCI_Locator);
          end if;
 
          Calling_Stubs := Build_Subprogram_Calling_Stubs
@@ -2811,10 +2805,12 @@ package body Exp_Dist is
             Asynchronous           => Nkind (N) = N_Procedure_Call_Statement
                                         and then
                                       Is_Asynchronous (Called_Subprogram),
-            Locator                => RCI_Cache,
+            Locator                => RCI_Locator,
             New_Name               => New_Internal_Name ('S'));
-         Insert_After (RCI_Locator, Calling_Stubs);
+         Insert_After (RCI_Locator_Decl, Calling_Stubs);
          Analyze (Calling_Stubs);
+         Pop_Scope;
+
          E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
       end if;
 
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 21183b2109e..e8a1fdd3dbc 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1350,6 +1350,17 @@ package body Exp_Util is
               Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
          end if;
 
+      --  Renamings of class-wide interface types require no equivalent
+      --  constrained type declarations because we only need to reference
+      --  the tag component associated with the interface.
+
+      elsif Present (N)
+        and then Nkind (N) = N_Object_Renaming_Declaration
+        and then Is_Interface (Unc_Type)
+      then
+         pragma Assert (Is_Class_Wide_Type (Unc_Type));
+         null;
+
       --  In Ada95, nothing to be done if the type of the expression is
       --  limited, because in this case the expression cannot be copied,
       --  and its use can only be by reference.
@@ -1371,16 +1382,6 @@ package body Exp_Util is
       then
          null;
 
-      --  For limited interfaces, nothing to be done
-
-      --  This branch may be redundant once the limited interface issue is
-      --  sorted out???
-
-      elsif Is_Interface (Exp_Typ)
-        and then Is_Limited_Interface (Exp_Typ)
-      then
-         null;
-
       --  For limited objects initialized with build in place function calls,
       --  nothing to be done; otherwise we prematurely introduce an N_Reference
       --  node in the expression initializing the object, which breaks the
@@ -1546,15 +1547,10 @@ package body Exp_Util is
          AI      : Node_Id;
 
       begin
-         --  Check if the interface is an immediate ancestor of the type and
-         --  therefore shares the main tag.
+         --  This routine does not handle the case in which the interface is an
+         --  ancestor of Typ. That case is handled by the enclosing subprogram.
 
-         if Typ = Iface then
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-            AI_Tag := First_Tag_Component (Typ);
-            Found  := True;
-            return;
-         end if;
+         pragma Assert (Typ /= Iface);
 
          --  Climb to the root type handling private types
 
@@ -1632,9 +1628,20 @@ package body Exp_Util is
          Typ := Corresponding_Record_Type (Typ);
       end if;
 
-      Find_Tag (Typ);
-      pragma Assert (Found);
-      return AI_Tag;
+      --  If the interface is an ancestor of the type, then it shared the
+      --  primary dispatch table.
+
+      if Is_Ancestor (Iface, Typ) then
+         pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+         return First_Tag_Component (Typ);
+
+      --  Otherwise we need to search for its associated tag component
+
+      else
+         Find_Tag (Typ);
+         pragma Assert (Found);
+         return AI_Tag;
+      end if;
    end Find_Interface_Tag;
 
    ------------------
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index fabf31ecaca..c3ec70c241a 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -2117,16 +2117,16 @@ begin
                   end if;
                end loop;
 
-               --  If the naming scheme of the project file is not standard,
-               --  and if the file name ends with the spec suffix, then
-               --  indicate to gnatstub the name of the body file with
-               --  a -o switch.
+               --  If the project file naming scheme is not standard, and if
+               --  the file name ends with the spec suffix, then indicate to
+               --  gnatstub the name of the body file with a -o switch.
 
-               if Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
+               if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
                   if File_Index /= 0 then
                      declare
                         Spec : constant String :=
-                          Base_Name (Last_Switches.Table (File_Index).all);
+                                 Base_Name
+                                   (Last_Switches.Table (File_Index).all);
                         Last : Natural := Spec'Last;
 
                      begin
@@ -2193,8 +2193,7 @@ begin
          end if;
 
          --  For gnat check, -rules and the following switches need to be the
-         --  last options. So, we move all these switches to table
-         --  Rules_Switches.
+         --  last options, so move all these switches to table Rules_Switches.
 
          if The_Command = Check then
             declare
diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb
index abe4224f098..c0fa09b220c 100644
--- a/gcc/ada/prj-err.adb
+++ b/gcc/ada/prj-err.adb
@@ -113,7 +113,9 @@ package body Prj.Err is
       --  Let the application know there was an error
 
       if Flags.Report_Error /= null then
-         Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?');
+         Flags.Report_Error
+           (Project,
+            Is_Warning => Msg (Msg'First) = '?' or Msg (Msg'First) = '<');
       end if;
    end Error_Msg;
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9c289e75136..00c40e7677b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -590,8 +590,8 @@ package body Sem_Ch3 is
 
    function Is_Progenitor
      (Iface : Entity_Id;
-      Typ   :  Entity_Id) return Boolean;
-   --  Determine whether type Typ implements interface Iface. This requires
+      Typ   : Entity_Id) return Boolean;
+   --  Determine whether the interface Iface is implemented by Typ. It requires
    --  traversing the list of abstract interfaces of the type, as well as that
    --  of the ancestor types. The predicate is used to determine when a formal
    --  in the signature of an inherited operation must carry the derived type.
@@ -2725,6 +2725,13 @@ package body Sem_Ch3 is
             then
                Act_T := Etype (E);
 
+            --  In case of class-wide interface object declarations we delay
+            --  the generation of the equivalent record type declarations until
+            --  its expansion because there are cases in they are not required.
+
+            elsif Is_Interface (T) then
+               null;
+
             else
                Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
                Act_T := Find_Type_Of_Object (Object_Definition (N), N);
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index f64df6f9823..705f428716a 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -105,15 +105,13 @@ package body Sem_Disp is
 
    begin
       Formal := First_Formal (Subp);
-
       while Present (Formal) loop
          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
 
          if Present (Ctrl_Type) then
 
-            --  When the controlling type is concurrent and declared within a
-            --  generic or inside an instance, use its corresponding record
-            --  type.
+            --  When controlling type is concurrent and declared within a
+            --  generic or inside an instance use corresponding record type.
 
             if Is_Concurrent_Type (Ctrl_Type)
               and then Present (Corresponding_Record_Type (Ctrl_Type))
@@ -124,7 +122,7 @@ package body Sem_Disp is
             if Ctrl_Type = Typ then
                Set_Is_Controlling_Formal (Formal);
 
-               --  Ada 2005 (AI-231): Anonymous access types used in
+               --  Ada 2005 (AI-231): Anonymous access types that are used in
                --  controlling parameters exclude null because it is necessary
                --  to read the tag to dispatch, and null has no tag.
 
@@ -178,7 +176,10 @@ package body Sem_Disp is
          Next_Formal (Formal);
       end loop;
 
-      if Present (Etype (Subp)) then
+      if Ekind (Subp) = E_Function
+           or else
+         Ekind (Subp) = E_Generic_Function
+      then
          Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
 
          if Present (Ctrl_Type) then
@@ -426,14 +427,12 @@ package body Sem_Disp is
 
             else
                Par := Parent (N);
-
                while Present (Par) loop
-
-                  if (Nkind (Par) = N_Function_Call            or else
-                      Nkind (Par) = N_Procedure_Call_Statement or else
-                      Nkind (Par) = N_Assignment_Statement     or else
-                      Nkind (Par) = N_Op_Eq                    or else
-                      Nkind (Par) = N_Op_Ne)
+                  if Nkind_In (Par, N_Function_Call,
+                                    N_Procedure_Call_Statement,
+                                    N_Assignment_Statement,
+                                    N_Op_Eq,
+                                    N_Op_Ne)
                     and then Is_Tagged_Type (Etype (Subp))
                   then
                      return;
@@ -471,11 +470,10 @@ package body Sem_Disp is
       --  Find a controlling argument, if any
 
       if Present (Parameter_Associations (N)) then
-         Actual := First_Actual (N);
-
          Subp_Entity := Entity (Name (N));
-         Formal := First_Formal (Subp_Entity);
 
+         Actual := First_Actual (N);
+         Formal := First_Formal (Subp_Entity);
          while Present (Actual) loop
             Control := Find_Controlling_Arg (Actual);
             exit when Present (Control);
@@ -544,7 +542,6 @@ package body Sem_Disp is
             end if;
 
             Actual := First_Actual (N);
-
             while Present (Actual) loop
                if Actual /= Control then
 
@@ -866,7 +863,7 @@ package body Sem_Disp is
          --  If the type is already frozen, the overriding is not allowed
          --  except when Old_Subp is not a dispatching operation (which can
          --  occur when Old_Subp was inherited by an untagged type). However,
-         --  a body with no previous spec freezes the type "after" its
+         --  a body with no previous spec freezes the type *after* its
          --  declaration, and therefore is a legal overriding (unless the type
          --  has already been frozen). Only the first such body is legal.
 
@@ -880,7 +877,7 @@ package body Sem_Disp is
             then
                declare
                   Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
-                  Decl_Item : Node_Id          := Next (Parent (Tagged_Type));
+                  Decl_Item : Node_Id;
 
                begin
                   --  ??? The checks here for whether the type has been
@@ -899,6 +896,7 @@ package body Sem_Disp is
                   --  then the type has been frozen already so the overriding
                   --  primitive is illegal.
 
+                  Decl_Item := Next (Parent (Tagged_Type));
                   while Present (Decl_Item)
                     and then (Decl_Item /= Subp_Body)
                   loop
@@ -1166,8 +1164,10 @@ package body Sem_Disp is
       elsif Has_Controlled_Component (Tagged_Type)
         and then
          (Chars (Subp) = Name_Initialize
-           or else Chars (Subp) = Name_Adjust
-           or else Chars (Subp) = Name_Finalize)
+            or else
+          Chars (Subp) = Name_Adjust
+            or else
+          Chars (Subp) = Name_Finalize)
       then
          declare
             F_Node   : constant Node_Id := Freeze_Node (Tagged_Type);
@@ -1187,13 +1187,13 @@ package body Sem_Disp is
                          TSS_Deep_Finalize);
 
          begin
-            --  Remove previous controlled function, which was constructed
-            --  and analyzed when the type was frozen. This requires
-            --  removing the body of the redefined primitive, as well as
-            --  its specification if needed (there is no spec created for
-            --  Deep_Initialize, see exp_ch3.adb). We must also dismantle
-            --  the exception information that may have been generated for
-            --  it when front end zero-cost tables are enabled.
+            --  Remove previous controlled function which was constructed and
+            --  analyzed when the type was frozen. This requires removing the
+            --  body of the redefined primitive, as well as its specification
+            --  if needed (there is no spec created for Deep_Initialize, see
+            --  exp_ch3.adb). We must also dismantle the exception information
+            --  that may have been generated for it when front end zero-cost
+            --  tables are enabled.
 
             for J in D_Names'Range loop
                Old_P := TSS (Tagged_Type, D_Names (J));
@@ -1217,9 +1217,9 @@ package body Sem_Disp is
 
             Build_Late_Proc (Tagged_Type, Chars (Subp));
 
-            --  The new operation is added to the actions of the freeze
-            --  node for the type, but this node has already been analyzed,
-            --  so we must retrieve and analyze explicitly the new body.
+            --  The new operation is added to the actions of the freeze node
+            --  for the type, but this node has already been analyzed, so we
+            --  must retrieve and analyze explicitly the new body.
 
             if Present (F_Node)
               and then Present (Actions (F_Node))
@@ -1264,14 +1264,10 @@ package body Sem_Disp is
 
          F1 := First_Formal (Proc);
          F2 := First_Formal (Subp);
-
          while Present (F1) and then Present (F2) loop
-
             if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
-
                if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
                   return False;
-
                elsif Designated_Type (Etype (F1)) = Parent_Typ
                  and then Designated_Type (Etype (F2)) /= Full
                then
@@ -1304,11 +1300,8 @@ package body Sem_Disp is
 
       Op1 := First_Elmt (Old_Prim);
       Op2 := First_Elmt (New_Prim);
-
       while Present (Op1) and then Present (Op2) loop
-
          if Derives_From (Node (Op1)) then
-
             if No (Prev) then
 
                --  Avoid adding it to the list of primitives if already there!
@@ -1371,6 +1364,7 @@ package body Sem_Disp is
                then
                   declare
                      Formal : Entity_Id;
+
                   begin
                      Formal := First_Formal (Old_Subp);
                      while Present (Formal) loop
@@ -1397,8 +1391,8 @@ package body Sem_Disp is
             --  Otherwise, update its alias and other attributes.
 
             if Present (Alias (Old_Subp))
-              and then Nkind (Unit_Declaration_Node (Old_Subp))
-                /= N_Subprogram_Renaming_Declaration
+              and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
+                                        N_Subprogram_Renaming_Declaration
             then
                Set_Alias (Old_Subp, Alias (Subp));
 
@@ -1461,24 +1455,22 @@ package body Sem_Disp is
          Typ := Etype (N);
 
          if Is_Access_Type (Typ) then
-            --  In the case of an Access attribute, use the type of
-            --  the prefix, since in the case of an actual for an
-            --  access parameter, the attribute's type may be of a
-            --  specific designated type, even though the prefix
-            --  type is class-wide.
+
+            --  In the case of an Access attribute, use the type of the prefix,
+            --  since in the case of an actual for an access parameter, the
+            --  attribute's type may be of a specific designated type, even
+            --  though the prefix type is class-wide.
 
             if Nkind (N) = N_Attribute_Reference then
                Typ := Etype (Prefix (N));
 
-            --  An allocator is dispatching if the type of qualified
-            --  expression is class_wide, in which case this is the
-            --  controlling type.
+            --  An allocator is dispatching if the type of qualified expression
+            --  is class_wide, in which case this is the controlling type.
 
             elsif Nkind (Orig_Node) = N_Allocator
                and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
             then
                Typ := Etype (Expression (Orig_Node));
-
             else
                Typ := Designated_Type (Typ);
             end if;
@@ -1560,6 +1552,7 @@ package body Sem_Disp is
          end if;
       end if;
 
+      pragma Assert (not Is_Dispatching_Operation (Subp));
       return Empty;
    end Find_Dispatching_Type;
 
@@ -1800,9 +1793,9 @@ package body Sem_Disp is
       elsif Nkind (Actual) = N_Identifier
         and then Nkind (Original_Node (Actual)) = N_Function_Call
       then
-         --  Call rewritten as object declaration when stack-checking
-         --  is enabled. Propagate tag to expression in declaration, which
-         --  is original call.
+         --  Call rewritten as object declaration when stack-checking is
+         --  enabled. Propagate tag to expression in declaration, which is
+         --  original call.
 
          Call_Node := Expression (Parent (Entity (Actual)));
 
@@ -1823,8 +1816,8 @@ package body Sem_Disp is
          Call_Node := Expression (Actual);
       end if;
 
-      --  Do not set the Controlling_Argument if already set. This happens
-      --  in the special case of _Input (see Exp_Attr, case Input).
+      --  Do not set the Controlling_Argument if already set. This happens in
+      --  the special case of _Input (see Exp_Attr, case Input).
 
       if No (Controlling_Argument (Call_Node)) then
          Set_Controlling_Argument (Call_Node, Control);
@@ -1841,8 +1834,8 @@ package body Sem_Disp is
       end loop;
 
       --  Expansion of dispatching calls is suppressed when VM_Target, because
-      --  the VM back-ends directly handle the generation of dispatching
-      --  calls and would have to undo any expansion to an indirect call.
+      --  the VM back-ends directly handle the generation of dispatching calls
+      --  and would have to undo any expansion to an indirect call.
 
       if Tagged_Type_Expansion then
          Expand_Dispatching_Call (Call_Node);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5ff2d7c0341..2bba1030289 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4937,26 +4937,22 @@ package body Sem_Util is
    is
       Ifaces_List : Elist_Id;
       Elmt        : Elmt_Id;
-      Iface       : Entity_Id;
-      Typ         : Entity_Id;
+      Iface       : Entity_Id := Base_Type (Iface_Ent);
+      Typ         : Entity_Id := Base_Type (Typ_Ent);
 
    begin
-      if Is_Class_Wide_Type (Typ_Ent) then
-         Typ := Etype (Typ_Ent);
-      else
-         Typ := Typ_Ent;
-      end if;
-
-      if Is_Class_Wide_Type (Iface_Ent) then
-         Iface := Etype (Iface_Ent);
-      else
-         Iface := Iface_Ent;
+      if Is_Class_Wide_Type (Typ) then
+         Typ := Root_Type (Typ);
       end if;
 
       if not Has_Interfaces (Typ) then
          return False;
       end if;
 
+      if Is_Class_Wide_Type (Iface) then
+         Iface := Root_Type (Iface);
+      end if;
+
       Collect_Interfaces (Typ, Ifaces_List);
 
       Elmt := First_Elmt (Ifaces_List);