OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_ch5.adb, [...]: Update handling of assigned value/unreferenced warnings

Browse Source 
2007-12-06  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb, s-taskin.adb, a-ciorma.adb, a-coorma.adb, a-cohama.adb, 
	a-cihama.adb, g-awk.adb, 
	s-inmaop-posix.adb: Update handling of assigned value/unreferenced
	warnings

	* exp_smem.adb: Update handling of assigned value/unreferenced warnings

	* sem.adb: Update handling of assigned value/unreferenced warnings

	* a-exexpr-gcc.adb: Add a pragma warnings off for boolean return

	* lib-xref.ads: Improve documentation for k xref type

	* lib-xref.adb: 
	Update handling of assigned value/unreferenced warnings
	(Generate_Reference): Warning for reference to entity for which a
	pragma Unreferenced has been given should be unconditional.
	If the entity is a discriminal, mark the original
	discriminant as referenced.

	* sem_warn.ads, sem_warn.adb
	(Check_One_Unit): Test Renamed_In_Spec to control giving warning for
	no entities referenced in package
	(Check_One_Unit): Don't give message about no entities referenced in
	a package if a pragma Unreferenced has appeared.
	Handle new warning flag -gnatw.a/-gnatw.A
	Update handling of assigned value/unreferenced warnings

	* atree.h: Add flags up to Flag247
	(Flag231): New macro.

From-SVN: r130815
This commit is contained in:
Robert Dewar 2007-12-13 11:19:43 +01:00 committed by Arnaud Charlet
parent 0312b36424
commit 561b584987
16 changed files with 335 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gcc/ada/a-cihama.adb
View File

@ -967,9 +967,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
pragma Unreferenced (E);
begin
Process (K, E);

2
gcc/ada/a-ciorma.adb
View File

@ -1302,9 +1302,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
pragma Unreferenced (E);
begin
Process (K, E);

3
gcc/ada/a-cohama.adb
View File

@ -852,9 +852,10 @@ package body Ada.Containers.Hashed_Maps is
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
pragma Unreferenced (E);
begin
Process (K, E);
exception
when others =>
L := L - 1;

2
gcc/ada/a-coorma.adb
View File

@ -1183,9 +1183,7 @@ package body Ada.Containers.Ordered_Maps is
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
pragma Unreferenced (E);
begin
Process (K, E);

17
gcc/ada/a-exexpr-gcc.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -242,18 +242,19 @@ package body Exception_Propagation is
-- Copy all the components of Source to Target as well as the
-- Private_Data pointer.
------------------------------------------------------------
-- Accessors to basic components of a GNAT exception data --
------------------------------------------------------------
--------------------------------------------------------------------
-- Accessors to Basic Components of a GNAT Exception Data Pointer --
--------------------------------------------------------------------
-- As of today, these are only used by the C implementation of the
-- GCC propagation personality routine to avoid having to rely on a C
-- As of today, these are only used by the C implementation of the GCC
-- propagation personality routine to avoid having to rely on a C
-- counterpart of the whole exception_data structure, which is both
-- painful and error prone. These subprograms could be moved to a
-- more widely visible location if need be.
-- painful and error prone. These subprograms could be moved to a more
-- widely visible location if need be.
function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
pragma Warnings (Off, Is_Handled_By_Others);
function Language_For (E : Exception_Data_Ptr) return Character;
pragma Export (C, Language_For, "__gnat_language_for");

18
gcc/ada/atree.h
View File

@ -726,6 +726,7 @@ extern Node_Id Current_Error_Node;
#define Flag213(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag213)
#define Flag214(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag214)
#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag215)
#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag216)
#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag217)
#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag218)
@ -741,3 +742,20 @@ extern Node_Id Current_Error_Node;
#define Flag228(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag228)
#define Flag229(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag229)
#define Flag230(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag230)
#define Flag231(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag231)
#define Flag232(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag232)
#define Flag233(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag233)
#define Flag234(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag234)
#define Flag235(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag235)
#define Flag236(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag236)
#define Flag237(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag237)
#define Flag238(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag238)
#define Flag239(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag239)
#define Flag240(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag240)
#define Flag241(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag241)
#define Flag242(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag242)
#define Flag243(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag243)
#define Flag244(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag244)
#define Flag245(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag245)
#define Flag246(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag246)
#define Flag247(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag247)

22
gcc/ada/exp_smem.adb
View File

@ -245,17 +245,25 @@ package body Exp_Smem is
-------------------
function Is_Out_Actual (N : Node_Id) return Boolean is
Kind : Entity_Kind;
Call : Node_Id;
Formal : Entity_Id;
Call : Node_Id;
begin
Find_Actual_Mode (N, Kind, Call);
Find_Actual (N, Formal, Call);
if Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter then
Insert_Node := Call;
return True;
else
if No (Formal) then
return False;
else
if Ekind (Formal) = E_Out_Parameter
or else
Ekind (Formal) = E_In_Out_Parameter
then
Insert_Node := Call;
return True;
else
return False;
end if;
end if;
end Is_Out_Actual;

1
gcc/ada/g-awk.adb
View File

@ -1475,7 +1475,6 @@ package body GNAT.AWK is
procedure Split_Line (Session : Session_Type) is
Fields : Field_Table.Instance renames Session.Data.Fields;
pragma Unreferenced (Fields);
begin
Field_Table.Init (Fields);
Split.Current_Line (Session.Data.Separators.all, Session);

138
gcc/ada/lib-xref.adb
View File

@ -167,8 +167,8 @@ package body Lib.Xref is
if Sloc (Entity (N)) /= Standard_Location then
Generate_Reference (Entity (N), N);
-- A reference to an implicit inequality operator is a also a
-- reference to the user-defined equality.
-- A reference to an implicit inequality operator is also a reference
-- to the user-defined equality.
if Nkind (N) = N_Op_Ne
and then not Comes_From_Source (Entity (N))
@ -200,11 +200,11 @@ package body Lib.Xref is
------------------------
procedure Generate_Reference
(E : Entity_Id;
N : Node_Id;
Typ : Character := 'r';
Set_Ref : Boolean := True;
Force : Boolean := False)
(E : Entity_Id;
N : Node_Id;
Typ : Character := 'r';
Set_Ref : Boolean := True;
Force : Boolean := False)
is
Indx : Nat;
Nod : Node_Id;
@ -212,9 +212,12 @@ package body Lib.Xref is
Def : Source_Ptr;
Ent : Entity_Id;
Call : Node_Id;
Formal : Entity_Id;
-- Used for call to Find_Actual
Kind : Entity_Kind;
Call : Node_Id;
-- Arguments used in call to Find_Actual_Mode
-- If Formal is non-Empty, then its Ekind, otherwise E_Void
function Is_On_LHS (Node : Node_Id) return Boolean;
-- Used to check if a node is on the left hand side of an assignment.
@ -256,7 +259,7 @@ package body Lib.Xref is
return False;
end if;
-- Immediat return if appeared as OUT parameter
-- Immediate return if appeared as OUT parameter
if Kind = E_Out_Parameter then
return True;
@ -311,7 +314,13 @@ package body Lib.Xref is
begin
pragma Assert (Nkind (E) in N_Entity);
Find_Actual_Mode (N, Kind, Call);
Find_Actual (N, Formal, Call);
if Present (Formal) then
Kind := Ekind (Formal);
else
Kind := E_Void;
end if;
-- Check for obsolescent reference to package ASCII. GNAT treats this
-- element of annex J specially since in practice, programs make a lot
@ -407,25 +416,45 @@ package body Lib.Xref is
if Set_Ref then
-- For a variable that appears on the left side of an assignment
-- statement, we set the Referenced_As_LHS flag since this is indeed
-- a left hand side. We also set the Referenced_As_LHS flag of a
-- prefix of selected or indexed component.
-- Assignable object appearing on left side of assignment or as
-- an out parameter.
if (Ekind (E) = E_Variable or else Is_Formal (E))
if Is_Assignable (E)
and then Is_On_LHS (N)
and then Ekind (E) /= E_In_Out_Parameter
then
-- If we have the OUT parameter case and the warning mode for
-- OUT parameters is not set, treat this as an ordinary reference
-- since we don't want warnings about it being unset.
-- For objects that are renamings, just set as simply referenced
-- we do not try to do assignment type tracking in this case.
if Kind = E_Out_Parameter and not Warn_On_Out_Parameter_Unread then
if Present (Renamed_Object (E)) then
Set_Referenced (E);
-- For other cases, set referenced on LHS
-- Out parameter case
elsif Kind = E_Out_Parameter then
-- If warning mode for all out parameters is set, or this is
-- the only warning parameter, then we want to mark this for
-- later warning logic by setting Referenced_As_Out_Parameter
if Warn_On_Modified_As_Out_Parameter (Formal) then
Set_Referenced_As_Out_Parameter (E, True);
Set_Referenced_As_LHS (E, False);
-- For OUT parameter not covered by the above cases, we simply
-- regard it as a normal reference (in this case we do not
-- want any of the warning machinery for out parameters).
else
Set_Referenced (E);
end if;
-- For the left hand of an assignment case, we do nothing here.
-- The processing for Analyze_Assignment_Statement will set the
-- Referenced_As_LHS flag.
else
Set_Referenced_As_LHS (E);
null;
end if;
-- Check for a reference in a pragma that should not count as a
@ -469,33 +498,33 @@ package body Lib.Xref is
-- All other cases
else
-- Special processing for IN OUT and OUT parameters, where we
-- have an implicit assignment to a simple variable.
-- Special processing for IN OUT parameters, where we have an
-- implicit assignment to a simple variable.
if (Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter)
and then Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Assignable (Entity (N))
if Kind = E_In_Out_Parameter
and then Is_Assignable (E)
then
-- Record implicit assignment unless we have an intrinsic
-- subprogram, which is most likely an instantiation of
-- Unchecked_Deallocation which we do not want to consider
-- as an assignment since it generates false positives. We
-- also exclude the case of an IN OUT parameter to a procedure
-- called Free, since we suspect similar semantics.
-- For sure this counts as a normal read reference
if Is_Entity_Name (Name (Call))
Set_Referenced (E);
Set_Last_Assignment (E, Empty);
-- We count it as being referenced as an out parameter if the
-- option is set to warn on all out parameters, except that we
-- have a special exclusion for an intrinsic subprogram, which
-- is most likely an instantiation of Unchecked_Deallocation
-- which we do not want to consider as an assignment since it
-- generates false positives. We also exclude the case of an
-- IN OUT parameter if the name of the procedure is Free,
-- since we suspect similar semantics.
if Warn_On_All_Unread_Out_Parameters
and then Is_Entity_Name (Name (Call))
and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
and then (Kind /= E_In_Out_Parameter
or else Chars (Name (Call)) /= Name_Free)
and then Chars (Name (Call)) /= Name_Free
then
Set_Referenced_As_LHS (E);
end if;
-- For IN OUT case, treat as also being normal reference
if Kind = E_In_Out_Parameter then
Set_Referenced (E);
Set_Referenced_As_Out_Parameter (E, True);
Set_Referenced_As_LHS (E, False);
end if;
-- Any other occurrence counts as referencing the entity
@ -549,7 +578,7 @@ package body Lib.Xref is
while Present (BE) loop
if Chars (BE) = Chars (E) then
Error_Msg_NE
("?pragma Unreferenced given for&", N, BE);
("?pragma Unreferenced given for&!", N, BE);
exit;
end if;
@ -560,7 +589,7 @@ package body Lib.Xref is
-- Here we issue the warning, since this is a real reference
else
Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
Error_Msg_NE ("?pragma Unreferenced given for&!", N, E);
end if;
end if;
@ -664,6 +693,15 @@ package body Lib.Xref is
then
Ent := Original_Record_Component (E);
-- If this is an expanded reference to a discriminant, recover the
-- original discriminant, which gets the reference.
elsif Ekind (E) = E_In_Parameter
and then Present (Discriminal_Link (E))
then
Ent := Discriminal_Link (E);
Set_Referenced (Ent);
-- Ignore reference to any other entity that is not from source
else
@ -1424,11 +1462,13 @@ package body Lib.Xref is
(Int (Get_Logical_Line_Number (Sloc (Tref))));
declare
Ent : Entity_Id := Tref;
Kind : constant Entity_Kind := Ekind (Ent);
Ctyp : Character := Xref_Entity_Letters (Kind);
Ent : Entity_Id;
Ctyp : Character;
begin
Ent := Tref;
Ctyp := Xref_Entity_Letters (Ekind (Ent));
if Ctyp = '+'
and then Present (Full_View (Ent))
then

39
gcc/ada/lib-xref.ads
View File

@ -237,8 +237,33 @@ package Lib.Xref is
-- source node that generates the implicit reference, and it is
-- useful to record this one.
-- k is used to denote a reference to the parent unit, in the
-- cross-reference line for a child unit.
-- k is another non-standard reference type, used to record a
-- reference from a child unit to its parent. For various cross-
-- referencing tools, we need a pointer from the xref entries for
-- the child to the parent. This is the opposite way round from
-- normal xref entries, since the reference is *from* the child
-- unit *to* the parent unit, yet appears in the xref entries for
-- the child. Consider this example:
--
-- package q is
-- end;
-- package q.r is
-- end q.r;
--
-- The ali file for q-r.ads has these entries
--
-- D q.ads
-- D q-r.ads
-- D system.ads
-- X 1 q.ads
-- 1K9*q 2e4 2|1r9 2r5
-- X 2 q-r.ads
-- 1K11*r 1|1k9 2|2l7 2e8
--
-- Here the 2|1r9 entry appearing in the section for the parent
-- is the normal reference from the child to the parent. The 1k9
-- entry in the section for the child duplicates this information
-- but appears in the child rather than the parent.
-- l is used to identify the occurrence in the source of the
-- name on an end line. This is just a syntactic reference
@ -568,11 +593,11 @@ package Lib.Xref is
-- a renaming of a predefined operator.
procedure Generate_Reference
(E : Entity_Id;
N : Node_Id;
Typ : Character := 'r';
Set_Ref : Boolean := True;
Force : Boolean := False);
(E : Entity_Id;
N : Node_Id;
Typ : Character := 'r';
Set_Ref : Boolean := True;
Force : Boolean := False);
-- This procedure is called to record a reference. N is the location
-- of the reference and E is the referenced entity. Typ is one of:
--

7
gcc/ada/s-inmaop-posix.adb
View File

@ -60,8 +60,9 @@ package body System.Interrupt_Management.Operations is
Initial_Action : array (Signal) of aliased struct_sigaction;
Default_Action : aliased struct_sigaction;
pragma Warnings (Off, Default_Action);
Ignore_Action : aliased struct_sigaction;
Ignore_Action : aliased struct_sigaction;
----------------------------
-- Thread_Block_Interrupt --
@ -136,11 +137,11 @@ package body System.Interrupt_Management.Operations is
--------------------
function Interrupt_Wait
(Mask : access Interrupt_Mask)
return Interrupt_ID
(Mask : access Interrupt_Mask) return Interrupt_ID
is
Result : Interfaces.C.int;
Sig : aliased Signal;
begin
Result := sigwait (Mask, Sig'Access);

6
gcc/ada/s-taskin.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -160,9 +160,11 @@ package body System.Tasking is
procedure Initialize is
T : Task_Id;
Success : Boolean;
Base_Priority : Any_Priority;
Success : Boolean;
pragma Warnings (Off, Success);
begin
if Initialized then
return;

7
gcc/ada/sem.adb
View File

@ -727,6 +727,7 @@ package body Sem is
To : Entity_Id)
is
Found : Boolean;
pragma Warnings (Off, Found);
procedure Search_Stack
(Top : Suppress_Stack_Entry_Ptr;
@ -1282,10 +1283,10 @@ package body Sem is
S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
S_GNAT_Mode : constant Boolean := GNAT_Mode;
S_Discard_Names : constant Boolean := Global_Discard_Names;
Generic_Main : constant Boolean :=
Nkind (Unit (Cunit (Main_Unit)))
in N_Generic_Declaration;
Generic_Main : constant Boolean :=
Nkind (Unit (Cunit (Main_Unit)))
in N_Generic_Declaration;
-- If the main unit is generic, every compiled unit, including its
-- context, is compiled with expansion disabled.

21
gcc/ada/sem_ch5.adb
View File

@ -220,9 +220,7 @@ package body Sem_Ch5 is
-- If assignment operand is a component reference, then we get the
-- actual subtype of the component for the unconstrained case.
elsif
(Nkind (Opnd) = N_Selected_Component
or else Nkind (Opnd) = N_Explicit_Dereference)
elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
@ -685,6 +683,17 @@ package body Sem_Ch5 is
Check_Elab_Assign (Lhs);
end if;
-- Set Referenced_As_LHS if appropriate. We only set this flag if the
-- assignment is a source assignment in the extended main source unit.
-- We are not interested in any reference information outside this
-- context, or in compiler generated assignment statements.
if Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Lhs)
then
Set_Referenced_Modified (Lhs, Out_Param => False);
end if;
-- Final step. If left side is an entity, then we may be able to
-- reset the current tracked values to new safe values. We only have
-- something to do if the left side is an entity name, and expansion
@ -715,7 +724,7 @@ package body Sem_Ch5 is
and then Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Ent)
then
Warn_On_Useless_Assignment (Ent, Sloc (N));
Warn_On_Useless_Assignment (Ent, N);
Set_Last_Assignment (Ent, Lhs);
end if;
@ -1458,8 +1467,8 @@ package body Sem_Ch5 is
if Analyzed (Original_Bound) then
return Original_Bound;
elsif Nkind (Analyzed_Bound) = N_Integer_Literal
or else Nkind (Analyzed_Bound) = N_Character_Literal
elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
N_Character_Literal)
or else Is_Entity_Name (Analyzed_Bound)
then
Analyze_And_Resolve (Original_Bound, Typ);

186
gcc/ada/sem_warn.adb
View File

@ -114,6 +114,13 @@ package body Sem_Warn is
-- formal, the setting of the flag in the corresponding spec is also
-- checked (and True returned if either flag is True).
function Referenced_As_Out_Parameter_Check_Spec
(E : Entity_Id) return Boolean;
-- Tests Referenced_As_Out_Parameter status for entity E. If E is not a
-- formal, this is simply the setting of Referenced_As_Out_Parameter. If E
-- is a body formal, the setting of the flag in the corresponding spec is
-- also checked (and True returned if either flag is True).
procedure Warn_On_Unreferenced_Entity
(Spec_E : Entity_Id;
Body_E : Entity_Id := Empty);
@ -222,7 +229,7 @@ package body Sem_Warn is
Ref := N;
Var := Entity (Ref);
-- Case of condition is a comparison with compile time known value
-- Case of condition is a comparison with compile time known value
elsif Nkind (N) in N_Op_Compare then
if Compile_Time_Known_Value (Right_Opnd (N)) then
@ -237,12 +244,12 @@ package body Sem_Warn is
return;
end if;
-- If condition is a negation, check its operand
-- If condition is a negation, check its operand
elsif Nkind (N) = N_Op_Not then
Find_Var (Right_Opnd (N));
-- Case of condition is function call
-- Case of condition is function call
elsif Nkind (N) = N_Function_Call then
@ -252,7 +259,7 @@ package body Sem_Warn is
if not Is_Entity_Name (Name (N)) then
return;
-- Forget it if warnings are suppressed on function entity
-- Forget it if warnings are suppressed on function entity
elsif Warnings_Off (Entity (Name (N))) then
return;
@ -281,14 +288,14 @@ package body Sem_Warn is
Find_Var (First (PA));
end if;
-- Not one argument
-- Not one argument
else
return;
end if;
end;
-- Any other kind of node is not something we warn for
-- Any other kind of node is not something we warn for
else
return;
@ -374,7 +381,7 @@ package body Sem_Warn is
return False;
end Substring_Present;
-- Start of processing for Is_Suspicious_Function_Name
-- Start of processing for Is_Suspicious_Function_Name
begin
S := E;
@ -405,7 +412,7 @@ package body Sem_Warn is
if N = Iter then
return Skip;
-- Direct reference to variable in question
-- Direct reference to variable in question
elsif Is_Entity_Name (N)
and then Present (Entity (N))
@ -424,6 +431,7 @@ package body Sem_Warn is
declare
P : Node_Id;
begin
P := N;
loop
@ -999,8 +1007,8 @@ package body Sem_Warn is
("?variable& is never read and never assigned!");
end if;
-- Deal with special case where this variable is
-- hidden by a loop variable
-- Deal with special case where this variable is hidden
-- by a loop variable.
if Ekind (E1) = E_Variable
and then Present (Hiding_Loop_Variable (E1))
@ -1115,13 +1123,27 @@ package body Sem_Warn is
-- Check that warnings on unreferenced entities are enabled
and then ((Check_Unreferenced and then not Is_Formal (E1))
or else
(Check_Unreferenced_Formals and then Is_Formal (E1))
or else
((Warn_On_Modified_Unread
or Warn_On_Out_Parameter_Unread)
and then Referenced_As_LHS_Check_Spec (E1)))
and then
((Check_Unreferenced and then not Is_Formal (E1))
-- Case of warning on unreferenced formal
or else
(Check_Unreferenced_Formals and then Is_Formal (E1))
-- Case of warning on unread variables modified by an
-- assignment, or an out parameter if it is the only one.
or else
(Warn_On_Modified_Unread
and then Referenced_As_LHS_Check_Spec (E1))
-- Case of warning on any unread out parameter (note
-- such indications are only set if the appropriate
-- warning options were set, so no need to recheck here.
or else
Referenced_As_Out_Parameter_Check_Spec (E1))
-- Labels, and enumeration literals, and exceptions. The
-- warnings are also placed on local packages that cannot be
@ -1939,10 +1961,13 @@ package body Sem_Warn is
-- are referenced. If none of the entities are referenced, we
-- still post a warning. This occurs if the only use of the
-- package is in a use clause, or in a package renaming
-- declaration.
elsif Ekind (Lunit) = E_Package then
-- declaration. This check is skipped for packages that are
-- renamed in a spec, since the entities in such a package are
-- visible to clients via the renaming.
elsif Ekind (Lunit) = E_Package
and then not Renamed_In_Spec (Lunit)
then
-- If Is_Instantiated is set, it means that the package is
-- implicitly instantiated (this is the case of parent
-- instance or an actual for a generic package formal), and
@ -1987,9 +2012,13 @@ package body Sem_Warn is
-- Else give the warning
else
Error_Msg_N
("?no entities of & are referenced!",
Name (Item));
if not Has_Pragma_Unreferenced
(Entity (Name (Item)))
then
Error_Msg_N
("?no entities of & are referenced!",
Name (Item));
end if;
-- Look for renamings of this package, and flag
-- them as well. If the original package has
@ -2000,11 +2029,12 @@ package body Sem_Warn is
if Present (Pack)
and then not Warnings_Off (Lunit)
and then not Has_Pragma_Unreferenced (Pack)
then
Error_Msg_NE
("?no entities of & are referenced!",
Unit_Declaration_Node (Pack),
Pack);
Pack);
end if;
end if;
@ -2016,6 +2046,7 @@ package body Sem_Warn is
elsif Referenced_Check_Spec (Ent)
or else Referenced_As_LHS_Check_Spec (Ent)
or else Referenced_As_Out_Parameter_Check_Spec (Ent)
or else
(From_With_Type (Ent)
and then Is_Incomplete_Type (Ent)
@ -2105,7 +2136,6 @@ package body Sem_Warn is
Next (Item);
end loop;
end Check_One_Unit;
-- Start of processing for Check_Unused_Withs
@ -2517,6 +2547,22 @@ package body Sem_Warn is
end if;
end Referenced_As_LHS_Check_Spec;
--------------------------------------------
-- Referenced_As_Out_Parameter_Check_Spec --
--------------------------------------------
function Referenced_As_Out_Parameter_Check_Spec
(E : Entity_Id) return Boolean
is
begin
if Is_Formal (E) and then Present (Spec_Entity (E)) then
return Referenced_As_Out_Parameter (E)
or else Referenced_As_Out_Parameter (Spec_Entity (E));
else
return Referenced_As_Out_Parameter (E);
end if;
end Referenced_As_Out_Parameter_Check_Spec;
----------------------------
-- Set_Dot_Warning_Switch --
----------------------------
@ -2524,6 +2570,12 @@ package body Sem_Warn is
function Set_Dot_Warning_Switch (C : Character) return Boolean is
begin
case C is
when 'a' =>
Warn_On_Assertion_Failure := True;
when 'A' =>
Warn_On_Assertion_Failure := False;
when 'c' =>
Warn_On_Unrepped_Components := True;
@ -2531,10 +2583,10 @@ package body Sem_Warn is
Warn_On_Unrepped_Components := False;
when 'o' =>
Warn_On_Out_Parameter_Unread := True;
Warn_On_All_Unread_Out_Parameters := True;
when 'O' =>
Warn_On_Out_Parameter_Unread := False;
Warn_On_All_Unread_Out_Parameters := False;
when 'r' =>
Warn_On_Object_Renames_Function := True;
@ -2570,6 +2622,7 @@ package body Sem_Warn is
Implementation_Unit_Warnings := True;
Ineffective_Inline_Warnings := True;
Warn_On_Ada_2005_Compatibility := True;
Warn_On_Assertion_Failure := True;
Warn_On_Assumed_Low_Bound := True;
Warn_On_Bad_Fixed_Value := True;
Warn_On_Constant := True;
@ -2594,6 +2647,8 @@ package body Sem_Warn is
Implementation_Unit_Warnings := False;
Ineffective_Inline_Warnings := False;
Warn_On_Ada_2005_Compatibility := False;
Warn_On_Assertion_Failure := False;
Warn_On_Assumed_Low_Bound := False;
Warn_On_Bad_Fixed_Value := False;
Warn_On_Constant := False;
Warn_On_Deleted_Code := False;
@ -2604,7 +2659,7 @@ package body Sem_Warn is
Warn_On_No_Value_Assigned := False;
Warn_On_Non_Local_Exception := False;
Warn_On_Obsolescent_Feature := False;
Warn_On_Out_Parameter_Unread := False;
Warn_On_All_Unread_Out_Parameters := False;
Warn_On_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False;
Warn_On_Object_Renames_Function := False;
@ -2914,6 +2969,17 @@ package body Sem_Warn is
end if;
end Warn_On_Known_Condition;
---------------------------------------
-- Warn_On_Modified_As_Out_Parameter --
---------------------------------------
function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean is
begin
return
(Warn_On_Modified_Unread and then Is_Only_Out_Parameter (E))
or else Warn_On_All_Unread_Out_Parameters;
end Warn_On_Modified_As_Out_Parameter;
------------------------------
-- Warn_On_Suspicious_Index --
------------------------------
@ -3270,22 +3336,17 @@ package body Sem_Warn is
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, or is imported.
-- 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.
if Referenced_As_LHS_Check_Spec (E)
and then No (Address_Clause (E))
and then not Is_Volatile (E)
then
if (Warn_On_Modified_Unread or Warn_On_Out_Parameter_Unread)
if Warn_On_Modified_Unread
and then not Is_Imported (E)
and then not Is_Return_Object (E)
-- Suppress message for aliased or renamed variables,
-- since there may be other entities that read the
-- same memory location.
and then not Is_Aliased (E)
and then No (Renamed_Object (E))
@ -3295,9 +3356,12 @@ package body Sem_Warn is
Set_Last_Assignment (E, Empty);
end if;
-- Normal case of neither assigned nor read
-- Normal case of neither assigned nor read (exclude variables
-- referenced as out parameters, since we already generated
-- appropriate warnings at the call point in this case).
elsif not Referenced_As_Out_Parameter (E) then
else
-- We suppress the message for types for which a valid
-- pragma Unreferenced_Objects has been given, otherwise
-- we go ahead and give the message.
@ -3396,10 +3460,10 @@ package body Sem_Warn is
procedure Warn_On_Useless_Assignment
(Ent : Entity_Id;
Loc : Source_Ptr := No_Location)
N : Node_Id := Empty)
is
P : Node_Id;
X : Node_Id;
P : Node_Id;
X : Node_Id;
function Check_Ref (N : Node_Id) return Traverse_Result;
-- Used to instantiate Traverse_Func. Returns Abandon if
@ -3430,9 +3494,11 @@ package body Sem_Warn is
-- Start of processing for Warn_On_Useless_Assignment
begin
-- Check if this is a case we want to warn on, a variable with the
-- last assignment field set, with warnings enabled, and which is
-- not imported or exported.
-- Check if this is a case we want to warn on, a scalar or access
-- variable with the last assignment field set, with warnings enabled,
-- and which is not imported or exported. We also check that it is OK
-- to capture the value. We are not going to capture any value, but
-- the warning messages depends on the same kind of conditions.
if Is_Assignable (Ent)
and then not Is_Return_Object (Ent)
@ -3441,6 +3507,7 @@ package body Sem_Warn is
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)
then
-- Before we issue the message, check covering exception handlers.
-- Search up tree for enclosing statement sequences and handlers
@ -3462,24 +3529,37 @@ package body Sem_Warn is
then
-- Case of assigned value never referenced
if Loc = No_Location then
if No (N) then
-- Don't give this for OUT and IN OUT formals, since
-- clearly caller may reference the assigned value.
if Ekind (Ent) = E_Variable then
Error_Msg_NE
("?useless assignment to&, value never referenced!",
Last_Assignment (Ent), Ent);
if Referenced_As_Out_Parameter (Ent) then
Error_Msg_NE
("?& modified by call, but value never referenced",
Last_Assignment (Ent), Ent);
else
Error_Msg_NE
("?useless assignment to&, value never referenced!",
Last_Assignment (Ent), Ent);
end if;
end if;
-- Case of assigned value overwritten
else
Error_Msg_Sloc := Loc;
Error_Msg_NE
("?useless assignment to&, value overwritten #!",
Last_Assignment (Ent), Ent);
Error_Msg_Sloc := Sloc (N);
if Referenced_As_Out_Parameter (Ent) then
Error_Msg_NE
("?& modified by call, but value overwritten #!",
Last_Assignment (Ent), Ent);
else
Error_Msg_NE
("?useless assignment to&, value overwritten #!",
Last_Assignment (Ent), Ent);
end if;
end if;
-- Clear last assignment indication and we are done

15
gcc/ada/sem_warn.ads
View File

@ -157,6 +157,11 @@ package Sem_Warn is
-- If all these conditions are met, the warning is issued noting that
-- the result of the test is always false or always true as appropriate.
function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean;
-- Returns True if we should activate warnings for entity E being modified
-- as an out parameter. True if either Warn_On_Modified_Unread is set for
-- an only OUT parameter, or if Warn_On_All_Unread_Out_Parameters is set.
procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id);
-- This is called after resolving an indexed component or a slice. Name
-- is the entity for the name of the indexed array, and X is the subscript
@ -176,14 +181,14 @@ package Sem_Warn is
procedure Warn_On_Useless_Assignment
(Ent : Entity_Id;
Loc : Source_Ptr := No_Location);
N : Node_Id := Empty);
-- Called to check if we have a case of a useless assignment to the given
-- entity Ent, as indicated by a non-empty Last_Assignment field. This call
-- should only be made if at least one of the flags Warn_On_Modified_Unread
-- or Warn_On_Out_Parameter_Unread is True, and if Ent is in the extended
-- main source unit. Loc is No_Location for the end of block call (warning
-- message says value unreferenced), or the it is the location of an
-- overwriting assignment (warning message points to this assignment).
-- or Warn_On_All_Unread_Out_Parameters is True, and if Ent is in the
-- extended main source unit. N is Empty for the end of block call
-- (warning message says value unreferenced), or the it is the node for
-- an overwriting assignment (warning message points to this assignment).
procedure Warn_On_Useless_Assignments (E : Entity_Id);
pragma Inline (Warn_On_Useless_Assignments);