| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . U T I L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2004 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Unchecked_Deallocation; |
| |
| with GNAT.Case_Util; use GNAT.Case_Util; |
| |
| with Namet; use Namet; |
| with Osint; use Osint; |
| with Output; use Output; |
| with Prj.Com; |
| with Snames; use Snames; |
| |
| package body Prj.Util is |
| |
| procedure Free is new Ada.Unchecked_Deallocation |
| (Text_File_Data, Text_File); |
| |
| ----------- |
| -- Close -- |
| ----------- |
| |
| procedure Close (File : in out Text_File) is |
| begin |
| if File = null then |
| Prj.Com.Fail ("Close attempted on an invalid Text_File"); |
| end if; |
| |
| -- Close 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); |
| Free (File); |
| end Close; |
| |
| ----------------- |
| -- 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; |
| Main : Name_Id; |
| Index : Int; |
| Ada_Main : Boolean := True) return Name_Id |
| is |
| pragma Assert (Project /= No_Project); |
| |
| The_Packages : constant Package_Id := |
| Projects.Table (Project).Decl.Packages; |
| |
| Builder_Package : constant Prj.Package_Id := |
| Prj.Util.Value_Of |
| (Name => Name_Builder, |
| In_Packages => The_Packages); |
| |
| Executable : Variable_Value := |
| Prj.Util.Value_Of |
| (Name => Main, |
| Index => Index, |
| Attribute_Or_Array_Name => Name_Executable, |
| In_Package => Builder_Package); |
| |
| Executable_Suffix : constant Variable_Value := |
| Prj.Util.Value_Of |
| (Name => Main, |
| Index => 0, |
| Attribute_Or_Array_Name => |
| Name_Executable_Suffix, |
| In_Package => Builder_Package); |
| |
| Body_Append : constant String := Get_Name_String |
| (Projects.Table |
| (Project). |
| Naming.Ada_Body_Suffix); |
| |
| Spec_Append : constant String := Get_Name_String |
| (Projects.Table |
| (Project). |
| Naming.Ada_Spec_Suffix); |
| |
| begin |
| if Builder_Package /= No_Package then |
| if Executable = Nil_Variable_Value and 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; |
| |
| Naming : constant Naming_Data := |
| Projects.Table (Project).Naming; |
| |
| Spec_Suffix : constant String := |
| Get_Name_String (Naming.Ada_Spec_Suffix); |
| Body_Suffix : constant String := |
| Get_Name_String (Naming.Ada_Body_Suffix); |
| |
| Truncated : Boolean := False; |
| |
| begin |
| if Last > Body_Suffix'Length |
| and then Name (Last - Body_Suffix'Length + 1 .. Last) = |
| Body_Suffix |
| then |
| Truncated := True; |
| Last := Last - Body_Suffix'Length; |
| end if; |
| |
| if not Truncated |
| and then Last > Spec_Suffix'Length |
| and then Name (Last - Spec_Suffix'Length + 1 .. Last) = |
| 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); |
| 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 /= Empty_Name |
| then |
| declare |
| Exec_Suffix : String_Access := Get_Executable_Suffix; |
| Result : Name_Id := Executable.Value; |
| |
| begin |
| if Exec_Suffix'Length /= 0 then |
| Get_Name_String (Executable.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| |
| -- If the Executable does not end with the executable |
| -- suffix, add it. |
| |
| if Name_Len <= Exec_Suffix'Length |
| or else |
| Name_Buffer |
| (Name_Len - Exec_Suffix'Length + 1 .. Name_Len) /= |
| Exec_Suffix.all |
| then |
| -- Get the original Executable to keep the correct |
| -- case for systems where file names are case |
| -- insensitive (Windows). |
| |
| Get_Name_String (Executable.Value); |
| Name_Buffer |
| (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := |
| Exec_Suffix.all; |
| Name_Len := Name_Len + Exec_Suffix'Length; |
| Result := Name_Find; |
| end if; |
| |
| Free (Exec_Suffix); |
| end if; |
| |
| return Result; |
| end; |
| 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 Ada_Main and then Name_Len > Body_Append'Length |
| and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) = |
| Body_Append |
| then |
| -- Found the body termination, remove it |
| |
| Name_Len := Name_Len - Body_Append'Length; |
| |
| elsif Ada_Main and then Name_Len > Spec_Append'Length |
| and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) = |
| Spec_Append |
| then |
| -- Found the spec termination, remove it |
| |
| Name_Len := Name_Len - Spec_Append'Length; |
| |
| else |
| -- Remove any suffix, if there is one |
| |
| Get_Name_String (Strip_Suffix (Main)); |
| end if; |
| |
| if Executable_Suffix /= Nil_Variable_Value |
| and then not Executable_Suffix.Default |
| then |
| -- If attribute Executable_Suffix is specified, add this suffix |
| |
| declare |
| Suffix : constant String := |
| Get_Name_String (Executable_Suffix.Value); |
| begin |
| Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; |
| Name_Len := Name_Len + Suffix'Length; |
| return Name_Find; |
| end; |
| |
| else |
| -- Otherwise, add the standard suffix for the platform, if any |
| |
| return Executable_Name (Name_Find); |
| end if; |
| end Executable_Of; |
| |
| -------------- |
| -- 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"); |
| 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; |
| |
| -------------- |
| -- Is_Valid -- |
| -------------- |
| |
| function Is_Valid (File : Text_File) return Boolean is |
| begin |
| return File /= null; |
| end Is_Valid; |
| |
| ---------- |
| -- Open -- |
| ---------- |
| |
| procedure Open (File : out Text_File; Name : in 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; |
| |
| -------------- |
| -- 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) return Name_Id |
| is |
| Current : Array_Element_Id := In_Array; |
| Element : Array_Element; |
| Real_Index : Name_Id := Index; |
| |
| begin |
| if Current = No_Array_Element then |
| return No_Name; |
| end if; |
| |
| Element := 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 := 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) return Variable_Value |
| is |
| Current : Array_Element_Id := In_Array; |
| Element : Array_Element; |
| Real_Index : Name_Id := Index; |
| |
| begin |
| if Current = No_Array_Element then |
| return Nil_Variable_Value; |
| end if; |
| |
| Element := 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 := Array_Elements.Table (Current); |
| |
| if Real_Index = Element.Index and then |
| Src_Index = Element.Src_Index |
| 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) 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 => Packages.Table (In_Package).Decl.Arrays); |
| The_Attribute := |
| Value_Of |
| (Index => Name, |
| Src_Index => Index, |
| In_Array => The_Array); |
| |
| -- 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 => Packages.Table (In_Package).Decl.Attributes); |
| end if; |
| end if; |
| |
| return The_Attribute; |
| end Value_Of; |
| |
| function Value_Of |
| (Index : Name_Id; |
| In_Array : Name_Id; |
| In_Arrays : Array_Id) return Name_Id |
| is |
| Current : Array_Id := In_Arrays; |
| The_Array : Array_Data; |
| |
| begin |
| while Current /= No_Array loop |
| The_Array := Arrays.Table (Current); |
| if The_Array.Name = In_Array then |
| return Value_Of (Index, In_Array => The_Array.Value); |
| 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) return Array_Element_Id |
| is |
| Current : Array_Id := In_Arrays; |
| The_Array : Array_Data; |
| |
| begin |
| while Current /= No_Array loop |
| The_Array := 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) return Package_Id |
| is |
| Current : Package_Id := In_Packages; |
| The_Package : Package_Element; |
| |
| begin |
| while Current /= No_Package loop |
| The_Package := 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) return Variable_Value |
| is |
| Current : Variable_Id := In_Variables; |
| The_Variable : Variable; |
| |
| begin |
| while Current /= No_Variable loop |
| The_Variable := 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_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; |
