-- --
-- 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- --
------------------------------------------------------------------------------
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
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;
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
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;
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);
exit when Iterator.Maximum_Depth = Max_Depth;
end if;
end loop;
-
end Start_Expansion;
begin
-- --
-- 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- --
Maximum_Depth : Depth := 1;
-- The maximum depth of directories, reflecting the number of directory
-- separators in the pattern.
-
end record;
end GNAT.Command_Line;
-- --
-- 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- --
package body Opt is
+ SU : constant := Storage_Unit;
+ -- Shorthand for System.Storage_Unit
+
----------------------------------
-- Register_Opt_Config_Switches --
----------------------------------
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);
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;
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));
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;
-- --
-- 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- --
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
-- 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,
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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 --
----------------------------
-- 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
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;
-- --
-- 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- --
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
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.
-- 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)
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.
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;
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);
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;
-- for it at the freezing point.
Set_Corresponding_Spec (N, Rename_Spec);
+
if Nkind (Unit_Declaration_Node (Rename_Spec)) =
N_Abstract_Subprogram_Declaration
then
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);
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
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));
-- 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))
else
Generate_Reference (E, N);
+ Check_Nested_Access (E);
end if;
-- Set Entity, with style check if need be. For a discriminant
-- 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
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;
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 --
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 --
------------------------
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 --
---------------------
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;
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));
-- --
-- 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- --
with Alloc;
with Atree; use Atree;
+with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Code; use Exp_Code;
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 --
----------------------
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.
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,
return;
end if;
- -- We are only interested in deferences
+ -- We are only interested in dereferences
if not Is_Dereferenced (N) then
return;
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;
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;
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;
-- --
-- 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- --
----------------------------
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
projects / gcc.git / commitdiff