-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2008, 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- --
-- --
------------------------------------------------------------------------------
-with Alloc;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Table;
with Uintp; use Uintp;
package body Sem_Warn is
-- The following table collects potential warnings for IN OUT parameters
-- that are referenced but not modified. These warnings are processed when
- -- the front end calls the procedure Output_Non_Modifed_In_Out_Warnings.
+ -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings.
-- The reason that we defer output of these messages is that we want to
-- detect the case where the relevant procedure is used as a generic actual
- -- in an instantation, since we suppress the warnings in this case. The
- -- flag Used_As_Generic_Actual will be set in this case, but will not be
- -- set till later. Similarly, we suppress the message if the address of
- -- the procedure is taken, where the flag Address_Taken may be set later.
+ -- in an instantiation, since we suppress the warnings in this case. The
+ -- flag Used_As_Generic_Actual will be set in this case, but only at the
+ -- point of usage. Similarly, we suppress the message if the address of the
+ -- procedure is taken, where the flag Address_Taken may be set later.
package In_Out_Warnings is new Table.Table (
Table_Component_Type => Entity_Id,
Table_Increment => Alloc.In_Out_Warnings_Increment,
Table_Name => "In_Out_Warnings");
+ --------------------------------------------------------
+ -- Handling of Warnings Off, Unmodified, Unreferenced --
+ --------------------------------------------------------
+
+ -- The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must
+ -- generally be used instead of Warnings_Off, Has_Pragma_Unmodified and
+ -- Has_Pragma_Unreferenced, as noted in the specs in Einfo.
+
+ -- In order to avoid losing warnings in -gnatw.w (warn on unnecessary
+ -- warnings off pragma) mode, i.e. to avoid false negatives, the code
+ -- must follow some important rules.
+
+ -- Call these functions as late as possible, after completing all other
+ -- tests, just before the warnings is given. For example, don't write:
+
+ -- if not Has_Warnings_Off (E)
+ -- and then some-other-predicate-on-E then ..
+
+ -- Instead the following is preferred
+
+ -- if some-other-predicate-on-E
+ -- and then Has_Warnings_Off (E)
+
+ -- This way if some-other-predicate is false, we avoid a false indication
+ -- that a Warnings (Off,E) pragma was useful in preventing a warning.
+
+ -- The second rule is that if both Has_Unmodified and Has_Warnings_Off, or
+ -- Has_Unreferenced and Has_Warnings_Off are called, make sure that the
+ -- call to Has_Unmodified/Has_Unreferenced comes first, this way we record
+ -- that the Warnings (Off) could have been Unreferenced or Unmodified. In
+ -- fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off,
+ -- and so a subsequent test is not needed anyway (though it is harmless).
+
-----------------------
-- Local Subprograms --
-----------------------
-- accept statement, and the message is posted on Body_E. In all other
-- cases, Body_E is ignored and must be Empty.
+ function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean;
+ -- Returns True if Warnings_Off is set for the entity E or (in the case
+ -- where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity.
+
--------------------------
-- Check_Code_Statement --
--------------------------
if not Is_Entity_Name (Name (N)) then
return;
- -- Forget it if warnings are suppressed on function entity
+ -- Forget it if function name is suspicious. A strange test
+ -- but warning generation is in the heuristics business!
- elsif Warnings_Off (Entity (Name (N))) then
+ elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
return;
- -- Forget it if function name is suspicious. A strange test
- -- but warning generation is in the heuristics business!
+ -- Forget it if warnings are suppressed on function entity
- elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
+ elsif Has_Warnings_Off (Entity (Name (N))) then
return;
end if;
(E : Entity_Id;
Accept_Statement : Node_Id) return Entity_Id;
-- For an entry formal entity from an entry declaration, find the
- -- corrsesponding body formal from the given accept statement.
+ -- corresponding body formal from the given accept statement.
function Missing_Subunits return Boolean;
-- We suppress warnings when there are missing subunits, because this
-- from another unit. This is true for entities in packages that are at
-- the library level.
+ function Warnings_Off_E1 return Boolean;
+ -- Return True if Warnings_Off is set for E1, or for its Etype (E1T),
+ -- or for the base type of E1T.
+
+ -----------------
+ -- Body_Formal --
+ -----------------
+
+ function Body_Formal
+ (E : Entity_Id;
+ Accept_Statement : Node_Id) return Entity_Id
+ is
+ Body_Param : Node_Id;
+ Body_E : Entity_Id;
+
+ begin
+ -- Loop to find matching parameter in accept statement
+
+ Body_Param := First (Parameter_Specifications (Accept_Statement));
+ while Present (Body_Param) loop
+ Body_E := Defining_Identifier (Body_Param);
+
+ if Chars (Body_E) = Chars (E) then
+ return Body_E;
+ end if;
+
+ Next (Body_Param);
+ end loop;
+
+ -- Should never fall through, should always find a match
+
+ raise Program_Error;
+ end Body_Formal;
+
----------------------
-- Missing_Subunits --
----------------------
end if;
end Missing_Subunits;
- -----------------
- -- Body_Formal --
- -----------------
-
- function Body_Formal
- (E : Entity_Id;
- Accept_Statement : Node_Id) return Entity_Id
- is
- Body_Param : Node_Id;
- Body_E : Entity_Id;
-
- begin
- -- Loop to find matching parameter in accept statement
-
- Body_Param := First (Parameter_Specifications (Accept_Statement));
- while Present (Body_Param) loop
- Body_E := Defining_Identifier (Body_Param);
-
- if Chars (Body_E) = Chars (E) then
- return Body_E;
- end if;
-
- Next (Body_Param);
- end loop;
-
- -- Should never fall through, should always find a match
-
- raise Program_Error;
- end Body_Formal;
-
----------------------------
-- Output_Reference_Error --
----------------------------
end loop;
end Publicly_Referenceable;
+ ---------------------
+ -- Warnings_Off_E1 --
+ ---------------------
+
+ function Warnings_Off_E1 return Boolean is
+ begin
+ return Has_Warnings_Off (E1T)
+ or else Has_Warnings_Off (Base_Type (E1T))
+ or else Warnings_Off_Check_Spec (E1);
+ end Warnings_Off_E1;
+
-- Start of processing for Check_References
begin
while Present (E1) loop
E1T := Etype (E1);
- -- We only look at source entities with warning flag on. We also
- -- ignore objects whose type or base type has warnings suppressed.
- -- We also don't issue warnings within instances, since the proper
- -- place for such warnings is on the template when it is compiled.
+ -- We are only interested in source entities. We also don't issue
+ -- warnings within instances, since the proper place for such
+ -- warnings is on the template when it is compiled.
if Comes_From_Source (E1)
- and then not Warnings_Off (E1)
- and then not Warnings_Off (E1T)
- and then not Warnings_Off (Base_Type (E1T))
and then Instantiation_Location (Sloc (E1)) = No_Location
then
-- We are interested in variables and out/in-out parameters, but
UR := Unset_Reference (E1);
end if;
- -- If the entity is an out parameter of the current subprogram
- -- body, check the warning status of the parameter in the spec.
-
- if Is_Formal (E1)
- and then Present (Spec_Entity (E1))
- and then Warnings_Off (Spec_Entity (E1))
- then
- null;
-
-- Special processing for access types
- elsif Present (UR)
+ if Present (UR)
and then Is_Access_Type (E1T)
then
-- For access types, the only time we made a UR entry was
-- assignment of a pointer involving discriminant check
-- on the designated object).
- Error_Msg_NE ("?& may be null!", UR, E1);
+ if not Warnings_Off_E1 then
+ Error_Msg_NE ("?& may be null!", UR, E1);
+ end if;
+
goto Continue;
-- Case of variable that could be a constant. Note that we
and then not Has_Pragma_Unreferenced_Check_Spec (E1)
and then not Has_Pragma_Unmodified_Check_Spec (E1)
then
- Error_Msg_N
- ("?& is not modified, "
- & "could be declared constant!",
- E1);
+ if not Warnings_Off_E1 then
+ Error_Msg_N
+ ("?& is not modified, "
+ & "could be declared constant!",
+ E1);
+ end if;
end if;
end if;
end if;
or else not Is_Fully_Initialized_Type (E1T))
then
-- Do not output complaint about never being assigned a
- -- value if a pragma Unreferenced applies to the variable
+ -- value if a pragma Unmodified applies to the variable
-- we are examining, or if it is a parameter, if there is
- -- a pragma Unreferenced for the corresponding spec.
+ -- a pragma Unreferenced for the corresponding spec, of
+ -- if the type is marked as having unreferenced objects.
+ -- The last is a little peculiar, but better too few than
+ -- too many warnings in this situation.
- if Has_Pragma_Unreferenced_Check_Spec (E1)
- or else Has_Pragma_Unreferenced_Objects (E1T)
+ if Has_Pragma_Unreferenced_Objects (E1T)
+ or else Has_Pragma_Unmodified_Check_Spec (E1)
then
null;
-- other method to achieve the local effect of a
-- modification. On the other hand if the spec and body
-- are in the same unit, we are in the package body and
- -- there we less excuse for a junk IN OUT parameter.
+ -- there we have less excuse for a junk IN OUT parameter.
if Has_Private_Declaration (E1T)
and then Present (Spec_Entity (E1))
-- Suppress warning for any parameter of a dispatching
-- operation, since it is quite reasonable to have an
-- operation that is overridden, and for some subclasses
- -- needs to be IN OUT and for others the parameter does
- -- not happen to be assigned.
+ -- needs the formal to be IN OUT and for others happens
+ -- not to assign it.
elsif Is_Dispatching_Operation
(Scope (Goto_Spec_Entity (E1)))
-- actual, or its address/access is taken. In these two
-- cases, we suppress the warning because the context may
-- force use of IN OUT, even if in this particular case
- -- the formal is not modifed.
+ -- the formal is not modified.
else
In_Out_Warnings.Append (E1);
-- Other cases of formals
elsif Is_Formal (E1) then
- if Referenced_Check_Spec (E1) then
- if not Has_Pragma_Unmodified_Check_Spec (E1) then
+ if not Is_Trivial_Subprogram (Scope (E1)) then
+ if Referenced_Check_Spec (E1) then
+ if not Has_Pragma_Unmodified_Check_Spec (E1)
+ and then not Warnings_Off_E1
+ then
+ Output_Reference_Error
+ ("?formal parameter& is read but "
+ & "never assigned!");
+ end if;
+
+ elsif not Has_Pragma_Unreferenced_Check_Spec (E1)
+ and then not Warnings_Off_E1
+ then
Output_Reference_Error
- ("?formal parameter& is read but "
- & "never assigned!");
+ ("?formal parameter& is not referenced!");
end if;
-
- else
- Output_Reference_Error
- ("?formal parameter& is not referenced!");
end if;
-- Case of variable
else
if Referenced (E1) then
- Output_Reference_Error
- ("?variable& is read but never assigned!");
- else
+ if not Has_Unmodified (E1)
+ and then not Warnings_Off_E1
+ then
+ Output_Reference_Error
+ ("?variable& is read but never assigned!");
+ end if;
+
+ elsif not Has_Unreferenced (E1)
+ and then not Warnings_Off_E1
+ then
Output_Reference_Error
("?variable& is never read and never assigned!");
end if;
if Ekind (E1) = E_Variable
and then Present (Hiding_Loop_Variable (E1))
+ and then not Warnings_Off_E1
then
Error_Msg_N
("?for loop implicitly declares loop variable!",
-- are only for functions, and functions do not allow OUT
-- parameters.)
- if Nkind (UR) = N_Simple_Return_Statement
- and then not Has_Pragma_Unmodified_Check_Spec (E1)
- then
- Error_Msg_NE
- ("?OUT parameter& not set before return", UR, E1);
+ if not Is_Trivial_Subprogram (Scope (E1)) then
+ if Nkind (UR) = N_Simple_Return_Statement
+ and then not Has_Pragma_Unmodified_Check_Spec (E1)
+ then
+ if not Warnings_Off_E1 then
+ Error_Msg_NE
+ ("?OUT parameter& not set before return", UR, E1);
+ end if;
- -- If the unset reference is prefix of a selected component
- -- that comes from source, mention the component as well. If
- -- the selected component comes from expansion, all we know
- -- is that the entity is not fully initialized at the point
- -- of the reference. Locate an unintialized component to get
- -- a better error message.
+ -- If the unset reference is a selected component
+ -- prefix from source, mention the component as well.
+ -- If the selected component comes from expansion, all
+ -- we know is that the entity is not fully initialized
+ -- at the point of the reference. Locate a random
+ -- uninitialized component to get a better message.
- elsif Nkind (Parent (UR)) = N_Selected_Component then
- Error_Msg_Node_2 := Selector_Name (Parent (UR));
+ elsif Nkind (Parent (UR)) = N_Selected_Component then
+ Error_Msg_Node_2 := Selector_Name (Parent (UR));
- if not Comes_From_Source (Parent (UR)) then
- declare
- Comp : Entity_Id;
+ if not Comes_From_Source (Parent (UR)) then
+ declare
+ Comp : Entity_Id;
- begin
- Comp := First_Entity (E1T);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Nkind (Parent (Comp)) =
- N_Component_Declaration
- and then No (Expression (Parent (Comp)))
- then
- Error_Msg_Node_2 := Comp;
- exit;
- end if;
+ begin
+ Comp := First_Entity (E1T);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Nkind (Parent (Comp)) =
+ N_Component_Declaration
+ and then No (Expression (Parent (Comp)))
+ then
+ Error_Msg_Node_2 := Comp;
+ exit;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
- Next_Entity (Comp);
- end loop;
- end;
- end if;
+ -- Issue proper warning. This is a case of referencing
+ -- a variable before it has been explicitly assigned.
+ -- For access types, UR was only set for dereferences,
+ -- so the issue is that the value may be null.
- -- Issue proper warning. This is a case of referencing
- -- a variable before it has been explicitly assigned.
- -- For access types, UR was only set for dereferences,
- -- so the issue is that the value may be null.
+ if not Is_Trivial_Subprogram (Scope (E1)) then
+ if not Warnings_Off_E1 then
+ if Is_Access_Type (Etype (Parent (UR))) then
+ Error_Msg_N ("?`&.&` may be null!", UR);
+ else
+ Error_Msg_N
+ ("?`&.&` may be referenced before "
+ & "it has a value!", UR);
+ end if;
+ end if;
+ end if;
- if Is_Access_Type (Etype (Parent (UR))) then
- Error_Msg_N ("?`&.&` may be null!", UR);
- else
+ -- All other cases of unset reference active
+
+ elsif not Warnings_Off_E1 then
Error_Msg_N
- ("?`&.&` may be referenced before it has a value!",
+ ("?& may be referenced before it has a value!",
UR);
end if;
-
- -- All other cases of unset reference active
-
- else
- Error_Msg_N
- ("?& may be referenced before it has a value!",
- UR);
end if;
goto Continue;
end if;
-- Then check for unreferenced entities. Note that we are only
- -- interested in entities which do not have the Referenced flag
- -- set. The Referenced_As_LHS flag is interesting only if the
- -- Referenced flag is not set.
+ -- interested in entities whose Referenced flag is not set.
if not Referenced_Check_Spec (E1)
+ -- If Referenced_As_LHS is set, then that's still interesting
+ -- (potential "assigned but never read" case), but not if we
+ -- have pragma Unreferenced, which cancels this error.
+
+ and then (not Referenced_As_LHS_Check_Spec (E1)
+ or else not Has_Unreferenced (E1))
+
-- Check that warnings on unreferenced entities are enabled
and then
-- The unreferenced entity is E1, but post the warning
-- on the body entity for this accept statement.
- Warn_On_Unreferenced_Entity
- (E1, Body_Formal (E1, Accept_Statement => Anod));
+ if not Warnings_Off_E1 then
+ Warn_On_Unreferenced_Entity
+ (E1, Body_Formal (E1, Accept_Statement => Anod));
+ end if;
- else
+ elsif not Warnings_Off_E1 then
Unreferenced_Entities.Append (E1);
end if;
end if;
and then Instantiation_Depth (Sloc (E1)) = 0
and then Warn_On_Redundant_Constructs
then
- Unreferenced_Entities.Append (E1);
+ if not Warnings_Off_E1 then
+ Unreferenced_Entities.Append (E1);
-- Force warning on entity
- Set_Referenced (E1, False);
+ Set_Referenced (E1, False);
+ end if;
end if;
end if;
-- Recurse into nested package or block. Do not recurse into a
- -- formal package, because the correponding body is not analyzed.
+ -- formal package, because the corresponding body is not analyzed.
<<Continue>>
if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package)
case Nkind (N) is
- -- For identifier or exanded name, examine the entity involved
+ -- For identifier or expanded name, examine the entity involved
when N_Identifier | N_Expanded_Name =>
declare
or else
Earlier_In_Extended_Unit
(Sloc (N), Sloc (Unset_Reference (E))))
- and then not Warnings_Off (E)
+ and then not Has_Pragma_Unmodified_Check_Spec (E)
+ and then not Warnings_Off_Check_Spec (E)
then
-- We may have an unset reference. The first test is whether
-- this is an access to a discriminant of a record or a
function Process
(N : Node_Id) return Traverse_Result;
- -- Process function for instantation of Traverse
+ -- Process function for instantiation of Traverse
-- below. Checks if N contains reference to other
-- than a dereference.
-- The only reference to a context unit may be in a renaming
-- declaration. If this renaming declares a visible entity, do
-- not warn that the context clause could be moved to the body,
- -- because the renaming may be intented to re-export the unit.
+ -- because the renaming may be intended to re-export the unit.
-------------------------
-- Check_Inner_Package --
-- is explicitly marked by a pragma Unreferenced).
if not Referenced (Lunit)
- and then not Has_Pragma_Unreferenced (Lunit)
+ and then not Has_Unreferenced (Lunit)
then
-- Suppress warnings in internal units if not in -gnatg mode
-- (these would be junk warnings for an application program,
-- Else give the warning
else
- if not Has_Pragma_Unreferenced
- (Entity (Name (Item)))
+ if not
+ Has_Unreferenced (Entity (Name (Item)))
then
Error_Msg_N
("?no entities of & are referenced!",
Pack := Find_Package_Renaming (Munite, Lunit);
if Present (Pack)
- and then not Warnings_Off (Lunit)
- and then not Has_Pragma_Unreferenced (Pack)
+ and then not Has_Warnings_Off (Lunit)
+ and then not Has_Unreferenced (Pack)
then
Error_Msg_NE
("?no entities of & are referenced!",
is
begin
if Is_Formal (E) and then Present (Spec_Entity (E)) then
- return Has_Pragma_Unmodified (E)
- or else
- Has_Pragma_Unmodified (Spec_Entity (E));
+
+ -- Note: use of OR instead of OR ELSE here is deliberate, we want
+ -- to mess with Unmodified flags on both body and spec entities.
+
+ return Has_Unmodified (E)
+ or
+ Has_Unmodified (Spec_Entity (E));
+
else
- return Has_Pragma_Unmodified (E);
+ return Has_Unmodified (E);
end if;
end Has_Pragma_Unmodified_Check_Spec;
is
begin
if Is_Formal (E) and then Present (Spec_Entity (E)) then
- return Has_Pragma_Unreferenced (E)
- or else
- Has_Pragma_Unreferenced (Spec_Entity (E));
+
+ -- Note: use of OR here instead of OR ELSE is deliberate, we want
+ -- to mess with flags on both entities.
+
+ return Has_Unreferenced (E)
+ or
+ Has_Unreferenced (Spec_Entity (E));
+
else
- return Has_Pragma_Unreferenced (E);
+ return Has_Unreferenced (E);
end if;
end Has_Pragma_Unreferenced_Check_Spec;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Warnings_Off_Pragmas.Init;
+ Unreferenced_Entities.Init;
+ In_Out_Warnings.Init;
+ end Initialize;
+
------------------------------------
-- Never_Set_In_Source_Check_Spec --
------------------------------------
begin
if Nkind (R) in N_Has_Entity
and then Present (Entity (R))
- and then Warnings_Off (Entity (R))
+ and then Has_Warnings_Off (Entity (R))
then
return Abandon;
else
-----------------------
function No_Warn_On_In_Out (E : Entity_Id) return Boolean is
- S : constant Entity_Id := Scope (E);
+ S : constant Entity_Id := Scope (E);
+ SE : constant Entity_Id := Spec_Entity (E);
+
begin
- if Warnings_Off (S) then
+ -- Do not warn if address is taken, since funny business may be going
+ -- on in treating the parameter indirectly as IN OUT.
+
+ if Address_Taken (S)
+ or else (Present (SE) and then Address_Taken (Scope (SE)))
+ then
return True;
- elsif Address_Taken (S) then
+
+ -- Do not warn if used as a generic actual, since the generic may be
+ -- what is forcing the use of an "unnecessary" IN OUT.
+
+ elsif Used_As_Generic_Actual (S)
+ or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE)))
+ then
return True;
- elsif Used_As_Generic_Actual (S) then
+
+ -- Else test warnings off
+
+ elsif Warnings_Off_Check_Spec (S) then
return True;
- elsif Present (Spec_Entity (E)) then
- return No_Warn_On_In_Out (Spec_Entity (E));
+
+ -- All tests for suppressing warning failed
+
else
return False;
end if;
end No_Warn_On_In_Out;
- -- Start of processing for Output_Non_Modifed_In_Out_Warnings
+ -- Start of processing for Output_Non_Modified_In_Out_Warnings
begin
-- Loop through entities for which a warning may be needed
-- Suppress warning in specific cases (see details in comments for
-- No_Warn_On_In_Out), or if there is a pragma Unmodified.
- if No_Warn_On_In_Out (E1)
- or else Has_Pragma_Unmodified_Check_Spec (E1)
+ if Has_Pragma_Unmodified_Check_Spec (E1)
+ or else No_Warn_On_In_Out (E1)
then
null;
else
-- If -gnatwc is set then output message that we could be IN
- if Warn_On_Constant then
- Error_Msg_N ("?formal parameter & is not modified!", E1);
- Error_Msg_N ("\?mode could be IN instead of `IN OUT`!", E1);
+ if not Is_Trivial_Subprogram (Scope (E1)) then
+ if Warn_On_Constant then
+ Error_Msg_N
+ ("?formal parameter & is not modified!", E1);
+ Error_Msg_N
+ ("\?mode could be IN instead of `IN OUT`!", E1);
- -- We do not generate warnings for IN OUT parameters unless we
- -- have at least -gnatwu. This is deliberately inconsistent
- -- with the treatment of variables, but otherwise we get too
- -- many unexpected warnings in default mode.
+ -- We do not generate warnings for IN OUT parameters
+ -- unless we have at least -gnatwu. This is deliberately
+ -- inconsistent with the treatment of variables, but
+ -- otherwise we get too many unexpected warnings in
+ -- default mode.
- elsif Check_Unreferenced then
- Error_Msg_N ("?formal parameter& is read but "
- & "never assigned!", E1);
+ elsif Check_Unreferenced then
+ Error_Msg_N ("?formal parameter& is read but "
+ & "never assigned!", E1);
+ end if;
end if;
-- Kill any other warnings on this entity, since this is the
-- Output additional warning if present
- declare
- W : constant Node_Id := Obsolescent_Warning (E);
-
- begin
- if Present (W) then
-
- -- This is a warning continuation to start on a new line
- Name_Buffer (1) := '\';
- Name_Buffer (2) := '\';
- Name_Buffer (3) := '?';
- Name_Len := 3;
-
- -- Add characters to message, and output message. Note that
- -- we quote every character of the message since we don't
- -- want to process any insertions.
-
- 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);
+ for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop
+ if Obsolescent_Warnings.Table (J).Ent = E then
+ String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg);
+ Error_Msg_Strlen := Name_Len;
+ Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Error_Msg_N ("\\?~", N);
+ exit;
end if;
- end;
+ end loop;
end Output_Obsolescent_Entity_Warnings;
----------------------------------
end loop;
end Output_Unreferenced_Messages;
+ -----------------------------------------
+ -- Output_Unused_Warnings_Off_Warnings --
+ -----------------------------------------
+
+ procedure Output_Unused_Warnings_Off_Warnings is
+ begin
+ for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop
+ declare
+ Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J);
+ N : Node_Id renames Wentry.N;
+ E : Node_Id renames Wentry.E;
+
+ begin
+ -- Turn off Warnings_Off, or we won't get the warning!
+
+ Set_Warnings_Off (E, False);
+
+ -- Nothing to do if pragma was used to suppress a general warning
+
+ if Warnings_Off_Used (E) then
+ null;
+
+ -- If pragma was used both in unmodified and unreferenced contexts
+ -- then that's as good as the general case, no warning.
+
+ elsif Warnings_Off_Used_Unmodified (E)
+ and
+ Warnings_Off_Used_Unreferenced (E)
+ then
+ null;
+
+ -- Used only in context where Unmodified would have worked
+
+ elsif Warnings_Off_Used_Unmodified (E) then
+ Error_Msg_NE
+ ("?could use Unmodified instead of "
+ & "Warnings Off for &", Pragma_Identifier (N), E);
+
+ -- Used only in context where Unreferenced would have worked
+
+ elsif Warnings_Off_Used_Unreferenced (E) then
+ Error_Msg_NE
+ ("?could use Unreferenced instead of "
+ & "Warnings Off for &", Pragma_Identifier (N), E);
+
+ -- Not used at all
+
+ else
+ Error_Msg_NE
+ ("?pragma Warnings Off for & unused, "
+ & "could be omitted", N, E);
+ end if;
+ end;
+ end loop;
+ end Output_Unused_Warnings_Off_Warnings;
+
---------------------------
-- Referenced_Check_Spec --
---------------------------
when 'C' =>
Warn_On_Unrepped_Components := False;
+ when 'e' =>
+ Address_Clause_Overlay_Warnings := True;
+ Check_Unreferenced := True;
+ Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
+ Elab_Warnings := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Ada_2005_Compatibility := True;
+ Warn_On_All_Unread_Out_Parameters := True;
+ Warn_On_Assertion_Failure := True;
+ Warn_On_Assumed_Low_Bound := True;
+ Warn_On_Bad_Fixed_Value := True;
+ Warn_On_Constant := True;
+ Warn_On_Deleted_Code := True;
+ Warn_On_Dereference := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Hiding := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Non_Local_Exception := True;
+ Warn_On_Object_Renames_Function := True;
+ Warn_On_Obsolescent_Feature := True;
+ Warn_On_Questionable_Missing_Parens := True;
+ Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
+ Warn_On_Unrepped_Components := True;
+ Warn_On_Warnings_Off := True;
+
when 'o' =>
Warn_On_All_Unread_Out_Parameters := True;
when 'O' =>
Warn_On_All_Unread_Out_Parameters := False;
+ when 'p' =>
+ Warn_On_Parameter_Order := True;
+
+ when 'P' =>
+ Warn_On_Parameter_Order := False;
+
when 'r' =>
Warn_On_Object_Renames_Function := True;
when 'R' =>
Warn_On_Object_Renames_Function := False;
+ when 'w' =>
+ Warn_On_Warnings_Off := True;
+
+ when 'W' =>
+ Warn_On_Warnings_Off := False;
+
when 'x' =>
Warn_On_Non_Local_Exception := True;
Warn_On_Modified_Unread := True;
Warn_On_No_Value_Assigned := True;
Warn_On_Non_Local_Exception := True;
+ Warn_On_Object_Renames_Function := True;
Warn_On_Obsolescent_Feature := True;
+ Warn_On_Parameter_Order := True;
Warn_On_Questionable_Missing_Parens := True;
Warn_On_Redundant_Constructs := True;
- Warn_On_Object_Renames_Function := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unrecognized_Pragma := True;
Warn_On_Unrepped_Components := True;
Warn_On_Non_Local_Exception := False;
Warn_On_Obsolescent_Feature := False;
Warn_On_All_Unread_Out_Parameters := False;
+ Warn_On_Parameter_Order := False;
Warn_On_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False;
Warn_On_Object_Renames_Function := False;
Warn_On_Unchecked_Conversion := False;
Warn_On_Unrecognized_Pragma := False;
Warn_On_Unrepped_Components := False;
+ Warn_On_Warnings_Off := False;
when 'b' =>
Warn_On_Bad_Fixed_Value := True;
then
return;
- -- Don't warn in assert pragma, since presumably tests in such
- -- a context are very definitely intended, and might well be
+ -- Don't warn in assert or check pragma, since presumably tests in
+ -- such a context are very definitely intended, and might well be
-- known at compile time. Note that we have to test the original
-- node, since assert pragmas get rewritten at analysis time.
elsif Nkind (Original_Node (P)) = N_Pragma
- and then Chars (Original_Node (P)) = Name_Assert
+ and then (Pragma_Name (Original_Node (P)) = Name_Assert
+ or else
+ Pragma_Name (Original_Node (P)) = Name_Check)
then
return;
end if;
-- to this lower bound. If not, False is returned, and Low_Bound is
-- undefined on return.
--
- -- For now, we limite this to standard string types, so any other
+ -- For now, we limit this to standard string types, so any other
-- unconstrained types return False. We may change our minds on this
-- later on, but strings seem the most important case.
if Is_Array_Type (Typ)
and then not Is_Constrained (Typ)
and then Number_Dimensions (Typ) = 1
- and then not Warnings_Off (Typ)
and then (Root_Type (Typ) = Standard_String
or else
Root_Type (Typ) = Standard_Wide_String
or else
Root_Type (Typ) = Standard_Wide_Wide_String)
+ and then not Has_Warnings_Off (Typ)
then
LB := Type_Low_Bound (Etype (First_Index (Typ)));
begin
-- Nothing to do if subscript does not come from source (we don't
-- want to give garbage warnings on compiler expanded code, e.g. the
- -- loops generated for slice assignments. Sucb junk warnings would
+ -- loops generated for slice assignments. Such junk warnings would
-- be placed on source constructs with no subscript in sight!)
if not Comes_From_Source (Original_Node (X)) then
-- Tref (Sref) is used to scan the subscript
Pctr : Natural;
- -- Paretheses counter when scanning subscript
+ -- Parentheses counter when scanning subscript
begin
-- Tref (Sref) points to start of subscript
Next_Formal (Form2);
end loop;
- -- Here all conditionas are met, record possible unset reference
+ -- Here all conditions are met, record possible unset reference
Set_Unset_Reference (Form, Return_Node);
end if;
E : Entity_Id := Spec_E;
begin
- if not Referenced_Check_Spec (E) and then not Warnings_Off (E) then
+ if not Referenced_Check_Spec (E)
+ and then not Has_Pragma_Unreferenced_Check_Spec (E)
+ and then not Warnings_Off_Check_Spec (E)
+ then
case Ekind (E) is
when E_Variable =>
-- Case of variable that is assigned but not read. We suppress
-- the message if the variable is volatile, has an address
- -- clause, is aliasied, or is a renaming, or is imported.
+ -- clause, is aliased, or is a renaming, or is imported.
if Referenced_As_LHS_Check_Spec (E)
and then No (Address_Clause (E))
if Present (Body_E) then
E := Body_E;
end if;
- Error_Msg_NE
- ("?formal parameter & is not referenced!", E, Spec_E);
+
+ if not Is_Trivial_Subprogram (Scope (E)) then
+ Error_Msg_NE
+ ("?formal parameter & is not referenced!",
+ E, Spec_E);
+ end if;
end if;
end if;
if Is_Assignable (Ent)
and then not Is_Return_Object (Ent)
and then Present (Last_Assignment (Ent))
- and then not Warnings_Off (Ent)
- and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
and then not Is_Imported (Ent)
and then not Is_Exported (Ent)
and then Safe_To_Capture_Value (N, Ent)
+ and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
then
-- Before we issue the message, check covering exception handlers.
- -- Search up tree for enclosing statement sequences and handlers
+ -- Search up tree for enclosing statement sequences and handlers.
P := Parent (Last_Assignment (Ent));
while Present (P) loop
- -- Something is really wrong if we don't find a handled
- -- statement sequence, so just suppress the warning.
+ -- Something is really wrong if we don't find a handled statement
+ -- sequence, so just suppress the warning.
if No (P) then
Set_Last_Assignment (Ent, Empty);
-- If we are not at the top level, we regard an inner
-- exception handler as a decisive indicator that we should
-- not generate the warning, since the variable in question
- -- may be acceessed after an exception in the outer block.
+ -- may be accessed after an exception in the outer block.
if Nkind (Parent (P)) /= N_Subprogram_Body
and then Nkind (Parent (P)) /= N_Package_Body
end if;
end Warn_On_Useless_Assignments;
+ -----------------------------
+ -- Warnings_Off_Check_Spec --
+ -----------------------------
+
+ function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is
+ begin
+ if Is_Formal (E) and then Present (Spec_Entity (E)) then
+
+ -- Note: use of OR here instead of OR ELSE is deliberate, we want
+ -- to mess with flags on both entities.
+
+ return Has_Warnings_Off (E)
+ or
+ Has_Warnings_Off (Spec_Entity (E));
+
+ else
+ return Has_Warnings_Off (E);
+ end if;
+ end Warnings_Off_Check_Spec;
+
end Sem_Warn;
OSDN Git Service
