-- --
-- 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- --
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N);
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;
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)))
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Resolve (N, Typ);
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
-
begin
Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
- W : Node_Id;
begin
-- The context imposes a unique interpretation with type Typ on a
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
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;
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;
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
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
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);
-- 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;
OSDN Git Service
