[multiple changes]

2009-04-29  Bob Duff  <duff@adacore.com>

	* exp_ch7.adb (Build_Final_List): For an access type that designates a
	Taft Amendment type, if the access type needs finalization, make sure
	the implicit with clause for List_Controller occurs on the package spec.

	* rtsfind.adb (Text_IO_Kludge): Fine tune the creation of implicit
	with's created for the pseudo-children of Text_IO and friends. In
	particular, avoid cycles, such as Ada.Wide_Text_IO.Integer_IO and
	Ada.Text_IO.Integer_IO both with-ing each other.

	* sem.adb (Walk_Library_Items): Suppress assertion failure in certain
	oddball cases when pragma Extend_System is used.

	* sem_ch12.adb (Get_Associated_Node): Prevent direct 'with' cycles in
	the case where a package spec instantiates a generic whose body with's
	this package, so Walk_Library_Items won't complain about cyclic with's.

2009-04-29  Emmanuel Briot  <briot@adacore.com>

	* gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads,
	prj-pp.adb, prj-pp.ads, makeutl.adb, clean.adb, prj-nmsc.adb,
	mlib-tgt.adb, mlib-tgt.ads, prj-util.adb, prj-env.adb, prj-env.ads
	(Project_Id): now a real pointer to Project_Data, instead of an index
	into the Projects_Table. This simplifies the API significantly, avoiding
	extra lookups in this table and the need to pass the Project_Tree_Ref
	parameter in several cases

From-SVN: r146931

gcc/ada/ChangeLog

+2009-04-29  Bob Duff  <duff@adacore.com>
+
+	* exp_ch7.adb (Build_Final_List): For an access type that designates a
+	Taft Amendment type, if the access type needs finalization, make sure
+	the implicit with clause for List_Controller occurs on the package spec.
+
+	* rtsfind.adb (Text_IO_Kludge): Fine tune the creation of implicit
+	with's created for the pseudo-children of Text_IO and friends. In
+	particular, avoid cycles, such as Ada.Wide_Text_IO.Integer_IO and
+	Ada.Text_IO.Integer_IO both with-ing each other.
+
+	* sem.adb (Walk_Library_Items): Suppress assertion failure in certain
+	oddball cases when pragma Extend_System is used.
+
+	* sem_ch12.adb (Get_Associated_Node): Prevent direct 'with' cycles in
+	the case where a package spec instantiates a generic whose body with's
+	this package, so Walk_Library_Items won't complain about cyclic with's.
+
+2009-04-29  Emmanuel Briot  <briot@adacore.com>
+
+	* gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads,
+	prj-pp.adb, prj-pp.ads, makeutl.adb, clean.adb, prj-nmsc.adb,
+	mlib-tgt.adb, mlib-tgt.ads, prj-util.adb, prj-env.adb, prj-env.ads
+	(Project_Id): now a real pointer to Project_Data, instead of an index
+	into the Projects_Table. This simplifies the API significantly, avoiding
+	extra lookups in this table and the need to pass the Project_Tree_Ref
+	parameter in several cases
+
 2009-04-29  Nicolas Setton  <setton@adacore.com>
 
 	* gcc-interface/Makefile.in: Produce .dSYM files for shared libs on

gcc/ada/exp_ch7.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -442,6 +442,37 @@ package body Exp_Ch7 is
             New_Reference_To
               (RTE (RE_List_Controller), Loc));
 
+      if Has_Completion_In_Body (Directly_Designated_Type (Typ))
+        and then In_Package_Body (Current_Scope)
+        and then
+          Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification
+      then
+         --  The type is declared in a package declaration and designates a
+         --  Taft amendment type that requires finalization. In general we
+         --  assume that TA types are controlled, but we inhibit this
+         --  worst-case assumption for runtime files, for efficiency reasons
+         --  (see exp_ch3.adb). The reference to RE_List_Controller may have
+         --  added a with_clause to the current body. Formally the spec needs
+         --  the with_clause as well, so we add it now, for use by codepeer.
+
+         declare
+            Loc         : constant Source_Ptr := Sloc (Typ);
+            Spec_Unit   : constant Node_Id :=
+                            Library_Unit (Cunit (Current_Sem_Unit));
+            List_Scope  : constant Entity_Id :=
+                            Scope (RTE (RE_List_Controller));
+            With_Clause : constant Node_Id :=
+                            Make_With_Clause (Loc,
+                              Name => New_Occurrence_Of (List_Scope, Loc));
+         begin
+            Set_Library_Unit
+              (With_Clause, Parent (Unit_Declaration_Node (List_Scope)));
+            Set_Corresponding_Spec (With_Clause, List_Scope);
+            Set_Implicit_With (With_Clause);
+            Append (With_Clause, Context_Items (Spec_Unit));
+         end;
+      end if;
+
       --  The type may have been frozen already, and this is a late freezing
       --  action, in which case the declaration must be elaborated at once.
       --  If the call is for an allocator, the chain must also be created now,

gcc/ada/makeutl.adb

@@ -373,7 +373,6 @@ package body Makeutl is
       procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean) is
          pragma Unreferenced (Dummy);
 
-         Data           : Project_Data renames In_Tree.Projects.Table (Proj);
          Linker_Package : Package_Id;
          Options        : Variable_Value;
 
@@ -381,7 +380,7 @@ package body Makeutl is
          Linker_Package :=
            Prj.Util.Value_Of
              (Name        => Name_Linker,
-              In_Packages => Data.Decl.Packages,
+              In_Packages => Proj.Decl.Packages,
               In_Tree     => In_Tree);
 
          Options :=
@@ -412,20 +411,21 @@ package body Makeutl is
    begin
       Linker_Opts.Init;
 
-      For_All_Projects (Project, In_Tree, Dummy, Imported_First => True);
+      For_All_Projects (Project, Dummy, Imported_First => True);
 
       Last_Linker_Option := 0;
 
       for Index in reverse 1 .. Linker_Opts.Last loop
          declare
-            Options : String_List_Id := Linker_Opts.Table (Index).Options;
+            Options : String_List_Id;
             Proj    : constant Project_Id :=
                         Linker_Opts.Table (Index).Project;
             Option  : Name_Id;
             Dir_Path : constant String :=
-              Get_Name_String (In_Tree.Projects.Table (Proj).Directory.Name);
+                         Get_Name_String (Proj.Directory.Name);
 
          begin
+            Options := Linker_Opts.Table (Index).Options;
             while Options /= Nil_String loop
                Option := In_Tree.String_Elements.Table (Options).Value;
                Get_Name_String (Option);
@@ -444,8 +444,7 @@ package body Makeutl is
                      Including_L_Switch => True);
                end if;
 
-               Options :=
-                 In_Tree.String_Elements.Table (Options).Next;
+               Options := In_Tree.String_Elements.Table (Options).Next;
             end loop;
          end;
       end loop;

gcc/ada/mlib-tgt.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 2001-2008, AdaCore                     --
+--                     Copyright (C) 2001-2009, 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- --
@@ -330,8 +330,9 @@ package body MLib.Tgt is
    function Library_Exists_For_Default
      (Project : Project_Id; In_Tree : Project_Tree_Ref) return Boolean
    is
+      pragma Unreferenced (In_Tree);
    begin
-      if not In_Tree.Projects.Table (Project).Library then
+      if not Project.Library then
          Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
                        "for non library project");
          return False;
@@ -339,14 +340,12 @@ package body MLib.Tgt is
       else
          declare
             Lib_Dir  : constant String :=
-                         Get_Name_String
-                           (In_Tree.Projects.Table (Project).Library_Dir.Name);
+                         Get_Name_String (Project.Library_Dir.Name);
             Lib_Name : constant String :=
-                         Get_Name_String
-                           (In_Tree.Projects.Table (Project).Library_Name);
+                         Get_Name_String (Project.Library_Name);
 
          begin
-            if In_Tree.Projects.Table (Project).Library_Kind = Static then
+            if Project.Library_Kind = Static then
                return Is_Regular_File
                  (Lib_Dir & Directory_Separator & "lib" &
                   Fil.Append_To (Lib_Name, Archive_Ext));
@@ -380,8 +379,9 @@ package body MLib.Tgt is
      (Project : Project_Id;
       In_Tree : Project_Tree_Ref) return File_Name_Type
    is
+      pragma Unreferenced (In_Tree);
    begin
-      if not In_Tree.Projects.Table (Project).Library then
+      if not Project.Library then
          Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
                        "for non library project");
          return No_File;
@@ -389,11 +389,10 @@ package body MLib.Tgt is
       else
          declare
             Lib_Name : constant String :=
-                         Get_Name_String
-                           (In_Tree.Projects.Table (Project).Library_Name);
+                         Get_Name_String (Project.Library_Name);
 
          begin
-            if In_Tree.Projects.Table (Project).Library_Kind =
+            if Project.Library_Kind =
                  Static
             then
                Name_Len := 3;

gcc/ada/mlib-tgt.ads

@@ -238,8 +238,7 @@ private
                               Library_Exists_For_Default'Access;
 
    function Library_File_Name_For_Default
-     (Project : Project_Id;
-      In_Tree : Project_Tree_Ref) return File_Name_Type;
+     (Project : Project_Id; In_Tree : Project_Tree_Ref) return File_Name_Type;
    Library_File_Name_For_Ptr : Library_File_Name_For_Function :=
                                  Library_File_Name_For_Default'Access;
 

gcc/ada/prj-env.ads

@@ -166,9 +166,7 @@ package Prj.Env is
 
    generic
       with procedure Action (Path : String);
-   procedure For_All_Object_Dirs
-     (Project : Project_Id;
-      In_Tree : Project_Tree_Ref);
+   procedure For_All_Object_Dirs (Project : Project_Id);
    --  Iterate through all the object directories of a project, including
    --  those of imported or modified projects.
 

gcc/ada/prj-pp.adb

@@ -74,8 +74,7 @@ package body Prj.PP is
       W_Eol                              : Write_Eol_Ap  := null;
       W_Str                              : Write_Str_Ap  := null;
       Backward_Compatibility             : Boolean;
-      Id                                 : Prj.Project_Id := Prj.No_Project;
-      Id_Tree                            : Prj.Project_Tree_Ref := null)
+      Id                                 : Prj.Project_Id := Prj.No_Project)
    is
       procedure Print (Node : Project_Node_Id; Indent : Natural);
       --  A recursive procedure that traverses a project file tree and outputs
@@ -339,7 +338,7 @@ package body Prj.PP is
                   Write_String ("project ");
 
                   if Id /= Prj.No_Project then
-                     Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
+                     Output_Name (Id.Display_Name);
                   else
                      Output_Name (Name_Of (Node, In_Tree));
                   end if;
@@ -372,7 +371,7 @@ package body Prj.PP is
                   Write_String ("end ");
 
                   if Id /= Prj.No_Project then
-                     Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
+                     Output_Name (Id.Display_Name);
                   else
                      Output_Name (Name_Of (Node, In_Tree));
                   end if;

gcc/ada/prj-pp.ads

@@ -53,8 +53,7 @@ package Prj.PP is
       W_Eol                              : Write_Eol_Ap  := null;
       W_Str                              : Write_Str_Ap  := null;
       Backward_Compatibility             : Boolean;
-      Id                                 : Prj.Project_Id := Prj.No_Project;
-      Id_Tree                            : Prj.Project_Tree_Ref := null);
+      Id                                 : Prj.Project_Id := Prj.No_Project);
    --  Output a project file, using either the default output routines, or the
    --  ones specified by W_Char, W_Eol and W_Str.
    --

gcc/ada/prj-util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2001-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2009, 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- --
@@ -114,8 +114,7 @@ package body Prj.Util is
    is
       pragma Assert (Project /= No_Project);
 
-      The_Packages : constant Package_Id :=
-                       In_Tree.Projects.Table (Project).Decl.Packages;
+      The_Packages : constant Package_Id := Project.Decl.Packages;
 
       Builder_Package : constant Prj.Package_Id :=
                           Prj.Util.Value_Of
@@ -135,7 +134,7 @@ package body Prj.Util is
 
       Executable_Suffix_Name : Name_Id := No_Name;
 
-      Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming;
+      Naming : constant Naming_Data := Project.Naming;
 
       Spec_Suffix : Name_Id := No_Name;
       Body_Suffix : Name_Id := No_Name;
@@ -188,8 +187,7 @@ package body Prj.Util is
 
       if Builder_Package /= No_Package then
          if Get_Mode = Multi_Language then
-            Executable_Suffix_Name :=
-              In_Tree.Projects.Table (Project).Config.Executable_Suffix;
+            Executable_Suffix_Name := Project.Config.Executable_Suffix;
 
          else
             Executable_Suffix := Prj.Util.Value_Of
@@ -330,11 +328,9 @@ package body Prj.Util is
             Result     : File_Name_Type;
 
          begin
-            if In_Tree.Projects.Table (Project).Config.Executable_Suffix /=
-              No_Name
-            then
+            if Project.Config.Executable_Suffix /= No_Name then
                Executable_Extension_On_Target :=
-                 In_Tree.Projects.Table (Project).Config.Executable_Suffix;
+                 Project.Config.Executable_Suffix;
             end if;
 
             Result := Executable_Name (Name_Find);

gcc/ada/prj.ads

@@ -160,8 +160,9 @@ package Prj is
 
    No_Path_Information : constant Path_Information := (No_Path, No_Path);
 
-   type Project_Id is new Nat;
-   No_Project : constant Project_Id := 0;
+   type Project_Data;
+   type Project_Id is access Project_Data;
+   No_Project : constant Project_Id := null;
    --  Id of a Project File
 
    type String_List_Id is new Nat;
@@ -323,10 +324,8 @@ package Prj is
    function Hash (Name : Name_Id)        return Header_Num;
    function Hash (Name : File_Name_Type) return Header_Num;
    function Hash (Name : Path_Name_Type) return Header_Num;
-   --  Used for computing hash values for names put into above hash table
-
    function Hash (Project : Project_Id) return Header_Num;
-   --  Used for hash tables where Project_Id is the Key
+   --  Used for computing hash values for names put into above hash table
 
    type Language_Kind is (File_Based, Unit_Based);
    --  Type for the kind of language. All languages are file based, except Ada
@@ -896,8 +895,7 @@ package Prj is
       Suffix   : File_Name_Type);
 
    function Get_Object_Directory
-     (In_Tree             : Project_Tree_Ref;
-      Project             : Project_Id;
+     (Project             : Project_Id;
       Including_Libraries : Boolean;
       Only_If_Ada         : Boolean := False) return Path_Name_Type;
    --  Return the object directory to use for the project. This depends on
@@ -908,13 +906,12 @@ package Prj is
    --  If Only_If_Ada is True, then No_Name will be returned when the project
    --  doesn't Ada sources.
 
-   procedure Compute_All_Imported_Projects
-     (Project : Project_Id; In_Tree : Project_Tree_Ref);
+   procedure Compute_All_Imported_Projects (Project : Project_Id);
    --  Compute, the list of the projects imported directly or indirectly by
    --  project Project. The result is stored in Project.All_Imported_Projects
 
    function Ultimate_Extending_Project_Of
-     (Proj : Project_Id; In_Tree : Project_Tree_Ref) return Project_Id;
+     (Proj : Project_Id) return Project_Id;
    --  Returns the ultimate extending project of project Proj. If project Proj
    --  is not extended, returns Proj.
 
@@ -938,6 +935,14 @@ package Prj is
    end record;
    --  A list of projects
 
+   procedure Free_List
+     (List         : in out Project_List;
+      Free_Project : Boolean;
+      Reset_Only   : Boolean := True);
+   --  Free the list of projects. If Free_Project, each project is also freed.
+   --  When Free_Project is True, Reset_Only indicates whether the specific
+   --  languages should also be freed.
+
    type Response_File_Format is
      (None,
       GNU,
@@ -1317,33 +1322,24 @@ package Prj is
 
    function Is_Extending
      (Extending : Project_Id;
-      Extended  : Project_Id;
-      In_Tree   : Project_Tree_Ref) return Boolean;
-   --  ??? needs comment
+      Extended  : Project_Id) return Boolean;
+   --  Return True if Extending is extending the Extended project.
 
    function Is_A_Language
-     (Data          : Project_Data;
+     (Project       : Project_Id;
       Language_Name : Name_Id) return Boolean;
    --  Return True when Language_Name (which must be lower case) is one of the
    --  languages used for the project.
 
-   function Has_Ada_Sources (Data : Project_Data) return Boolean;
+   function Has_Ada_Sources (Data : Project_Id) return Boolean;
    --  Return True if the project has Ada sources
 
-   function Has_Foreign_Sources (Data : Project_Data) return Boolean;
+   function Has_Foreign_Sources (Data : Project_Id) return Boolean;
    --  Return True if the project has foreign sources
 
    Project_Error : exception;
    --  Raised by some subprograms in Prj.Attr
 
-   package Project_Table is new GNAT.Dynamic_Tables (
-     Table_Component_Type => Project_Data,
-     Table_Index_Type     => Project_Id,
-     Table_Low_Bound      => 1,
-     Table_Initial        => 100,
-     Table_Increment      => 100);
-   --  The set of all project files
-
    type Spec_Or_Body is (Specification, Body_Part);
 
    type File_Name_Data is record
@@ -1427,7 +1423,7 @@ package Prj is
          Array_Elements    : Array_Element_Table.Instance;
          Arrays            : Array_Table.Instance;
          Packages          : Package_Table.Instance;
-         Projects          : Project_Table.Instance;
+         Projects          : Project_List;
          Units             : Unit_Table.Instance;
          Units_HT          : Units_Htable.Instance;
          Source_Paths_HT   : Source_Paths_Htable.Instance;
@@ -1486,7 +1482,6 @@ package Prj is
          With_State : in out State);
    procedure For_Every_Project_Imported
      (By             : Project_Id;
-      In_Tree        : Project_Tree_Ref;
       With_State     : in out State;
       Imported_First : Boolean := False);
    --  Call Action for each project imported directly or indirectly by project
@@ -1560,7 +1555,7 @@ private
    type Source_Iterator is record
       In_Tree : Project_Tree_Ref;
 
-      Project      : Project_Id;
+      Project      : Project_List;
       All_Projects : Boolean;
       --  Current project and whether we should move on to the next
 

gcc/ada/rtsfind.adb

@@ -1396,7 +1396,7 @@ package body Rtsfind is
 
    begin
       --  Nothing to do if name is not an identifier or a selected component
-      --  whose selector_name is not an identifier.
+      --  whose selector_name is an identifier.
 
       if Nkind (Nam) = N_Identifier then
          Chrs := Chars (Nam);
@@ -1448,8 +1448,40 @@ package body Rtsfind is
                Load_RTU
                  (To_Load,
                   Use_Setting => In_Use (Cunit_Entity (U)));
-               Set_Is_Visible_Child_Unit
-                 (RT_Unit_Table (To_Load).Entity);
+               Set_Is_Visible_Child_Unit (RT_Unit_Table (To_Load).Entity);
+
+               --  Prevent creation of an implicit 'with' from (for example)
+               --  Ada.Wide_Text_IO.Integer_IO to Ada.Text_IO.Integer_IO,
+               --  because these could create cycles. First check whether the
+               --  simple names match ("integer_io" = "integer_io"), and then
+               --  check whether the parent is indeed one of the
+               --  [[Wide_]Wide_]Text_IO packages.
+
+               if Chrs = Chars (Cunit_Entity (Current_Sem_Unit)) then
+                  declare
+                     Parent_Name : constant Unit_Name_Type
+                       := Get_Parent_Spec_Name (Unit_Name (Current_Sem_Unit));
+                  begin
+                     if Parent_Name /= No_Unit_Name then
+                        Get_Name_String (Parent_Name);
+
+                        declare
+                           P : String renames Name_Buffer (1 .. Name_Len);
+                        begin
+                           if P = "ada.text_io%s"
+                             or else P = "ada.wide_text_io%s"
+                             or else P = "ada.wide_wide_text_io%s"
+                           then
+                              goto Continue;
+                           end if;
+                        end;
+                     end if;
+                  end;
+               end if;
+
+               --  Add an implicit with clause from the current unit to the
+               --  [[Wide_]Wide_]Text_IO child (if necessary).
+
                Maybe_Add_With (RT_Unit_Table (To_Load));
             end if;
 

gcc/ada/sem.adb

@@ -1618,9 +1618,12 @@ package body Sem is
                   Write_Unit_Info (Unit_Num, Item, Withs => True);
                end if;
 
-               --  Main unit should come last
+               --  Main unit should come last (except in the case where we
+               --  skipped System_Aux_Id, in which case we missed the things it
+               --  depends on).
 
-               pragma Assert (not Done (Main_Unit));
+               pragma Assert
+                 (not Done (Main_Unit) or else Present (System_Aux_Id));
 
                --  We shouldn't do the same thing twice
 

gcc/ada/sem_ch12.adb

@@ -634,8 +634,8 @@ package body Sem_Ch12 is
    --  loaded. In that case a missing body is acceptable.
 
    procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
-   --  Add the context clause of the unit containing a generic unit to an
-   --  instantiation that is a compilation unit.
+   --  Add the context clause of the unit containing a generic unit to a
+   --  compilation unit that is, or contains, an instantiation.
 
    function Get_Associated_Node (N : Node_Id) return Node_Id;
    --  In order to propagate semantic information back from the analyzed copy
@@ -6935,9 +6935,19 @@ package body Sem_Ch12 is
          Item := First (Context_Items (Parent (Gen_Decl)));
          while Present (Item) loop
             if Nkind (Item) = N_With_Clause then
-               New_I := New_Copy (Item);
-               Set_Implicit_With (New_I, True);
-               Append (New_I, Current_Context);
+
+               --  Take care to prevent direct cyclic with's, which can happen
+               --  if the generic body with's the current unit. Such a case
+               --  would result in binder errors (or run-time errors if the
+               --  -gnatE switch is in effect), but we want to prevent it here,
+               --  because Sem.Walk_Library_Items doesn't like cycles. Note
+               --  that we don't bother to detect indirect cycles.
+
+               if Library_Unit (Item) /= Current_Unit then
+                  New_I := New_Copy (Item);
+                  Set_Implicit_With (New_I, True);
+                  Append (New_I, Current_Context);
+               end if;
             end if;
 
             Next (Item);