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

1 files changed, 49 insertions, 56 deletions

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