-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
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. ???
+
-- One entry is made in the following table for each branch of
-- a conditional, e.g. an if-then-elsif-else-endif structure
-- creates three entries in this table.
Table_Increment => Alloc.Conditional_Stack_Increment,
Table_Name => "Conditional_Stack");
- Current_Entity_List : Elist_Id := No_Elist;
- -- This is a copy of the Defs list of the current branch of the current
- -- conditional. It could be accessed by taking the top element of the
- -- Conditional_Stack, and going to te Current_Branch entry of this
- -- conditional, but we keep it precomputed for rapid access.
+ pragma Warnings (Off, Branch_Table);
+ pragma Warnings (Off, Conditional_Table);
+ pragma Warnings (Off, Conditional_Stack);
+ -- Not yet referenced, see note above ???
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean;
+ -- This returns true if the entity E is declared within a generic package.
+ -- The point of this is to detect variables which are not assigned within
+ -- the generic, but might be assigned outside the package for any given
+ -- instance. These are cases where we leave the warnings to be posted
+ -- for the instance, when we will know more.
+
+ function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean;
+ -- This function traverses the expression tree represented by the node
+ -- N and determines if any sub-operand is a reference to an entity for
+ -- which the Warnings_Off flag is set. True is returned if such an
+ -- entity is encountered, and False otherwise.
----------------------
-- Check_References --
procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
E1 : Entity_Id;
UR : Node_Id;
- PU : Node_Id;
+
+ function Missing_Subunits return Boolean;
+ -- We suppress warnings when there are missing subunits, because this
+ -- may generate too many false positives: entities in a parent may
+ -- only be referenced in one of the subunits. We make an exception
+ -- for subunits that contain no other stubs.
procedure Output_Reference_Error (M : String);
-- Used to output an error message. Deals with posting the error on
function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
-- This is true if the entity in question is potentially referenceable
-- from another unit. This is true for entities in packages that are
- -- at the library level, or for entities in tasks or protected objects
- -- that are themselves publicly visible.
+ -- at the library level.
+
+ ----------------------
+ -- Missing_Subunits --
+ ----------------------
+
+ function Missing_Subunits return Boolean is
+ D : Node_Id;
+
+ begin
+ if not Unloaded_Subunits then
+
+ -- Normal compilation, all subunits are present
+
+ return False;
+
+ elsif E /= Main_Unit_Entity then
+
+ -- No warnings on a stub that is not the main unit
+
+ return True;
+
+ elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then
+ D := First (Declarations (Unit_Declaration_Node (E)));
+
+ while Present (D) loop
+
+ -- No warnings if the proper body contains nested stubs
+
+ if Nkind (D) in N_Body_Stub then
+ return True;
+ end if;
+
+ Next (D);
+ end loop;
+
+ return False;
+
+ else
+ -- Missing stubs elsewhere
+
+ return True;
+ end if;
+ end Missing_Subunits;
----------------------------
-- Output_Reference_Error --
----------------------------
function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
- S : Entity_Id;
+ P : Node_Id;
+ Prev : Node_Id;
begin
- -- Any entity in a generic package is considered to be publicly
- -- referenceable, since it could be referenced in an instantiation
+ -- Examine parents to look for a library level package spec
+ -- But if we find a body or block or other similar construct
+ -- along the way, we cannot be referenced.
- if Ekind (E) = E_Generic_Package then
- return True;
- end if;
+ Prev := Ent;
+ P := Parent (Ent);
+ loop
+ case Nkind (P) is
+
+ -- If we get to top of tree, then publicly referenceable
+
+ when N_Empty =>
+ return True;
+
+ -- If we reach a generic package declaration, then always
+ -- consider this referenceable, since any instantiation will
+ -- have access to the entities in the generic package. Note
+ -- that the package itself may not be instantiated, but then
+ -- we will get a warning for the package entity
+ -- Note that generic formal parameters are themselves not
+ -- publicly referenceable in an instance, and warnings on
+ -- them are useful.
+
+ when N_Generic_Package_Declaration =>
+ return
+ not Is_List_Member (Prev)
+ or else List_Containing (Prev)
+ /= Generic_Formal_Declarations (P);
+
+ -- if we reach a subprogram body, entity is not referenceable
+ -- unless it is the defining entity of the body. This will
+ -- happen, e.g. when a function is an attribute renaming that
+ -- is rewritten as a body.
+
+ when N_Subprogram_Body =>
+ if Ent /= Defining_Entity (P) then
+ return False;
+ else
+ P := Parent (P);
+ end if;
- -- Otherwise look up the scope stack
+ -- If we reach any other body, definitely not referenceable
- S := Scope (Ent);
- loop
- if Is_Package (S) then
- return Is_Library_Level_Entity (S);
+ when N_Package_Body |
+ N_Task_Body |
+ N_Entry_Body |
+ N_Protected_Body |
+ N_Block_Statement |
+ N_Subunit =>
+ return False;
- elsif Ekind (S) = E_Task_Type
- or else Ekind (S) = E_Protected_Type
- or else Ekind (S) = E_Entry
- then
- S := Scope (S);
+ -- For all other cases, keep looking up tree
- else
- return False;
- end if;
+ when others =>
+ Prev := P;
+ P := Parent (P);
+ end case;
end loop;
end Publicly_Referenceable;
-- any real errors so far (this last check avoids junk messages
-- resulting from errors, e.g. a subunit that is not loaded).
+ if Warning_Mode = Suppress
+ or else Serious_Errors_Detected /= 0
+ then
+ return;
+ end if;
+
-- We also skip the messages if any subunits were not loaded (see
-- comment in Sem_Ch10 to understand how this is set, and why it is
-- necessary to suppress the warnings in this case).
- if Warning_Mode = Suppress
- or else Errors_Detected /= 0
- or else Unloaded_Subunits
- then
+ if Missing_Subunits then
return;
end if;
E1 := First_Entity (E);
while Present (E1) loop
- -- We only look at source entities with warning flag off
+ -- We only look at source entities with warning flag on
if Comes_From_Source (E1) and then not Warnings_Off (E1) then
-- Post warning if this object not assigned. Note that we
-- do not consider the implicit initialization of an access
-- type to be the assignment of a value for this purpose.
+
+ if Ekind (E1) = E_Out_Parameter
+ and then Present (Spec_Entity (E1))
+ then
+ UR := Unset_Reference (Spec_Entity (E1));
+ else
+ UR := Unset_Reference (E1);
+ end if;
+
-- If the entity is an out parameter of the current subprogram
-- body, check the warning status of the parameter in the spec.
then
null;
- elsif Not_Source_Assigned (E1) then
- Output_Reference_Error ("& is never assigned a value?");
+ elsif Present (UR)
+ and then Is_Access_Type (Etype (E1))
+ then
- -- Deal with special case where this variable is hidden
- -- by a loop variable
+ -- For access types, the only time we made a UR
+ -- entry was for a dereference, and so we post
+ -- the appropriate warning here (note that the
+ -- dereference may not be explicit in the source,
+ -- for example in the case of a dispatching call
+ -- with an anonymous access controlling formal, or
+ -- of an assignment of a pointer involving a
+ -- discriminant check on the designated object).
- if Ekind (E1) = E_Variable
- and then Present (Hiding_Loop_Variable (E1))
- then
- Error_Msg_Sloc := Sloc (E1);
- Error_Msg_N
- ("declaration hides &#?",
- Hiding_Loop_Variable (E1));
- Error_Msg_N
- ("for loop implicitly declares loop variable?",
- Hiding_Loop_Variable (E1));
- end if;
+ Error_Msg_NE ("& may be null?", UR, E1);
+ goto Continue;
+
+ elsif Never_Set_In_Source (E1)
+ and then not Generic_Package_Spec_Entity (E1)
+ then
+ if Warn_On_No_Value_Assigned then
+
+ -- Do not output complaint about never being assigned a
+ -- value if a pragma Unreferenced applies to the variable
+ -- or if it is a parameter, to the corresponding spec.
+
+ if Has_Pragma_Unreferenced (E1)
+ or else (Is_Formal (E1)
+ and then Present (Spec_Entity (E1))
+ and then
+ Has_Pragma_Unreferenced (Spec_Entity (E1)))
+ then
+ null;
+
+ -- Pragma Unreferenced not set, so output message
+
+ else
+ Output_Reference_Error
+ ("& is never assigned a value?");
+
+ -- Deal with special case where this variable is
+ -- hidden by a loop variable
+ if Ekind (E1) = E_Variable
+ and then Present (Hiding_Loop_Variable (E1))
+ then
+ Error_Msg_Sloc := Sloc (E1);
+ Error_Msg_N
+ ("declaration hides &#?",
+ Hiding_Loop_Variable (E1));
+ Error_Msg_N
+ ("for loop implicitly declares loop variable?",
+ Hiding_Loop_Variable (E1));
+ end if;
+ end if;
+ end if;
goto Continue;
+
+ -- Case of variable that could be a constant. Note that we
+ -- never signal such messages for generic package entities,
+ -- since a given instance could have modifications outside
+ -- the package.
+
+ elsif Warn_On_Constant
+ and then Ekind (E1) = E_Variable
+ and then Is_True_Constant (E1)
+ and then not Generic_Package_Spec_Entity (E1)
+ then
+ Error_Msg_N
+ ("& is not modified, could be declared constant?", E1);
end if;
-- Check for unset reference, note that we exclude access
-- types from this check, since access types do always have
-- a null value, and that seems legitimate in this case.
- UR := Unset_Reference (E1);
- if Present (UR) then
-
- -- For access types, the only time we complain is when
- -- we have a dereference (of a null value)
-
- if Is_Access_Type (Etype (E1)) then
- PU := Parent (UR);
-
- if (Nkind (PU) = N_Selected_Component
- or else
- Nkind (PU) = N_Explicit_Dereference
- or else
- Nkind (PU) = N_Indexed_Component)
- and then
- Prefix (PU) = UR
- then
- Error_Msg_N ("& may be null?", UR);
- goto Continue;
- end if;
+ if Warn_On_No_Value_Assigned and then Present (UR) then
-- For other than access type, go back to original node
-- to deal with case where original unset reference
-- has been rewritten during expansion.
- else
- UR := Original_Node (UR);
+ UR := Original_Node (UR);
- -- In some cases, the original node may be a type
- -- conversion or qualification, and in this case
- -- we want the object entity inside.
+ -- In some cases, the original node may be a type
+ -- conversion or qualification, and in this case
+ -- we want the object entity inside.
- while Nkind (UR) = N_Type_Conversion
- or else Nkind (UR) = N_Qualified_Expression
- loop
- UR := Expression (UR);
- end loop;
+ while Nkind (UR) = N_Type_Conversion
+ or else Nkind (UR) = N_Qualified_Expression
+ loop
+ UR := Expression (UR);
+ end loop;
+
+ -- Here we issue the warning, all checks completed
+ -- If the unset reference is prefix of a selected
+ -- component that comes from source, mention the
+ -- component as well. If the selected component comes
+ -- from expansion, all we know is that the entity is
+ -- not fully initialized at the point of the reference.
+ -- Locate an unintialized component to get a better
+ -- error message.
+
+ if Nkind (Parent (UR)) = N_Selected_Component then
+ Error_Msg_Node_2 := Selector_Name (Parent (UR));
+
+ if not Comes_From_Source (Parent (UR)) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Etype (E1));
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Nkind (Parent (Comp)) =
+ N_Component_Declaration
+ and then No (Expression (Parent (Comp)))
+ then
+ Error_Msg_Node_2 := Comp;
+ exit;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
Error_Msg_N
- ("& may be referenced before it has a value?", UR);
- goto Continue;
+ ("`&.&` may be referenced before it has a value?",
+ UR);
+ else
+ Error_Msg_N
+ ("& may be referenced before it has a value?",
+ UR);
end if;
+
+ goto Continue;
end if;
end if;
- -- Then check for unreferenced variables
+ -- Then check for unreferenced entities. Note that we are only
+ -- interested in entities which do not have the Referenced flag
+ -- set. The Referenced_As_LHS flag is interesting only if the
+ -- Referenced flag is not set.
- if Check_Unreferenced
+ if not Referenced (E1)
- -- Check entity is flagged as not referenced and that
- -- warnings are not suppressed for this entity
+ -- Check that warnings on unreferenced entities are enabled
- and then not Referenced (E1)
- and then not Warnings_Off (E1)
+ and then ((Check_Unreferenced and then not Is_Formal (E1))
+ or else
+ (Check_Unreferenced_Formals and then Is_Formal (E1))
+ or else
+ (Warn_On_Modified_Unread
+ and then Referenced_As_LHS (E1)))
- -- Warnings are placed on objects, types, subprograms,
- -- labels, and enumeration literals.
+ -- Labels, and enumeration literals, and exceptions. The
+ -- warnings are also placed on local packages that cannot
+ -- be referenced from elsewhere, including those declared
+ -- within a package body.
and then (Is_Object (E1)
or else
or else
Ekind (E1) = E_Label
or else
+ Ekind (E1) = E_Exception
+ or else
Ekind (E1) = E_Named_Integer
or else
Ekind (E1) = E_Named_Real
or else
- Is_Overloadable (E1))
-
- -- We only place warnings for the main unit
-
- and then In_Extended_Main_Source_Unit (E1)
+ Is_Overloadable (E1)
+ or else
+ (Ekind (E1) = E_Package
+ and then
+ (Ekind (E) = E_Function
+ or else Ekind (E) = E_Package_Body
+ or else Ekind (E) = E_Procedure
+ or else Ekind (E) = E_Subprogram_Body
+ or else Ekind (E) = E_Block)))
-- Exclude instantiations, since there is no reason why
-- every entity in an instantiation should be referenced.
and then Instantiation_Location (Sloc (E1)) = No_Location
- -- Exclude formal parameters from bodies (in the case
- -- where there is a separate spec, it is the spec formals
- -- that are of interest).
+ -- Exclude formal parameters from bodies if the corresponding
+ -- spec entity has been referenced in the case where there is
+ -- a separate spec.
- and then (not Is_Formal (E1)
- or else
- Ekind (Scope (E1)) /= E_Subprogram_Body)
+ and then not (Is_Formal (E1)
+ and then
+ Ekind (Scope (E1)) = E_Subprogram_Body
+ and then
+ Present (Spec_Entity (E1))
+ and then
+ Referenced (Spec_Entity (E1)))
- -- Consider private type referenced if full view is
- -- referenced.
+ -- Consider private type referenced if full view is referenced
+ -- If there is not full view, this is a generic type on which
+ -- warnings are also useful.
- and then not (Is_Private_Type (E1)
- and then
- Referenced (Full_View (E1)))
+ and then
+ not (Is_Private_Type (E1)
+ and then
+ Present (Full_View (E1))
+ and then Referenced (Full_View (E1)))
-- Don't worry about full view, only about private type
and then Ekind (E1) /= E_Constant
and then Ekind (E1) /= E_Component)
or else not Is_Task_Type (Etype (E1)))
+
+ -- For subunits, only place warnings on the main unit
+ -- itself, since parent units are not completely compiled
+
+ and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
+ or else
+ Get_Source_Unit (E1) = Main_Unit)
then
-- Suppress warnings in internal units if not in -gnatg
-- mode (these would be junk warnings for an applications
(Unreferenced_Entities.Last) := E1;
end if;
end if;
+
+ -- Generic units are referenced in the generic body,
+ -- but if they are not public and never instantiated
+ -- we want to force a warning on them. We treat them
+ -- as redundant constructs to minimize noise.
+
+ elsif Is_Generic_Subprogram (E1)
+ and then not Is_Instantiated (E1)
+ and then not Publicly_Referenceable (E1)
+ and then Instantiation_Depth (Sloc (E1)) = 0
+ and then Warn_On_Redundant_Constructs
+ then
+ Unreferenced_Entities.Increment_Last;
+ Unreferenced_Entities.Table (Unreferenced_Entities.Last) := E1;
+
+ -- Force warning on entity
+
+ Set_Referenced (E1, False);
end if;
end if;
- -- Recurse into nested package or block
+ -- Recurse into nested package or block. Do not recurse into a
+ -- formal package, because the correponding body is not analyzed.
<<Continue>>
- if (Ekind (E1) = E_Package
- and then Nkind (Parent (E1)) = N_Package_Specification)
+ if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package)
+ and then Nkind (Parent (E1)) = N_Package_Specification
+ and then
+ Nkind (Original_Node (Unit_Declaration_Node (E1)))
+ /= N_Formal_Package_Declaration)
+
or else Ekind (E1) = E_Block
then
Check_References (E1);
return;
end if;
+ -- Ignore reference to non-scalar if not from source. Almost always
+ -- such references are bogus (e.g. calls to init procs to set
+ -- default discriminant values).
+
+ if not Comes_From_Source (N)
+ and then not Is_Scalar_Type (Etype (N))
+ then
+ return;
+ end if;
+
-- Otherwise see what kind of node we have. If the entity already
-- has an unset reference, it is not necessarily the earliest in
-- the text, because resolution of the prefix of selected components
-- unset reference, we check whether N is earlier before proceeding.
case Nkind (N) is
-
when N_Identifier | N_Expanded_Name =>
declare
- E : constant Entity_Id := Entity (N);
+ E : constant Entity_Id := Entity (N);
begin
if (Ekind (E) = E_Variable
or else Ekind (E) = E_Out_Parameter)
- and then Not_Source_Assigned (E)
+ and then Never_Set_In_Source (E)
and then (No (Unset_Reference (E))
or else Earlier_In_Extended_Unit
(Sloc (N), Sloc (Unset_Reference (E))))
and then not Warnings_Off (E)
then
+ -- We may have an unset reference. The first test is
+ -- whether we are accessing a discriminant of a record
+ -- or a component with default initialization. Both of
+ -- these cases can be ignored, since the actual object
+ -- that is referenced is definitely initialized. Note
+ -- that this covers the case of reading discriminants
+ -- of an out parameter, which is OK even in Ada 83.
+
+ -- Note that we are only interested in a direct reference
+ -- to a record component here. If the reference is via an
+ -- access type, then the access object is being referenced,
+ -- not the record, and still deserves an unset reference.
+
+ if Nkind (Parent (N)) = N_Selected_Component
+ and not Is_Access_Type (Etype (N))
+ then
+ declare
+ ES : constant Entity_Id :=
+ Entity (Selector_Name (Parent (N)));
+
+ begin
+ if Ekind (ES) = E_Discriminant
+ or else Present (Expression (Declaration_Node (ES)))
+ then
+ return;
+ end if;
+ end;
+ end if;
+
-- Here we have a potential unset reference. But before we
-- get worried about it, we have to make sure that the
-- entity declaration is in the same procedure as the
-- As always, it is possible to construct cases where the
-- warning is wrong, that is why it is a warning!
- -- If the entity is an out_parameter, it is ok to read its
- -- its discriminants (that was true in Ada83) so suppress
- -- the message in that case as well.
-
- if Ekind (E) = E_Out_Parameter
- and then Nkind (Parent (N)) = N_Selected_Component
- and then Ekind (Entity (Selector_Name (Parent (N))))
- = E_Discriminant
- then
- return;
- end if;
-
declare
SR : Entity_Id;
SE : constant Entity_Id := Scope (E);
SR := Scope (SR);
end loop;
+ -- Case of reference has an access type. This is a
+ -- special case since access types are always set to
+ -- null so cannot be truly uninitialized, but we still
+ -- want to warn about cases of obvious null dereference.
+
+ if Is_Access_Type (Etype (N)) then
+ declare
+ P : Node_Id;
+
+ function Process
+ (N : Node_Id)
+ return Traverse_Result;
+ -- Process function for instantation of Traverse
+ -- below. Checks if N contains reference to E
+ -- other than a dereference.
+
+ function Ref_In (Nod : Node_Id) return Boolean;
+ -- Determines whether Nod contains a reference
+ -- to the entity E that is not a dereference.
+
+ function Process
+ (N : Node_Id)
+ return Traverse_Result
+ is
+ begin
+ if Is_Entity_Name (N)
+ and then Entity (N) = E
+ and then not Is_Dereferenced (N)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Process;
+
+ function Ref_In (Nod : Node_Id) return Boolean is
+ function Traverse is new Traverse_Func (Process);
+
+ begin
+ return Traverse (Nod) = Abandon;
+ end Ref_In;
+
+ begin
+ -- Don't bother if we are inside an instance,
+ -- since the compilation of the generic template
+ -- is where the warning should be issued.
+
+ if In_Instance then
+ return;
+ end if;
+
+ -- Don't bother if this is not the main unit.
+ -- If we try to give this warning for with'ed
+ -- units, we get some false positives, since
+ -- we do not record references in other units.
+
+ if not In_Extended_Main_Source_Unit (E)
+ or else
+ not In_Extended_Main_Source_Unit (N)
+ then
+ return;
+ end if;
+
+ -- We are only interested in deferences
+
+ if not Is_Dereferenced (N) then
+ return;
+ end if;
+
+ -- One more check, don't bother with references
+ -- that are inside conditional statements or while
+ -- loops if the condition references the entity in
+ -- question. This avoids most false positives.
+
+ P := Parent (N);
+ loop
+ P := Parent (P);
+ exit when No (P);
+
+ if (Nkind (P) = N_If_Statement
+ or else
+ Nkind (P) = N_Elsif_Part)
+ and then Ref_In (Condition (P))
+ then
+ return;
+
+ elsif Nkind (P) = N_Loop_Statement
+ and then Present (Iteration_Scheme (P))
+ and then
+ Ref_In (Condition (Iteration_Scheme (P)))
+ then
+ return;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Here we definitely have a case for giving a warning
+ -- for a reference to an unset value. But we don't give
+ -- the warning now. Instead we set the Unset_Reference
+ -- field of the identifier involved. The reason for this
+ -- is that if we find the variable is never ever assigned
+ -- a value then that warning is more important and there
+ -- is no point in giving the reference warning.
+
+ -- If this is an identifier, set the field directly
+
if Nkind (N) = N_Identifier then
Set_Unset_Reference (E, N);
+
+ -- Otherwise it is an expanded name, so set the field
+ -- of the actual identifier for the reference.
+
else
Set_Unset_Reference (E, Selector_Name (N));
end if;
end if;
end;
- when N_Indexed_Component | N_Selected_Component | N_Slice =>
+ when N_Indexed_Component | N_Slice =>
Check_Unset_Reference (Prefix (N));
- return;
+
+ when N_Selected_Component =>
+
+ if Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ then
+ -- A discriminant is always initialized
+
+ null;
+
+ else
+ Check_Unset_Reference (Prefix (N));
+ end if;
when N_Type_Conversion | N_Qualified_Expression =>
Check_Unset_Reference (Expression (N));
Is_Visible_Renaming : Boolean := False;
Pack : Entity_Id;
+ procedure Check_Inner_Package (Pack : Entity_Id);
+ -- Pack is a package local to a unit in a with_clause. Both the
+ -- unit and Pack are referenced. If none of the entities in Pack
+ -- are referenced, then the only occurrence of Pack is in a use
+ -- clause or a pragma, and a warning is worthwhile as well.
+
+ function Check_System_Aux return Boolean;
+ -- Before giving a warning on a with_clause for System, check
+ -- whether a system extension is present.
+
function Find_Package_Renaming
(P : Entity_Id;
L : Entity_Id) return Entity_Id;
-- not warn that the context clause could be moved to the body,
-- because the renaming may be intented to re-export the unit.
+ -------------------------
+ -- Check_Inner_Package --
+ -------------------------
+
+ procedure Check_Inner_Package (Pack : Entity_Id) is
+ E : Entity_Id;
+ Un : constant Node_Id := Sinfo.Unit (Cnode);
+
+ function Check_Use_Clause (N : Node_Id) return Traverse_Result;
+ -- If N is a use_clause for Pack, emit warning
+
+ procedure Check_Use_Clauses is new
+ Traverse_Proc (Check_Use_Clause);
+
+ ----------------------
+ -- Check_Use_Clause --
+ ----------------------
+
+ function Check_Use_Clause (N : Node_Id) return Traverse_Result is
+ Nam : Node_Id;
+
+ begin
+ if Nkind (N) = N_Use_Package_Clause then
+ Nam := First (Names (N));
+
+ while Present (Nam) loop
+ if Entity (Nam) = Pack then
+ Error_Msg_Qual_Level := 1;
+ Error_Msg_NE
+ ("no entities of package& are referenced?",
+ Nam, Pack);
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ Next (Nam);
+ end loop;
+ end if;
+
+ return OK;
+ end Check_Use_Clause;
+
+ -- Start of processing for Check_Inner_Package
+
+ begin
+ E := First_Entity (Pack);
+
+ while Present (E) loop
+ if Referenced (E) then
+ return;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- No entities of the package are referenced. Check whether
+ -- the reference to the package itself is a use clause, and
+ -- if so place a warning on it.
+
+ Check_Use_Clauses (Un);
+ end Check_Inner_Package;
+
+ ----------------------
+ -- Check_System_Aux --
+ ----------------------
+
+ function Check_System_Aux return Boolean is
+ Ent : Entity_Id;
+
+ begin
+ if Chars (Lunit) = Name_System
+ and then Scope (Lunit) = Standard_Standard
+ and then Present_System_Aux
+ then
+ Ent := First_Entity (System_Aux_Id);
+
+ while Present (Ent) loop
+ if Referenced (Ent) then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end if;
+
+ return False;
+ end Check_System_Aux;
+
---------------------------
-- Find_Package_Renaming --
---------------------------
if not In_Extended_Main_Source_Unit (Cnode) then
return;
+
+ -- In configurable run time mode, we remove the bodies of
+ -- non-inlined subprograms, which may lead to spurious warnings,
+ -- which are clearly undesirable.
+
+ elsif Configurable_Run_Time_Mode
+ and then Is_Predefined_File_Name (Unit_File_Name (Unit))
+ then
+ return;
end if;
-- Loop through context items in this unit
Item := First (Context_Items (Cnode));
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then In_Extended_Main_Source_Unit (Item)
-- Otherwise see if any entities have been referenced
else
- Ent := First_Entity (Lunit);
-
+ Ent := First_Entity (Lunit);
loop
-- No more entities, and we did not find one
-- that was referenced. Means we have a definite
if Unit = Spec_Unit then
Set_No_Entities_Ref_In_Spec (Item);
+ elsif Check_System_Aux then
+ null;
+
-- Else give the warning
else
-- Case of next entity is referenced
- elsif Referenced (Ent) then
-
+ elsif Referenced (Ent)
+ or else Referenced_As_LHS (Ent)
+ then
-- This means that the with is indeed fine, in
-- that it is definitely needed somewhere, and
-- we can quite worrying about this one.
Name (Item));
else
+ if Ekind (Ent) = E_Package then
+ Check_Inner_Package (Ent);
+ end if;
+
exit;
end if;
end if;
end Check_Unused_Withs;
+ ---------------------------------
+ -- Generic_Package_Spec_Entity --
+ ---------------------------------
+
+ function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ if Is_Package_Body_Entity (E) then
+ return False;
+
+ else
+ S := Scope (E);
+
+ loop
+ if S = Standard_Standard then
+ return False;
+
+ elsif Ekind (S) = E_Generic_Package then
+ return True;
+
+ elsif Ekind (S) = E_Package then
+ S := Scope (S);
+
+ else
+ return False;
+ end if;
+ end loop;
+ end if;
+ end Generic_Package_Spec_Entity;
+
+ -------------------------------------
+ -- Operand_Has_Warnings_Suppressed --
+ -------------------------------------
+
+ function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is
+
+ function Check_For_Warnings (N : Node_Id) return Traverse_Result;
+ -- Function used to check one node to see if it is or was originally
+ -- a reference to an entity for which Warnings are off. If so, Abandon
+ -- is returned, otherwise OK_Orig is returned to continue the traversal
+ -- of the original expression.
+
+ function Traverse is new Traverse_Func (Check_For_Warnings);
+ -- Function used to traverse tree looking for warnings
+
+ ------------------------
+ -- Check_For_Warnings --
+ ------------------------
+
+ function Check_For_Warnings (N : Node_Id) return Traverse_Result is
+ R : constant Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (R) in N_Has_Entity
+ and then Present (Entity (R))
+ and then Warnings_Off (Entity (R))
+ then
+ return Abandon;
+ else
+ return OK_Orig;
+ end if;
+ end Check_For_Warnings;
+
+ -- Start of processing for Operand_Has_Warnings_Suppressed
+
+ begin
+ return Traverse (N) = Abandon;
+
+ -- If any exception occurs, then something has gone wrong, and this is
+ -- only a minor aesthetic issue anyway, so just say we did not find what
+ -- we are looking for, rather than blow up.
+
+ exception
+ when others =>
+ return False;
+ end Operand_Has_Warnings_Suppressed;
+
----------------------------------
-- Output_Unreferenced_Messages --
----------------------------------
E := Unreferenced_Entities.Table (J);
if not Referenced (E) and then not Warnings_Off (E) then
-
case Ekind (E) is
when E_Variable =>
- if Present (Renamed_Object (E))
- and then Comes_From_Source (Renamed_Object (E))
+
+ -- Case of variable that is assigned but not read. We
+ -- suppress the message if the variable is volatile,
+ -- has an address clause, or is imported.
+
+ if Referenced_As_LHS (E)
+ and then No (Address_Clause (E))
+ and then not Is_Volatile (E)
then
- Error_Msg_N ("renamed variable & is not referenced?", E);
+ 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.
+
+ and then not Is_Aliased (E)
+ and then No (Renamed_Object (E))
+
+ then
+ Error_Msg_N
+ ("variable & is assigned but never read?", E);
+ end if;
+
+ -- Normal case of neither assigned nor read
+
else
- Error_Msg_N ("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;
when E_Constant =>
when E_Procedure =>
Error_Msg_N ("procedure & is not referenced?", E);
+ when E_Generic_Procedure =>
+ Error_Msg_N
+ ("generic procedure & is never instantiated?", E);
+
+ when E_Generic_Function =>
+ Error_Msg_N ("generic function & is never instantiated?", E);
+
when Type_Kind =>
Error_Msg_N ("type & is not referenced?", E);
P : Node_Id;
begin
+ -- Argument replacement in an inlined body can make conditions
+ -- static. Do not emit warnings in this case.
+
+ if In_Inlined_Body then
+ return;
+ end if;
+
if Constant_Condition_Warnings
and then Nkind (C) = N_Identifier
and then
P := Parent (P);
end loop;
- if Entity (C) = Standard_True then
- Error_Msg_N ("condition is always True?", C);
- else
- Error_Msg_N ("condition is always False?", C);
+ -- Here we issue the warning unless some sub-operand has warnings
+ -- set off, in which case we suppress the warning for the node. If
+ -- the original expression is an inequality, it has been expanded
+ -- into a negation, and the value of the original expression is the
+ -- negation of the equality. If the expression is an entity that
+ -- appears within a negation, it is clearer to flag the negation
+ -- itself, and report on its constant value.
+
+ if not Operand_Has_Warnings_Suppressed (C) then
+ declare
+ True_Branch : Boolean := Entity (C) = Standard_True;
+ Cond : Node_Id := C;
+
+ begin
+ if Present (Parent (C))
+ and then Nkind (Parent (C)) = N_Op_Not
+ then
+ True_Branch := not True_Branch;
+ Cond := Parent (C);
+ end if;
+
+ if True_Branch then
+ Error_Msg_N ("condition is always True?", Cond);
+ else
+ Error_Msg_N ("condition is always False?", Cond);
+ end if;
+ end;
end if;
end if;
end Warn_On_Known_Condition;