FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_res.adb (Resolve_Call): Provide a better error message whenever a procedure call is used as a select...

Browse source 
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.

From-SVN: r107005
This commit is contained in:
Hristian Kirtchev 2005-11-15 15:03:45 +01:00 • committed by Arnaud Charlet
parent 0356699b56
commit 9ebe37436f
1 changed files with 112 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

195
gcc/ada/sem_res.adb
View file

@ -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.
-- Check for call to subprogram marked Is_Obsolescent
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);
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
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("\possible interpretation#", Arg);
end if;
Func := It.Nam;
Get_Next_Interp (I, It);
Get_Next_Interp (I, It);
end loop;
-- 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);
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;