From: Robert Dewar Date: Wed, 6 Jun 2007 10:29:05 +0000 (+0200) Subject: g-comlin.ads, [...]: Add new warning for renaming of function return objects X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fbe627afbd02f0e151a772f1bbd00ec8dc13c6a8;p=gcc.git g-comlin.ads, [...]: Add new warning for renaming of function return objects 2007-04-20 Robert Dewar Ed Schonberg * g-comlin.ads, g-comlin.adb: Add new warning for renaming of function return objects * opt.adb (Tree_Write, Tree_Read): Use proper expressions for size (Tree_Read): Use size of object instead of type'object_size, since the latter is incorrect for packed array types. (Tree_Write): Same fix * opt.ads: Add new warning for renaming of function return objects (Generating_Code): New boolean variable used to indicate that the frontend as finished its work and has called the backend to process the tree and generate the object file. (GCC_Version): Is now private (Static_Dispatch_Tables): New constant declaration. (Overflow_Checks_Unsuppressed): New flag. (Process_Suppress_Unsuppress): Set Overflow_Checks_Unsuppressed. (List_Closure): New flag for gnatbind (-R) Zero_Formatting: New flag for gnatbind (-Z) (Special_Exception_Package_Used): New flag. (Warn_On_Unrepped_Components): New flag. * sem_ch8.adb (Check_Library_Unit_Renaming): Check that the renamed unit is a compilation unit, rather than relying on its scope, so that Standard can be renamed. (Analyze_Object_Renaming): Add new warning for renaming of function return objects. Also reject attempt to rename function return object in Ada 83 mode. (Attribute_Renaming): In case of tagged types, add the body of the generated function to the freezing actions of the type. (Find_Type): A protected type is visible right after the reserved word "is" is encountered in its type declaration. Set the entity and type rather than emitting an error message. (New_Scope): Properly propagate Discard_Names to inner scopes (Check_Nested_Access): New procedure. (Has_Nested_Access, Set_Has_Nested_Access): New procedures. (Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access. * sem_warn.ads, sem_warn.adb: Improvements to infinite loop warning Add new warning for renaming of function return objects (Check_References): Suppress warnings for objects whose type or base type has Warnings suppressed. (Set_Dot_Warning_Switch): Add processing for -gnatw.c/C (Set_Warning_Switch): Include new -gnatwc in -gnatwa From-SVN: r125414 --- diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 4b62e1ceb03..52a15550762 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2007, 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- -- @@ -32,7 +32,7 @@ ------------------------------------------------------------------------------ with Ada.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is @@ -142,9 +142,9 @@ package body GNAT.Command_Line is use GNAT.Directory_Operations; type Pointer is access all Expansion_Iterator; + It : constant Pointer := Iterator'Unrestricted_Access; S : String (1 .. 1024); Last : Natural; - It : constant Pointer := Iterator'Unrestricted_Access; Current : Depth := It.Current_Depth; NL : Positive; @@ -304,8 +304,8 @@ package body GNAT.Command_Line is if Do_Expansion then declare - Arg : String renames CL.Argument (Current_Argument - 1); - Index : Positive := Arg'First; + Arg : constant String := CL.Argument (Current_Argument - 1); + Index : Positive := Arg'First; begin while Index <= Arg'Last loop @@ -381,7 +381,7 @@ package body GNAT.Command_Line is end if; declare - Arg : String renames CL.Argument (Current_Argument); + Arg : constant String := CL.Argument (Current_Argument); Index_Switches : Natural := 0; Max_Length : Natural := 0; Index : Natural; @@ -780,9 +780,9 @@ package body GNAT.Command_Line is is Directory_Separator : Character; pragma Import (C, Directory_Separator, "__gnat_dir_separator"); - First : Positive := Pattern'First; - Pat : String := Pattern; + First : Positive := Pattern'First; + Pat : String := Pattern; begin Canonical_Case_File_Name (Pat); @@ -838,7 +838,6 @@ package body GNAT.Command_Line is exit when Iterator.Maximum_Depth = Max_Depth; end if; end loop; - end Start_Expansion; begin diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 447e617c28e..60073f303c6 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2005, AdaCore -- +-- Copyright (C) 1999-2007, 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- -- @@ -322,7 +322,6 @@ private Maximum_Depth : Depth := 1; -- The maximum depth of directories, reflecting the number of directory -- separators in the pattern. - end record; end GNAT.Command_Line; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 8c11718e189..783481245b2 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -37,6 +37,9 @@ with Tree_IO; use Tree_IO; package body Opt is + SU : constant := Storage_Unit; + -- Shorthand for System.Storage_Unit + ---------------------------------- -- Register_Opt_Config_Switches -- ---------------------------------- @@ -169,10 +172,10 @@ package body Opt is Tree_Read_Char (Identifier_Character_Set); Tree_Read_Int (Maximum_File_Name_Length); Tree_Read_Data (Suppress_Options'Address, - Suppress_Array'Object_Size / Storage_Unit); + (Suppress_Options'Size + SU - 1) / SU); Tree_Read_Bool (Verbose_Mode); Tree_Read_Data (Warning_Mode'Address, - Warning_Mode_Type'Object_Size / Storage_Unit); + (Warning_Mode'Size + SU - 1) / SU); Tree_Read_Int (Ada_Version_Config_Val); Tree_Read_Int (Ada_Version_Explicit_Config_Val); Tree_Read_Int (Assertions_Enabled_Config_Val); @@ -198,23 +201,23 @@ package body Opt is begin Tree_Read_Data (Tmp'Address, Tree_Version_String_Len); - GNAT.Strings.Free (Tree_Version_String); + System.Strings.Free (Tree_Version_String); Free (Tree_Version_String); Tree_Version_String := new String'(Tmp); end; Tree_Read_Data (Distribution_Stub_Mode'Address, - Distribution_Stub_Mode_Type'Object_Size / Storage_Unit); + (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit); Tree_Read_Bool (Inline_Active); Tree_Read_Bool (Inline_Processing_Required); Tree_Read_Bool (List_Units); Tree_Read_Bool (Configurable_Run_Time_Mode); Tree_Read_Data (Operating_Mode'Address, - Operating_Mode_Type'Object_Size / Storage_Unit); + (Operating_Mode'Size + SU - 1) / Storage_Unit); Tree_Read_Bool (Suppress_Checks); Tree_Read_Bool (Try_Semantics); Tree_Read_Data (Wide_Character_Encoding_Method'Address, - WC_Encoding_Method'Object_Size / Storage_Unit); + (Wide_Character_Encoding_Method'Size + SU - 1) / SU); Tree_Read_Bool (Upper_Half_Encoding); Tree_Read_Bool (Force_ALI_Tree_File); end Tree_Read; @@ -233,10 +236,10 @@ package body Opt is Tree_Write_Char (Identifier_Character_Set); Tree_Write_Int (Maximum_File_Name_Length); Tree_Write_Data (Suppress_Options'Address, - Suppress_Array'Object_Size / Storage_Unit); + (Suppress_Options'Size + SU - 1) / SU); Tree_Write_Bool (Verbose_Mode); Tree_Write_Data (Warning_Mode'Address, - Warning_Mode_Type'Object_Size / Storage_Unit); + (Warning_Mode'Size + SU - 1) / Storage_Unit); Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Config)); Tree_Write_Int (Ada_Version_Type'Pos (Ada_Version_Explicit_Config)); Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config)); @@ -246,20 +249,19 @@ package body Opt is Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); Tree_Write_Int (Int (Version_String'Length)); - Tree_Write_Data (Version_String'Address, - Version_String'Length); + Tree_Write_Data (Version_String'Address, Version_String'Length); Tree_Write_Data (Distribution_Stub_Mode'Address, - Distribution_Stub_Mode_Type'Object_Size / Storage_Unit); + (Distribution_Stub_Mode'Size + SU - 1) / SU); Tree_Write_Bool (Inline_Active); Tree_Write_Bool (Inline_Processing_Required); Tree_Write_Bool (List_Units); Tree_Write_Bool (Configurable_Run_Time_Mode); Tree_Write_Data (Operating_Mode'Address, - Operating_Mode_Type'Object_Size / Storage_Unit); + (Operating_Mode'Size + SU - 1) / SU); Tree_Write_Bool (Suppress_Checks); Tree_Write_Bool (Try_Semantics); Tree_Write_Data (Wide_Character_Encoding_Method'Address, - WC_Encoding_Method'Object_Size / Storage_Unit); + (Wide_Character_Encoding_Method'Size + SU - 1) / SU); Tree_Write_Bool (Upper_Half_Encoding); Tree_Write_Bool (Force_ALI_Tree_File); end Tree_Write; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index fb1fa0ed217..14d04dbbc2b 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -39,8 +39,8 @@ with Hostparm; use Hostparm; with Types; use Types; +with System.Strings; use System.Strings; with System.WCh_Con; use System.WCh_Con; -with GNAT.Strings; use GNAT.Strings; package Opt is @@ -386,6 +386,11 @@ package Opt is -- Set to True if -gnato (enable overflow checks) switch is set, -- but not -gnatp. + Overflow_Checks_Unsuppressed : Boolean := False; + -- GNAT + -- Set to True if at least one pragma Unsuppress + -- (All_Checks|Overflow_Checks) has been processed. + Error_Msg_Line_Length : Nat := 0; -- GNAT -- Records the error message line length limit. If this is set to zero, @@ -510,16 +515,15 @@ package Opt is -- the name is of the form .xxx, then to name.xxx where name is the source -- file name with extension stripped. - function get_gcc_version return Int; - pragma Import (C, get_gcc_version, "get_gcc_version"); - - GCC_Version : constant Nat := get_gcc_version; - -- GNATMAKE - -- Indicates which version of gcc is in use (2 = 2.8.1, 3 = 3.x) + Generating_Code : Boolean := False; + -- GNAT + -- True if the frontend finished its work and has called the backend to + -- processs the tree and generate the object file. Global_Discard_Names : Boolean := False; -- GNAT, GNATBIND - -- Set true if a pragma Discard_Names applies to the current unit + -- True if a pragma Discard_Names appeared as a configuration pragma for + -- the current compilation unit. GNAT_Mode : Boolean := False; -- GNAT @@ -633,6 +637,10 @@ package Opt is -- GNAT -- List units in the active library for a compilation (-gnatu switch) + List_Closure : Boolean := False; + -- GNATBIND + -- List all sources in the closure of a main (-R gnatbind switch) + List_Dependencies : Boolean := False; -- GNATMAKE -- When True gnatmake verifies that the objects are up to date and @@ -668,7 +676,7 @@ package Opt is -- before preprocessing occurs. Set to True by switch -s of gnatprep -- or -s in preprocessing data file for the compiler. - type Create_Repinfo_File_Proc is access procedure (Src : File_Name_Type); + type Create_Repinfo_File_Proc is access procedure (Src : String); type Write_Repinfo_Line_Proc is access procedure (Info : String); type Close_Repinfo_File_Proc is access procedure; -- Types used for procedure addresses below @@ -753,6 +761,12 @@ package Opt is -- GNATMAKE -- Set to True if minimal recompilation mode requested + Special_Exception_Package_Used : Boolean := False; + -- GNAT + -- Set to True if either of the unit GNAT.Most_Recent_Exception or + -- GNAT.Exception_Traces is with'ed. Used to inhibit transformation of + -- local raise statements into gotos in the presence of either package. + Multiple_Unit_Index : Int; -- GNAT -- This is set non-zero if the current unit is being compiled in multiple @@ -1186,6 +1200,11 @@ package Opt is -- Set to True to generate warnings for redundant constructs (e.g. useless -- assignments/conversions). The default is that this warning is disabled. + Warn_On_Object_Renames_Function : Boolean := False; + -- GNAT + -- Set to True to generate warnings when a function result is renamed as + -- an object. The default is that this warning is disabled. + Warn_On_Reverse_Bit_Order : Boolean := True; -- GNAT -- Set to True to generate warning (informational) messages for component @@ -1203,6 +1222,12 @@ package Opt is -- Set to True to generate warnings for unrecognized pragmas. The default -- is that this warning is enabled. + Warn_On_Unrepped_Components : Boolean := False; + -- GNAT + -- Set to True to generate warnings for the case of components of record + -- which have a record representation clause but this component does not + -- have a component clause. The default is that this warning is disabled. + type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); Warning_Mode : Warning_Mode_Type := Normal; -- GNAT, GNATBIND @@ -1226,6 +1251,11 @@ package Opt is -- GNAT -- Set if cross-referencing is enabled (i.e. xref info in ALI files) + Zero_Formatting : Boolean := False; + -- GNATBIND + -- Do no formatting (no title, no leading spaces, no empty lines) in + -- auxiliary outputs (-e, -K, -l, -R). + ---------------------------- -- Configuration Settings -- ---------------------------- @@ -1362,6 +1392,15 @@ package Opt is -- Other Global Flags -- ------------------------ + Static_Dispatch_Tables : constant Boolean; + -- This flag indicates if the backend supports generation of statically + -- allocated dispatch tables. If it is True, then the front end will + -- generate static aggregates for dispatch tables that contain forward + -- references to addresses of subprograms not seen yet, and the back end + -- must be prepared to handle this case. If it is False, then the front + -- end generates assignments to initialize the dispatch table, and there + -- are no such forward references. + Expander_Active : Boolean := False; -- A flag that indicates if expansion is active (True) or deactivated -- (False). When expansion is deactivated all calls to expander routines @@ -1431,4 +1470,20 @@ private Use_VADS_Size : Boolean; end record; + -- The following declarations are for GCC version dependent flags. We do + -- not let client code in the compiler test GCC_Version directly, but + -- instead use deferred constants for relevant feature tags. + + function get_gcc_version return Int; + pragma Import (C, get_gcc_version, "get_gcc_version"); + + GCC_Version : constant Nat := get_gcc_version; + -- GNATMAKE + -- Indicates which version of gcc is in use (3 = 3.x, 4 = 4.x). Note that + -- gcc 2.8.1 (which used to be a value of 2) is no longer supported. + + Static_Dispatch_Tables : constant Boolean := GCC_Version >= 4; + -- GCC version 4 can handle the static dispatch tables, but not version 3. + -- Also we need -funit-at-a-time, which should also be tested here ??? + end Opt; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 982fa76c4d1..7de0b707c54 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -721,10 +721,25 @@ package body Sem_Ch8 is Set_Etype (Nam, T); end if; + -- Complete analysis of the subtype mark in any case, for ASIS use. + + if Present (Subtype_Mark (N)) then + Find_Type (Subtype_Mark (N)); + end if; + elsif Present (Subtype_Mark (N)) then Find_Type (Subtype_Mark (N)); T := Entity (Subtype_Mark (N)); - Analyze_And_Resolve (Nam, T); + Analyze (Nam); + + if Nkind (Nam) = N_Type_Conversion + and then not Is_Tagged_Type (T) + then + Error_Msg_N + ("renaming of conversion only allowed for tagged types", Nam); + end if; + + Resolve (Nam, T); -- Ada 2005 (AI-230/AI-254): Access renaming @@ -748,6 +763,40 @@ package body Sem_Ch8 is end if; end if; + -- Special processing for renaming function return object + + if Nkind (Nam) = N_Function_Call + and then Comes_From_Source (Nam) + then + case Ada_Version is + + -- Usage is illegal in Ada 83 + + when Ada_83 => + Error_Msg_N + ("(Ada 83) cannot rename function return object", Nam); + + -- In Ada 95, warn for odd case of renaming parameterless function + -- call if this is not a limited type (where this is useful) + + when others => + if Warn_On_Object_Renames_Function + and then No (Parameter_Associations (Nam)) + and then not Is_Limited_Type (Etype (Nam)) + then + Error_Msg_N + ("?renaming function result object is suspicious", + Nam); + Error_Msg_NE + ("\?function & will be called only once", + Nam, Entity (Name (Nam))); + Error_Msg_N + ("\?suggest using an initialized constant object instead", + Nam); + end if; + end case; + end if; + -- An object renaming requires an exact match of the type. Class-wide -- matching is not allowed. @@ -802,7 +851,7 @@ package body Sem_Ch8 is -- formal object of a generic unit G, and the object renaming -- declaration occurs within the body of G or within the body -- of a generic unit declared within the declarative region - -- of G, then the declaration of the formal object of G shall + -- of G, then the declaration of the formal object of G must -- have a null exclusion. if Is_Formal_Object (Nam_Ent) @@ -818,8 +867,12 @@ package body Sem_Ch8 is Error_Node := Access_Definition (Nam_Decl); end if; - Error_Msg_N ("null-exclusion required in formal " & - "object declaration", Error_Node); + Error_Msg_N + ("`NOT NULL` required in formal object declaration", + Error_Node); + Error_Msg_Sloc := Sloc (N); + Error_Msg_N + ("\because of renaming at# ('R'M 8.5.4(4))", Error_Node); -- Ada 2005 (AI-423): Otherwise, the subtype of the object name -- shall exclude null. @@ -827,8 +880,9 @@ package body Sem_Ch8 is elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration and then not Has_Null_Exclusion (Subtyp_Decl) then - Error_Msg_N ("subtype must have null-exclusion", - Subtyp_Decl); + Error_Msg_N + ("`NOT NULL` required for subtype & ('R'M 8.5.1(4.6/2))", + Defining_Identifier (Subtyp_Decl)); end if; end if; end; @@ -1275,8 +1329,9 @@ package body Sem_Ch8 is not (Has_Null_Exclusion (Parent (Sub_Formal)) or else Can_Never_Be_Null (Etype (Sub_Formal))) then - Error_Msg_N ("null-exclusion required in parameter profile", - Parent (Sub_Formal)); + Error_Msg_NE + ("`NOT NULL` required for parameter &", + Parent (Sub_Formal), Sub_Formal); end if; Next_Formal (Ren_Formal); @@ -1292,8 +1347,9 @@ package body Sem_Ch8 is not (Has_Null_Exclusion (Parent (Sub)) or else Can_Never_Be_Null (Etype (Sub))) then - Error_Msg_N ("null-exclusion required in return profile", - Result_Definition (Parent (Sub))); + Error_Msg_N + ("return must specify `NOT NULL`", + Result_Definition (Parent (Sub))); end if; end Check_Null_Exclusion; @@ -1525,6 +1581,7 @@ package body Sem_Ch8 is -- for it at the freezing point. Set_Corresponding_Spec (N, Rename_Spec); + if Nkind (Unit_Declaration_Node (Rename_Spec)) = N_Abstract_Subprogram_Declaration then @@ -1954,8 +2011,9 @@ package body Sem_Ch8 is and then not Can_Never_Be_Null (Old_F) then Error_Msg_N ("access parameter is controlling,", New_F); - Error_Msg_NE ("\corresponding parameter of& " & - " must be explicitly null excluding", New_F, Old_S); + Error_Msg_NE + ("\corresponding parameter of& " + & "must be explicitly null excluding", New_F, Old_S); end if; Next_Formal (Old_F); @@ -2334,16 +2392,43 @@ package body Sem_Ch8 is Statements => New_List (Attr_Node))); end if; - Rewrite (N, Body_Node); - Analyze (N); + -- In case of tagged types we add the body of the generated function to + -- the freezing actions of the type (because in the general case such + -- type is still not frozen). We exclude from this processing generic + -- formal subprograms found in instantiations and AST_Entry renamings. + + if not Present (Corresponding_Formal_Spec (N)) + and then Etype (Nam) /= RTE (RE_AST_Handler) + then + declare + P : constant Entity_Id := Prefix (Nam); + + begin + Find_Type (P); + + if Is_Tagged_Type (Etype (P)) then + Ensure_Freeze_Node (Etype (P)); + Append_Freeze_Action (Etype (P), Body_Node); + else + Rewrite (N, Body_Node); + Analyze (N); + Set_Etype (New_S, Base_Type (Etype (New_S))); + end if; + end; + + -- Generic formal subprograms or AST_Handler renaming + + else + Rewrite (N, Body_Node); + Analyze (N); + Set_Etype (New_S, Base_Type (Etype (New_S))); + end if; if Is_Compilation_Unit (New_S) then Error_Msg_N ("a library unit can only rename another library unit", N); end if; - Set_Etype (New_S, Base_Type (Etype (New_S))); - -- We suppress elaboration warnings for the resulting entity, since -- clearly they are not needed, and more particularly, in the case -- of a generic formal subprogram, the resulting entity can appear @@ -2502,7 +2587,10 @@ package body Sem_Ch8 is if Nkind (Parent (N)) /= N_Compilation_Unit then return; - elsif Scope (Old_E) /= Standard_Standard + -- Check for library unit. Note that we used to check for the scope + -- being Standard here, but that was wrong for Standard itself. + + elsif not Is_Compilation_Unit (Old_E) and then not Is_Child_Unit (Old_E) then Error_Msg_N ("renamed unit must be a library unit", Name (N)); @@ -3276,7 +3364,7 @@ package body Sem_Ch8 is -- Another special check if N is the prefix of a selected -- component which is a known unit, add message complaining - -- about missingw with for this unit. + -- about missing with for this unit. elsif Nkind (Parent (N)) = N_Selected_Component and then N = Prefix (Parent (N)) @@ -3735,6 +3823,7 @@ package body Sem_Ch8 is else Generate_Reference (E, N); + Check_Nested_Access (E); end if; -- Set Entity, with style check if need be. For a discriminant @@ -4029,8 +4118,10 @@ package body Sem_Ch8 is -- we assume a missing with for the corresponding package. if Is_Known_Unit (N) then - Error_Msg_Node_2 := Selector; - Error_Msg_N ("missing `WITH &.&;`", Prefix (N)); + if not Error_Posted (N) then + Error_Msg_Node_2 := Selector; + Error_Msg_N ("missing `WITH &.&;`", Prefix (N)); + end if; -- If this is a selection from a dummy package, then suppress -- the error message, of course the entity is missing if the @@ -5005,8 +5096,27 @@ package body Sem_Ch8 is else Error_Msg_N ("task type cannot be used as type mark " & - "within its own body", N); + "within its own spec or body", N); end if; + + elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then + + -- In Ada 2005, a protected name can be used in an access + -- definition within its own body. + + if Ada_Version >= Ada_05 + and then Nkind (Parent (N)) = N_Access_Definition + then + Set_Entity (N, T_Name); + Set_Etype (N, T_Name); + return; + + else + Error_Msg_N + ("protected type cannot be used as type mark " & + "within its own spec or body", N); + end if; + else Error_Msg_N ("type declaration cannot refer to itself", N); end if; @@ -5151,10 +5261,10 @@ package body Sem_Ch8 is procedure Add_Implicit_Operator (T : Entity_Id; Op_Type : Entity_Id := Empty); - -- Add implicit interpretation to node N, using the type for which - -- a predefined operator exists. If the operator yields a boolean - -- type, the Operand_Type is implicitly referenced by the operator, - -- and a reference to it must be generated. + -- Add implicit interpretation to node N, using the type for which a + -- predefined operator exists. If the operator yields a boolean type, + -- the Operand_Type is implicitly referenced by the operator, and a + -- reference to it must be generated. --------------------------- -- Add_Implicit_Operator -- @@ -5511,101 +5621,6 @@ package body Sem_Ch8 is and then Has_Components (Designated_Type (T)))); end Is_Appropriate_For_Record; - --------------- - -- New_Scope -- - --------------- - - procedure New_Scope (S : Entity_Id) is - E : Entity_Id; - - begin - if Ekind (S) = E_Void then - null; - - -- Set scope depth if not a non-concurrent type, and we have not - -- yet set the scope depth. This means that we have the first - -- occurrence of the scope, and this is where the depth is set. - - elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) - and then not Scope_Depth_Set (S) - then - if S = Standard_Standard then - Set_Scope_Depth_Value (S, Uint_0); - - elsif Is_Child_Unit (S) then - Set_Scope_Depth_Value (S, Uint_1); - - elsif not Is_Record_Type (Current_Scope) then - if Ekind (S) = E_Loop then - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); - else - Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); - end if; - end if; - end if; - - Scope_Stack.Increment_Last; - - declare - SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); - - begin - SST.Entity := S; - SST.Save_Scope_Suppress := Scope_Suppress; - SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last; - - if Scope_Stack.Last > Scope_Stack.First then - SST.Component_Alignment_Default := Scope_Stack.Table - (Scope_Stack.Last - 1). - Component_Alignment_Default; - end if; - - SST.Last_Subprogram_Name := null; - SST.Is_Transient := False; - SST.Node_To_Be_Wrapped := Empty; - SST.Pending_Freeze_Actions := No_List; - SST.Actions_To_Be_Wrapped_Before := No_List; - SST.Actions_To_Be_Wrapped_After := No_List; - SST.First_Use_Clause := Empty; - SST.Is_Active_Stack_Base := False; - SST.Previous_Visibility := False; - end; - - if Debug_Flag_W then - Write_Str ("--> new scope: "); - Write_Name (Chars (Current_Scope)); - Write_Str (", Id="); - Write_Int (Int (Current_Scope)); - Write_Str (", Depth="); - Write_Int (Int (Scope_Stack.Last)); - Write_Eol; - end if; - - -- Copy from Scope (S) the categorization flags to S, this is not - -- done in case Scope (S) is Standard_Standard since propagation - -- is from library unit entity inwards. - - if S /= Standard_Standard - and then Scope (S) /= Standard_Standard - and then not Is_Child_Unit (S) - then - E := Scope (S); - - if Nkind (E) not in N_Entity then - return; - end if; - - -- We only propagate inwards for library level entities, - -- inner level subprograms do not inherit the categorization. - - if Is_Library_Level_Entity (S) then - Set_Is_Preelaborated (S, Is_Preelaborated (E)); - Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); - Set_Categorization_From_Scope (E => S, Scop => E); - end if; - end if; - end New_Scope; - ------------------------ -- Note_Redundant_Use -- ------------------------ @@ -5832,6 +5847,109 @@ package body Sem_Ch8 is Scope_Stack.Decrement_Last; end Pop_Scope; + --------------- + -- Push_Scope -- + --------------- + + procedure Push_Scope (S : Entity_Id) is + E : Entity_Id; + + begin + if Ekind (S) = E_Void then + null; + + -- Set scope depth if not a non-concurrent type, and we have not + -- yet set the scope depth. This means that we have the first + -- occurrence of the scope, and this is where the depth is set. + + elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) + and then not Scope_Depth_Set (S) + then + if S = Standard_Standard then + Set_Scope_Depth_Value (S, Uint_0); + + elsif Is_Child_Unit (S) then + Set_Scope_Depth_Value (S, Uint_1); + + elsif not Is_Record_Type (Current_Scope) then + if Ekind (S) = E_Loop then + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); + else + Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); + end if; + end if; + end if; + + Scope_Stack.Increment_Last; + + declare + SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); + + begin + SST.Entity := S; + SST.Save_Scope_Suppress := Scope_Suppress; + SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last; + + if Scope_Stack.Last > Scope_Stack.First then + SST.Component_Alignment_Default := Scope_Stack.Table + (Scope_Stack.Last - 1). + Component_Alignment_Default; + end if; + + SST.Last_Subprogram_Name := null; + SST.Is_Transient := False; + SST.Node_To_Be_Wrapped := Empty; + SST.Pending_Freeze_Actions := No_List; + SST.Actions_To_Be_Wrapped_Before := No_List; + SST.Actions_To_Be_Wrapped_After := No_List; + SST.First_Use_Clause := Empty; + SST.Is_Active_Stack_Base := False; + SST.Previous_Visibility := False; + end; + + if Debug_Flag_W then + Write_Str ("--> new scope: "); + Write_Name (Chars (Current_Scope)); + Write_Str (", Id="); + Write_Int (Int (Current_Scope)); + Write_Str (", Depth="); + Write_Int (Int (Scope_Stack.Last)); + Write_Eol; + end if; + + -- Deal with copying flags from the previous scope to this one. This + -- is not necessary if either scope is standard, or if the new scope + -- is a child unit. + + if S /= Standard_Standard + and then Scope (S) /= Standard_Standard + and then not Is_Child_Unit (S) + then + E := Scope (S); + + if Nkind (E) not in N_Entity then + return; + end if; + + -- Copy categorization flags from Scope (S) to S, this is not done + -- when Scope (S) is Standard_Standard since propagation is from + -- library unit entity inwards. Copy other relevant attributes as + -- well (Discard_Names in particular). + + -- We only propagate inwards for library level entities, + -- inner level subprograms do not inherit the categorization. + + if Is_Library_Level_Entity (S) then + Set_Is_Preelaborated (S, Is_Preelaborated (E)); + Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); + Set_Discard_Names (S, Discard_Names (E)); + Set_Suppress_Value_Tracking_On_Call + (S, Suppress_Value_Tracking_On_Call (E)); + Set_Categorization_From_Scope (E => S, Scop => E); + end if; + end if; + end Push_Scope; + --------------------- -- Premature_Usage -- --------------------- @@ -5897,7 +6015,7 @@ package body Sem_Ch8 is function Present_System_Aux (N : Node_Id := Empty) return Boolean is Loc : Source_Ptr; - Aux_Name : Name_Id; + Aux_Name : Unit_Name_Type; Unum : Unit_Number_Type; Withn : Node_Id; With_Sys : Node_Id; @@ -6104,11 +6222,11 @@ package body Sem_Ch8 is end if; if Is_Child_Unit (S) - and not In_Child -- check only for current unit. + and not In_Child -- check only for current unit then In_Child := True; - -- restore visibility of parents according to whether the child + -- Restore visibility of parents according to whether the child -- is private and whether we are in its visible part. Comp_Unit := Parent (Unit_Declaration_Node (S)); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index af50d9cae4d..b2141d7cce4 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2007, 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- -- @@ -26,6 +26,7 @@ with Alloc; with Atree; use Atree; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Code; use Exp_Code; @@ -119,6 +120,377 @@ package body Sem_Warn is end if; end Check_Code_Statement; + --------------------------------- + -- Check_Infinite_Loop_Warning -- + --------------------------------- + + -- The case we look for is a while loop which tests a local variable, where + -- there is no obvious direct or possible indirect update of the variable + -- within the body of the loop. + + 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. + + 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. + + function Has_Indirection (T : Entity_Id) return Boolean; + -- If the controlling variable is an access type, or is a record type + -- with access components, assume that it is changed indirectly and + -- suppress the warning. As a concession to low-level programming, in + -- particular within Declib, we also suppress warnings on a record + -- type that contains components of type Address or Short_Address. + + function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean; + -- Given an entity name, see if the name appears to have something to + -- do with I/O or network stuff, and if so, return True. Used to kill + -- some false positives on a heuristic basis that such functions will + -- likely have some strange side effect dependencies. A rather funny + -- kludge, but warning messages are in the heuristics business. + + function Test_Ref (N : Node_Id) return Traverse_Result; + -- Test for reference to variable in question. Returns Abandon if + -- matching reference found. + + function Find_Ref is new Traverse_Func (Test_Ref); + -- Function to traverse body of procedure. Returns Abandon if matching + -- reference found. + + -------------- + -- Find_Var -- + -------------- + + procedure Find_Var (N : Node_Id) is + begin + -- Condition is a direct variable reference + + if Is_Entity_Name (N) then + Ref := N; + Var := Entity (Ref); + + -- Case of condition is a comparison with compile time known value + + elsif Nkind (N) in N_Op_Compare then + if Compile_Time_Known_Value (Right_Opnd (N)) then + Find_Var (Left_Opnd (N)); + + elsif Compile_Time_Known_Value (Left_Opnd (N)) then + Find_Var (Right_Opnd (N)); + + -- Ignore any other comparison + + else + return; + end if; + + -- If condition is a negation, check its operand + + elsif Nkind (N) = N_Op_Not then + Find_Var (Right_Opnd (N)); + + -- Case of condition is function call + + elsif Nkind (N) = N_Function_Call then + + -- Forget it if function name is not entity, who knows what + -- we might be calling? + + if not Is_Entity_Name (Name (N)) then + return; + + -- Forget it if warnings are suppressed on function entity + + elsif Warnings_Off (Entity (Name (N))) then + return; + + -- Forget it if function name is suspicious. A strange test + -- but warning generation is in the heuristics business! + + elsif Is_Suspicious_Function_Name (Entity (Name (N))) then + return; + end if; + + -- OK, see if we have one argument + + declare + PA : constant List_Id := Parameter_Associations (N); + + begin + -- One argument, so check the argument + + if Present (PA) + and then List_Length (PA) = 1 + then + if Nkind (First (PA)) = N_Parameter_Association then + Find_Var (Explicit_Actual_Parameter (First (PA))); + else + Find_Var (First (PA)); + end if; + + -- Not one argument + + else + return; + end if; + end; + + -- Any other kind of node is not something we warn for + + else + return; + end if; + end Find_Var; + + --------------------- + -- Has_Indirection -- + --------------------- + + function Has_Indirection (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Rec : Entity_Id; + + begin + if Is_Access_Type (T) then + return True; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Access_Type (Full_View (T)) + then + return True; + + elsif Is_Record_Type (T) then + Rec := T; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Record_Type (Full_View (T)) + then + Rec := Full_View (T); + else + return False; + end if; + + Comp := First_Component (Rec); + while Present (Comp) loop + if Is_Access_Type (Etype (Comp)) + or else Is_Descendent_Of_Address (Etype (Comp)) + then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Indirection; + + --------------------------------- + -- Is_Suspicious_Function_Name -- + --------------------------------- + + function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean is + S : Entity_Id; + + function Substring_Present (S : String) return Boolean; + -- Returns True if name buffer has given string delimited by non- + -- alphabetic characters or by end of string. S is lower case. + + ----------------------- + -- Substring_Present -- + ----------------------- + + function Substring_Present (S : String) return Boolean is + Len : constant Natural := S'Length; + + begin + for J in 1 .. Name_Len - (Len - 1) loop + if Name_Buffer (J .. J + (Len - 1)) = S + and then + (J = 1 + or else Name_Buffer (J - 1) not in 'a' .. 'z') + and then + (J + Len > Name_Len + or else Name_Buffer (J + Len) not in 'a' .. 'z') + then + return True; + end if; + end loop; + + return False; + end Substring_Present; + + -- Start of processing for Is_Suspicious_Function_Name + + begin + S := E; + while Present (S) and then S /= Standard_Standard loop + Get_Name_String (Chars (S)); + + if Substring_Present ("io") + or else Substring_Present ("file") + or else Substring_Present ("network") + then + return True; + else + S := Scope (S); + end if; + end loop; + + return False; + end Is_Suspicious_Function_Name; + + -------------- + -- Test_Ref -- + -------------- + + function Test_Ref (N : Node_Id) return Traverse_Result is + begin + -- Waste of time to look at iteration scheme + + if N = Iter then + return Skip; + + -- Direct reference to variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Entity (N) = Var + then + -- If this is an Lvalue, then definitely abandon, since + -- this could be a direct modification of the variable. + + if May_Be_Lvalue (N) then + return Abandon; + end if; + + -- If we appear in the context of a procedure call, then also + -- abandon, since there may be issues of non-visible side + -- effects going on in the call. + + declare + P : Node_Id; + begin + P := N; + loop + P := Parent (P); + exit when P = Loop_Statement; + + if Nkind (P) = N_Procedure_Call_Statement then + return Abandon; + end if; + end loop; + end; + + -- Reference to variable renaming variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Present (Renamed_Object (Entity (N))) + and then Is_Entity_Name (Renamed_Object (Entity (N))) + and then Entity (Renamed_Object (Entity (N))) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Call to subprogram + + 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 not Is_Entity_Name (Name (N)) + or else Scope_Within (Entity (Name (N)), Scope (Var)) + then + return Abandon; + end if; + end if; + + -- All OK, continue scan + + return OK; + end Test_Ref; + + -- Start of processing for Check_Infinite_Loop_Warning + + begin + -- We need a while iteration with no condition actions. Conditions + -- actions just make things too complicated to get the warning right. + + if No (Iter) + or else No (Condition (Iter)) + or else Present (Condition_Actions (Iter)) + or else Debug_Flag_Dot_W + then + return; + end if; + + -- Initial conditions met, see if condition is of right form + + Find_Var (Condition (Iter)); + + -- Nothing to do if local variable from source not found + + if No (Var) + or else Ekind (Var) /= E_Variable + or else Is_Library_Level_Entity (Var) + or else not Comes_From_Source (Var) + then + return; + + -- Nothing to do if there is some indirection involved (assume that the + -- designated variable might be modified in some way we don't see). + + elsif Has_Indirection (Etype (Var)) then + return; + + -- Same sort of thing for volatile variable, might be modified by + -- some other task or by the operating system in some way. + + elsif Is_Volatile (Var) then + return; + end if; + + -- Filter out case of original statement sequence starting with delay. + -- We assume this is a multi-tasking program and that the condition + -- is affected by other threads (some kind of busy wait). + + declare + Fstm : constant Node_Id := + Original_Node (First (Statements (Loop_Statement))); + begin + if Nkind (Fstm) = N_Delay_Relative_Statement + or else Nkind (Fstm) = N_Delay_Until_Statement + then + return; + end if; + end; + + -- We have a variable reference of the right form, now we scan the loop + -- body to see if it looks like it might not be modified + + if Find_Ref (Loop_Statement) = OK then + Error_Msg_NE + ("variable& is not modified in loop body?", Ref, Var); + Error_Msg_N + ("\possible infinite loop", Ref); + end if; + end Check_Infinite_Loop_Warning; + ---------------------- -- Check_References -- ---------------------- @@ -334,10 +706,14 @@ package body Sem_Warn is E1 := First_Entity (E); while Present (E1) loop - -- We only look at source entities with warning flag on - - if Comes_From_Source (E1) and then not Warnings_Off (E1) then + -- We only look at source entities with warning flag on. We also + -- ignore objects whose type or base type has warnings suppressed. + if Comes_From_Source (E1) + and then not Warnings_Off (E1) + 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. @@ -629,6 +1005,14 @@ package body Sem_Warn is and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit or else Get_Source_Unit (E1) = Main_Unit) + + -- No warning on a return object, because these are often + -- created with a single expression and an implicit return. + -- If the object is a variable there will be a warning + -- indicating that it could be declared constant. + + and then not + (Ekind (E1) = E_Constant and then Is_Return_Object (E1)) then -- Suppress warnings in internal units if not in -gnatg mode -- (these would be junk warnings for an applications program, @@ -870,7 +1254,7 @@ package body Sem_Warn is return; end if; - -- We are only interested in deferences + -- We are only interested in dereferences if not Is_Dereferenced (N) then return; @@ -1741,6 +2125,18 @@ package body Sem_Warn is function Set_Dot_Warning_Switch (C : Character) return Boolean is begin case C is + when 'c' => + Warn_On_Unrepped_Components := True; + + when 'C' => + Warn_On_Unrepped_Components := False; + + when 'r' => + Warn_On_Object_Renames_Function := True; + + when 'R' => + Warn_On_Object_Renames_Function := False; + when 'x' => Warn_On_Non_Local_Exception := True; @@ -1779,8 +2175,10 @@ package body Sem_Warn is Warn_On_Obsolescent_Feature := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; + Warn_On_Object_Renames_Function := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := True; when 'A' => Check_Unreferenced := False; @@ -1803,8 +2201,10 @@ package body Sem_Warn is Warn_On_Obsolescent_Feature := False; Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; + Warn_On_Object_Renames_Function := False; Warn_On_Unchecked_Conversion := False; Warn_On_Unrecognized_Pragma := False; + Warn_On_Unrepped_Components := False; when 'b' => Warn_On_Bad_Fixed_Value := True; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index efc747cf9c3..86c36a96577 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2007, 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- -- @@ -120,7 +120,11 @@ package Sem_Warn is ---------------------------- procedure Check_Code_Statement (N : Node_Id); - -- Peform warning checks on a code statement node + -- Perform warning checks on a code statement node + + procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); + -- N is the node for a loop statement. This procedure checks if a warning + -- should be given for a possible infinite loop, and if so issues it. procedure Warn_On_Known_Condition (C : Node_Id); -- C is a node for a boolean expression resluting from a relational