From 8063f7509272340d9072b41566d0497da95d7bc2 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 09:00:48 +0000 Subject: [PATCH] (Check_References.Publicly_Referenceable): A formal parameter is never publicly referenceable outside of its body. (Check_References): For an unreferenced formal parameter in an accecpt statement, use the same warning circuitry as for subprogram formal parameters. (Warn_On_Unreferenced_Entity): New subprogram, taken from Output_Unreferenced_Messages, containing the part of that routine that is now reused for entry formals as described above. (Has_Pragma_Unreferenced_Check_Spec): New function (Check_References): Clean up handling of unmodified IN OUT parameters git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127471 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sem_warn.adb | 1196 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 893 insertions(+), 303 deletions(-) diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index b2141d7..087d8e8 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -35,6 +35,7 @@ with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; @@ -51,6 +52,7 @@ package body Sem_Warn is -- The following table collects Id's of entities that are potentially -- unreferenced. See Check_Unset_Reference for further details. + -- ??? Check_Unset_Reference has zero information about this table. package Unreferenced_Entities is new Table.Table ( Table_Component_Type => Entity_Id, @@ -60,6 +62,14 @@ package body Sem_Warn is Table_Increment => Alloc.Unreferenced_Entities_Increment, Table_Name => "Unreferenced_Entities"); + package In_Out_Warnings is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.In_Out_Warnings_Initial, + Table_Increment => Alloc.In_Out_Warnings_Increment, + Table_Name => "In_Out_Warnings"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -68,8 +78,24 @@ package body Sem_Warn is -- 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. + -- instance. These are cases where we leave the warnings to be posted for + -- the instance, when we will know more. + + function Goto_Spec_Entity (E : Entity_Id) return Entity_Id; + -- If E is a parameter entity for a subprogram body, then this function + -- returns the corresponding spec entity, if not, E is returned unchanged. + + function Has_Pragma_Unreferenced_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Has_Pragma_Unreferenced flag for entity E. If E is not a formal, + -- this is simply the setting of the flag Has_Pragma_Unreferenced. If E is + -- a body formal, the setting of the flag in the corresponding spec is + -- also checked (and True returned if either flag is True). + + function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Never_Set_In_Source status for entity E. If E is not a formal, + -- this is simply the setting of the flag Never_Set_In_Source. If E is + -- a body formal, the setting of the flag in the corresponding spec is + -- also checked (and False returned if either flag is False). function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean; -- This function traverses the expression tree represented by the node N @@ -77,6 +103,26 @@ package body Sem_Warn is -- the Warnings_Off flag is set. True is returned if such an entity is -- encountered, and False otherwise. + function Referenced_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Referenced status for entity E. If E is not a formal, this is + -- simply the setting of the flag Referenced. If E is a body formal, the + -- setting of the flag in the corresponding spec is also checked (and True + -- returned if either flag is True). + + function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean; + -- Tests Referenced_As_LHS status for entity E. If E is not a formal, this + -- is simply the setting of the flag Referenced_As_LHS. If E is a body + -- formal, the setting of the flag in the corresponding spec is also + -- checked (and True returned if either flag is True). + + procedure Warn_On_Unreferenced_Entity + (Spec_E : Entity_Id; + Body_E : Entity_Id := Empty); + -- Output warnings for unreferenced entity E. For the case of an entry + -- formal, Body_E is the corresponding body entity for a particular + -- accept statement, and the message is posted on Body_E. In all other + -- cases, Body_E is ignored and must be Empty. + -------------------------- -- Check_Code_Statement -- -------------------------- @@ -95,7 +141,7 @@ package body Sem_Warn is if No (Asm_Input_Value) then Error_Msg_F - ("?code statement with no inputs should usually be Volatile", N); + ("?code statement with no inputs should usually be Volatile!", N); return; end if; @@ -103,7 +149,7 @@ package body Sem_Warn is if No (Asm_Output_Variable) then Error_Msg_F - ("?code statement with no outputs should usually be Volatile", N); + ("?code statement with no outputs should usually be Volatile!", N); return; end if; @@ -114,9 +160,9 @@ package body Sem_Warn is and then Nkind (Prev (N)) = N_Code_Statement then Error_Msg_F - ("?code statements in sequence should usually be Volatile", N); + ("?code statements in sequence should usually be Volatile!", N); Error_Msg_F - ("\?(suggest using template with multiple instructions)", N); + ("\?(suggest using template with multiple instructions)!", N); end if; end Check_Code_Statement; @@ -131,17 +177,17 @@ package body Sem_Warn is procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); - Ref : Node_Id := Empty; - -- Reference in iteration scheme to variable that may not be modified - -- in loop, indicating a possible infinite loop. + Ref : Node_Id := Empty; + -- Reference in iteration scheme to variable that may not be modified in + -- loop, indicating a possible infinite loop. Var : Entity_Id := Empty; -- Corresponding entity (entity of Ref) procedure Find_Var (N : Node_Id); - -- Inspect condition to see if it depends on a single entity - -- reference. If so, Ref is set to point to the reference node, - -- and Var is set to the referenced Entity. + -- Inspect condition to see if it depends on a single entity reference. + -- If so, Ref is set to point to the reference node, and Var is set to + -- the referenced Entity. function Has_Indirection (T : Entity_Id) return Boolean; -- If the controlling variable is an access type, or is a record type @@ -408,12 +454,14 @@ package body Sem_Warn is elsif Nkind (N) = N_Procedure_Call_Statement or else Nkind (N) = N_Function_Call then - -- If subprogram is within the scope of the entity we are - -- dealing with as the loop variable, then it could modify - -- this parameter, so we abandon in this case. In the case - -- of a subprogram that is not an entity we also abandon. + -- If subprogram is within the scope of the entity we are dealing + -- with as the loop variable, then it could modify this parameter, + -- so we abandon in this case. In the case of a subprogram that is + -- not an entity we also abandon. The check for no entity being + -- present is a defense against previous errors. if not Is_Entity_Name (Name (N)) + or else No (Entity (Name (N))) or else Scope_Within (Entity (Name (N)), Scope (Var)) then return Abandon; @@ -485,9 +533,9 @@ package body Sem_Warn is if Find_Ref (Loop_Statement) = OK then Error_Msg_NE - ("variable& is not modified in loop body?", Ref, Var); + ("?variable& is not modified in loop body!", Ref, Var); Error_Msg_N - ("\possible infinite loop", Ref); + ("\?possible infinite loop!", Ref); end if; end Check_Infinite_Loop_Warning; @@ -499,6 +547,12 @@ package body Sem_Warn is E1 : Entity_Id; UR : Node_Id; + function Body_Formal + (E : Entity_Id; + Accept_Statement : Node_Id) return Entity_Id; + -- For an entry formal entity from an entry declaration, find the + -- corrsesponding body formal from the given accept statement. + 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 @@ -556,12 +610,53 @@ package body Sem_Warn is end if; end Missing_Subunits; + ----------------- + -- Body_Formal -- + ----------------- + + function Body_Formal + (E : Entity_Id; + Accept_Statement : Node_Id) return Entity_Id + is + Body_Param : Node_Id; + Body_E : Entity_Id; + + begin + -- Loop to find matching parameter in accept statement + + Body_Param := First (Parameter_Specifications (Accept_Statement)); + while Present (Body_Param) loop + Body_E := Defining_Identifier (Body_Param); + + if Chars (Body_E) = Chars (E) then + return Body_E; + end if; + + Next (Body_Param); + end loop; + + -- Should never fall through, should always find a match + + raise Program_Error; + end Body_Formal; + ---------------------------- -- Output_Reference_Error -- ---------------------------- procedure Output_Reference_Error (M : String) is begin + -- Don't output message for IN OUT formal unless we have the warning + -- flag specifically set. It is a bit odd to distinguish IN OUT + -- formals from other cases. This distinction is historical in + -- nature. Warnings for IN OUT formals were added fairly late. + + if Ekind (E1) = E_In_Out_Parameter + and then not Check_Unreferenced_Formals + then + return; + end if; + -- Other than accept case, post error on defining identifier if No (Anod) then @@ -570,30 +665,8 @@ package body Sem_Warn is -- Accept case, find body formal to post the message else - declare - Parm : Node_Id; - Enod : Node_Id; - Defid : Entity_Id; - - begin - Enod := Anod; - - if Present (Parameter_Specifications (Anod)) then - Parm := First (Parameter_Specifications (Anod)); - while Present (Parm) loop - Defid := Defining_Identifier (Parm); + Error_Msg_NE (M, Body_Formal (E1, Accept_Statement => Anod), E1); - if Chars (E1) = Chars (Defid) then - Enod := Defid; - exit; - end if; - - Next (Parm); - end loop; - end if; - - Error_Msg_NE (M, Enod, E1); - end; end if; end Output_Reference_Error; @@ -606,6 +679,13 @@ package body Sem_Warn is Prev : Node_Id; begin + -- A formal parameter is never referenceable outside the body of its + -- subprogram or entry. + + if Is_Formal (Ent) then + return False; + end if; + -- 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. @@ -627,8 +707,8 @@ package body Sem_Warn is -- 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. + -- publicly referenceable in an instance, and warnings on them + -- are useful. when N_Generic_Package_Declaration => return @@ -636,8 +716,8 @@ package body Sem_Warn is or else List_Containing (Prev) /= Generic_Formal_Declarations (P); - -- Similarly, the generic formals of a generic subprogram - -- are not accessible. + -- Similarly, the generic formals of a generic subprogram are + -- not accessible. when N_Generic_Subprogram_Declaration => if Is_List_Member (Prev) @@ -714,17 +794,19 @@ package body Sem_Warn is and then not Warnings_Off (Etype (E1)) and then not Warnings_Off (Base_Type (Etype (E1))) then - -- We are interested in variables and out parameters, but we - -- exclude protected types, too complicated to worry about. + -- We are interested in variables and out/in-out parameters, but + -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable or else - (Ekind (E1) = E_Out_Parameter + ((Ekind (E1) = E_Out_Parameter + or else Ekind (E1) = E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) 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. + -- Case of an unassigned variable + + -- First gather any Unset_Reference indication for E1. In the + -- case of a parameter, it is the Spec_Entity that is relevant. if Ekind (E1) = E_Out_Parameter and then Present (Spec_Entity (E1)) @@ -737,7 +819,7 @@ package body Sem_Warn is -- If the entity is an out parameter of the current subprogram -- body, check the warning status of the parameter in the spec. - if Ekind (E1) = E_Out_Parameter + if Is_Formal (E1) and then Present (Spec_Entity (E1)) and then Warnings_Off (Spec_Entity (E1)) then @@ -746,63 +828,15 @@ package body Sem_Warn is 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 discriminant check on - -- the designated object). + -- assignment of a pointer involving 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 - 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 Has_Pragma_Unreferenced_Objects (Etype (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 - 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 - - 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; + Error_Msg_NE ("?& may be null!", UR, E1); goto Continue; -- Case of variable that could be a constant. Note that we @@ -811,8 +845,12 @@ package body Sem_Warn is -- the package. elsif Warn_On_Constant - and then Ekind (E1) = E_Variable - and then Is_True_Constant (E1) + and then ((Ekind (E1) = E_Variable + and then Has_Initial_Value (E1)) + or else + Ekind (E1) = E_In_Out_Parameter) + and then Never_Set_In_Source_Check_Spec (E1) + and then not Address_Taken (E1) and then not Generic_Package_Spec_Entity (E1) then -- A special case, if this variable is volatile and not @@ -824,44 +862,203 @@ package body Sem_Warn is and then not Is_Imported (E1) then Error_Msg_N - ("& is not modified, volatile has no effect?", E1); + ("?& is not modified, volatile has no effect!", E1); + + -- Another special case, Exception_Occurrence, this catches + -- the case of exception choice (and a bit more too, but not + -- worth doing more investigation here). + + elsif Is_RTE (Etype (E1), RE_Exception_Occurrence) then + null; + + -- Here we give the warning if referenced and no pragma + -- Unreferenced is present. + else - Error_Msg_N - ("& is not modified, could be declared constant?", E1); + if Ekind (E1) = E_Variable then + if Referenced_Check_Spec (E1) + and then not Has_Pragma_Unreferenced_Check_Spec (E1) + then + Error_Msg_N + ("?& is not modified, " + & "could be declared constant!", + E1); + end if; + + else pragma Assert (Ekind (E1) = E_In_Out_Parameter); + if Referenced_Check_Spec (E1) + and then + not Has_Pragma_Unreferenced_Check_Spec (E1) + then + -- Suppress warning if private type, since in this + -- case it may be quite reasonable for the logical + -- view to be in out, even if the implementation + -- ends up using access types. + + if Has_Private_Declaration (Etype (E1)) then + null; + + -- Suppress warning for any composite type, since + -- for composites it seems quite reasonable to pass + -- a value of the composite type and then modify + -- just a component. + + elsif Is_Composite_Type (Etype (E1)) then + null; + + -- Suppress warning for parameter of dispatching + -- operation, since it is quite reasonable to have + -- an operation that is overridden, and for some + -- subclasses needs to be IN OUT and for others + -- the parameter does not happen to be assigned. + + elsif Is_Dispatching_Operation + (Scope (Goto_Spec_Entity (E1))) + then + null; + + -- OK, looks like warning for an IN OUT parameter + -- that could be IN makes sense, but we delay the + -- output of the warning, pending possibly finding + -- out later on that the associated subprogram is + -- used as a generic actual, or its address/access + -- is taken. In these two cases, we suppress the + -- warning because the context may force use of IN + -- OUT, even if in this particular case the formal + -- is not modifed. + + else + In_Out_Warnings.Append (E1); + end if; + end if; + end if; + end if; + + -- Other cases of a variable never set in source + + elsif Never_Set_In_Source_Check_Spec (E1) + + -- No warning if warning for this case turned off + + and then Warn_On_No_Value_Assigned + + -- No warning if address taken somewhere + + and then not Address_Taken (E1) + + -- No warning if explicit initial value + + and then not Has_Initial_Value (E1) + + -- No warning for generic package spec entities, since we + -- might set them in a child unit or something like that + + and then not Generic_Package_Spec_Entity (E1) + + -- No warning if fully initialized type, except that for + -- this purpose we do not consider access types to qualify + -- as fully initialized types (relying on an access type + -- variable being null when it is never set is a bit odd!) + + -- Also we generate warning for an out parameter that is + -- never referenced, since again it seems odd to rely on + -- default initialization to set an out parameter value. + + and then (Is_Access_Type (Etype (E1)) + or else Ekind (E1) = E_Out_Parameter + or else not Is_Fully_Initialized_Type (Etype (E1))) + then + -- Do not output complaint about never being assigned a + -- value if a pragma Unreferenced applies to the variable + -- we are examining, or if it is a parameter, if there is + -- a pragma Unreferenced for the corresponding spec. + + if Has_Pragma_Unreferenced_Check_Spec (E1) + or else Has_Pragma_Unreferenced_Objects (Etype (E1)) + then + null; + + -- Case of unreferenced formal + + elsif Is_Formal (E1) then + if Referenced_Check_Spec (E1) then + Output_Reference_Error + ("?formal parameter& is read but never assigned!"); + else + Output_Reference_Error + ("?formal parameter& is not referenced!"); + end if; + + -- Case of variable + + else + 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 + + if Ekind (E1) = E_Variable + and then Present (Hiding_Loop_Variable (E1)) + then + Error_Msg_N + ("?for loop implicitly declares loop variable!", + Hiding_Loop_Variable (E1)); + + Error_Msg_Sloc := Sloc (E1); + Error_Msg_N + ("\?declaration hides & declared#!", + Hiding_Loop_Variable (E1)); + end if; end if; + + goto Continue; 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. + -- Check for unset reference 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. + -- For other than access type, go back to original node to + -- deal with case where original unset reference has been + -- rewritten during expansion. - 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. + UR := Original_Node (UR); 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 we have a return statement, this was a case of an OUT + -- parameter not being set at the time of the return. (Note: + -- it can't be N_Extended_Return_Statement, because those + -- are only for functions, and functions do not allow OUT + -- parameters.) + + if Nkind (UR) = N_Simple_Return_Statement then + Error_Msg_NE + ("?OUT parameter& not set before return", UR, E1); + + -- 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 + elsif Nkind (Parent (UR)) = N_Selected_Component then Error_Msg_Node_2 := Selector_Name (Parent (UR)); if not Comes_From_Source (Parent (UR)) then @@ -873,7 +1070,7 @@ package body Sem_Warn is while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = - N_Component_Declaration + N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; @@ -885,12 +1082,24 @@ package body Sem_Warn is end; end if; - Error_Msg_N - ("`&.&` may be referenced before it has a value?", - UR); + -- Issue proper warning. This is a case of referencing + -- a variable before it has been explicitly assigned. + -- For access types, UR was only set for dereferences, + -- so the issue is that the value may be null. + + if Is_Access_Type (Etype (Parent (UR))) then + Error_Msg_N ("?`&.&` may be null!", UR); + else + Error_Msg_N + ("?`&.&` may be referenced before it has a value!", + UR); + end if; + + -- All other cases of unset reference active + else Error_Msg_N - ("& may be referenced before it has a value?", + ("?& may be referenced before it has a value!", UR); end if; @@ -903,7 +1112,7 @@ package body Sem_Warn is -- set. The Referenced_As_LHS flag is interesting only if the -- Referenced flag is not set. - if not Referenced (E1) + if not Referenced_Check_Spec (E1) -- Check that warnings on unreferenced entities are enabled @@ -912,7 +1121,7 @@ package body Sem_Warn is (Check_Unreferenced_Formals and then Is_Formal (E1)) or else (Warn_On_Modified_Unread - and then Referenced_As_LHS (E1))) + and then Referenced_As_LHS_Check_Spec (E1))) -- Labels, and enumeration literals, and exceptions. The -- warnings are also placed on local packages that cannot be @@ -1026,17 +1235,23 @@ package body Sem_Warn is -- We do not immediately flag the error. This is because we -- have not expanded generic bodies yet, and they may have -- the missing reference. So instead we park the entity on a - -- list, for later processing. However, for the accept case, - -- post the error right here, since we have the information - -- now in this case. + -- list, for later processing. However for the case of an + -- accept statement we want to output messages now, since + -- we know we already have all information at hand, and we + -- also want to have separate warnings for each accept + -- statement for the same entry. if Present (Anod) then - Output_Reference_Error ("& is not referenced?"); + pragma Assert (Is_Formal (E1)); + + -- The unreferenced entity is E1, but post the warning + -- on the body entity for this accept statement. + + Warn_On_Unreferenced_Entity + (E1, Body_Formal (E1, Accept_Statement => Anod)); else - Unreferenced_Entities.Increment_Last; - Unreferenced_Entities.Table - (Unreferenced_Entities.Last) := E1; + Unreferenced_Entities.Append (E1); end if; end if; @@ -1051,8 +1266,7 @@ package body Sem_Warn is 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; + Unreferenced_Entities.Append (E1); -- Force warning on entity @@ -1084,6 +1298,68 @@ package body Sem_Warn is --------------------------- procedure Check_Unset_Reference (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + + function Is_OK_Fully_Initialized return Boolean; + -- This function returns true if the given node N is fully initialized + -- so that the reference is safe as far as this routine is concerned. + -- Safe generally means that the type of N is a fully initialized type. + -- The one special case is that for access types, which are always fully + -- initialized, we don't consider a dereference OK since it will surely + -- be dereferencing a null value, which won't do. + + function Prefix_Has_Dereference (Pref : Node_Id) return Boolean; + -- Used to test indexed or selected component or slice to see if the + -- evaluation of the prefix depends on a dereference, and if so, returns + -- True, in which case we always check the prefix, even if we know that + -- the referenced component is initialized. Pref is the prefix to test. + + ----------------------------- + -- Is_OK_Fully_Initialized -- + ----------------------------- + + function Is_OK_Fully_Initialized return Boolean is + begin + if Is_Access_Type (Typ) and then Is_Dereferenced (N) then + return False; + else + return Is_Fully_Initialized_Type (Typ); + end if; + end Is_OK_Fully_Initialized; + + ---------------------------- + -- Prefix_Has_Dereference -- + ---------------------------- + + function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is + begin + -- If prefix is of an access type, certainly need a dereference + + if Is_Access_Type (Etype (Pref)) then + return True; + + -- If prefix is explicit dereference, that's a dereference for sure + + elsif Nkind (Pref) = N_Explicit_Dereference then + return True; + + -- If prefix is itself a component reference or slice check prefix + + elsif Nkind (Pref) = N_Slice + or else Nkind (Pref) = N_Indexed_Component + or else Nkind (Pref) = N_Selected_Component + then + return Prefix_Has_Dereference (Prefix (Pref)); + + -- All other cases do not involve a dereference + + else + return False; + end if; + end Prefix_Has_Dereference; + + -- Start of processing for Check_Unset_Reference + begin -- Nothing to do if warnings suppressed @@ -1091,13 +1367,11 @@ package body Sem_Warn is 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). + -- Ignore reference unless it comes from source. Almost always if we + -- have a reference from generated code, it is 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 + if not Comes_From_Source (N) then return; end if; @@ -1110,21 +1384,27 @@ package body Sem_Warn is -- unset reference, we check whether N is earlier before proceeding. case Nkind (N) is + + -- For identifier or exanded name, examine the entity involved + when N_Identifier | N_Expanded_Name => declare E : constant Entity_Id := Entity (N); begin if (Ekind (E) = E_Variable - or else Ekind (E) = E_Out_Parameter) - and then Never_Set_In_Source (E) + or else + Ekind (E) = E_Out_Parameter) + and then Never_Set_In_Source_Check_Spec (E) + and then not Has_Initial_Value (E) and then (No (Unset_Reference (E)) - or else Earlier_In_Extended_Unit - (Sloc (N), Sloc (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 + -- this is an access to 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 @@ -1137,21 +1417,29 @@ package body Sem_Warn is -- not the record, and still deserves an unset reference. if Nkind (Parent (N)) = N_Selected_Component - and not Is_Access_Type (Etype (N)) + and not Is_Access_Type (Typ) then declare ES : constant Entity_Id := Entity (Selector_Name (Parent (N))); - begin if Ekind (ES) = E_Discriminant - or else Present (Expression (Declaration_Node (ES))) + or else + (Present (Declaration_Node (ES)) + and then + Present (Expression (Declaration_Node (ES)))) then return; end if; end; end if; + -- Exclude fully initialized types + + if Is_OK_Fully_Initialized then + return; + 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 @@ -1187,13 +1475,12 @@ package body Sem_Warn is -- cannot be truly uninitialized, but we still want to -- warn about cases of obvious null dereference. - if Is_Access_Type (Etype (N)) then + if Is_Access_Type (Typ) then Access_Type_Case : declare P : Node_Id; function Process - (N : Node_Id) - return Traverse_Result; + (N : Node_Id) return Traverse_Result; -- Process function for instantation of Traverse -- below. Checks if N contains reference to other -- than a dereference. @@ -1207,8 +1494,7 @@ package body Sem_Warn is ------------- function Process - (N : Node_Id) - return Traverse_Result + (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) @@ -1234,18 +1520,18 @@ package body Sem_Warn is -- Start of processing for Access_Type_Case begin - -- Don't bother if we are inside an instance, - -- since the compilation of the generic template - -- is where the warning should be issued. + -- 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. + -- 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 @@ -1301,8 +1587,8 @@ package body Sem_Warn is 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. + -- 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)); @@ -1311,25 +1597,90 @@ package body Sem_Warn is end if; end; + -- Indexed component or slice + when N_Indexed_Component | N_Slice => - Check_Unset_Reference (Prefix (N)); - when N_Selected_Component => + -- If prefix does not involve dereferencing an access type, then + -- we know we are OK if the component type is fully initialized, + -- since the component will have been set as part of the default + -- initialization. - if Present (Entity (Selector_Name (N))) - and then Ekind (Entity (Selector_Name (N))) = E_Discriminant + if not Prefix_Has_Dereference (Prefix (N)) + and then Is_OK_Fully_Initialized then - -- A discriminant is always initialized + return; - null; + -- Look at prefix in access type case, or if the component is not + -- fully initialized. else Check_Unset_Reference (Prefix (N)); end if; + -- Record component + + when N_Selected_Component => + declare + Pref : constant Node_Id := Prefix (N); + Ent : constant Entity_Id := Entity (Selector_Name (N)); + + begin + -- If prefix involves dereferencing an access type, always + -- check the prefix, since the issue then is whether this + -- access value is null. + + if Prefix_Has_Dereference (Pref) then + null; + + -- Always go to prefix if no selector entity is set. Can this + -- happen in the normal case? Not clear, but it definitely can + -- happen in error cases. + + elsif No (Ent) then + null; + + -- For a record component, check some cases where we have + -- reasonable cause to consider that the component is known to + -- be or probably is initialized. In this case, we don't care + -- if the prefix itself was explicitly initialized. + + -- Discriminants are always considered initialized + + elsif Ekind (Ent) = E_Discriminant then + return; + + -- An explicitly initialized component is certainly initialized + + elsif Nkind (Parent (Ent)) = N_Component_Declaration + and then Present (Expression (Parent (Ent))) + then + return; + + -- A fully initialized component is initialized + + elsif Is_OK_Fully_Initialized then + return; + end if; + + -- If none of those cases apply, check the record type prefix + + Check_Unset_Reference (Pref); + end; + + -- For type conversions or qualifications examine the expression + when N_Type_Conversion | N_Qualified_Expression => Check_Unset_Reference (Expression (N)); + -- For explicit dereference, always check prefix, which will generate + -- an unset reference (since this is a case of dereferencing null). + + when N_Explicit_Dereference => + Check_Unset_Reference (Prefix (N)); + + -- All other cases are not cases of an unset reference + when others => null; @@ -1406,7 +1757,7 @@ package body Sem_Warn is if Entity (Nam) = Pack then Error_Msg_Qual_Level := 1; Error_Msg_NE - ("no entities of package& are referenced?", + ("?no entities of package& are referenced!", Nam, Pack); Error_Msg_Qual_Level := 0; end if; @@ -1423,7 +1774,7 @@ package body Sem_Warn is begin E := First_Entity (Pack); while Present (E) loop - if Referenced (E) then + if Referenced_Check_Spec (E) then return; end if; @@ -1451,7 +1802,7 @@ package body Sem_Warn is then Ent := First_Entity (System_Aux_Id); while Present (Ent) loop - if Referenced (Ent) then + if Referenced_Check_Spec (Ent) then return True; end if; @@ -1559,7 +1910,7 @@ package body Sem_Warn is else Error_Msg_N - ("unit& is not referenced?", Name (Item)); + ("?unit& is not referenced!", Name (Item)); end if; end if; @@ -1630,7 +1981,7 @@ package body Sem_Warn is else Error_Msg_N - ("no entities of & are referenced?", + ("?no entities of & are referenced!", Name (Item)); -- Look for renamings of this package, and flag @@ -1644,7 +1995,7 @@ package body Sem_Warn is and then not Warnings_Off (Lunit) then Error_Msg_NE - ("no entities of & are referenced?", + ("?no entities of & are referenced!", Unit_Declaration_Node (Pack), Pack); end if; @@ -1652,16 +2003,23 @@ package body Sem_Warn is exit; - -- Case of next entity is referenced - - elsif Referenced (Ent) - or else Referenced_As_LHS (Ent) + -- Case of entity being referenced. The reference may + -- come from a limited_with_clause, in which case the + -- limited view of the entity carries the flag. + + elsif Referenced_Check_Spec (Ent) + or else Referenced_As_LHS_Check_Spec (Ent) + or else + (From_With_Type (Ent) + and then Is_Incomplete_Type (Ent) + and then Present (Non_Limited_View (Ent)) + and then Referenced (Non_Limited_View (Ent))) then -- This means that the with is indeed fine, in that -- it is definitely needed somewhere, and we can - -- quit 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 -- where we complain that the with could be moved -- from the spec. If the spec contains a visible @@ -1676,12 +2034,12 @@ package body Sem_Warn is if Unreferenced_In_Spec (Item) then Error_Msg_N - ("unit& is not referenced in spec?", + ("?unit& is not referenced in spec!", Name (Item)); elsif No_Entities_Ref_In_Spec (Item) then Error_Msg_N - ("no entities of & are referenced in spec?", + ("?no entities of & are referenced in spec!", Name (Item)); else @@ -1694,7 +2052,7 @@ package body Sem_Warn is if not Is_Visible_Renaming then Error_Msg_N - ("\with clause might be moved to body?", + ("\?with clause might be moved to body!", Name (Item)); end if; @@ -1722,7 +2080,7 @@ package body Sem_Warn is Set_Unreferenced_In_Spec (Item); else Error_Msg_N - ("unit& is never instantiated?", Name (Item)); + ("?unit& is never instantiated!", Name (Item)); end if; -- If unit was indeed instantiated, make sure that flag is @@ -1731,9 +2089,9 @@ package body Sem_Warn is elsif Unreferenced_In_Spec (Item) then Error_Msg_N - ("unit& is not instantiated in spec?", Name (Item)); + ("?unit& is not instantiated in spec!", Name (Item)); Error_Msg_N - ("\with clause can be moved to body?", Name (Item)); + ("\?with clause can be moved to body!", Name (Item)); end if; end if; end if; @@ -1809,6 +2167,53 @@ package body Sem_Warn is end if; end Generic_Package_Spec_Entity; + ---------------------- + -- Goto_Spec_Entity -- + ---------------------- + + function Goto_Spec_Entity (E : Entity_Id) return Entity_Id is + begin + if Is_Formal (E) + and then Present (Spec_Entity (E)) + then + return Spec_Entity (E); + else + return E; + end if; + end Goto_Spec_Entity; + + ---------------------------------------- + -- Has_Pragma_Unreferenced_Check_Spec -- + ---------------------------------------- + + function Has_Pragma_Unreferenced_Check_Spec + (E : Entity_Id) return Boolean + is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Has_Pragma_Unreferenced (E) + or else + Has_Pragma_Unreferenced (Spec_Entity (E)); + else + return Has_Pragma_Unreferenced (E); + end if; + end Has_Pragma_Unreferenced_Check_Spec; + + ------------------------------------ + -- Never_Set_In_Source_Check_Spec -- + ------------------------------------ + + function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Never_Set_In_Source (E) + and then + Never_Set_In_Source (Spec_Entity (E)); + else + return Never_Set_In_Source (E); + end if; + end Never_Set_In_Source_Check_Spec; + ------------------------------------- -- Operand_Has_Warnings_Suppressed -- ------------------------------------- @@ -1856,6 +2261,72 @@ package body Sem_Warn is return False; end Operand_Has_Warnings_Suppressed; + ----------------------------------------- + -- Output_Non_Modified_In_Out_Warnings -- + ----------------------------------------- + + procedure Output_Non_Modifed_In_Out_Warnings is + + function No_Warn_On_In_Out (E : Entity_Id) return Boolean; + -- Given a formal parameter entity E, determines if there is a reason to + -- suppress IN OUT warnings (not modified, could be IN) for formals of + -- the subprogram. We suppress these warnings if Warnings Off is set, or + -- if we have seen the address of the subprogram being taken, or if the + -- subprogram is used as a generic actual (in the latter cases the + -- context may force use of IN OUT, even if the parameter is not + -- modifies for this particular case. + + ----------------------- + -- No_Warn_On_In_Out -- + ----------------------- + + function No_Warn_On_In_Out (E : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (E); + begin + if Warnings_Off (S) then + return True; + elsif Address_Taken (S) then + return True; + elsif Used_As_Generic_Actual (S) then + return True; + elsif Present (Spec_Entity (E)) then + return No_Warn_On_In_Out (Spec_Entity (E)); + else + return False; + end if; + end No_Warn_On_In_Out; + + -- Start of processing for Output_Non_Modifed_In_Out_Warnings + + begin + -- Loop through entities for which a warning may be needed + + for J in In_Out_Warnings.First .. In_Out_Warnings.Last loop + declare + E1 : constant Entity_Id := In_Out_Warnings.Table (J); + + begin + -- Suppress warning in specific cases (see details in comments for + -- No_Warn_On_In_Out). + + if No_Warn_On_In_Out (E1) then + null; + + -- Here we generate the warning + + else + Error_Msg_N ("?formal parameter & is not modified!", E1); + Error_Msg_N ("\?mode could be IN instead of `IN OUT`!", E1); + + -- Kill any other warnings on this entity, since this is the + -- one that should dominate any other unreferenced warning. + + Set_Warnings_Off (E1); + end if; + end; + end loop; + end Output_Non_Modifed_In_Out_Warnings; + ---------------------------------------- -- Output_Obsolescent_Entity_Warnings -- ---------------------------------------- @@ -2004,119 +2475,40 @@ package body Sem_Warn is ---------------------------------- procedure Output_Unreferenced_Messages is - E : Entity_Id; - begin for J in Unreferenced_Entities.First .. Unreferenced_Entities.Last loop - E := Unreferenced_Entities.Table (J); - - if not Referenced (E) and then not Warnings_Off (E) then - case Ekind (E) is - when E_Variable => - - -- 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 - if Warn_On_Modified_Unread - and then not Is_Imported (E) - and then not Is_Return_Object (E) - - -- Suppress message for aliased or renamed variables, - -- since there may be other entities that read the - -- same memory location. - - and then not Is_Aliased (E) - and then 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 - -- We suppress the message for types for which a valid - -- pragma Unreferenced_Objects has been given, otherwise - -- we go ahead and give the message. - - if not Has_Pragma_Unreferenced_Objects (Etype (E)) then - - -- 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; - - when E_Constant => - if Present (Renamed_Object (E)) - and then Comes_From_Source (Renamed_Object (E)) - then - Error_Msg_N ("renamed constant & is not referenced?", E); - else - Error_Msg_N ("constant & is not referenced?", E); - end if; - - when E_In_Parameter | - E_Out_Parameter | - E_In_Out_Parameter => - - -- Do not emit message for formals of a renaming, because - -- they are never referenced explicitly. - - if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) - /= N_Subprogram_Renaming_Declaration - then - Error_Msg_N ("formal parameter & is not referenced?", E); - end if; - - when E_Named_Integer | - E_Named_Real => - Error_Msg_N ("named number & is not referenced?", E); - - when E_Enumeration_Literal => - Error_Msg_N ("literal & is not referenced?", E); - - when E_Function => - Error_Msg_N ("function & is not referenced?", E); - - when E_Procedure => - Error_Msg_N ("procedure & is not referenced?", E); - - when E_Generic_Procedure => - Error_Msg_N - ("generic procedure & is never instantiated?", E); + Warn_On_Unreferenced_Entity (Unreferenced_Entities.Table (J)); + end loop; + end Output_Unreferenced_Messages; - when E_Generic_Function => - Error_Msg_N ("generic function & is never instantiated?", E); + --------------------------- + -- Referenced_Check_Spec -- + --------------------------- - when Type_Kind => - Error_Msg_N ("type & is not referenced?", E); + function Referenced_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Referenced (E) or else Referenced (Spec_Entity (E)); + else + return Referenced (E); + end if; + end Referenced_Check_Spec; - when others => - Error_Msg_N ("& is not referenced?", E); - end case; + ---------------------------------- + -- Referenced_As_LHS_Check_Spec -- + ---------------------------------- - Set_Warnings_Off (E); - end if; - end loop; - end Output_Unreferenced_Messages; + function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean is + begin + if Is_Formal (E) and then Present (Spec_Entity (E)) then + return Referenced_As_LHS (E) + or else Referenced_As_LHS (Spec_Entity (E)); + else + return Referenced_As_LHS (E); + end if; + end Referenced_As_LHS_Check_Spec; ---------------------------- -- Set_Dot_Warning_Switch -- @@ -2785,6 +3177,204 @@ package body Sem_Warn is end if; end Warn_On_Suspicious_Index; + -------------------------------------- + -- Warn_On_Unassigned_Out_Parameter -- + -------------------------------------- + + procedure Warn_On_Unassigned_Out_Parameter + (Return_Node : Node_Id; + Scope_Id : Entity_Id) + is + Form : Entity_Id; + Form2 : Entity_Id; + + begin + -- Ignore if procedure or return statement does not come from source + + if not Comes_From_Source (Scope_Id) + or else not Comes_From_Source (Return_Node) + then + return; + end if; + + -- Loop through formals + + Form := First_Formal (Scope_Id); + while Present (Form) loop + + -- We are only interested in OUT parameters that come from source + -- and are never set in the source, and furthermore only in scalars + -- since non-scalars generate too many false positives. + + if Ekind (Form) = E_Out_Parameter + and then Never_Set_In_Source_Check_Spec (Form) + and then Is_Scalar_Type (Etype (Form)) + and then not Present (Unset_Reference (Form)) + then + -- Before we issue the warning, an add ad hoc defence against the + -- most common case of false positives with this warning which is + -- the case where there is a Boolean OUT parameter that has been + -- set, and whose meaning is "ignore the values of the other + -- parameters". We can't of course reliably tell this case at + -- compile time, but the following test kills a lot of false + -- positives, without generating a significant number of false + -- negatives (missed real warnings). + + Form2 := First_Formal (Scope_Id); + while Present (Form2) loop + if Ekind (Form2) = E_Out_Parameter + and then Root_Type (Etype (Form2)) = Standard_Boolean + and then not Never_Set_In_Source_Check_Spec (Form2) + then + return; + end if; + + Next_Formal (Form2); + end loop; + + -- Here all conditionas are met, record possible unset reference + + Set_Unset_Reference (Form, Return_Node); + end if; + + Next_Formal (Form); + end loop; + end Warn_On_Unassigned_Out_Parameter; + + --------------------------------- + -- Warn_On_Unreferenced_Entity -- + --------------------------------- + + procedure Warn_On_Unreferenced_Entity + (Spec_E : Entity_Id; + Body_E : Entity_Id := Empty) + is + E : Entity_Id := Spec_E; + begin + if not Referenced_Check_Spec (E) and then not Warnings_Off (E) then + case Ekind (E) is + when E_Variable => + + -- 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_Check_Spec (E) + and then No (Address_Clause (E)) + and then not Is_Volatile (E) + then + if Warn_On_Modified_Unread + and then not Is_Imported (E) + and then not Is_Return_Object (E) + + -- Suppress message for aliased or renamed variables, + -- since there may be other entities that read the + -- same memory location. + + and then not Is_Aliased (E) + and then 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 + -- We suppress the message for types for which a valid + -- pragma Unreferenced_Objects has been given, otherwise + -- we go ahead and give the message. + + if not Has_Pragma_Unreferenced_Objects (Etype (E)) then + + -- 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; + + when E_Constant => + if Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + Error_Msg_N + ("?renamed constant & is not referenced!", E); + else + Error_Msg_N ("?constant & is not referenced!", E); + end if; + + when E_In_Parameter | + E_In_Out_Parameter => + + -- Do not emit message for formals of a renaming, because + -- they are never referenced explicitly. + + if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) + /= N_Subprogram_Renaming_Declaration + then + -- Suppress this message for an IN OUT parameter of a + -- non-scalar type, since it is normal to have only an + -- assignment in such a case. + + if Ekind (E) = E_In_Parameter + or else not Referenced_As_LHS_Check_Spec (E) + or else Is_Scalar_Type (E) + then + if Present (Body_E) then + E := Body_E; + end if; + Error_Msg_NE + ("?formal parameter & is not referenced!", E, Spec_E); + end if; + end if; + + when E_Out_Parameter => + null; + + when E_Named_Integer | + E_Named_Real => + Error_Msg_N ("?named number & is not referenced!", E); + + when E_Enumeration_Literal => + Error_Msg_N ("?literal & is not referenced!", E); + + when E_Function => + Error_Msg_N ("?function & is not referenced!", E); + + 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); + + when others => + Error_Msg_N ("?& is not referenced!", E); + end case; + + -- Kill warnings on the entity on which the message has been posted + + Set_Warnings_Off (E); + end if; + end Warn_On_Unreferenced_Entity; + -------------------------------- -- Warn_On_Useless_Assignment -- -------------------------------- @@ -2833,7 +3423,7 @@ package body Sem_Warn is and then not Is_Return_Object (Ent) and then Present (Last_Assignment (Ent)) and then not Warnings_Off (Ent) - and then not Has_Pragma_Unreferenced (Ent) + and then not Has_Pragma_Unreferenced_Check_Spec (Ent) and then not Is_Imported (Ent) and then not Is_Exported (Ent) then @@ -2857,12 +3447,12 @@ package body Sem_Warn is then if Loc = No_Location then Error_Msg_NE - ("?useless assignment to&, value never referenced", + ("?useless assignment to&, value never referenced!", Last_Assignment (Ent), Ent); else Error_Msg_Sloc := Loc; Error_Msg_NE - ("?useless assignment to&, value overwritten #", + ("?useless assignment to&, value overwritten #!", Last_Assignment (Ent), Ent); end if; -- 2.7.4