------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T R I N G T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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, 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.Increment_Last; Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1; Strings.Table (Strings.Last).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.Increment_Last; String_Chars.Table (String_Chars.Last) := 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.Increment_Last; String_Chars.Table (String_Chars.Last) := 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 begin for J in 1 .. String_Length (S) loop Store_String_Char (Get_String_Char (S, J)); end loop; 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 Character'Val (C) = '"' then Write_Str (""""""); else Write_Char_Code (C); end if; end loop; Write_Char ('"'); end if; end Write_String_Table_Entry; end Stringt;