diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/prj-util.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/prj-util.adb | 1350 |
1 files changed, 1350 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/prj-util.adb b/gcc-4.8.3/gcc/ada/prj-util.adb new file mode 100644 index 000000000..2c70d1fee --- /dev/null +++ b/gcc-4.8.3/gcc/ada/prj-util.adb @@ -0,0 +1,1350 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |