2005-11-14 Hristian Kirtchev <kirtchev@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* sem_res.adb (Resolve_Call): Provide a better error message whenever
	a procedure call is used as a select statement trigger and is not an
	entry renaming or a primitive of a limited interface.
	(Valid_Conversion): If the operand has a single interpretation do not
	remove address operations.
	(Check_Infinite_Recursion): Skip freeze nodes when looking for a raise
	statement to inhibit warning.
	(Resolve_Unary_Op): Do not produce a warning when
	processing an expression of the form -(A mod B)
	Use Universal_Real instead of Long_Long_Float when we need a high
	precision float type for the generated code (prevents gratuitous
	Vax_Float stuff when pragma Float_Representation (Vax_Float) used)
	(Resolve_Concatenation_Arg): Improve error message when argument is an
	ambiguous call to a function that returns an array.
	(Make_Call_Into_Operator, Operand_Type_In_Scope): Do not check that
	there is an implicit operator in the given scope if we are within an
	instance: legality check has been performed on the generic.
	(Resolve_Unary_Op): Apply warnings checks on argument of Abs operator
	after resolving operand, to avoid false warnings on overloaded calls.



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

1 files changed, 111 insertions, 82 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index e1e9b7b4ec3..f9093455fbb 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -280,7 +280,6 @@ package body Sem_Res is
       if Suppress = All_Checks then
          declare
             Svg : constant Suppress_Array := Scope_Suppress;
-
          begin
             Scope_Suppress := (others => True);
             Analyze_And_Resolve (N, Typ);
@@ -322,7 +321,6 @@ package body Sem_Res is
       if Suppress = All_Checks then
          declare
             Svg : constant Suppress_Array := Scope_Suppress;
-
          begin
             Scope_Suppress := (others => True);
             Analyze_And_Resolve (N);
@@ -685,12 +683,30 @@ package body Sem_Res is
             if Nkind (Parent (N)) = N_Return_Statement
               and then Same_Argument_List
             then
-               exit when not Is_List_Member (Parent (N))
-                 or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
-                            and then
-                          (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error
-                             or else
-                           Present (Condition (Prev (Parent (N))))));
+               exit when not Is_List_Member (Parent (N));
+
+               --  OK, return statement is in a statement list, look for raise
+
+               declare
+                  Nod : Node_Id;
+
+               begin
+                  --  Skip past N_Freeze_Entity nodes generated by expansion
+
+                  Nod := Prev (Parent (N));
+                  while Present (Nod)
+                    and then Nkind (Nod) = N_Freeze_Entity
+                  loop
+                     Prev (Nod);
+                  end loop;
+
+                  --  If no raise statement, give warning
+
+                  exit when Nkind (Nod) /= N_Raise_Statement
+                    and then
+                      (Nkind (Nod) not in N_Raise_xxx_Error
+                         or else Present (Condition (Nod)));
+               end;
             end if;
 
             return False;
@@ -1124,6 +1140,13 @@ package body Sem_Res is
          then
             null;
 
+         --  Visibility does not need to be checked in an instance: if the
+         --  operator was not visible in the generic it has been diagnosed
+         --  already, else there is an implicit copy of it in the instance.
+
+         elsif In_Instance then
+            null;
+
          elsif (Op_Name =  Name_Op_Multiply
               or else Op_Name = Name_Op_Divide)
            and then Is_Fixed_Point_Type (Etype (Left_Opnd  (Op_Node)))
@@ -2316,7 +2339,6 @@ package body Sem_Res is
       if Suppress = All_Checks then
          declare
             Svg : constant Suppress_Array := Scope_Suppress;
-
          begin
             Scope_Suppress := (others => True);
             Resolve (N, Typ);
@@ -2326,7 +2348,6 @@ package body Sem_Res is
       else
          declare
             Svg : constant Boolean := Scope_Suppress (Suppress);
-
          begin
             Scope_Suppress (Suppress) := True;
             Resolve (N, Typ);
@@ -3519,7 +3540,6 @@ package body Sem_Res is
       It      : Interp;
       Norm_OK : Boolean;
       Scop    : Entity_Id;
-      W       : Node_Id;
 
    begin
       --  The context imposes a unique interpretation with type Typ on a
@@ -3659,39 +3679,9 @@ package body Sem_Res is
          Kill_Current_Values;
       end if;
 
-      --  Deal with call to obsolescent subprogram. Note that we always allow
-      --  such calls in the compiler itself and the run-time, since we assume
-      --  that we know what we are doing in such cases. For example, the calls
-      --  in Ada.Characters.Handling to its own obsolescent subprograms are
-      --  just fine.
-
-      if Is_Obsolescent (Nam) and then not GNAT_Mode then
-         Check_Restriction (No_Obsolescent_Features, N);
-
-         if Warn_On_Obsolescent_Feature then
-            Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
-
-            --  Output additional warning if present
-
-            W := Obsolescent_Warning (Nam);
+      --  Check for call to subprogram marked Is_Obsolescent
 
-            if Present (W) then
-               Name_Buffer (1) := '|';
-               Name_Buffer (2) := '?';
-               Name_Len := 2;
-
-               --  Add characters to message, and output message
-
-               for J in 1 .. String_Length (Strval (W)) loop
-                  Add_Char_To_Name_Buffer (''');
-                  Add_Char_To_Name_Buffer
-                    (Get_Character (Get_String_Char (Strval (W), J)));
-               end loop;
-
-               Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
-            end if;
-         end if;
-      end if;
+      Check_Obsolescent (Nam, N);
 
       --  Check that a procedure call does not occur in the context of the
       --  entry call statement of a conditional or timed entry call. Note that
@@ -3720,7 +3710,8 @@ package body Sem_Res is
            and then not Is_Controlling_Limited_Procedure (Nam)
          then
             Error_Msg_N
-              ("procedure or entry call required in select statement", N);
+             ("entry call, entry renaming or dispatching primitive " &
+              "of limited or synchronized interface required", N);
          end if;
       end if;
 
@@ -5469,25 +5460,47 @@ package body Sem_Res is
                  and then Has_Compatible_Type (Arg, Typ)
                  and then Etype (Arg) /= Any_Type
                then
-                  Error_Msg_N ("ambiguous operand for concatenation!", Arg);
 
                   declare
-                     I  : Interp_Index;
-                     It : Interp;
+                     I    : Interp_Index;
+                     It   : Interp;
+                     Func : Entity_Id;
 
                   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))
-                        then
+                     Func := It.Nam;
+                     Get_Next_Interp (I, It);
+
+                     --  Special-case the error message when the overloading
+                     --  is caused by a function that yields and array and
+                     --  can be called without parameters.
+
+                     if It.Nam = Func then
+                        Error_Msg_Sloc := Sloc (Func);
+                        Error_Msg_N ("\ambiguous call to function#", Arg);
+                        Error_Msg_NE
+                          ("\interpretation as call yields&", Arg, Typ);
+                        Error_Msg_NE
+                          ("\interpretation as indexing of call yields&",
+                            Arg, Component_Type (Typ));
+
+                     else
+                        Error_Msg_N ("ambiguous operand for concatenation!",
+                          Arg);
+                        Get_First_Interp (Arg, I, It);
+                        while Present (It.Nam) loop
                            Error_Msg_Sloc := Sloc (It.Nam);
-                           Error_Msg_N ("\possible interpretation#", Arg);
-                        end if;
 
-                        Get_Next_Interp (I, It);
-                     end loop;
+                           if Base_Type (It.Typ) = Base_Type (Typ)
+                             or else Base_Type (It.Typ) =
+                               Base_Type (Component_Type (Typ))
+                           then
+                              Error_Msg_N ("\possible interpretation#", Arg);
+                           end if;
+
+                           Get_Next_Interp (I, It);
+                        end loop;
+                     end if;
                   end;
                end if;
 
@@ -6536,13 +6549,14 @@ package body Sem_Res is
             end if;
 
             --  Resolve the real operand with largest available precision
+
             if Etype (Right_Opnd (Operand)) = Universal_Real then
                Rop := New_Copy_Tree (Right_Opnd (Operand));
             else
                Rop := New_Copy_Tree (Left_Opnd (Operand));
             end if;
 
-            Resolve (Rop, Standard_Long_Long_Float);
+            Resolve (Rop, Universal_Real);
 
             --  If the operand is a literal (it could be a non-static and
             --  illegal exponentiation) check whether the use of Duration
@@ -6690,23 +6704,11 @@ package body Sem_Res is
       Hi    : Uint;
 
    begin
-      --  Generate warning for expressions like abs (x mod 2)
-
-      if Warn_On_Redundant_Constructs
-        and then Nkind (N) = N_Op_Abs
-      then
-         Determine_Range (Right_Opnd (N), OK, Lo, Hi);
-
-         if OK and then Hi >= Lo and then Lo >= 0 then
-            Error_Msg_N
-             ("?abs applied to known non-negative value has no effect", N);
-         end if;
-      end if;
-
       --  Generate warning for expressions like -5 mod 3
 
       if Paren_Count (N) = 0
         and then Nkind (N) = N_Op_Minus
+        and then Paren_Count (Right_Opnd (N)) = 0
         and then Nkind (Right_Opnd (N)) = N_Op_Mod
         and then Comes_From_Source (N)
       then
@@ -6732,6 +6734,19 @@ package body Sem_Res is
       Set_Etype (N, B_Typ);
       Resolve (R, B_Typ);
 
+      --  Generate warning for expressions like abs (x mod 2)
+
+      if Warn_On_Redundant_Constructs
+        and then Nkind (N) = N_Op_Abs
+      then
+         Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+
+         if OK and then Hi >= Lo and then Lo >= 0 then
+            Error_Msg_N
+             ("?abs applied to known non-negative value has no effect", N);
+         end if;
+      end if;
+
       Check_Unset_Reference (R);
       Generate_Operator_Reference (N, B_Typ);
       Eval_Unary_Op (N);
@@ -7187,21 +7202,35 @@ package body Sem_Res is
             --  is no context type and the removal of the spurious operations
             --  must be done explicitly here.
 
+            --  The node may be labelled overloaded, but still contain only
+            --  one interpretation because others were discarded in previous
+            --  filters. If this is the case, retain the single interpretation
+            --  if legal.
+
             Get_First_Interp (Operand, I, It);
+            Opnd_Type := It.Typ;
+            Get_Next_Interp (I, It);
 
-            while Present (It.Typ) loop
-               if It.Typ = Standard_Void_Type then
-                  Remove_Interp (I);
-               end if;
+            if Present (It.Typ)
+              and then Opnd_Type /= Standard_Void_Type
+            then
+               --  More than one candidate interpretation is available
 
-               if Present (System_Aux_Id)
-                 and then Is_Descendent_Of_Address (It.Typ)
-               then
-                  Remove_Interp (I);
-               end if;
+               Get_First_Interp (Operand, I, It);
+               while Present (It.Typ) loop
+                  if It.Typ = Standard_Void_Type then
+                     Remove_Interp (I);
+                  end if;
 
-               Get_Next_Interp (I, It);
-            end loop;
+                  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;
+            end if;
 
             Get_First_Interp (Operand, I, It);
             I1  := I;