with Sem; use Sem;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
if Opt.Xref_Active
-- Definition must come from source
+
-- We make an exception for subprogram child units that have no
-- spec. For these we generate a subprogram declaration for library
-- use, and the corresponding entity does not come from source.
Ent : Entity_Id;
function Is_On_LHS (Node : Node_Id) return Boolean;
- -- Used to check if a node is on the left hand side of an
- -- assignment. The following cases are handled:
+ -- Used to check if a node is on the left hand side of an assignment.
+ -- The following cases are handled:
--
- -- Variable Node is a direct descendant of an assignment
- -- statement.
+ -- Variable Node is a direct descendant of an assignment statement.
--
- -- Prefix Of an indexed or selected component that is
- -- present in a subtree rooted by an assignment
- -- statement. There is no restriction of nesting
- -- of components, thus cases such as A.B(C).D are
- -- handled properly.
+ -- Prefix Of an indexed or selected component that is present in a
+ -- subtree rooted by an assignment statement. There is no
+ -- restriction of nesting of components, thus cases such as
+ -- A.B(C).D are handled properly.
---------------
-- Is_On_LHS --
return False;
end if;
- -- Reach the assignment statement subtree root. In the
- -- case of a variable being a direct descendant of an
- -- assignment statement, the loop is skiped.
+ -- Reach the assignment statement subtree root. In the case of a
+ -- variable being a direct descendant of an assignment statement,
+ -- the loop is skiped.
while Nkind (Parent (N)) /= N_Assignment_Statement loop
begin
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
Check_Restriction (No_Obsolescent_Features, N);
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
-- 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 Warn_On_Ada_2005_Compatibility
and then (Typ = 'm' or else Typ = 'r')
-- case of 'p' since we want to include inherited primitive operations
-- from other packages.
- if not In_Extended_Main_Source_Unit (N)
- and then Typ /= 'e'
- and then Typ /= 'p'
- and then Typ /= 'k'
- then
- return;
+ -- We also omit this test is this is a body reference for a subprogram
+ -- instantiation. In this case the reference is to the generic body,
+ -- which clearly need not be in the main unit containing the instance.
+ -- For the same reason we accept an implicit reference generated for
+ -- a default in an instance.
+
+ 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;
-- For reference type p, the entity must be in main source unit
return;
end if;
- -- Unless the reference is forced, we ignore references where
- -- the reference itself does not come from Source.
+ -- Unless the reference is forced, we ignore references where the
+ -- reference itself does not come from Source.
if not Force and then not Comes_From_Source (N) then
return;
end if;
- -- Deal with setting entity as referenced, unless suppressed.
- -- Note that we still do Set_Referenced on entities that do not
- -- come from source. This situation arises when we have a source
- -- reference to a derived operation, where the derived operation
- -- itself does not come from source, but we still want to mark it
- -- as referenced, since we really are referencing an entity in the
- -- corresponding package (this avoids incorrect complaints that the
- -- package contains no referenced entities).
+ -- Deal with setting entity as referenced, unless suppressed. Note that
+ -- we still do Set_Referenced on entities that do not come from source.
+ -- This situation arises when we have a source reference to a derived
+ -- operation, where the derived operation itself does not come from
+ -- source, but we still want to mark it as referenced, since we really
+ -- are referencing an entity in the corresponding package (this avoids
+ -- wrong complaints that the package contains no referenced entities).
if Set_Ref then
- -- For a variable that appears on the left side of an
- -- assignment statement, we set the Referenced_As_LHS
- -- flag since this is indeed a left hand side.
- -- We also set the Referenced_As_LHS flag of a prefix
- -- of selected or indexed component.
+ -- For a variable that appears on the left side of an assignment
+ -- statement, we set the Referenced_As_LHS flag since this is indeed
+ -- a left hand side. We also set the Referenced_As_LHS flag of a
+ -- prefix of selected or indexed component.
if Ekind (E) = E_Variable
and then Is_On_LHS (N)
elsif Is_Non_Significant_Pragma_Reference (N) then
null;
- -- A reference in an attribute definition clause does not
- -- count as a reference except for the case of Address.
- -- The reason that 'Address is an exception is that it
- -- creates an alias through which the variable may be
- -- referenced.
+ -- A reference in an attribute definition clause does not count as a
+ -- reference except for the case of Address. The reason that 'Address
+ -- is an exception is that it creates an alias through which the
+ -- variable may be referenced.
elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
and then Chars (Parent (N)) /= Name_Address
else
Set_Referenced (E);
+
+ if Ekind (E) = E_Variable then
+ Set_Last_Assignment (E, Empty);
+ end if;
end if;
-- Check for pragma Unreferenced given and reference is within
elsif Is_On_LHS (N) then
null;
- -- For entry formals, we want to place the warning on the
- -- corresponding entity in the accept statement. The current
- -- scope is the body of the accept, so we find the formal
- -- whose name matches that of the entry formal (there is no
- -- link between the two entities, and the one in the accept
- -- statement is only used for conformance checking).
+ -- For entry formals, we want to place the warning message on the
+ -- corresponding entity in the accept statement. The current scope
+ -- is the body of the accept, so we find the formal whose name
+ -- matches that of the entry formal (there is no link between the
+ -- two entities, and the one in the accept statement is only used
+ -- for conformance checking).
elsif Ekind (Scope (E)) = E_Entry then
declare
and then Present (Alias (E))
then
Ent := Alias (E);
-
- loop
- if Comes_From_Source (Ent) then
- exit;
- elsif No (Alias (Ent)) then
+ while not Comes_From_Source (Ent) loop
+ if No (Alias (Ent)) then
return;
- else
- Ent := Alias (Ent);
end if;
+
+ Ent := Alias (Ent);
end loop;
-- The internally created defining entity for a child subprogram
begin
Formal := First_Entity (E);
-
while Present (Formal) loop
if Comes_From_Source (Formal) then
Generate_Reference (E, Formal, 'z', False);
Right := ')';
end if;
- -- If non-derived array, get component type.
- -- Skip component type for case of String
- -- or Wide_String, saves worthwhile space.
+ -- If non-derived array, get component type. Skip component
+ -- type for case of String or Wide_String, saves worthwhile
+ -- space.
elsif Is_Array_Type (Tref)
and then Tref /= Standard_String
procedure Output_Import_Export_Info (Ent : Entity_Id) is
Language_Name : Name_Id;
Conv : constant Convention_Id := Convention (Ent);
+
begin
+ -- Generate language name from convention
+
if Conv = Convention_C then
Language_Name := Name_C;
Language_Name := Name_Ada;
else
- -- These are the only languages that GPS knows about
+ -- For the moment we ignore all other cases ???
return;
end if;
-- Name_Change --
-----------------
+ -- Why a string comparison here??? Why not compare Name_Id values???
+
function Name_Change (X : Entity_Id) return Boolean is
begin
Get_Unqualified_Name_String (Chars (X));
-- Special handling for abstract types and operations
if Is_Abstract (XE.Ent) then
-
if Ctyp = 'U' then
Ctyp := 'x'; -- abstract procedure
end if;
end if;
- -- Only output reference if interesting type of entity,
- -- and suppress self references, except for bodies that
- -- act as specs. Also suppress definitions of body formals
- -- (we only treat these as references, and the references
- -- were separately recorded).
+ -- Only output reference if interesting type of entity, and
+ -- suppress self references, except for bodies that act as
+ -- specs. Also suppress definitions of body formals (we only
+ -- treat these as references, and the references were
+ -- separately recorded).
if Ctyp = ' '
or else (XE.Loc = XE.Def
end if;
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
Original_Location (Sloc (XE.Ent)) .. P - 1
loop
(Int (Get_Column_Number (Sloc (Rref))));
end if;
- -- Indicate that the entity is in the unit
- -- of the current xref xection.
+ -- Indicate that the entity is in the unit of the current
+ -- xref xection.
Curru := Curxu;
- -- Write out information about generic parent,
- -- if entity is an instance.
+ -- Write out information about generic parent, if entity
+ -- is an instance.
if Is_Generic_Instance (XE.Ent) then
declare
Gen_Par : constant Entity_Id :=
- Generic_Parent
- (Specification
- (Unit_Declaration_Node (XE.Ent)));
- Loc : constant Source_Ptr := Sloc (Gen_Par);
- Gen_U : constant Unit_Number_Type :=
- Get_Source_Unit (Loc);
+ Generic_Parent
+ (Specification
+ (Unit_Declaration_Node (XE.Ent)));
+ Loc : constant Source_Ptr := Sloc (Gen_Par);
+ Gen_U : constant Unit_Number_Type :=
+ Get_Source_Unit (Loc);
+
begin
Write_Info_Char ('[');
if Curru /= Gen_U then
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
+with Exp_Code; use Exp_Code;
with Fname; use Fname;
with Lib; use Lib;
+with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Table;
+with Uintp; use Uintp;
package body Sem_Warn is
Table_Increment => Alloc.Unreferenced_Entities_Increment,
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 --
-----------------------
-- the Warnings_Off flag is set. True is returned if such an entity is
-- 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 --
----------------------
-- Pragma Unreferenced not set, so output message
else
- Output_Reference_Error
- ("& is never assigned a value?");
+ if Referenced (E1) then
+ 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
-- hidden by a loop variable
then
Lunit := Entity (Name (Item));
- -- Check if this unit is referenced
-
- if not Referenced (Lunit) then
+ -- Check if this unit is referenced (skip the check if this
+ -- is explicitly marked by a pragma Unreferenced).
+ if not Referenced (Lunit)
+ and then not Has_Pragma_Unreferenced (Lunit)
+ then
-- Suppress warnings in internal units if not in -gnatg mode
-- (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
or else not Is_Internal_File_Name (Unit_File_Name (Unit))
-- If main unit is a renaming of this unit, then we consider
-- 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))
- and then Renamed_Entity (Munite) = Lunit
+ and then
+ (Renamed_Entity (Munite) = Lunit
+ or else Renamed_Entity (Munite) = Renamed_Entity (Lunit))
then
null;
then
-- This means that the with is indeed fine, in that
-- 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
-- flags was set during spec processing, this is
return False;
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 --
----------------------------------
if Warn_On_Modified_Unread
and then not Is_Imported (E)
- -- Suppress the message for aliased or renamed
- -- variables, since there may be other entities read
- -- the same memory location.
+ -- Suppress message for aliased or renamed variables,
+ -- since there may be other entities that read the
+ -- same memory location.
and then not Is_Aliased (E)
and then No (Renamed_Object (E))
then
Error_Msg_N
("variable & is assigned but never read?", E);
+ Set_Last_Assignment (E, Empty);
end if;
-- Normal case of neither assigned nor read
else
- if Present (Renamed_Object (E))
- and then Comes_From_Source (Renamed_Object (E))
+ -- We suppress the message for limited controlled types,
+ -- 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
- Error_Msg_N
- ("renamed variable & is not referenced?", E);
+ null;
+
+ -- Normal case where we want to give message
+
else
- Error_Msg_N
- ("variable & is not referenced?", E);
+ -- Distinguish renamed case in message
+
+ 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;
begin
case C is
when 'a' =>
- Check_Unreferenced := True;
- Check_Unreferenced_Formals := True;
- Check_Withs := True;
- Constant_Condition_Warnings := True;
- Implementation_Unit_Warnings := True;
- Ineffective_Inline_Warnings := True;
- Warn_On_Ada_2005_Compatibility := True;
- Warn_On_Bad_Fixed_Value := True;
- Warn_On_Constant := True;
- Warn_On_Export_Import := True;
- Warn_On_Modified_Unread := True;
- Warn_On_No_Value_Assigned := True;
- Warn_On_Obsolescent_Feature := True;
- Warn_On_Redundant_Constructs := True;
- Warn_On_Unchecked_Conversion := True;
- Warn_On_Unrecognized_Pragma := True;
+ Check_Unreferenced := True;
+ Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Ada_2005_Compatibility := True;
+ Warn_On_Assumed_Low_Bound := True;
+ Warn_On_Bad_Fixed_Value := True;
+ Warn_On_Constant := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Obsolescent_Feature := True;
+ Warn_On_Questionable_Missing_Parens := True;
+ Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
when 'A' =>
- Check_Unreferenced := False;
- Check_Unreferenced_Formals := False;
- Check_Withs := False;
- Constant_Condition_Warnings := False;
- Elab_Warnings := False;
- Implementation_Unit_Warnings := False;
- Ineffective_Inline_Warnings := False;
- Warn_On_Ada_2005_Compatibility := False;
- Warn_On_Bad_Fixed_Value := False;
- Warn_On_Constant := False;
- Warn_On_Dereference := False;
- Warn_On_Export_Import := False;
- Warn_On_Hiding := False;
- Warn_On_Modified_Unread := False;
- Warn_On_No_Value_Assigned := False;
- Warn_On_Obsolescent_Feature := False;
- Warn_On_Redundant_Constructs := False;
- Warn_On_Unchecked_Conversion := False;
- Warn_On_Unrecognized_Pragma := False;
+ Check_Unreferenced := False;
+ Check_Unreferenced_Formals := False;
+ Check_Withs := False;
+ Constant_Condition_Warnings := False;
+ Elab_Warnings := False;
+ Implementation_Unit_Warnings := False;
+ Ineffective_Inline_Warnings := False;
+ Warn_On_Ada_2005_Compatibility := False;
+ Warn_On_Bad_Fixed_Value := False;
+ Warn_On_Constant := False;
+ Warn_On_Deleted_Code := False;
+ Warn_On_Dereference := False;
+ Warn_On_Export_Import := False;
+ Warn_On_Hiding := False;
+ Warn_On_Modified_Unread := False;
+ Warn_On_No_Value_Assigned := False;
+ Warn_On_Obsolescent_Feature := False;
+ Warn_On_Questionable_Missing_Parens := True;
+ Warn_On_Redundant_Constructs := False;
+ Warn_On_Unchecked_Conversion := False;
+ Warn_On_Unrecognized_Pragma := False;
when 'b' =>
- Warn_On_Bad_Fixed_Value := True;
+ Warn_On_Bad_Fixed_Value := True;
when 'B' =>
- Warn_On_Bad_Fixed_Value := False;
+ Warn_On_Bad_Fixed_Value := False;
when 'c' =>
- Constant_Condition_Warnings := True;
+ Constant_Condition_Warnings := True;
when 'C' =>
- Constant_Condition_Warnings := False;
+ Constant_Condition_Warnings := False;
when 'd' =>
- Warn_On_Dereference := True;
+ Warn_On_Dereference := True;
when 'D' =>
- Warn_On_Dereference := False;
+ Warn_On_Dereference := False;
when 'e' =>
- Warning_Mode := Treat_As_Error;
+ Warning_Mode := Treat_As_Error;
when 'f' =>
- Check_Unreferenced_Formals := True;
+ Check_Unreferenced_Formals := True;
when 'F' =>
- Check_Unreferenced_Formals := False;
+ Check_Unreferenced_Formals := False;
when 'g' =>
- Warn_On_Unrecognized_Pragma := True;
+ Warn_On_Unrecognized_Pragma := True;
when 'G' =>
- Warn_On_Unrecognized_Pragma := False;
+ Warn_On_Unrecognized_Pragma := False;
when 'h' =>
- Warn_On_Hiding := True;
+ Warn_On_Hiding := True;
when 'H' =>
- Warn_On_Hiding := False;
+ Warn_On_Hiding := False;
when 'i' =>
- Implementation_Unit_Warnings := True;
+ Implementation_Unit_Warnings := True;
when 'I' =>
- Implementation_Unit_Warnings := False;
+ Implementation_Unit_Warnings := False;
when 'j' =>
- Warn_On_Obsolescent_Feature := True;
+ Warn_On_Obsolescent_Feature := True;
when 'J' =>
- Warn_On_Obsolescent_Feature := False;
+ Warn_On_Obsolescent_Feature := False;
when 'k' =>
- Warn_On_Constant := True;
+ Warn_On_Constant := True;
when 'K' =>
- Warn_On_Constant := False;
+ Warn_On_Constant := False;
when 'l' =>
- Elab_Warnings := True;
+ Elab_Warnings := True;
when 'L' =>
- Elab_Warnings := False;
+ Elab_Warnings := False;
when 'm' =>
- Warn_On_Modified_Unread := True;
+ Warn_On_Modified_Unread := True;
when 'M' =>
- Warn_On_Modified_Unread := False;
+ Warn_On_Modified_Unread := False;
when 'n' =>
- Warning_Mode := Normal;
+ Warning_Mode := Normal;
when 'o' =>
- Address_Clause_Overlay_Warnings := True;
+ Address_Clause_Overlay_Warnings := True;
when 'O' =>
- Address_Clause_Overlay_Warnings := False;
+ Address_Clause_Overlay_Warnings := False;
when 'p' =>
- Ineffective_Inline_Warnings := True;
+ Ineffective_Inline_Warnings := True;
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' =>
- Warn_On_Redundant_Constructs := True;
+ Warn_On_Redundant_Constructs := True;
when 'R' =>
- Warn_On_Redundant_Constructs := False;
+ Warn_On_Redundant_Constructs := False;
when 's' =>
- Warning_Mode := Suppress;
+ Warning_Mode := Suppress;
+
+ when 't' =>
+ Warn_On_Deleted_Code := True;
+
+ when 'T' =>
+ Warn_On_Deleted_Code := False;
when 'u' =>
- Check_Unreferenced := True;
- Check_Withs := True;
- Check_Unreferenced_Formals := True;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Check_Unreferenced_Formals := True;
when 'U' =>
- Check_Unreferenced := False;
- Check_Withs := False;
- Check_Unreferenced_Formals := False;
+ Check_Unreferenced := False;
+ Check_Withs := False;
+ Check_Unreferenced_Formals := False;
when 'v' =>
- Warn_On_No_Value_Assigned := True;
+ Warn_On_No_Value_Assigned := True;
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' =>
- Warn_On_Export_Import := True;
+ Warn_On_Export_Import := True;
when 'X' =>
- Warn_On_Export_Import := False;
+ Warn_On_Export_Import := False;
when 'y' =>
- Warn_On_Ada_2005_Compatibility := True;
+ Warn_On_Ada_2005_Compatibility := True;
when 'Y' =>
- Warn_On_Ada_2005_Compatibility := False;
+ Warn_On_Ada_2005_Compatibility := False;
when 'z' =>
- Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unchecked_Conversion := True;
when 'Z' =>
- Warn_On_Unchecked_Conversion := False;
-
- -- Allow and ignore 'w' so that the old
- -- format (e.g. -gnatwuwl) will work.
-
- when 'w' =>
- null;
+ Warn_On_Unchecked_Conversion := False;
when others =>
return False;
procedure Warn_On_Known_Condition (C : Node_Id) is
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
-- Argument replacement in an inlined body can make conditions static.
-- Do not emit warnings in this case.
and then Nkind (Cond) /= N_Op_Not
then
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
Error_Msg_N ("condition is always True?", Cond);
+ Track (Cond, Cond);
end if;
+
else
Error_Msg_N ("condition is always False?", Cond);
+ Track (Cond, Cond);
end if;
end;
end if;
end if;
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;
OSDN Git Service
