------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . E N V -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 2001-2002 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Namet; use Namet; with Opt; with Osint; use Osint; with Output; use Output; with Prj.Com; use Prj.Com; with Prj.Util; with Snames; use Snames; with Stringt; use Stringt; with Table; package body Prj.Env is type Naming_Id is new Nat; Ada_Path_Buffer : String_Access := new String (1 .. 1_000); -- 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. package Namings is new Table.Table ( Table_Component_Type => Naming_Data, Table_Index_Type => Naming_Id, Table_Low_Bound => 1, Table_Initial => 5, Table_Increment => 100, Table_Name => "Prj.Env.Namings"); Default_Naming : constant Naming_Id := Namings.First; Global_Configuration_Pragmas : Name_Id; Local_Configuration_Pragmas : Name_Id; Fill_Mapping_File : Boolean := True; ----------------------- -- Local Subprograms -- ----------------------- function Body_Path_Name_Of (Unit : Unit_Id) return String; -- Returns the path name of the body of a unit. -- Compute it first, if necessary. function Spec_Path_Name_Of (Unit : Unit_Id) 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); -- Add to Ada_Path_Buffer all the source directories in string list -- Source_Dirs, if any. Increment Ada_Path_Length. procedure Add_To_Path (Path : String); -- Add Path to global variable Ada_Path_Buffer -- Increment Ada_Path_Length ---------------------- -- Ada_Include_Path -- ---------------------- function Ada_Include_Path (Project : Project_Id) 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 modified, 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 Projects.Table (Project).Seen then Projects.Table (Project).Seen := True; declare Data : Project_Data := 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); -- Call Add to the project being modified, if any if Data.Modifies /= No_Project then Add (Data.Modifies); end if; -- Call Add for each imported project, if any while List /= Empty_Project_List loop Add (Project_Lists.Table (List).Project); List := 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 Projects.Table (Project).Include_Path = null then Ada_Path_Length := 0; for Index in 1 .. Projects.Last loop Projects.Table (Index).Seen := False; end loop; Add (Project); Projects.Table (Project).Include_Path := new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); end if; return Projects.Table (Project).Include_Path; end Ada_Include_Path; function Ada_Include_Path (Project : Project_Id; Recursive : Boolean) return String is begin if Recursive then return Ada_Include_Path (Project).all; else Ada_Path_Length := 0; Add_To_Path (Projects.Table (Project).Source_Dirs); return Ada_Path_Buffer (1 .. Ada_Path_Length); end if; end Ada_Include_Path; ---------------------- -- Ada_Objects_Path -- ---------------------- function Ada_Objects_Path (Project : Project_Id; 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 modified, 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 Projects.Table (Project).Seen then Projects.Table (Project).Seen := True; declare Data : Project_Data := 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_Name and then (not Including_Libraries or else not Data.Library)) then if Ada_Path_Length > 0 then Add_To_Path (Path => (1 => Path_Separator)); end if; -- For a library project, att the library directory if Data.Library then declare New_Path : constant String := Get_Name_String (Data.Library_Dir); begin Add_To_Path (New_Path); end; else -- For a non library project, add the object directory declare New_Path : constant String := Get_Name_String (Data.Object_Directory); begin Add_To_Path (New_Path); end; end if; end if; -- Call Add to the project being modified, if any if Data.Modifies /= No_Project then Add (Data.Modifies); end if; -- Call Add for each imported project, if any while List /= Empty_Project_List loop Add (Project_Lists.Table (List).Project); List := 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 Projects.Table (Project).Objects_Path = null then Ada_Path_Length := 0; for Index in 1 .. Projects.Last loop Projects.Table (Index).Seen := False; end loop; Add (Project); Projects.Table (Project).Objects_Path := new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); end if; return Projects.Table (Project).Objects_Path; end Ada_Objects_Path; ----------------- -- Add_To_Path -- ----------------- procedure Add_To_Path (Source_Dirs : String_List_Id) is Current : String_List_Id := Source_Dirs; Source_Dir : String_Element; begin while Current /= Nil_String loop if Ada_Path_Length > 0 then Add_To_Path (Path => (1 => Path_Separator)); end if; Source_Dir := String_Elements.Table (Current); String_To_Name_Buffer (Source_Dir.Value); declare New_Path : constant String := Name_Buffer (1 .. Name_Len); begin Add_To_Path (New_Path); end; Current := Source_Dir.Next; end loop; end Add_To_Path; procedure Add_To_Path (Path : String) is begin -- If Ada_Path_Buffer is too small, double it if Ada_Path_Length + Path'Length > Ada_Path_Buffer'Last then declare New_Ada_Path_Buffer : constant String_Access := new String (1 .. Ada_Path_Buffer'Last + Ada_Path_Buffer'Last); begin New_Ada_Path_Buffer (1 .. Ada_Path_Length) := Ada_Path_Buffer (1 .. Ada_Path_Length); Ada_Path_Buffer := New_Ada_Path_Buffer; end; end if; Ada_Path_Buffer (Ada_Path_Length + 1 .. Ada_Path_Length + Path'Length) := Path; Ada_Path_Length := Ada_Path_Length + Path'Length; end Add_To_Path; ----------------------- -- Body_Path_Name_Of -- ----------------------- function Body_Path_Name_Of (Unit : Unit_Id) return String is Data : Unit_Data := 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_Name then declare Current_Source : String_List_Id := Projects.Table (Data.File_Names (Body_Part).Project).Sources; Path : GNAT.OS_Lib.String_Access; begin -- By default, put the file name Data.File_Names (Body_Part).Path := Data.File_Names (Body_Part).Name; -- For each source directory while Current_Source /= Nil_String loop String_To_Name_Buffer (String_Elements.Table (Current_Source).Value); Path := Locate_Regular_File (Namet.Get_Name_String (Data.File_Names (Body_Part).Name), Name_Buffer (1 .. Name_Len)); -- 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_Enter; exit; else Current_Source := String_Elements.Table (Current_Source).Next; end if; end loop; Units.Table (Unit) := Data; end; end if; -- Returned the value stored return Namet.Get_Name_String (Data.File_Names (Body_Part).Path); end Body_Path_Name_Of; -------------------------------- -- Create_Config_Pragmas_File -- -------------------------------- procedure Create_Config_Pragmas_File (For_Project : Project_Id; Main_Project : Project_Id) is File_Name : Temp_File_Name; File : File_Descriptor := Invalid_FD; The_Packages : Package_Id; Gnatmake : Prj.Package_Id; Compiler : Prj.Package_Id; Current_Unit : Unit_Id := Units.First; First_Project : Project_List := Empty_Project_List; Current_Project : Project_List; Current_Naming : Naming_Id; Global_Attribute : Variable_Value := Nil_Variable_Value; Local_Attribute : Variable_Value := Nil_Variable_Value; Global_Attribute_Present : Boolean := False; Local_Attribute_Present : Boolean := False; procedure Check (Project : Project_Id); 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 Copy_File (Name : String_Id); -- Copy a configuration pragmas file into the temp file. procedure Put (Unit_Name : Name_Id; File_Name : Name_Id; Unit_Kind : Spec_Or_Body); -- Put an SFN pragma in the temporary file. procedure Put (File : File_Descriptor; S : String); procedure Put_Line (File : File_Descriptor; S : String); ----------- -- Check -- ----------- procedure Check (Project : Project_Id) is Data : constant Project_Data := 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 Project_Lists.Table (Current_Project).Project /= Project loop Current_Project := 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_Lists.Increment_Last; Project_Lists.Table (Project_Lists.Last) := (Project => Project, Next => First_Project); First_Project := Project_Lists.Last; -- Is the naming scheme of this project one that we know? Current_Naming := Default_Naming; while Current_Naming <= Namings.Last and then not Same_Naming_Scheme (Left => 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 > Namings.Last then Namings.Increment_Last; Namings.Table (Namings.Last) := 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"); Put_Line (File, " (Spec_File_Name => ""*" & Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix) & ""","); 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"); Put_Line (File, " (Body_File_Name => ""*" & Namet.Get_Name_String (Data.Naming.Current_Impl_Suffix) & ""","); 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 Data.Naming.Current_Impl_Suffix /= Data.Naming.Separate_Suffix then Put_Line (File, "pragma Source_File_Name"); 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.Modifies /= No_Project then Check (Data.Modifies); end if; declare Current : Project_List := Data.Imported_Projects; begin while Current /= Empty_Project_List loop Check (Project_Lists.Table (Current).Project); Current := 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 GNAT.OS_Lib.Create_Temp_File (File, Name => File_Name); if File = Invalid_FD then Osint.Fail ("unable to create temporary configuration pragmas file"); elsif Opt.Verbose_Mode then Write_Str ("Creating temp file """); Write_Str (File_Name); Write_Line (""""); end if; end if; end Check_Temp_File; --------------- -- Copy_File -- --------------- procedure Copy_File (Name : in String_Id) is Input : File_Descriptor; Buffer : String (1 .. 1_000); Input_Length : Integer; Output_Length : Integer; begin Check_Temp_File; String_To_Name_Buffer (Name); if Opt.Verbose_Mode then Write_Str ("Copying config pragmas file """); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Line (""" into temp file"); end if; declare Name : constant String := Name_Buffer (1 .. Name_Len) & ASCII.NUL; begin Input := Open_Read (Name'Address, Binary); end; if Input = Invalid_FD then Osint.Fail ("cannot open configuration pragmas file " & Name_Buffer (1 .. Name_Len)); end if; loop Input_Length := Read (Input, Buffer'Address, Buffer'Length); Output_Length := Write (File, Buffer'Address, Input_Length); if Output_Length /= Input_Length then Osint.Fail ("disk full"); end if; exit when Input_Length < Buffer'Length; end loop; Close (Input); end Copy_File; --------- -- Put -- --------- procedure Put (Unit_Name : Name_Id; File_Name : Name_Id; Unit_Kind : Spec_Or_Body) 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 ("); 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_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 Osint.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 gnat.adc 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 Osint.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 Projects.Table (For_Project).Config_Checked then -- Remove any memory of processed naming schemes, if any Namings.Set_Last (Default_Naming); -- Check the naming schemes Check (For_Project); -- Visit all the units and process those that need an SFN pragma while Current_Unit <= Units.Last loop declare Unit : constant Unit_Data := Units.Table (Current_Unit); begin if Unit.File_Names (Specification).Needs_Pragma then Put (Unit.Name, Unit.File_Names (Specification).Name, Specification); end if; if Unit.File_Names (Body_Part).Needs_Pragma then Put (Unit.Name, Unit.File_Names (Body_Part).Name, Body_Part); end if; Current_Unit := Current_Unit + 1; end; end loop; The_Packages := Projects.Table (Main_Project).Decl.Packages; Gnatmake := Prj.Util.Value_Of (Name => Name_Builder, In_Packages => The_Packages); if Gnatmake /= No_Package then Global_Attribute := Prj.Util.Value_Of (Variable_Name => Global_Configuration_Pragmas, In_Variables => Packages.Table (Gnatmake).Decl.Attributes); Global_Attribute_Present := Global_Attribute /= Nil_Variable_Value and then String_Length (Global_Attribute.Value) > 0; end if; The_Packages := Projects.Table (For_Project).Decl.Packages; Compiler := Prj.Util.Value_Of (Name => Name_Compiler, In_Packages => The_Packages); if Compiler /= No_Package then Local_Attribute := Prj.Util.Value_Of (Variable_Name => Local_Configuration_Pragmas, In_Variables => Packages.Table (Compiler).Decl.Attributes); Local_Attribute_Present := Local_Attribute /= Nil_Variable_Value and then String_Length (Local_Attribute.Value) > 0; end if; if Global_Attribute_Present then if File /= Invalid_FD or else Local_Attribute_Present then Copy_File (Global_Attribute.Value); else String_To_Name_Buffer (Global_Attribute.Value); Projects.Table (For_Project).Config_File_Name := Name_Find; end if; end if; if Local_Attribute_Present then if File /= Invalid_FD then Copy_File (Local_Attribute.Value); else String_To_Name_Buffer (Local_Attribute.Value); Projects.Table (For_Project).Config_File_Name := Name_Find; end if; end if; if File /= Invalid_FD then GNAT.OS_Lib.Close (File); if Opt.Verbose_Mode then Write_Str ("Closing configuration file """); Write_Str (File_Name); Write_Line (""""); end if; Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Projects.Table (For_Project).Config_File_Name := Name_Find; Projects.Table (For_Project).Config_File_Temp := True; end if; Projects.Table (For_Project).Config_Checked := True; end if; end Create_Config_Pragmas_File; ------------------------- -- Create_Mapping_File -- ------------------------- procedure Create_Mapping_File (Name : in out Temp_File_Name) is File : File_Descriptor := Invalid_FD; The_Unit_Data : Unit_Data; Data : File_Name_Data; 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). --------- -- 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 Osint.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 nale Get_Name_String (Data.Name); Put_Name_Buffer; -- Line with the path name Get_Name_String (Data.Path); Put_Name_Buffer; end Put_Data; -- Start of processing for Create_Mapping_File begin GNAT.OS_Lib.Create_Temp_File (File, Name => Name); if File = Invalid_FD then Osint.Fail ("unable to create temporary mapping file"); elsif Opt.Verbose_Mode then Write_Str ("Creating temp mapping file """); Write_Str (Name); Write_Line (""""); end if; if Fill_Mapping_File then -- For all units in table Units for Unit in 1 .. Units.Last loop The_Unit_Data := 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 Data.Name /= No_Name 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 Data.Name /= No_Name then Put_Data (Spec => False); end if; end if; end loop; end if; GNAT.OS_Lib.Close (File); end Create_Mapping_File; ------------------------------------ -- File_Name_Of_Library_Unit_Body -- ------------------------------------ function File_Name_Of_Library_Unit_Body (Name : String; Project : Project_Id) return String is Data : constant Project_Data := Projects.Table (Project); Original_Name : String := Name; Extended_Spec_Name : String := Name & Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix); Extended_Body_Name : String := Name & Namet.Get_Name_String (Data.Naming.Current_Impl_Suffix); 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 every unit for Current in reverse Units.First .. Units.Last loop Unit := Units.Table (Current); -- Case of unit of the same project if Unit.File_Names (Body_Part).Project = Project then declare Current_Name : constant Name_Id := Unit.File_Names (Body_Part).Name; begin -- Case of a body present if Current_Name /= No_Name 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 = The_Original_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Get_Name_String (Current_Name); -- If it has the name of the extended body name, -- return the extended body name elsif Current_Name = The_Body_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Extended_Body_Name; else if Current_Verbosity = High then Write_Line (" not good"); end if; end if; end if; end; end if; -- Case of a unit of the same project if Units.Table (Current).File_Names (Specification).Project = Project then declare Current_Name : constant Name_Id := Unit.File_Names (Specification).Name; begin -- Case of spec present if Current_Name /= No_Name 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 the original name, return original name if Unit.Name = The_Original_Name or else Current_Name = The_Original_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Get_Name_String (Current_Name); -- If it has the same name as the extended spec name, -- return the extended spec name. elsif Current_Name = The_Spec_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Extended_Spec_Name; else if Current_Verbosity = High then Write_Line (" not good"); end if; end if; end if; end; end if; 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) 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 -- modified project, and all imported projects. --------- -- Add -- --------- procedure Add (Project : Project_Id) is Data : constant Project_Data := 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_Lists.Increment_Last; Seen := Project_Lists.Last; 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 Project_Lists.Table (Current).Project = Project then return; end if; exit when Project_Lists.Table (Current).Next = Empty_Project_List; Current := Project_Lists.Table (Current).Next; end loop; -- This project has never been visited, add it -- to the list. Project_Lists.Increment_Last; Project_Lists.Table (Current).Next := Project_Lists.Last; Project_Lists.Table (Project_Lists.Last) := (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_Name then Get_Name_String (Data.Object_Directory); Action (Name_Buffer (1 .. Name_Len)); end if; -- If we are extending a project, visit it if Data.Modifies /= No_Project then Add (Data.Modifies); end if; -- And visit all imported projects while List /= Empty_Project_List loop Add (Project_Lists.Table (List).Project); List := 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) 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 -- modified project, and all imported projects. --------- -- Add -- --------- procedure Add (Project : Project_Id) is Data : constant Project_Data := 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_Lists.Increment_Last; Seen := Project_Lists.Last; 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 Project_Lists.Table (Current).Project = Project then return; end if; exit when Project_Lists.Table (Current).Next = Empty_Project_List; Current := Project_Lists.Table (Current).Next; end loop; -- This project has never been visited, add it -- to the list. Project_Lists.Increment_Last; Project_Lists.Table (Current).Next := Project_Lists.Last; Project_Lists.Table (Project_Lists.Last) := (Project => Project, Next => Empty_Project_List); end; end if; declare Current : String_List_Id := Data.Source_Dirs; The_String : String_Element; begin -- Call action with the name of every source directorie while Current /= Nil_String loop The_String := String_Elements.Table (Current); String_To_Name_Buffer (The_String.Value); Action (Name_Buffer (1 .. Name_Len)); Current := The_String.Next; end loop; end; -- If we are extending a project, visit it if Data.Modifies /= No_Project then Add (Data.Modifies); end if; -- And visit all imported projects while List /= Empty_Project_List loop Add (Project_Lists.Table (List).Project); List := 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; Project : out Project_Id; Path : out Name_Id) is begin 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 Units.First .. Units.Last loop Unit := Units.Table (Id); if (Unit.File_Names (Specification).Name /= No_Name and then Namet.Get_Name_String (Unit.File_Names (Specification).Name) = Original_Name) or else (Unit.File_Names (Specification).Path /= No_Name and then Namet.Get_Name_String (Unit.File_Names (Specification).Path) = Original_Name) then Project := Unit.File_Names (Specification).Project; Path := Unit.File_Names (Specification).Path; if Current_Verbosity > Default then Write_Str ("Done: Specification."); Write_Eol; end if; return; elsif (Unit.File_Names (Body_Part).Name /= No_Name and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Name) = Original_Name) or else (Unit.File_Names (Body_Part).Path /= No_Name and then Namet.Get_Name_String (Unit.File_Names (Body_Part).Path) = Original_Name) then Project := Unit.File_Names (Body_Part).Project; Path := Unit.File_Names (Body_Part).Path; if Current_Verbosity > Default then Write_Str ("Done: Body."); Write_Eol; end if; return; end if; end loop; end; Project := No_Project; Path := No_Name; if Current_Verbosity > Default then Write_Str ("Cannot be found."); Write_Eol; end if; end Get_Reference; ---------------- -- Initialize -- ---------------- procedure Initialize is Global : constant String := "global_configuration_pragmas"; Local : constant String := "local_configuration_pragmas"; begin -- Put the standard GNAT naming scheme in the Namings table Namings.Increment_Last; Namings.Table (Namings.Last) := Standard_Naming_Data; Name_Len := Global'Length; Name_Buffer (1 .. Name_Len) := Global; Global_Configuration_Pragmas := Name_Find; Name_Len := Local'Length; Name_Buffer (1 .. Name_Len) := Local; Local_Configuration_Pragmas := Name_Find; end Initialize; ------------------------------------ -- Path_Name_Of_Library_Unit_Body -- ------------------------------------ function Path_Name_Of_Library_Unit_Body (Name : String; Project : Project_Id) return String is Data : constant Project_Data := Projects.Table (Project); Original_Name : String := Name; Extended_Spec_Name : String := Name & Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix); Extended_Body_Name : String := Name & Namet.Get_Name_String (Data.Naming.Current_Impl_Suffix); First : Unit_Id := Units.First; Current : Unit_Id; Unit : Unit_Data; begin Canonical_Case_File_Name (Original_Name); Canonical_Case_File_Name (Extended_Spec_Name); Canonical_Case_File_Name (Extended_Spec_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 <= Units.Last and then Units.Table (First).File_Names (Body_Part).Project /= Project loop First := First + 1; end loop; Current := First; while Current <= Units.Last loop Unit := Units.Table (Current); if Unit.File_Names (Body_Part).Project = Project and then Unit.File_Names (Body_Part).Name /= No_Name 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); elsif Current_Name = Extended_Body_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Body_Path_Name_Of (Current); else if Current_Verbosity = High then Write_Line (" not good"); end if; end if; end; elsif Unit.File_Names (Specification).Name /= No_Name 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); elsif Current_Name = Extended_Spec_Name then if Current_Verbosity = High then Write_Line (" OK"); end if; return Spec_Path_Name_Of (Current); 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 -- ------------------- procedure Print_Sources is Unit : Unit_Data; begin Write_Line ("List of Sources:"); for Id in Units.First .. Units.Last loop Unit := Units.Table (Id); Write_Str (" "); Write_Line (Namet.Get_Name_String (Unit.Name)); if Unit.File_Names (Specification).Name /= No_Name then if Unit.File_Names (Specification).Project = No_Project then Write_Line (" No project"); else Write_Str (" Project: "); Get_Name_String (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_Name then if Unit.File_Names (Body_Part).Project = No_Project then Write_Line (" No project"); else Write_Str (" Project: "); Get_Name_String (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; --------------------------------------------- -- 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; ----------------------- -- Spec_Path_Name_Of -- ----------------------- function Spec_Path_Name_Of (Unit : Unit_Id) return String is Data : Unit_Data := Units.Table (Unit); begin if Data.File_Names (Specification).Path = No_Name then declare Current_Source : String_List_Id := Projects.Table (Data.File_Names (Specification).Project).Sources; Path : GNAT.OS_Lib.String_Access; begin Data.File_Names (Specification).Path := Data.File_Names (Specification).Name; while Current_Source /= Nil_String loop String_To_Name_Buffer (String_Elements.Table (Current_Source).Value); Path := Locate_Regular_File (Namet.Get_Name_String (Data.File_Names (Specification).Name), Name_Buffer (1 .. Name_Len)); if Path /= null then Name_Len := Path'Length; Name_Buffer (1 .. Name_Len) := Path.all; Data.File_Names (Specification).Path := Name_Enter; exit; else Current_Source := String_Elements.Table (Current_Source).Next; end if; end loop; Units.Table (Unit) := Data; end; end if; return Namet.Get_Name_String (Data.File_Names (Specification).Path); end Spec_Path_Name_Of; end Prj.Env;