aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/stringt.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/stringt.adb')
-rw-r--r--gcc-4.9/gcc/ada/stringt.adb480
1 files changed, 480 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/stringt.adb b/gcc-4.9/gcc/ada/stringt.adb
new file mode 100644
index 000000000..5a0c89c7d
--- /dev/null
+++ b/gcc-4.9/gcc/ada/stringt.adb
@@ -0,0 +1,480 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R I N G T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2013, 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.
+
+ Strings_Last : String_Id := First_String_Id;
+ String_Chars_Last : Int := 0;
+ -- Strings_Last and String_Chars_Last are used by procedure Mark and
+ -- Release to get a snapshot of the tables and to restore them to their
+ -- previous situation.
+
+ -------------------------------
+ -- 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;
+
+ -- Set up the null string
+
+ Start_String;
+ Null_String_Id := End_String;
+ end Initialize;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock is
+ begin
+ String_Chars.Locked := True;
+ Strings.Locked := True;
+ String_Chars.Release;
+ Strings.Release;
+ end Lock;
+
+ ----------
+ -- Mark --
+ ----------
+
+ procedure Mark is
+ begin
+ Strings_Last := Strings.Last;
+ String_Chars_Last := String_Chars.Last;
+ end Mark;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release is
+ begin
+ Strings.Set_Last (Strings_Last);
+ String_Chars.Set_Last (String_Chars_Last);
+ end Release;
+
+ ------------------
+ -- 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;