Skip to content

R
riscv-gcc-1
Commit 9ebe3743 by Hristian Kirtchev Committed by Arnaud Charlet
Options

sem_res.adb (Resolve_Call): Provide a better error message whenever a procedure… 

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

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
parent 0356699b
Showing with 91 additions and 62 deletions
gcc/ada/sem_res.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -280,7 +280,6 @@ package body Sem_Res is ...@@ -280,7 +280,6 @@ package body Sem_Res is
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Array := Scope_Suppress; Svg : constant Suppress_Array := Scope_Suppress;
begin begin
Scope_Suppress := (others => True); Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ); Analyze_And_Resolve (N, Typ);
...@@ -322,7 +321,6 @@ package body Sem_Res is ...@@ -322,7 +321,6 @@ package body Sem_Res is
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Array := Scope_Suppress; Svg : constant Suppress_Array := Scope_Suppress;
begin begin
Scope_Suppress := (others => True); Scope_Suppress := (others => True);
Analyze_And_Resolve (N); Analyze_And_Resolve (N);
...@@ -685,12 +683,30 @@ package body Sem_Res is ...@@ -685,12 +683,30 @@ package body Sem_Res is
if Nkind (Parent (N)) = N_Return_Statement if Nkind (Parent (N)) = N_Return_Statement
and then Same_Argument_List and then Same_Argument_List
then then
exit when not Is_List_Member (Parent (N)) exit when not Is_List_Member (Parent (N));
or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
-- 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 and then
(Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error (Nkind (Nod) not in N_Raise_xxx_Error
or else or else Present (Condition (Nod)));
Present (Condition (Prev (Parent (N)))))); end;
end if; end if;
return False; return False;
...@@ -1124,6 +1140,13 @@ package body Sem_Res is ...@@ -1124,6 +1140,13 @@ package body Sem_Res is
then then
null; 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 elsif (Op_Name = Name_Op_Multiply
or else Op_Name = Name_Op_Divide) or else Op_Name = Name_Op_Divide)
and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
...@@ -2316,7 +2339,6 @@ package body Sem_Res is ...@@ -2316,7 +2339,6 @@ package body Sem_Res is
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Array := Scope_Suppress; Svg : constant Suppress_Array := Scope_Suppress;
begin begin
Scope_Suppress := (others => True); Scope_Suppress := (others => True);
Resolve (N, Typ); Resolve (N, Typ);
...@@ -2326,7 +2348,6 @@ package body Sem_Res is ...@@ -2326,7 +2348,6 @@ package body Sem_Res is
else else
declare declare
Svg : constant Boolean := Scope_Suppress (Suppress); Svg : constant Boolean := Scope_Suppress (Suppress);
begin begin
Scope_Suppress (Suppress) := True; Scope_Suppress (Suppress) := True;
Resolve (N, Typ); Resolve (N, Typ);
...@@ -3519,7 +3540,6 @@ package body Sem_Res is ...@@ -3519,7 +3540,6 @@ package body Sem_Res is
It : Interp; It : Interp;
Norm_OK : Boolean; Norm_OK : Boolean;
Scop : Entity_Id; Scop : Entity_Id;
W : Node_Id;
begin begin
-- The context imposes a unique interpretation with type Typ on a -- The context imposes a unique interpretation with type Typ on a
...@@ -3659,39 +3679,9 @@ package body Sem_Res is ...@@ -3659,39 +3679,9 @@ package body Sem_Res is
Kill_Current_Values; Kill_Current_Values;
end if; end if;
-- Deal with call to obsolescent subprogram. Note that we always allow -- Check for call to subprogram marked Is_Obsolescent
-- 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_Obsolescent (Nam, N);
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 that a procedure call does not occur in the context of the -- 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 -- entry call statement of a conditional or timed entry call. Note that
...@@ -3720,7 +3710,8 @@ package body Sem_Res is ...@@ -3720,7 +3710,8 @@ package body Sem_Res is
and then not Is_Controlling_Limited_Procedure (Nam) and then not Is_Controlling_Limited_Procedure (Nam)
then then
Error_Msg_N 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;
end if; end if;
...@@ -5469,25 +5460,47 @@ package body Sem_Res is ...@@ -5469,25 +5460,47 @@ package body Sem_Res is
and then Has_Compatible_Type (Arg, Typ) and then Has_Compatible_Type (Arg, Typ)
and then Etype (Arg) /= Any_Type and then Etype (Arg) /= Any_Type
then then
Error_Msg_N ("ambiguous operand for concatenation!", Arg);
declare declare
I : Interp_Index; I : Interp_Index;
It : Interp; It : Interp;
Func : Entity_Id;
begin begin
Get_First_Interp (Arg, I, It); Get_First_Interp (Arg, I, It);
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 while Present (It.Nam) loop
if Base_Type (Etype (It.Nam)) = Base_Type (Typ) Error_Msg_Sloc := Sloc (It.Nam);
or else Base_Type (Etype (It.Nam)) =
if Base_Type (It.Typ) = Base_Type (Typ)
or else Base_Type (It.Typ) =
Base_Type (Component_Type (Typ)) Base_Type (Component_Type (Typ))
then then
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("\possible interpretation#", Arg); Error_Msg_N ("\possible interpretation#", Arg);
end if; end if;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
end loop; end loop;
end if;
end; end;
end if; end if;
...@@ -6536,13 +6549,14 @@ package body Sem_Res is ...@@ -6536,13 +6549,14 @@ package body Sem_Res is
end if; end if;
-- Resolve the real operand with largest available precision -- Resolve the real operand with largest available precision
if Etype (Right_Opnd (Operand)) = Universal_Real then if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand)); Rop := New_Copy_Tree (Right_Opnd (Operand));
else else
Rop := New_Copy_Tree (Left_Opnd (Operand)); Rop := New_Copy_Tree (Left_Opnd (Operand));
end if; 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 -- If the operand is a literal (it could be a non-static and
-- illegal exponentiation) check whether the use of Duration -- illegal exponentiation) check whether the use of Duration
...@@ -6690,23 +6704,11 @@ package body Sem_Res is ...@@ -6690,23 +6704,11 @@ package body Sem_Res is
Hi : Uint; Hi : Uint;
begin 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 -- Generate warning for expressions like -5 mod 3
if Paren_Count (N) = 0 if Paren_Count (N) = 0
and then Nkind (N) = N_Op_Minus 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 Nkind (Right_Opnd (N)) = N_Op_Mod
and then Comes_From_Source (N) and then Comes_From_Source (N)
then then
...@@ -6732,6 +6734,19 @@ package body Sem_Res is ...@@ -6732,6 +6734,19 @@ package body Sem_Res is
Set_Etype (N, B_Typ); Set_Etype (N, B_Typ);
Resolve (R, 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); Check_Unset_Reference (R);
Generate_Operator_Reference (N, B_Typ); Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N); Eval_Unary_Op (N);
...@@ -7187,8 +7202,21 @@ package body Sem_Res is ...@@ -7187,8 +7202,21 @@ package body Sem_Res is
-- is no context type and the removal of the spurious operations -- is no context type and the removal of the spurious operations
-- must be done explicitly here. -- 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); Get_First_Interp (Operand, I, It);
Opnd_Type := It.Typ;
Get_Next_Interp (I, It);
if Present (It.Typ)
and then Opnd_Type /= Standard_Void_Type
then
-- More than one candidate interpretation is available
Get_First_Interp (Operand, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if It.Typ = Standard_Void_Type then if It.Typ = Standard_Void_Type then
Remove_Interp (I); Remove_Interp (I);
...@@ -7202,6 +7230,7 @@ package body Sem_Res is ...@@ -7202,6 +7230,7 @@ package body Sem_Res is
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
end loop; end loop;
end if;
Get_First_Interp (Operand, I, It); Get_First_Interp (Operand, I, It);
I1 := I; I1 := I;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment