[multiple changes]

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.

From-SVN: r149574

gcc/ada/ChangeLog

+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.

gcc/ada/exp_disp.adb

@@ -6118,21 +6118,27 @@ 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;
 
+      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);
+                                  Make_Defining_Identifier (Loc,
+                                    Name_DT_Prims);
             DT_Prims_Acc      : constant Entity_Id :=
                                   Make_Defining_Identifier (Loc,
                                     Name_DT_Prims_Acc);
@@ -6165,17 +6171,18 @@ package body Exp_Disp is
 
             --  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.
+            --  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));
 
-         --  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;
+      end if;
 
       Set_Ekind        (DT_Ptr, E_Constant);
       Set_Is_Tag       (DT_Ptr);

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);
+         RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
 
-            --  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.
+         --  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.
 
          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;
-
-               Analyze (RCI_Locator);
-               Pop_Scope;
          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;
 

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;
 
+      --  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;
 
    ------------------

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

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;
 

gcc/ada/sem_ch3.adb

@@ -591,7 +591,7 @@ 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
+   --  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);

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);