mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-31 15:31:11 +08:00
Code Issues Packages Projects Releases Wiki Activity

g-comlin.ads, [...]: Add new warning for renaming of function return objects

Browse Source 
2007-04-20  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* 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
This commit is contained in:
Robert Dewar 2007-06-06 12:29:05 +02:00 committed by Arnaud Charlet
parent f24f72e892
commit fbe627afbd
7 changed files with 743 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/g-comlin.adb
View File

@ -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

3
gcc/ada/g-comlin.ads
View File

@ -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;

30
gcc/ada/opt.adb
View File

@ -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;

75
gcc/ada/opt.ads
View File

@ -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;

366
gcc/ada/sem_ch8.adb
View File

@ -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));

410
gcc/ada/sem_warn.adb
View File

@ -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;

8
gcc/ada/sem_warn.ads
View File

@ -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