From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/stringt.adb | 449 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 449 insertions(+) create mode 100644 gcc/ada/stringt.adb (limited to 'gcc/ada/stringt.adb') diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb new file mode 100644 index 000000000..89dfe6e27 --- /dev/null +++ b/gcc/ada/stringt.adb @@ -0,0 +1,449 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3