diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/prj-env.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/prj-env.adb | 2319 |
1 files changed, 0 insertions, 2319 deletions
diff --git a/gcc-4.8/gcc/ada/prj-env.adb b/gcc-4.8/gcc/ada/prj-env.adb deleted file mode 100644 index 4788fbedf..000000000 --- a/gcc-4.8/gcc/ada/prj-env.adb +++ /dev/null @@ -1,2319 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |