diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/prj-util.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/prj-util.adb | 1350 |
1 files changed, 0 insertions, 1350 deletions
diff --git a/gcc-4.8/gcc/ada/prj-util.adb b/gcc-4.8/gcc/ada/prj-util.adb deleted file mode 100644 index 2c70d1fee..000000000 --- a/gcc-4.8/gcc/ada/prj-util.adb +++ /dev/null @@ -1,1350 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2012, 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 Ada.Containers.Indefinite_Ordered_Sets; -with Ada.Directories; -with Ada.Unchecked_Deallocation; - -with GNAT.Case_Util; use GNAT.Case_Util; -with GNAT.Regexp; use GNAT.Regexp; - -with ALI; use ALI; -with Osint; use Osint; -with Output; use Output; -with Opt; -with Prj.Com; -with Snames; use Snames; -with Table; -with Targparm; use Targparm; - -with GNAT.HTable; - -package body Prj.Util is - - package Source_Info_Table is new Table.Table - (Table_Component_Type => Source_Info_Iterator, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Makeutl.Source_Info_Table"); - - package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable - (Header_Num => Prj.Header_Num, - Element => Natural, - No_Element => 0, - Key => Name_Id, - Hash => Prj.Hash, - Equal => "="); - - procedure Free is new Ada.Unchecked_Deallocation - (Text_File_Data, Text_File); - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out Text_File) is - Len : Integer; - Status : Boolean; - - begin - if File = null then - Prj.Com.Fail ("Close attempted on an invalid Text_File"); - end if; - - if File.Out_File then - if File.Buffer_Len > 0 then - Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); - - if Len /= File.Buffer_Len then - Prj.Com.Fail ("Unable to write to an out Text_File"); - end if; - end if; - - Close (File.FD, Status); - - if not Status then - Prj.Com.Fail ("Unable to close an out Text_File"); - end if; - - else - - -- Close in file, no need to test status, since this is a file that - -- we read, and the file was read successfully before we closed it. - - Close (File.FD); - end if; - - Free (File); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create (File : out Text_File; Name : String) is - FD : File_Descriptor; - File_Name : String (1 .. Name'Length + 1); - - begin - File_Name (1 .. Name'Length) := Name; - File_Name (File_Name'Last) := ASCII.NUL; - FD := Create_File (Name => File_Name'Address, - Fmode => GNAT.OS_Lib.Text); - - if FD = Invalid_FD then - File := null; - - else - File := new Text_File_Data; - File.FD := FD; - File.Out_File := True; - File.End_Of_File_Reached := True; - end if; - end Create; - - --------------- - -- Duplicate -- - --------------- - - procedure Duplicate - (This : in out Name_List_Index; - Shared : Shared_Project_Tree_Data_Access) - is - Old_Current : Name_List_Index; - New_Current : Name_List_Index; - - begin - if This /= No_Name_List then - Old_Current := This; - Name_List_Table.Increment_Last (Shared.Name_Lists); - New_Current := Name_List_Table.Last (Shared.Name_Lists); - This := New_Current; - Shared.Name_Lists.Table (New_Current) := - (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); - - loop - Old_Current := Shared.Name_Lists.Table (Old_Current).Next; - exit when Old_Current = No_Name_List; - Shared.Name_Lists.Table (New_Current).Next := New_Current + 1; - Name_List_Table.Increment_Last (Shared.Name_Lists); - New_Current := New_Current + 1; - Shared.Name_Lists.Table (New_Current) := - (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); - end loop; - end if; - end Duplicate; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : Text_File) return Boolean is - begin - if File = null then - Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File"); - end if; - - return File.End_Of_File_Reached; - end End_Of_File; - - ------------------- - -- Executable_Of -- - ------------------- - - function Executable_Of - (Project : Project_Id; - Shared : Shared_Project_Tree_Data_Access; - Main : File_Name_Type; - Index : Int; - Ada_Main : Boolean := True; - Language : String := ""; - Include_Suffix : Boolean := True) return File_Name_Type - is - pragma Assert (Project /= No_Project); - - The_Packages : constant Package_Id := Project.Decl.Packages; - - Builder_Package : constant Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Builder, - In_Packages => The_Packages, - Shared => Shared); - - Executable : Variable_Value := - Prj.Util.Value_Of - (Name => Name_Id (Main), - Index => Index, - Attribute_Or_Array_Name => Name_Executable, - In_Package => Builder_Package, - Shared => Shared); - - Lang : Language_Ptr; - - Spec_Suffix : Name_Id := No_Name; - Body_Suffix : Name_Id := No_Name; - - Spec_Suffix_Length : Natural := 0; - Body_Suffix_Length : Natural := 0; - - procedure Get_Suffixes - (B_Suffix : File_Name_Type; - S_Suffix : File_Name_Type); - -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix - - function Add_Suffix (File : File_Name_Type) return File_Name_Type; - -- Return the name of the executable, based on File, and adding the - -- executable suffix if needed - - ------------------ - -- Get_Suffixes -- - ------------------ - - procedure Get_Suffixes - (B_Suffix : File_Name_Type; - S_Suffix : File_Name_Type) - is - begin - if B_Suffix /= No_File then - Body_Suffix := Name_Id (B_Suffix); - Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); - end if; - - if S_Suffix /= No_File then - Spec_Suffix := Name_Id (S_Suffix); - Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); - end if; - end Get_Suffixes; - - ---------------- - -- Add_Suffix -- - ---------------- - - function Add_Suffix (File : File_Name_Type) return File_Name_Type is - Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; - Result : File_Name_Type; - Suffix_From_Project : Variable_Value; - begin - if Include_Suffix then - if Project.Config.Executable_Suffix /= No_Name then - Executable_Extension_On_Target := - Project.Config.Executable_Suffix; - end if; - - Result := Executable_Name (File); - Executable_Extension_On_Target := Saved_EEOT; - return Result; - - elsif Builder_Package /= No_Package then - - -- If the suffix is specified in the project itself, as opposed to - -- the config file, it needs to be taken into account. However, - -- when the project was processed, in both cases the suffix was - -- stored in Project.Config, so get it from the project again. - - Suffix_From_Project := - Prj.Util.Value_Of - (Variable_Name => Name_Executable_Suffix, - In_Variables => - Shared.Packages.Table (Builder_Package).Decl.Attributes, - Shared => Shared); - - if Suffix_From_Project /= Nil_Variable_Value - and then Suffix_From_Project.Value /= No_Name - then - Executable_Extension_On_Target := Suffix_From_Project.Value; - Result := Executable_Name (File); - Executable_Extension_On_Target := Saved_EEOT; - return Result; - end if; - end if; - - return File; - end Add_Suffix; - - -- Start of processing for Executable_Of - - begin - if Ada_Main then - Lang := Get_Language_From_Name (Project, "ada"); - elsif Language /= "" then - Lang := Get_Language_From_Name (Project, Language); - end if; - - if Lang /= null then - Get_Suffixes - (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, - S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); - end if; - - if Builder_Package /= No_Package then - if Executable = Nil_Variable_Value and then Ada_Main then - Get_Name_String (Main); - - -- Try as index the name minus the implementation suffix or minus - -- the specification suffix. - - declare - Name : constant String (1 .. Name_Len) := - Name_Buffer (1 .. Name_Len); - Last : Positive := Name_Len; - - Truncated : Boolean := False; - - begin - if Body_Suffix /= No_Name - and then Last > Natural (Length_Of_Name (Body_Suffix)) - and then Name (Last - Body_Suffix_Length + 1 .. Last) = - Get_Name_String (Body_Suffix) - then - Truncated := True; - Last := Last - Body_Suffix_Length; - end if; - - if Spec_Suffix /= No_Name - and then not Truncated - and then Last > Spec_Suffix_Length - and then Name (Last - Spec_Suffix_Length + 1 .. Last) = - Get_Name_String (Spec_Suffix) - then - Truncated := True; - Last := Last - Spec_Suffix_Length; - end if; - - if Truncated then - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := Name (1 .. Last); - Executable := - Prj.Util.Value_Of - (Name => Name_Find, - Index => 0, - Attribute_Or_Array_Name => Name_Executable, - In_Package => Builder_Package, - Shared => Shared); - end if; - end; - end if; - - -- If we have found an Executable attribute, return its value, - -- possibly suffixed by the executable suffix. - - if Executable /= Nil_Variable_Value - and then Executable.Value /= No_Name - and then Length_Of_Name (Executable.Value) /= 0 - then - return Add_Suffix (File_Name_Type (Executable.Value)); - end if; - end if; - - Get_Name_String (Main); - - -- If there is a body suffix or a spec suffix, remove this suffix, - -- otherwise remove any suffix ('.' followed by other characters), if - -- there is one. - - if Body_Suffix /= No_Name - and then Name_Len > Body_Suffix_Length - and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = - Get_Name_String (Body_Suffix) - then - -- Found the body termination, remove it - - Name_Len := Name_Len - Body_Suffix_Length; - - elsif Spec_Suffix /= No_Name - and then Name_Len > Spec_Suffix_Length - and then - Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = - Get_Name_String (Spec_Suffix) - then - -- Found the spec termination, remove it - - Name_Len := Name_Len - Spec_Suffix_Length; - - else - -- Remove any suffix, if there is one - - Get_Name_String (Strip_Suffix (Main)); - end if; - - return Add_Suffix (Name_Find); - end Executable_Of; - - --------------------------- - -- For_Interface_Sources -- - --------------------------- - - procedure For_Interface_Sources - (Tree : Project_Tree_Ref; - Project : Project_Id) - is - use Ada; - use type Ada.Containers.Count_Type; - - package Dep_Names is new Containers.Indefinite_Ordered_Sets (String); - - function Load_ALI (Filename : String) return ALI_Id; - -- Load an ALI file and return its id - - -------------- - -- Load_ALI -- - -------------- - - function Load_ALI (Filename : String) return ALI_Id is - Result : ALI_Id := No_ALI_Id; - Text : Text_Buffer_Ptr; - Lib_File : File_Name_Type; - - begin - if Directories.Exists (Filename) then - Name_Len := 0; - Add_Str_To_Name_Buffer (Filename); - Lib_File := Name_Find; - Text := Osint.Read_Library_Info (Lib_File); - Result := - ALI.Scan_ALI - (Lib_File, - Text, - Ignore_ED => False, - Err => True, - Read_Lines => "UD"); - Free (Text); - end if; - - return Result; - end Load_ALI; - - -- Local declarations - - Iter : Source_Iterator; - Sid : Source_Id; - ALI : ALI_Id; - - First_Unit : Unit_Id; - Second_Unit : Unit_Id; - Body_Needed : Boolean; - Deps : Dep_Names.Set; - - -- Start of processing for For_Interface_Sources - - begin - if Project.Qualifier = Aggregate_Library then - Iter := For_Each_Source (Tree); - else - Iter := For_Each_Source (Tree, Project); - end if; - - -- First look at each spec, check if the body is needed - - loop - Sid := Element (Iter); - exit when Sid = No_Source; - - -- Skip sources that are removed/excluded and sources not part of - -- the interface for standalone libraries. - - if Sid.Kind = Spec - and then not Sid.Locally_Removed - and then (Project.Standalone_Library = No - or else Sid.Declared_In_Interfaces) - then - Action (Sid); - - -- Check ALI for dependencies on body and sep - - ALI := - Load_ALI - (Get_Name_String (Get_Object_Directory (Sid.Project, True)) - & Get_Name_String (Sid.Dep_Name)); - - if ALI /= No_ALI_Id then - First_Unit := ALIs.Table (ALI).First_Unit; - Second_Unit := No_Unit_Id; - Body_Needed := True; - - -- If there is both a spec and a body, check if both needed - - if Units.Table (First_Unit).Utype = Is_Body then - Second_Unit := ALIs.Table (ALI).Last_Unit; - - -- If the body is not needed, then reset First_Unit - - if not Units.Table (Second_Unit).Body_Needed_For_SAL then - Body_Needed := False; - end if; - - elsif Units.Table (First_Unit).Utype = Is_Spec_Only then - Body_Needed := False; - end if; - - -- Handle all the separates, if any - - if Body_Needed then - if Other_Part (Sid) /= null then - Deps.Include (Get_Name_String (Other_Part (Sid).File)); - end if; - - for Dep in ALIs.Table (ALI).First_Sdep .. - ALIs.Table (ALI).Last_Sdep - loop - if Sdep.Table (Dep).Subunit_Name /= No_Name then - Deps.Include - (Get_Name_String (Sdep.Table (Dep).Sfile)); - end if; - end loop; - end if; - end if; - end if; - - Next (Iter); - end loop; - - -- Now handle the bodies and separates if needed - - if Deps.Length /= 0 then - Iter := For_Each_Source (Tree, Project); - - loop - Sid := Element (Iter); - exit when Sid = No_Source; - - if Sid.Kind /= Spec - and then Deps.Contains (Get_Name_String (Sid.File)) - then - Action (Sid); - end if; - - Next (Iter); - end loop; - end if; - end For_Interface_Sources; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : Text_File; - Line : out String; - Last : out Natural) - is - C : Character; - - procedure Advance; - - ------------- - -- Advance -- - ------------- - - procedure Advance is - begin - if File.Cursor = File.Buffer_Len then - File.Buffer_Len := - Read - (FD => File.FD, - A => File.Buffer'Address, - N => File.Buffer'Length); - - if File.Buffer_Len = 0 then - File.End_Of_File_Reached := True; - return; - else - File.Cursor := 1; - end if; - - else - File.Cursor := File.Cursor + 1; - end if; - end Advance; - - -- Start of processing for Get_Line - - begin - if File = null then - Prj.Com.Fail ("Get_Line attempted on an invalid Text_File"); - - elsif File.Out_File then - Prj.Com.Fail ("Get_Line attempted on an out file"); - end if; - - Last := Line'First - 1; - - if not File.End_Of_File_Reached then - loop - C := File.Buffer (File.Cursor); - exit when C = ASCII.CR or else C = ASCII.LF; - Last := Last + 1; - Line (Last) := C; - Advance; - - if File.End_Of_File_Reached then - return; - end if; - - exit when Last = Line'Last; - end loop; - - if C = ASCII.CR or else C = ASCII.LF then - Advance; - - if File.End_Of_File_Reached then - return; - end if; - end if; - - if C = ASCII.CR - and then File.Buffer (File.Cursor) = ASCII.LF - then - Advance; - end if; - end if; - end Get_Line; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Iter : out Source_Info_Iterator; - For_Project : Name_Id) - is - Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); - begin - if Ind = 0 then - Iter := (No_Source_Info, 0); - else - Iter := Source_Info_Table.Table (Ind); - end if; - end Initialize; - - -------------- - -- Is_Valid -- - -------------- - - function Is_Valid (File : Text_File) return Boolean is - begin - return File /= null; - end Is_Valid; - - ---------- - -- Next -- - ---------- - - procedure Next (Iter : in out Source_Info_Iterator) is - begin - if Iter.Next = 0 then - Iter.Info := No_Source_Info; - - else - Iter := Source_Info_Table.Table (Iter.Next); - end if; - end Next; - - ---------- - -- Open -- - ---------- - - procedure Open (File : out Text_File; Name : String) is - FD : File_Descriptor; - File_Name : String (1 .. Name'Length + 1); - - begin - File_Name (1 .. Name'Length) := Name; - File_Name (File_Name'Last) := ASCII.NUL; - FD := Open_Read (Name => File_Name'Address, - Fmode => GNAT.OS_Lib.Text); - - if FD = Invalid_FD then - File := null; - - else - File := new Text_File_Data; - File.FD := FD; - File.Buffer_Len := - Read (FD => FD, - A => File.Buffer'Address, - N => File.Buffer'Length); - - if File.Buffer_Len = 0 then - File.End_Of_File_Reached := True; - else - File.Cursor := 1; - end if; - end if; - end Open; - - --------- - -- Put -- - --------- - - procedure Put - (Into_List : in out Name_List_Index; - From_List : String_List_Id; - In_Tree : Project_Tree_Ref; - Lower_Case : Boolean := False) - is - Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; - - Current_Name : Name_List_Index; - List : String_List_Id; - Element : String_Element; - Last : Name_List_Index := - Name_List_Table.Last (Shared.Name_Lists); - Value : Name_Id; - - begin - Current_Name := Into_List; - while Current_Name /= No_Name_List - and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List - loop - Current_Name := Shared.Name_Lists.Table (Current_Name).Next; - end loop; - - List := From_List; - while List /= Nil_String loop - Element := Shared.String_Elements.Table (List); - Value := Element.Value; - - if Lower_Case then - Get_Name_String (Value); - To_Lower (Name_Buffer (1 .. Name_Len)); - Value := Name_Find; - end if; - - Name_List_Table.Append - (Shared.Name_Lists, (Name => Value, Next => No_Name_List)); - - Last := Last + 1; - - if Current_Name = No_Name_List then - Into_List := Last; - else - Shared.Name_Lists.Table (Current_Name).Next := Last; - end if; - - Current_Name := Last; - - List := Element.Next; - end loop; - end Put; - - procedure Put (File : Text_File; S : String) is - Len : Integer; - begin - if File = null then - Prj.Com.Fail ("Attempted to write on an invalid Text_File"); - - elsif not File.Out_File then - Prj.Com.Fail ("Attempted to write an in Text_File"); - end if; - - if File.Buffer_Len + S'Length > File.Buffer'Last then - -- Write buffer - Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); - - if Len /= File.Buffer_Len then - Prj.Com.Fail ("Failed to write to an out Text_File"); - end if; - - File.Buffer_Len := 0; - end if; - - File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; - File.Buffer_Len := File.Buffer_Len + S'Length; - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (File : Text_File; Line : String) is - L : String (1 .. Line'Length + 1); - begin - L (1 .. Line'Length) := Line; - L (L'Last) := ASCII.LF; - Put (File, L); - end Put_Line; - - --------------------------- - -- Read_Source_Info_File -- - --------------------------- - - procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is - File : Text_File; - Info : Source_Info_Iterator; - Proj : Name_Id; - - procedure Report_Error; - - ------------------ - -- Report_Error -- - ------------------ - - procedure Report_Error is - begin - Write_Line ("errors in source info file """ & - Tree.Source_Info_File_Name.all & '"'); - Tree.Source_Info_File_Exists := False; - end Report_Error; - - begin - Source_Info_Project_HTable.Reset; - Source_Info_Table.Init; - - if Tree.Source_Info_File_Name = null then - Tree.Source_Info_File_Exists := False; - return; - end if; - - Open (File, Tree.Source_Info_File_Name.all); - - if not Is_Valid (File) then - if Opt.Verbose_Mode then - Write_Line ("source info file " & Tree.Source_Info_File_Name.all & - " does not exist"); - end if; - - Tree.Source_Info_File_Exists := False; - return; - end if; - - Tree.Source_Info_File_Exists := True; - - if Opt.Verbose_Mode then - Write_Line ("Reading source info file " & - Tree.Source_Info_File_Name.all); - end if; - - Source_Loop : - while not End_Of_File (File) loop - Info := (new Source_Info_Data, 0); - Source_Info_Table.Increment_Last; - - -- project name - Get_Line (File, Name_Buffer, Name_Len); - Proj := Name_Find; - Info.Info.Project := Proj; - Info.Next := Source_Info_Project_HTable.Get (Proj); - Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); - - if End_Of_File (File) then - Report_Error; - exit Source_Loop; - end if; - - -- language name - Get_Line (File, Name_Buffer, Name_Len); - Info.Info.Language := Name_Find; - - if End_Of_File (File) then - Report_Error; - exit Source_Loop; - end if; - - -- kind - Get_Line (File, Name_Buffer, Name_Len); - Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); - - if End_Of_File (File) then - Report_Error; - exit Source_Loop; - end if; - - -- display path name - Get_Line (File, Name_Buffer, Name_Len); - Info.Info.Display_Path_Name := Name_Find; - Info.Info.Path_Name := Info.Info.Display_Path_Name; - - if End_Of_File (File) then - Report_Error; - exit Source_Loop; - end if; - - -- optional fields - Option_Loop : - loop - Get_Line (File, Name_Buffer, Name_Len); - exit Option_Loop when Name_Len = 0; - - if Name_Len <= 2 then - Report_Error; - exit Source_Loop; - - else - if Name_Buffer (1 .. 2) = "P=" then - Name_Buffer (1 .. Name_Len - 2) := - Name_Buffer (3 .. Name_Len); - Name_Len := Name_Len - 2; - Info.Info.Path_Name := Name_Find; - - elsif Name_Buffer (1 .. 2) = "U=" then - Name_Buffer (1 .. Name_Len - 2) := - Name_Buffer (3 .. Name_Len); - Name_Len := Name_Len - 2; - Info.Info.Unit_Name := Name_Find; - - elsif Name_Buffer (1 .. 2) = "I=" then - Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); - - elsif Name_Buffer (1 .. Name_Len) = "N=Y" then - Info.Info.Naming_Exception := Yes; - - elsif Name_Buffer (1 .. Name_Len) = "N=I" then - Info.Info.Naming_Exception := Inherited; - - else - Report_Error; - exit Source_Loop; - end if; - end if; - end loop Option_Loop; - - Source_Info_Table.Table (Source_Info_Table.Last) := Info; - end loop Source_Loop; - - Close (File); - - exception - when others => - Close (File); - Report_Error; - end Read_Source_Info_File; - - -------------------- - -- Source_Info_Of -- - -------------------- - - function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is - begin - return Iter.Info; - end Source_Info_Of; - - -------------- - -- Value_Of -- - -------------- - - function Value_Of - (Variable : Variable_Value; - Default : String) return String - is - begin - if Variable.Kind /= Single - or else Variable.Default - or else Variable.Value = No_Name - then - return Default; - else - return Get_Name_String (Variable.Value); - end if; - end Value_Of; - - function Value_Of - (Index : Name_Id; - In_Array : Array_Element_Id; - Shared : Shared_Project_Tree_Data_Access) return Name_Id - is - - Current : Array_Element_Id; - Element : Array_Element; - Real_Index : Name_Id := Index; - - begin - Current := In_Array; - - if Current = No_Array_Element then - return No_Name; - end if; - - Element := Shared.Array_Elements.Table (Current); - - if not Element.Index_Case_Sensitive then - Get_Name_String (Index); - To_Lower (Name_Buffer (1 .. Name_Len)); - Real_Index := Name_Find; - end if; - - while Current /= No_Array_Element loop - Element := Shared.Array_Elements.Table (Current); - - if Real_Index = Element.Index then - exit when Element.Value.Kind /= Single; - exit when Element.Value.Value = Empty_String; - return Element.Value.Value; - else - Current := Element.Next; - end if; - end loop; - - return No_Name; - end Value_Of; - - function Value_Of - (Index : Name_Id; - Src_Index : Int := 0; - In_Array : Array_Element_Id; - Shared : Shared_Project_Tree_Data_Access; - Force_Lower_Case_Index : Boolean := False; - Allow_Wildcards : Boolean := False) return Variable_Value - is - Current : Array_Element_Id; - Element : Array_Element; - Real_Index_1 : Name_Id; - Real_Index_2 : Name_Id; - - begin - Current := In_Array; - - if Current = No_Array_Element then - return Nil_Variable_Value; - end if; - - Element := Shared.Array_Elements.Table (Current); - - Real_Index_1 := Index; - - if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then - if Index /= All_Other_Names then - Get_Name_String (Index); - To_Lower (Name_Buffer (1 .. Name_Len)); - Real_Index_1 := Name_Find; - end if; - end if; - - while Current /= No_Array_Element loop - Element := Shared.Array_Elements.Table (Current); - Real_Index_2 := Element.Index; - - if not Element.Index_Case_Sensitive - or else Force_Lower_Case_Index - then - if Element.Index /= All_Other_Names then - Get_Name_String (Element.Index); - To_Lower (Name_Buffer (1 .. Name_Len)); - Real_Index_2 := Name_Find; - end if; - end if; - - if Src_Index = Element.Src_Index and then - (Real_Index_1 = Real_Index_2 or else - (Real_Index_2 /= All_Other_Names and then - Allow_Wildcards and then - Match (Get_Name_String (Real_Index_1), - Compile (Get_Name_String (Real_Index_2), - Glob => True)))) - then - return Element.Value; - else - Current := Element.Next; - end if; - end loop; - - return Nil_Variable_Value; - end Value_Of; - - function Value_Of - (Name : Name_Id; - Index : Int := 0; - Attribute_Or_Array_Name : Name_Id; - In_Package : Package_Id; - Shared : Shared_Project_Tree_Data_Access; - Force_Lower_Case_Index : Boolean := False; - Allow_Wildcards : Boolean := False) return Variable_Value - is - The_Array : Array_Element_Id; - The_Attribute : Variable_Value := Nil_Variable_Value; - - begin - if In_Package /= No_Package then - - -- First, look if there is an array element that fits - - The_Array := - Value_Of - (Name => Attribute_Or_Array_Name, - In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays, - Shared => Shared); - The_Attribute := - Value_Of - (Index => Name, - Src_Index => Index, - In_Array => The_Array, - Shared => Shared, - Force_Lower_Case_Index => Force_Lower_Case_Index, - Allow_Wildcards => Allow_Wildcards); - - -- If there is no array element, look for a variable - - if The_Attribute = Nil_Variable_Value then - The_Attribute := - Value_Of - (Variable_Name => Attribute_Or_Array_Name, - In_Variables => Shared.Packages.Table - (In_Package).Decl.Attributes, - Shared => Shared); - end if; - end if; - - return The_Attribute; - end Value_Of; - - function Value_Of - (Index : Name_Id; - In_Array : Name_Id; - In_Arrays : Array_Id; - Shared : Shared_Project_Tree_Data_Access) return Name_Id - is - Current : Array_Id; - The_Array : Array_Data; - - begin - Current := In_Arrays; - while Current /= No_Array loop - The_Array := Shared.Arrays.Table (Current); - if The_Array.Name = In_Array then - return Value_Of - (Index, In_Array => The_Array.Value, Shared => Shared); - else - Current := The_Array.Next; - end if; - end loop; - - return No_Name; - end Value_Of; - - function Value_Of - (Name : Name_Id; - In_Arrays : Array_Id; - Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id - is - Current : Array_Id; - The_Array : Array_Data; - - begin - Current := In_Arrays; - while Current /= No_Array loop - The_Array := Shared.Arrays.Table (Current); - - if The_Array.Name = Name then - return The_Array.Value; - else - Current := The_Array.Next; - end if; - end loop; - - return No_Array_Element; - end Value_Of; - - function Value_Of - (Name : Name_Id; - In_Packages : Package_Id; - Shared : Shared_Project_Tree_Data_Access) return Package_Id - is - Current : Package_Id; - The_Package : Package_Element; - - begin - Current := In_Packages; - while Current /= No_Package loop - The_Package := Shared.Packages.Table (Current); - exit when The_Package.Name /= No_Name - and then The_Package.Name = Name; - Current := The_Package.Next; - end loop; - - return Current; - end Value_Of; - - function Value_Of - (Variable_Name : Name_Id; - In_Variables : Variable_Id; - Shared : Shared_Project_Tree_Data_Access) return Variable_Value - is - Current : Variable_Id; - The_Variable : Variable; - - begin - Current := In_Variables; - while Current /= No_Variable loop - The_Variable := Shared.Variable_Elements.Table (Current); - - if Variable_Name = The_Variable.Name then - return The_Variable.Value; - else - Current := The_Variable.Next; - end if; - end loop; - - return Nil_Variable_Value; - end Value_Of; - - ---------------------------- - -- Write_Source_Info_File -- - ---------------------------- - - procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is - Iter : Source_Iterator := For_Each_Source (Tree); - Source : Prj.Source_Id; - File : Text_File; - - begin - if Opt.Verbose_Mode then - Write_Line ("Writing new source info file " & - Tree.Source_Info_File_Name.all); - end if; - - Create (File, Tree.Source_Info_File_Name.all); - - if not Is_Valid (File) then - Write_Line ("warning: unable to create source info file """ & - Tree.Source_Info_File_Name.all & '"'); - return; - end if; - - loop - Source := Element (Iter); - exit when Source = No_Source; - - if not Source.Locally_Removed and then - Source.Replaced_By = No_Source - then - -- Project name - - Put_Line (File, Get_Name_String (Source.Project.Name)); - - -- Language name - - Put_Line (File, Get_Name_String (Source.Language.Name)); - - -- Kind - - Put_Line (File, Source.Kind'Img); - - -- Display path name - - Put_Line (File, Get_Name_String (Source.Path.Display_Name)); - - -- Optional lines: - - -- Path name (P=) - - if Source.Path.Name /= Source.Path.Display_Name then - Put (File, "P="); - Put_Line (File, Get_Name_String (Source.Path.Name)); - end if; - - -- Unit name (U=) - - if Source.Unit /= No_Unit_Index then - Put (File, "U="); - Put_Line (File, Get_Name_String (Source.Unit.Name)); - end if; - - -- Multi-source index (I=) - - if Source.Index /= 0 then - Put (File, "I="); - Put_Line (File, Source.Index'Img); - end if; - - -- Naming exception ("N=T"); - - if Source.Naming_Exception = Yes then - Put_Line (File, "N=Y"); - - elsif Source.Naming_Exception = Inherited then - Put_Line (File, "N=I"); - end if; - - -- Empty line to indicate end of info on this source - - Put_Line (File, ""); - end if; - - Next (Iter); - end loop; - - Close (File); - end Write_Source_Info_File; - - --------------- - -- Write_Str -- - --------------- - - procedure Write_Str - (S : String; - Max_Length : Positive; - Separator : Character) - is - First : Positive := S'First; - Last : Natural := S'Last; - - begin - -- Nothing to do for empty strings - - if S'Length > 0 then - - -- Start on a new line if current line is already longer than - -- Max_Length. - - if Positive (Column) >= Max_Length then - Write_Eol; - end if; - - -- If length of remainder is longer than Max_Length, we need to - -- cut the remainder in several lines. - - while Positive (Column) + S'Last - First > Max_Length loop - - -- Try the maximum length possible - - Last := First + Max_Length - Positive (Column); - - -- Look for last Separator in the line - - while Last >= First and then S (Last) /= Separator loop - Last := Last - 1; - end loop; - - -- If we do not find a separator, we output the maximum length - -- possible. - - if Last < First then - Last := First + Max_Length - Positive (Column); - end if; - - Write_Line (S (First .. Last)); - - -- Set the beginning of the new remainder - - First := Last + 1; - end loop; - - -- What is left goes to the buffer, without EOL - - Write_Str (S (First .. S'Last)); - end if; - end Write_Str; -end Prj.Util; |