------------------------------------------------------------------------------
--                                                                          --
--                     ASIS UTILITY LIBRARY COMPONENTS                      --
--                                                                          --
--                      A S I S _ U L . S T R I N G S                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2004-2007, AdaCore                     --
--                                                                          --
-- Asis Utility Library (ASIS UL) is free software; you can redistribute it --
-- and/or  modify  it  under  terms  of  the  GNU General Public License as --
-- published by the Free Software Foundation; either version 2, or (at your --
-- option)  any later version.  ASIS UL  is distributed in the hope that it --
-- will  be  useful,  but  WITHOUT  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.                         --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

with Table;

with Asis.Set_Get; use Asis.Set_Get;

with Atree;        use Atree;
with Namet;        use Namet;
with Sinput;       use Sinput;
with Types;        use Types;

package body ASIS_UL.Strings is

   package Chars is new Table.Table (
     Table_Component_Type => Character,
     Table_Index_Type     => Integer,
     Table_Low_Bound      => 1,
     Table_Initial        => 10000,
     Table_Increment      => 1000,
     Table_Name           => "character container");

   Table : Chars.Table_Ptr renames Chars.Table;

   -------------------------
   -- Build_GNAT_Location --
   -------------------------

   function Build_GNAT_Location
     (For_Elem : Asis.Element;
      Line     : Natural := 0;
      Column   : Natural := 0)
      return     String_Loc
   is
      S     :          String_Loc := Nil_String_Loc;
      First : constant Natural    := Chars.Last + 1;

      P              : Source_Ptr;
      Sindex         : Source_File_Index;
      Instance_Depth : Natural := 0;

      function Strip_Space (S : String) return String;
      --  Is applied to the result of 'Img attribute. Cuts out the leading
      --  space.

      function Strip_Space (S : String) return String is
         First_Idx : constant Positive := S'First + 1;
         Result    : constant String := S (First_Idx .. S'Last);
      begin
         return Result;
      end Strip_Space;

      procedure Enter_Sloc
        (Line     : Natural := 0;
         Column   : Natural := 0);
      --  For the current value of P, sets in the string table the string
      --  of the form file_name:line_number. Also computes Sindex as the
      --  Id of the sourse file of P. If Line and Column are equal to zero,
      --  computes line and column number from P.

      procedure Enter_Sloc
        (Line     : Natural := 0;
         Column   : Natural := 0)
       is
         F_Name : File_Name_Type;
      begin
         Sindex := Get_Source_File_Index (P);
         F_Name := File_Name (Sindex);

         Get_Name_String (F_Name);

         S := Enter_String (Name_Buffer (1 .. Name_Len) & ":");

         if Line = 0 then
            S := Enter_String (Strip_Space (Get_Physical_Line_Number (P)'Img));
         else
            S := Enter_String (Strip_Space (Line'Img));
         end if;

         S := Enter_String (":");

         if Column = 0 then
            S := Enter_String (Strip_Space (Get_Column_Number (P)'Img));
         else
            S := Enter_String (Strip_Space (Column'Img));
         end if;

      end Enter_Sloc;

   begin
      --  The implementation is adopted from
      --  Gnatelim.Asis_Utilities.Build_Sloc_Trace

      P := Sloc (Node (For_Elem));

      Enter_Sloc (Line, Column);

      P := Instantiation (Sindex);

      while P /= No_Location loop
         pragma Assert (Line = 0 and then Column = 0);

         S              := Enter_String ("[");
         Instance_Depth := Instance_Depth + 1;

         Enter_Sloc;

         P := Instantiation (Sindex);
      end loop;

      for J in 1 .. Instance_Depth loop
         S := Enter_String ("]");
      end loop;

      S.First := First;
      S.Last  := Chars.Last;

      return S;
   end Build_GNAT_Location;

   function Build_GNAT_Location
     (For_Elem : Asis.Element;
      Line     : Natural := 0;
      Column   : Natural := 0)
      return     String
   is
      Last_Backup : constant Integer    := Chars.Last;
      Res_Sloc    : constant String_Loc :=
        Build_GNAT_Location (For_Elem, Line, Column);
   begin

      declare
         Result : constant String := Get_String (Res_Sloc);
      begin
         Chars.Set_Last (Last_Backup);
         return Result;
      end;

   end Build_GNAT_Location;

   ------------------
   -- Enter_String --
   ------------------

   function Enter_String (S : String) return String_Loc is
      Len   : constant Integer := S'Length;
      F     :          Integer;
   begin

      if Len = 0 then
         return Nil_String_Loc;
      else
         Chars.Increment_Last;
         F := Chars.Last;
         Chars.Set_Last (F + Len - 1);

         Table (F .. F + Len - 1) := Chars.Table_Type (S);

         return (F, F + Len - 1);
      end if;

   end Enter_String;

   ----------------
   -- Get_String --
   ----------------

   function Get_String (SL : String_Loc) return String is
   begin

      if SL = Nil_String_Loc then
         return "";
      else
         return String (Table (SL.First .. SL.Last));
      end if;

   end Get_String;

   ----------
   -- Init --
   ----------

   procedure Init is
   begin
      Chars.Init;
   end Init;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal (S : String; SL : String_Loc) return Boolean is
      Result : Boolean := False;
   begin

      if SL.First in 1 .. Chars.Last
        and then
         SL.Last in 1 .. Chars.Last
        and then
         SL.Last - SL.First + 1 = S'Length
      then
         Result := S = Get_String (SL);
      end if;

      return Result;

   end Is_Equal;

end ASIS_UL.Strings;
