Skip to content

R
riscv-gcc-1
Commit 9a18e785 by Robert Dewar Committed by Arnaud Charlet
Options

sem_warn.ads, [...] (Warnings_Off_Pragmas): New table 

2008-03-26  Robert Dewar  <dewar@adacore.com>

	* sem_warn.ads, sem_warn.adb (Warnings_Off_Pragmas): New table
	(Initialize): New procedure
	(Output_Warnings_Off_Warnings): New procedure
	(Check_References): Suppress certain msgs if Is_Trivial_Subprogram
	(Output_Non_Modifed_In_Out_Warnings): Ditto
	(Warn_On_Unreferenced_Entity): Ditto

From-SVN: r133580
parent 26570b21
Showing with 364 additions and 119 deletions
gcc/ada/sem_warn.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -23,7 +23,6 @@ ...@@ -23,7 +23,6 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Alloc;
with Atree; use Atree; with Atree; use Atree;
with Debug; use Debug; with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
...@@ -44,7 +43,6 @@ with Sinput; use Sinput; ...@@ -44,7 +43,6 @@ with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt; with Stringt; use Stringt;
with Table;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Sem_Warn is package body Sem_Warn is
...@@ -67,9 +65,9 @@ package body Sem_Warn is ...@@ -67,9 +65,9 @@ package body Sem_Warn is
-- The reason that we defer output of these messages is that we want to -- 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 -- 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 -- 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 -- flag Used_As_Generic_Actual will be set in this case, but only at the
-- set till later. Similarly, we suppress the message if the address of -- point of usage. Similarly, we suppress the message if the address of the
-- the procedure is taken, where the flag Address_Taken may be set later. -- procedure is taken, where the flag Address_Taken may be set later.
package In_Out_Warnings is new Table.Table ( package In_Out_Warnings is new Table.Table (
Table_Component_Type => Entity_Id, Table_Component_Type => Entity_Id,
...@@ -79,6 +77,39 @@ package body Sem_Warn is ...@@ -79,6 +77,39 @@ package body Sem_Warn is
Table_Increment => Alloc.In_Out_Warnings_Increment, Table_Increment => Alloc.In_Out_Warnings_Increment,
Table_Name => "In_Out_Warnings"); 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 somme-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 -- -- Local Subprograms --
----------------------- -----------------------
...@@ -145,6 +176,10 @@ package body Sem_Warn is ...@@ -145,6 +176,10 @@ package body Sem_Warn is
-- accept statement, and the message is posted on Body_E. In all other -- accept statement, and the message is posted on Body_E. In all other
-- cases, Body_E is ignored and must be Empty. -- 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 -- -- Check_Code_Statement --
-------------------------- --------------------------
...@@ -275,16 +310,16 @@ package body Sem_Warn is ...@@ -275,16 +310,16 @@ package body Sem_Warn is
if not Is_Entity_Name (Name (N)) then if not Is_Entity_Name (Name (N)) then
return; return;
-- Forget it if warnings are suppressed on function entity
elsif Warnings_Off (Entity (Name (N))) then
return;
-- Forget it if function name is suspicious. A strange test -- Forget it if function name is suspicious. A strange test
-- but warning generation is in the heuristics business! -- but warning generation is in the heuristics business!
elsif Is_Suspicious_Function_Name (Entity (Name (N))) then elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
return; return;
-- Forget it if warnings are suppressed on function entity
elsif Has_Warnings_Off (Entity (Name (N))) then
return;
end if; end if;
-- OK, see if we have one argument -- OK, see if we have one argument
...@@ -592,6 +627,40 @@ package body Sem_Warn is ...@@ -592,6 +627,40 @@ package body Sem_Warn is
-- from another unit. This is true for entities in packages that are at -- from another unit. This is true for entities in packages that are at
-- the library level. -- 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 -- -- Missing_Subunits --
---------------------- ----------------------
...@@ -634,36 +703,6 @@ package body Sem_Warn is ...@@ -634,36 +703,6 @@ package body Sem_Warn is
end if; end if;
end Missing_Subunits; 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 -- -- Output_Reference_Error --
---------------------------- ----------------------------
...@@ -790,6 +829,17 @@ package body Sem_Warn is ...@@ -790,6 +829,17 @@ package body Sem_Warn is
end loop; end loop;
end Publicly_Referenceable; 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 -- Start of processing for Check_References
begin begin
...@@ -817,15 +867,11 @@ package body Sem_Warn is ...@@ -817,15 +867,11 @@ package body Sem_Warn is
while Present (E1) loop while Present (E1) loop
E1T := Etype (E1); E1T := Etype (E1);
-- We only look at source entities with warning flag on. We also -- We are only interested in source entities. We also don't issue
-- ignore objects whose type or base type has warnings suppressed. -- warnings within instances, since the proper place for such
-- We also don't issue warnings within instances, since the proper -- warnings is on the template when it is compiled.
-- place for such warnings is on the template when it is compiled.
if Comes_From_Source (E1) 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 and then Instantiation_Location (Sloc (E1)) = No_Location
then then
-- We are interested in variables and out/in-out parameters, but -- We are interested in variables and out/in-out parameters, but
...@@ -850,18 +896,9 @@ package body Sem_Warn is ...@@ -850,18 +896,9 @@ package body Sem_Warn is
UR := Unset_Reference (E1); UR := Unset_Reference (E1);
end if; 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 -- Special processing for access types
elsif Present (UR) if Present (UR)
and then Is_Access_Type (E1T) and then Is_Access_Type (E1T)
then then
-- For access types, the only time we made a UR entry was -- For access types, the only time we made a UR entry was
...@@ -872,7 +909,10 @@ package body Sem_Warn is ...@@ -872,7 +909,10 @@ package body Sem_Warn is
-- assignment of a pointer involving discriminant check -- assignment of a pointer involving discriminant check
-- on the designated object). -- on the designated object).
if not Warnings_Off_E1 then
Error_Msg_NE ("?& may be null!", UR, E1); Error_Msg_NE ("?& may be null!", UR, E1);
end if;
goto Continue; goto Continue;
-- Case of variable that could be a constant. Note that we -- Case of variable that could be a constant. Note that we
...@@ -916,6 +956,7 @@ package body Sem_Warn is ...@@ -916,6 +956,7 @@ package body Sem_Warn is
and then not Has_Pragma_Unreferenced_Check_Spec (E1) and then not Has_Pragma_Unreferenced_Check_Spec (E1)
and then not Has_Pragma_Unmodified_Check_Spec (E1) and then not Has_Pragma_Unmodified_Check_Spec (E1)
then then
if not Warnings_Off_E1 then
Error_Msg_N Error_Msg_N
("?& is not modified, " ("?& is not modified, "
& "could be declared constant!", & "could be declared constant!",
...@@ -923,6 +964,7 @@ package body Sem_Warn is ...@@ -923,6 +964,7 @@ package body Sem_Warn is
end if; end if;
end if; end if;
end if; end if;
end if;
-- Other cases of a variable or parameter never set in source -- Other cases of a variable or parameter never set in source
...@@ -959,12 +1001,15 @@ package body Sem_Warn is ...@@ -959,12 +1001,15 @@ package body Sem_Warn is
or else not Is_Fully_Initialized_Type (E1T)) or else not Is_Fully_Initialized_Type (E1T))
then then
-- Do not output complaint about never being assigned a -- 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 -- 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) if Has_Pragma_Unreferenced_Objects (E1T)
or else Has_Pragma_Unreferenced_Objects (E1T) or else Has_Pragma_Unmodified_Check_Spec (E1)
then then
null; null;
...@@ -985,7 +1030,7 @@ package body Sem_Warn is ...@@ -985,7 +1030,7 @@ package body Sem_Warn is
-- other method to achieve the local effect of a -- other method to achieve the local effect of a
-- modification. On the other hand if the spec and body -- modification. On the other hand if the spec and body
-- are in the same unit, we are in the package body and -- 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) if Has_Private_Declaration (E1T)
and then Present (Spec_Entity (E1)) and then Present (Spec_Entity (E1))
...@@ -996,8 +1041,8 @@ package body Sem_Warn is ...@@ -996,8 +1041,8 @@ package body Sem_Warn is
-- Suppress warning for any parameter of a dispatching -- Suppress warning for any parameter of a dispatching
-- operation, since it is quite reasonable to have an -- operation, since it is quite reasonable to have an
-- operation that is overridden, and for some subclasses -- operation that is overridden, and for some subclasses
-- needs to be IN OUT and for others the parameter does -- needs the formal to be IN OUT and for others happens
-- not happen to be assigned. -- not to assign it.
elsif Is_Dispatching_Operation elsif Is_Dispatching_Operation
(Scope (Goto_Spec_Entity (E1))) (Scope (Goto_Spec_Entity (E1)))
...@@ -1030,25 +1075,38 @@ package body Sem_Warn is ...@@ -1030,25 +1075,38 @@ package body Sem_Warn is
-- Other cases of formals -- Other cases of formals
elsif Is_Formal (E1) then elsif Is_Formal (E1) then
if not Is_Trivial_Subprogram (Scope (E1)) then
if Referenced_Check_Spec (E1) then if Referenced_Check_Spec (E1) then
if not Has_Pragma_Unmodified_Check_Spec (E1) then if not Has_Pragma_Unmodified_Check_Spec (E1)
and then not Warnings_Off_E1
then
Output_Reference_Error Output_Reference_Error
("?formal parameter& is read but " ("?formal parameter& is read but "
& "never assigned!"); & "never assigned!");
end if; end if;
else elsif not Has_Pragma_Unreferenced_Check_Spec (E1)
and then not Warnings_Off_E1
then
Output_Reference_Error Output_Reference_Error
("?formal parameter& is not referenced!"); ("?formal parameter& is not referenced!");
end if; end if;
end if;
-- Case of variable -- Case of variable
else else
if Referenced (E1) then if Referenced (E1) then
if not Has_Unmodified (E1)
and then not Warnings_Off_E1
then
Output_Reference_Error Output_Reference_Error
("?variable& is read but never assigned!"); ("?variable& is read but never assigned!");
else end if;
elsif not Has_Unreferenced (E1)
and then not Warnings_Off_E1
then
Output_Reference_Error Output_Reference_Error
("?variable& is never read and never assigned!"); ("?variable& is never read and never assigned!");
end if; end if;
...@@ -1058,6 +1116,7 @@ package body Sem_Warn is ...@@ -1058,6 +1116,7 @@ package body Sem_Warn is
if Ekind (E1) = E_Variable if Ekind (E1) = E_Variable
and then Present (Hiding_Loop_Variable (E1)) and then Present (Hiding_Loop_Variable (E1))
and then not Warnings_Off_E1
then then
Error_Msg_N Error_Msg_N
("?for loop implicitly declares loop variable!", ("?for loop implicitly declares loop variable!",
...@@ -1100,18 +1159,21 @@ package body Sem_Warn is ...@@ -1100,18 +1159,21 @@ package body Sem_Warn is
-- are only for functions, and functions do not allow OUT -- are only for functions, and functions do not allow OUT
-- parameters.) -- parameters.)
if not Is_Trivial_Subprogram (Scope (E1)) then
if Nkind (UR) = N_Simple_Return_Statement if Nkind (UR) = N_Simple_Return_Statement
and then not Has_Pragma_Unmodified_Check_Spec (E1) and then not Has_Pragma_Unmodified_Check_Spec (E1)
then then
if not Warnings_Off_E1 then
Error_Msg_NE Error_Msg_NE
("?OUT parameter& not set before return", UR, E1); ("?OUT parameter& not set before return", UR, E1);
end if;
-- If the unset reference is prefix of a selected component -- If the unset reference is a selected component
-- that comes from source, mention the component as well. If -- prefix from source, mention the component as well.
-- the selected component comes from expansion, all we know -- If the selected component comes from expansion, all
-- is that the entity is not fully initialized at the point -- we know is that the entity is not fully initialized
-- of the reference. Locate an unintialized component to get -- at the point of the reference. Locate a random
-- a better error message. -- unintialized component to get a better message.
elsif Nkind (Parent (UR)) = N_Selected_Component then elsif Nkind (Parent (UR)) = N_Selected_Component then
Error_Msg_Node_2 := Selector_Name (Parent (UR)); Error_Msg_Node_2 := Selector_Name (Parent (UR));
...@@ -1142,33 +1204,43 @@ package body Sem_Warn is ...@@ -1142,33 +1204,43 @@ package body Sem_Warn is
-- For access types, UR was only set for dereferences, -- For access types, UR was only set for dereferences,
-- so the issue is that the value may be null. -- 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 if Is_Access_Type (Etype (Parent (UR))) then
Error_Msg_N ("?`&.&` may be null!", UR); Error_Msg_N ("?`&.&` may be null!", UR);
else else
Error_Msg_N Error_Msg_N
("?`&.&` may be referenced before it has a value!", ("?`&.&` may be referenced before "
UR); & "it has a value!", UR);
end if;
end if;
end if; end if;
-- All other cases of unset reference active -- All other cases of unset reference active
else elsif not Warnings_Off_E1 then
Error_Msg_N Error_Msg_N
("?& may be referenced before it has a value!", ("?& may be referenced before it has a value!",
UR); UR);
end if; end if;
end if;
goto Continue; goto Continue;
end if; end if;
end if; end if;
-- Then check for unreferenced entities. Note that we are only -- Then check for unreferenced entities. Note that we are only
-- interested in entities which do not have the Referenced flag -- interested in entities whose Referenced flag is not set.
-- set. The Referenced_As_LHS flag is interesting only if the
-- Referenced flag is not set.
if not Referenced_Check_Spec (E1) 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 -- Check that warnings on unreferenced entities are enabled
and then and then
...@@ -1324,10 +1396,12 @@ package body Sem_Warn is ...@@ -1324,10 +1396,12 @@ package body Sem_Warn is
-- The unreferenced entity is E1, but post the warning -- The unreferenced entity is E1, but post the warning
-- on the body entity for this accept statement. -- on the body entity for this accept statement.
if not Warnings_Off_E1 then
Warn_On_Unreferenced_Entity Warn_On_Unreferenced_Entity
(E1, Body_Formal (E1, Accept_Statement => Anod)); (E1, Body_Formal (E1, Accept_Statement => Anod));
end if;
else elsif not Warnings_Off_E1 then
Unreferenced_Entities.Append (E1); Unreferenced_Entities.Append (E1);
end if; end if;
end if; end if;
...@@ -1343,6 +1417,7 @@ package body Sem_Warn is ...@@ -1343,6 +1417,7 @@ package body Sem_Warn is
and then Instantiation_Depth (Sloc (E1)) = 0 and then Instantiation_Depth (Sloc (E1)) = 0
and then Warn_On_Redundant_Constructs and then Warn_On_Redundant_Constructs
then then
if not Warnings_Off_E1 then
Unreferenced_Entities.Append (E1); Unreferenced_Entities.Append (E1);
-- Force warning on entity -- Force warning on entity
...@@ -1350,6 +1425,7 @@ package body Sem_Warn is ...@@ -1350,6 +1425,7 @@ package body Sem_Warn is
Set_Referenced (E1, False); Set_Referenced (E1, False);
end if; end if;
end if; end if;
end if;
-- Recurse into nested package or block. Do not recurse into a -- Recurse into nested package or block. Do not recurse into a
-- formal package, because the correponding body is not analyzed. -- formal package, because the correponding body is not analyzed.
...@@ -1478,7 +1554,8 @@ package body Sem_Warn is ...@@ -1478,7 +1554,8 @@ package body Sem_Warn is
or else or else
Earlier_In_Extended_Unit Earlier_In_Extended_Unit
(Sloc (N), Sloc (Unset_Reference (E)))) (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 then
-- We may have an unset reference. The first test is whether -- We may have an unset reference. The first test is whether
-- this is an access to a discriminant of a record or a -- this is an access to a discriminant of a record or a
...@@ -1967,7 +2044,7 @@ package body Sem_Warn is ...@@ -1967,7 +2044,7 @@ package body Sem_Warn is
-- is explicitly marked by a pragma Unreferenced). -- is explicitly marked by a pragma Unreferenced).
if not Referenced (Lunit) if not Referenced (Lunit)
and then not Has_Pragma_Unreferenced (Lunit) and then not Has_Unreferenced (Lunit)
then then
-- Suppress warnings in internal units if not in -gnatg mode -- Suppress warnings in internal units if not in -gnatg mode
-- (these would be junk warnings for an application program, -- (these would be junk warnings for an application program,
...@@ -2060,8 +2137,8 @@ package body Sem_Warn is ...@@ -2060,8 +2137,8 @@ package body Sem_Warn is
-- Else give the warning -- Else give the warning
else else
if not Has_Pragma_Unreferenced if not
(Entity (Name (Item))) Has_Unreferenced (Entity (Name (Item)))
then then
Error_Msg_N Error_Msg_N
("?no entities of & are referenced!", ("?no entities of & are referenced!",
...@@ -2076,8 +2153,8 @@ package body Sem_Warn is ...@@ -2076,8 +2153,8 @@ package body Sem_Warn is
Pack := Find_Package_Renaming (Munite, Lunit); Pack := Find_Package_Renaming (Munite, Lunit);
if Present (Pack) if Present (Pack)
and then not Warnings_Off (Lunit) and then not Has_Warnings_Off (Lunit)
and then not Has_Pragma_Unreferenced (Pack) and then not Has_Unreferenced (Pack)
then then
Error_Msg_NE Error_Msg_NE
("?no entities of & are referenced!", ("?no entities of & are referenced!",
...@@ -2276,11 +2353,16 @@ package body Sem_Warn is ...@@ -2276,11 +2353,16 @@ package body Sem_Warn is
is is
begin begin
if Is_Formal (E) and then Present (Spec_Entity (E)) then if Is_Formal (E) and then Present (Spec_Entity (E)) then
return Has_Pragma_Unmodified (E)
or else -- Note: use of OR instead of OR ELSE here is deliberate, we want
Has_Pragma_Unmodified (Spec_Entity (E)); -- to mess with Unmodified flags on both body and spec entities.
return Has_Unmodified (E)
or
Has_Unmodified (Spec_Entity (E));
else else
return Has_Pragma_Unmodified (E); return Has_Unmodified (E);
end if; end if;
end Has_Pragma_Unmodified_Check_Spec; end Has_Pragma_Unmodified_Check_Spec;
...@@ -2293,14 +2375,30 @@ package body Sem_Warn is ...@@ -2293,14 +2375,30 @@ package body Sem_Warn is
is is
begin begin
if Is_Formal (E) and then Present (Spec_Entity (E)) then if Is_Formal (E) and then Present (Spec_Entity (E)) then
return Has_Pragma_Unreferenced (E)
or else -- Note: use of OR here instead of OR ELSE is deliberate, we want
Has_Pragma_Unreferenced (Spec_Entity (E)); -- to mess with flags on both entities.
return Has_Unreferenced (E)
or
Has_Unreferenced (Spec_Entity (E));
else else
return Has_Pragma_Unreferenced (E); return Has_Unreferenced (E);
end if; end if;
end Has_Pragma_Unreferenced_Check_Spec; 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 -- -- Never_Set_In_Source_Check_Spec --
------------------------------------ ------------------------------------
...@@ -2341,7 +2439,7 @@ package body Sem_Warn is ...@@ -2341,7 +2439,7 @@ package body Sem_Warn is
begin begin
if Nkind (R) in N_Has_Entity if Nkind (R) in N_Has_Entity
and then Present (Entity (R)) and then Present (Entity (R))
and then Warnings_Off (Entity (R)) and then Has_Warnings_Off (Entity (R))
then then
return Abandon; return Abandon;
else else
...@@ -2384,15 +2482,32 @@ package body Sem_Warn is ...@@ -2384,15 +2482,32 @@ package body Sem_Warn is
function No_Warn_On_In_Out (E : Entity_Id) return Boolean is 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 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; 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; return True;
elsif Used_As_Generic_Actual (S) then
-- Else test warnings off
elsif Warnings_Off_Check_Spec (S) then
return True; return True;
elsif Present (Spec_Entity (E)) then
return No_Warn_On_In_Out (Spec_Entity (E)); -- All tests for suppressing warning failed
else else
return False; return False;
end if; end if;
...@@ -2411,8 +2526,8 @@ package body Sem_Warn is ...@@ -2411,8 +2526,8 @@ package body Sem_Warn is
-- Suppress warning in specific cases (see details in comments for -- Suppress warning in specific cases (see details in comments for
-- No_Warn_On_In_Out), or if there is a pragma Unmodified. -- No_Warn_On_In_Out), or if there is a pragma Unmodified.
if No_Warn_On_In_Out (E1) if Has_Pragma_Unmodified_Check_Spec (E1)
or else Has_Pragma_Unmodified_Check_Spec (E1) or else No_Warn_On_In_Out (E1)
then then
null; null;
...@@ -2421,19 +2536,24 @@ package body Sem_Warn is ...@@ -2421,19 +2536,24 @@ package body Sem_Warn is
else else
-- If -gnatwc is set then output message that we could be IN -- If -gnatwc is set then output message that we could be IN
if not Is_Trivial_Subprogram (Scope (E1)) then
if Warn_On_Constant then if Warn_On_Constant then
Error_Msg_N ("?formal parameter & is not modified!", E1); Error_Msg_N
Error_Msg_N ("\?mode could be IN instead of `IN OUT`!", E1); ("?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 -- We do not generate warnings for IN OUT parameters
-- have at least -gnatwu. This is deliberately inconsistent -- unless we have at least -gnatwu. This is deliberately
-- with the treatment of variables, but otherwise we get too -- inconsistent with the treatment of variables, but
-- many unexpected warnings in default mode. -- otherwise we get too many unexpected warnings in
-- default mode.
elsif Check_Unreferenced then elsif Check_Unreferenced then
Error_Msg_N ("?formal parameter& is read but " Error_Msg_N ("?formal parameter& is read but "
& "never assigned!", E1); & "never assigned!", E1);
end if; end if;
end if;
-- Kill any other warnings on this entity, since this is the -- Kill any other warnings on this entity, since this is the
-- one that should dominate any other unreferenced warning. -- one that should dominate any other unreferenced warning.
...@@ -2600,6 +2720,62 @@ package body Sem_Warn is ...@@ -2600,6 +2720,62 @@ package body Sem_Warn is
end loop; end loop;
end Output_Unreferenced_Messages; 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 -- -- Referenced_Check_Spec --
--------------------------- ---------------------------
...@@ -2674,6 +2850,12 @@ package body Sem_Warn is ...@@ -2674,6 +2850,12 @@ package body Sem_Warn is
when 'R' => when 'R' =>
Warn_On_Object_Renames_Function := False; Warn_On_Object_Renames_Function := False;
when 'w' =>
Warn_On_Warnings_Off := True;
when 'W' =>
Warn_On_Warnings_Off := False;
when 'x' => when 'x' =>
Warn_On_Non_Local_Exception := True; Warn_On_Non_Local_Exception := True;
...@@ -2746,6 +2928,7 @@ package body Sem_Warn is ...@@ -2746,6 +2928,7 @@ package body Sem_Warn is
Warn_On_Unchecked_Conversion := False; Warn_On_Unchecked_Conversion := False;
Warn_On_Unrecognized_Pragma := False; Warn_On_Unrecognized_Pragma := False;
Warn_On_Unrepped_Components := False; Warn_On_Unrepped_Components := False;
Warn_On_Warnings_Off := False;
when 'b' => when 'b' =>
Warn_On_Bad_Fixed_Value := True; Warn_On_Bad_Fixed_Value := True;
...@@ -2997,7 +3180,7 @@ package body Sem_Warn is ...@@ -2997,7 +3180,7 @@ package body Sem_Warn is
-- node, since assert pragmas get rewritten at analysis time. -- node, since assert pragmas get rewritten at analysis time.
elsif Nkind (Original_Node (P)) = N_Pragma elsif Nkind (Original_Node (P)) = N_Pragma
and then Chars (Original_Node (P)) = Name_Assert and then Pragma_Name (Original_Node (P)) = Name_Assert
then then
return; return;
end if; end if;
...@@ -3100,12 +3283,12 @@ package body Sem_Warn is ...@@ -3100,12 +3283,12 @@ package body Sem_Warn is
if Is_Array_Type (Typ) if Is_Array_Type (Typ)
and then not Is_Constrained (Typ) and then not Is_Constrained (Typ)
and then Number_Dimensions (Typ) = 1 and then Number_Dimensions (Typ) = 1
and then not Warnings_Off (Typ)
and then (Root_Type (Typ) = Standard_String and then (Root_Type (Typ) = Standard_String
or else or else
Root_Type (Typ) = Standard_Wide_String Root_Type (Typ) = Standard_Wide_String
or else or else
Root_Type (Typ) = Standard_Wide_Wide_String) Root_Type (Typ) = Standard_Wide_Wide_String)
and then not Has_Warnings_Off (Typ)
then then
LB := Type_Low_Bound (Etype (First_Index (Typ))); LB := Type_Low_Bound (Etype (First_Index (Typ)));
...@@ -3412,7 +3595,10 @@ package body Sem_Warn is ...@@ -3412,7 +3595,10 @@ package body Sem_Warn is
E : Entity_Id := Spec_E; E : Entity_Id := Spec_E;
begin 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 case Ekind (E) is
when E_Variable => when E_Variable =>
...@@ -3494,8 +3680,12 @@ package body Sem_Warn is ...@@ -3494,8 +3680,12 @@ package body Sem_Warn is
if Present (Body_E) then if Present (Body_E) then
E := Body_E; E := Body_E;
end if; end if;
if not Is_Trivial_Subprogram (Scope (E)) then
Error_Msg_NE Error_Msg_NE
("?formal parameter & is not referenced!", E, Spec_E); ("?formal parameter & is not referenced!",
E, Spec_E);
end if;
end if; end if;
end if; end if;
...@@ -3585,20 +3775,19 @@ package body Sem_Warn is ...@@ -3585,20 +3775,19 @@ package body Sem_Warn is
if Is_Assignable (Ent) if Is_Assignable (Ent)
and then not Is_Return_Object (Ent) and then not Is_Return_Object (Ent)
and then Present (Last_Assignment (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_Imported (Ent)
and then not Is_Exported (Ent) and then not Is_Exported (Ent)
and then Safe_To_Capture_Value (N, Ent) and then Safe_To_Capture_Value (N, Ent)
and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
then then
-- Before we issue the message, check covering exception handlers. -- 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)); P := Parent (Last_Assignment (Ent));
while Present (P) loop while Present (P) loop
-- Something is really wrong if we don't find a handled -- Something is really wrong if we don't find a handled statement
-- statement sequence, so just suppress the warning. -- sequence, so just suppress the warning.
if No (P) then if No (P) then
Set_Last_Assignment (Ent, Empty); Set_Last_Assignment (Ent, Empty);
...@@ -3712,4 +3901,24 @@ package body Sem_Warn is ...@@ -3712,4 +3901,24 @@ package body Sem_Warn is
end if; end if;
end Warn_On_Useless_Assignments; 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; end Sem_Warn;
gcc/ada/sem_warn.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- 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 -- -- 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- --
...@@ -27,14 +27,44 @@ ...@@ -27,14 +27,44 @@
-- about uses of uninitialized variables and unused with's. It also has -- about uses of uninitialized variables and unused with's. It also has
-- some unrelated routines related to the generation of warnings. -- some unrelated routines related to the generation of warnings.
with Alloc; use Alloc;
with Table;
with Types; use Types; with Types; use Types;
package Sem_Warn is package Sem_Warn is
------------------------
-- Warnings Off Table --
------------------------
type Warnings_Off_Entry is record
N : Node_Id;
-- A pragma Warnings (Off, ent) node
E : Entity_Id;
-- The entity involved
end record;
-- An entry is made in the following table for any valid Pragma Warnings
-- (Off, entity) encountered while Opt.Warn_On_Warnings_Off is True. It
-- is used to generate warnings on any of these pragmas that turn out not
-- to be needed, or that could be replaced by Unmodified/Unreferenced.
package Warnings_Off_Pragmas is new Table.Table (
Table_Component_Type => Warnings_Off_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Warnings_Off_Pragmas_Initial,
Table_Increment => Alloc.Warnings_Off_Pragmas_Increment,
Table_Name => "Name_Warnings_Off_Pragmas");
-------------------- --------------------
-- Initialization -- -- Initialization --
-------------------- --------------------
procedure Initialize;
-- Initialize this package for new compilation
function Set_Warning_Switch (C : Character) return Boolean; function Set_Warning_Switch (C : Character) return Boolean;
-- This function sets the warning switch or switches corresponding to the -- This function sets the warning switch or switches corresponding to the
-- given character. It is used to process a -gnatw switch on the command -- given character. It is used to process a -gnatw switch on the command
...@@ -121,6 +151,12 @@ package Sem_Warn is ...@@ -121,6 +151,12 @@ package Sem_Warn is
-- the compilation process (see Check_Unset_Reference for further -- the compilation process (see Check_Unset_Reference for further
-- details). This procedure outputs waiting warnings, if any. -- details). This procedure outputs waiting warnings, if any.
procedure Output_Unused_Warnings_Off_Warnings;
-- Warnings about pragma Warnings (Off, ent) statements that are unused,
-- or could be replaced by Unmodified/Unreferenced pragmas, are collected
-- till the end of the compilation process. This procedure outputs waiting
-- warnings if any.
---------------------------- ----------------------------
-- Other Warning Routines -- -- Other Warning Routines --
---------------------------- ----------------------------
......
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