X-Git-Url: https://oss.titaniummirror.com/gitweb/?a=blobdiff_plain;f=gcc%2Fada%2Fprj-env.adb;fp=gcc%2Fada%2Fprj-env.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=916e45f41fefc2c60000aa8f72e5736c74e058f7;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb deleted file mode 100644 index 916e45f4..00000000 --- a/gcc/ada/prj-env.adb +++ /dev/null @@ -1,1570 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . E N V -- --- -- --- B o d y -- --- -- --- $Revision: 1.5.10.1 $ --- -- --- Copyright (C) 2001 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; - No_Naming : constant Naming_Id := 0; - - 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; - - ----------------------- - -- 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 (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. - -- Call itself recursively for projects being modified, - -- and imported projects. - -- Add the project to the list Seen if this is the first time - -- we call 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; - - Current : String_List_Id := Data.Source_Dirs; - Source_Dir : String_Element; - - begin - -- Add to path all source directories of this project - - 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; - - -- 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; - - ---------------------- - -- 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 directory of a project to the path, - -- only if this project has not been visited. - -- Call itself recursively for projects being modified, - -- and imported projects. - -- Add the project to the list Seen if this is the first time - -- we call 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 (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. - -- The truth is we could have put a space, but it is - -- more convenient to be able to read gnat.adc during - -- development. And the development was done under UNIX. - -- Hence the ASCII.LF. - - 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 (S : String); - -- Put a line 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 (S : String) is - Last : Natural; - - begin - Last := Write (File, S'Address, S'Length); - - if Last /= S'Length then - Osint.Fail ("Disk full"); - end if; - end Put; - - -------------- - -- Put_Data -- - -------------- - - procedure Put_Data (Spec : Boolean) is - begin - Put (Get_Name_String (The_Unit_Data.Name)); - - if Spec then - Put ("%s"); - else - Put ("%b"); - end if; - - Put (S => (1 => ASCII.LF)); - Put (Get_Name_String (Data.Name)); - Put (S => (1 => ASCII.LF)); - Put (Get_Name_String (Data.Path)); - Put (S => (1 => ASCII.LF)); - 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; - - -- 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; - - 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; - - ----------------------- - -- 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;