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
This commit is contained in:
parent
0356699b56
commit
9ebe37436f
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue