[multiple changes]

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.

From-SVN: r146112

gcc/ada/ChangeLog

+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

gcc/ada/exp_ch9.adb

@@ -1132,8 +1132,9 @@ package body Exp_Ch9 is
       --    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.
@@ -1141,8 +1142,10 @@ package body Exp_Ch9 is
       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;
@@ -1213,13 +1216,13 @@ package body Exp_Ch9 is
       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
@@ -1233,13 +1236,18 @@ package body Exp_Ch9 is
                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));
@@ -1247,7 +1255,8 @@ package body Exp_Ch9 is
          --  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,

gcc/ada/sem_ch12.adb

@@ -2957,6 +2957,23 @@ package body Sem_Ch12 is
 
       --  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;
@@ -6145,6 +6162,7 @@ package body Sem_Ch12 is
       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 --
@@ -6154,7 +6172,8 @@ package body Sem_Ch12 is
          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
@@ -6162,8 +6181,13 @@ package body Sem_Ch12 is
                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;
 

gcc/ada/sem_util.adb

@@ -7224,19 +7224,28 @@ package body Sem_Util is
          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
 

gcc/ada/sem_warn.adb

@@ -236,12 +236,15 @@ package body Sem_Warn 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.
+      --  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
@@ -305,6 +308,8 @@ package body Sem_Warn is
 
          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?
 
@@ -570,8 +575,11 @@ package body Sem_Warn is
 
       --  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

gcc/ada/sinput-p.adb

@@ -23,9 +23,14 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
 with Prj.Err;
 with Sinput.C;
 
+with System;
+
 package body Sinput.P is
 
    First : Boolean := True;
@@ -34,6 +39,56 @@ package body Sinput.P is
    --  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 --
    -----------------------

gcc/ada/sinput-p.ads

@@ -31,6 +31,13 @@ with Scans; use Scans;
 
 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.