+2009-04-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch9.adb: Comment improvements.
+ (Build_Entry_Family_Name): Add parentheses around the index of a entry
+ family member.
+
+2009-04-15 Bob Duff <duff@adacore.com>
+
+ * sem_warn.adb (Check_Infinite_Loop_Warning): Catch cases like
+ "while X /= null loop" where X is unchanged inside the loop. We were
+ not warning in this case, because of the pointers -- we feared that the
+ loop variable could be updated via a pointer, if there are any pointers
+ around the place. But that is impossible in this case.
+
+ * sem_util.adb (May_Be_Lvalue): This routine was overly pessimistic in
+ the case of dereferences. In X.all, X cannot be an l-value. We now
+ catch that case (and implicit dereferences, too).
+
+2009-04-15 Vincent Celier <celier@adacore.com>
+
+ * sinput-p.ads, sinput-p.adb (Clear_Source_File_Table): New procedure
+
+2009-04-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Is_Actual_Of_Previous_Formal): Make fully recursive.
+ From code reading.
+ (Analyze_Package_Instantiation): If generic unit in child instance is
+ the same as generic unit in parent instance, look for an outer homonym
+ to locate the desired generic.
+
2009-04-15 Bob Duff <duff@adacore.com>
* sem_ch5.adb (Analyze_Loop_Statement): Don't check for infinite loop
-- for Lnn in Family_Low .. Family_High loop
-- Inn := Inn + 1;
-- Set_Entry_Name
- -- (_init._object, Inn, new String ("<Entry name> " & Lnn'Img));
- -- _init._task_id
+ -- (_init._object <or> _init._task_id,
+ -- Inn,
+ -- new String ("<Entry name>(" & Lnn'Img & ")"));
-- end loop;
-- Note that the bounds of the range may reference discriminants. The
-- above construct is added directly to the statements of the block.
procedure Build_Entry_Name (Id : Entity_Id);
-- Generate:
-- Inn := Inn + 1;
- -- Set_Entry_Name (_init._task_id, Inn, new String ("<Entry name>");
- -- _init._object
+ -- Set_Entry_Name
+ -- (_init._object <or>_init._task_id,
+ -- Inn,
+ -- new String ("<Entry name>");
-- The above construct is added directly to the statements of the block.
function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
begin
Get_Name_String (Chars (Id));
- if Is_Enumeration_Type (Etype (Def)) then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ' ';
- end if;
+ -- Add a leading '('
+
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := '(';
-- Generate:
- -- new String'("<Entry name>" & Lnn'Img);
+ -- new String'("<Entry name>(" & Lnn'Img & ")");
-- This is an implicit heap allocation, and Comes_From_Source is
-- False, which ensures that it will get flagged as a violation of
Expression =>
Make_Op_Concat (Loc,
Left_Opnd =>
- Make_String_Literal (Loc,
- String_From_Name_Buffer),
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (L_Id, Loc),
+ Attribute_Name => Name_Img)),
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (L_Id, Loc),
- Attribute_Name => Name_Img))));
+ Make_String_Literal (Loc,
+ Strval => ")"))));
Increment_Index (L_Stmts);
Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
-- Generate:
-- for Lnn in Family_Low .. Family_High loop
-- Inn := Inn + 1;
- -- Set_Entry_Name (_init._task_id, Inn, <Val>);
+ -- Set_Entry_Name
+ -- (_init._object <or> _init._task_id, Inn, <Val>);
-- end loop;
Append_To (B_Stmts,
-- Verify that it is the name of a generic package
+ -- A visibility glitch: if the instance is a child unit and the generic
+ -- is the generic unit of a parent instance (i.e. both the parent and
+ -- the child units are instances of the same package) the name now
+ -- denotes the renaming within the parent, not the intended generic
+ -- unit. See if there is a homonym that is the desired generic. The
+ -- renaming declaration must be visible inside the instance of the
+ -- child, but not when analyzing the name in the instantiation itself.
+
+ if Ekind (Gen_Unit) = E_Package
+ and then Present (Renamed_Entity (Gen_Unit))
+ and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
+ and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
+ and then Present (Homonym (Gen_Unit))
+ then
+ Gen_Unit := Homonym (Gen_Unit);
+ end if;
+
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
return;
function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
-- The package in question may be an actual for a previous formal
-- package P of the current instance, so examine its actuals as well.
+ -- This must be recursive over other formal packages.
----------------------------------
-- Is_Actual_Of_Previous_Formal --
E1 : Entity_Id;
begin
- E1 := First_Entity (E);
+ E1 := First_Entity (P);
+
while Present (E1) and then E1 /= Instance loop
if Ekind (E1) = E_Package
and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
if Renamed_Object (E1) = Pack then
return True;
- elsif Renamed_Object (E1) = P then
+ elsif E1 = P
+ or else Renamed_Object (E1) = P
+ then
return False;
+
+ elsif Is_Actual_Of_Previous_Formal (E1) then
+ return True;
end if;
end if;
when N_Assignment_Statement =>
return N = Name (P);
- -- Test prefix of component or attribute
+ -- Test prefix of component or attribute. Note that the prefix of an
+ -- explicit or implicit dereference cannot be an l-value.
when N_Attribute_Reference =>
return N = Prefix (P)
and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
when N_Expanded_Name |
- N_Explicit_Dereference |
N_Indexed_Component |
- N_Reference |
N_Selected_Component |
N_Slice =>
- return N = Prefix (P);
+ if Is_Access_Type (Etype (N)) then
+ return False; -- P is an implicit dereference
+ else
+ return N = Prefix (P);
+ end if;
+
+ when N_Reference =>
+ return N = Prefix (P);
+
+ when N_Explicit_Dereference =>
+ return False;
-- Function call arguments are never lvalues
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.
+ -- Reference in iteration scheme to variable that might not be modified
+ -- in loop, indicating a possible infinite loop.
Var : Entity_Id := Empty;
-- Corresponding entity (entity of Ref)
+ Function_Call_Found : Boolean := False;
+ -- True if Find_Var found a function call in the condition
+
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
elsif Nkind (N) = N_Function_Call then
+ Function_Call_Found := True;
+
-- Forget it if function name is not entity, who knows what
-- we might be calling?
-- Nothing to do if there is some indirection involved (assume that the
-- designated variable might be modified in some way we don't see).
+ -- However, if no function call was found, then we don't care about
+ -- indirections, because the condition must be something like "while X
+ -- /= null loop", so we don't care if X.all is modified in the loop.
- elsif Has_Indirection (Etype (Var)) then
+ elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then
return;
-- Same sort of thing for volatile variable, might be modified by
-- --
------------------------------------------------------------------------------
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
with Prj.Err;
with Sinput.C;
+with System;
+
package body Sinput.P is
First : Boolean := True;
-- The flag is reset to False at the first call to Load_Project_File.
-- Calling Reset_First sets it back to True.
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Lines_Table_Type, Lines_Table_Ptr);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
+
+ -----------------------------
+ -- Clear_Source_File_Table --
+ -----------------------------
+
+ procedure Clear_Source_File_Table is
+ use System;
+ begin
+ for X in 1 .. Source_File.Last loop
+ declare
+ S : Source_File_Record renames Source_File.Table (X);
+ Lo : constant Source_Ptr := S.Source_First;
+ Hi : constant Source_Ptr := S.Source_Last;
+ subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+ -- Physical buffer allocated
+
+ type Actual_Source_Ptr is access Actual_Source_Buffer;
+ -- This is the pointer type for the physical buffer allocated
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Actual_Source_Buffer, Actual_Source_Ptr);
+
+ pragma Suppress (All_Checks);
+
+ pragma Warnings (Off);
+ -- The following unchecked conversion is aliased safe, since it
+ -- is not used to create improperly aliased pointer values.
+
+ function To_Actual_Source_Ptr is new
+ Ada.Unchecked_Conversion (Address, Actual_Source_Ptr);
+
+ Actual_Ptr : Actual_Source_Ptr :=
+ To_Actual_Source_Ptr (S.Source_Text (Lo)'Address);
+
+ begin
+ Free (Actual_Ptr);
+ Free (S.Lines_Table);
+ Free (S.Logical_Lines_Table);
+ end;
+ end loop;
+
+ Source_File.Free;
+ Source_File.Init;
+ end Clear_Source_File_Table;
+
-----------------------
-- Load_Project_File --
-----------------------
package Sinput.P is
+ procedure Clear_Source_File_Table;
+ -- This procedure frees memory allocated in the Source_File table (in the
+ -- private part of package Sinput). It should only be used when it is
+ -- guaranteed that all source files that have been loaded so far will not
+ -- be accessed before being reloaded. It is intended for tools that parse
+ -- several times sources, to avoid memory leaks.
+
function Load_Project_File (Path : String) return Source_File_Index;
-- Load the source of a project source file into memory and initialize the
-- Scans state.
projects / platform / upstream / gcc.git / commitdiff