mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-06 01:59:48 +08:00
Code Issues Packages 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 declare
K : Key_Type renames Position.Node.Key.all; K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all; E : Element_Type renames Position.Node.Element.all;
pragma Unreferenced (E);
begin begin
Process (K, E); Process (K, E);

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

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

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

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

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

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

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
@ -242,18 +242,19 @@ package body Exception_Propagation is
-- Copy all the components of Source to Target as well as the -- Copy all the components of Source to Target as well as the
-- Private_Data pointer. -- 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 -- As of today, these are only used by the C implementation of the GCC
-- GCC propagation personality routine to avoid having to rely on a C -- propagation personality routine to avoid having to rely on a C
-- counterpart of the whole exception_data structure, which is both -- counterpart of the whole exception_data structure, which is both
-- painful and error prone. These subprograms could be moved to a -- painful and error prone. These subprograms could be moved to a more
-- more widely visible location if need be. -- widely visible location if need be.
function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); 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; function Language_For (E : Exception_Data_Ptr) return Character;
pragma Export (C, Language_For, "__gnat_language_for"); 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 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 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 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 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 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) #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 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 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 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 function Is_Out_Actual (N : Node_Id) return Boolean is
Kind : Entity_Kind; Formal : Entity_Id;
Call : Node_Id; Call : Node_Id;
begin 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 if No (Formal) then
Insert_Node := Call;
return True;
else
return False; 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 if;
end Is_Out_Actual; 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 procedure Split_Line (Session : Session_Type) is
Fields : Field_Table.Instance renames Session.Data.Fields; Fields : Field_Table.Instance renames Session.Data.Fields;
pragma Unreferenced (Fields);
begin begin
Field_Table.Init (Fields); Field_Table.Init (Fields);
Split.Current_Line (Session.Data.Separators.all, Session); 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 if Sloc (Entity (N)) /= Standard_Location then
Generate_Reference (Entity (N), N); Generate_Reference (Entity (N), N);
-- A reference to an implicit inequality operator is a also a -- A reference to an implicit inequality operator is also a reference
-- reference to the user-defined equality. -- to the user-defined equality.
if Nkind (N) = N_Op_Ne if Nkind (N) = N_Op_Ne
and then not Comes_From_Source (Entity (N)) and then not Comes_From_Source (Entity (N))
@ -200,11 +200,11 @@ package body Lib.Xref is
------------------------ ------------------------
procedure Generate_Reference procedure Generate_Reference
(E : Entity_Id; (E : Entity_Id;
N : Node_Id; N : Node_Id;
Typ : Character := 'r'; Typ : Character := 'r';
Set_Ref : Boolean := True; Set_Ref : Boolean := True;
Force : Boolean := False) Force : Boolean := False)
is is
Indx : Nat; Indx : Nat;
Nod : Node_Id; Nod : Node_Id;
@ -212,9 +212,12 @@ package body Lib.Xref is
Def : Source_Ptr; Def : Source_Ptr;
Ent : Entity_Id; Ent : Entity_Id;
Call : Node_Id;
Formal : Entity_Id;
-- Used for call to Find_Actual
Kind : Entity_Kind; Kind : Entity_Kind;
Call : Node_Id; -- If Formal is non-Empty, then its Ekind, otherwise E_Void
-- Arguments used in call to Find_Actual_Mode
function Is_On_LHS (Node : Node_Id) return Boolean; function Is_On_LHS (Node : Node_Id) return Boolean;
-- Used to check if a node is on the left hand side of an assignment. -- 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; return False;
end if; end if;
-- Immediat return if appeared as OUT parameter -- Immediate return if appeared as OUT parameter
if Kind = E_Out_Parameter then if Kind = E_Out_Parameter then
return True; return True;
@ -311,7 +314,13 @@ package body Lib.Xref is
begin begin
pragma Assert (Nkind (E) in N_Entity); 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 -- Check for obsolescent reference to package ASCII. GNAT treats this
-- element of annex J specially since in practice, programs make a lot -- 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 if Set_Ref then
-- For a variable that appears on the left side of an assignment -- Assignable object appearing on left side of assignment or as
-- statement, we set the Referenced_As_LHS flag since this is indeed -- an out parameter.
-- a left hand side. We also set the Referenced_As_LHS flag of a
-- prefix of selected or indexed component.
if (Ekind (E) = E_Variable or else Is_Formal (E)) if Is_Assignable (E)
and then Is_On_LHS (N) and then Is_On_LHS (N)
and then Ekind (E) /= E_In_Out_Parameter
then then
-- If we have the OUT parameter case and the warning mode for -- For objects that are renamings, just set as simply referenced
-- OUT parameters is not set, treat this as an ordinary reference -- we do not try to do assignment type tracking in this case.
-- since we don't want warnings about it being unset.
if Kind = E_Out_Parameter and not Warn_On_Out_Parameter_Unread then if Present (Renamed_Object (E)) then
Set_Referenced (E); 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 else
Set_Referenced_As_LHS (E); null;
end if; end if;
-- Check for a reference in a pragma that should not count as a -- 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 -- All other cases
else else
-- Special processing for IN OUT and OUT parameters, where we -- Special processing for IN OUT parameters, where we have an
-- have an implicit assignment to a simple variable. -- implicit assignment to a simple variable.
if (Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter) if Kind = E_In_Out_Parameter
and then Is_Entity_Name (N) and then Is_Assignable (E)
and then Present (Entity (N))
and then Is_Assignable (Entity (N))
then then
-- Record implicit assignment unless we have an intrinsic -- For sure this counts as a normal read reference
-- 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.
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 not Is_Intrinsic_Subprogram (Entity (Name (Call)))
and then (Kind /= E_In_Out_Parameter and then Chars (Name (Call)) /= Name_Free
or else Chars (Name (Call)) /= Name_Free)
then then
Set_Referenced_As_LHS (E); Set_Referenced_As_Out_Parameter (E, True);
end if; Set_Referenced_As_LHS (E, False);
-- For IN OUT case, treat as also being normal reference
if Kind = E_In_Out_Parameter then
Set_Referenced (E);
end if; end if;
-- Any other occurrence counts as referencing the entity -- Any other occurrence counts as referencing the entity
@ -549,7 +578,7 @@ package body Lib.Xref is
while Present (BE) loop while Present (BE) loop
if Chars (BE) = Chars (E) then if Chars (BE) = Chars (E) then
Error_Msg_NE Error_Msg_NE
("?pragma Unreferenced given for&", N, BE); ("?pragma Unreferenced given for&!", N, BE);
exit; exit;
end if; end if;
@ -560,7 +589,7 @@ package body Lib.Xref is
-- Here we issue the warning, since this is a real reference -- Here we issue the warning, since this is a real reference
else else
Error_Msg_NE ("?pragma Unreferenced given for&", N, E); Error_Msg_NE ("?pragma Unreferenced given for&!", N, E);
end if; end if;
end if; end if;
@ -664,6 +693,15 @@ package body Lib.Xref is
then then
Ent := Original_Record_Component (E); 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 -- Ignore reference to any other entity that is not from source
else else
@ -1424,11 +1462,13 @@ package body Lib.Xref is
(Int (Get_Logical_Line_Number (Sloc (Tref)))); (Int (Get_Logical_Line_Number (Sloc (Tref))));
declare declare
Ent : Entity_Id := Tref; Ent : Entity_Id;
Kind : constant Entity_Kind := Ekind (Ent); Ctyp : Character;
Ctyp : Character := Xref_Entity_Letters (Kind);
begin begin
Ent := Tref;
Ctyp := Xref_Entity_Letters (Ekind (Ent));
if Ctyp = '+' if Ctyp = '+'
and then Present (Full_View (Ent)) and then Present (Full_View (Ent))
then 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 -- source node that generates the implicit reference, and it is
-- useful to record this one. -- useful to record this one.
-- k is used to denote a reference to the parent unit, in the -- k is another non-standard reference type, used to record a
-- cross-reference line for a child unit. -- 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 -- l is used to identify the occurrence in the source of the
-- name on an end line. This is just a syntactic reference -- 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. -- a renaming of a predefined operator.
procedure Generate_Reference procedure Generate_Reference
(E : Entity_Id; (E : Entity_Id;
N : Node_Id; N : Node_Id;
Typ : Character := 'r'; Typ : Character := 'r';
Set_Ref : Boolean := True; Set_Ref : Boolean := True;
Force : Boolean := False); Force : Boolean := False);
-- This procedure is called to record a reference. N is the location -- 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: -- 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; Initial_Action : array (Signal) of aliased struct_sigaction;
Default_Action : 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 -- -- Thread_Block_Interrupt --
@ -136,11 +137,11 @@ package body System.Interrupt_Management.Operations is
-------------------- --------------------
function Interrupt_Wait function Interrupt_Wait
(Mask : access Interrupt_Mask) (Mask : access Interrupt_Mask) return Interrupt_ID
return Interrupt_ID
is is
Result : Interfaces.C.int; Result : Interfaces.C.int;
Sig : aliased Signal; Sig : aliased Signal;
begin begin
Result := sigwait (Mask, Sig'Access); Result := sigwait (Mask, Sig'Access);

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 procedure Initialize is
T : Task_Id; T : Task_Id;
Success : Boolean;
Base_Priority : Any_Priority; Base_Priority : Any_Priority;
Success : Boolean;
pragma Warnings (Off, Success);
begin begin
if Initialized then if Initialized then
return; return;

7
gcc/ada/sem.adb
View File

@ -727,6 +727,7 @@ package body Sem is
To : Entity_Id) To : Entity_Id)
is is
Found : Boolean; Found : Boolean;
pragma Warnings (Off, Found);
procedure Search_Stack procedure Search_Stack
(Top : Suppress_Stack_Entry_Ptr; (Top : Suppress_Stack_Entry_Ptr;
@ -1282,10 +1283,10 @@ package body Sem is
S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
S_GNAT_Mode : constant Boolean := GNAT_Mode; S_GNAT_Mode : constant Boolean := GNAT_Mode;
S_Discard_Names : constant Boolean := Global_Discard_Names; 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 -- If the main unit is generic, every compiled unit, including its
-- context, is compiled with expansion disabled. -- 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 -- If assignment operand is a component reference, then we get the
-- actual subtype of the component for the unconstrained case. -- actual subtype of the component for the unconstrained case.
elsif elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
(Nkind (Opnd) = N_Selected_Component
or else Nkind (Opnd) = N_Explicit_Dereference)
and then not Is_Unchecked_Union (Opnd_Type) and then not Is_Unchecked_Union (Opnd_Type)
then then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
@ -685,6 +683,17 @@ package body Sem_Ch5 is
Check_Elab_Assign (Lhs); Check_Elab_Assign (Lhs);
end if; 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 -- 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 -- 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 -- 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 Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Ent) and then In_Extended_Main_Source_Unit (Ent)
then then
Warn_On_Useless_Assignment (Ent, Sloc (N)); Warn_On_Useless_Assignment (Ent, N);
Set_Last_Assignment (Ent, Lhs); Set_Last_Assignment (Ent, Lhs);
end if; end if;
@ -1458,8 +1467,8 @@ package body Sem_Ch5 is
if Analyzed (Original_Bound) then if Analyzed (Original_Bound) then
return Original_Bound; return Original_Bound;
elsif Nkind (Analyzed_Bound) = N_Integer_Literal elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
or else Nkind (Analyzed_Bound) = N_Character_Literal N_Character_Literal)
or else Is_Entity_Name (Analyzed_Bound) or else Is_Entity_Name (Analyzed_Bound)
then then
Analyze_And_Resolve (Original_Bound, Typ); 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 -- formal, the setting of the flag in the corresponding spec is also
-- checked (and True returned if either flag is True). -- 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 procedure Warn_On_Unreferenced_Entity
(Spec_E : Entity_Id; (Spec_E : Entity_Id;
Body_E : Entity_Id := Empty); Body_E : Entity_Id := Empty);
@ -222,7 +229,7 @@ package body Sem_Warn is
Ref := N; Ref := N;
Var := Entity (Ref); 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 elsif Nkind (N) in N_Op_Compare then
if Compile_Time_Known_Value (Right_Opnd (N)) then if Compile_Time_Known_Value (Right_Opnd (N)) then
@ -237,12 +244,12 @@ package body Sem_Warn is
return; return;
end if; 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 elsif Nkind (N) = N_Op_Not then
Find_Var (Right_Opnd (N)); Find_Var (Right_Opnd (N));
-- Case of condition is function call -- Case of condition is function call
elsif Nkind (N) = N_Function_Call then elsif Nkind (N) = N_Function_Call then
@ -252,7 +259,7 @@ 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 -- Forget it if warnings are suppressed on function entity
elsif Warnings_Off (Entity (Name (N))) then elsif Warnings_Off (Entity (Name (N))) then
return; return;
@ -281,14 +288,14 @@ package body Sem_Warn is
Find_Var (First (PA)); Find_Var (First (PA));
end if; end if;
-- Not one argument -- Not one argument
else else
return; return;
end if; end if;
end; end;
-- Any other kind of node is not something we warn for -- Any other kind of node is not something we warn for
else else
return; return;
@ -374,7 +381,7 @@ package body Sem_Warn is
return False; return False;
end Substring_Present; end Substring_Present;
-- Start of processing for Is_Suspicious_Function_Name -- Start of processing for Is_Suspicious_Function_Name
begin begin
S := E; S := E;
@ -405,7 +412,7 @@ package body Sem_Warn is
if N = Iter then if N = Iter then
return Skip; return Skip;
-- Direct reference to variable in question -- Direct reference to variable in question
elsif Is_Entity_Name (N) elsif Is_Entity_Name (N)
and then Present (Entity (N)) and then Present (Entity (N))
@ -424,6 +431,7 @@ package body Sem_Warn is
declare declare
P : Node_Id; P : Node_Id;
begin begin
P := N; P := N;
loop loop
@ -999,8 +1007,8 @@ package body Sem_Warn is
("?variable& is never read and never assigned!"); ("?variable& is never read and never assigned!");
end if; end if;
-- Deal with special case where this variable is -- Deal with special case where this variable is hidden
-- hidden by a loop variable -- by a loop variable.
if Ekind (E1) = E_Variable if Ekind (E1) = E_Variable
and then Present (Hiding_Loop_Variable (E1)) and then Present (Hiding_Loop_Variable (E1))
@ -1115,13 +1123,27 @@ package body Sem_Warn is
-- Check that warnings on unreferenced entities are enabled -- Check that warnings on unreferenced entities are enabled
and then ((Check_Unreferenced and then not Is_Formal (E1)) and then
or else ((Check_Unreferenced and then not Is_Formal (E1))
(Check_Unreferenced_Formals and then Is_Formal (E1))
or else -- Case of warning on unreferenced formal
((Warn_On_Modified_Unread
or Warn_On_Out_Parameter_Unread) or else
and then Referenced_As_LHS_Check_Spec (E1))) (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 -- Labels, and enumeration literals, and exceptions. The
-- warnings are also placed on local packages that cannot be -- 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 -- are referenced. If none of the entities are referenced, we
-- still post a warning. This occurs if the only use of the -- still post a warning. This occurs if the only use of the
-- package is in a use clause, or in a package renaming -- package is in a use clause, or in a package renaming
-- declaration. -- declaration. This check is skipped for packages that are
-- renamed in a spec, since the entities in such a package are
elsif Ekind (Lunit) = E_Package then -- 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 -- If Is_Instantiated is set, it means that the package is
-- implicitly instantiated (this is the case of parent -- implicitly instantiated (this is the case of parent
-- instance or an actual for a generic package formal), and -- instance or an actual for a generic package formal), and
@ -1987,9 +2012,13 @@ package body Sem_Warn is
-- Else give the warning -- Else give the warning
else else
Error_Msg_N if not Has_Pragma_Unreferenced
("?no entities of & are referenced!", (Entity (Name (Item)))
Name (Item)); then
Error_Msg_N
("?no entities of & are referenced!",
Name (Item));
end if;
-- Look for renamings of this package, and flag -- Look for renamings of this package, and flag
-- them as well. If the original package has -- them as well. If the original package has
@ -2000,11 +2029,12 @@ package body Sem_Warn is
if Present (Pack) if Present (Pack)
and then not Warnings_Off (Lunit) and then not Warnings_Off (Lunit)
and then not Has_Pragma_Unreferenced (Pack)
then then
Error_Msg_NE Error_Msg_NE
("?no entities of & are referenced!", ("?no entities of & are referenced!",
Unit_Declaration_Node (Pack), Unit_Declaration_Node (Pack),
Pack); Pack);
end if; end if;
end if; end if;
@ -2016,6 +2046,7 @@ package body Sem_Warn is
elsif Referenced_Check_Spec (Ent) elsif Referenced_Check_Spec (Ent)
or else Referenced_As_LHS_Check_Spec (Ent) or else Referenced_As_LHS_Check_Spec (Ent)
or else Referenced_As_Out_Parameter_Check_Spec (Ent)
or else or else
(From_With_Type (Ent) (From_With_Type (Ent)
and then Is_Incomplete_Type (Ent) and then Is_Incomplete_Type (Ent)
@ -2105,7 +2136,6 @@ package body Sem_Warn is
Next (Item); Next (Item);
end loop; end loop;
end Check_One_Unit; end Check_One_Unit;
-- Start of processing for Check_Unused_Withs -- Start of processing for Check_Unused_Withs
@ -2517,6 +2547,22 @@ package body Sem_Warn is
end if; end if;
end Referenced_As_LHS_Check_Spec; 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 -- -- Set_Dot_Warning_Switch --
---------------------------- ----------------------------
@ -2524,6 +2570,12 @@ package body Sem_Warn is
function Set_Dot_Warning_Switch (C : Character) return Boolean is function Set_Dot_Warning_Switch (C : Character) return Boolean is
begin begin
case C is case C is
when 'a' =>
Warn_On_Assertion_Failure := True;
when 'A' =>
Warn_On_Assertion_Failure := False;
when 'c' => when 'c' =>
Warn_On_Unrepped_Components := True; Warn_On_Unrepped_Components := True;
@ -2531,10 +2583,10 @@ package body Sem_Warn is
Warn_On_Unrepped_Components := False; Warn_On_Unrepped_Components := False;
when 'o' => when 'o' =>
Warn_On_Out_Parameter_Unread := True; Warn_On_All_Unread_Out_Parameters := True;
when 'O' => when 'O' =>
Warn_On_Out_Parameter_Unread := False; Warn_On_All_Unread_Out_Parameters := False;
when 'r' => when 'r' =>
Warn_On_Object_Renames_Function := True; Warn_On_Object_Renames_Function := True;
@ -2570,6 +2622,7 @@ package body Sem_Warn is
Implementation_Unit_Warnings := True; Implementation_Unit_Warnings := True;
Ineffective_Inline_Warnings := True; Ineffective_Inline_Warnings := True;
Warn_On_Ada_2005_Compatibility := True; Warn_On_Ada_2005_Compatibility := True;
Warn_On_Assertion_Failure := True;
Warn_On_Assumed_Low_Bound := True; Warn_On_Assumed_Low_Bound := True;
Warn_On_Bad_Fixed_Value := True; Warn_On_Bad_Fixed_Value := True;
Warn_On_Constant := True; Warn_On_Constant := True;
@ -2594,6 +2647,8 @@ package body Sem_Warn is
Implementation_Unit_Warnings := False; Implementation_Unit_Warnings := False;
Ineffective_Inline_Warnings := False; Ineffective_Inline_Warnings := False;
Warn_On_Ada_2005_Compatibility := 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_Bad_Fixed_Value := False;
Warn_On_Constant := False; Warn_On_Constant := False;
Warn_On_Deleted_Code := False; Warn_On_Deleted_Code := False;
@ -2604,7 +2659,7 @@ package body Sem_Warn is
Warn_On_No_Value_Assigned := False; Warn_On_No_Value_Assigned := False;
Warn_On_Non_Local_Exception := False; Warn_On_Non_Local_Exception := False;
Warn_On_Obsolescent_Feature := 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_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False; Warn_On_Redundant_Constructs := False;
Warn_On_Object_Renames_Function := False; Warn_On_Object_Renames_Function := False;
@ -2914,6 +2969,17 @@ package body Sem_Warn is
end if; end if;
end Warn_On_Known_Condition; 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 -- -- Warn_On_Suspicious_Index --
------------------------------ ------------------------------
@ -3270,22 +3336,17 @@ package body Sem_Warn is
case Ekind (E) is case Ekind (E) is
when E_Variable => when E_Variable =>
-- Case of variable that is assigned but not read. We -- Case of variable that is assigned but not read. We suppress
-- suppress the message if the variable is volatile, has an -- the message if the variable is volatile, has an address
-- address clause, or is imported. -- clause, is aliasied, or is a renaming, or is imported.
if Referenced_As_LHS_Check_Spec (E) if Referenced_As_LHS_Check_Spec (E)
and then No (Address_Clause (E)) and then No (Address_Clause (E))
and then not Is_Volatile (E) and then not Is_Volatile (E)
then 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_Imported (E)
and then not Is_Return_Object (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 not Is_Aliased (E)
and then No (Renamed_Object (E)) and then No (Renamed_Object (E))
@ -3295,9 +3356,12 @@ package body Sem_Warn is
Set_Last_Assignment (E, Empty); Set_Last_Assignment (E, Empty);
end if; 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 -- We suppress the message for types for which a valid
-- pragma Unreferenced_Objects has been given, otherwise -- pragma Unreferenced_Objects has been given, otherwise
-- we go ahead and give the message. -- we go ahead and give the message.
@ -3396,10 +3460,10 @@ package body Sem_Warn is
procedure Warn_On_Useless_Assignment procedure Warn_On_Useless_Assignment
(Ent : Entity_Id; (Ent : Entity_Id;
Loc : Source_Ptr := No_Location) N : Node_Id := Empty)
is is
P : Node_Id; P : Node_Id;
X : Node_Id; X : Node_Id;
function Check_Ref (N : Node_Id) return Traverse_Result; function Check_Ref (N : Node_Id) return Traverse_Result;
-- Used to instantiate Traverse_Func. Returns Abandon if -- 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 -- Start of processing for Warn_On_Useless_Assignment
begin begin
-- Check if this is a case we want to warn on, a variable with the -- Check if this is a case we want to warn on, a scalar or access
-- last assignment field set, with warnings enabled, and which is -- variable with the last assignment field set, with warnings enabled,
-- not imported or exported. -- 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) if Is_Assignable (Ent)
and then not Is_Return_Object (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 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)
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
@ -3462,24 +3529,37 @@ package body Sem_Warn is
then then
-- Case of assigned value never referenced -- 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 -- Don't give this for OUT and IN OUT formals, since
-- clearly caller may reference the assigned value. -- clearly caller may reference the assigned value.
if Ekind (Ent) = E_Variable then if Ekind (Ent) = E_Variable then
Error_Msg_NE if Referenced_As_Out_Parameter (Ent) then
("?useless assignment to&, value never referenced!", Error_Msg_NE
Last_Assignment (Ent), Ent); ("?& 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; end if;
-- Case of assigned value overwritten -- Case of assigned value overwritten
else else
Error_Msg_Sloc := Loc; Error_Msg_Sloc := Sloc (N);
Error_Msg_NE
("?useless assignment to&, value overwritten #!", if Referenced_As_Out_Parameter (Ent) then
Last_Assignment (Ent), Ent); 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; end if;
-- Clear last assignment indication and we are done -- 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 -- 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. -- 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); procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id);
-- This is called after resolving an indexed component or a slice. Name -- 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 -- 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 procedure Warn_On_Useless_Assignment
(Ent : Entity_Id; (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 -- 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 -- 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 -- 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 -- or Warn_On_All_Unread_Out_Parameters is True, and if Ent is in the
-- main source unit. Loc is No_Location for the end of block call (warning -- extended main source unit. N is Empty for the end of block call
-- message says value unreferenced), or the it is the location of an -- (warning message says value unreferenced), or the it is the node for
-- overwriting assignment (warning message points to this assignment). -- an overwriting assignment (warning message points to this assignment).
procedure Warn_On_Useless_Assignments (E : Entity_Id); procedure Warn_On_Useless_Assignments (E : Entity_Id);
pragma Inline (Warn_On_Useless_Assignments); pragma Inline (Warn_On_Useless_Assignments);