URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj.adb] - Blame information for rev 768

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                  P R J                                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2001-2012, 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- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Debug;
with Opt;
with Osint;    use Osint;
with Output;   use Output;
with Prj.Attr;
with Prj.Com;
with Prj.Err;  use Prj.Err;
with Snames;   use Snames;
with Uintp;    use Uintp;
 
with Ada.Characters.Handling;    use Ada.Characters.Handling;
with Ada.Containers.Ordered_Sets;
with Ada.Unchecked_Deallocation;
 
with GNAT.Case_Util;            use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable;
 
package body Prj is
 
   type Restricted_Lang;
   type Restricted_Lang_Access is access Restricted_Lang;
   type Restricted_Lang is record
      Name : Name_Id;
      Next : Restricted_Lang_Access;
   end record;
 
   Restricted_Languages : Restricted_Lang_Access := null;
   --  When null, all languages are allowed, otherwise only the languages in
   --  the list are allowed.
 
   Object_Suffix : constant String := Get_Target_Object_Suffix.all;
   --  File suffix for object files
 
   Initial_Buffer_Size : constant := 100;
   --  Initial size for extensible buffer used in Add_To_Buffer
 
   The_Empty_String : Name_Id := No_Name;
 
   Debug_Level : Integer := 0;
   --  Current indentation level for debug traces
 
   type Cst_String_Access is access constant String;
 
   All_Lower_Case_Image : aliased constant String := "lowercase";
   All_Upper_Case_Image : aliased constant String := "UPPERCASE";
   Mixed_Case_Image     : aliased constant String := "MixedCase";
 
   The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
                         (All_Lower_Case => All_Lower_Case_Image'Access,
                          All_Upper_Case => All_Upper_Case_Image'Access,
                          Mixed_Case     => Mixed_Case_Image'Access);
 
   procedure Free (Project : in out Project_Id);
   --  Free memory allocated for Project
 
   procedure Free_List (Languages : in out Language_Ptr);
   procedure Free_List (Source : in out Source_Id);
   procedure Free_List (Languages : in out Language_List);
   --  Free memory allocated for the list of languages or sources
 
   procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance);
   --  Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit &
   --  Unit.File_Names (Impl).Unit in the given table.
 
   procedure Free_Units (Table : in out Units_Htable.Instance);
   --  Free memory allocated for unit information in the project
 
   procedure Language_Changed (Iter : in out Source_Iterator);
   procedure Project_Changed (Iter : in out Source_Iterator);
   --  Called when a new project or language was selected for this iterator
 
   function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
   --  Return True if there is at least one ALI file in the directory Dir
 
   -----------------------------
   -- Add_Restricted_Language --
   -----------------------------
 
   procedure Add_Restricted_Language (Name : String) is
      N : String (1 .. Name'Length) := Name;
   begin
      To_Lower (N);
      Name_Len := 0;
      Add_Str_To_Name_Buffer (N);
      Restricted_Languages :=
        new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages);
   end Add_Restricted_Language;
 
   -------------------
   -- Add_To_Buffer --
   -------------------
 
   procedure Add_To_Buffer
     (S    : String;
      To   : in out String_Access;
      Last : in out Natural)
   is
   begin
      if To = null then
         To := new String (1 .. Initial_Buffer_Size);
         Last := 0;
      end if;
 
      --  If Buffer is too small, double its size
 
      while Last + S'Length > To'Last loop
         declare
            New_Buffer : constant  String_Access :=
                           new String (1 .. 2 * Last);
 
         begin
            New_Buffer (1 .. Last) := To (1 .. Last);
            Free (To);
            To := New_Buffer;
         end;
      end loop;
 
      To (Last + 1 .. Last + S'Length) := S;
      Last := Last + S'Length;
   end Add_To_Buffer;
 
   ---------------------------------
   -- Current_Object_Path_File_Of --
   ---------------------------------
 
   function Current_Object_Path_File_Of
     (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type
   is
   begin
      return Shared.Private_Part.Current_Object_Path_File;
   end Current_Object_Path_File_Of;
 
   ---------------------------------
   -- Current_Source_Path_File_Of --
   ---------------------------------
 
   function Current_Source_Path_File_Of
     (Shared : Shared_Project_Tree_Data_Access)
      return Path_Name_Type is
   begin
      return Shared.Private_Part.Current_Source_Path_File;
   end Current_Source_Path_File_Of;
 
   ---------------------------
   -- Delete_Temporary_File --
   ---------------------------
 
   procedure Delete_Temporary_File
     (Shared : Shared_Project_Tree_Data_Access := null;
      Path   : Path_Name_Type)
   is
      Dont_Care : Boolean;
      pragma Warnings (Off, Dont_Care);
 
   begin
      if not Debug.Debug_Flag_N then
         if Current_Verbosity = High then
            Write_Line ("Removing temp file: " & Get_Name_String (Path));
         end if;
 
         Delete_File (Get_Name_String (Path), Dont_Care);
 
         if Shared /= null then
            for Index in
              1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
            loop
               if Shared.Private_Part.Temp_Files.Table (Index) = Path then
                  Shared.Private_Part.Temp_Files.Table (Index) := No_Path;
               end if;
            end loop;
         end if;
      end if;
   end Delete_Temporary_File;
 
   ------------------------------
   -- Delete_Temp_Config_Files --
   ------------------------------
 
   procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
      Success : Boolean;
      pragma Warnings (Off, Success);
 
      Proj : Project_List;
 
   begin
      if not Debug.Debug_Flag_N then
         if Project_Tree /= null then
            Proj := Project_Tree.Projects;
            while Proj /= null loop
               if Proj.Project.Config_File_Temp then
                  Delete_Temporary_File
                    (Project_Tree.Shared, Proj.Project.Config_File_Name);
 
                  --  Make sure that we don't have a config file for this
                  --  project, in case there are several mains. In this case,
                  --  we will recreate another config file: we cannot reuse the
                  --  one that we just deleted!
 
                  Proj.Project.Config_Checked   := False;
                  Proj.Project.Config_File_Name := No_Path;
                  Proj.Project.Config_File_Temp := False;
               end if;
 
               Proj := Proj.Next;
            end loop;
         end if;
      end if;
   end Delete_Temp_Config_Files;
 
   ---------------------------
   -- Delete_All_Temp_Files --
   ---------------------------
 
   procedure Delete_All_Temp_Files
     (Shared : Shared_Project_Tree_Data_Access)
   is
      Dont_Care : Boolean;
      pragma Warnings (Off, Dont_Care);
 
      Path : Path_Name_Type;
 
   begin
      if not Debug.Debug_Flag_N then
         for Index in
           1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
         loop
            Path := Shared.Private_Part.Temp_Files.Table (Index);
 
            if Path /= No_Path then
               if Current_Verbosity = High then
                  Write_Line ("Removing temp file: "
                              & Get_Name_String (Path));
               end if;
 
               Delete_File (Get_Name_String (Path), Dont_Care);
            end if;
         end loop;
 
         Temp_Files_Table.Free (Shared.Private_Part.Temp_Files);
         Temp_Files_Table.Init (Shared.Private_Part.Temp_Files);
      end if;
 
      --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
      --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
      --  the empty string. On VMS, this has the effect of deassigning
      --  the logical names.
 
      if Shared.Private_Part.Current_Source_Path_File /= No_Path then
         Setenv (Project_Include_Path_File, "");
      end if;
 
      if Shared.Private_Part.Current_Object_Path_File /= No_Path then
         Setenv (Project_Objects_Path_File, "");
      end if;
   end Delete_All_Temp_Files;
 
   ---------------------
   -- Dependency_Name --
   ---------------------
 
   function Dependency_Name
     (Source_File_Name : File_Name_Type;
      Dependency       : Dependency_File_Kind) return File_Name_Type
   is
   begin
      case Dependency is
         when None =>
            return No_File;
 
         when Makefile =>
            return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
 
         when ALI_File =>
            return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
      end case;
   end Dependency_Name;
 
   ----------------
   -- Empty_File --
   ----------------
 
   function Empty_File return File_Name_Type is
   begin
      return File_Name_Type (The_Empty_String);
   end Empty_File;
 
   -------------------
   -- Empty_Project --
   -------------------
 
   function Empty_Project
     (Qualifier : Project_Qualifier) return Project_Data
   is
   begin
      Prj.Initialize (Tree => No_Project_Tree);
 
      declare
         Data : Project_Data (Qualifier => Qualifier);
 
      begin
         --  Only the fields for which no default value could be provided in
         --  prj.ads are initialized below.
 
         Data.Config := Default_Project_Config;
         return Data;
      end;
   end Empty_Project;
 
   ------------------
   -- Empty_String --
   ------------------
 
   function Empty_String return Name_Id is
   begin
      return The_Empty_String;
   end Empty_String;
 
   ------------
   -- Expect --
   ------------
 
   procedure Expect (The_Token : Token_Type; Token_Image : String) is
   begin
      if Token /= The_Token then
 
         --  ??? Should pass user flags here instead
 
         Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
      end if;
   end Expect;
 
   -----------------
   -- Extend_Name --
   -----------------
 
   function Extend_Name
     (File        : File_Name_Type;
      With_Suffix : String) return File_Name_Type
   is
      Last : Positive;
 
   begin
      Get_Name_String (File);
      Last := Name_Len + 1;
 
      while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
         Name_Len := Name_Len - 1;
      end loop;
 
      if Name_Len <= 1 then
         Name_Len := Last;
      end if;
 
      for J in With_Suffix'Range loop
         Name_Buffer (Name_Len) := With_Suffix (J);
         Name_Len := Name_Len + 1;
      end loop;
 
      Name_Len := Name_Len - 1;
      return Name_Find;
   end Extend_Name;
 
   -------------------------
   -- Is_Allowed_Language --
   -------------------------
 
   function Is_Allowed_Language (Name : Name_Id) return Boolean is
      R    : Restricted_Lang_Access := Restricted_Languages;
      Lang : constant String := Get_Name_String (Name);
 
   begin
      if R = null then
         return True;
 
      else
         while R /= null loop
            if Get_Name_String (R.Name) = Lang then
               return True;
            end if;
 
            R := R.Next;
         end loop;
 
         return False;
      end if;
   end Is_Allowed_Language;
 
   ---------------------
   -- Project_Changed --
   ---------------------
 
   procedure Project_Changed (Iter : in out Source_Iterator) is
   begin
      if Iter.Project /= null then
         Iter.Language := Iter.Project.Project.Languages;
         Language_Changed (Iter);
      end if;
   end Project_Changed;
 
   ----------------------
   -- Language_Changed --
   ----------------------
 
   procedure Language_Changed (Iter : in out Source_Iterator) is
   begin
      Iter.Current := No_Source;
 
      if Iter.Language_Name /= No_Name then
         while Iter.Language /= null
           and then Iter.Language.Name /= Iter.Language_Name
         loop
            Iter.Language := Iter.Language.Next;
         end loop;
      end if;
 
      --  If there is no matching language in this project, move to next
 
      if Iter.Language = No_Language_Index then
         if Iter.All_Projects then
            loop
               Iter.Project := Iter.Project.Next;
               exit when Iter.Project = null
                 or else Iter.Encapsulated_Libs
                 or else not Iter.Project.From_Encapsulated_Lib;
            end loop;
 
            Project_Changed (Iter);
         else
            Iter.Project := null;
         end if;
 
      else
         Iter.Current := Iter.Language.First_Source;
 
         if Iter.Current = No_Source then
            Iter.Language := Iter.Language.Next;
            Language_Changed (Iter);
         end if;
      end if;
   end Language_Changed;
 
   ---------------------
   -- For_Each_Source --
   ---------------------
 
   function For_Each_Source
     (In_Tree           : Project_Tree_Ref;
      Project           : Project_Id := No_Project;
      Language          : Name_Id := No_Name;
      Encapsulated_Libs : Boolean := True) return Source_Iterator
   is
      Iter : Source_Iterator;
   begin
      Iter := Source_Iterator'
        (In_Tree           => In_Tree,
         Project           => In_Tree.Projects,
         All_Projects      => Project = No_Project,
         Language_Name     => Language,
         Language          => No_Language_Index,
         Current           => No_Source,
         Encapsulated_Libs => Encapsulated_Libs);
 
      if Project /= null then
         while Iter.Project /= null
           and then Iter.Project.Project /= Project
         loop
            Iter.Project := Iter.Project.Next;
         end loop;
 
      else
         while not Iter.Encapsulated_Libs
           and then Iter.Project.From_Encapsulated_Lib
         loop
            Iter.Project := Iter.Project.Next;
         end loop;
      end if;
 
      Project_Changed (Iter);
 
      return Iter;
   end For_Each_Source;
 
   -------------
   -- Element --
   -------------
 
   function Element (Iter : Source_Iterator) return Source_Id is
   begin
      return Iter.Current;
   end Element;
 
   ----------
   -- Next --
   ----------
 
   procedure Next (Iter : in out Source_Iterator) is
   begin
      Iter.Current := Iter.Current.Next_In_Lang;
      if Iter.Current = No_Source then
         Iter.Language := Iter.Language.Next;
         Language_Changed (Iter);
      end if;
   end Next;
 
   --------------------------------
   -- For_Every_Project_Imported --
   --------------------------------
 
   procedure For_Every_Project_Imported_Context
     (By                 : Project_Id;
      Tree               : Project_Tree_Ref;
      With_State         : in out State;
      Include_Aggregated : Boolean := True;
      Imported_First     : Boolean := False)
   is
      use Project_Boolean_Htable;
 
      procedure Recursive_Check_Context
        (Project               : Project_Id;
         Tree                  : Project_Tree_Ref;
         In_Aggregate_Lib      : Boolean;
         From_Encapsulated_Lib : Boolean);
      --  Recursively handle the project tree creating a new context for
      --  keeping track about already handled projects.
 
      -----------------------------
      -- Recursive_Check_Context --
      -----------------------------
 
      procedure Recursive_Check_Context
        (Project               : Project_Id;
         Tree                  : Project_Tree_Ref;
         In_Aggregate_Lib      : Boolean;
         From_Encapsulated_Lib : Boolean)
      is
         package Name_Id_Set is
           new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
 
         Seen_Name : Name_Id_Set.Set;
         --  This set is needed to ensure that we do not haandle the same
         --  project twice in the context of aggregate libraries.
 
         procedure Recursive_Check
           (Project               : Project_Id;
            Tree                  : Project_Tree_Ref;
            In_Aggregate_Lib      : Boolean;
            From_Encapsulated_Lib : Boolean);
         --  Check if project has already been seen. If not, mark it as Seen,
         --  Call Action, and check all its imported and aggregated projects.
 
         ---------------------
         -- Recursive_Check --
         ---------------------
 
         procedure Recursive_Check
           (Project               : Project_Id;
            Tree                  : Project_Tree_Ref;
            In_Aggregate_Lib      : Boolean;
            From_Encapsulated_Lib : Boolean)
         is
            List : Project_List;
            T    : Project_Tree_Ref;
 
         begin
            if not Seen_Name.Contains (Project.Name) then
 
               --  Even if a project is aggregated multiple times in an
               --  aggregated library, we will only return it once.
 
               Seen_Name.Include (Project.Name);
 
               if not Imported_First then
                  Action
                    (Project,
                     Tree,
                     Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
                     With_State);
               end if;
 
               --  Visit all extended projects
 
               if Project.Extends /= No_Project then
                  Recursive_Check
                    (Project.Extends, Tree,
                     In_Aggregate_Lib, From_Encapsulated_Lib);
               end if;
 
               --  Visit all imported projects
 
               List := Project.Imported_Projects;
               while List /= null loop
                  Recursive_Check
                    (List.Project, Tree,
                     In_Aggregate_Lib,
                     From_Encapsulated_Lib
                       or else Project.Standalone_Library = Encapsulated);
                  List := List.Next;
               end loop;
 
               --  Visit all aggregated projects
 
               if Include_Aggregated
                 and then Project.Qualifier in Aggregate_Project
               then
                  declare
                     Agg : Aggregated_Project_List;
 
                  begin
                     Agg := Project.Aggregated_Projects;
                     while Agg /= null loop
                        pragma Assert (Agg.Project /= No_Project);
 
                        --  For aggregated libraries, the tree must be the one
                        --  of the aggregate library.
 
                        if Project.Qualifier = Aggregate_Library then
                           T := Tree;
                           Recursive_Check
                             (Agg.Project, T,
                              True,
                              From_Encapsulated_Lib
                                or else
                                  Project.Standalone_Library = Encapsulated);
 
                        else
                           T := Agg.Tree;
 
                           --  Use a new context as we want to returns the same
                           --  project in different project tree for aggregated
                           --  projects.
 
                           Recursive_Check_Context
                             (Agg.Project, T, False, False);
                        end if;
 
                        Agg := Agg.Next;
                     end loop;
                  end;
               end if;
 
               if Imported_First then
                  Action
                    (Project,
                     Tree,
                     Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
                     With_State);
               end if;
            end if;
         end Recursive_Check;
 
      --  Start of processing for Recursive_Check_Context
 
      begin
         Recursive_Check
           (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib);
      end Recursive_Check_Context;
 
   --  Start of processing for For_Every_Project_Imported
 
   begin
      Recursive_Check_Context
        (Project               => By,
         Tree                  => Tree,
         In_Aggregate_Lib      => False,
         From_Encapsulated_Lib => False);
   end For_Every_Project_Imported_Context;
 
   procedure For_Every_Project_Imported
     (By                 : Project_Id;
      Tree               : Project_Tree_Ref;
      With_State         : in out State;
      Include_Aggregated : Boolean := True;
      Imported_First     : Boolean := False)
   is
      procedure Internal
        (Project    : Project_Id;
         Tree       : Project_Tree_Ref;
         Context    : Project_Context;
         With_State : in out State);
      --  Action wrapper for handling the context
 
      --------------
      -- Internal --
      --------------
 
      procedure Internal
        (Project    : Project_Id;
         Tree       : Project_Tree_Ref;
         Context    : Project_Context;
         With_State : in out State)
      is
         pragma Unreferenced (Context);
      begin
         Action (Project, Tree, With_State);
      end Internal;
 
      procedure For_Projects is
        new For_Every_Project_Imported_Context (State, Internal);
 
   begin
      For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First);
   end For_Every_Project_Imported;
 
   -----------------
   -- Find_Source --
   -----------------
 
   function Find_Source
     (In_Tree          : Project_Tree_Ref;
      Project          : Project_Id;
      In_Imported_Only : Boolean := False;
      In_Extended_Only : Boolean := False;
      Base_Name        : File_Name_Type;
      Index            : Int := 0) return Source_Id
   is
      Result : Source_Id  := No_Source;
 
      procedure Look_For_Sources
        (Proj : Project_Id;
         Tree : Project_Tree_Ref;
         Src  : in out Source_Id);
      --  Look for Base_Name in the sources of Proj
 
      ----------------------
      -- Look_For_Sources --
      ----------------------
 
      procedure Look_For_Sources
        (Proj : Project_Id;
         Tree : Project_Tree_Ref;
         Src  : in out Source_Id)
      is
         Iterator : Source_Iterator;
 
      begin
         Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
         while Element (Iterator) /= No_Source loop
            if Element (Iterator).File = Base_Name
              and then (Index = 0 or else Element (Iterator).Index = Index)
            then
               Src := Element (Iterator);
 
               --  If the source has been excluded, continue looking. We will
               --  get the excluded source only if there is no other source
               --  with the same base name that is not locally removed.
 
               if not Element (Iterator).Locally_Removed then
                  return;
               end if;
            end if;
 
            Next (Iterator);
         end loop;
      end Look_For_Sources;
 
      procedure For_Imported_Projects is new For_Every_Project_Imported
        (State => Source_Id, Action => Look_For_Sources);
 
      Proj : Project_Id;
 
   --  Start of processing for Find_Source
 
   begin
      if In_Extended_Only then
         Proj := Project;
         while Proj /= No_Project loop
            Look_For_Sources (Proj, In_Tree, Result);
            exit when Result /= No_Source;
 
            Proj := Proj.Extends;
         end loop;
 
      elsif In_Imported_Only then
         Look_For_Sources (Project, In_Tree, Result);
 
         if Result = No_Source then
            For_Imported_Projects
              (By                 => Project,
               Tree               => In_Tree,
               Include_Aggregated => False,
               With_State         => Result);
         end if;
 
      else
         Look_For_Sources (No_Project, In_Tree, Result);
      end if;
 
      return Result;
   end Find_Source;
 
   ----------
   -- Hash --
   ----------
 
   function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
   --  Used in implementation of other functions Hash below
 
   function Hash (Name : File_Name_Type) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;
 
   function Hash (Name : Name_Id) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;
 
   function Hash (Name : Path_Name_Type) return Header_Num is
   begin
      return Hash (Get_Name_String (Name));
   end Hash;
 
   function Hash (Project : Project_Id) return Header_Num is
   begin
      if Project = No_Project then
         return Header_Num'First;
      else
         return Hash (Get_Name_String (Project.Name));
      end if;
   end Hash;
 
   -----------
   -- Image --
   -----------
 
   function Image (The_Casing : Casing_Type) return String is
   begin
      return The_Casing_Images (The_Casing).all;
   end Image;
 
   -----------------------------
   -- Is_Standard_GNAT_Naming --
   -----------------------------
 
   function Is_Standard_GNAT_Naming
     (Naming : Lang_Naming_Data) return Boolean
   is
   begin
      return Get_Name_String (Naming.Spec_Suffix) = ".ads"
        and then Get_Name_String (Naming.Body_Suffix) = ".adb"
        and then Get_Name_String (Naming.Dot_Replacement) = "-";
   end Is_Standard_GNAT_Naming;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize (Tree : Project_Tree_Ref) is
   begin
      if The_Empty_String = No_Name then
         Uintp.Initialize;
         Name_Len := 0;
         The_Empty_String := Name_Find;
 
         Prj.Attr.Initialize;
 
         --  Make sure that new reserved words after Ada 95 may be used as
         --  identifiers.
 
         Opt.Ada_Version := Opt.Ada_95;
 
         Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
         Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
         Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
         Set_Name_Table_Byte
           (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
      end if;
 
      if Tree /= No_Project_Tree then
         Reset (Tree);
      end if;
   end Initialize;
 
   ------------------
   -- Is_Extending --
   ------------------
 
   function Is_Extending
     (Extending : Project_Id;
      Extended  : Project_Id) return Boolean
   is
      Proj : Project_Id;
 
   begin
      Proj := Extending;
      while Proj /= No_Project loop
         if Proj = Extended then
            return True;
         end if;
 
         Proj := Proj.Extends;
      end loop;
 
      return False;
   end Is_Extending;
 
   -----------------
   -- Object_Name --
   -----------------
 
   function Object_Name
     (Source_File_Name   : File_Name_Type;
      Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
   is
   begin
      if Object_File_Suffix = No_Name then
         return Extend_Name
           (Source_File_Name, Object_Suffix);
      else
         return Extend_Name
           (Source_File_Name, Get_Name_String (Object_File_Suffix));
      end if;
   end Object_Name;
 
   function Object_Name
     (Source_File_Name   : File_Name_Type;
      Source_Index       : Int;
      Index_Separator    : Character;
      Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
   is
      Index_Img : constant String := Source_Index'Img;
      Last      : Natural;
 
   begin
      Get_Name_String (Source_File_Name);
 
      Last := Name_Len;
      while Last > 1 and then Name_Buffer (Last) /= '.' loop
         Last := Last - 1;
      end loop;
 
      if Last > 1 then
         Name_Len := Last - 1;
      end if;
 
      Add_Char_To_Name_Buffer (Index_Separator);
      Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
 
      if Object_File_Suffix = No_Name then
         Add_Str_To_Name_Buffer (Object_Suffix);
      else
         Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
      end if;
 
      return Name_Find;
   end Object_Name;
 
   ----------------------
   -- Record_Temp_File --
   ----------------------
 
   procedure Record_Temp_File
     (Shared : Shared_Project_Tree_Data_Access;
      Path   : Path_Name_Type)
   is
   begin
      Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
   end Record_Temp_File;
 
   ----------
   -- Free --
   ----------
 
   procedure Free (List : in out Aggregated_Project_List) is
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Aggregated_Project, Aggregated_Project_List);
      Tmp : Aggregated_Project_List;
   begin
      while List /= null loop
         Tmp := List.Next;
 
         Free (List.Tree);
 
         Unchecked_Free (List);
         List := Tmp;
      end loop;
   end Free;
 
   ----------------------------
   -- Add_Aggregated_Project --
   ----------------------------
 
   procedure Add_Aggregated_Project
     (Project : Project_Id; Path : Path_Name_Type) is
   begin
      Project.Aggregated_Projects := new Aggregated_Project'
        (Path    => Path,
         Project => No_Project,
         Tree    => null,
         Next    => Project.Aggregated_Projects);
   end Add_Aggregated_Project;
 
   ----------
   -- Free --
   ----------
 
   procedure Free (Project : in out Project_Id) is
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Project_Data, Project_Id);
 
   begin
      if Project /= null then
         Free (Project.Ada_Include_Path);
         Free (Project.Objects_Path);
         Free (Project.Ada_Objects_Path);
         Free_List (Project.Imported_Projects, Free_Project => False);
         Free_List (Project.All_Imported_Projects, Free_Project => False);
         Free_List (Project.Languages);
 
         case Project.Qualifier is
            when Aggregate | Aggregate_Library =>
               Free (Project.Aggregated_Projects);
 
            when others =>
               null;
         end case;
 
         Unchecked_Free (Project);
      end if;
   end Free;
 
   ---------------
   -- Free_List --
   ---------------
 
   procedure Free_List (Languages : in out Language_List) is
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Language_List_Element, Language_List);
      Tmp : Language_List;
   begin
      while Languages /= null loop
         Tmp := Languages.Next;
         Unchecked_Free (Languages);
         Languages := Tmp;
      end loop;
   end Free_List;
 
   ---------------
   -- Free_List --
   ---------------
 
   procedure Free_List (Source : in out Source_Id) is
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation (Source_Data, Source_Id);
 
      Tmp : Source_Id;
 
   begin
      while Source /= No_Source loop
         Tmp := Source.Next_In_Lang;
         Free_List (Source.Alternate_Languages);
 
         if Source.Unit /= null
           and then Source.Kind in Spec_Or_Body
         then
            Source.Unit.File_Names (Source.Kind) := null;
         end if;
 
         Unchecked_Free (Source);
         Source := Tmp;
      end loop;
   end Free_List;
 
   ---------------
   -- Free_List --
   ---------------
 
   procedure Free_List
     (List         : in out Project_List;
      Free_Project : Boolean)
   is
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
 
      Tmp : Project_List;
 
   begin
      while List /= null loop
         Tmp := List.Next;
 
         if Free_Project then
            Free (List.Project);
         end if;
 
         Unchecked_Free (List);
         List := Tmp;
      end loop;
   end Free_List;
 
   ---------------
   -- Free_List --
   ---------------
 
   procedure Free_List (Languages : in out Language_Ptr) is
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
 
      Tmp : Language_Ptr;
 
   begin
      while Languages /= null loop
         Tmp := Languages.Next;
         Free_List (Languages.First_Source);
         Unchecked_Free (Languages);
         Languages := Tmp;
      end loop;
   end Free_List;
 
   --------------------------
   -- Reset_Units_In_Table --
   --------------------------
 
   procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
      Unit : Unit_Index;
 
   begin
      Unit := Units_Htable.Get_First (Table);
      while Unit /= No_Unit_Index loop
         if Unit.File_Names (Spec) /= null then
            Unit.File_Names (Spec).Unit := No_Unit_Index;
         end if;
 
         if Unit.File_Names (Impl) /= null then
            Unit.File_Names (Impl).Unit := No_Unit_Index;
         end if;
 
         Unit := Units_Htable.Get_Next (Table);
      end loop;
   end Reset_Units_In_Table;
 
   ----------------
   -- Free_Units --
   ----------------
 
   procedure Free_Units (Table : in out Units_Htable.Instance) is
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
 
      Unit : Unit_Index;
 
   begin
      Unit := Units_Htable.Get_First (Table);
      while Unit /= No_Unit_Index loop
 
         --  We cannot reset Unit.File_Names (Impl or Spec).Unit here as
         --  Source_Data buffer is freed by the following instruction
         --  Free_List (Tree.Projects, Free_Project => True);
 
         Unchecked_Free (Unit);
         Unit := Units_Htable.Get_Next (Table);
      end loop;
 
      Units_Htable.Reset (Table);
   end Free_Units;
 
   ----------
   -- Free --
   ----------
 
   procedure Free (Tree : in out Project_Tree_Ref) is
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation
          (Project_Tree_Data, Project_Tree_Ref);
 
      procedure Unchecked_Free is new
        Ada.Unchecked_Deallocation
          (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
 
   begin
      if Tree /= null then
         if Tree.Is_Root_Tree then
            Name_List_Table.Free        (Tree.Shared.Name_Lists);
            Number_List_Table.Free      (Tree.Shared.Number_Lists);
            String_Element_Table.Free   (Tree.Shared.String_Elements);
            Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
            Array_Element_Table.Free    (Tree.Shared.Array_Elements);
            Array_Table.Free            (Tree.Shared.Arrays);
            Package_Table.Free          (Tree.Shared.Packages);
            Temp_Files_Table.Free       (Tree.Shared.Private_Part.Temp_Files);
         end if;
 
         if Tree.Appdata /= null then
            Free (Tree.Appdata.all);
            Unchecked_Free (Tree.Appdata);
         end if;
 
         Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
         Source_Files_Htable.Reset (Tree.Source_Files_HT);
 
         Reset_Units_In_Table (Tree.Units_HT);
         Free_List (Tree.Projects, Free_Project => True);
         Free_Units (Tree.Units_HT);
 
         Unchecked_Free (Tree);
      end if;
   end Free;
 
   -----------
   -- Reset --
   -----------
 
   procedure Reset (Tree : Project_Tree_Ref) is
   begin
      --  Visible tables
 
      if Tree.Is_Root_Tree then
 
         --  We cannot use 'Access here:
         --    "illegal attribute for discriminant-dependent component"
         --  However, we know this is valid since Shared and Shared_Data have
         --  the same lifetime and will always exist concurrently.
 
         Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
         Name_List_Table.Init        (Tree.Shared.Name_Lists);
         Number_List_Table.Init      (Tree.Shared.Number_Lists);
         String_Element_Table.Init   (Tree.Shared.String_Elements);
         Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
         Array_Element_Table.Init    (Tree.Shared.Array_Elements);
         Array_Table.Init            (Tree.Shared.Arrays);
         Package_Table.Init          (Tree.Shared.Packages);
 
         --  Private part table
 
         Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
 
         Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
         Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
      end if;
 
      Source_Paths_Htable.Reset    (Tree.Source_Paths_HT);
      Source_Files_Htable.Reset    (Tree.Source_Files_HT);
      Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
 
      Tree.Replaced_Source_Number := 0;
 
      Reset_Units_In_Table (Tree.Units_HT);
      Free_List (Tree.Projects, Free_Project => True);
      Free_Units (Tree.Units_HT);
   end Reset;
 
   -------------------------------------
   -- Set_Current_Object_Path_File_Of --
   -------------------------------------
 
   procedure Set_Current_Object_Path_File_Of
     (Shared : Shared_Project_Tree_Data_Access;
      To     : Path_Name_Type)
   is
   begin
      Shared.Private_Part.Current_Object_Path_File := To;
   end Set_Current_Object_Path_File_Of;
 
   -------------------------------------
   -- Set_Current_Source_Path_File_Of --
   -------------------------------------
 
   procedure Set_Current_Source_Path_File_Of
     (Shared : Shared_Project_Tree_Data_Access;
      To     : Path_Name_Type)
   is
   begin
      Shared.Private_Part.Current_Source_Path_File := To;
   end Set_Current_Source_Path_File_Of;
 
   -----------------------
   -- Set_Path_File_Var --
   -----------------------
 
   procedure Set_Path_File_Var (Name : String; Value : String) is
      Host_Spec : String_Access := To_Host_File_Spec (Value);
   begin
      if Host_Spec = null then
         Prj.Com.Fail
           ("could not convert file name """ & Value & """ to host spec");
      else
         Setenv (Name, Host_Spec.all);
         Free (Host_Spec);
      end if;
   end Set_Path_File_Var;
 
   -------------------
   -- Switches_Name --
   -------------------
 
   function Switches_Name
     (Source_File_Name : File_Name_Type) return File_Name_Type
   is
   begin
      return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
   end Switches_Name;
 
   -----------
   -- Value --
   -----------
 
   function Value (Image : String) return Casing_Type is
   begin
      for Casing in The_Casing_Images'Range loop
         if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
            return Casing;
         end if;
      end loop;
 
      raise Constraint_Error;
   end Value;
 
   ---------------------
   -- Has_Ada_Sources --
   ---------------------
 
   function Has_Ada_Sources (Data : Project_Id) return Boolean is
      Lang : Language_Ptr;
 
   begin
      Lang := Data.Languages;
      while Lang /= No_Language_Index loop
         if Lang.Name = Name_Ada then
            return Lang.First_Source /= No_Source;
         end if;
         Lang := Lang.Next;
      end loop;
 
      return False;
   end Has_Ada_Sources;
 
   ------------------------
   -- Contains_ALI_Files --
   ------------------------
 
   function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
      Dir_Name : constant String := Get_Name_String (Dir);
      Direct   : Dir_Type;
      Name     : String (1 .. 1_000);
      Last     : Natural;
      Result   : Boolean := False;
 
   begin
      Open (Direct, Dir_Name);
 
      --  For each file in the directory, check if it is an ALI file
 
      loop
         Read (Direct, Name, Last);
         exit when Last = 0;
         Canonical_Case_File_Name (Name (1 .. Last));
         Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
         exit when Result;
      end loop;
 
      Close (Direct);
      return Result;
 
   exception
      --  If there is any problem, close the directory if open and return True.
      --  The library directory will be added to the path.
 
      when others =>
         if Is_Open (Direct) then
            Close (Direct);
         end if;
 
         return True;
   end Contains_ALI_Files;
 
   --------------------------
   -- Get_Object_Directory --
   --------------------------
 
   function Get_Object_Directory
     (Project             : Project_Id;
      Including_Libraries : Boolean;
      Only_If_Ada         : Boolean := False) return Path_Name_Type
   is
   begin
      if (Project.Library and then Including_Libraries)
        or else
          (Project.Object_Directory /= No_Path_Information
            and then (not Including_Libraries or else not Project.Library))
      then
         --  For a library project, add the library ALI directory if there is
         --  no object directory or if the library ALI directory contains ALI
         --  files; otherwise add the object directory.
 
         if Project.Library then
            if Project.Object_Directory = No_Path_Information
              or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)
            then
               return Project.Library_ALI_Dir.Display_Name;
            else
               return Project.Object_Directory.Display_Name;
            end if;
 
            --  For a non-library project, add object directory if it is not a
            --  virtual project, and if there are Ada sources in the project or
            --  one of the projects it extends. If there are no Ada sources,
            --  adding the object directory could disrupt the order of the
            --  object dirs in the path.
 
         elsif not Project.Virtual then
            declare
               Add_Object_Dir : Boolean;
               Prj            : Project_Id;
 
            begin
               Add_Object_Dir := not Only_If_Ada;
               Prj := Project;
               while not Add_Object_Dir and then Prj /= No_Project loop
                  if Has_Ada_Sources (Prj) then
                     Add_Object_Dir := True;
                  else
                     Prj := Prj.Extends;
                  end if;
               end loop;
 
               if Add_Object_Dir then
                  return Project.Object_Directory.Display_Name;
               end if;
            end;
         end if;
      end if;
 
      return No_Path;
   end Get_Object_Directory;
 
   -----------------------------------
   -- Ultimate_Extending_Project_Of --
   -----------------------------------
 
   function Ultimate_Extending_Project_Of
     (Proj : Project_Id) return Project_Id
   is
      Prj : Project_Id;
 
   begin
      Prj := Proj;
      while Prj /= null and then Prj.Extended_By /= No_Project loop
         Prj := Prj.Extended_By;
      end loop;
 
      return Prj;
   end Ultimate_Extending_Project_Of;
 
   -----------------------------------
   -- Compute_All_Imported_Projects --
   -----------------------------------
 
   procedure Compute_All_Imported_Projects
     (Root_Project : Project_Id;
      Tree         : Project_Tree_Ref)
   is
      procedure Analyze_Tree
        (Local_Root : Project_Id;
         Local_Tree : Project_Tree_Ref;
         Context    : Project_Context);
      --  Process Project and all its aggregated project to analyze their own
      --  imported projects.
 
      ------------------
      -- Analyze_Tree --
      ------------------
 
      procedure Analyze_Tree
        (Local_Root : Project_Id;
         Local_Tree : Project_Tree_Ref;
         Context    : Project_Context)
      is
         pragma Unreferenced (Local_Root);
 
         Project : Project_Id;
 
         procedure Recursive_Add
           (Prj     : Project_Id;
            Tree    : Project_Tree_Ref;
            Context : Project_Context;
            Dummy   : in out Boolean);
         --  Recursively add the projects imported by project Project, but not
         --  those that are extended.
 
         -------------------
         -- Recursive_Add --
         -------------------
 
         procedure Recursive_Add
           (Prj     : Project_Id;
            Tree    : Project_Tree_Ref;
            Context : Project_Context;
            Dummy   : in out Boolean)
         is
            pragma Unreferenced (Dummy, Tree);
 
            List : Project_List;
            Prj2 : Project_Id;
 
         begin
            --  A project is not importing itself
 
            Prj2 := Ultimate_Extending_Project_Of (Prj);
 
            if Project /= Prj2 then
 
               --  Check that the project is not already in the list. We know
               --  the one passed to Recursive_Add have never been visited
               --  before, but the one passed it are the extended projects.
 
               List := Project.All_Imported_Projects;
               while List /= null loop
                  if List.Project = Prj2 then
                     return;
                  end if;
 
                  List := List.Next;
               end loop;
 
               --  Add it to the list
 
               Project.All_Imported_Projects :=
                 new Project_List_Element'
                   (Project               => Prj2,
                    From_Encapsulated_Lib =>
                      Context.From_Encapsulated_Lib
                        or else Analyze_Tree.Context.From_Encapsulated_Lib,
                    Next                  => Project.All_Imported_Projects);
            end if;
         end Recursive_Add;
 
         procedure For_All_Projects is
           new For_Every_Project_Imported_Context (Boolean, Recursive_Add);
 
         Dummy : Boolean := False;
         List  : Project_List;
 
      begin
         List := Local_Tree.Projects;
         while List /= null loop
            Project := List.Project;
            Free_List
              (Project.All_Imported_Projects, Free_Project => False);
            For_All_Projects
              (Project, Local_Tree, Dummy, Include_Aggregated => False);
            List := List.Next;
         end loop;
      end Analyze_Tree;
 
      procedure For_Aggregates is
        new For_Project_And_Aggregated_Context (Analyze_Tree);
 
   --  Start of processing for Compute_All_Imported_Projects
 
   begin
      For_Aggregates (Root_Project, Tree);
   end Compute_All_Imported_Projects;
 
   -------------------
   -- Is_Compilable --
   -------------------
 
   function Is_Compilable (Source : Source_Id) return Boolean is
   begin
      case Source.Compilable is
         when Unknown =>
            if Source.Language.Config.Compiler_Driver /= No_File
              and then
                Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
              and then not Source.Locally_Removed
              and then (Source.Language.Config.Kind /= File_Based
                         or else Source.Kind /= Spec)
            then
               --  Do not modify Source.Compilable before the source record
               --  has been initialized.
 
               if Source.Source_TS /= Empty_Time_Stamp then
                  Source.Compilable := Yes;
               end if;
 
               return True;
 
            else
               if Source.Source_TS /= Empty_Time_Stamp then
                  Source.Compilable := No;
               end if;
 
               return False;
            end if;
 
         when Yes =>
            return True;
 
         when No =>
            return False;
      end case;
   end Is_Compilable;
 
   ------------------------------
   -- Object_To_Global_Archive --
   ------------------------------
 
   function Object_To_Global_Archive (Source : Source_Id) return Boolean is
   begin
      return Source.Language.Config.Kind = File_Based
        and then Source.Kind = Impl
        and then Source.Language.Config.Objects_Linked
        and then Is_Compilable (Source)
        and then Source.Language.Config.Object_Generated;
   end Object_To_Global_Archive;
 
   ----------------------------
   -- Get_Language_From_Name --
   ----------------------------
 
   function Get_Language_From_Name
     (Project : Project_Id;
      Name    : String) return Language_Ptr
   is
      N      : Name_Id;
      Result : Language_Ptr;
 
   begin
      Name_Len := Name'Length;
      Name_Buffer (1 .. Name_Len) := Name;
      To_Lower (Name_Buffer (1 .. Name_Len));
      N := Name_Find;
 
      Result := Project.Languages;
      while Result /= No_Language_Index loop
         if Result.Name = N then
            return Result;
         end if;
 
         Result := Result.Next;
      end loop;
 
      return No_Language_Index;
   end Get_Language_From_Name;
 
   ----------------
   -- Other_Part --
   ----------------
 
   function Other_Part (Source : Source_Id) return Source_Id is
   begin
      if Source.Unit /= No_Unit_Index then
         case Source.Kind is
            when Impl =>
               return Source.Unit.File_Names (Spec);
            when Spec =>
               return Source.Unit.File_Names (Impl);
            when Sep =>
               return No_Source;
         end case;
      else
         return No_Source;
      end if;
   end Other_Part;
 
   ------------------
   -- Create_Flags --
   ------------------
 
   function Create_Flags
     (Report_Error               : Error_Handler;
      When_No_Sources            : Error_Warning;
      Require_Sources_Other_Lang : Boolean       := True;
      Allow_Duplicate_Basenames  : Boolean       := True;
      Compiler_Driver_Mandatory  : Boolean       := False;
      Error_On_Unknown_Language  : Boolean       := True;
      Require_Obj_Dirs           : Error_Warning := Error;
      Allow_Invalid_External     : Error_Warning := Error;
      Missing_Source_Files       : Error_Warning := Error;
      Ignore_Missing_With        : Boolean       := False)
      return Processing_Flags
   is
   begin
      return Processing_Flags'
        (Report_Error               => Report_Error,
         When_No_Sources            => When_No_Sources,
         Require_Sources_Other_Lang => Require_Sources_Other_Lang,
         Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
         Error_On_Unknown_Language  => Error_On_Unknown_Language,
         Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
         Require_Obj_Dirs           => Require_Obj_Dirs,
         Allow_Invalid_External     => Allow_Invalid_External,
         Missing_Source_Files       => Missing_Source_Files,
         Ignore_Missing_With        => Ignore_Missing_With);
   end Create_Flags;
 
   ------------
   -- Length --
   ------------
 
   function Length
     (Table : Name_List_Table.Instance;
      List  : Name_List_Index) return Natural
   is
      Count : Natural := 0;
      Tmp   : Name_List_Index;
 
   begin
      Tmp := List;
      while Tmp /= No_Name_List loop
         Count := Count + 1;
         Tmp := Table.Table (Tmp).Next;
      end loop;
 
      return Count;
   end Length;
 
   ------------------
   -- Debug_Output --
   ------------------
 
   procedure Debug_Output (Str : String) is
   begin
      if Current_Verbosity > Default then
         Set_Standard_Error;
         Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
         Set_Standard_Output;
      end if;
   end Debug_Output;
 
   ------------------
   -- Debug_Indent --
   ------------------
 
   procedure Debug_Indent is
   begin
      if Current_Verbosity = High then
         Set_Standard_Error;
         Write_Str ((1 .. Debug_Level * 2 => ' '));
         Set_Standard_Output;
      end if;
   end Debug_Indent;
 
   ------------------
   -- Debug_Output --
   ------------------
 
   procedure Debug_Output (Str : String; Str2 : Name_Id) is
   begin
      if Current_Verbosity = High then
         Debug_Indent;
         Set_Standard_Error;
         Write_Str (Str);
 
         if Str2 = No_Name then
            Write_Line (" <no_name>");
         else
            Write_Line (" """ & Get_Name_String (Str2) & '"');
         end if;
 
         Set_Standard_Output;
      end if;
   end Debug_Output;
 
   ---------------------------
   -- Debug_Increase_Indent --
   ---------------------------
 
   procedure Debug_Increase_Indent
     (Str : String := ""; Str2 : Name_Id := No_Name)
   is
   begin
      if Str2 /= No_Name then
         Debug_Output (Str, Str2);
      else
         Debug_Output (Str);
      end if;
      Debug_Level := Debug_Level + 1;
   end Debug_Increase_Indent;
 
   ---------------------------
   -- Debug_Decrease_Indent --
   ---------------------------
 
   procedure Debug_Decrease_Indent (Str : String := "") is
   begin
      if Debug_Level > 0 then
         Debug_Level := Debug_Level - 1;
      end if;
 
      if Str /= "" then
         Debug_Output (Str);
      end if;
   end Debug_Decrease_Indent;
 
   ----------------
   -- Debug_Name --
   ----------------
 
   function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
      P : Project_List;
 
   begin
      Name_Len := 0;
      Add_Str_To_Name_Buffer ("Tree [");
 
      P := Tree.Projects;
      while P /= null loop
         if P /= Tree.Projects then
            Add_Char_To_Name_Buffer (',');
         end if;
 
         Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
 
         P := P.Next;
      end loop;
 
      Add_Char_To_Name_Buffer (']');
 
      return Name_Find;
   end Debug_Name;
 
   ----------
   -- Free --
   ----------
 
   procedure Free (Tree : in out Project_Tree_Appdata) is
      pragma Unreferenced (Tree);
   begin
      null;
   end Free;
 
   --------------------------------
   -- For_Project_And_Aggregated --
   --------------------------------
 
   procedure For_Project_And_Aggregated
     (Root_Project : Project_Id;
      Root_Tree    : Project_Tree_Ref)
   is
      Agg : Aggregated_Project_List;
 
   begin
      Action (Root_Project, Root_Tree);
 
      if Root_Project.Qualifier in Aggregate_Project then
         Agg := Root_Project.Aggregated_Projects;
         while Agg /= null loop
            For_Project_And_Aggregated (Agg.Project, Agg.Tree);
            Agg := Agg.Next;
         end loop;
      end if;
   end For_Project_And_Aggregated;
 
   ----------------------------------------
   -- For_Project_And_Aggregated_Context --
   ----------------------------------------
 
   procedure For_Project_And_Aggregated_Context
     (Root_Project : Project_Id;
      Root_Tree    : Project_Tree_Ref)
   is
 
      procedure Recursive_Process
        (Project : Project_Id;
         Tree    : Project_Tree_Ref;
         Context : Project_Context);
      --  Process Project and all aggregated projects recursively
 
      -----------------------
      -- Recursive_Process --
      -----------------------
 
      procedure Recursive_Process
        (Project : Project_Id;
         Tree    : Project_Tree_Ref;
         Context : Project_Context)
      is
         Agg : Aggregated_Project_List;
         Ctx : Project_Context;
 
      begin
         Action (Project, Tree, Context);
 
         if Project.Qualifier in Aggregate_Project then
            Ctx :=
              (In_Aggregate_Lib      => True,
               From_Encapsulated_Lib =>
                 Context.From_Encapsulated_Lib
                   or else Project.Standalone_Library = Encapsulated);
 
            Agg := Project.Aggregated_Projects;
            while Agg /= null loop
               Recursive_Process (Agg.Project, Agg.Tree, Ctx);
               Agg := Agg.Next;
            end loop;
         end if;
      end Recursive_Process;
 
   --  Start of processing for For_Project_And_Aggregated_Context
 
   begin
      Recursive_Process
        (Root_Project, Root_Tree, Project_Context'(False, False));
   end For_Project_And_Aggregated_Context;
 
--  Package initialization for Prj
 
begin
   --  Make sure that the standard config and user project file extensions are
   --  compatible with canonical case file naming.
 
   Canonical_Case_File_Name (Config_Project_File_Extension);
   Canonical_Case_File_Name (Project_File_Extension);
end Prj;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj.adb] - Blame information for rev 768

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- P R J --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2001-2012, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Debug;`
27			`with Opt;`
28			`with Osint; use Osint;`
29			`with Output; use Output;`
30			`with Prj.Attr;`
31			`with Prj.Com;`
32			`with Prj.Err; use Prj.Err;`
33			`with Snames; use Snames;`
34			`with Uintp; use Uintp;`
35
36			`with Ada.Characters.Handling; use Ada.Characters.Handling;`
37			`with Ada.Containers.Ordered_Sets;`
38			`with Ada.Unchecked_Deallocation;`
39
40			`with GNAT.Case_Util; use GNAT.Case_Util;`