-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- from another unit. This is true for entities in packages that are
-- at the library level.
- -----------------------
- -- Missing_Subunits --
- -----------------------
+ ----------------------
+ -- Missing_Subunits --
+ ----------------------
function Missing_Subunits return Boolean is
D : Node_Id;
or else List_Containing (Prev)
/= Generic_Formal_Declarations (P);
- -- if we reach a subprogram body, entity is not referenceable
+ -- Similarly, the generic formals of a generic subprogram
+ -- are not accessible.
+
+ when N_Generic_Subprogram_Declaration =>
+ if Is_List_Member (Prev)
+ and then List_Containing (Prev) =
+ Generic_Formal_Declarations (P)
+ then
+ return False;
+ else
+ P := Parent (P);
+ end if;
+
+ -- 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.
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
-- 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 Present (UR)
+ and then Is_Access_Type (Etype (E1))
+ then
+
+ -- 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).
+
+ 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
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);
+ -- A special case, if this variable is volatile and not
+ -- imported, it is not helpful to tell the programmer
+ -- to mark the variable as constant, since this would be
+ -- illegal by virtue of RM C.6(13).
+
+ if (Is_Volatile (E1) or else Has_Volatile_Components (E1))
+ and then not Is_Imported (E1)
+ then
+ Error_Msg_N
+ ("& is not modified, volatile has no effect?", E1);
+ else
+ Error_Msg_N
+ ("& is not modified, could be declared constant?", E1);
+ end if;
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.
- 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 Warn_On_No_Value_Assigned and then Present (UR) then
- -- For access types, the only time we made a UR entry
- -- was for a dereference, and so we post the appropriate
- -- warning here. The issue is not that the value is not
- -- initialized here, but that it is null.
-
- if Is_Access_Type (Etype (E1)) then
- Error_Msg_NE ("& may be null?", UR, E1);
- goto Continue;
-
-- 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.
+ -- 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 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;
+ 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;
+ 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;
- Error_Msg_N
- ("`&.&` may be referenced before it has a value?",
- UR);
- else
- Error_Msg_N
- ("& may be referenced before it has a value?",
- UR);
+ Next_Entity (Comp);
+ end loop;
+ end;
end if;
- goto Continue;
+ Error_Msg_N
+ ("`&.&` 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;
(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
Unreferenced_Entities.Increment_Last;
Unreferenced_Entities.Table (Unreferenced_Entities.Last) := E1;
- -- Force warning on entity.
+ -- Force warning on entity
Set_Referenced (E1, False);
end if;
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.
+ -- If N is a use_clause for Pack, emit warning
procedure Check_Use_Clauses is new
Traverse_Proc (Check_Use_Clause);
then
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 loop;
end Output_Unreferenced_Messages;
+ ------------------------
+ -- Set_Warning_Switch --
+ ------------------------
+
+ function Set_Warning_Switch (C : Character) return Boolean is
+ 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;
+
+ 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;
+
+ when 'b' =>
+ Warn_On_Bad_Fixed_Value := True;
+
+ when 'B' =>
+ Warn_On_Bad_Fixed_Value := False;
+
+ when 'c' =>
+ Constant_Condition_Warnings := True;
+
+ when 'C' =>
+ Constant_Condition_Warnings := False;
+
+ when 'd' =>
+ Warn_On_Dereference := True;
+
+ when 'D' =>
+ Warn_On_Dereference := False;
+
+ when 'e' =>
+ Warning_Mode := Treat_As_Error;
+
+ when 'f' =>
+ Check_Unreferenced_Formals := True;
+
+ when 'F' =>
+ Check_Unreferenced_Formals := False;
+
+ when 'g' =>
+ Warn_On_Unrecognized_Pragma := True;
+
+ when 'G' =>
+ Warn_On_Unrecognized_Pragma := False;
+
+ when 'h' =>
+ Warn_On_Hiding := True;
+
+ when 'H' =>
+ Warn_On_Hiding := False;
+
+ when 'i' =>
+ Implementation_Unit_Warnings := True;
+
+ when 'I' =>
+ Implementation_Unit_Warnings := False;
+
+ when 'j' =>
+ Warn_On_Obsolescent_Feature := True;
+
+ when 'J' =>
+ Warn_On_Obsolescent_Feature := False;
+
+ when 'k' =>
+ Warn_On_Constant := True;
+
+ when 'K' =>
+ Warn_On_Constant := False;
+
+ when 'l' =>
+ Elab_Warnings := True;
+
+ when 'L' =>
+ Elab_Warnings := False;
+
+ when 'm' =>
+ Warn_On_Modified_Unread := True;
+
+ when 'M' =>
+ Warn_On_Modified_Unread := False;
+
+ when 'n' =>
+ Warning_Mode := Normal;
+
+ when 'o' =>
+ Address_Clause_Overlay_Warnings := True;
+
+ when 'O' =>
+ Address_Clause_Overlay_Warnings := False;
+
+ when 'p' =>
+ Ineffective_Inline_Warnings := True;
+
+ when 'P' =>
+ Ineffective_Inline_Warnings := False;
+
+ when 'r' =>
+ Warn_On_Redundant_Constructs := True;
+
+ when 'R' =>
+ Warn_On_Redundant_Constructs := False;
+
+ when 's' =>
+ Warning_Mode := Suppress;
+
+ when 'u' =>
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Check_Unreferenced_Formals := True;
+
+ when 'U' =>
+ Check_Unreferenced := False;
+ Check_Withs := False;
+ Check_Unreferenced_Formals := False;
+
+ when 'v' =>
+ Warn_On_No_Value_Assigned := True;
+
+ when 'V' =>
+ Warn_On_No_Value_Assigned := False;
+
+ when 'x' =>
+ Warn_On_Export_Import := True;
+
+ when 'X' =>
+ Warn_On_Export_Import := False;
+
+ when 'y' =>
+ Warn_On_Ada_2005_Compatibility := True;
+
+ when 'Y' =>
+ Warn_On_Ada_2005_Compatibility := False;
+
+ when 'z' =>
+ 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;
+
+ when others =>
+ return False;
+ end case;
+
+ return True;
+ end Set_Warning_Switch;
+
-----------------------------
-- Warn_On_Known_Condition --
-----------------------------
end loop;
-- Here we issue the warning unless some sub-operand has warnings
- -- set off, in which case we suppress the warning for the node.
+ -- 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
- if Entity (C) = Standard_True then
- Error_Msg_N ("condition is always True?", C);
- else
- Error_Msg_N ("condition is always False?", C);
- end if;
+ 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
+ if Is_Entity_Name (Original_Node (C))
+ and then Nkind (Cond) /= N_Op_Not
+ then
+ Error_Msg_NE
+ ("object & is always True?", Cond, Original_Node (C));
+ else
+ Error_Msg_N ("condition is always True?", Cond);
+ end if;
+ else
+ Error_Msg_N ("condition is always False?", Cond);
+ end if;
+ end;
end if;
end if;
end Warn_On_Known_Condition;
OSDN Git Service
