Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S T R I N G T                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-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.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

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

with Alloc;

with Namet;  use Namet;

with Output; use Output;

with Table;

package body Stringt is

   --  The following table stores the sequence of character codes for the

   --  stored string constants. The entries are referenced from the

   --  separate Strings table.

   package String_Chars is new Table.Table (

     Table_Component_Type => Char_Code,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 0,

     Table_Initial        => Alloc.String_Chars_Initial,

     Table_Increment      => Alloc.String_Chars_Increment,

     Table_Name           => "String_Chars");

   --  The String_Id values reference entries in the Strings table, which

   --  contains String_Entry records that record the length of each stored

   --  string and its starting location in the String_Chars table.

   type String_Entry is record

      String_Index : Int;

      Length       : Nat;

   end record;

   package Strings is new Table.Table (

     Table_Component_Type => String_Entry,

     Table_Index_Type     => String_Id'Base,

     Table_Low_Bound      => First_String_Id,

     Table_Initial        => Alloc.Strings_Initial,

     Table_Increment      => Alloc.Strings_Increment,

     Table_Name           => "Strings");

   --  Note: it is possible that two entries in the Strings table can share

   --  string data in the String_Chars table, and in particular this happens

   --  when Start_String is called with a parameter that is the last string

   --  currently allocated in the table.

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

   -- Add_String_To_Name_Buffer --

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

   procedure Add_String_To_Name_Buffer (S : String_Id) is

      Len : constant Natural := Natural (String_Length (S));

   begin

      for J in 1 .. Len loop

         Name_Buffer (Name_Len + J) :=

           Get_Character (Get_String_Char (S, Int (J)));

      end loop;

      Name_Len := Name_Len + Len;

   end Add_String_To_Name_Buffer;

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

   -- End_String --

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

   function End_String return String_Id is

   begin

      return Strings.Last;

   end End_String;

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

   -- Get_String_Char --

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

   function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is

   begin

      pragma Assert (Id in First_String_Id .. Strings.Last

                       and then Index in 1 .. Strings.Table (Id).Length);

      return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);

   end Get_String_Char;

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

   -- Initialize --

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

   procedure Initialize is

   begin

      String_Chars.Init;

      Strings.Init;

   end Initialize;

   ----------

   -- Lock --

   ----------

   procedure Lock is

   begin

      String_Chars.Locked := True;

      Strings.Locked := True;

      String_Chars.Release;

      Strings.Release;

   end Lock;

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

   -- Start_String --

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

   --  Version to start completely new string

   procedure Start_String is

   begin

      Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));

   end Start_String;

   --  Version to start from initially stored string

   procedure Start_String (S : String_Id) is

   begin

      Strings.Increment_Last;

      --  Case of initial string value is at the end of the string characters

      --  table, so it does not need copying, instead it can be shared.

      if Strings.Table (S).String_Index + Strings.Table (S).Length =

                                                    String_Chars.Last + 1

      then

         Strings.Table (Strings.Last).String_Index :=

           Strings.Table (S).String_Index;

      --  Case of initial string value must be copied to new string

      else

         Strings.Table (Strings.Last).String_Index :=

           String_Chars.Last + 1;

         for J in 1 .. Strings.Table (S).Length loop

            String_Chars.Append

              (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));

         end loop;

      end if;

      --  In either case the result string length is copied from the argument

      Strings.Table (Strings.Last).Length := Strings.Table (S).Length;

   end Start_String;

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

   -- Store_String_Char --

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

   procedure Store_String_Char (C : Char_Code) is

   begin

      String_Chars.Append (C);

      Strings.Table (Strings.Last).Length :=

        Strings.Table (Strings.Last).Length + 1;

   end Store_String_Char;

   procedure Store_String_Char (C : Character) is

   begin

      Store_String_Char (Get_Char_Code (C));

   end Store_String_Char;

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

   -- Store_String_Chars --

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

   procedure Store_String_Chars (S : String) is

   begin

      for J in S'First .. S'Last loop

         Store_String_Char (Get_Char_Code (S (J)));

      end loop;

   end Store_String_Chars;

   procedure Store_String_Chars (S : String_Id) is

      --  We are essentially doing this:

      --   for J in 1 .. String_Length (S) loop

      --      Store_String_Char (Get_String_Char (S, J));

      --   end loop;

      --  but when the string is long it's more efficient to grow the

      --  String_Chars table all at once.

      S_First  : constant Int := Strings.Table (S).String_Index;

      S_Len    : constant Int := String_Length (S);

      Old_Last : constant Int := String_Chars.Last;

      New_Last : constant Int := Old_Last + S_Len;

   begin

      String_Chars.Set_Last (New_Last);

      String_Chars.Table (Old_Last + 1 .. New_Last) :=

        String_Chars.Table (S_First .. S_First + S_Len - 1);

      Strings.Table (Strings.Last).Length :=

        Strings.Table (Strings.Last).Length + S_Len;

   end Store_String_Chars;

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

   -- Store_String_Int --

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

   procedure Store_String_Int (N : Int) is

   begin

      if N < 0 then

         Store_String_Char ('-');

         Store_String_Int (-N);

      else

         if N > 9 then

            Store_String_Int (N / 10);

         end if;

         Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));

      end if;

   end Store_String_Int;

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

   -- String_Chars_Address --

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

   function String_Chars_Address return System.Address is

   begin

      return String_Chars.Table (0)'Address;

   end String_Chars_Address;

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

   -- String_Equal --

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

   function String_Equal (L, R : String_Id) return Boolean is

      Len : constant Nat := Strings.Table (L).Length;

   begin

      if Len /= Strings.Table (R).Length then

         return False;

      else

         for J in 1 .. Len loop

            if Get_String_Char (L, J) /= Get_String_Char (R, J) then

               return False;

            end if;

         end loop;

         return True;

      end if;

   end String_Equal;

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

   -- String_From_Name_Buffer --

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

   function String_From_Name_Buffer return String_Id is

   begin

      Start_String;

      for J in 1 .. Name_Len loop

         Store_String_Char (Get_Char_Code (Name_Buffer (J)));

      end loop;

      return End_String;

   end String_From_Name_Buffer;

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

   -- String_Length --

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

   function String_Length (Id : String_Id) return Nat is

   begin

      return Strings.Table (Id).Length;

   end String_Length;

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

   -- String_To_Name_Buffer --

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

   procedure String_To_Name_Buffer (S : String_Id) is

   begin

      Name_Len := Natural (String_Length (S));

      for J in 1 .. Name_Len loop

         Name_Buffer (J) :=

           Get_Character (Get_String_Char (S, Int (J)));

      end loop;

   end String_To_Name_Buffer;

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

   -- Strings_Address --

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

   function Strings_Address return System.Address is

   begin

      return Strings.Table (First_String_Id)'Address;

   end Strings_Address;

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

   -- Tree_Read --

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

   procedure Tree_Read is

   begin

      String_Chars.Tree_Read;

      Strings.Tree_Read;

   end Tree_Read;

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

   -- Tree_Write --

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

   procedure Tree_Write is

   begin

      String_Chars.Tree_Write;

      Strings.Tree_Write;

   end Tree_Write;

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

   -- Unlock --

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

   procedure Unlock is

   begin

      String_Chars.Locked := False;

      Strings.Locked := False;

   end Unlock;

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

   -- Unstore_String_Char --

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

   procedure Unstore_String_Char is

   begin

      String_Chars.Decrement_Last;

      Strings.Table (Strings.Last).Length :=

        Strings.Table (Strings.Last).Length - 1;

   end Unstore_String_Char;

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

   -- Write_Char_Code --

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

   procedure Write_Char_Code (Code : Char_Code) is

      procedure Write_Hex_Byte (J : Char_Code);

      --  Write single hex byte (value in range 0 .. 255) as two digits

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

      -- Write_Hex_Byte --

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

      procedure Write_Hex_Byte (J : Char_Code) is

         Hexd : constant array (Char_Code range 0 .. 15) of Character :=

                  "0123456789abcdef";

      begin

         Write_Char (Hexd (J / 16));

         Write_Char (Hexd (J mod 16));

      end Write_Hex_Byte;

   --  Start of processing for Write_Char_Code

   begin

      if Code in 16#20# .. 16#7E# then

         Write_Char (Character'Val (Code));

      else

         Write_Char ('[');

         Write_Char ('"');

         if Code > 16#FF_FFFF# then

            Write_Hex_Byte (Code / 2 ** 24);

         end if;

         if Code > 16#FFFF# then

            Write_Hex_Byte ((Code / 2 ** 16) mod 256);

         end if;

         if Code > 16#FF# then

            Write_Hex_Byte ((Code / 256) mod 256);

         end if;

         Write_Hex_Byte (Code mod 256);

         Write_Char ('"');

         Write_Char (']');

      end if;

   end Write_Char_Code;

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

   -- Write_String_Table_Entry --

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

   procedure Write_String_Table_Entry (Id : String_Id) is

      C : Char_Code;

   begin

      if Id = No_String then

         Write_Str ("no string");

      else

         Write_Char ('"');

         for J in 1 .. String_Length (Id) loop

            C := Get_String_Char (Id, J);

            if C = Character'Pos ('"') then

               Write_Str ("""""");

            else

               Write_Char_Code (C);

            end if;

            --  If string is very long, quit

            if J >= 1000 then  --  arbitrary limit

               Write_Str ("""...etc (length = ");

               Write_Int (String_Length (Id));

               Write_Str (")");

               return;

            end if;

         end loop;

         Write_Char ('"');

      end if;

   end Write_String_Table_Entry;

end Stringt;