diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/prj-util.adb')
-rw-r--r-- | gcc-4.2.1/gcc/ada/prj-util.adb | 668 |
1 files changed, 668 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/prj-util.adb b/gcc-4.2.1/gcc/ada/prj-util.adb new file mode 100644 index 000000000..efc0a6874 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/prj-util.adb @@ -0,0 +1,668 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2006, 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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; + In_Tree : Project_Tree_Ref; + Main : Name_Id; + Index : Int; + Ada_Main : Boolean := True) return Name_Id + is + pragma Assert (Project /= No_Project); + + The_Packages : constant Package_Id := + In_Tree.Projects.Table (Project).Decl.Packages; + + Builder_Package : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => The_Packages, + In_Tree => In_Tree); + + Executable : Variable_Value := + Prj.Util.Value_Of + (Name => Main, + Index => Index, + Attribute_Or_Array_Name => Name_Executable, + In_Package => Builder_Package, + In_Tree => In_Tree); + + Executable_Suffix : constant Variable_Value := + Prj.Util.Value_Of + (Name => Main, + Index => 0, + Attribute_Or_Array_Name => + Name_Executable_Suffix, + In_Package => Builder_Package, + In_Tree => In_Tree); + + Body_Append : constant String := Get_Name_String + (In_Tree.Projects.Table + (Project). + Naming.Ada_Body_Suffix); + + Spec_Append : constant String := Get_Name_String + (In_Tree.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 := + In_Tree.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, + In_Tree => In_Tree); + 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 : 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; + In_Tree : Project_Tree_Ref) 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 := In_Tree.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 := In_Tree.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; + In_Tree : Project_Tree_Ref) 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 := In_Tree.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 := In_Tree.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; + In_Tree : Project_Tree_Ref) 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 => In_Tree.Packages.Table (In_Package).Decl.Arrays, + In_Tree => In_Tree); + The_Attribute := + Value_Of + (Index => Name, + Src_Index => Index, + In_Array => The_Array, + In_Tree => In_Tree); + + -- 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 => In_Tree.Packages.Table + (In_Package).Decl.Attributes, + In_Tree => In_Tree); + end if; + end if; + + return The_Attribute; + end Value_Of; + + function Value_Of + (Index : Name_Id; + In_Array : Name_Id; + In_Arrays : Array_Id; + In_Tree : Project_Tree_Ref) return Name_Id + is + Current : Array_Id := In_Arrays; + The_Array : Array_Data; + + begin + while Current /= No_Array loop + The_Array := In_Tree.Arrays.Table (Current); + if The_Array.Name = In_Array then + return Value_Of + (Index, In_Array => The_Array.Value, In_Tree => In_Tree); + 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; + In_Tree : Project_Tree_Ref) return Array_Element_Id + is + Current : Array_Id := In_Arrays; + The_Array : Array_Data; + + begin + while Current /= No_Array loop + The_Array := In_Tree.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; + In_Tree : Project_Tree_Ref) return Package_Id + is + Current : Package_Id := In_Packages; + The_Package : Package_Element; + + begin + while Current /= No_Package loop + The_Package := In_Tree.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; + In_Tree : Project_Tree_Ref) return Variable_Value + is + Current : Variable_Id := In_Variables; + The_Variable : Variable; + + begin + while Current /= No_Variable loop + The_Variable := + In_Tree.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; |