Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              P R J . U T I L                             --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2001-2009, 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.Unchecked_Deallocation;

with GNAT.Case_Util; use GNAT.Case_Util;

with Osint;    use Osint;

with Output;   use Output;

with Prj.Com;

with Snames;   use Snames;

with Targparm; use Targparm;

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;

   ---------------

   -- Duplicate --

   ---------------

   procedure Duplicate

     (This    : in out Name_List_Index;

      In_Tree : Project_Tree_Ref)

   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 (In_Tree.Name_Lists);

         New_Current := Name_List_Table.Last (In_Tree.Name_Lists);

         This := New_Current;

         In_Tree.Name_Lists.Table (New_Current) :=

           (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);

         loop

            Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;

            exit when Old_Current = No_Name_List;

            In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;

            Name_List_Table.Increment_Last (In_Tree.Name_Lists);

            New_Current := New_Current + 1;

            In_Tree.Name_Lists.Table (New_Current) :=

              (In_Tree.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;

      In_Tree  : Project_Tree_Ref;

      Main     : File_Name_Type;

      Index    : Int;

      Ada_Main : Boolean := True;

      Language : String := "") 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,

                             In_Tree     => In_Tree);

      Executable : Variable_Value :=

                     Prj.Util.Value_Of

                       (Name                    => Name_Id (Main),

                        Index                   => Index,

                        Attribute_Or_Array_Name => Name_Executable,

                        In_Package              => Builder_Package,

                        In_Tree                 => In_Tree);

      Executable_Suffix_Name : Name_Id := No_Name;

      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

      ------------------

      -- 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;

   --  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

         Executable_Suffix_Name := Project.Config.Executable_Suffix;

         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,

                       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 /= No_Name

           and then Length_Of_Name (Executable.Value) /= 0

         then

            --  Get the executable name. If Executable_Suffix is defined,

            --  make sure that it will be the extension of the executable.

            declare

               Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;

               Result     : File_Name_Type;

            begin

               if Executable_Suffix_Name /= No_Name then

                  Executable_Extension_On_Target := Executable_Suffix_Name;

               end if;

               Result :=  Executable_Name (File_Name_Type (Executable.Value));

               Executable_Extension_On_Target := Saved_EEOT;

               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 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;

      --  Get the executable name. If Executable_Suffix is defined in the

      --  configuration, make sure that it will be the extension of the

      --  executable.

      declare

         Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;

         Result     : File_Name_Type;

      begin

         if Project.Config.Executable_Suffix /= No_Name then

            Executable_Extension_On_Target :=

              Project.Config.Executable_Suffix;

         end if;

         Result := Executable_Name (Name_Find);

         Executable_Extension_On_Target := Saved_EEOT;

         return Result;

      end;

   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;

   ---------

   -- 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

      Current_Name : Name_List_Index;

      List         : String_List_Id;

      Element      : String_Element;

      Last         : Name_List_Index :=

                       Name_List_Table.Last (In_Tree.Name_Lists);

      Value        : Name_Id;

   begin

      Current_Name := Into_List;

      while Current_Name /= No_Name_List

        and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List

      loop

         Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;

      end loop;

      List := From_List;

      while List /= Nil_String loop

         Element := In_Tree.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

           (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List));

         Last := Last + 1;

         if Current_Name = No_Name_List then

            Into_List := Last;

         else

            In_Tree.Name_Lists.Table (Current_Name).Next := Last;

         end if;

         Current_Name := Last;

         List := Element.Next;

      end loop;

   end Put;

   --------------

   -- 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;

      Element    : Array_Element;

      Real_Index : Name_Id := Index;

   begin

      Current := In_Array;

      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;

      Force_Lower_Case_Index : 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 := In_Tree.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 := In_Tree.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 Real_Index_1 = Real_Index_2 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;

      Force_Lower_Case_Index  : 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 => 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,

              Force_Lower_Case_Index => Force_Lower_Case_Index);

         --  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;

      The_Array : Array_Data;

   begin

      Current := In_Arrays;

      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;

      The_Array : Array_Data;

   begin

      Current := In_Arrays;

      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;

      The_Package : Package_Element;

   begin

      Current := In_Packages;

      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;

      The_Variable : Variable;

   begin

      Current := In_Variables;

      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;