with Alloc;
with Namet; use Namet;
with Output; use Output;
with Table;
package body Stringt is
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");
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");
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;
function End_String return String_Id is
begin
return Strings.Last;
end End_String;
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;
procedure Initialize is
begin
String_Chars.Init;
Strings.Init;
end Initialize;
procedure Lock is
begin
String_Chars.Locked := True;
Strings.Locked := True;
String_Chars.Release;
Strings.Release;
end Lock;
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;
procedure Start_String (S : String_Id) is
begin
Strings.Increment_Last;
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;
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;
Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
end Start_String;
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;
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;
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;
function String_Chars_Address return System.Address is
begin
return String_Chars.Table (0)'Address;
end String_Chars_Address;
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;
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;
function String_Length (Id : String_Id) return Nat is
begin
return Strings.Table (Id).Length;
end String_Length;
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;
function Strings_Address return System.Address is
begin
return Strings.Table (First_String_Id)'Address;
end Strings_Address;
procedure Tree_Read is
begin
String_Chars.Tree_Read;
Strings.Tree_Read;
end Tree_Read;
procedure Tree_Write is
begin
String_Chars.Tree_Write;
Strings.Tree_Write;
end Tree_Write;
procedure Unlock is
begin
String_Chars.Locked := False;
Strings.Locked := False;
end Unlock;
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;
procedure Write_Char_Code (Code : Char_Code) is
procedure Write_Hex_Byte (J : Char_Code);
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;
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;
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;