diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/prj-env.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/prj-env.adb | 2652 |
1 files changed, 0 insertions, 2652 deletions
diff --git a/gcc-4.4.0/gcc/ada/prj-env.adb b/gcc-4.4.0/gcc/ada/prj-env.adb deleted file mode 100644 index 174471634..000000000 --- a/gcc-4.4.0/gcc/ada/prj-env.adb +++ /dev/null @@ -1,2652 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . E N V -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2008, 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 Opt; -with Osint; use Osint; -with Output; use Output; -with Prj.Com; use Prj.Com; -with Tempdir; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -package body Prj.Env is - - Current_Source_Path_File : Path_Name_Type := No_Path; - -- Current value of project source path file env var. - -- Used to avoid setting the env var to the same value. - - Current_Object_Path_File : Path_Name_Type := No_Path; - -- Current value of project object path file env var. - -- Used to avoid setting the env var to the same value. - - Ada_Path_Buffer : String_Access := new String (1 .. 1024); - -- A buffer where values for ADA_INCLUDE_PATH - -- and ADA_OBJECTS_PATH are stored. - - Ada_Path_Length : Natural := 0; - -- Index of the last valid character in Ada_Path_Buffer - - Ada_Prj_Include_File_Set : Boolean := False; - Ada_Prj_Objects_File_Set : Boolean := False; - -- These flags are set to True when the corresponding environment variables - -- are set and are used to give these environment variables an empty string - -- value at the end of the program. This has no practical effect on most - -- platforms, except on VMS where the logical names are deassigned, thus - -- avoiding the pollution of the environment of the caller. - - Default_Naming : constant Naming_Id := Naming_Table.First; - - Fill_Mapping_File : Boolean := True; - - type Project_Flags is array (Project_Id range <>) of Boolean; - -- A Boolean array type used in Create_Mapping_File to select the projects - -- in the closure of a specific project. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Body_Path_Name_Of - (Unit : Unit_Index; - In_Tree : Project_Tree_Ref) return String; - -- Returns the path name of the body of a unit. - -- Compute it first, if necessary. - - function Spec_Path_Name_Of - (Unit : Unit_Index; - In_Tree : Project_Tree_Ref) return String; - -- Returns the path name of the spec of a unit. - -- Compute it first, if necessary. - - procedure Add_To_Path - (Source_Dirs : String_List_Id; - In_Tree : Project_Tree_Ref); - -- Add to Ada_Path_Buffer all the source directories in string list - -- Source_Dirs, if any. Increment Ada_Path_Length. - - procedure Add_To_Path (Dir : String); - -- If Dir is not already in the global variable Ada_Path_Buffer, add it. - -- Increment Ada_Path_Length. - -- If Ada_Path_Length /= 0, prepend a Path_Separator character to - -- Path. - - procedure Add_To_Source_Path - (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref); - -- 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; - In_Tree : Project_Tree_Ref); - -- Add Object_Dir to object path table. Make sure it is not duplicate - -- and it is the last one in the current table. - - function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; - -- Return True if there is at least one ALI file in the directory Dir - - procedure Set_Path_File_Var (Name : String; Value : String); - -- Call Setenv, after calling To_Host_File_Spec - - function Ultimate_Extension_Of - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return Project_Id; - -- Return a project that is either Project or an extended ancestor of - -- Project that itself is not extended. - - ---------------------- - -- Ada_Include_Path -- - ---------------------- - - function Ada_Include_Path - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return String_Access is - - procedure Add (Project : Project_Id); - -- Add all the source directories of a project to the path only if - -- this project has not been visited. Calls itself recursively for - -- projects being extended, and imported projects. Adds the project - -- to the list Seen if this is the call to Add for this project. - - --------- - -- Add -- - --------- - - procedure Add (Project : Project_Id) is - begin - -- If Seen is empty, then the project cannot have been visited - - if not In_Tree.Projects.Table (Project).Seen then - In_Tree.Projects.Table (Project).Seen := True; - - declare - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - List : Project_List := Data.Imported_Projects; - - begin - -- Add to path all source directories of this project - - Add_To_Path (Data.Source_Dirs, In_Tree); - - -- Call Add to the project being extended, if any - - if Data.Extends /= No_Project then - Add (Data.Extends); - end if; - - -- Call Add for each imported project, if any - - while List /= Empty_Project_List loop - Add - (In_Tree.Project_Lists.Table (List).Project); - List := In_Tree.Project_Lists.Table (List).Next; - end loop; - end; - end if; - end Add; - - -- Start of processing for Ada_Include_Path - - begin - -- If it is the first time we call this function for - -- this project, compute the source path - - if - In_Tree.Projects.Table (Project).Ada_Include_Path = null - then - Ada_Path_Length := 0; - - for Index in Project_Table.First .. - Project_Table.Last (In_Tree.Projects) - loop - In_Tree.Projects.Table (Index).Seen := False; - end loop; - - Add (Project); - In_Tree.Projects.Table (Project).Ada_Include_Path := - new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); - end if; - - return In_Tree.Projects.Table (Project).Ada_Include_Path; - end Ada_Include_Path; - - ---------------------- - -- Ada_Include_Path -- - ---------------------- - - function Ada_Include_Path - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Recursive : Boolean) return String - is - begin - if Recursive then - return Ada_Include_Path (Project, In_Tree).all; - else - Ada_Path_Length := 0; - Add_To_Path - (In_Tree.Projects.Table (Project).Source_Dirs, In_Tree); - return Ada_Path_Buffer (1 .. Ada_Path_Length); - 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 - procedure Add (Project : Project_Id); - -- Add all the object directories of a project to the path only if - -- this project has not been visited. Calls itself recursively for - -- projects being extended, and imported projects. Adds the project - -- to the list Seen if this is the first call to Add for this project. - - --------- - -- Add -- - --------- - - procedure Add (Project : Project_Id) is - begin - -- If this project has not been seen yet - - if not In_Tree.Projects.Table (Project).Seen then - In_Tree.Projects.Table (Project).Seen := True; - - declare - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - List : Project_List := Data.Imported_Projects; - - begin - -- Add to path the object directory of this project - -- except if we don't include library project and - -- this is a library project. - - if (Data.Library and then Including_Libraries) - or else - (Data.Object_Directory /= No_Path_Information - and then - (not Including_Libraries or else not Data.Library)) - then - -- For a library project, add the library directory, - -- if there is no object directory or if it contains ALI - -- files; otherwise add the object directory. - - if Data.Library then - if Data.Object_Directory = No_Path_Information - or else - Contains_ALI_Files (Data.Library_ALI_Dir.Name) - then - Add_To_Path - (Get_Name_String (Data.Library_ALI_Dir.Name)); - else - Add_To_Path - (Get_Name_String (Data.Object_Directory.Name)); - end if; - - else - -- For a non library project, add the object directory - - Add_To_Path - (Get_Name_String (Data.Object_Directory.Name)); - end if; - end if; - - -- Call Add to the project being extended, if any - - if Data.Extends /= No_Project then - Add (Data.Extends); - end if; - - -- Call Add for each imported project, if any - - while List /= Empty_Project_List loop - Add - (In_Tree.Project_Lists.Table (List).Project); - List := In_Tree.Project_Lists.Table (List).Next; - end loop; - end; - - end if; - end Add; - - -- 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 - In_Tree.Projects.Table (Project).Ada_Objects_Path = null - then - Ada_Path_Length := 0; - - for Index in Project_Table.First .. - Project_Table.Last (In_Tree.Projects) - loop - In_Tree.Projects.Table (Index).Seen := False; - end loop; - - Add (Project); - In_Tree.Projects.Table (Project).Ada_Objects_Path := - new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); - end if; - - return In_Tree.Projects.Table (Project).Ada_Objects_Path; - end Ada_Objects_Path; - - ------------------------ - -- Add_To_Object_Path -- - ------------------------ - - procedure Add_To_Object_Path - (Object_Dir : Path_Name_Type; In_Tree : Project_Tree_Ref) - is - begin - -- Check if the directory is already in the table - - for Index in Object_Path_Table.First .. - Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths) - loop - - -- If it is, remove it, and add it as the last one - - if In_Tree.Private_Part.Object_Paths.Table (Index) = Object_Dir then - for Index2 in Index + 1 .. - Object_Path_Table.Last - (In_Tree.Private_Part.Object_Paths) - loop - In_Tree.Private_Part.Object_Paths.Table (Index2 - 1) := - In_Tree.Private_Part.Object_Paths.Table (Index2); - end loop; - - In_Tree.Private_Part.Object_Paths.Table - (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) := - Object_Dir; - return; - end if; - end loop; - - -- The directory is not already in the table, add it - - Object_Path_Table.Increment_Last (In_Tree.Private_Part.Object_Paths); - In_Tree.Private_Part.Object_Paths.Table - (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) := - Object_Dir; - end Add_To_Object_Path; - - ----------------- - -- Add_To_Path -- - ----------------- - - procedure Add_To_Path - (Source_Dirs : String_List_Id; - In_Tree : Project_Tree_Ref) - is - Current : String_List_Id := Source_Dirs; - Source_Dir : String_Element; - begin - while Current /= Nil_String loop - Source_Dir := In_Tree.String_Elements.Table (Current); - Add_To_Path (Get_Name_String (Source_Dir.Display_Value)); - Current := Source_Dir.Next; - end loop; - end Add_To_Path; - - procedure Add_To_Path (Dir : String) 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 (Ada_Path_Buffer (1 .. Ada_Path_Length), Dir) then - - -- Dir is already in the path, nothing to do - - return; - end if; - - Min_Len := Ada_Path_Length + Dir'Length; - - if Ada_Path_Length > 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 := Ada_Path_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 .. Ada_Path_Length) := - Ada_Path_Buffer (1 .. Ada_Path_Length); - Free (Ada_Path_Buffer); - Ada_Path_Buffer := New_Buffer; - end if; - - if Ada_Path_Length > 0 then - Ada_Path_Length := Ada_Path_Length + 1; - Ada_Path_Buffer (Ada_Path_Length) := Path_Separator; - end if; - - Ada_Path_Buffer - (Ada_Path_Length + 1 .. Ada_Path_Length + Dir'Length) := Dir; - Ada_Path_Length := Ada_Path_Length + Dir'Length; - end Add_To_Path; - - ------------------------ - -- Add_To_Source_Path -- - ------------------------ - - procedure Add_To_Source_Path - (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref) - 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 := In_Tree.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 - (In_Tree.Private_Part.Source_Paths) - loop - -- If it is already, no need to add it - - if In_Tree.Private_Part.Source_Paths.Table (Index) = - Source_Dir.Value - then - Add_It := False; - exit; - end if; - end loop; - - if Add_It then - Source_Path_Table.Increment_Last - (In_Tree.Private_Part.Source_Paths); - In_Tree.Private_Part.Source_Paths.Table - (Source_Path_Table.Last (In_Tree.Private_Part.Source_Paths)) := - Source_Dir.Value; - end if; - - -- Next source directory - - Current := Source_Dir.Next; - end loop; - end Add_To_Source_Path; - - ----------------------- - -- Body_Path_Name_Of -- - ----------------------- - - function Body_Path_Name_Of - (Unit : Unit_Index; - In_Tree : Project_Tree_Ref) return String - is - Data : Unit_Data := In_Tree.Units.Table (Unit); - - begin - -- If we don't know the path name of the body of this unit, - -- we compute it, and we store it. - - if Data.File_Names (Body_Part).Path = No_Path_Information then - declare - Current_Source : String_List_Id := - In_Tree.Projects.Table - (Data.File_Names (Body_Part).Project).Ada_Sources; - Path : GNAT.OS_Lib.String_Access; - - begin - -- By default, put the file name - - Data.File_Names (Body_Part).Path.Name := - Path_Name_Type (Data.File_Names (Body_Part).Name); - - -- For each source directory - - while Current_Source /= Nil_String loop - Path := - Locate_Regular_File - (Namet.Get_Name_String - (Data.File_Names (Body_Part).Name), - Namet.Get_Name_String - (In_Tree.String_Elements.Table - (Current_Source).Value)); - - -- If the file is in this directory, then we store the path, - -- and we are done. - - if Path /= null then - Name_Len := Path'Length; - Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Body_Part).Path.Name := Name_Enter; - exit; - - else - Current_Source := - In_Tree.String_Elements.Table - (Current_Source).Next; - end if; - end loop; - - In_Tree.Units.Table (Unit) := Data; - end; - end if; - - -- Returned the stored value - - return Namet.Get_Name_String (Data.File_Names (Body_Part).Path.Name); - end Body_Path_Name_Of; - - ------------------------ - -- Contains_ALI_Files -- - ------------------------ - - function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is - Dir_Name : constant String := Get_Name_String (Dir); - Direct : Dir_Type; - Name : String (1 .. 1_000); - Last : Natural; - Result : Boolean := False; - - begin - Open (Direct, Dir_Name); - - -- For each file in the directory, check if it is an ALI file - - loop - Read (Direct, Name, Last); - exit when Last = 0; - Canonical_Case_File_Name (Name (1 .. Last)); - Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; - exit when Result; - end loop; - - Close (Direct); - return Result; - - exception - -- If there is any problem, close the directory if open and return - -- True; the library directory will be added to the path. - - when others => - if Is_Open (Direct) then - Close (Direct); - end if; - - return True; - end Contains_ALI_Files; - - -------------------------------- - -- Create_Config_Pragmas_File -- - -------------------------------- - - procedure Create_Config_Pragmas_File - (For_Project : Project_Id; - Main_Project : Project_Id; - In_Tree : Project_Tree_Ref; - Include_Config_Files : Boolean := True) - is - pragma Unreferenced (Main_Project); - pragma Unreferenced (Include_Config_Files); - - File_Name : Path_Name_Type := No_Path; - File : File_Descriptor := Invalid_FD; - - Current_Unit : Unit_Index := Unit_Table.First; - - First_Project : Project_List := Empty_Project_List; - - Current_Project : Project_List; - Current_Naming : Naming_Id; - - Status : Boolean; - -- For call to Close - - procedure Check (Project : Project_Id); - -- 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 Check_Temp_File; - -- Check that a temporary file has been opened. - -- If not, create one, and put its name in the project data, - -- with the indication that it is a temporary file. - - procedure Put - (Unit_Name : Name_Id; - File_Name : File_Name_Type; - Unit_Kind : Spec_Or_Body; - Index : Int); - -- Put an SFN pragma in the temporary file - - procedure Put (File : File_Descriptor; S : String); - procedure Put_Line (File : File_Descriptor; S : String); - -- Output procedures, analogous to normal Text_IO procs of same name - - ----------- - -- Check -- - ----------- - - procedure Check (Project : Project_Id) is - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - - begin - if Current_Verbosity = High then - Write_Str ("Checking project file """); - Write_Str (Namet.Get_Name_String (Data.Name)); - Write_Str ("""."); - Write_Eol; - end if; - - -- Is this project in the list of the visited project? - - Current_Project := First_Project; - while Current_Project /= Empty_Project_List - and then In_Tree.Project_Lists.Table - (Current_Project).Project /= Project - loop - Current_Project := - In_Tree.Project_Lists.Table (Current_Project).Next; - end loop; - - -- If it is not, put it in the list, and visit it - - if Current_Project = Empty_Project_List then - Project_List_Table.Increment_Last - (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table - (Project_List_Table.Last (In_Tree.Project_Lists)) := - (Project => Project, Next => First_Project); - First_Project := - Project_List_Table.Last (In_Tree.Project_Lists); - - -- Is the naming scheme of this project one that we know? - - Current_Naming := Default_Naming; - while Current_Naming <= - Naming_Table.Last (In_Tree.Private_Part.Namings) - and then not Same_Naming_Scheme - (Left => In_Tree.Private_Part.Namings.Table (Current_Naming), - Right => Data.Naming) loop - Current_Naming := Current_Naming + 1; - end loop; - - -- If we don't know it, add it - - if Current_Naming > - Naming_Table.Last (In_Tree.Private_Part.Namings) - then - Naming_Table.Increment_Last (In_Tree.Private_Part.Namings); - In_Tree.Private_Part.Namings.Table - (Naming_Table.Last (In_Tree.Private_Part.Namings)) := - Data.Naming; - - -- We need a temporary file to be created - - Check_Temp_File; - - -- Put the SFN pragmas for the naming scheme - - -- Spec - - Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Spec_File_Name => ""*" & - Spec_Suffix_Of (In_Tree, "ada", Data.Naming) & - ""","); - Put_Line - (File, " Casing => " & - Image (Data.Naming.Casing) & ","); - Put_Line - (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Data.Naming.Dot_Replacement) & - """);"); - - -- and body - - Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Body_File_Name => ""*" & - Body_Suffix_Of (In_Tree, "ada", Data.Naming) & - ""","); - Put_Line - (File, " Casing => " & - Image (Data.Naming.Casing) & ","); - Put_Line - (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Data.Naming.Dot_Replacement) & - """);"); - - -- and maybe separate - - if Body_Suffix_Of (In_Tree, "ada", Data.Naming) /= - Get_Name_String (Data.Naming.Separate_Suffix) - then - Put_Line - (File, "pragma Source_File_Name_Project"); - Put_Line - (File, " (Subunit_File_Name => ""*" & - Namet.Get_Name_String (Data.Naming.Separate_Suffix) & - ""","); - Put_Line - (File, " Casing => " & - Image (Data.Naming.Casing) & - ","); - Put_Line - (File, " Dot_Replacement => """ & - Namet.Get_Name_String (Data.Naming.Dot_Replacement) & - """);"); - end if; - end if; - - if Data.Extends /= No_Project then - Check (Data.Extends); - end if; - - declare - Current : Project_List := Data.Imported_Projects; - - begin - while Current /= Empty_Project_List loop - Check - (In_Tree.Project_Lists.Table - (Current).Project); - Current := In_Tree.Project_Lists.Table - (Current).Next; - end loop; - end; - end if; - end Check; - - --------------------- - -- Check_Temp_File -- - --------------------- - - procedure Check_Temp_File is - begin - if File = Invalid_FD then - Tempdir.Create_Temp_File (File, Name => File_Name); - - if File = Invalid_FD then - Prj.Com.Fail - ("unable to create temporary configuration pragmas file"); - - else - Record_Temp_File (File_Name); - - if Opt.Verbose_Mode then - Write_Str ("Creating temp file """); - Write_Str (Get_Name_String (File_Name)); - Write_Line (""""); - end if; - end if; - end if; - end Check_Temp_File; - - --------- - -- Put -- - --------- - - procedure Put - (Unit_Name : Name_Id; - File_Name : File_Name_Type; - Unit_Kind : Spec_Or_Body; - Index : Int) - is - begin - -- A temporary file needs to be open - - Check_Temp_File; - - -- Put the pragma SFN for the unit kind (spec or body) - - Put (File, "pragma Source_File_Name_Project ("); - Put (File, Namet.Get_Name_String (Unit_Name)); - - if Unit_Kind = Specification then - Put (File, ", Spec_File_Name => """); - else - Put (File, ", Body_File_Name => """); - end if; - - Put (File, Namet.Get_Name_String (File_Name)); - Put (File, """"); - - if Index /= 0 then - Put (File, ", Index =>"); - Put (File, Index'Img); - end if; - - Put_Line (File, ");"); - end Put; - - procedure Put (File : File_Descriptor; S : String) is - Last : Natural; - - begin - Last := Write (File, S (S'First)'Address, S'Length); - - if Last /= S'Length then - Prj.Com.Fail ("Disk full"); - end if; - - if Current_Verbosity = High then - Write_Str (S); - end if; - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (File : File_Descriptor; S : String) is - S0 : String (1 .. S'Length + 1); - Last : Natural; - - 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. - - S0 (1 .. S'Length) := S; - S0 (S0'Last) := ASCII.LF; - Last := Write (File, S0'Address, S0'Length); - - if Last /= S'Length + 1 then - Prj.Com.Fail ("Disk full"); - end if; - - if Current_Verbosity = High then - Write_Line (S); - end if; - end Put_Line; - - -- Start of processing for Create_Config_Pragmas_File - - begin - if not - In_Tree.Projects.Table (For_Project).Config_Checked - then - - -- Remove any memory of processed naming schemes, if any - - Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming); - - -- Check the naming schemes - - Check (For_Project); - - -- Visit all the units and process those that need an SFN pragma - - while - Current_Unit <= Unit_Table.Last (In_Tree.Units) - loop - declare - Unit : constant Unit_Data := - In_Tree.Units.Table (Current_Unit); - - begin - if Unit.File_Names (Specification).Needs_Pragma then - Put (Unit.Name, - Unit.File_Names (Specification).Name, - Specification, - Unit.File_Names (Specification).Index); - end if; - - if Unit.File_Names (Body_Part).Needs_Pragma then - Put (Unit.Name, - Unit.File_Names (Body_Part).Name, - Body_Part, - Unit.File_Names (Body_Part).Index); - end if; - - Current_Unit := Current_Unit + 1; - end; - end loop; - - -- 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 File = Invalid_FD then - Check_Temp_File; - - Put_Line (File, "pragma Source_File_Name_Project"); - Put_Line (File, " (Spec_File_Name => ""*.ads"","); - Put_Line (File, " Dot_Replacement => ""-"","); - Put_Line (File, " Casing => lowercase);"); - - Put_Line (File, "pragma Source_File_Name_Project"); - Put_Line (File, " (Body_File_Name => ""*.adb"","); - Put_Line (File, " Dot_Replacement => ""-"","); - Put_Line (File, " Casing => lowercase);"); - end if; - - -- Close the temporary file - - GNAT.OS_Lib.Close (File, Status); - - if not Status then - Prj.Com.Fail ("disk full"); - end if; - - if Opt.Verbose_Mode then - Write_Str ("Closing configuration file """); - Write_Str (Get_Name_String (File_Name)); - Write_Line (""""); - end if; - - In_Tree.Projects.Table (For_Project).Config_File_Name := - File_Name; - In_Tree.Projects.Table (For_Project).Config_File_Temp := - True; - - In_Tree.Projects.Table (For_Project).Config_Checked := - True; - end if; - end Create_Config_Pragmas_File; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping (In_Tree : Project_Tree_Ref) is - The_Unit_Data : Unit_Data; - Data : File_Name_Data; - - begin - Fmap.Reset_Tables; - - for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop - The_Unit_Data := In_Tree.Units.Table (Unit); - - -- Process only if the unit has a valid name - - if The_Unit_Data.Name /= No_Name then - Data := The_Unit_Data.File_Names (Specification); - - -- If there is a spec, put it in the mapping - - if Data.Name /= No_File then - if Data.Path.Name = Slash then - Fmap.Add_Forbidden_File_Name (Data.Name); - else - Fmap.Add_To_File_Map - (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), - File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path.Name)); - end if; - end if; - - Data := The_Unit_Data.File_Names (Body_Part); - - -- If there is a body (or subunit) put it in the mapping - - if Data.Name /= No_File then - if Data.Path.Name = Slash then - Fmap.Add_Forbidden_File_Name (Data.Name); - else - Fmap.Add_To_File_Map - (Unit_Name => Unit_Name_Type (The_Unit_Data.Name), - File_Name => Data.Name, - Path_Name => File_Name_Type (Data.Path.Name)); - end if; - end if; - end if; - end loop; - end Create_Mapping; - - ------------------------- - -- Create_Mapping_File -- - ------------------------- - - procedure Create_Mapping_File - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Name : out Path_Name_Type) - is - File : File_Descriptor := Invalid_FD; - The_Unit_Data : Unit_Data; - Data : File_Name_Data; - - Status : Boolean; - -- For call to Close - - Present : Project_Flags - (No_Project .. Project_Table.Last (In_Tree.Projects)) := - (others => False); - -- For each project in the closure of Project, the corresponding flag - -- will be set to True; - - procedure Put_Name_Buffer; - -- Put the line contained in the Name_Buffer in the mapping file - - procedure Put_Data (Spec : Boolean); - -- Put the mapping of the spec or body contained in Data in the file - -- (3 lines). - - procedure Recursive_Flag (Prj : Project_Id); - -- Set the flags corresponding to Prj, the projects it imports - -- (directly or indirectly) or extends to True. Call itself recursively. - - --------- - -- Put -- - --------- - - procedure Put_Name_Buffer is - Last : Natural; - - begin - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ASCII.LF; - Last := Write (File, Name_Buffer (1)'Address, Name_Len); - - if Last /= Name_Len then - Prj.Com.Fail ("Disk full"); - end if; - end Put_Name_Buffer; - - -------------- - -- Put_Data -- - -------------- - - procedure Put_Data (Spec : Boolean) is - begin - -- Line with the unit name - - Get_Name_String (The_Unit_Data.Name); - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := '%'; - Name_Len := Name_Len + 1; - - if Spec then - Name_Buffer (Name_Len) := 's'; - else - Name_Buffer (Name_Len) := 'b'; - end if; - - Put_Name_Buffer; - - -- Line with the file name - - Get_Name_String (Data.Name); - Put_Name_Buffer; - - -- Line with the path name - - Get_Name_String (Data.Path.Name); - Put_Name_Buffer; - - end Put_Data; - - -------------------- - -- Recursive_Flag -- - -------------------- - - procedure Recursive_Flag (Prj : Project_Id) is - Imported : Project_List; - Proj : Project_Id; - - begin - -- Nothing to do for non existent project or project that has - -- already been flagged. - - if Prj = No_Project or else Present (Prj) then - return; - end if; - - -- Flag the current project - - Present (Prj) := True; - Imported := - In_Tree.Projects.Table (Prj).Imported_Projects; - - -- Call itself for each project directly imported - - while Imported /= Empty_Project_List loop - Proj := - In_Tree.Project_Lists.Table (Imported).Project; - Imported := - In_Tree.Project_Lists.Table (Imported).Next; - Recursive_Flag (Proj); - end loop; - - -- Call itself for an eventual project being extended - - Recursive_Flag (In_Tree.Projects.Table (Prj).Extends); - end Recursive_Flag; - - -- Start of processing for Create_Mapping_File - - begin - -- Flag the necessary projects - - Recursive_Flag (Project); - - -- Create the temporary file - - Tempdir.Create_Temp_File (File, Name => Name); - - if File = Invalid_FD then - Prj.Com.Fail ("unable to create temporary mapping file"); - - else - Record_Temp_File (Name); - - if Opt.Verbose_Mode then - Write_Str ("Creating temp mapping file """); - Write_Str (Get_Name_String (Name)); - Write_Line (""""); - end if; - end if; - - if Fill_Mapping_File then - - -- For all units in table Units - - for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop - The_Unit_Data := In_Tree.Units.Table (Unit); - - -- If the unit has a valid name - - if The_Unit_Data.Name /= No_Name then - Data := The_Unit_Data.File_Names (Specification); - - -- If there is a spec, put it mapping in the file if it is - -- from a project in the closure of Project. - - if Data.Name /= No_File and then Present (Data.Project) then - Put_Data (Spec => True); - end if; - - Data := The_Unit_Data.File_Names (Body_Part); - - -- If there is a body (or subunit) put its mapping in the file - -- if it is from a project in the closure of Project. - - if Data.Name /= No_File and then Present (Data.Project) then - Put_Data (Spec => False); - end if; - - end if; - end loop; - end if; - - GNAT.OS_Lib.Close (File, Status); - - if not Status then - Prj.Com.Fail ("disk full"); - end if; - end 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; - - Status : Boolean; - -- For call to Close - - Present : Project_Flags - (No_Project .. Project_Table.Last (In_Tree.Projects)) := - (others => False); - -- For each project in the closure of Project, the corresponding flag - -- will be set to True. - - Source : Source_Id; - Src_Data : Source_Data; - Suffix : File_Name_Type; - - procedure Put_Name_Buffer; - -- Put the line contained in the Name_Buffer in the mapping file - - procedure Recursive_Flag (Prj : Project_Id); - -- Set the flags corresponding to Prj, the projects it imports - -- (directly or indirectly) or extends to True. Call itself recursively. - - --------- - -- Put -- - --------- - - procedure Put_Name_Buffer is - Last : Natural; - - begin - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ASCII.LF; - Last := Write (File, Name_Buffer (1)'Address, Name_Len); - - if Last /= Name_Len then - Prj.Com.Fail ("Disk full"); - end if; - end Put_Name_Buffer; - - -------------------- - -- Recursive_Flag -- - -------------------- - - procedure Recursive_Flag (Prj : Project_Id) is - Imported : Project_List; - Proj : Project_Id; - - begin - -- Nothing to do for non existent project or project that has already - -- been flagged. - - if Prj = No_Project or else Present (Prj) then - return; - end if; - - -- Flag the current project - - Present (Prj) := True; - Imported := - In_Tree.Projects.Table (Prj).Imported_Projects; - - -- Call itself for each project directly imported - - while Imported /= Empty_Project_List loop - Proj := - In_Tree.Project_Lists.Table (Imported).Project; - Imported := - In_Tree.Project_Lists.Table (Imported).Next; - Recursive_Flag (Proj); - end loop; - - -- Call itself for an eventual project being extended - - Recursive_Flag (In_Tree.Projects.Table (Prj).Extends); - end Recursive_Flag; - - -- Start of processing for Create_Mapping_File - - begin - -- Flag the necessary projects - - Recursive_Flag (Project); - - -- Create the temporary file - - Tempdir.Create_Temp_File (File, Name => Name); - - if File = Invalid_FD then - Prj.Com.Fail ("unable to create temporary mapping file"); - - else - Record_Temp_File (Name); - - if Opt.Verbose_Mode then - Write_Str ("Creating temp mapping file """); - Write_Str (Get_Name_String (Name)); - Write_Line (""""); - end if; - end if; - - -- For all source of the Language of all projects in the closure - - for Proj in Present'Range loop - if Present (Proj) then - Source := In_Tree.Projects.Table (Proj).First_Source; - - while Source /= No_Source loop - Src_Data := In_Tree.Sources.Table (Source); - - if Src_Data.Language_Name = Language - and then not Src_Data.Locally_Removed - and then Src_Data.Replaced_By = No_Source - and then Src_Data.Path.Name /= No_Path - then - if Src_Data.Unit /= No_Name then - Get_Name_String (Src_Data.Unit); - - if Src_Data.Kind = Spec then - Suffix := - In_Tree.Languages_Data.Table - (Src_Data.Language).Config.Mapping_Spec_Suffix; - else - Suffix := - In_Tree.Languages_Data.Table - (Src_Data.Language).Config.Mapping_Body_Suffix; - end if; - - if Suffix /= No_File then - Add_Str_To_Name_Buffer (Get_Name_String (Suffix)); - end if; - - Put_Name_Buffer; - end if; - - Get_Name_String (Src_Data.File); - Put_Name_Buffer; - - Get_Name_String (Src_Data.Path.Name); - Put_Name_Buffer; - end if; - - Source := Src_Data.Next_In_Project; - end loop; - end if; - end loop; - - GNAT.OS_Lib.Close (File, Status); - - if not Status then - Prj.Com.Fail ("disk full"); - end if; - end Create_Mapping_File; - - -------------------------- - -- Create_New_Path_File -- - -------------------------- - - procedure Create_New_Path_File - (In_Tree : Project_Tree_Ref; - Path_FD : out File_Descriptor; - Path_Name : out Path_Name_Type) - is - begin - Tempdir.Create_Temp_File (Path_FD, Path_Name); - - if Path_Name /= No_Path then - Record_Temp_File (Path_Name); - - -- Record the name, so that the temp path file will be deleted at the - -- end of the program. - - Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files); - In_Tree.Private_Part.Path_Files.Table - (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) := - Path_Name; - end if; - end Create_New_Path_File; - - --------------------------- - -- Delete_All_Path_Files -- - --------------------------- - - procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is - Disregard : Boolean := True; - pragma Warnings (Off, Disregard); - - begin - for Index in Path_File_Table.First .. - Path_File_Table.Last (In_Tree.Private_Part.Path_Files) - loop - if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then - Delete_File - (Get_Name_String - (In_Tree.Private_Part.Path_Files.Table (Index)), - Disregard); - end if; - end loop; - - -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or - -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to - -- the empty string. On VMS, this has the effect of deassigning - -- the logical names. - - if Ada_Prj_Include_File_Set then - Setenv (Project_Include_Path_File, ""); - Ada_Prj_Include_File_Set := False; - end if; - - if Ada_Prj_Objects_File_Set then - Setenv (Project_Objects_Path_File, ""); - Ada_Prj_Objects_File_Set := False; - end if; - end Delete_All_Path_Files; - - ------------------------------------ - -- 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 - The_Project : Project_Id := Project; - Data : Project_Data := - In_Tree.Projects.Table (Project); - Original_Name : String := Name; - - Extended_Spec_Name : String := - Name & - Spec_Suffix_Of (In_Tree, "ada", Data.Naming); - Extended_Body_Name : String := - Name & - Body_Suffix_Of (In_Tree, "ada", Data.Naming); - - Unit : Unit_Data; - - The_Original_Name : Name_Id; - The_Spec_Name : Name_Id; - The_Body_Name : Name_Id; - - begin - Canonical_Case_File_Name (Original_Name); - Name_Len := Original_Name'Length; - Name_Buffer (1 .. Name_Len) := Original_Name; - The_Original_Name := Name_Find; - - 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; - - 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 (Extended_Spec_Name); - Write_Char ('"'); - Write_Eol; - Write_Str (" Extended Body Name = """); - Write_Str (Extended_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 - -- Should have comment explaining reverse ??? - - for Current in reverse Unit_Table.First .. - Unit_Table.Last (In_Tree.Units) - loop - Unit := In_Tree.Units.Table (Current); - - -- Check for body - - if not Main_Project_Only - or else Unit.File_Names (Body_Part).Project = The_Project - then - declare - Current_Name : constant File_Name_Type := - Unit.File_Names (Body_Part).Name; - - begin - -- Case of a body present - - if Current_Name /= No_File then - 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 (Body_Part).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 (Body_Part).Path.Name); - - else - return Extended_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 (Specification).Project = The_Project - then - declare - Current_Name : constant File_Name_Type := - Unit.File_Names (Specification).Name; - - begin - -- Case of spec present - - if Current_Name /= No_File then - 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 (Specification).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 (Specification).Path.Name); - else - return Extended_Spec_Name; - end if; - - else - if Current_Verbosity = High then - Write_Line (" not good"); - end if; - end if; - end if; - end; - end if; - end loop; - - -- If we are not in an extending project, give up - - exit when (not Main_Project_Only) or else Data.Extends = No_Project; - - -- Otherwise, look in the project we are extending - - The_Project := Data.Extends; - Data := In_Tree.Projects.Table (The_Project); - 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; - In_Tree : Project_Tree_Ref) - is - Seen : Project_List := Empty_Project_List; - - procedure Add (Project : Project_Id); - -- Process a project. Remember the processes visited to avoid processing - -- a project twice. Recursively process an eventual extended project, - -- and all imported projects. - - --------- - -- Add -- - --------- - - procedure Add (Project : Project_Id) is - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - List : Project_List := Data.Imported_Projects; - - begin - -- If the list of visited project is empty, then - -- for sure we never visited this project. - - if Seen = Empty_Project_List then - Project_List_Table.Increment_Last (In_Tree.Project_Lists); - Seen := Project_List_Table.Last (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table (Seen) := - (Project => Project, Next => Empty_Project_List); - - else - -- Check if the project is in the list - - declare - Current : Project_List := Seen; - - begin - loop - -- If it is, then there is nothing else to do - - if In_Tree.Project_Lists.Table - (Current).Project = Project - then - return; - end if; - - exit when - In_Tree.Project_Lists.Table (Current).Next = - Empty_Project_List; - Current := - In_Tree.Project_Lists.Table (Current).Next; - end loop; - - -- This project has never been visited, add it - -- to the list. - - Project_List_Table.Increment_Last - (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table (Current).Next := - Project_List_Table.Last (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table - (Project_List_Table.Last - (In_Tree.Project_Lists)) := - (Project => Project, Next => Empty_Project_List); - end; - end if; - - -- If there is an object directory, call Action with its name - - if Data.Object_Directory /= No_Path_Information then - Get_Name_String (Data.Object_Directory.Display_Name); - Action (Name_Buffer (1 .. Name_Len)); - end if; - - -- If we are extending a project, visit it - - if Data.Extends /= No_Project then - Add (Data.Extends); - end if; - - -- And visit all imported projects - - while List /= Empty_Project_List loop - Add (In_Tree.Project_Lists.Table (List).Project); - List := In_Tree.Project_Lists.Table (List).Next; - end loop; - end Add; - - -- Start of processing for For_All_Object_Dirs - - begin - -- Visit this project, and its imported projects, recursively - - Add (Project); - end For_All_Object_Dirs; - - ------------------------- - -- For_All_Source_Dirs -- - ------------------------- - - procedure For_All_Source_Dirs - (Project : Project_Id; - In_Tree : Project_Tree_Ref) - is - Seen : Project_List := Empty_Project_List; - - procedure Add (Project : Project_Id); - -- Process a project. Remember the processes visited to avoid processing - -- a project twice. Recursively process an eventual extended project, - -- and all imported projects. - - --------- - -- Add -- - --------- - - procedure Add (Project : Project_Id) is - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - List : Project_List := Data.Imported_Projects; - - begin - -- If the list of visited project is empty, then for sure we never - -- visited this project. - - if Seen = Empty_Project_List then - Project_List_Table.Increment_Last - (In_Tree.Project_Lists); - Seen := Project_List_Table.Last - (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table (Seen) := - (Project => Project, Next => Empty_Project_List); - - else - -- Check if the project is in the list - - declare - Current : Project_List := Seen; - - begin - loop - -- If it is, then there is nothing else to do - - if In_Tree.Project_Lists.Table - (Current).Project = Project - then - return; - end if; - - exit when - In_Tree.Project_Lists.Table (Current).Next = - Empty_Project_List; - Current := - In_Tree.Project_Lists.Table (Current).Next; - end loop; - - -- This project has never been visited, add it to the list - - Project_List_Table.Increment_Last - (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table (Current).Next := - Project_List_Table.Last (In_Tree.Project_Lists); - In_Tree.Project_Lists.Table - (Project_List_Table.Last - (In_Tree.Project_Lists)) := - (Project => Project, Next => Empty_Project_List); - end; - end if; - - declare - Current : String_List_Id := Data.Source_Dirs; - The_String : String_Element; - - begin - -- If there are Ada sources, call action with the name of every - -- source directory. - - if - In_Tree.Projects.Table (Project).Ada_Sources /= Nil_String - then - while Current /= Nil_String loop - The_String := - In_Tree.String_Elements.Table (Current); - Action (Get_Name_String (The_String.Display_Value)); - Current := The_String.Next; - end loop; - end if; - end; - - -- If we are extending a project, visit it - - if Data.Extends /= No_Project then - Add (Data.Extends); - end if; - - -- And visit all imported projects - - while List /= Empty_Project_List loop - Add (In_Tree.Project_Lists.Table (List).Project); - List := In_Tree.Project_Lists.Table (List).Next; - end loop; - end Add; - - -- Start of processing for For_All_Source_Dirs - - begin - -- Visit this project, and its imported projects recursively - - Add (Project); - 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_Data; - - begin - Canonical_Case_File_Name (Original_Name); - - for Id in Unit_Table.First .. - Unit_Table.Last (In_Tree.Units) - loop - Unit := In_Tree.Units.Table (Id); - - if (Unit.File_Names (Specification).Name /= No_File - and then - Namet.Get_Name_String - (Unit.File_Names (Specification).Name) = Original_Name) - or else (Unit.File_Names (Specification).Path /= - No_Path_Information - and then - Namet.Get_Name_String - (Unit.File_Names (Specification).Path.Name) = - Original_Name) - then - Project := Ultimate_Extension_Of - (Project => Unit.File_Names (Specification).Project, - In_Tree => In_Tree); - Path := Unit.File_Names (Specification).Path.Display_Name; - - if Current_Verbosity > Default then - Write_Str ("Done: Specification."); - Write_Eol; - end if; - - return; - - elsif (Unit.File_Names (Body_Part).Name /= No_File - and then - Namet.Get_Name_String - (Unit.File_Names (Body_Part).Name) = Original_Name) - or else (Unit.File_Names (Body_Part).Path /= No_Path_Information - and then Namet.Get_Name_String - (Unit.File_Names (Body_Part).Path.Name) = - Original_Name) - then - Project := Ultimate_Extension_Of - (Project => Unit.File_Names (Body_Part).Project, - In_Tree => In_Tree); - Path := Unit.File_Names (Body_Part).Path.Display_Name; - - if Current_Verbosity > Default then - Write_Str ("Done: Body."); - Write_Eol; - end if; - - return; - end if; - 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; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Fill_Mapping_File := True; - Current_Source_Path_File := No_Path; - Current_Object_Path_File := No_Path; - end Initialize; - - ------------------------------------ - -- Path_Name_Of_Library_Unit_Body -- - ------------------------------------ - - -- Could use some comments in the body here ??? - - function Path_Name_Of_Library_Unit_Body - (Name : String; - Project : Project_Id; - In_Tree : Project_Tree_Ref) return String - is - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - Original_Name : String := Name; - - Extended_Spec_Name : String := - Name & - Spec_Suffix_Of (In_Tree, "ada", Data.Naming); - Extended_Body_Name : String := - Name & - Body_Suffix_Of (In_Tree, "ada", Data.Naming); - - First : Unit_Index := Unit_Table.First; - Current : Unit_Index; - Unit : Unit_Data; - - begin - Canonical_Case_File_Name (Original_Name); - Canonical_Case_File_Name (Extended_Spec_Name); - Canonical_Case_File_Name (Extended_Body_Name); - - if Current_Verbosity = High then - Write_Str ("Looking for path name of """); - Write_Str (Name); - Write_Char ('"'); - Write_Eol; - Write_Str (" Extended Spec Name = """); - Write_Str (Extended_Spec_Name); - Write_Char ('"'); - Write_Eol; - Write_Str (" Extended Body Name = """); - Write_Str (Extended_Body_Name); - Write_Char ('"'); - Write_Eol; - end if; - - while First <= Unit_Table.Last (In_Tree.Units) - and then In_Tree.Units.Table - (First).File_Names (Body_Part).Project /= Project - loop - First := First + 1; - end loop; - - Current := First; - while Current <= Unit_Table.Last (In_Tree.Units) loop - Unit := In_Tree.Units.Table (Current); - - if Unit.File_Names (Body_Part).Project = Project - and then Unit.File_Names (Body_Part).Name /= No_File - then - declare - Current_Name : constant String := - Namet.Get_Name_String (Unit.File_Names (Body_Part).Name); - begin - if Current_Verbosity = High then - Write_Str (" Comparing with """); - Write_Str (Current_Name); - Write_Char ('"'); - Write_Eol; - end if; - - if Current_Name = Original_Name then - if Current_Verbosity = High then - Write_Line (" OK"); - end if; - - return Body_Path_Name_Of (Current, In_Tree); - - elsif Current_Name = Extended_Body_Name then - if Current_Verbosity = High then - Write_Line (" OK"); - end if; - - return Body_Path_Name_Of (Current, In_Tree); - - else - if Current_Verbosity = High then - Write_Line (" not good"); - end if; - end if; - end; - - elsif Unit.File_Names (Specification).Name /= No_File then - declare - Current_Name : constant String := - Namet.Get_Name_String - (Unit.File_Names (Specification).Name); - - begin - if Current_Verbosity = High then - Write_Str (" Comparing with """); - Write_Str (Current_Name); - Write_Char ('"'); - Write_Eol; - end if; - - if Current_Name = Original_Name then - if Current_Verbosity = High then - Write_Line (" OK"); - end if; - - return Spec_Path_Name_Of (Current, In_Tree); - - elsif Current_Name = Extended_Spec_Name then - if Current_Verbosity = High then - Write_Line (" OK"); - end if; - - return Spec_Path_Name_Of (Current, In_Tree); - - else - if Current_Verbosity = High then - Write_Line (" not good"); - end if; - end if; - end; - end if; - Current := Current + 1; - end loop; - - return ""; - end Path_Name_Of_Library_Unit_Body; - - ------------------- - -- Print_Sources -- - ------------------- - - -- Could use some comments in this body ??? - - procedure Print_Sources (In_Tree : Project_Tree_Ref) is - Unit : Unit_Data; - - begin - Write_Line ("List of Sources:"); - - for Id in Unit_Table.First .. - Unit_Table.Last (In_Tree.Units) - loop - Unit := In_Tree.Units.Table (Id); - Write_Str (" "); - Write_Line (Namet.Get_Name_String (Unit.Name)); - - if Unit.File_Names (Specification).Name /= No_File then - if Unit.File_Names (Specification).Project = No_Project then - Write_Line (" No project"); - - else - Write_Str (" Project: "); - Get_Name_String - (In_Tree.Projects.Table - (Unit.File_Names (Specification).Project).Path.Name); - Write_Line (Name_Buffer (1 .. Name_Len)); - end if; - - Write_Str (" spec: "); - Write_Line - (Namet.Get_Name_String - (Unit.File_Names (Specification).Name)); - end if; - - if Unit.File_Names (Body_Part).Name /= No_File then - if Unit.File_Names (Body_Part).Project = No_Project then - Write_Line (" No project"); - - else - Write_Str (" Project: "); - Get_Name_String - (In_Tree.Projects.Table - (Unit.File_Names (Body_Part).Project).Path.Name); - Write_Line (Name_Buffer (1 .. Name_Len)); - end if; - - Write_Str (" body: "); - Write_Line - (Namet.Get_Name_String - (Unit.File_Names (Body_Part).Name)); - end if; - 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; - - Data : constant Project_Data := - In_Tree.Projects.Table (Main_Project); - - Extended_Spec_Name : String := - Name & - Spec_Suffix_Of (In_Tree, "ada", Data.Naming); - Extended_Body_Name : String := - Name & - Body_Suffix_Of (In_Tree, "ada", Data.Naming); - - Unit : Unit_Data; - - Current_Name : File_Name_Type; - The_Original_Name : File_Name_Type; - The_Spec_Name : File_Name_Type; - The_Body_Name : File_Name_Type; - - begin - Canonical_Case_File_Name (Original_Name); - Name_Len := Original_Name'Length; - Name_Buffer (1 .. Name_Len) := Original_Name; - The_Original_Name := Name_Find; - - 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; - - for Current in reverse Unit_Table.First .. - Unit_Table.Last (In_Tree.Units) - loop - Unit := In_Tree.Units.Table (Current); - - -- Check for body - - Current_Name := Unit.File_Names (Body_Part).Name; - - -- Case of a body present - - if Current_Name /= No_File then - - -- 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 (Body_Part).Project; - exit; - end if; - end if; - - -- Check for spec - - Current_Name := Unit.File_Names (Specification).Name; - - if Current_Name /= No_File then - - -- 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 (Specification).Project; - exit; - end if; - end if; - end loop; - - -- Get the ultimate extending project - - if Result /= No_Project then - while In_Tree.Projects.Table (Result).Extended_By /= - No_Project - loop - Result := In_Tree.Projects.Table (Result).Extended_By; - end loop; - end if; - - return Result; - end Project_Of; - - ------------------- - -- Set_Ada_Paths -- - ------------------- - - procedure Set_Ada_Paths - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Including_Libraries : Boolean) - is - Source_FD : File_Descriptor := Invalid_FD; - Object_FD : File_Descriptor := Invalid_FD; - - Process_Source_Dirs : Boolean := False; - Process_Object_Dirs : Boolean := False; - - Status : Boolean; - -- For calls to Close - - Len : Natural; - - procedure Add (Proj : Project_Id); - -- Add all the source/object directories of a project to the path only - -- if this project has not been visited. Calls an internal procedure - -- recursively for projects being extended, and imported projects. - - --------- - -- Add -- - --------- - - procedure Add (Proj : Project_Id) is - - procedure Recursive_Add (Project : Project_Id); - -- Recursive procedure to add the source/object paths of extended/ - -- imported projects. - - ------------------- - -- Recursive_Add -- - ------------------- - - procedure Recursive_Add (Project : Project_Id) is - begin - -- If Seen is False, then the project has not yet been visited - - if not In_Tree.Projects.Table (Project).Seen then - In_Tree.Projects.Table (Project).Seen := True; - - declare - Data : constant Project_Data := - In_Tree.Projects.Table (Project); - List : Project_List := Data.Imported_Projects; - - begin - if Process_Source_Dirs then - - -- Add to path all source directories of this project if - -- there are Ada sources. - - if In_Tree.Projects.Table (Project).Ada_Sources /= - Nil_String - then - Add_To_Source_Path (Data.Source_Dirs, In_Tree); - end if; - end if; - - if Process_Object_Dirs then - - -- Add to path the object directory of this project - -- except if we don't include library project and this - -- is a library project. - - if (Data.Library and Including_Libraries) - or else - (Data.Object_Directory /= No_Path_Information - and then - (not Including_Libraries or else not Data.Library)) - then - -- For a library project, add the library ALI - -- directory if there is no object directory or - -- if the library ALI directory contains ALI files; - -- otherwise add the object directory. - - if Data.Library then - if Data.Object_Directory = No_Path_Information - or else Contains_ALI_Files - (Data.Library_ALI_Dir.Name) - then - Add_To_Object_Path - (Data.Library_ALI_Dir.Name, In_Tree); - else - Add_To_Object_Path - (Data.Object_Directory.Name, In_Tree); - end if; - - -- For a non-library project, add object directory if - -- it is not a virtual project, and if there are Ada - -- sources in the project or one of the projects it - -- extends. If there are no Ada sources, adding the - -- object directory could disrupt the order of the - -- object dirs in the path. - - elsif not Data.Virtual then - declare - Add_Object_Dir : Boolean := False; - Prj : Project_Id := Project; - - begin - while not Add_Object_Dir - and then Prj /= No_Project - loop - if In_Tree.Projects.Table - (Prj).Ada_Sources /= Nil_String - then - Add_Object_Dir := True; - - else - Prj := - In_Tree.Projects.Table (Prj).Extends; - end if; - end loop; - - if Add_Object_Dir then - Add_To_Object_Path - (Data.Object_Directory.Name, In_Tree); - end if; - end; - end if; - end if; - end if; - - -- Call Add to the project being extended, if any - - if Data.Extends /= No_Project then - Recursive_Add (Data.Extends); - end if; - - -- Call Add for each imported project, if any - - while List /= Empty_Project_List loop - Recursive_Add - (In_Tree.Project_Lists.Table - (List).Project); - List := - In_Tree.Project_Lists.Table (List).Next; - end loop; - end; - end if; - end Recursive_Add; - - begin - Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0); - Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0); - - for Index in Project_Table.First .. - Project_Table.Last (In_Tree.Projects) - loop - In_Tree.Projects.Table (Index).Seen := False; - end loop; - - Recursive_Add (Proj); - end Add; - - -- 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 In_Tree.Projects.Table (Project).Include_Path_File = No_Path then - Process_Source_Dirs := True; - Create_New_Path_File - (In_Tree, Source_FD, - In_Tree.Projects.Table (Project).Include_Path_File); - end if; - - -- For the object path, we make a distinction depending on - -- Including_Libraries. - - if Including_Libraries then - if In_Tree.Projects.Table - (Project).Objects_Path_File_With_Libs = No_Path - then - Process_Object_Dirs := True; - Create_New_Path_File - (In_Tree, Object_FD, In_Tree.Projects.Table (Project). - Objects_Path_File_With_Libs); - end if; - - else - if In_Tree.Projects.Table - (Project).Objects_Path_File_Without_Libs = No_Path - then - Process_Object_Dirs := True; - Create_New_Path_File - (In_Tree, Object_FD, In_Tree.Projects.Table (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 - Add (Project); - end if; - - -- Write and close any file that has been created - - if Source_FD /= Invalid_FD then - for Index in Source_Path_Table.First .. - Source_Path_Table.Last - (In_Tree.Private_Part.Source_Paths) - loop - Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index)); - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ASCII.LF; - Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len); - - if Len /= Name_Len then - Prj.Com.Fail ("disk full"); - end if; - end loop; - - Close (Source_FD, Status); - - if not Status then - Prj.Com.Fail ("disk full"); - end if; - end if; - - if Object_FD /= Invalid_FD then - for Index in Object_Path_Table.First .. - Object_Path_Table.Last - (In_Tree.Private_Part.Object_Paths) - loop - Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index)); - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ASCII.LF; - Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len); - - if Len /= Name_Len then - Prj.Com.Fail ("disk full"); - end if; - end loop; - - Close (Object_FD, Status); - - if not Status then - Prj.Com.Fail ("disk full"); - end if; - end if; - - -- Set the env vars, if they need to be changed, and set the - -- corresponding flags. - - if Current_Source_Path_File /= - In_Tree.Projects.Table (Project).Include_Path_File - then - Current_Source_Path_File := - In_Tree.Projects.Table (Project).Include_Path_File; - Set_Path_File_Var - (Project_Include_Path_File, - Get_Name_String (Current_Source_Path_File)); - Ada_Prj_Include_File_Set := True; - end if; - - if Including_Libraries then - if Current_Object_Path_File - /= In_Tree.Projects.Table - (Project).Objects_Path_File_With_Libs - then - Current_Object_Path_File := - In_Tree.Projects.Table - (Project).Objects_Path_File_With_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String (Current_Object_Path_File)); - Ada_Prj_Objects_File_Set := True; - end if; - - else - if Current_Object_Path_File /= - In_Tree.Projects.Table - (Project).Objects_Path_File_Without_Libs - then - Current_Object_Path_File := - In_Tree.Projects.Table - (Project).Objects_Path_File_Without_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String (Current_Object_Path_File)); - Ada_Prj_Objects_File_Set := True; - end if; - end if; - end Set_Ada_Paths; - - --------------------------------------------- - -- Set_Mapping_File_Initial_State_To_Empty -- - --------------------------------------------- - - procedure Set_Mapping_File_Initial_State_To_Empty is - begin - Fill_Mapping_File := False; - end Set_Mapping_File_Initial_State_To_Empty; - - ----------------------- - -- Set_Path_File_Var -- - ----------------------- - - procedure Set_Path_File_Var (Name : String; Value : String) is - Host_Spec : String_Access := To_Host_File_Spec (Value); - - begin - if Host_Spec = null then - Prj.Com.Fail - ("could not convert file name """, Value, """ to host spec"); - else - Setenv (Name, Host_Spec.all); - Free (Host_Spec); - end if; - end Set_Path_File_Var; - - ----------------------- - -- Spec_Path_Name_Of -- - ----------------------- - - function Spec_Path_Name_Of - (Unit : Unit_Index; In_Tree : Project_Tree_Ref) return String - is - Data : Unit_Data := In_Tree.Units.Table (Unit); - - begin - if Data.File_Names (Specification).Path.Name = No_Path then - declare - Current_Source : String_List_Id := - In_Tree.Projects.Table - (Data.File_Names (Specification).Project).Ada_Sources; - Path : GNAT.OS_Lib.String_Access; - - begin - Data.File_Names (Specification).Path.Name := - Path_Name_Type (Data.File_Names (Specification).Name); - - while Current_Source /= Nil_String loop - Path := Locate_Regular_File - (Namet.Get_Name_String - (Data.File_Names (Specification).Name), - Namet.Get_Name_String - (In_Tree.String_Elements.Table - (Current_Source).Value)); - - if Path /= null then - Name_Len := Path'Length; - Name_Buffer (1 .. Name_Len) := Path.all; - Data.File_Names (Specification).Path.Name := Name_Enter; - exit; - else - Current_Source := - In_Tree.String_Elements.Table - (Current_Source).Next; - end if; - end loop; - - In_Tree.Units.Table (Unit) := Data; - end; - end if; - - return Namet.Get_Name_String (Data.File_Names (Specification).Path.Name); - end Spec_Path_Name_Of; - - --------------------------- - -- Ultimate_Extension_Of -- - --------------------------- - - function Ultimate_Extension_Of - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return Project_Id - is - Result : Project_Id := Project; - - begin - while In_Tree.Projects.Table (Result).Extended_By /= - No_Project - loop - Result := In_Tree.Projects.Table (Result).Extended_By; - end loop; - - return Result; - end Ultimate_Extension_Of; - -end Prj.Env; |