with Debug; use Debug;
with Output; use Output;
with Unchecked_Conversion;
package body Tree_IO is
Debug_Flag_Tree : Boolean := False;
C_Noncomp : constant := 2#00_000000#;
C_Zeros : constant := 2#01_000000#;
C_Spaces : constant := 2#10_000000#;
C_Repeat : constant := 2#11_000000#;
Max_Count : constant := 63;
type Int_Bytes is array (1 .. 4) of Byte;
for Int_Bytes'Size use 32;
function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
function To_Int is new Unchecked_Conversion (Int_Bytes, Int);
Tree_FD : File_Descriptor;
Buflen : constant Int := 8_192;
Buf : array (Pos range 1 .. Buflen) of Byte;
Bufn : Nat;
Buft : Nat;
procedure Read_Buffer;
function Read_Byte return Byte;
pragma Inline (Read_Byte);
procedure Write_Buffer;
procedure Write_Byte (B : Byte);
pragma Inline (Write_Byte);
procedure Read_Buffer is
begin
Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
if Buft = 0 then
raise Tree_Format_Error;
else
Bufn := 0;
end if;
end Read_Buffer;
function Read_Byte return Byte is
begin
if Bufn = Buft then
Read_Buffer;
end if;
Bufn := Bufn + 1;
return Buf (Bufn);
end Read_Byte;
procedure Tree_Read_Bool (B : out Boolean) is
begin
B := Boolean'Val (Read_Byte);
if Debug_Flag_Tree then
if B then
Write_Str ("True");
else
Write_Str ("False");
end if;
Write_Eol;
end if;
end Tree_Read_Bool;
procedure Tree_Read_Char (C : out Character) is
begin
C := Character'Val (Read_Byte);
if Debug_Flag_Tree then
Write_Str ("==> transmitting Character = ");
Write_Char (C);
Write_Eol;
end if;
end Tree_Read_Char;
procedure Tree_Read_Data (Addr : Address; Length : Int) is
type S is array (Pos) of Byte;
type SP is access all S;
function To_SP is new Unchecked_Conversion (Address, SP);
Data : constant SP := To_SP (Addr);
OP : Pos := 1;
B : Byte;
C : Byte;
L : Int;
begin
if Debug_Flag_Tree then
Write_Str ("==> transmitting ");
Write_Int (Length);
Write_Str (" data bytes");
Write_Eol;
end if;
Tree_Read_Int (L);
if L /= Length then
Write_Str ("==> transmitting, expected ");
Write_Int (Length);
Write_Str (" bytes, found length = ");
Write_Int (L);
Write_Eol;
raise Tree_Format_Error;
end if;
while OP <= Length loop
B := Read_Byte;
C := B and 2#00_111111#;
B := B and 2#11_000000#;
if B = C_Noncomp then
if Debug_Flag_Tree then
Write_Str ("==> uncompressed: ");
Write_Int (Int (C));
Write_Str (", starting at ");
Write_Int (OP);
Write_Eol;
end if;
for J in 1 .. C loop
Data (OP) := Read_Byte;
OP := OP + 1;
end loop;
elsif B = C_Zeros then
if Debug_Flag_Tree then
Write_Str ("==> zeroes: ");
Write_Int (Int (C));
Write_Str (", starting at ");
Write_Int (OP);
Write_Eol;
end if;
for J in 1 .. C loop
Data (OP) := 0;
OP := OP + 1;
end loop;
elsif B = C_Spaces then
if Debug_Flag_Tree then
Write_Str ("==> spaces: ");
Write_Int (Int (C));
Write_Str (", starting at ");
Write_Int (OP);
Write_Eol;
end if;
for J in 1 .. C loop
Data (OP) := Character'Pos (' ');
OP := OP + 1;
end loop;
else B := Read_Byte;
if Debug_Flag_Tree then
Write_Str ("==> other char: ");
Write_Int (Int (C));
Write_Str (" (");
Write_Int (Int (B));
Write_Char (')');
Write_Str (", starting at ");
Write_Int (OP);
Write_Eol;
end if;
for J in 1 .. C loop
Data (OP) := B;
OP := OP + 1;
end loop;
end if;
end loop;
if OP /= Length + 1 then
raise Tree_Format_Error;
end if;
end Tree_Read_Data;
procedure Tree_Read_Initialize (Desc : File_Descriptor) is
begin
Buft := 0;
Bufn := 0;
Tree_FD := Desc;
Debug_Flag_Tree := Debug_Flag_5;
end Tree_Read_Initialize;
procedure Tree_Read_Int (N : out Int) is
N_Bytes : Int_Bytes;
begin
for J in 1 .. 4 loop
N_Bytes (J) := Read_Byte;
end loop;
N := To_Int (N_Bytes);
if Debug_Flag_Tree then
Write_Str ("==> transmitting Int = ");
Write_Int (N);
Write_Eol;
end if;
end Tree_Read_Int;
procedure Tree_Read_Str (S : out String_Ptr) is
N : Nat;
begin
Tree_Read_Int (N);
S := new String (1 .. Natural (N));
Tree_Read_Data (S.all (1)'Address, N);
end Tree_Read_Str;
procedure Tree_Read_Terminate is
begin
declare
B : Byte;
pragma Warnings (Off, B);
begin
B := Read_Byte;
exception
when Tree_Format_Error => return;
end;
raise Tree_Format_Error;
end Tree_Read_Terminate;
procedure Tree_Write_Bool (B : Boolean) is
begin
if Debug_Flag_Tree then
Write_Str ("==> transmitting Boolean = ");
if B then
Write_Str ("True");
else
Write_Str ("False");
end if;
Write_Eol;
end if;
Write_Byte (Boolean'Pos (B));
end Tree_Write_Bool;
procedure Tree_Write_Char (C : Character) is
begin
if Debug_Flag_Tree then
Write_Str ("==> transmitting Character = ");
Write_Char (C);
Write_Eol;
end if;
Write_Byte (Character'Pos (C));
end Tree_Write_Char;
procedure Tree_Write_Data (Addr : Address; Length : Int) is
type S is array (Pos) of Byte;
type SP is access all S;
function To_SP is new Unchecked_Conversion (Address, SP);
Data : constant SP := To_SP (Addr);
IP : Pos := 1;
NC : Nat range 0 .. Max_Count := 0;
C : Byte;
procedure Write_Non_Compressed_Sequence;
procedure Write_Non_Compressed_Sequence is
begin
if NC > 0 then
Write_Byte (C_Noncomp + Byte (NC));
if Debug_Flag_Tree then
Write_Str ("==> uncompressed: ");
Write_Int (NC);
Write_Str (", starting at ");
Write_Int (IP - NC);
Write_Eol;
end if;
for J in reverse 1 .. NC loop
Write_Byte (Data (IP - J));
end loop;
NC := 0;
end if;
end Write_Non_Compressed_Sequence;
begin
if Debug_Flag_Tree then
Write_Str ("==> transmitting ");
Write_Int (Length);
Write_Str (" data bytes");
Write_Eol;
end if;
Tree_Write_Int (Length);
loop
if IP > Length then
Write_Non_Compressed_Sequence;
return;
end if;
if IP + 2 <= Length
and then Data (IP) = Data (IP + 1)
and then Data (IP) = Data (IP + 2)
then
Write_Non_Compressed_Sequence;
C := 3;
IP := IP + 3;
while IP < Length
and then Data (IP) = Data (IP - 1)
and then C < Max_Count
loop
C := C + 1;
IP := IP + 1;
end loop;
if Data (IP - 1) = 0 then
if Debug_Flag_Tree then
Write_Str ("==> zeroes: ");
Write_Int (Int (C));
Write_Str (", starting at ");
Write_Int (IP - Int (C));
Write_Eol;
end if;
Write_Byte (C_Zeros + C);
elsif Data (IP - 1) = Character'Pos (' ') then
if Debug_Flag_Tree then
Write_Str ("==> spaces: ");
Write_Int (Int (C));
Write_Str (", starting at ");
Write_Int (IP - Int (C));
Write_Eol;
end if;
Write_Byte (C_Spaces + C);
else
if Debug_Flag_Tree then
Write_Str ("==> other char: ");
Write_Int (Int (C));
Write_Str (" (");
Write_Int (Int (Data (IP - 1)));
Write_Char (')');
Write_Str (", starting at ");
Write_Int (IP - Int (C));
Write_Eol;
end if;
Write_Byte (C_Repeat + C);
Write_Byte (Data (IP - 1));
end if;
else
if NC = Max_Count then
Write_Non_Compressed_Sequence;
end if;
NC := NC + 1;
IP := IP + 1;
end if;
end loop;
end Tree_Write_Data;
procedure Tree_Write_Initialize (Desc : File_Descriptor) is
begin
Bufn := 0;
Tree_FD := Desc;
Set_Standard_Error;
Debug_Flag_Tree := Debug_Flag_5;
end Tree_Write_Initialize;
procedure Tree_Write_Int (N : Int) is
N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
begin
if Debug_Flag_Tree then
Write_Str ("==> transmitting Int = ");
Write_Int (N);
Write_Eol;
end if;
for J in 1 .. 4 loop
Write_Byte (N_Bytes (J));
end loop;
end Tree_Write_Int;
procedure Tree_Write_Str (S : String_Ptr) is
begin
Tree_Write_Int (S'Length);
Tree_Write_Data (S (1)'Address, S'Length);
end Tree_Write_Str;
procedure Tree_Write_Terminate is
begin
if Bufn > 0 then
Write_Buffer;
end if;
end Tree_Write_Terminate;
procedure Write_Buffer is
begin
if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
Bufn := 0;
else
Set_Standard_Error;
Write_Str ("fatal error: disk full");
OS_Exit (2);
end if;
end Write_Buffer;
procedure Write_Byte (B : Byte) is
begin
Bufn := Bufn + 1;
Buf (Bufn) := B;
if Bufn = Buflen then
Write_Buffer;
end if;
end Write_Byte;
end Tree_IO;