diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/prj-env.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/prj-env.adb | 2319 |
1 files changed, 2319 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/prj-env.adb b/gcc-4.8.3/gcc/ada/prj-env.adb new file mode 100644 index 000000000..4788fbedf --- /dev/null +++ b/gcc-4.8.3/gcc/ada/prj-env.adb @@ -0,0 +1,2319 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E N V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2013, 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 Fmap; +with Hostparm; +with Makeutl; use Makeutl; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Sdefault; +with Tempdir; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +package body Prj.Env is + + Buffer_Initial : constant := 1_000; + -- Initial size of Buffer + + Uninitialized_Prefix : constant String := '#' & Path_Separator; + -- Prefix to indicate that the project path has not been initialized yet. + -- Must be two characters long + + No_Project_Default_Dir : constant String := "-"; + -- Indicator in the project path to indicate that the default search + -- directories should not be added to the path + + ----------------------- + -- Local Subprograms -- + ----------------------- + + package Source_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Name_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the source dirs before creating the source path file + + package Object_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Path_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the object dirs, before creating the object path file + + procedure Add_To_Buffer + (S : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- Add a string to Buffer, extending Buffer if needed + + procedure Add_To_Path + (Source_Dirs : String_List_Id; + Shared : Shared_Project_Tree_Data_Access; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- Add to Ada_Path_Buffer all the source directories in string list + -- Source_Dirs, if any. + + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural); + -- If Dir is not already in the global variable Ada_Path_Buffer, add it. + -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. + + procedure Add_To_Source_Path + (Source_Dirs : String_List_Id; + Shared : Shared_Project_Tree_Data_Access; + Source_Paths : in out Source_Path_Table.Instance); + -- Add to Ada_Path_B all the source directories in string list + -- Source_Dirs, if any. Increment Ada_Path_Length. + + procedure Add_To_Object_Path + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance); + -- Add Object_Dir to object path table. Make sure it is not duplicate + -- and it is the last one in the current table. + + ---------------------- + -- Ada_Include_Path -- + ---------------------- + + function Ada_Include_Path + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Recursive : Boolean := False) return String + is + Buffer : String_Access; + Buffer_Last : Natural := 0; + + procedure Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean); + -- Add source dirs of Project to the path + + --------- + -- Add -- + --------- + + procedure Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean) + is + pragma Unreferenced (Dummy); + begin + Add_To_Path + (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); + end Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Add); + + Dummy : Boolean := False; + + -- Start of processing for Ada_Include_Path + + begin + if Recursive then + + -- If it is the first time we call this function for + -- this project, compute the source path + + if Project.Ada_Include_Path = null then + Buffer := new String (1 .. 4096); + For_All_Projects + (Project, In_Tree, Dummy, Include_Aggregated => True); + Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); + end if; + + return Project.Ada_Include_Path.all; + + else + Buffer := new String (1 .. 4096); + Add_To_Path + (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); + + declare + Result : constant String := Buffer (1 .. Buffer_Last); + begin + Free (Buffer); + return Result; + end; + end if; + end Ada_Include_Path; + + ---------------------- + -- Ada_Objects_Path -- + ---------------------- + + function Ada_Objects_Path + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Including_Libraries : Boolean := True) return String_Access + is + Buffer : String_Access; + Buffer_Last : Natural := 0; + + procedure Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean); + -- Add all the object directories of a project to the path + + --------- + -- Add -- + --------- + + procedure Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean) + is + pragma Unreferenced (Dummy, In_Tree); + + Path : constant Path_Name_Type := + Get_Object_Directory + (Project, + Including_Libraries => Including_Libraries, + Only_If_Ada => False); + begin + if Path /= No_Path then + Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); + end if; + end Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Add); + + Dummy : Boolean := False; + + -- Start of processing for Ada_Objects_Path + + begin + -- If it is the first time we call this function for + -- this project, compute the objects path + + if Project.Ada_Objects_Path = null then + Buffer := new String (1 .. 4096); + For_All_Projects (Project, In_Tree, Dummy); + + Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); + end if; + + return Project.Ada_Objects_Path; + end Ada_Objects_Path; + + ------------------- + -- Add_To_Buffer -- + ------------------- + + procedure Add_To_Buffer + (S : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Last : constant Natural := Buffer_Last + S'Length; + + begin + while Last > Buffer'Last loop + declare + New_Buffer : constant String_Access := + new String (1 .. 2 * Buffer'Last); + begin + New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); + Free (Buffer); + Buffer := New_Buffer; + end; + end loop; + + Buffer (Buffer_Last + 1 .. Last) := S; + Buffer_Last := Last; + end Add_To_Buffer; + + ------------------------ + -- Add_To_Object_Path -- + ------------------------ + + procedure Add_To_Object_Path + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance) + is + begin + -- Check if the directory is already in the table + + for Index in + Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) + loop + + -- If it is, remove it, and add it as the last one + + if Object_Paths.Table (Index) = Object_Dir then + for Index2 in + Index + 1 .. Object_Path_Table.Last (Object_Paths) + loop + Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); + end loop; + + Object_Paths.Table + (Object_Path_Table.Last (Object_Paths)) := Object_Dir; + return; + end if; + end loop; + + -- The directory is not already in the table, add it + + Object_Path_Table.Append (Object_Paths, Object_Dir); + end Add_To_Object_Path; + + ----------------- + -- Add_To_Path -- + ----------------- + + procedure Add_To_Path + (Source_Dirs : String_List_Id; + Shared : Shared_Project_Tree_Data_Access; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Current : String_List_Id := Source_Dirs; + Source_Dir : String_Element; + begin + while Current /= Nil_String loop + Source_Dir := Shared.String_Elements.Table (Current); + Add_To_Path (Get_Name_String (Source_Dir.Display_Value), + Buffer, Buffer_Last); + Current := Source_Dir.Next; + end loop; + end Add_To_Path; + + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is + Len : Natural; + New_Buffer : String_Access; + Min_Len : Natural; + + function Is_Present (Path : String; Dir : String) return Boolean; + -- Return True if Dir is part of Path + + ---------------- + -- Is_Present -- + ---------------- + + function Is_Present (Path : String; Dir : String) return Boolean is + Last : constant Integer := Path'Last - Dir'Length + 1; + + begin + for J in Path'First .. Last loop + + -- Note: the order of the conditions below is important, since + -- it ensures a minimal number of string comparisons. + + if (J = Path'First + or else Path (J - 1) = Path_Separator) + and then + (J + Dir'Length > Path'Last + or else Path (J + Dir'Length) = Path_Separator) + and then Dir = Path (J .. J + Dir'Length - 1) + then + return True; + end if; + end loop; + + return False; + end Is_Present; + + -- Start of processing for Add_To_Path + + begin + if Is_Present (Buffer (1 .. Buffer_Last), Dir) then + + -- Dir is already in the path, nothing to do + + return; + end if; + + Min_Len := Buffer_Last + Dir'Length; + + if Buffer_Last > 0 then + + -- Add 1 for the Path_Separator character + + Min_Len := Min_Len + 1; + end if; + + -- If Ada_Path_Buffer is too small, increase it + + Len := Buffer'Last; + + if Len < Min_Len then + loop + Len := Len * 2; + exit when Len >= Min_Len; + end loop; + + New_Buffer := new String (1 .. Len); + New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); + Free (Buffer); + Buffer := New_Buffer; + end if; + + if Buffer_Last > 0 then + Buffer_Last := Buffer_Last + 1; + Buffer (Buffer_Last) := Path_Separator; + end if; + + Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; + Buffer_Last := Buffer_Last + Dir'Length; + end Add_To_Path; + + ------------------------ + -- Add_To_Source_Path -- + ------------------------ + + procedure Add_To_Source_Path + (Source_Dirs : String_List_Id; + Shared : Shared_Project_Tree_Data_Access; + Source_Paths : in out Source_Path_Table.Instance) + is + Current : String_List_Id := Source_Dirs; + Source_Dir : String_Element; + Add_It : Boolean; + + begin + -- Add each source directory + + while Current /= Nil_String loop + Source_Dir := Shared.String_Elements.Table (Current); + Add_It := True; + + -- Check if the source directory is already in the table + + for Index in + Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) + loop + -- If it is already, no need to add it + + if Source_Paths.Table (Index) = Source_Dir.Value then + Add_It := False; + exit; + end if; + end loop; + + if Add_It then + Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); + end if; + + -- Next source directory + + Current := Source_Dir.Next; + end loop; + end Add_To_Source_Path; + + -------------------------------- + -- Create_Config_Pragmas_File -- + -------------------------------- + + procedure Create_Config_Pragmas_File + (For_Project : Project_Id; + In_Tree : Project_Tree_Ref) + is + type Naming_Id is new Nat; + package Naming_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Lang_Naming_Data, + Table_Index_Type => Naming_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100); + + Default_Naming : constant Naming_Id := Naming_Table.First; + Namings : Naming_Table.Instance; + -- Table storing the naming data for gnatmake/gprmake + + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + File_Name : Path_Name_Type := No_Path; + File : File_Descriptor := Invalid_FD; + + Current_Naming : Naming_Id; + + procedure Check + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + State : in out Integer); + -- Recursive procedure that put in the config pragmas file any non + -- standard naming schemes, if it is not already in the file, then call + -- itself for any imported project. + + procedure Put (Source : Source_Id); + -- Put an SFN pragma in the temporary file + + procedure Put (S : String); + procedure Put_Line (S : String); + -- Output procedures, analogous to normal Text_IO procs of same name. + -- The text is put in Buffer, then it will be written into a temporary + -- file with procedure Write_Temp_File below. + + procedure Write_Temp_File; + -- Create a temporary file and put the content of the buffer in it + + ----------- + -- Check -- + ----------- + + procedure Check + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + State : in out Integer) + is + pragma Unreferenced (State); + + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + Naming : Lang_Naming_Data; + Iter : Source_Iterator; + Source : Source_Id; + + begin + if Current_Verbosity = High then + Debug_Output ("Checking project file:", Project.Name); + end if; + + if Lang = null then + if Current_Verbosity = High then + Debug_Output ("Languages does not contain Ada, nothing to do"); + end if; + + return; + end if; + + -- Visit all the files and process those that need an SFN pragma + + Iter := For_Each_Source (In_Tree, Project); + while Element (Iter) /= No_Source loop + Source := Element (Iter); + + if not Source.Locally_Removed + and then Source.Unit /= null + and then + (Source.Index >= 1 or else Source.Naming_Exception /= No) + then + Put (Source); + end if; + + Next (Iter); + end loop; + + Naming := Lang.Config.Naming_Data; + + -- Is the naming scheme of this project one that we know? + + Current_Naming := Default_Naming; + while Current_Naming <= Naming_Table.Last (Namings) + and then Namings.Table (Current_Naming).Dot_Replacement = + Naming.Dot_Replacement + and then Namings.Table (Current_Naming).Casing = + Naming.Casing + and then Namings.Table (Current_Naming).Separate_Suffix = + Naming.Separate_Suffix + loop + Current_Naming := Current_Naming + 1; + end loop; + + -- If we don't know it, add it + + if Current_Naming > Naming_Table.Last (Namings) then + Naming_Table.Increment_Last (Namings); + Namings.Table (Naming_Table.Last (Namings)) := Naming; + + -- Put the SFN pragmas for the naming scheme + + -- Spec + + Put_Line + ("pragma Source_File_Name_Project"); + Put_Line + (" (Spec_File_Name => ""*" & + Get_Name_String (Naming.Spec_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & """);"); + + -- and body + + Put_Line + ("pragma Source_File_Name_Project"); + Put_Line + (" (Body_File_Name => ""*" & + Get_Name_String (Naming.Body_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & + """);"); + + -- and maybe separate + + if Naming.Body_Suffix /= Naming.Separate_Suffix then + Put_Line ("pragma Source_File_Name_Project"); + Put_Line + (" (Subunit_File_Name => ""*" & + Get_Name_String (Naming.Separate_Suffix) & ""","); + Put_Line + (" Casing => " & + Image (Naming.Casing) & ","); + Put_Line + (" Dot_Replacement => """ & + Get_Name_String (Naming.Dot_Replacement) & + """);"); + end if; + end if; + end Check; + + --------- + -- Put -- + --------- + + procedure Put (Source : Source_Id) is + begin + -- Put the pragma SFN for the unit kind (spec or body) + + Put ("pragma Source_File_Name_Project ("); + Put (Namet.Get_Name_String (Source.Unit.Name)); + + if Source.Kind = Spec then + Put (", Spec_File_Name => """); + else + Put (", Body_File_Name => """); + end if; + + Put (Namet.Get_Name_String (Source.File)); + Put (""""); + + if Source.Index /= 0 then + Put (", Index =>"); + Put (Source.Index'Img); + end if; + + Put_Line (");"); + end Put; + + procedure Put (S : String) is + begin + Add_To_Buffer (S, Buffer, Buffer_Last); + + if Current_Verbosity = High then + Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + -- Add an ASCII.LF to the string. As this config file is supposed to + -- be used only by the compiler, we don't care about the characters + -- for the end of line. In fact we could have put a space, but + -- it is more convenient to be able to read gnat.adc during + -- development, for which the ASCII.LF is fine. + + Put (S); + Put (S => (1 => ASCII.LF)); + end Put_Line; + + --------------------- + -- Write_Temp_File -- + --------------------- + + procedure Write_Temp_File is + Status : Boolean := False; + Last : Natural; + + begin + Tempdir.Create_Temp_File (File, File_Name); + + if File /= Invalid_FD then + Last := Write (File, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (File, Status); + end if; + end if; + + if not Status then + Prj.Com.Fail ("unable to create temporary file"); + end if; + end Write_Temp_File; + + procedure Check_Imported_Projects is + new For_Every_Project_Imported (Integer, Check); + + Dummy : Integer := 0; + + -- Start of processing for Create_Config_Pragmas_File + + begin + if not For_Project.Config_Checked then + Naming_Table.Init (Namings); + + -- Check the naming schemes + + Check_Imported_Projects + (For_Project, In_Tree, Dummy, Imported_First => False); + + -- If there are no non standard naming scheme, issue the GNAT + -- standard naming scheme. This will tell the compiler that + -- a project file is used and will forbid any pragma SFN. + + if Buffer_Last = 0 then + + Put_Line ("pragma Source_File_Name_Project"); + Put_Line (" (Spec_File_Name => ""*.ads"","); + Put_Line (" Dot_Replacement => ""-"","); + Put_Line (" Casing => lowercase);"); + + Put_Line ("pragma Source_File_Name_Project"); + Put_Line (" (Body_File_Name => ""*.adb"","); + Put_Line (" Dot_Replacement => ""-"","); + Put_Line (" Casing => lowercase);"); + end if; + + -- Close the temporary file + + Write_Temp_File; + + if Opt.Verbose_Mode then + Write_Str ("Created configuration file """); + Write_Str (Get_Name_String (File_Name)); + Write_Line (""""); + end if; + + For_Project.Config_File_Name := File_Name; + For_Project.Config_File_Temp := True; + For_Project.Config_Checked := True; + end if; + + Free (Buffer); + end Create_Config_Pragmas_File; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping (In_Tree : Project_Tree_Ref) is + Data : Source_Id; + Iter : Source_Iterator; + + begin + Fmap.Reset_Tables; + + Iter := For_Each_Source (In_Tree); + loop + Data := Element (Iter); + exit when Data = No_Source; + + if Data.Unit /= No_Unit_Index then + if Data.Locally_Removed and then not Data.Suppressed then + Fmap.Add_Forbidden_File_Name (Data.File); + else + Fmap.Add_To_File_Map + (Unit_Name => Unit_Name_Type (Data.Unit.Name), + File_Name => Data.File, + Path_Name => File_Name_Type (Data.Path.Display_Name)); + end if; + end if; + + Next (Iter); + end loop; + end Create_Mapping; + + ------------------------- + -- Create_Mapping_File -- + ------------------------- + + procedure Create_Mapping_File + (Project : Project_Id; + Language : Name_Id; + In_Tree : Project_Tree_Ref; + Name : out Path_Name_Type) + is + File : File_Descriptor := Invalid_FD; + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + procedure Put_Name_Buffer; + -- Put the line contained in the Name_Buffer in the global buffer + + procedure Process + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + State : in out Integer); + -- Generate the mapping file for Project (not recursively) + + --------------------- + -- Put_Name_Buffer -- + --------------------- + + procedure Put_Name_Buffer is + begin + if Current_Verbosity = High then + Debug_Output (Name_Buffer (1 .. Name_Len)); + end if; + + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end Put_Name_Buffer; + + ------------- + -- Process -- + ------------- + + procedure Process + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + State : in out Integer) + is + pragma Unreferenced (State); + + Source : Source_Id; + Suffix : File_Name_Type; + Iter : Source_Iterator; + + begin + Debug_Output ("Add mapping for project", Project.Name); + Iter := For_Each_Source (In_Tree, Project, Language => Language); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if not Source.Suppressed + and then Source.Replaced_By = No_Source + and then Source.Path.Name /= No_Path + and then (Source.Language.Config.Kind = File_Based + or else Source.Unit /= No_Unit_Index) + then + if Source.Unit /= No_Unit_Index then + + -- Put the encoded unit name in the name buffer + + declare + Uname : constant String := + Get_Name_String (Source.Unit.Name); + + begin + Name_Len := 0; + for J in Uname'Range loop + if Uname (J) in Upper_Half_Character then + Store_Encoded_Character (Get_Char_Code (Uname (J))); + else + Add_Char_To_Name_Buffer (Uname (J)); + end if; + end loop; + end; + + if Source.Language.Config.Kind = Unit_Based then + + -- ??? Mapping_Spec_Suffix could be set in the case of + -- gnatmake as well + + Add_Char_To_Name_Buffer ('%'); + + if Source.Kind = Spec then + Add_Char_To_Name_Buffer ('s'); + else + Add_Char_To_Name_Buffer ('b'); + end if; + + else + case Source.Kind is + when Spec => + Suffix := + Source.Language.Config.Mapping_Spec_Suffix; + when Impl | Sep => + Suffix := + Source.Language.Config.Mapping_Body_Suffix; + end case; + + if Suffix /= No_File then + Add_Str_To_Name_Buffer (Get_Name_String (Suffix)); + end if; + end if; + + Put_Name_Buffer; + end if; + + Get_Name_String (Source.Display_File); + Put_Name_Buffer; + + if Source.Locally_Removed then + Name_Len := 1; + Name_Buffer (1) := '/'; + else + Get_Name_String (Source.Path.Display_Name); + end if; + + Put_Name_Buffer; + end if; + + Next (Iter); + end loop; + end Process; + + procedure For_Every_Imported_Project is new + For_Every_Project_Imported (State => Integer, Action => Process); + + -- Local variables + + Dummy : Integer := 0; + + -- Start of processing for Create_Mapping_File + + begin + if Current_Verbosity = High then + Debug_Output ("Create mapping file for", Debug_Name (In_Tree)); + end if; + + Create_Temp_File (In_Tree.Shared, File, Name, "mapping"); + + if Current_Verbosity = High then + Debug_Increase_Indent ("Create mapping file ", Name_Id (Name)); + end if; + + For_Every_Imported_Project + (Project, In_Tree, Dummy, Include_Aggregated => False); + + declare + Last : Natural; + Status : Boolean := False; + + begin + if File /= Invalid_FD then + Last := Write (File, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + GNAT.OS_Lib.Close (File, Status); + end if; + end if; + + if not Status then + Prj.Com.Fail ("could not write mapping file"); + end if; + end; + + Free (Buffer); + + Debug_Decrease_Indent ("Done create mapping file"); + end Create_Mapping_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (Shared : Shared_Project_Tree_Data_Access; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type; + File_Use : String) + is + begin + Tempdir.Create_Temp_File (Path_FD, Path_Name); + + if Path_Name /= No_Path then + if Current_Verbosity = High then + Write_Line ("Create temp file (" & File_Use & ") " + & Get_Name_String (Path_Name)); + end if; + + Record_Temp_File (Shared, Path_Name); + + else + Prj.Com.Fail + ("unable to create temporary " & File_Use & " file"); + end if; + end Create_Temp_File; + + -------------------------- + -- Create_New_Path_File -- + -------------------------- + + procedure Create_New_Path_File + (Shared : Shared_Project_Tree_Data_Access; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type) + is + begin + Create_Temp_File (Shared, Path_FD, Path_Name, "path file"); + end Create_New_Path_File; + + ------------------------------------ + -- File_Name_Of_Library_Unit_Body -- + ------------------------------------ + + function File_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id; + In_Tree : Project_Tree_Ref; + Main_Project_Only : Boolean := True; + Full_Path : Boolean := False) return String + is + + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); + The_Project : Project_Id := Project; + Original_Name : String := Name; + + Unit : Unit_Index; + The_Original_Name : Name_Id; + The_Spec_Name : Name_Id; + The_Body_Name : Name_Id; + + begin + -- ??? Same block in Project_Of + Canonical_Case_File_Name (Original_Name); + Name_Len := Original_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Name; + The_Original_Name := Name_Find; + + if Lang /= null then + declare + Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Naming.Body_Suffix); + + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; + + else + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + Canonical_Case_File_Name (Name_Buffer); + The_Spec_Name := Name_Find; + The_Body_Name := The_Spec_Name; + end if; + + if Current_Verbosity = High then + Write_Str ("Looking for file name of """); + Write_Str (Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Spec Name = """); + Write_Str (Get_Name_String (The_Spec_Name)); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Body Name = """); + Write_Str (Get_Name_String (The_Body_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- For extending project, search in the extended project if the source + -- is not found. For non extending projects, this loop will be run only + -- once. + + loop + -- Loop through units + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= null loop + -- Check for body + + if not Main_Project_Only + or else + (Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).Project = The_Project) + then + declare + Current_Name : File_Name_Type; + begin + -- Case of a body present + + if Unit.File_Names (Impl) /= null then + Current_Name := Unit.File_Names (Impl).File; + + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If it has the name of the original name, return the + -- original name. + + if Unit.Name = The_Original_Name + or else + Current_Name = File_Name_Type (The_Original_Name) + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Impl).Path.Name); + + else + return Get_Name_String (Current_Name); + end if; + + -- If it has the name of the extended body name, + -- return the extended body name + + elsif Current_Name = File_Name_Type (The_Body_Name) then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Impl).Path.Name); + + else + return Get_Name_String (The_Body_Name); + end if; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + -- Check for spec + + if not Main_Project_Only + or else (Unit.File_Names (Spec) /= null + and then Unit.File_Names (Spec).Project = The_Project) + then + declare + Current_Name : File_Name_Type; + + begin + -- Case of spec present + + if Unit.File_Names (Spec) /= null then + Current_Name := Unit.File_Names (Spec).File; + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If name same as original name, return original name + + if Unit.Name = The_Original_Name + or else + Current_Name = File_Name_Type (The_Original_Name) + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Spec).Path.Name); + else + return Get_Name_String (Current_Name); + end if; + + -- If it has the same name as the extended spec name, + -- return the extended spec name. + + elsif Current_Name = File_Name_Type (The_Spec_Name) then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + if Full_Path then + return Get_Name_String + (Unit.File_Names (Spec).Path.Name); + else + return Get_Name_String (The_Spec_Name); + end if; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + -- If we are not in an extending project, give up + + exit when not Main_Project_Only + or else The_Project.Extends = No_Project; + + -- Otherwise, look in the project we are extending + + The_Project := The_Project.Extends; + end loop; + + -- We don't know this file name, return an empty string + + return ""; + end File_Name_Of_Library_Unit_Body; + + ------------------------- + -- For_All_Object_Dirs -- + ------------------------- + + procedure For_All_Object_Dirs + (Project : Project_Id; + Tree : Project_Tree_Ref) + is + procedure For_Project + (Prj : Project_Id; + Tree : Project_Tree_Ref; + Dummy : in out Integer); + -- Get all object directories of Prj + + ----------------- + -- For_Project -- + ----------------- + + procedure For_Project + (Prj : Project_Id; + Tree : Project_Tree_Ref; + Dummy : in out Integer) + is + pragma Unreferenced (Dummy, Tree); + + begin + -- ??? Set_Ada_Paths has a different behavior for library project + -- files, should we have the same ? + + if Prj.Object_Directory /= No_Path_Information then + Get_Name_String (Prj.Object_Directory.Display_Name); + Action (Name_Buffer (1 .. Name_Len)); + end if; + end For_Project; + + procedure Get_Object_Dirs is + new For_Every_Project_Imported (Integer, For_Project); + Dummy : Integer := 1; + + -- Start of processing for For_All_Object_Dirs + + begin + Get_Object_Dirs (Project, Tree, Dummy); + end For_All_Object_Dirs; + + ------------------------- + -- For_All_Source_Dirs -- + ------------------------- + + procedure For_All_Source_Dirs + (Project : Project_Id; + In_Tree : Project_Tree_Ref) + is + procedure For_Project + (Prj : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Integer); + -- Get all object directories of Prj + + ----------------- + -- For_Project -- + ----------------- + + procedure For_Project + (Prj : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Integer) + is + pragma Unreferenced (Dummy); + + Current : String_List_Id := Prj.Source_Dirs; + The_String : String_Element; + + begin + -- If there are Ada sources, call action with the name of every + -- source directory. + + if Has_Ada_Sources (Prj) then + while Current /= Nil_String loop + The_String := In_Tree.Shared.String_Elements.Table (Current); + Action (Get_Name_String (The_String.Display_Value)); + Current := The_String.Next; + end loop; + end if; + end For_Project; + + procedure Get_Source_Dirs is + new For_Every_Project_Imported (Integer, For_Project); + Dummy : Integer := 1; + + -- Start of processing for For_All_Source_Dirs + + begin + Get_Source_Dirs (Project, In_Tree, Dummy); + end For_All_Source_Dirs; + + ------------------- + -- Get_Reference -- + ------------------- + + procedure Get_Reference + (Source_File_Name : String; + In_Tree : Project_Tree_Ref; + Project : out Project_Id; + Path : out Path_Name_Type) + is + begin + -- Body below could use some comments ??? + + if Current_Verbosity > Default then + Write_Str ("Getting Reference_Of ("""); + Write_Str (Source_File_Name); + Write_Str (""") ... "); + end if; + + declare + Original_Name : String := Source_File_Name; + Unit : Unit_Index; + + begin + Canonical_Case_File_Name (Original_Name); + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + + while Unit /= null loop + if Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + and then Unit.File_Names (Spec).File /= No_File + and then + (Namet.Get_Name_String + (Unit.File_Names (Spec).File) = Original_Name + or else (Unit.File_Names (Spec).Path /= No_Path_Information + and then + Namet.Get_Name_String + (Unit.File_Names (Spec).Path.Name) = + Original_Name)) + then + Project := + Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project); + Path := Unit.File_Names (Spec).Path.Display_Name; + + if Current_Verbosity > Default then + Write_Str ("Done: Spec."); + Write_Eol; + end if; + + return; + + elsif Unit.File_Names (Impl) /= null + and then Unit.File_Names (Impl).File /= No_File + and then not Unit.File_Names (Impl).Locally_Removed + and then + (Namet.Get_Name_String + (Unit.File_Names (Impl).File) = Original_Name + or else (Unit.File_Names (Impl).Path /= No_Path_Information + and then Namet.Get_Name_String + (Unit.File_Names (Impl).Path.Name) = + Original_Name)) + then + Project := + Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project); + Path := Unit.File_Names (Impl).Path.Display_Name; + + if Current_Verbosity > Default then + Write_Str ("Done: Body."); + Write_Eol; + end if; + + return; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + end; + + Project := No_Project; + Path := No_Path; + + if Current_Verbosity > Default then + Write_Str ("Cannot be found."); + Write_Eol; + end if; + end Get_Reference; + + ---------------------- + -- Get_Runtime_Path -- + ---------------------- + + function Get_Runtime_Path + (Self : Project_Search_Path; + Name : String) return String_Access + is + function Is_Base_Name (Path : String) return Boolean; + -- Returns True if Path has no directory separator + + ------------------ + -- Is_Base_Name -- + ------------------ + + function Is_Base_Name (Path : String) return Boolean is + begin + for J in Path'Range loop + if Path (J) = Directory_Separator or else Path (J) = '/' then + return False; + end if; + end loop; + + return True; + end Is_Base_Name; + + function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path + (Check_Filename => Is_Directory); + + -- Start of processing for Get_Runtime_Path + + begin + if not Is_Base_Name (Name) then + return Find_Rts_In_Path (Self, Name); + else + return null; + end if; + end Get_Runtime_Path; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (In_Tree : Project_Tree_Ref) is + begin + In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; + In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; + end Initialize; + + ------------------- + -- Print_Sources -- + ------------------- + + -- Could use some comments in this body ??? + + procedure Print_Sources (In_Tree : Project_Tree_Ref) is + Unit : Unit_Index; + + begin + Write_Line ("List of Sources:"); + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + + while Unit /= No_Unit_Index loop + Write_Str (" "); + Write_Line (Namet.Get_Name_String (Unit.Name)); + + if Unit.File_Names (Spec).File /= No_File then + if Unit.File_Names (Spec).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Unit.File_Names (Spec).Project.Path.Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" spec: "); + Write_Line + (Namet.Get_Name_String + (Unit.File_Names (Spec).File)); + end if; + + if Unit.File_Names (Impl).File /= No_File then + if Unit.File_Names (Impl).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Unit.File_Names (Impl).Project.Path.Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" body: "); + Write_Line + (Namet.Get_Name_String (Unit.File_Names (Impl).File)); + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + Write_Line ("end of List of Sources."); + end Print_Sources; + + ---------------- + -- Project_Of -- + ---------------- + + function Project_Of + (Name : String; + Main_Project : Project_Id; + In_Tree : Project_Tree_Ref) return Project_Id + is + Result : Project_Id := No_Project; + + Original_Name : String := Name; + + Lang : constant Language_Ptr := + Get_Language_From_Name (Main_Project, "ada"); + + Unit : Unit_Index; + + Current_Name : File_Name_Type; + The_Original_Name : File_Name_Type; + The_Spec_Name : File_Name_Type; + The_Body_Name : File_Name_Type; + + begin + -- ??? Same block in File_Name_Of_Library_Unit_Body + Canonical_Case_File_Name (Original_Name); + Name_Len := Original_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Name; + The_Original_Name := Name_Find; + + if Lang /= null then + declare + Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Naming.Spec_Suffix); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Naming.Body_Suffix); + + begin + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + end; + + else + The_Spec_Name := The_Original_Name; + The_Body_Name := The_Original_Name; + end if; + + Unit := Units_Htable.Get_First (In_Tree.Units_HT); + while Unit /= null loop + + -- Case of a body present + + if Unit.File_Names (Impl) /= null then + Current_Name := Unit.File_Names (Impl).File; + + -- If it has the name of the original name or the body name, + -- we have found the project. + + if Unit.Name = Name_Id (The_Original_Name) + or else Current_Name = The_Original_Name + or else Current_Name = The_Body_Name + then + Result := Unit.File_Names (Impl).Project; + exit; + end if; + end if; + + -- Check for spec + + if Unit.File_Names (Spec) /= null then + Current_Name := Unit.File_Names (Spec).File; + + -- If name same as the original name, or the spec name, we have + -- found the project. + + if Unit.Name = Name_Id (The_Original_Name) + or else Current_Name = The_Original_Name + or else Current_Name = The_Spec_Name + then + Result := Unit.File_Names (Spec).Project; + exit; + end if; + end if; + + Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + end loop; + + return Ultimate_Extending_Project_Of (Result); + end Project_Of; + + ------------------- + -- Set_Ada_Paths -- + ------------------- + + procedure Set_Ada_Paths + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True) + + is + Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; + + Source_Paths : Source_Path_Table.Instance; + Object_Paths : Object_Path_Table.Instance; + -- List of source or object dirs. Only computed the first time this + -- procedure is called (since Source_FD is then reused) + + Source_FD : File_Descriptor := Invalid_FD; + Object_FD : File_Descriptor := Invalid_FD; + -- The temporary files to store the paths. These are only created the + -- first time this procedure is called, and reused from then on. + + Process_Source_Dirs : Boolean := False; + Process_Object_Dirs : Boolean := False; + + Status : Boolean; + -- For calls to Close + + Last : Natural; + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; + + procedure Recursive_Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean); + -- Recursive procedure to add the source/object paths of extended/ + -- imported projects. + + ------------------- + -- Recursive_Add -- + ------------------- + + procedure Recursive_Add + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Dummy : in out Boolean) + is + pragma Unreferenced (Dummy, In_Tree); + + Path : Path_Name_Type; + + begin + -- ??? This is almost the equivalent of For_All_Source_Dirs + + if Process_Source_Dirs then + + -- Add to path all source directories of this project if there are + -- Ada sources. + + if Has_Ada_Sources (Project) then + Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths); + end if; + end if; + + if Process_Object_Dirs then + Path := Get_Object_Directory + (Project, + Including_Libraries => Including_Libraries, + Only_If_Ada => True); + + if Path /= No_Path then + Add_To_Object_Path (Path, Object_Paths); + end if; + end if; + end Recursive_Add; + + procedure For_All_Projects is + new For_Every_Project_Imported (Boolean, Recursive_Add); + + Dummy : Boolean := False; + + -- Start of processing for Set_Ada_Paths + + begin + -- If it is the first time we call this procedure for this project, + -- compute the source path and/or the object path. + + if Include_Path and then Project.Include_Path_File = No_Path then + Source_Path_Table.Init (Source_Paths); + Process_Source_Dirs := True; + Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File); + end if; + + -- For the object path, we make a distinction depending on + -- Including_Libraries. + + if Objects_Path and Including_Libraries then + if Project.Objects_Path_File_With_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); + Process_Object_Dirs := True; + Create_New_Path_File + (Shared, Object_FD, Project.Objects_Path_File_With_Libs); + end if; + + elsif Objects_Path then + if Project.Objects_Path_File_Without_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); + Process_Object_Dirs := True; + Create_New_Path_File + (Shared, Object_FD, Project.Objects_Path_File_Without_Libs); + end if; + end if; + + -- If there is something to do, set Seen to False for all projects, + -- then call the recursive procedure Add for Project. + + if Process_Source_Dirs or Process_Object_Dirs then + For_All_Projects (Project, In_Tree, Dummy); + end if; + + -- Write and close any file that has been created. Source_FD is not set + -- when this subprogram is called a second time or more, since we reuse + -- the previous version of the file. + + if Source_FD /= Invalid_FD then + Buffer_Last := 0; + + for Index in + Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) + loop + Get_Name_String (Source_Paths.Table (Index)); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end loop; + + Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (Source_FD, Status); + + else + Status := False; + end if; + + if not Status then + Prj.Com.Fail ("could not write temporary file"); + end if; + end if; + + if Object_FD /= Invalid_FD then + Buffer_Last := 0; + + for Index in + Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) + loop + Get_Name_String (Object_Paths.Table (Index)); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + end loop; + + Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last); + + if Last = Buffer_Last then + Close (Object_FD, Status); + else + Status := False; + end if; + + if not Status then + Prj.Com.Fail ("could not write temporary file"); + end if; + end if; + + -- Set the env vars, if they need to be changed, and set the + -- corresponding flags. + + if Include_Path + and then + Shared.Private_Part.Current_Source_Path_File /= + Project.Include_Path_File + then + Shared.Private_Part.Current_Source_Path_File := + Project.Include_Path_File; + Set_Path_File_Var + (Project_Include_Path_File, + Get_Name_String (Shared.Private_Part.Current_Source_Path_File)); + end if; + + if Objects_Path then + if Including_Libraries then + if Shared.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_With_Libs + then + Shared.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_With_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (Shared.Private_Part.Current_Object_Path_File)); + end if; + + else + if Shared.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_Without_Libs + then + Shared.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_Without_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (Shared.Private_Part.Current_Object_Path_File)); + end if; + end if; + end if; + + Free (Buffer); + end Set_Ada_Paths; + + --------------------- + -- Add_Directories -- + --------------------- + + procedure Add_Directories + (Self : in out Project_Search_Path; + Path : String; + Prepend : Boolean := False) + is + Tmp : String_Access; + begin + if Self.Path = null then + Self.Path := new String'(Uninitialized_Prefix & Path); + else + Tmp := Self.Path; + if Prepend then + Self.Path := new String'(Path & Path_Separator & Tmp.all); + else + Self.Path := new String'(Tmp.all & Path_Separator & Path); + end if; + Free (Tmp); + end if; + + if Current_Verbosity = High then + Debug_Output ("Adding directories to Project_Path: """ + & Path & '"'); + end if; + end Add_Directories; + + -------------------- + -- Is_Initialized -- + -------------------- + + function Is_Initialized (Self : Project_Search_Path) return Boolean is + begin + return Self.Path /= null + and then (Self.Path'Length = 0 + or else Self.Path (Self.Path'First) /= '#'); + end Is_Initialized; + + ---------------------- + -- Initialize_Empty -- + ---------------------- + + procedure Initialize_Empty (Self : in out Project_Search_Path) is + begin + Free (Self.Path); + Self.Path := new String'(""); + end Initialize_Empty; + + ------------------------------------- + -- Initialize_Default_Project_Path -- + ------------------------------------- + + procedure Initialize_Default_Project_Path + (Self : in out Project_Search_Path; + Target_Name : String) + is + Add_Default_Dir : Boolean := True; + First : Positive; + Last : Positive; + New_Len : Positive; + New_Last : Positive; + + Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; + Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; + -- Name of alternate env. variable that contain path name(s) of + -- directories where project files may reside. GPR_PROJECT_PATH has + -- precedence over ADA_PROJECT_PATH. + + Gpr_Prj_Path : String_Access; + Ada_Prj_Path : String_Access; + -- The path name(s) of directories where project files may reside. + -- May be empty. + + begin + if Is_Initialized (Self) then + return; + end if; + + -- The current directory is always first in the search path. Since the + -- Project_Path currently starts with '#:' as a sign that it isn't + -- initialized, we simply replace '#' with '.' + + if Self.Path = null then + Self.Path := new String'('.' & Path_Separator); + else + Self.Path (Self.Path'First) := '.'; + end if; + + -- Then the reset of the project path (if any) currently contains the + -- directories added through Add_Search_Project_Directory + + -- If environment variables are defined and not empty, add their content + + Gpr_Prj_Path := Getenv (Gpr_Project_Path); + Ada_Prj_Path := Getenv (Ada_Project_Path); + + if Gpr_Prj_Path.all /= "" then + Add_Directories (Self, Gpr_Prj_Path.all); + end if; + + Free (Gpr_Prj_Path); + + if Ada_Prj_Path.all /= "" then + Add_Directories (Self, Ada_Prj_Path.all); + end if; + + Free (Ada_Prj_Path); + + -- Copy to Name_Buffer, since we will need to manipulate the path + + Name_Len := Self.Path'Length; + Name_Buffer (1 .. Name_Len) := Self.Path.all; + + -- Scan the directory path to see if "-" is one of the directories. + -- Remove each occurrence of "-" and set Add_Default_Dir to False. + -- Also resolve relative paths and symbolic links. + + First := 3; + loop + while First <= Name_Len + and then (Name_Buffer (First) = Path_Separator) + loop + First := First + 1; + end loop; + + exit when First > Name_Len; + + Last := First; + + while Last < Name_Len + and then Name_Buffer (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + -- If the directory is "-", set Add_Default_Dir to False and + -- remove from path. + + if Name_Buffer (First .. Last) = No_Project_Default_Dir then + Add_Default_Dir := False; + + for J in Last + 1 .. Name_Len loop + Name_Buffer (J - No_Project_Default_Dir'Length - 1) := + Name_Buffer (J); + end loop; + + Name_Len := Name_Len - No_Project_Default_Dir'Length - 1; + + -- After removing the '-', go back one character to get the next + -- directory correctly. + + Last := Last - 1; + + elsif not Hostparm.OpenVMS + or else not Is_Absolute_Path (Name_Buffer (First .. Last)) + then + -- On VMS, only expand relative path names, as absolute paths + -- may correspond to multi-valued VMS logical names. + + declare + New_Dir : constant String := + Normalize_Pathname + (Name_Buffer (First .. Last), + Resolve_Links => Opt.Follow_Links_For_Dirs); + + begin + -- If the absolute path was resolved and is different from + -- the original, replace original with the resolved path. + + if New_Dir /= Name_Buffer (First .. Last) + and then New_Dir'Length /= 0 + then + New_Len := Name_Len + New_Dir'Length - (Last - First + 1); + New_Last := First + New_Dir'Length - 1; + Name_Buffer (New_Last + 1 .. New_Len) := + Name_Buffer (Last + 1 .. Name_Len); + Name_Buffer (First .. New_Last) := New_Dir; + Name_Len := New_Len; + Last := New_Last; + end if; + end; + end if; + + First := Last + 1; + end loop; + + Free (Self.Path); + + -- Set the initial value of Current_Project_Path + + if Add_Default_Dir then + declare + Prefix : String_Ptr; + + begin + if Sdefault.Search_Dir_Prefix = null then + + -- gprbuild case + + Prefix := new String'(Executable_Prefix_Path); + + else + Prefix := new String'(Sdefault.Search_Dir_Prefix.all + & ".." & Dir_Separator + & ".." & Dir_Separator + & ".." & Dir_Separator + & ".." & Dir_Separator); + end if; + + if Prefix.all /= "" then + if Target_Name /= "" then + + -- $prefix/$target/lib/gnat + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & Target_Name); + + -- Note: Target_Name has a trailing / when it comes from + -- Sdefault. + + if Name_Buffer (Name_Len) /= '/' then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer + ("lib" & Directory_Separator & "gnat"); + end if; + + -- $prefix/share/gpr + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "share" & Directory_Separator & "gpr"); + + -- $prefix/lib/gnat + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "lib" & Directory_Separator & "gnat"); + end if; + + Free (Prefix); + end; + end if; + + Self.Path := new String'(Name_Buffer (1 .. Name_Len)); + end Initialize_Default_Project_Path; + + -------------- + -- Get_Path -- + -------------- + + procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is + begin + pragma Assert (Is_Initialized (Self)); + Path := Self.Path; + end Get_Path; + + -------------- + -- Set_Path -- + -------------- + + procedure Set_Path (Self : in out Project_Search_Path; Path : String) is + begin + Free (Self.Path); + Self.Path := new String'(Path); + Projects_Paths.Reset (Self.Cache); + end Set_Path; + + ----------------------- + -- Find_Name_In_Path -- + ----------------------- + + function Find_Name_In_Path + (Self : Project_Search_Path; + Path : String) return String_Access + is + First : Natural; + Last : Natural; + + begin + if Current_Verbosity = High then + Debug_Output ("Trying " & Path); + end if; + + if Is_Absolute_Path (Path) then + if Check_Filename (Path) then + return new String'(Path); + else + return null; + end if; + + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path successively. + + First := Self.Path'First; + while First <= Self.Path'Last loop + while First <= Self.Path'Last + and then Self.Path (First) = Path_Separator + loop + First := First + 1; + end loop; + + exit when First > Self.Path'Last; + + Last := First; + while Last < Self.Path'Last + and then Self.Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Name_Len := 0; + + if not Is_Absolute_Path (Self.Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Self.Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); + + if Current_Verbosity = High then + Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); + end if; + + if Check_Filename (Name_Buffer (1 .. Name_Len)) then + return new String'(Name_Buffer (1 .. Name_Len)); + end if; + + First := Last + 1; + end loop; + end if; + + return null; + end Find_Name_In_Path; + + ------------------ + -- Find_Project -- + ------------------ + + procedure Find_Project + (Self : in out Project_Search_Path; + Project_File_Name : String; + Directory : String; + Path : out Namet.Path_Name_Type) + is + File : constant String := Project_File_Name; + -- Have to do a copy, in case the parameter is Name_Buffer, which we + -- modify below + + function Try_Path_Name is new Find_Name_In_Path + (Check_Filename => Is_Regular_File); + -- Find a file in the project search path + + -- Local Declarations + + Result : String_Access; + Has_Dot : Boolean := False; + Key : Name_Id; + + -- Start of processing for Find_Project + + begin + pragma Assert (Is_Initialized (Self)); + + if Current_Verbosity = High then + Debug_Increase_Indent + ("Searching for project """ & File & """ in """ + & Directory & '"'); + end if; + + -- Check the project cache + + Name_Len := File'Length; + Name_Buffer (1 .. Name_Len) := File; + Key := Name_Find; + Path := Projects_Paths.Get (Self.Cache, Key); + + if Path /= No_Path then + Debug_Decrease_Indent; + return; + end if; + + -- Check if File contains an extension (a dot before a + -- directory separator). If it is the case we do not try project file + -- with an added extension as it is not possible to have multiple dots + -- on a project file name. + + Check_Dot : for K in reverse File'Range loop + if File (K) = '.' then + Has_Dot := True; + exit Check_Dot; + end if; + + exit Check_Dot when File (K) = Directory_Separator + or else File (K) = '/'; + end loop Check_Dot; + + if not Is_Absolute_Path (File) then + + -- First we try <directory>/<file_name>.<extension> + + if not Has_Dot then + Result := Try_Path_Name + (Self, + Directory & Directory_Separator & + File & Project_File_Extension); + end if; + + -- Then we try <directory>/<file_name> + + if Result = null then + Result := Try_Path_Name + (Self, Directory & Directory_Separator & File); + end if; + end if; + + -- Then we try <file_name>.<extension> + + if Result = null and then not Has_Dot then + Result := Try_Path_Name (Self, File & Project_File_Extension); + end if; + + -- Then we try <file_name> + + if Result = null then + Result := Try_Path_Name (Self, File); + end if; + + -- If we cannot find the project file, we return an empty string + + if Result = null then + Path := Namet.No_Path; + return; + + else + declare + Final_Result : constant String := + GNAT.OS_Lib.Normalize_Pathname + (Result.all, + Directory => Directory, + Resolve_Links => Opt.Follow_Links_For_Files, + Case_Sensitive => True); + begin + Free (Result); + Name_Len := Final_Result'Length; + Name_Buffer (1 .. Name_Len) := Final_Result; + Path := Name_Find; + Projects_Paths.Set (Self.Cache, Key, Path); + end; + end if; + + Debug_Decrease_Indent; + end Find_Project; + + ---------- + -- Free -- + ---------- + + procedure Free (Self : in out Project_Search_Path) is + begin + Free (Self.Path); + Projects_Paths.Reset (Self.Cache); + end Free; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is + begin + Free (To); + + if From.Path /= null then + To.Path := new String'(From.Path.all); + end if; + + -- No need to copy the Cache, it will be recomputed as needed + end Copy; + +end Prj.Env; |