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