URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [prj-util.adb] - Blame information for rev 281

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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;
end Prj.Util;

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [prj-util.adb] - Blame information for rev 281

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- P R J . U T I L --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Ada.Unchecked_Deallocation;`
27
28			`with GNAT.Case_Util; use GNAT.Case_Util;`
29
30			`with Osint; use Osint;`
31			`with Output; use Output;`
32			`with Prj.Com;`
33			`with Snames; use Snames;`
34			`with Targparm; use Targparm;`
35
36			`package body Prj.Util is`
37
38			`procedure Free is new Ada.Unchecked_Deallocation`
39			`(Text_File_Data, Text_File);`
40
41			`-----------`
42			`-- Close --`
43			`-----------`
44
45			`procedure Close (File : in out Text_File) is`
46			`begin`
47			`if File = null then`
48			`Prj.Com.Fail ("Close attempted on an invalid Text_File");`
49			`end if;`
50
51			`-- Close file, no need to test status, since this is a file that we`
52			`-- read, and the file was read successfully before we closed it.`
53
54			`Close (File.FD);`
55			`Free (File);`
56			`end Close;`
57
58			`---------------`
59			`-- Duplicate --`
60			`---------------`
61
62			`procedure Duplicate`
63			`(This : in out Name_List_Index;`
64			`In_Tree : Project_Tree_Ref)`
65			`is`
66			`Old_Current : Name_List_Index;`
67			`New_Current : Name_List_Index;`
68
69			`begin`
70			`if This /= No_Name_List then`
71			`Old_Current := This;`
72			`Name_List_Table.Increment_Last (In_Tree.Name_Lists);`
73			`New_Current := Name_List_Table.Last (In_Tree.Name_Lists);`
74			`This := New_Current;`
75			`In_Tree.Name_Lists.Table (New_Current) :=`
76			`(In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);`
77
78			`loop`
79			`Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;`
80			`exit when Old_Current = No_Name_List;`
81			`In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;`
82			`Name_List_Table.Increment_Last (In_Tree.Name_Lists);`
83			`New_Current := New_Current + 1;`
84			`In_Tree.Name_Lists.Table (New_Current) :=`
85			`(In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);`
86			`end loop;`
87			`end if;`
88			`end Duplicate;`
89
90			`-----------------`
91			`-- End_Of_File --`
92			`-----------------`
93
94			`function End_Of_File (File : Text_File) return Boolean is`
95			`begin`
96			`if File = null then`
97			`Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");`
98			`end if;`
99
100			`return File.End_Of_File_Reached;`
101			`end End_Of_File;`
102
103			`-------------------`
104			`-- Executable_Of --`
105			`-------------------`
106
107			`function Executable_Of`
108			`(Project : Project_Id;`
109			`In_Tree : Project_Tree_Ref;`
110			`Main : File_Name_Type;`
111			`Index : Int;`
112			`Ada_Main : Boolean := True;`
113			`Language : String := "") return File_Name_Type`
114			`is`
115			`pragma Assert (Project /= No_Project);`
116
117			`The_Packages : constant Package_Id := Project.Decl.Packages;`
118
119			`Builder_Package : constant Prj.Package_Id :=`
120			`Prj.Util.Value_Of`
121			`(Name => Name_Builder,`
122			`In_Packages => The_Packages,`
123			`In_Tree => In_Tree);`
124
125			`Executable : Variable_Value :=`
126			`Prj.Util.Value_Of`
127			`(Name => Name_Id (Main),`
128			`Index => Index,`
129			`Attribute_Or_Array_Name => Name_Executable,`
130			`In_Package => Builder_Package,`
131			`In_Tree => In_Tree);`
132
133			`Executable_Suffix_Name : Name_Id := No_Name;`
134
135			`Lang : Language_Ptr;`
136
137			`Spec_Suffix : Name_Id := No_Name;`
138			`Body_Suffix : Name_Id := No_Name;`
139
140			`Spec_Suffix_Length : Natural := 0;`
141			`Body_Suffix_Length : Natural := 0;`
142
143			`procedure Get_Suffixes`
144			`(B_Suffix : File_Name_Type;`
145			`S_Suffix : File_Name_Type);`
146			`-- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix`
147
148			`------------------`
149			`-- Get_Suffixes --`
150			`------------------`
151
152			`procedure Get_Suffixes`
153			`(B_Suffix : File_Name_Type;`
154			`S_Suffix : File_Name_Type)`
155			`is`
156			`begin`
157			`if B_Suffix /= No_File then`
158			`Body_Suffix := Name_Id (B_Suffix);`
159			`Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));`
160			`end if;`
161
162			`if S_Suffix /= No_File then`
163			`Spec_Suffix := Name_Id (S_Suffix);`
164			`Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));`
165			`end if;`
166			`end Get_Suffixes;`
167
168			`-- Start of processing for Executable_Of`
169
170			`begin`
171			`if Ada_Main then`
172			`Lang := Get_Language_From_Name (Project, "ada");`
173			`elsif Language /= "" then`
174			`Lang := Get_Language_From_Name (Project, Language);`
175			`end if;`
176
177			`if Lang /= null then`
178			`Get_Suffixes`
179			`(B_Suffix => Lang.Config.Naming_Data.Body_Suffix,`
180			`S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);`
181			`end if;`
182
183			`if Builder_Package /= No_Package then`
184			`Executable_Suffix_Name := Project.Config.Executable_Suffix;`
185
186			`if Executable = Nil_Variable_Value and then Ada_Main then`
187			`Get_Name_String (Main);`
188
189			`-- Try as index the name minus the implementation suffix or minus`
190			`-- the specification suffix.`
191
192			`declare`
193			`Name : constant String (1 .. Name_Len) :=`
194			`Name_Buffer (1 .. Name_Len);`
195			`Last : Positive := Name_Len;`
196
197			`Truncated : Boolean := False;`
198
199			`begin`
200			`if Body_Suffix /= No_Name`
201			`and then Last > Natural (Length_Of_Name (Body_Suffix))`
202			`and then Name (Last - Body_Suffix_Length + 1 .. Last) =`
203			`Get_Name_String (Body_Suffix)`
204			`then`
205			`Truncated := True;`
206			`Last := Last - Body_Suffix_Length;`
207			`end if;`
208
209			`if Spec_Suffix /= No_Name`
210			`and then not Truncated`
211			`and then Last > Spec_Suffix_Length`
212			`and then Name (Last - Spec_Suffix_Length + 1 .. Last) =`
213			`Get_Name_String (Spec_Suffix)`
214			`then`
215			`Truncated := True;`
216			`Last := Last - Spec_Suffix_Length;`
217			`end if;`
218
219			`if Truncated then`
220			`Name_Len := Last;`
221			`Name_Buffer (1 .. Name_Len) := Name (1 .. Last);`
222			`Executable :=`
223			`Prj.Util.Value_Of`
224			`(Name => Name_Find,`
225			`Index => 0,`
226			`Attribute_Or_Array_Name => Name_Executable,`
227			`In_Package => Builder_Package,`
228			`In_Tree => In_Tree);`
229			`end if;`
230			`end;`
231			`end if;`
232
233			`-- If we have found an Executable attribute, return its value,`
234			`-- possibly suffixed by the executable suffix.`
235
236			`if Executable /= Nil_Variable_Value`
237			`and then Executable.Value /= No_Name`
238			`and then Length_Of_Name (Executable.Value) /= 0`
239			`then`
240			`-- Get the executable name. If Executable_Suffix is defined,`
241			`-- make sure that it will be the extension of the executable.`
242
243			`declare`
244			`Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;`
245			`Result : File_Name_Type;`
246
247			`begin`
248			`if Executable_Suffix_Name /= No_Name then`
249			`Executable_Extension_On_Target := Executable_Suffix_Name;`
250			`end if;`
251
252			`Result := Executable_Name (File_Name_Type (Executable.Value));`
253			`Executable_Extension_On_Target := Saved_EEOT;`
254			`return Result;`
255			`end;`
256			`end if;`
257			`end if;`
258
259			`Get_Name_String (Main);`
260
261			`-- If there is a body suffix or a spec suffix, remove this suffix,`
262			`-- otherwise remove any suffix ('.' followed by other characters), if`
263			`-- there is one.`
264
265			`if Body_Suffix /= No_Name`
266			`and then Name_Len > Body_Suffix_Length`
267			`and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =`
268			`Get_Name_String (Body_Suffix)`
269			`then`
270			`-- Found the body termination, remove it`
271
272			`Name_Len := Name_Len - Body_Suffix_Length;`
273
274			`elsif Spec_Suffix /= No_Name`
275			`and then Name_Len > Spec_Suffix_Length`
276			`and then`
277			`Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =`
278			`Get_Name_String (Spec_Suffix)`
279			`then`
280			`-- Found the spec termination, remove it`
281
282			`Name_Len := Name_Len - Spec_Suffix_Length;`
283
284			`else`
285			`-- Remove any suffix, if there is one`
286
287			`Get_Name_String (Strip_Suffix (Main));`
288			`end if;`
289
290			`-- Get the executable name. If Executable_Suffix is defined in the`
291			`-- configuration, make sure that it will be the extension of the`
292			`-- executable.`
293
294			`declare`
295			`Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;`
296			`Result : File_Name_Type;`
297
298			`begin`
299			`if Project.Config.Executable_Suffix /= No_Name then`
300			`Executable_Extension_On_Target :=`
301			`Project.Config.Executable_Suffix;`
302			`end if;`
303
304			`Result := Executable_Name (Name_Find);`
305			`Executable_Extension_On_Target := Saved_EEOT;`
306			`return Result;`
307			`end;`
308			`end Executable_Of;`
309
310			`--------------`
311			`-- Get_Line --`
312			`--------------`
313
314			`procedure Get_Line`
315			`(File : Text_File;`
316			`Line : out String;`
317			`Last : out Natural)`
318			`is`
319			`C : Character;`
320
321			`procedure Advance;`
322
323			`-------------`
324			`-- Advance --`
325			`-------------`
326
327			`procedure Advance is`
328			`begin`
329			`if File.Cursor = File.Buffer_Len then`
330			`File.Buffer_Len :=`
331			`Read`
332			`(FD => File.FD,`
333			`A => File.Buffer'Address,`
334			`N => File.Buffer'Length);`
335
336			`if File.Buffer_Len = 0 then`
337			`File.End_Of_File_Reached := True;`
338			`return;`
339			`else`
340			`File.Cursor := 1;`
341			`end if;`
342
343			`else`
344			`File.Cursor := File.Cursor + 1;`
345			`end if;`
346			`end Advance;`
347
348			`-- Start of processing for Get_Line`
349
350			`begin`
351			`if File = null then`
352			`Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");`
353			`end if;`
354
355			`Last := Line'First - 1;`
356
357			`if not File.End_Of_File_Reached then`
358			`loop`
359			`C := File.Buffer (File.Cursor);`
360			`exit when C = ASCII.CR or else C = ASCII.LF;`
361			`Last := Last + 1;`
362			`Line (Last) := C;`
363			`Advance;`
364
365			`if File.End_Of_File_Reached then`
366			`return;`
367			`end if;`
368
369			`exit when Last = Line'Last;`
370			`end loop;`
371
372			`if C = ASCII.CR or else C = ASCII.LF then`
373			`Advance;`
374
375			`if File.End_Of_File_Reached then`
376			`return;`
377			`end if;`
378			`end if;`
379
380			`if C = ASCII.CR`
381			`and then File.Buffer (File.Cursor) = ASCII.LF`
382			`then`
383			`Advance;`
384			`end if;`
385			`end if;`
386			`end Get_Line;`
387
388			`--------------`
389			`-- Is_Valid --`
390			`--------------`
391
392			`function Is_Valid (File : Text_File) return Boolean is`
393			`begin`
394			`return File /= null;`
395			`end Is_Valid;`
396
397			`----------`
398			`-- Open --`
399			`----------`
400
401			`procedure Open (File : out Text_File; Name : String) is`
402			`FD : File_Descriptor;`
403			`File_Name : String (1 .. Name'Length + 1);`
404
405			`begin`
406			`File_Name (1 .. Name'Length) := Name;`
407			`File_Name (File_Name'Last) := ASCII.NUL;`
408			`FD := Open_Read (Name => File_Name'Address,`
409			`Fmode => GNAT.OS_Lib.Text);`
410
411			`if FD = Invalid_FD then`
412			`File := null;`
413
414			`else`
415			`File := new Text_File_Data;`
416			`File.FD := FD;`
417			`File.Buffer_Len :=`
418			`Read (FD => FD,`
419			`A => File.Buffer'Address,`
420			`N => File.Buffer'Length);`
421
422			`if File.Buffer_Len = 0 then`
423			`File.End_Of_File_Reached := True;`
424			`else`
425			`File.Cursor := 1;`
426			`end if;`
427			`end if;`
428			`end Open;`
429
430			`---------`
431			`-- Put --`
432			`---------`
433
434			`procedure Put`
435			`(Into_List : in out Name_List_Index;`
436			`From_List : String_List_Id;`
437			`In_Tree : Project_Tree_Ref;`
438			`Lower_Case : Boolean := False)`
439			`is`
440			`Current_Name : Name_List_Index;`
441			`List : String_List_Id;`
442			`Element : String_Element;`
443			`Last : Name_List_Index :=`
444			`Name_List_Table.Last (In_Tree.Name_Lists);`
445			`Value : Name_Id;`
446
447			`begin`
448			`Current_Name := Into_List;`
449			`while Current_Name /= No_Name_List`
450			`and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List`
451			`loop`
452			`Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;`
453			`end loop;`
454
455			`List := From_List;`
456			`while List /= Nil_String loop`
457			`Element := In_Tree.String_Elements.Table (List);`
458			`Value := Element.Value;`
459
460			`if Lower_Case then`
461			`Get_Name_String (Value);`
462			`To_Lower (Name_Buffer (1 .. Name_Len));`
463			`Value := Name_Find;`
464			`end if;`
465
466			`Name_List_Table.Append`
467			`(In_Tree.Name_Lists, (Name => Value, Next => No_Name_List));`
468
469			`Last := Last + 1;`
470
471			`if Current_Name = No_Name_List then`
472			`Into_List := Last;`
473
474			`else`
475			`In_Tree.Name_Lists.Table (Current_Name).Next := Last;`
476			`end if;`
477
478			`Current_Name := Last;`
479
480			`List := Element.Next;`
481			`end loop;`
482			`end Put;`
483
484			`--------------`
485			`-- Value_Of --`
486			`--------------`
487
488			`function Value_Of`
489			`(Variable : Variable_Value;`
490			`Default : String) return String`
491			`is`
492			`begin`
493			`if Variable.Kind /= Single`
494			`or else Variable.Default`
495			`or else Variable.Value = No_Name`
496			`then`
497			`return Default;`
498			`else`
499			`return Get_Name_String (Variable.Value);`
500			`end if;`
501			`end Value_Of;`
502
503			`function Value_Of`
504			`(Index : Name_Id;`
505			`In_Array : Array_Element_Id;`
506			`In_Tree : Project_Tree_Ref) return Name_Id`
507			`is`
508			`Current : Array_Element_Id;`
509			`Element : Array_Element;`
510			`Real_Index : Name_Id := Index;`
511
512			`begin`
513			`Current := In_Array;`
514
515			`if Current = No_Array_Element then`
516			`return No_Name;`
517			`end if;`
518
519			`Element := In_Tree.Array_Elements.Table (Current);`
520
521			`if not Element.Index_Case_Sensitive then`
522			`Get_Name_String (Index);`
523			`To_Lower (Name_Buffer (1 .. Name_Len));`
524			`Real_Index := Name_Find;`
525			`end if;`
526
527			`while Current /= No_Array_Element loop`
528			`Element := In_Tree.Array_Elements.Table (Current);`
529
530			`if Real_Index = Element.Index then`
531			`exit when Element.Value.Kind /= Single;`
532			`exit when Element.Value.Value = Empty_String;`
533			`return Element.Value.Value;`
534			`else`
535			`Current := Element.Next;`
536			`end if;`
537			`end loop;`
538
539			`return No_Name;`
540			`end Value_Of;`
541
542			`function Value_Of`
543			`(Index : Name_Id;`
544			`Src_Index : Int := 0;`
545			`In_Array : Array_Element_Id;`
546			`In_Tree : Project_Tree_Ref;`
547			`Force_Lower_Case_Index : Boolean := False) return Variable_Value`
548			`is`
549			`Current : Array_Element_Id;`
550			`Element : Array_Element;`
551			`Real_Index_1 : Name_Id;`
552			`Real_Index_2 : Name_Id;`
553
554			`begin`
555			`Current := In_Array;`
556
557			`if Current = No_Array_Element then`
558			`return Nil_Variable_Value;`
559			`end if;`
560
561			`Element := In_Tree.Array_Elements.Table (Current);`
562
563			`Real_Index_1 := Index;`
564
565			`if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then`
566			`if Index /= All_Other_Names then`
567			`Get_Name_String (Index);`
568			`To_Lower (Name_Buffer (1 .. Name_Len));`
569			`Real_Index_1 := Name_Find;`
570			`end if;`
571			`end if;`
572
573			`while Current /= No_Array_Element loop`
574			`Element := In_Tree.Array_Elements.Table (Current);`
575			`Real_Index_2 := Element.Index;`
576
577			`if not Element.Index_Case_Sensitive`
578			`or else Force_Lower_Case_Index`
579			`then`
580			`if Element.Index /= All_Other_Names then`
581			`Get_Name_String (Element.Index);`
582			`To_Lower (Name_Buffer (1 .. Name_Len));`
583			`Real_Index_2 := Name_Find;`
584			`end if;`
585			`end if;`
586
587			`if Real_Index_1 = Real_Index_2 and then`
588			`Src_Index = Element.Src_Index`
589			`then`
590			`return Element.Value;`
591			`else`
592			`Current := Element.Next;`
593			`end if;`
594			`end loop;`
595
596			`return Nil_Variable_Value;`
597			`end Value_Of;`
598
599			`function Value_Of`
600			`(Name : Name_Id;`
601			`Index : Int := 0;`
602			`Attribute_Or_Array_Name : Name_Id;`
603			`In_Package : Package_Id;`
604			`In_Tree : Project_Tree_Ref;`
605			`Force_Lower_Case_Index : Boolean := False) return Variable_Value`
606			`is`
607			`The_Array : Array_Element_Id;`
608			`The_Attribute : Variable_Value := Nil_Variable_Value;`
609
610			`begin`
611			`if In_Package /= No_Package then`
612
613			`-- First, look if there is an array element that fits`
614
615			`The_Array :=`
616			`Value_Of`
617			`(Name => Attribute_Or_Array_Name,`
618			`In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,`
619			`In_Tree => In_Tree);`
620			`The_Attribute :=`
621			`Value_Of`
622			`(Index => Name,`
623			`Src_Index => Index,`
624			`In_Array => The_Array,`
625			`In_Tree => In_Tree,`
626			`Force_Lower_Case_Index => Force_Lower_Case_Index);`
627
628			`-- If there is no array element, look for a variable`
629
630			`if The_Attribute = Nil_Variable_Value then`
631			`The_Attribute :=`
632			`Value_Of`
633			`(Variable_Name => Attribute_Or_Array_Name,`
634			`In_Variables => In_Tree.Packages.Table`
635			`(In_Package).Decl.Attributes,`
636			`In_Tree => In_Tree);`
637			`end if;`
638			`end if;`
639
640			`return The_Attribute;`
641			`end Value_Of;`
642
643			`function Value_Of`
644			`(Index : Name_Id;`
645			`In_Array : Name_Id;`
646			`In_Arrays : Array_Id;`
647			`In_Tree : Project_Tree_Ref) return Name_Id`
648			`is`
649			`Current : Array_Id;`
650			`The_Array : Array_Data;`
651
652			`begin`
653			`Current := In_Arrays;`
654			`while Current /= No_Array loop`
655			`The_Array := In_Tree.Arrays.Table (Current);`
656			`if The_Array.Name = In_Array then`
657			`return Value_Of`
658			`(Index, In_Array => The_Array.Value, In_Tree => In_Tree);`
659			`else`
660			`Current := The_Array.Next;`
661			`end if;`
662			`end loop;`
663
664			`return No_Name;`
665			`end Value_Of;`
666
667			`function Value_Of`
668			`(Name : Name_Id;`
669			`In_Arrays : Array_Id;`
670			`In_Tree : Project_Tree_Ref) return Array_Element_Id`
671			`is`
672			`Current : Array_Id;`
673			`The_Array : Array_Data;`
674
675			`begin`
676			`Current := In_Arrays;`
677			`while Current /= No_Array loop`
678			`The_Array := In_Tree.Arrays.Table (Current);`
679
680			`if The_Array.Name = Name then`
681			`return The_Array.Value;`
682			`else`
683			`Current := The_Array.Next;`
684			`end if;`
685			`end loop;`
686
687			`return No_Array_Element;`
688			`end Value_Of;`
689
690			`function Value_Of`
691			`(Name : Name_Id;`
692			`In_Packages : Package_Id;`
693			`In_Tree : Project_Tree_Ref) return Package_Id`
694			`is`
695			`Current : Package_Id;`
696			`The_Package : Package_Element;`
697
698			`begin`
699			`Current := In_Packages;`
700			`while Current /= No_Package loop`
701			`The_Package := In_Tree.Packages.Table (Current);`
702			`exit when The_Package.Name /= No_Name`
703			`and then The_Package.Name = Name;`
704			`Current := The_Package.Next;`
705			`end loop;`
706
707			`return Current;`
708			`end Value_Of;`
709
710			`function Value_Of`
711			`(Variable_Name : Name_Id;`
712			`In_Variables : Variable_Id;`
713			`In_Tree : Project_Tree_Ref) return Variable_Value`
714			`is`
715			`Current : Variable_Id;`
716			`The_Variable : Variable;`
717
718			`begin`
719			`Current := In_Variables;`
720			`while Current /= No_Variable loop`
721			`The_Variable :=`
722			`In_Tree.Variable_Elements.Table (Current);`
723
724			`if Variable_Name = The_Variable.Name then`
725			`return The_Variable.Value;`
726			`else`
727			`Current := The_Variable.Next;`
728			`end if;`
729			`end loop;`
730
731			`return Nil_Variable_Value;`
732			`end Value_Of;`
733
734			`---------------`
735			`-- Write_Str --`
736			`---------------`
737
738			`procedure Write_Str`
739			`(S : String;`
740			`Max_Length : Positive;`
741			`Separator : Character)`
742			`is`
743			`First : Positive := S'First;`
744			`Last : Natural := S'Last;`
745
746			`begin`
747			`-- Nothing to do for empty strings`
748
749			`if S'Length > 0 then`
750
751			`-- Start on a new line if current line is already longer than`
752			`-- Max_Length.`
753
754			`if Positive (Column) >= Max_Length then`
755			`Write_Eol;`
756			`end if;`
757
758			`-- If length of remainder is longer than Max_Length, we need to`
759			`-- cut the remainder in several lines.`
760
761			`while Positive (Column) + S'Last - First > Max_Length loop`
762
763			`-- Try the maximum length possible`
764
765			`Last := First + Max_Length - Positive (Column);`
766
767			`-- Look for last Separator in the line`
768
769			`while Last >= First and then S (Last) /= Separator loop`
770			`Last := Last - 1;`
771			`end loop;`
772
773			`-- If we do not find a separator, we output the maximum length`
774			`-- possible.`
775
776			`if Last < First then`
777			`Last := First + Max_Length - Positive (Column);`
778			`end if;`
779
780			`Write_Line (S (First .. Last));`
781
782			`-- Set the beginning of the new remainder`
783
784			`First := Last + 1;`
785			`end loop;`
786
787			`-- What is left goes to the buffer, without EOL`
788
789			`Write_Str (S (First .. S'Last));`
790			`end if;`
791			`end Write_Str;`
792			`end Prj.Util;`