2005-09-01 Javier Miranda <miranda@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_res.adb (Resolve_Membership_Op): In case of the membership test
	"Iface_CW_Typ in T'Class" we have nothing else to do in the frontend;
	the expander will generate the corresponding run-time check to evaluate
	the expression.
	(Resolve_Call): Check for legal type of procedure name or prefix that
	appears as a trigger in a triggering alternative.
	(Valid_Conversion): If expression is ambiguous and the context involves
	an extension of System, remove System.Address interpretations.
	(Resolve_Qualified_Expression): Reject the case of a specific-type
	qualification applied to a class-wide argument. Enhance comment
	to explain checking of Original_Node.
	(Resolve_Type_Conversion): The location of the error message was not
	general enough to handle the general case and hence it has been removed.
	In addition, this patch improves the text of the message.
	(Resolve_Type_Conversion): Add missing support for access to interface
	types.
	(Resolve_Type_Conversion): If the target is a class-wide interface type,
	do not expand if the expression is the actual in a call, because proper
	expansion will take place when the call itself is expanded.
	(Resolve_Allocator): If the context is an unchecked conversion, the
	allocator inherits its storage pool, if any, from the target type of
	the conversion.


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

1 files changed, 115 insertions, 83 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 285ab115a08..e1e9b7b4ec3 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -244,14 +244,10 @@ package body Sem_Res is
            ("\possible interpretations: Character, Wide_Character!", C);
 
          E := Current_Entity (C);
-
-         if Present (E) then
-
-            while Present (E) loop
-               Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
-               E := Homonym (E);
-            end loop;
-         end if;
+         while Present (E) loop
+            Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
+            E := Homonym (E);
+         end loop;
       end if;
    end Ambiguous_Character;
 
@@ -557,7 +553,6 @@ package body Sem_Res is
       else
          D := PN;
          P := Parent (PN);
-
          while Nkind (P) /= N_Component_Declaration
            and then Nkind (P) /= N_Subtype_Indication
            and then Nkind (P) /= N_Entry_Declaration
@@ -742,9 +737,7 @@ package body Sem_Res is
 
          elsif Is_Record_Type (T) then
             Comp := First_Component (T);
-
             while Present (Comp) loop
-
                if Ekind (Comp) = E_Component
                  and then Nkind (Parent (Comp)) = N_Component_Declaration
                then
@@ -996,9 +989,7 @@ package body Sem_Res is
 
          else
             Get_First_Interp (Nod, I, It);
-
             while Present (It.Typ) loop
-
                if Scope (Base_Type (It.Typ)) = S then
                   return True;
                end if;
@@ -1066,9 +1057,7 @@ package body Sem_Res is
 
          else
             E := First_Entity (Pack);
-
             while Present (E) loop
-
                if Test (E)
                  and then not In_Decl
                then
@@ -1672,10 +1661,9 @@ package body Sem_Res is
       --  is compatible with the context (i.e. the type passed to Resolve)
 
       else
-         Get_First_Interp (N, I, It);
-
          --  Loop through possible interpretations
 
+         Get_First_Interp (N, I, It);
          Interp_Loop : while Present (It.Typ) loop
 
             --  We are only interested in interpretations that are compatible
@@ -1726,10 +1714,11 @@ package body Sem_Res is
                        or else Nkind (N) = N_Procedure_Call_Statement
                      then
                         declare
-                           A : Node_Id := First_Actual (N);
+                           A : Node_Id;
                            E : Node_Id;
 
                         begin
+                           A := First_Actual (N);
                            while Present (A) loop
                               E := A;
 
@@ -2076,10 +2065,9 @@ package body Sem_Res is
 
                      begin
                         Error_Msg_N ("\possible interpretations:", N);
-                        Get_First_Interp (Name (N), Index, It);
 
+                        Get_First_Interp (Name (N), Index, It);
                         while Present (It.Nam) loop
-
                               Error_Msg_Sloc := Sloc (It.Nam);
                               Error_Msg_Node_2 := It.Typ;
                               Error_Msg_NE ("\&  declared#, type&",
@@ -2769,16 +2757,14 @@ package body Sem_Res is
 
                if Ada_Version >= Ada_05
                  and then Is_Access_Type (F_Typ)
-                 and then (Can_Never_Be_Null (F)
-                           or else Can_Never_Be_Null (F_Typ))
+                 and then Can_Never_Be_Null (F_Typ)
+                 and then Nkind (A) = N_Null
                then
-                  if Nkind (A) = N_Null then
-                     Apply_Compile_Time_Constraint_Error
-                       (N      => A,
-                        Msg    => "(Ada 2005) NULL not allowed in "
-                                   & "null-excluding formal?",
-                        Reason => CE_Null_Not_Allowed);
-                  end if;
+                  Apply_Compile_Time_Constraint_Error
+                    (N      => A,
+                     Msg    => "(Ada 2005) NULL not allowed in "
+                               & "null-excluding formal?",
+                     Reason => CE_Null_Not_Allowed);
                end if;
             end if;
 
@@ -3013,7 +2999,6 @@ package body Sem_Res is
             if Has_Discriminants (Subtyp) then
                Discrim := First_Discriminant (Base_Type (Subtyp));
                Constr := First (Constraints (Constraint (Original_Node (E))));
-
                while Present (Discrim) and then Present (Constr) loop
                   if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
                      if Nkind (Constr) = N_Discriminant_Association then
@@ -3104,7 +3089,6 @@ package body Sem_Res is
       if No_Pool_Assigned (Typ) then
          declare
             Loc : constant Source_Ptr := Sloc (N);
-
          begin
             Error_Msg_N ("?allocation from empty storage pool!", N);
             Error_Msg_N ("?Storage_Error will be raised at run time!", N);
@@ -3112,6 +3096,17 @@ package body Sem_Res is
               Make_Raise_Storage_Error (Loc,
                 Reason => SE_Empty_Storage_Pool));
          end;
+
+      --  If the context is an unchecked conversion, as may happen within
+      --  an inlined subprogram, the allocator is being resolved with its
+      --  own anonymous type. In that case, if the target type has a specific
+      --  storage pool, it must be inherited explicitly by the allocator type.
+
+      elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+        and then No (Associated_Storage_Pool (Typ))
+      then
+         Set_Associated_Storage_Pool
+           (Typ, Associated_Storage_Pool (Etype (Parent (N))));
       end if;
    end Resolve_Allocator;
 
@@ -3161,9 +3156,7 @@ package body Sem_Res is
               or else T = Universal_Real;
          else
             Get_First_Interp (N, Index, It);
-
             while Present (It.Typ) loop
-
                if Base_Type (It.Typ) = Base_Type (Standard_Integer)
                  or else It.Typ = Universal_Integer
                  or else It.Typ = Universal_Real
@@ -3251,7 +3244,6 @@ package body Sem_Res is
             --  interpretation or an integer interpretation, but not both.
 
             Get_First_Interp (N, Index, It);
-
             while Present (It.Typ) loop
                if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
 
@@ -3548,9 +3540,9 @@ package body Sem_Res is
             --  return type that is compatible with the context. Analysis of
             --  the node has established that one exists.
 
-            Get_First_Interp (Subp,  I, It);
             Nam := Empty;
 
+            Get_First_Interp (Subp,  I, It);
             while Present (It.Typ) loop
                if Covers (Typ, Etype (It.Typ)) then
                   Nam := It.Typ;
@@ -3609,10 +3601,9 @@ package body Sem_Res is
 
       else
          pragma Assert (Is_Overloaded (Subp));
-         Nam := Empty;  --  We know that it will be assigned in loop below.
+         Nam := Empty;  --  We know that it will be assigned in loop below
 
          Get_First_Interp (Subp,  I, It);
-
          while Present (It.Typ) loop
             if Covers (Typ, It.Typ) then
                Nam := It.Nam;
@@ -3714,7 +3705,23 @@ package body Sem_Res is
         and then Nkind (N) /= N_Entry_Call_Statement
         and then Entry_Call_Statement (Parent (N)) = N
       then
-         Error_Msg_N ("entry call required in select statement", N);
+         if Ada_Version < Ada_05 then
+            Error_Msg_N ("entry call required in select statement", N);
+
+         --  Ada 2005 (AI-345): If a procedure_call_statement is used
+         --  for a procedure_or_entry_call, the procedure_name or pro-
+         --  cedure_prefix of the procedure_call_statement shall denote
+         --  an entry renamed by a procedure, or (a view of) a primitive
+         --  subprogram of a limited interface whose first parameter is
+         --  a controlling parameter.
+
+         elsif Nkind (N) = N_Procedure_Call_Statement
+           and then not Is_Renamed_Entry (Nam)
+           and then not Is_Controlling_Limited_Procedure (Nam)
+         then
+            Error_Msg_N
+              ("procedure or entry call required in select statement", N);
+         end if;
       end if;
 
       --  Check that this is not a call to a protected procedure or
@@ -4050,7 +4057,6 @@ package body Sem_Res is
 
       else
          C := Current_Entity (N);
-
          while Present (C) loop
             if Etype (C) = B_Typ then
                Set_Entity_With_Style_Check (N, C);
@@ -4092,6 +4098,7 @@ package body Sem_Res is
 
       if Scope (Entity (N)) /= Standard_Standard then
          T := Etype (First_Entity (Entity (N)));
+
       else
          T := Find_Unique_Type (L, R);
 
@@ -4475,7 +4482,6 @@ package body Sem_Res is
                --  the type in the same declarative part.
 
                Tsk := Next_Entity (S);
-
                while Etype (Tsk) /= S loop
                   Next_Entity (Tsk);
                end loop;
@@ -4515,9 +4521,7 @@ package body Sem_Res is
 
          begin
             Get_First_Interp (Pref, I, It);
-
             while Present (It.Typ) loop
-
                if Scope (Ent) = It.Typ then
                   Set_Etype (Pref, It.Typ);
                   exit;
@@ -4586,9 +4590,7 @@ package body Sem_Res is
 
          begin
             Get_First_Interp (Selector_Name (Entry_Name), I, It);
-
             while Present (It.Typ) loop
-
                if Covers (Typ, It.Typ) then
                   Set_Entity (Selector_Name (Entry_Name), It.Nam);
                   Set_Etype  (Entry_Name, It.Typ);
@@ -4740,7 +4742,7 @@ package body Sem_Res is
          Set_Analyzed (N, True);
 
       --  Protected functions can return on the secondary stack, in which
-      --  case we must trigger the transient scope mechanism
+      --  case we must trigger the transient scope mechanism.
 
       elsif Expander_Active
         and then Requires_Transient_Scope (Etype (Nam))
@@ -4780,7 +4782,7 @@ package body Sem_Res is
       function Find_Unique_Access_Type return Entity_Id is
          Acc : Entity_Id;
          E   : Entity_Id;
-         S   : Entity_Id := Current_Scope;
+         S   : Entity_Id;
 
       begin
          if Ekind (Etype (R)) =  E_Allocator_Type then
@@ -4793,11 +4795,10 @@ package body Sem_Res is
             return Empty;
          end if;
 
+         S := Current_Scope;
          while S /= Standard_Standard loop
             E := First_Entity (S);
-
             while Present (E) loop
-
                if Is_Type (E)
                  and then Is_Access_Type (E)
                  and then Ekind (E) /= E_Allocator_Type
@@ -4826,12 +4827,10 @@ package body Sem_Res is
       end if;
 
       if T /= Any_Type then
-
          if T = Any_String
            or else T = Any_Composite
            or else T = Any_Character
          then
-
             if T = Any_Character then
                Ambiguous_Character (L);
             else
@@ -4936,7 +4935,6 @@ package body Sem_Res is
         and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
       then
          null;
-
       else
          Check_Fully_Declared (Typ, N);
       end if;
@@ -4950,7 +4948,6 @@ package body Sem_Res is
          while Present (It.Typ) loop
             exit when Is_Access_Type (It.Typ)
               and then Covers (Typ, Designated_Type (It.Typ));
-
             Get_Next_Interp (I, It);
          end loop;
 
@@ -5044,12 +5041,7 @@ package body Sem_Res is
 
          begin
             Get_First_Interp (P, I, It);
-
-      --  the task has access discriminants, the designated type may be
-      --  incomplete at the point the expression is resolved. This resolution
-      --  takes place within the body of the initialization proc
             while Present (It.Typ) loop
-
                if (Is_Array_Type (It.Typ)
                      and then Covers (Typ, Component_Type (It.Typ)))
                  or else (Is_Access_Type (It.Typ)
@@ -5153,7 +5145,6 @@ package body Sem_Res is
 
    begin
       Op := Entity (N);
-
       while Scope (Op) /= Standard_Standard loop
          Op := Homonym (Op);
          pragma Assert (Present (Op));
@@ -5231,7 +5222,6 @@ package body Sem_Res is
 
    begin
       Op := Entity (N);
-
       while Scope (Op) /= Standard_Standard loop
          Op := Homonym (Op);
          pragma Assert (Present (Op));
@@ -5334,6 +5324,28 @@ package body Sem_Res is
         and then Is_Overloaded (L)
       then
          T := Etype (R);
+
+      --  Ada 2005 (AI-251): Give support to the following case:
+
+      --      type I is interface;
+      --      type T is tagged ...
+
+      --      function Test (O : in I'Class) is
+      --      begin
+      --         return O in T'Class.
+      --      end Test;
+
+      --  In this case we have nothing else to do; the membership test will be
+      --  done at run-time.
+
+      elsif Ada_Version >= Ada_05
+        and then Is_Class_Wide_Type (Etype (L))
+        and then Is_Interface (Etype (L))
+        and then Is_Class_Wide_Type (Etype (R))
+        and then not Is_Interface (Etype (R))
+      then
+         return;
+
       else
          T := Intersect_Types (L, R);
       end if;
@@ -5465,9 +5477,7 @@ package body Sem_Res is
 
                   begin
                      Get_First_Interp (Arg, I, It);
-
                      while Present (It.Nam) loop
-
                         if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
                           or else Base_Type (Etype (It.Nam)) =
                             Base_Type (Component_Type (Typ))
@@ -5725,9 +5735,16 @@ package body Sem_Res is
       Resolve (Expr, Target_Typ);
 
       --  A qualified expression requires an exact match of the type,
-      --  class-wide matching is not allowed.
-
-      if Is_Class_Wide_Type (Target_Typ)
+      --  class-wide matching is not allowed. However, if the qualifying
+      --  type is specific and the expression has a class-wide type, it
+      --  may still be okay, since it can be the result of the expansion
+      --  of a call to a dispatching function, so we also have to check
+      --  class-wideness of the type of the expression's original node.
+
+      if (Is_Class_Wide_Type (Target_Typ)
+           or else
+             (Is_Class_Wide_Type (Etype (Expr))
+               and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
         and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
       then
          Wrong_Type (Expr, Target_Typ);
@@ -5944,9 +5961,7 @@ package body Sem_Res is
 
             if Is_Record_Type (T) then
                Comp := First_Entity (T);
-
                while Present (Comp) loop
-
                   if Chars (Comp) = Chars (S)
                     and then Covers (Etype (Comp), Typ)
                   then
@@ -5974,7 +5989,6 @@ package body Sem_Res is
                               --  Find the component with the right name.
 
                               Comp1 := First_Entity (It1.Typ);
-
                               while Present (Comp1)
                                 and then Chars (Comp1) /= Chars (S)
                               loop
@@ -6118,9 +6132,7 @@ package body Sem_Res is
 
          begin
             Get_First_Interp (P, I,  It);
-
             while Present (It.Typ) loop
-
                if (Is_Array_Type (It.Typ)
                     and then Covers (Typ,  It.Typ))
                  or else (Is_Access_Type (It.Typ)
@@ -6630,6 +6642,10 @@ package body Sem_Res is
          end if;
 
          if Is_Interface (Target_Type) then
+            if Is_Access_Type (Opnd_Type) then
+               Opnd_Type := Directly_Designated_Type (Opnd_Type);
+            end if;
+
             if Is_Class_Wide_Type (Opnd_Type) then
                Opnd_Type := Etype (Opnd_Type);
             end if;
@@ -6638,19 +6654,25 @@ package body Sem_Res is
                      (Typ   => Opnd_Type,
                       Iface => Target_Type)
             then
-               if Nkind (Operand) = N_Attribute_Reference then
-                  Error_Msg_Name_1 := Chars (Prefix (Operand));
-               else
-                  Error_Msg_Name_1 := Chars (Operand);
-               end if;
-
-               Error_Msg_Name_2 := Chars (Target_Type);
                Error_Msg_NE
-                 ("(Ada 2005) % does not implement interface %",
+                 ("(Ada 2005) does not implement interface }",
                   Operand, Target_Type);
 
             else
-               Expand_Interface_Conversion (N);
+               --  If a conversion to an interface type appears as an actual in
+               --  a source call, it will be expanded when the enclosing call
+               --  itself is examined in Expand_Interface_Formals. Otherwise,
+               --  generate the proper conversion code now, using the tag of
+               --  the interface.
+
+               if (Nkind (Parent (N)) = N_Procedure_Call_Statement
+                     or else Nkind (Parent (N)) = N_Function_Call)
+                 and then Comes_From_Source (N)
+               then
+                  null;
+               else
+                  Expand_Interface_Conversion (N);
+               end if;
             end if;
          end if;
       end if;
@@ -7000,7 +7022,6 @@ package body Sem_Res is
       Scop := Current_Scope;
       while Scop /= Standard_Standard loop
          T2 := First_Entity (Scop);
-
          while Present (T2) loop
             if Is_Fixed_Point_Type (T2)
               and then Current_Entity (T2) = T2
@@ -7027,7 +7048,6 @@ package body Sem_Res is
          if Nkind (Item) = N_With_Clause then
             Scop := Entity (Name (Item));
             T2 := First_Entity (Scop);
-
             while Present (T2) loop
                if Is_Fixed_Point_Type (T2)
                  and then Scope (Base_Type (T2)) = Scop
@@ -7160,14 +7180,26 @@ package body Sem_Res is
             --  in this context, but which cannot be removed by type checking,
             --  because the context does not impose a type.
 
+            --  When compiling for VMS, spurious ambiguities can be produced
+            --  when arithmetic operations have a literal operand and return
+            --  System.Address or a descendant of it. These ambiguities are
+            --  otherwise resolved by the context, but for conversions there
+            --  is no context type and the removal of the spurious operations
+            --  must be done explicitly here.
+
             Get_First_Interp (Operand, I, It);
 
             while Present (It.Typ) loop
-
                if It.Typ = Standard_Void_Type then
                   Remove_Interp (I);
                end if;
 
+               if Present (System_Aux_Id)
+                 and then Is_Descendent_Of_Address (It.Typ)
+               then
+                  Remove_Interp (I);
+               end if;
+
                Get_Next_Interp (I, It);
             end loop;
 
@@ -7557,10 +7589,10 @@ package body Sem_Res is
                O_Gen : constant Node_Id :=
                          Enclosing_Generic_Body (Opnd_Type);
 
-               T_Gen : Node_Id :=
-                         Enclosing_Generic_Body (Target_Type);
+               T_Gen : Node_Id;
 
             begin
+               T_Gen := Enclosing_Generic_Body (Target_Type);
                while Present (T_Gen) and then T_Gen /= O_Gen loop
                   T_Gen := Enclosing_Generic_Body (T_Gen);
                end loop;