Skip to content

R
riscv-gcc-1
Commit 3f1ede06 by Robert Dewar Committed by Arnaud Charlet
Options

freeze.adb: Add handling of Last_Assignment field 

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb: Add handling of Last_Assignment field
	(Warn_Overlay): Supply missing continuation marks in error msgs
	(Freeze_Entity): Add check for Preelaborable_Initialization

	* g-comlin.adb: Add Warnings (Off) to prevent new warning

	* g-expect.adb: Add Warnings (Off) to prevent new warning

	* lib-xref.adb: Add handling of Last_Assignment field
	(Generate_Reference): Centralize handling of pragma Obsolescent here
	(Generate_Reference): Accept an implicit reference generated for a
	default in an instance.
	(Generate_Reference): Accept a reference for a node that is not in the
	main unit, if it is the generic body corresponding to an subprogram
	instantiation.

	* xref_lib.adb: Add pragma Warnings (Off) to avoid new warnings

        * sem_warn.ads, sem_warn.adb (Set_Warning_Switch): Add processing for
	-gnatwq/Q.
	(Warn_On_Useless_Assignment): Suppress warning if enclosing inner
	exception handler.
	(Output_Obsolescent_Entity_Warnings): Rewrite to avoid any messages on
	use clauses, to avoid messages on packages used to qualify, and also
	to avoid messages from obsolescent units.
	(Warn_On_Useless_Assignments): Don't generate messages for imported
	and exported variables.
	(Warn_On_Useless_Assignments): New procedure
	(Output_Obsolescent_Entity_Warnings): New procedure
	(Check_Code_Statement): New procedure

        * einfo.ads, einfo.adb (Has_Static_Discriminants): New flag
	Change name Is_Ada_2005 to Is_Ada_2005_Only
	(Last_Assignment): New field for useless assignment warning

From-SVN: r118271
parent ac3b962e
Showing with 1006 additions and 295 deletions
gcc/ada/freeze.adb
...@@ -887,31 +887,12 @@ package body Freeze is ...@@ -887,31 +887,12 @@ package body Freeze is
(T : Entity_Id) return Boolean (T : Entity_Id) return Boolean
is is
Constraint : Elmt_Id; Constraint : Elmt_Id;
Discr : Entity_Id;
begin begin
if Has_Discriminants (T) if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T)) and then Present (Discriminant_Constraint (T))
and then Present (First_Component (T)) and then Present (First_Component (T))
then then
Discr := First_Discriminant (T);
if Is_Access_Type (Etype (Discr)) then
null;
-- If the bounds of the discriminant are not compile-time known,
-- treat this as non-static, even if the value of the discriminant
-- is compile-time known, because the back-end treats aggregates
-- of such a subtype as having unknown size.
elsif not
(Compile_Time_Known_Value (Type_Low_Bound (Etype (Discr)))
and then
Compile_Time_Known_Value (Type_High_Bound (Etype (Discr))))
then
return False;
end if;
Constraint := First_Elmt (Discriminant_Constraint (T)); Constraint := First_Elmt (Discriminant_Constraint (T));
while Present (Constraint) loop while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then if not Compile_Time_Known_Value (Node (Constraint)) then
...@@ -2453,6 +2434,16 @@ package body Freeze is ...@@ -2453,6 +2434,16 @@ package body Freeze is
-- Case of a type or subtype being frozen -- Case of a type or subtype being frozen
else else
-- Check preelaborable initialization for full type completing a
-- private type for which pragma Preelaborable_Initialization given.
if Must_Have_Preelab_Init (E)
and then not Has_Preelaborable_Initialization (E)
then
Error_Msg_N
("full view of & does not have preelaborable initialization", E);
end if;
-- The type may be defined in a generic unit. This can occur when -- The type may be defined in a generic unit. This can occur when
-- freezing a generic function that returns the type (which is -- freezing a generic function that returns the type (which is
-- defined in a parent unit). It is clearly meaningless to freeze -- defined in a parent unit). It is clearly meaningless to freeze
...@@ -3014,7 +3005,7 @@ package body Freeze is ...@@ -3014,7 +3005,7 @@ package body Freeze is
Freeze_Subprogram (E); Freeze_Subprogram (E);
-- AI-326: Check wrong use of tag incomplete type -- Ada 2005 (AI-326): Check wrong use of tag incomplete type
-- --
-- type T is tagged; -- type T is tagged;
-- type Acc is access function (X : T) return T; -- ERROR -- type Acc is access function (X : T) return T; -- ERROR
...@@ -4503,11 +4494,15 @@ package body Freeze is ...@@ -4503,11 +4494,15 @@ package body Freeze is
-- Reset True_Constant flag, since something strange is going on with -- Reset True_Constant flag, since something strange is going on with
-- the scoping here, and our simple value tracing may not be sufficient -- the scoping here, and our simple value tracing may not be sufficient
-- for this indication to be reliable. We kill the Constant_Value -- for this indication to be reliable. We kill the Constant_Value
-- indication for the same reason. -- and Last_Assignment indications for the same reason.
Set_Is_True_Constant (E, False); Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty); Set_Current_Value (E, Empty);
if Ekind (E) = E_Variable then
Set_Last_Assignment (E, Empty);
end if;
exception exception
when Cannot_Be_Static => when Cannot_Be_Static =>
...@@ -5091,8 +5086,9 @@ package body Freeze is ...@@ -5091,8 +5086,9 @@ package body Freeze is
and then Present (Packed_Array_Type (Etype (Comp))) and then Present (Packed_Array_Type (Etype (Comp)))
then then
Error_Msg_NE Error_Msg_NE
("packed array component& will be initialized to zero?", ("\packed array component& " &
Nam, Comp); "will be initialized to zero?",
Nam, Comp);
exit; exit;
else else
Next_Component (Comp); Next_Component (Comp);
...@@ -5102,9 +5098,9 @@ package body Freeze is ...@@ -5102,9 +5098,9 @@ package body Freeze is
end if; end if;
Error_Msg_N Error_Msg_N
("use pragma Import for & to " & ("\use pragma Import for & to " &
"suppress initialization ('R'M B.1(24))?", "suppress initialization ('R'M B.1(24))?",
Nam); Nam);
end if; end if;
end Warn_Overlay; end Warn_Overlay;
......
gcc/ada/g-comlin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2006, 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- --
...@@ -683,6 +683,9 @@ package body GNAT.Command_Line is ...@@ -683,6 +683,9 @@ package body GNAT.Command_Line is
Last : Integer; Last : Integer;
Delimiter_Found : Boolean; Delimiter_Found : Boolean;
Discard : Boolean;
pragma Warnings (Off, Discard);
begin begin
Current_Argument := 0; Current_Argument := 0;
Current_Index := 0; Current_Index := 0;
...@@ -732,7 +735,7 @@ package body GNAT.Command_Line is ...@@ -732,7 +735,7 @@ package body GNAT.Command_Line is
end loop; end loop;
end loop; end loop;
Delimiter_Found := Goto_Next_Argument_In_Section; Discard := Goto_Next_Argument_In_Section;
end Initialize_Option_Scan; end Initialize_Option_Scan;
--------------- ---------------
......
gcc/ada/g-expect.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2005, AdaCore -- -- Copyright (C) 2000-2006, AdaCore --
-- -- -- --
-- 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- --
...@@ -1110,8 +1110,8 @@ package body GNAT.Expect is ...@@ -1110,8 +1110,8 @@ package body GNAT.Expect is
Result : Expect_Match; Result : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
Dummy : Natural; Discard : Natural;
pragma Unreferenced (Dummy); pragma Warnings (Off, Discard);
begin begin
if Empty_Buffer then if Empty_Buffer then
...@@ -1135,7 +1135,7 @@ package body GNAT.Expect is ...@@ -1135,7 +1135,7 @@ package body GNAT.Expect is
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
Dummy := Discard :=
Write (Descriptor.Input_Fd, Write (Descriptor.Input_Fd,
Full_Str'Address, Full_Str'Address,
Last - Full_Str'First + 1); Last - Full_Str'First + 1);
...@@ -1275,7 +1275,6 @@ package body GNAT.Expect is ...@@ -1275,7 +1275,6 @@ package body GNAT.Expect is
Pipe3 : in out Pipe_Type) Pipe3 : in out Pipe_Type)
is is
pragma Warnings (Off, Pid); pragma Warnings (Off, Pid);
begin begin
Close (Pipe1.Input); Close (Pipe1.Input);
Close (Pipe2.Output); Close (Pipe2.Output);
......
gcc/ada/lib-xref.adb
...@@ -37,6 +37,7 @@ with Rident; use Rident; ...@@ -37,6 +37,7 @@ with Rident; use Rident;
with Sem; use Sem; with Sem; use Sem;
with Sem_Prag; use Sem_Prag; with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
...@@ -111,6 +112,7 @@ package body Lib.Xref is ...@@ -111,6 +112,7 @@ package body Lib.Xref is
if Opt.Xref_Active if Opt.Xref_Active
-- Definition must come from source -- Definition must come from source
-- We make an exception for subprogram child units that have no -- We make an exception for subprogram child units that have no
-- spec. For these we generate a subprogram declaration for library -- spec. For these we generate a subprogram declaration for library
-- use, and the corresponding entity does not come from source. -- use, and the corresponding entity does not come from source.
...@@ -212,17 +214,15 @@ package body Lib.Xref is ...@@ -212,17 +214,15 @@ package body Lib.Xref is
Ent : Entity_Id; Ent : Entity_Id;
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 -- Used to check if a node is on the left hand side of an assignment.
-- assignment. The following cases are handled: -- The following cases are handled:
-- --
-- Variable Node is a direct descendant of an assignment -- Variable Node is a direct descendant of an assignment statement.
-- statement.
-- --
-- Prefix Of an indexed or selected component that is -- Prefix Of an indexed or selected component that is present in a
-- present in a subtree rooted by an assignment -- subtree rooted by an assignment statement. There is no
-- statement. There is no restriction of nesting -- restriction of nesting of components, thus cases such as
-- of components, thus cases such as A.B(C).D are -- A.B(C).D are handled properly.
-- handled properly.
--------------- ---------------
-- Is_On_LHS -- -- Is_On_LHS --
...@@ -240,9 +240,9 @@ package body Lib.Xref is ...@@ -240,9 +240,9 @@ package body Lib.Xref is
return False; return False;
end if; end if;
-- Reach the assignment statement subtree root. In the -- Reach the assignment statement subtree root. In the case of a
-- case of a variable being a direct descendant of an -- variable being a direct descendant of an assignment statement,
-- assignment statement, the loop is skiped. -- the loop is skiped.
while Nkind (Parent (N)) /= N_Assignment_Statement loop while Nkind (Parent (N)) /= N_Assignment_Statement loop
...@@ -270,16 +270,43 @@ package body Lib.Xref is ...@@ -270,16 +270,43 @@ package body Lib.Xref is
begin begin
pragma Assert (Nkind (E) in N_Entity); pragma Assert (Nkind (E) in N_Entity);
-- Check for obsolescent reference to ASCII -- Check for obsolescent reference to package ASCII. GNAT treats this
-- element of annex J specially since in practice, programs make a lot
-- of use of this feature, so we don't include it in the set of features
-- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
-- are required to note it as a violation of the RM defined restriction.
if E = Standard_ASCII then if E = Standard_ASCII then
Check_Restriction (No_Obsolescent_Features, N); Check_Restriction (No_Obsolescent_Features, N);
end if; end if;
-- Check for reference to entity marked with Is_Obsolescent
-- Note that we always allow obsolescent references in the compiler
-- itself and the run time, since we assume that we know what we are
-- doing in such cases. For example the calls in Ada.Characters.Handling
-- to its own obsolescent subprograms are just fine.
-- In any case we do not generate warnings within the extended source
-- unit of the entity in question, since we assume the source unit
-- itself knows what is going on (and for sure we do not want silly
-- warnings, e.g. on the end line of an obsolescent procedure body).
if Is_Obsolescent (E)
and then not GNAT_Mode
and then not In_Extended_Main_Source_Unit (E)
then
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
Output_Obsolescent_Entity_Warnings (N, E);
end if;
end if;
-- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
-- detect real explicit references (modifications and references). -- detect real explicit references (modifications and references).
if Is_Ada_2005 (E) if Is_Ada_2005_Only (E)
and then Ada_Version < Ada_05 and then Ada_Version < Ada_05
and then Warn_On_Ada_2005_Compatibility and then Warn_On_Ada_2005_Compatibility
and then (Typ = 'm' or else Typ = 'r') and then (Typ = 'm' or else Typ = 'r')
...@@ -294,12 +321,23 @@ package body Lib.Xref is ...@@ -294,12 +321,23 @@ package body Lib.Xref is
-- case of 'p' since we want to include inherited primitive operations -- case of 'p' since we want to include inherited primitive operations
-- from other packages. -- from other packages.
if not In_Extended_Main_Source_Unit (N) -- We also omit this test is this is a body reference for a subprogram
and then Typ /= 'e' -- instantiation. In this case the reference is to the generic body,
and then Typ /= 'p' -- which clearly need not be in the main unit containing the instance.
and then Typ /= 'k' -- For the same reason we accept an implicit reference generated for
then -- a default in an instance.
return;
if not In_Extended_Main_Source_Unit (N) then
if Typ = 'e'
or else Typ = 'p'
or else Typ = 'i'
or else Typ = 'k'
or else (Typ = 'b' and then Is_Generic_Instance (E))
then
null;
else
return;
end if;
end if; end if;
-- For reference type p, the entity must be in main source unit -- For reference type p, the entity must be in main source unit
...@@ -308,29 +346,27 @@ package body Lib.Xref is ...@@ -308,29 +346,27 @@ package body Lib.Xref is
return; return;
end if; end if;
-- Unless the reference is forced, we ignore references where -- Unless the reference is forced, we ignore references where the
-- the reference itself does not come from Source. -- reference itself does not come from Source.
if not Force and then not Comes_From_Source (N) then if not Force and then not Comes_From_Source (N) then
return; return;
end if; end if;
-- Deal with setting entity as referenced, unless suppressed. -- Deal with setting entity as referenced, unless suppressed. Note that
-- Note that we still do Set_Referenced on entities that do not -- we still do Set_Referenced on entities that do not come from source.
-- come from source. This situation arises when we have a source -- This situation arises when we have a source reference to a derived
-- reference to a derived operation, where the derived operation -- operation, where the derived operation itself does not come from
-- itself does not come from source, but we still want to mark it -- source, but we still want to mark it as referenced, since we really
-- as referenced, since we really are referencing an entity in the -- are referencing an entity in the corresponding package (this avoids
-- corresponding package (this avoids incorrect complaints that the -- wrong complaints that the package contains no referenced entities).
-- package contains no referenced entities).
if Set_Ref then if Set_Ref then
-- For a variable that appears on the left side of an -- For a variable that appears on the left side of an assignment
-- assignment statement, we set the Referenced_As_LHS -- statement, we set the Referenced_As_LHS flag since this is indeed
-- flag since this is indeed a left hand side. -- a left hand side. We also set the Referenced_As_LHS flag of a
-- We also set the Referenced_As_LHS flag of a prefix -- prefix of selected or indexed component.
-- of selected or indexed component.
if Ekind (E) = E_Variable if Ekind (E) = E_Variable
and then Is_On_LHS (N) and then Is_On_LHS (N)
...@@ -343,11 +379,10 @@ package body Lib.Xref is ...@@ -343,11 +379,10 @@ package body Lib.Xref is
elsif Is_Non_Significant_Pragma_Reference (N) then elsif Is_Non_Significant_Pragma_Reference (N) then
null; null;
-- A reference in an attribute definition clause does not -- A reference in an attribute definition clause does not count as a
-- count as a reference except for the case of Address. -- reference except for the case of Address. The reason that 'Address
-- The reason that 'Address is an exception is that it -- is an exception is that it creates an alias through which the
-- creates an alias through which the variable may be -- variable may be referenced.
-- referenced.
elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
and then Chars (Parent (N)) /= Name_Address and then Chars (Parent (N)) /= Name_Address
...@@ -380,6 +415,10 @@ package body Lib.Xref is ...@@ -380,6 +415,10 @@ package body Lib.Xref is
else else
Set_Referenced (E); Set_Referenced (E);
if Ekind (E) = E_Variable then
Set_Last_Assignment (E, Empty);
end if;
end if; end if;
-- Check for pragma Unreferenced given and reference is within -- Check for pragma Unreferenced given and reference is within
...@@ -403,12 +442,12 @@ package body Lib.Xref is ...@@ -403,12 +442,12 @@ package body Lib.Xref is
elsif Is_On_LHS (N) then elsif Is_On_LHS (N) then
null; null;
-- For entry formals, we want to place the warning on the -- For entry formals, we want to place the warning message on the
-- corresponding entity in the accept statement. The current -- corresponding entity in the accept statement. The current scope
-- scope is the body of the accept, so we find the formal -- is the body of the accept, so we find the formal whose name
-- whose name matches that of the entry formal (there is no -- matches that of the entry formal (there is no link between the
-- link between the two entities, and the one in the accept -- two entities, and the one in the accept statement is only used
-- statement is only used for conformance checking). -- for conformance checking).
elsif Ekind (Scope (E)) = E_Entry then elsif Ekind (Scope (E)) = E_Entry then
declare declare
...@@ -510,15 +549,12 @@ package body Lib.Xref is ...@@ -510,15 +549,12 @@ package body Lib.Xref is
and then Present (Alias (E)) and then Present (Alias (E))
then then
Ent := Alias (E); Ent := Alias (E);
while not Comes_From_Source (Ent) loop
loop if No (Alias (Ent)) then
if Comes_From_Source (Ent) then
exit;
elsif No (Alias (Ent)) then
return; return;
else
Ent := Alias (Ent);
end if; end if;
Ent := Alias (Ent);
end loop; end loop;
-- The internally created defining entity for a child subprogram -- The internally created defining entity for a child subprogram
...@@ -623,7 +659,6 @@ package body Lib.Xref is ...@@ -623,7 +659,6 @@ package body Lib.Xref is
begin begin
Formal := First_Entity (E); Formal := First_Entity (E);
while Present (Formal) loop while Present (Formal) loop
if Comes_From_Source (Formal) then if Comes_From_Source (Formal) then
Generate_Reference (E, Formal, 'z', False); Generate_Reference (E, Formal, 'z', False);
...@@ -734,9 +769,9 @@ package body Lib.Xref is ...@@ -734,9 +769,9 @@ package body Lib.Xref is
Right := ')'; Right := ')';
end if; end if;
-- If non-derived array, get component type. -- If non-derived array, get component type. Skip component
-- Skip component type for case of String -- type for case of String or Wide_String, saves worthwhile
-- or Wide_String, saves worthwhile space. -- space.
elsif Is_Array_Type (Tref) elsif Is_Array_Type (Tref)
and then Tref /= Standard_String and then Tref /= Standard_String
...@@ -828,7 +863,10 @@ package body Lib.Xref is ...@@ -828,7 +863,10 @@ package body Lib.Xref is
procedure Output_Import_Export_Info (Ent : Entity_Id) is procedure Output_Import_Export_Info (Ent : Entity_Id) is
Language_Name : Name_Id; Language_Name : Name_Id;
Conv : constant Convention_Id := Convention (Ent); Conv : constant Convention_Id := Convention (Ent);
begin begin
-- Generate language name from convention
if Conv = Convention_C then if Conv = Convention_C then
Language_Name := Name_C; Language_Name := Name_C;
...@@ -839,7 +877,7 @@ package body Lib.Xref is ...@@ -839,7 +877,7 @@ package body Lib.Xref is
Language_Name := Name_Ada; Language_Name := Name_Ada;
else else
-- These are the only languages that GPS knows about -- For the moment we ignore all other cases ???
return; return;
end if; end if;
...@@ -1104,6 +1142,8 @@ package body Lib.Xref is ...@@ -1104,6 +1142,8 @@ package body Lib.Xref is
-- Name_Change -- -- Name_Change --
----------------- -----------------
-- Why a string comparison here??? Why not compare Name_Id values???
function Name_Change (X : Entity_Id) return Boolean is function Name_Change (X : Entity_Id) return Boolean is
begin begin
Get_Unqualified_Name_String (Chars (X)); Get_Unqualified_Name_String (Chars (X));
...@@ -1358,7 +1398,6 @@ package body Lib.Xref is ...@@ -1358,7 +1398,6 @@ package body Lib.Xref is
-- Special handling for abstract types and operations -- Special handling for abstract types and operations
if Is_Abstract (XE.Ent) then if Is_Abstract (XE.Ent) then
if Ctyp = 'U' then if Ctyp = 'U' then
Ctyp := 'x'; -- abstract procedure Ctyp := 'x'; -- abstract procedure
...@@ -1370,11 +1409,11 @@ package body Lib.Xref is ...@@ -1370,11 +1409,11 @@ package body Lib.Xref is
end if; end if;
end if; end if;
-- Only output reference if interesting type of entity, -- Only output reference if interesting type of entity, and
-- and suppress self references, except for bodies that -- suppress self references, except for bodies that act as
-- act as specs. Also suppress definitions of body formals -- specs. Also suppress definitions of body formals (we only
-- (we only treat these as references, and the references -- treat these as references, and the references were
-- were separately recorded). -- separately recorded).
if Ctyp = ' ' if Ctyp = ' '
or else (XE.Loc = XE.Def or else (XE.Loc = XE.Def
...@@ -1559,6 +1598,11 @@ package body Lib.Xref is ...@@ -1559,6 +1598,11 @@ package body Lib.Xref is
end if; end if;
end loop; end loop;
-- Write out the identifier by copying the exact
-- source characters used in its declaration. Note
-- that this means wide characters will be in their
-- original encoded form.
for J in for J in
Original_Location (Sloc (XE.Ent)) .. P - 1 Original_Location (Sloc (XE.Ent)) .. P - 1
loop loop
...@@ -1628,23 +1672,24 @@ package body Lib.Xref is ...@@ -1628,23 +1672,24 @@ package body Lib.Xref is
(Int (Get_Column_Number (Sloc (Rref)))); (Int (Get_Column_Number (Sloc (Rref))));
end if; end if;
-- Indicate that the entity is in the unit -- Indicate that the entity is in the unit of the current
-- of the current xref xection. -- xref xection.
Curru := Curxu; Curru := Curxu;
-- Write out information about generic parent, -- Write out information about generic parent, if entity
-- if entity is an instance. -- is an instance.
if Is_Generic_Instance (XE.Ent) then if Is_Generic_Instance (XE.Ent) then
declare declare
Gen_Par : constant Entity_Id := Gen_Par : constant Entity_Id :=
Generic_Parent Generic_Parent
(Specification (Specification
(Unit_Declaration_Node (XE.Ent))); (Unit_Declaration_Node (XE.Ent)));
Loc : constant Source_Ptr := Sloc (Gen_Par); Loc : constant Source_Ptr := Sloc (Gen_Par);
Gen_U : constant Unit_Number_Type := Gen_U : constant Unit_Number_Type :=
Get_Source_Unit (Loc); Get_Source_Unit (Loc);
begin begin
Write_Info_Char ('['); Write_Info_Char ('[');
if Curru /= Gen_U then if Curru /= Gen_U then
......
gcc/ada/sem_warn.adb
...@@ -28,18 +28,23 @@ with Alloc; ...@@ -28,18 +28,23 @@ with Alloc;
with Atree; use Atree; with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Exp_Code; use Exp_Code;
with Fname; use Fname; with Fname; use Fname;
with Lib; use Lib; with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Opt; use Opt; with Opt; use Opt;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; 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 Table; with Table;
with Uintp; use Uintp;
package body Sem_Warn is package body Sem_Warn is
...@@ -54,83 +59,6 @@ package body Sem_Warn is ...@@ -54,83 +59,6 @@ package body Sem_Warn is
Table_Increment => Alloc.Unreferenced_Entities_Increment, Table_Increment => Alloc.Unreferenced_Entities_Increment,
Table_Name => "Unreferenced_Entities"); Table_Name => "Unreferenced_Entities");
------------------------------
-- Handling of Conditionals --
------------------------------
-- Note: this is work in progress, the data structures and general approach
-- are defined, but are not in use yet. ???
-- An entry is made in the following table for each branch of conditional,
-- e.g. an if-then-elsif-else-endif structure creates three entries in this
-- table.
type Branch_Entry is record
Sloc : Source_Ptr;
-- Location for warnings associated with this branch
Defs : Elist_Id;
-- List of entities defined for the first time in this branch. On exit
-- from a conditional structure, any entity that is in the list of all
-- branches is removed (and the entity flagged as defined by the
-- conditional as a whole). Thus after processing a conditional, Defs
-- contains a list of entities defined in this branch for the first
-- time, but not defined at all in some other branch of the same
-- conditional. A value of No_Elist is used to represent the initial
-- empty list.
Next : Nat;
-- Index of next branch for this conditional, zero = last branch
end record;
package Branch_Table is new Table.Table (
Table_Component_Type => Branch_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => Alloc.Branches_Initial,
Table_Increment => Alloc.Branches_Increment,
Table_Name => "Branches");
-- The following table is used to represent conditionals, there is one
-- entry in this table for each conditional structure.
type Conditional_Entry is record
If_Stmt : Boolean;
-- True for IF statement, False for CASE statement
First_Branch : Nat;
-- Index in Branch table of first branch, zero = none yet
Current_Branch : Nat;
-- Index in Branch table of current branch, zero = none yet
end record;
package Conditional_Table is new Table.Table (
Table_Component_Type => Conditional_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => Alloc.Conditionals_Initial,
Table_Increment => Alloc.Conditionals_Increment,
Table_Name => "Conditionals");
-- The following table is a stack that keeps track of the current
-- conditional. The Last entry is the top of the stack. An Empty entry
-- represents the start of a compilation unit. Non-zero entries in the
-- stack are indexes into the conditional table.
package Conditional_Stack is new Table.Table (
Table_Component_Type => Nat,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => Alloc.Conditional_Stack_Initial,
Table_Increment => Alloc.Conditional_Stack_Increment,
Table_Name => "Conditional_Stack");
pragma Warnings (Off, Branch_Table);
pragma Warnings (Off, Conditional_Table);
pragma Warnings (Off, Conditional_Stack);
-- Not yet referenced, see note above ???
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
...@@ -148,6 +76,49 @@ package body Sem_Warn is ...@@ -148,6 +76,49 @@ package body Sem_Warn is
-- the Warnings_Off flag is set. True is returned if such an entity is -- the Warnings_Off flag is set. True is returned if such an entity is
-- encountered, and False otherwise. -- encountered, and False otherwise.
--------------------------
-- Check_Code_Statement --
--------------------------
procedure Check_Code_Statement (N : Node_Id) is
begin
-- If volatile, nothing to worry about
if Is_Asm_Volatile (N) then
return;
end if;
-- Warn if no input or no output
Setup_Asm_Inputs (N);
if No (Asm_Input_Value) then
Error_Msg_F
("?code statement with no inputs should usually be Volatile", N);
return;
end if;
Setup_Asm_Outputs (N);
if No (Asm_Output_Variable) then
Error_Msg_F
("?code statement with no outputs should usually be Volatile", N);
return;
end if;
-- Check multiple code statements in a row
if Is_List_Member (N)
and then Present (Prev (N))
and then Nkind (Prev (N)) = N_Code_Statement
then
Error_Msg_F
("?code statements in sequence should usually be Volatile", N);
Error_Msg_F
("\?(suggest using template with multiple instructions)", N);
end if;
end Check_Code_Statement;
---------------------- ----------------------
-- Check_References -- -- Check_References --
---------------------- ----------------------
...@@ -431,8 +402,13 @@ package body Sem_Warn is ...@@ -431,8 +402,13 @@ package body Sem_Warn is
-- Pragma Unreferenced not set, so output message -- Pragma Unreferenced not set, so output message
else else
Output_Reference_Error if Referenced (E1) then
("& is never assigned a value?"); Output_Reference_Error
("variable& is read but never assigned?");
else
Output_Reference_Error
("variable& is never read and never assigned?");
end if;
-- Deal with special case where this variable is -- Deal with special case where this variable is
-- hidden by a loop variable -- hidden by a loop variable
...@@ -1174,13 +1150,15 @@ package body Sem_Warn is ...@@ -1174,13 +1150,15 @@ package body Sem_Warn is
then then
Lunit := Entity (Name (Item)); Lunit := Entity (Name (Item));
-- Check if this unit is referenced -- Check if this unit is referenced (skip the check if this
-- is explicitly marked by a pragma Unreferenced).
if not Referenced (Lunit) then
if not Referenced (Lunit)
and then not Has_Pragma_Unreferenced (Lunit)
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,
-- since they refer to problems in internal units) -- since they refer to problems in internal units).
if GNAT_Mode if GNAT_Mode
or else not Is_Internal_File_Name (Unit_File_Name (Unit)) or else not Is_Internal_File_Name (Unit_File_Name (Unit))
...@@ -1202,9 +1180,14 @@ package body Sem_Warn is ...@@ -1202,9 +1180,14 @@ package body Sem_Warn is
-- If main unit is a renaming of this unit, then we consider -- If main unit is a renaming of this unit, then we consider
-- the with to be OK (obviously it is needed in this case!) -- the with to be OK (obviously it is needed in this case!)
-- This may be transitive: the unit in the with_clause may
-- itself be a renaming, in which case both it and the main
-- unit rename the same ultimate package.
elsif Present (Renamed_Entity (Munite)) elsif Present (Renamed_Entity (Munite))
and then Renamed_Entity (Munite) = Lunit and then
(Renamed_Entity (Munite) = Lunit
or else Renamed_Entity (Munite) = Renamed_Entity (Lunit))
then then
null; null;
...@@ -1291,7 +1274,7 @@ package body Sem_Warn is ...@@ -1291,7 +1274,7 @@ package body Sem_Warn is
then then
-- This means that the with is indeed fine, in that -- This means that the with is indeed fine, in that
-- it is definitely needed somewhere, and we can -- it is definitely needed somewhere, and we can
-- quite worrying about this one. -- quit worrying about this one.
-- Except for one little detail, if either of the -- Except for one little detail, if either of the
-- flags was set during spec processing, this is -- flags was set during spec processing, this is
...@@ -1488,6 +1471,149 @@ package body Sem_Warn is ...@@ -1488,6 +1471,149 @@ package body Sem_Warn is
return False; return False;
end Operand_Has_Warnings_Suppressed; end Operand_Has_Warnings_Suppressed;
----------------------------------------
-- Output_Obsolescent_Entity_Warnings --
----------------------------------------
procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is
P : constant Node_Id := Parent (N);
S : Entity_Id;
begin
S := Current_Scope;
-- Do not output message if we are the scope of standard. This means
-- we have a reference from a context clause from when it is originally
-- processed, and that's too early to tell whether it is an obsolescent
-- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make
-- sure that we have a later call when the scope is available. This test
-- also eliminates all messages for use clauses, which is fine (we do
-- not want messages for use clauses, since they are always redundant
-- with respect to the associated with clause).
if S = Standard_Standard then
return;
end if;
-- Do not output message if we are in scope of an obsolescent package
-- or subprogram.
loop
if Is_Obsolescent (S) then
return;
end if;
S := Scope (S);
exit when S = Standard_Standard;
end loop;
-- Here we will output the message
Error_Msg_Sloc := Sloc (E);
-- Case of with clause
if Nkind (P) = N_With_Clause then
if Ekind (E) = E_Package then
Error_Msg_NE
("?with of obsolescent package& declared#", N, E);
elsif Ekind (E) = E_Procedure then
Error_Msg_NE
("?with of obsolescent procedure& declared#", N, E);
else
Error_Msg_NE
("?with of obsolescent function& declared#", N, E);
end if;
-- If we do not have a with clause, then ignore any reference to an
-- obsolescent package name. We only want to give the one warning of
-- withing the package, not one each time it is used to qualify.
elsif Ekind (E) = E_Package then
return;
-- Procedure call statement
elsif Nkind (P) = N_Procedure_Call_Statement then
Error_Msg_NE
("?call to obsolescent procedure& declared#", N, E);
-- Function call
elsif Nkind (P) = N_Function_Call then
Error_Msg_NE
("?call to obsolescent function& declared#", N, E);
-- Reference to obsolescent type
elsif Is_Type (E) then
Error_Msg_NE
("?reference to obsolescent type& declared#", N, E);
-- Reference to obsolescent component
elsif Ekind (E) = E_Component
or else Ekind (E) = E_Discriminant
then
Error_Msg_NE
("?reference to obsolescent component& declared#", N, E);
-- Reference to obsolescent variable
elsif Ekind (E) = E_Variable then
Error_Msg_NE
("?reference to obsolescent variable& declared#", N, E);
-- Reference to obsolescent constant
elsif Ekind (E) = E_Constant
or else Ekind (E) in Named_Kind
then
Error_Msg_NE
("?reference to obsolescent constant& declared#", N, E);
-- Reference to obsolescent enumeration literal
elsif Ekind (E) = E_Enumeration_Literal then
Error_Msg_NE
("?reference to obsolescent enumeration literal& declared#", N, E);
-- Generic message for any other case we missed
else
Error_Msg_NE
("?reference to obsolescent entity& declared#", N, E);
end if;
-- Output additional warning if present
declare
W : constant Node_Id := Obsolescent_Warning (E);
begin
if Present (W) then
-- This is a warning continuation to start on a new line
Name_Buffer (1) := '\';
Name_Buffer (2) := '\';
Name_Buffer (3) := '?';
Name_Len := 3;
-- Add characters to message, and output message. Note that
-- we quote every character of the message since we don't
-- want to process any insertions.
for J in 1 .. String_Length (Strval (W)) loop
Add_Char_To_Name_Buffer (''');
Add_Char_To_Name_Buffer
(Get_Character (Get_String_Char (Strval (W), J)));
end loop;
Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
end if;
end;
end Output_Obsolescent_Entity_Warnings;
---------------------------------- ----------------------------------
-- Output_Unreferenced_Messages -- -- Output_Unreferenced_Messages --
---------------------------------- ----------------------------------
...@@ -1516,9 +1642,9 @@ package body Sem_Warn is ...@@ -1516,9 +1642,9 @@ package body Sem_Warn is
if Warn_On_Modified_Unread if Warn_On_Modified_Unread
and then not Is_Imported (E) and then not Is_Imported (E)
-- Suppress the message for aliased or renamed -- Suppress message for aliased or renamed variables,
-- variables, since there may be other entities read -- since there may be other entities that read the
-- the same memory location. -- 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))
...@@ -1526,19 +1652,37 @@ package body Sem_Warn is ...@@ -1526,19 +1652,37 @@ package body Sem_Warn is
then then
Error_Msg_N Error_Msg_N
("variable & is assigned but never read?", E); ("variable & is assigned but never read?", E);
Set_Last_Assignment (E, Empty);
end if; end if;
-- Normal case of neither assigned nor read -- Normal case of neither assigned nor read
else else
if Present (Renamed_Object (E)) -- We suppress the message for limited controlled types,
and then Comes_From_Source (Renamed_Object (E)) -- to catch the common design pattern (known as RAII, or
-- Resource Acquisition Is Initialization) which uses
-- such types solely for their initialization and
-- finalization semantics.
if Is_Controlled (Etype (E))
and then Is_Limited_Type (Etype (E))
then then
Error_Msg_N null;
("renamed variable & is not referenced?", E);
-- Normal case where we want to give message
else else
Error_Msg_N -- Distinguish renamed case in message
("variable & is not referenced?", E);
if Present (Renamed_Object (E))
and then Comes_From_Source (Renamed_Object (E))
then
Error_Msg_N
("renamed variable & is not referenced?", E);
else
Error_Msg_N
("variable & is not referenced?", E);
end if;
end if; end if;
end if; end if;
...@@ -1604,176 +1748,192 @@ package body Sem_Warn is ...@@ -1604,176 +1748,192 @@ package body Sem_Warn is
begin begin
case C is case C is
when 'a' => when 'a' =>
Check_Unreferenced := True; Check_Unreferenced := True;
Check_Unreferenced_Formals := True; Check_Unreferenced_Formals := True;
Check_Withs := True; Check_Withs := True;
Constant_Condition_Warnings := True; Constant_Condition_Warnings := True;
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_Bad_Fixed_Value := True; Warn_On_Assumed_Low_Bound := True;
Warn_On_Constant := True; Warn_On_Bad_Fixed_Value := True;
Warn_On_Export_Import := True; Warn_On_Constant := True;
Warn_On_Modified_Unread := True; Warn_On_Export_Import := True;
Warn_On_No_Value_Assigned := True; Warn_On_Modified_Unread := True;
Warn_On_Obsolescent_Feature := True; Warn_On_No_Value_Assigned := True;
Warn_On_Redundant_Constructs := True; Warn_On_Obsolescent_Feature := True;
Warn_On_Unchecked_Conversion := True; Warn_On_Questionable_Missing_Parens := True;
Warn_On_Unrecognized_Pragma := True; Warn_On_Redundant_Constructs := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unrecognized_Pragma := True;
when 'A' => when 'A' =>
Check_Unreferenced := False; Check_Unreferenced := False;
Check_Unreferenced_Formals := False; Check_Unreferenced_Formals := False;
Check_Withs := False; Check_Withs := False;
Constant_Condition_Warnings := False; Constant_Condition_Warnings := False;
Elab_Warnings := False; Elab_Warnings := False;
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_Bad_Fixed_Value := False; Warn_On_Bad_Fixed_Value := False;
Warn_On_Constant := False; Warn_On_Constant := False;
Warn_On_Dereference := False; Warn_On_Deleted_Code := False;
Warn_On_Export_Import := False; Warn_On_Dereference := False;
Warn_On_Hiding := False; Warn_On_Export_Import := False;
Warn_On_Modified_Unread := False; Warn_On_Hiding := False;
Warn_On_No_Value_Assigned := False; Warn_On_Modified_Unread := False;
Warn_On_Obsolescent_Feature := False; Warn_On_No_Value_Assigned := False;
Warn_On_Redundant_Constructs := False; Warn_On_Obsolescent_Feature := False;
Warn_On_Unchecked_Conversion := False; Warn_On_Questionable_Missing_Parens := True;
Warn_On_Unrecognized_Pragma := False; Warn_On_Redundant_Constructs := False;
Warn_On_Unchecked_Conversion := False;
Warn_On_Unrecognized_Pragma := False;
when 'b' => when 'b' =>
Warn_On_Bad_Fixed_Value := True; Warn_On_Bad_Fixed_Value := True;
when 'B' => when 'B' =>
Warn_On_Bad_Fixed_Value := False; Warn_On_Bad_Fixed_Value := False;
when 'c' => when 'c' =>
Constant_Condition_Warnings := True; Constant_Condition_Warnings := True;
when 'C' => when 'C' =>
Constant_Condition_Warnings := False; Constant_Condition_Warnings := False;
when 'd' => when 'd' =>
Warn_On_Dereference := True; Warn_On_Dereference := True;
when 'D' => when 'D' =>
Warn_On_Dereference := False; Warn_On_Dereference := False;
when 'e' => when 'e' =>
Warning_Mode := Treat_As_Error; Warning_Mode := Treat_As_Error;
when 'f' => when 'f' =>
Check_Unreferenced_Formals := True; Check_Unreferenced_Formals := True;
when 'F' => when 'F' =>
Check_Unreferenced_Formals := False; Check_Unreferenced_Formals := False;
when 'g' => when 'g' =>
Warn_On_Unrecognized_Pragma := True; Warn_On_Unrecognized_Pragma := True;
when 'G' => when 'G' =>
Warn_On_Unrecognized_Pragma := False; Warn_On_Unrecognized_Pragma := False;
when 'h' => when 'h' =>
Warn_On_Hiding := True; Warn_On_Hiding := True;
when 'H' => when 'H' =>
Warn_On_Hiding := False; Warn_On_Hiding := False;
when 'i' => when 'i' =>
Implementation_Unit_Warnings := True; Implementation_Unit_Warnings := True;
when 'I' => when 'I' =>
Implementation_Unit_Warnings := False; Implementation_Unit_Warnings := False;
when 'j' => when 'j' =>
Warn_On_Obsolescent_Feature := True; Warn_On_Obsolescent_Feature := True;
when 'J' => when 'J' =>
Warn_On_Obsolescent_Feature := False; Warn_On_Obsolescent_Feature := False;
when 'k' => when 'k' =>
Warn_On_Constant := True; Warn_On_Constant := True;
when 'K' => when 'K' =>
Warn_On_Constant := False; Warn_On_Constant := False;
when 'l' => when 'l' =>
Elab_Warnings := True; Elab_Warnings := True;
when 'L' => when 'L' =>
Elab_Warnings := False; Elab_Warnings := False;
when 'm' => when 'm' =>
Warn_On_Modified_Unread := True; Warn_On_Modified_Unread := True;
when 'M' => when 'M' =>
Warn_On_Modified_Unread := False; Warn_On_Modified_Unread := False;
when 'n' => when 'n' =>
Warning_Mode := Normal; Warning_Mode := Normal;
when 'o' => when 'o' =>
Address_Clause_Overlay_Warnings := True; Address_Clause_Overlay_Warnings := True;
when 'O' => when 'O' =>
Address_Clause_Overlay_Warnings := False; Address_Clause_Overlay_Warnings := False;
when 'p' => when 'p' =>
Ineffective_Inline_Warnings := True; Ineffective_Inline_Warnings := True;
when 'P' => when 'P' =>
Ineffective_Inline_Warnings := False; Ineffective_Inline_Warnings := False;
when 'q' =>
Warn_On_Questionable_Missing_Parens := True;
when 'Q' =>
Warn_On_Questionable_Missing_Parens := False;
when 'r' => when 'r' =>
Warn_On_Redundant_Constructs := True; Warn_On_Redundant_Constructs := True;
when 'R' => when 'R' =>
Warn_On_Redundant_Constructs := False; Warn_On_Redundant_Constructs := False;
when 's' => when 's' =>
Warning_Mode := Suppress; Warning_Mode := Suppress;
when 't' =>
Warn_On_Deleted_Code := True;
when 'T' =>
Warn_On_Deleted_Code := False;
when 'u' => when 'u' =>
Check_Unreferenced := True; Check_Unreferenced := True;
Check_Withs := True; Check_Withs := True;
Check_Unreferenced_Formals := True; Check_Unreferenced_Formals := True;
when 'U' => when 'U' =>
Check_Unreferenced := False; Check_Unreferenced := False;
Check_Withs := False; Check_Withs := False;
Check_Unreferenced_Formals := False; Check_Unreferenced_Formals := False;
when 'v' => when 'v' =>
Warn_On_No_Value_Assigned := True; Warn_On_No_Value_Assigned := True;
when 'V' => when 'V' =>
Warn_On_No_Value_Assigned := False; Warn_On_No_Value_Assigned := False;
when 'w' =>
Warn_On_Assumed_Low_Bound := True;
when 'W' =>
Warn_On_Assumed_Low_Bound := False;
when 'x' => when 'x' =>
Warn_On_Export_Import := True; Warn_On_Export_Import := True;
when 'X' => when 'X' =>
Warn_On_Export_Import := False; Warn_On_Export_Import := False;
when 'y' => when 'y' =>
Warn_On_Ada_2005_Compatibility := True; Warn_On_Ada_2005_Compatibility := True;
when 'Y' => when 'Y' =>
Warn_On_Ada_2005_Compatibility := False; Warn_On_Ada_2005_Compatibility := False;
when 'z' => when 'z' =>
Warn_On_Unchecked_Conversion := True; Warn_On_Unchecked_Conversion := True;
when 'Z' => when 'Z' =>
Warn_On_Unchecked_Conversion := False; Warn_On_Unchecked_Conversion := False;
-- Allow and ignore 'w' so that the old
-- format (e.g. -gnatwuwl) will work.
when 'w' =>
null;
when others => when others =>
return False; return False;
...@@ -1789,6 +1949,52 @@ package body Sem_Warn is ...@@ -1789,6 +1949,52 @@ package body Sem_Warn is
procedure Warn_On_Known_Condition (C : Node_Id) is procedure Warn_On_Known_Condition (C : Node_Id) is
P : Node_Id; P : Node_Id;
procedure Track (N : Node_Id; Loc : Node_Id);
-- Adds continuation warning(s) pointing to reason (assignment or test)
-- for the operand of the conditional having a known value (or at least
-- enough is known about the value to issue the warning). N is the node
-- which is judged to have a known value. Loc is the warning location.
-----------
-- Track --
-----------
procedure Track (N : Node_Id; Loc : Node_Id) is
Nod : constant Node_Id := Original_Node (N);
begin
if Nkind (Nod) in N_Op_Compare then
Track (Left_Opnd (Nod), Loc);
Track (Right_Opnd (Nod), Loc);
elsif Is_Entity_Name (Nod)
and then Is_Object (Entity (Nod))
then
declare
CV : constant Node_Id := Current_Value (Entity (Nod));
begin
if Present (CV) then
Error_Msg_Sloc := Sloc (CV);
if Nkind (CV) not in N_Subexpr then
Error_Msg_N ("\\?(see test #)", Loc);
elsif Nkind (Parent (CV)) =
N_Case_Statement_Alternative
then
Error_Msg_N ("\\?(see case alternative #)", Loc);
else
Error_Msg_N ("\\?(see assignment #)", Loc);
end if;
end if;
end;
end if;
end Track;
-- Start of processing for Warn_On_Known_Condition
begin begin
-- Argument replacement in an inlined body can make conditions static. -- Argument replacement in an inlined body can make conditions static.
-- Do not emit warnings in this case. -- Do not emit warnings in this case.
...@@ -1869,16 +2075,441 @@ package body Sem_Warn is ...@@ -1869,16 +2075,441 @@ package body Sem_Warn is
and then Nkind (Cond) /= N_Op_Not and then Nkind (Cond) /= N_Op_Not
then then
Error_Msg_NE Error_Msg_NE
("object & is always True?", Cond, Original_Node (C)); ("object & is always True?", Cond, Original_Node (C));
Track (Original_Node (C), Cond);
else else
Error_Msg_N ("condition is always True?", Cond); Error_Msg_N ("condition is always True?", Cond);
Track (Cond, Cond);
end if; end if;
else else
Error_Msg_N ("condition is always False?", Cond); Error_Msg_N ("condition is always False?", Cond);
Track (Cond, Cond);
end if; end if;
end; end;
end if; end if;
end if; end if;
end Warn_On_Known_Condition; end Warn_On_Known_Condition;
------------------------------
-- Warn_On_Suspicious_Index --
------------------------------
procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is
Low_Bound : Uint;
-- Set to lower bound for a suspicious type
Ent : Entity_Id;
-- Entity for array reference
Typ : Entity_Id;
-- Array type
function Is_Suspicious_Type (Typ : Entity_Id) return Boolean;
-- Tests to see if Typ is a type for which we may have a suspicious
-- index, namely an unconstrained array type, whose lower bound is
-- either zero or one. If so, True is returned, and Low_Bound is set
-- to this lower bound. If not, False is returned, and Low_Bound is
-- undefined on return.
--
-- For now, we limite this to standard string types, so any other
-- unconstrained types return False. We may change our minds on this
-- later on, but strings seem the most important case.
procedure Test_Suspicious_Index;
-- Test if index is of suspicious type and if so, generate warning
------------------------
-- Is_Suspicious_Type --
------------------------
function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is
LB : Node_Id;
begin
if Is_Array_Type (Typ)
and then not Is_Constrained (Typ)
and then Number_Dimensions (Typ) = 1
and then not Warnings_Off (Typ)
and then (Root_Type (Typ) = Standard_String
or else
Root_Type (Typ) = Standard_Wide_String
or else
Root_Type (Typ) = Standard_Wide_Wide_String)
then
LB := Type_Low_Bound (Etype (First_Index (Typ)));
if Compile_Time_Known_Value (LB) then
Low_Bound := Expr_Value (LB);
return Low_Bound = Uint_0 or else Low_Bound = Uint_1;
end if;
end if;
return False;
end Is_Suspicious_Type;
---------------------------
-- Test_Suspicious_Index --
---------------------------
procedure Test_Suspicious_Index is
function Length_Reference (N : Node_Id) return Boolean;
-- Check if node N is of the form Name'Length
procedure Warn1;
-- Generate first warning line
----------------------
-- Length_Reference --
----------------------
function Length_Reference (N : Node_Id) return Boolean is
R : constant Node_Id := Original_Node (N);
begin
return
Nkind (R) = N_Attribute_Reference
and then Attribute_Name (R) = Name_Length
and then Is_Entity_Name (Prefix (R))
and then Entity (Prefix (R)) = Ent;
end Length_Reference;
-----------
-- Warn1 --
-----------
procedure Warn1 is
begin
Error_Msg_Uint_1 := Low_Bound;
Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent);
end Warn1;
-- Start of processing for Test_Suspicious_Index
begin
-- Nothing to do if subscript does not come from source (we don't
-- want to give garbage warnings on compiler expanded code, e.g. the
-- loops generated for slice assignments. Sucb junk warnings would
-- be placed on source constructs with no subscript in sight!)
if not Comes_From_Source (Original_Node (X)) then
return;
end if;
-- Case where subscript is a constant integer
if Nkind (X) = N_Integer_Literal then
Warn1;
-- Case where original form of subscript is an integer literal
if Nkind (Original_Node (X)) = N_Integer_Literal then
if Intval (X) = Low_Bound then
Error_Msg_FE
("\suggested replacement: `&''First`", X, Ent);
else
Error_Msg_Uint_1 := Intval (X) - Low_Bound;
Error_Msg_FE
("\suggested replacement: `&''First + ^`", X, Ent);
end if;
-- Case where original form of subscript is more complex
else
-- Build string X'First - 1 + expression where the expression
-- is the original subscript. If the expression starts with "1
-- + ", then the "- 1 + 1" is elided.
Error_Msg_String (1 .. 13) := "'First - 1 + ";
Error_Msg_Strlen := 13;
declare
Sref : Source_Ptr := Sloc (First_Node (Original_Node (X)));
Tref : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (Sref));
-- Tref (Sref) is used to scan the subscript
Pctr : Natural;
-- Paretheses counter when scanning subscript
begin
-- Tref (Sref) points to start of subscript
-- Elide - 1 if subscript starts with 1 +
if Tref (Sref .. Sref + 2) = "1 +" then
Error_Msg_Strlen := Error_Msg_Strlen - 6;
Sref := Sref + 2;
elsif Tref (Sref .. Sref + 1) = "1+" then
Error_Msg_Strlen := Error_Msg_Strlen - 6;
Sref := Sref + 1;
end if;
-- Now we will copy the subscript to the string buffer
Pctr := 0;
loop
-- Count parens, exit if terminating right paren. Note
-- check to ignore paren appearing as character literal.
if Tref (Sref + 1) = '''
and then
Tref (Sref - 1) = '''
then
null;
else
if Tref (Sref) = '(' then
Pctr := Pctr + 1;
elsif Tref (Sref) = ')' then
exit when Pctr = 0;
Pctr := Pctr - 1;
end if;
end if;
-- Done if terminating double dot (slice case)
exit when Pctr = 0
and then (Tref (Sref .. Sref + 1) = ".."
or else
Tref (Sref .. Sref + 2) = " ..");
-- Quit if we have hit EOF character, something wrong
if Tref (Sref) = EOF then
return;
end if;
-- String literals are too much of a pain to handle
if Tref (Sref) = '"' or else Tref (Sref) = '%' then
return;
end if;
-- If we have a 'Range reference, then this is a case
-- where we cannot easily give a replacement. Don't try!
if Tref (Sref .. Sref + 4) = "range"
and then Tref (Sref - 1) < 'A'
and then Tref (Sref + 5) < 'A'
then
return;
end if;
-- Else store next character
Error_Msg_Strlen := Error_Msg_Strlen + 1;
Error_Msg_String (Error_Msg_Strlen) := Tref (Sref);
Sref := Sref + 1;
-- If we get more than 40 characters then the expression
-- is too long to copy, or something has gone wrong. In
-- either case, just skip the attempt at a suggested fix.
if Error_Msg_Strlen > 40 then
return;
end if;
end loop;
end;
-- Replacement subscript is now in string buffer
Error_Msg_FE
("\suggested replacement: `&~`", Original_Node (X), Ent);
end if;
-- Case where subscript is of the form X'Length
elsif Length_Reference (X) then
Warn1;
Error_Msg_Node_2 := Ent;
Error_Msg_FE
("\suggest replacement of `&''Length` by `&''Last`",
X, Ent);
-- Case where subscript is of the form X'Length - expression
elsif Nkind (X) = N_Op_Subtract
and then Length_Reference (Left_Opnd (X))
then
Warn1;
Error_Msg_Node_2 := Ent;
Error_Msg_FE
("\suggest replacement of `&''Length` by `&''Last`",
Left_Opnd (X), Ent);
end if;
end Test_Suspicious_Index;
-- Start of processing for Warn_On_Suspicious_Index
begin
-- Only process if warnings activated
if Warn_On_Assumed_Low_Bound then
-- Test if array is simple entity name
if Is_Entity_Name (Name) then
-- Test if array is parameter of unconstrained string type
Ent := Entity (Name);
Typ := Etype (Ent);
if Is_Formal (Ent)
and then Is_Suspicious_Type (Typ)
and then not Low_Bound_Known (Ent)
then
Test_Suspicious_Index;
end if;
end if;
end if;
end Warn_On_Suspicious_Index;
--------------------------------
-- Warn_On_Useless_Assignment --
--------------------------------
procedure Warn_On_Useless_Assignment
(Ent : Entity_Id;
Loc : Source_Ptr := No_Location)
is
P : Node_Id;
X : Node_Id;
function Check_Ref (N : Node_Id) return Traverse_Result;
-- Used to instantiate Traverse_Func. Returns Abandon if
-- a reference to the entity in question is found.
function Test_No_Refs is new Traverse_Func (Check_Ref);
---------------
-- Check_Ref --
---------------
function Check_Ref (N : Node_Id) return Traverse_Result is
begin
-- Check reference to our identifier. We use name equality here
-- because the exception handlers have not yet been analyzed. This
-- is not quite right, but it really does not matter that we fail
-- to output the warning in some obscure cases of name clashes.
if Nkind (N) = N_Identifier
and then Chars (N) = Chars (Ent)
then
return Abandon;
else
return OK;
end if;
end Check_Ref;
-- 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.
if Ekind (Ent) = E_Variable
and then Present (Last_Assignment (Ent))
and then not Warnings_Off (Ent)
and then not Has_Pragma_Unreferenced (Ent)
and then not Is_Imported (Ent)
and then not Is_Exported (Ent)
then
-- Before we issue the message, check covering exception handlers.
-- Search up tree for enclosing statement sequences and handlers
P := Parent (Last_Assignment (Ent));
while Present (P) loop
-- Something is really wrong if we don't find a handled
-- statement sequence, so just suppress the warning.
if No (P) then
Set_Last_Assignment (Ent, Empty);
return;
-- When we hit a package/subprogram body, issue warning and exit
elsif Nkind (P) = N_Subprogram_Body
or else Nkind (P) = N_Package_Body
then
if Loc = No_Location then
Error_Msg_NE
("?useless assignment to&, value never referenced",
Last_Assignment (Ent), Ent);
else
Error_Msg_Sloc := Loc;
Error_Msg_NE
("?useless assignment to&, value overwritten #",
Last_Assignment (Ent), Ent);
end if;
Set_Last_Assignment (Ent, Empty);
return;
-- Enclosing handled sequence of statements
elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
-- Check exception handlers present
if Present (Exception_Handlers (P)) then
-- If we are not at the top level, we regard an inner
-- exception handler as a decisive indicator that we should
-- not generate the warning, since the variable in question
-- may be acceessed after an exception in the outer block.
if Nkind (Parent (P)) /= N_Subprogram_Body
and then Nkind (Parent (P)) /= N_Package_Body
then
Set_Last_Assignment (Ent, Empty);
return;
-- Otherwise we are at the outer level. An exception
-- handler is significant only if it references the
-- variable in question.
else
X := First (Exception_Handlers (P));
while Present (X) loop
if Test_No_Refs (X) = Abandon then
Set_Last_Assignment (Ent, Empty);
return;
end if;
X := Next (X);
end loop;
end if;
end if;
end if;
P := Parent (P);
end loop;
end if;
end Warn_On_Useless_Assignment;
---------------------------------
-- Warn_On_Useless_Assignments --
---------------------------------
procedure Warn_On_Useless_Assignments (E : Entity_Id) is
Ent : Entity_Id;
begin
if Warn_On_Modified_Unread
and then In_Extended_Main_Source_Unit (E)
then
Ent := First_Entity (E);
while Present (Ent) loop
Warn_On_Useless_Assignment (Ent);
Next_Entity (Ent);
end loop;
end if;
end Warn_On_Useless_Assignments;
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-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2006, 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- --
...@@ -98,6 +98,11 @@ package Sem_Warn is ...@@ -98,6 +98,11 @@ package Sem_Warn is
-- Output Routines -- -- Output Routines --
--------------------- ---------------------
procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id);
-- N is a reference to obsolescent entity E, for which appropriate warning
-- messages are to be generated (caller has already checked that warnings
-- are active and appropriate for this entity).
procedure Output_Unreferenced_Messages; procedure Output_Unreferenced_Messages;
-- Warnings about unreferenced entities are collected till the end of -- Warnings about unreferenced entities are collected till the end of
-- the compilation process (see Check_Unset_Reference for further -- the compilation process (see Check_Unset_Reference for further
...@@ -107,6 +112,9 @@ package Sem_Warn is ...@@ -107,6 +112,9 @@ package Sem_Warn is
-- Other Warning Routines -- -- Other Warning Routines --
---------------------------- ----------------------------
procedure Check_Code_Statement (N : Node_Id);
-- Peform warning checks on a code statement node
procedure Warn_On_Known_Condition (C : Node_Id); procedure Warn_On_Known_Condition (C : Node_Id);
-- C is a node for a boolean expression resluting from a relational -- C is a node for a boolean expression resluting from a relational
-- or membership operation. If the expression has a compile time known -- or membership operation. If the expression has a compile time known
...@@ -132,4 +140,29 @@ package Sem_Warn is ...@@ -132,4 +140,29 @@ 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.
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
-- for the indexed component case, or one of the bounds in the slice case.
-- If Name is an unconstrained parameter of a standard string type, and
-- the index is of the form of a literal or Name'Length [- literal], then
-- a warning is generated that the subscripting operation is possibly
-- incorrectly assuming a lower bound of 1.
procedure Warn_On_Useless_Assignment
(Ent : Entity_Id;
Loc : Source_Ptr := No_Location);
-- 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 Warn_On_Modified_Unread is True, and if Ent is in
-- the extended main source unit. Loc is No_Location for the end of block
-- call (warning msg says value unreferenced), or the it is the location of
-- an overwriting assignment (warning msg points to this assignment).
procedure Warn_On_Useless_Assignments (E : Entity_Id);
pragma Inline (Warn_On_Useless_Assignments);
-- Called at the end of a block or subprogram. Scans the entities of the
-- block or subprogram to see if there are any variables for which useless
-- assignments were made (assignments whose values were never read).
end Sem_Warn; end Sem_Warn;
gcc/ada/xref_lib.adb
...@@ -136,12 +136,14 @@ package body Xref_Lib is ...@@ -136,12 +136,14 @@ package body Xref_Lib is
Entity : String; Entity : String;
Glob : Boolean := False) Glob : Boolean := False)
is is
File_Start : Natural; File_Start : Natural;
Line_Start : Natural; Line_Start : Natural;
Col_Start : Natural; Col_Start : Natural;
Line_Num : Natural := 0; Line_Num : Natural := 0;
Col_Num : Natural := 0; Col_Num : Natural := 0;
File_Ref : File_Reference := Empty_File;
File_Ref : File_Reference := Empty_File;
pragma Warnings (Off, File_Ref);
begin begin
-- Find the end of the first item in Entity (pattern or file?) -- Find the end of the first item in Entity (pattern or file?)
...@@ -275,7 +277,9 @@ package body Xref_Lib is ...@@ -275,7 +277,9 @@ package body Xref_Lib is
Add_To_Xref_File Add_To_Xref_File
(Entity (File_Start .. Line_Start - 1), Visited => True); (Entity (File_Start .. Line_Start - 1), Visited => True);
Pattern.File_Ref := File_Ref; Pattern.File_Ref := File_Ref;
Add_Line (Pattern.File_Ref, Line_Num, Col_Num); Add_Line (Pattern.File_Ref, Line_Num, Col_Num);
File_Ref := File_Ref :=
Add_To_Xref_File Add_To_Xref_File
(ALI_File_Name (Entity (File_Start .. Line_Start - 1)), (ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
......
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