| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . U T I L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2014, 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.Project.Externally_Built |
| or else Sid.Project = Project) |
| and then not Sid.Locally_Removed |
| and then (Project.Standalone_Library = No |
| or else Sid.Declared_In_Interfaces) |
| |
| -- Handle case of non-compilable languages |
| |
| and then Sid.Dep_Name /= No_File |
| 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 |
| if Project.Qualifier = Aggregate_Library then |
| Iter := For_Each_Source (Tree); |
| else |
| Iter := For_Each_Source (Tree, Project); |
| end if; |
| |
| 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; |
