with Interfaces;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body UnZip.Decompress.Huffman is
procedure HufT_free (tl : in out p_Table_list) is
procedure Dispose is new
Ada.Unchecked_Deallocation (HufT_table, p_HufT_table);
procedure Dispose is new
Ada.Unchecked_Deallocation (Table_list, p_Table_list);
current : p_Table_list;
tcount : Natural;
begin
if full_trace then
pragma Warnings (Off, "this code can never be executed and has been deleted");
Ada.Text_IO.Put ("[HufT_Free .. . ");
tcount := 0;
pragma Warnings (On, "this code can never be executed and has been deleted");
end if;
while tl /= null loop
Dispose (tl.all.table);
current := tl;
tl := tl.all.next;
Dispose (current);
if full_trace then
pragma Warnings (Off, "this code can never be executed and has been deleted");
tcount := tcount + 1;
pragma Warnings (On, "this code can never be executed and has been deleted");
end if;
end loop;
if full_trace then
pragma Warnings (Off, "this code can never be executed and has been deleted");
Ada.Text_IO.Put_Line (Integer'Image (tcount) & " tables]");
pragma Warnings (On, "this code can never be executed and has been deleted");
end if;
end HufT_free;
procedure HufT_build (b : Length_array;
s : Integer;
d, e : Length_array;
tl : out p_Table_list;
m : in out Integer;
huft_incomplete : out Boolean)
is
use Interfaces;
b_max : constant := 16;
b_maxp1 : constant := b_max + 1;
count : array (0 .. b_maxp1) of Integer := (others => 0);
f : Integer;
g : Integer;
i,
j : Integer;
kcc : Integer;
c_idx, v_idx : Natural;
current_table_ptr : p_HufT_table := null;
current_node_ptr : p_Table_list := null;
new_node_ptr : p_Table_list;
new_entry : HufT;
u : array (0 .. b_max) of p_HufT_table;
n_max : constant := 288;
v : array (0 .. n_max) of Integer := (others => 0);
el_v, el_v_m_s : Integer;
w : Natural := 0;
offset, code_stack : array (0 .. b_maxp1) of Integer;
table_level : Integer := -1;
bits : array (Integer'(-1) .. b_maxp1) of Integer;
y : Integer;
z : Natural := 0;
el : Integer;
no_copy_length_array : constant Boolean := d'Length = 0 or else e'Length = 0;
begin
if full_trace then
pragma Warnings (Off, "this code can never be executed and has been deleted");
Ada.Text_IO.Put ("[HufT_Build .. .");
pragma Warnings (On, "this code can never be executed and has been deleted");
end if;
tl := null;
if b'Length > 256 then
el := b (256);
else
el := b_max;
end if;
for k in b'Range loop
if b (k) > b_max then
raise huft_error;
end if;
count (b (k)) := count (b (k)) + 1;
end loop;
if count (0) = b'Length then
m := 0;
huft_incomplete := False;
return;
end if;
j := 1;
while j <= b_max and then count (j) = 0 loop
j := j + 1;
end loop;
kcc := j;
if m < j then
m := j;
end if;
i := b_max;
while i > 0 and then count (i) = 0 loop
i := i - 1;
end loop;
g := i;
if m > i then
m := i;
end if;
y := Integer (Shift_Left (Unsigned_32'(1), j));
while j < i loop
y := y - count (j);
if y < 0 then
raise huft_error;
end if;
y := y * 2;
j := j + 1;
end loop;
y := y - count (i);
if y < 0 then
raise huft_error;
end if;
count (i) := count (i) + y;
offset (1) := 0;
j := 0;
for idx in 2 .. i loop
j := j + count (idx - 1);
offset (idx) := j;
end loop;
for idx in b'Range loop
j := b (idx);
if j /= 0 then
v (offset (j)) := idx - b'First;
offset (j) := offset (j) + 1;
end if;
end loop;
code_stack (0) := 0;
i := 0;
v_idx := v'First;
bits (-1) := 0;
for k in kcc .. g loop
for am1 in reverse 0 .. count (k) - 1 loop
while k > w + bits (table_level) loop
w := w + bits (table_level);
table_level := table_level + 1;
z := g - w;
if z > m then
z := m;
end if;
j := k - w;
f := Integer (Shift_Left (Unsigned_32'(1), j));
if f > am1 + 2 then
f := f - (am1 + 2);
c_idx := k;
loop
j := j + 1;
exit when j >= z;
f := f * 2;
c_idx := c_idx + 1;
exit when f - count (c_idx) <= 0;
f := f - count (c_idx);
end loop;
end if;
if w + j > el and then w < el then
j := el - w;
end if;
if w = 0 then
j := m;
end if;
z := Integer (Shift_Left (Unsigned_32'(1), j));
bits (table_level) := j;
begin
current_table_ptr := new HufT_table (0 .. z);
new_node_ptr := new Table_list'(current_table_ptr, null);
exception
when Storage_Error =>
raise huft_out_of_memory;
end;
if current_node_ptr = null then
tl := new_node_ptr;
else
current_node_ptr.all.next := new_node_ptr;
end if;
current_node_ptr := new_node_ptr;
u (table_level) := current_table_ptr;
if table_level > 0 then
code_stack (table_level) := i;
new_entry.bits := bits (table_level - 1);
new_entry.extra_bits := 16 + j;
new_entry.next_table := current_table_ptr;
j := Integer (
Shift_Right (Unsigned_32 (i) and
(Shift_Left (Unsigned_32'(1), w) - 1),
w - bits (table_level - 1))
);
if j > u (table_level - 1)'Last then
raise huft_error;
end if;
u (table_level - 1).all (j) := new_entry;
end if;
end loop;
new_entry.bits := k - w;
new_entry.next_table := null;
if v_idx >= b'Length then
new_entry.extra_bits := invalid;
else
el_v := v (v_idx);
el_v_m_s := el_v - s;
if el_v_m_s < 0 then
if el_v < 256 then
new_entry.extra_bits := 16;
else
new_entry.extra_bits := 15;
end if;
new_entry.n := el_v;
else
if no_copy_length_array then
raise huft_error;
end if;
new_entry.extra_bits := e (el_v_m_s);
new_entry.n := d (el_v_m_s);
end if;
v_idx := v_idx + 1;
end if;
f := Integer (Shift_Left (Unsigned_32'(1), k - w));
j := Integer (Shift_Right (Unsigned_32 (i), w));
while j < z loop
current_table_ptr.all (j) := new_entry;
j := j + f;
end loop;
j := Integer (Shift_Left (Unsigned_32'(1), k - 1));
while (Unsigned_32 (i) and Unsigned_32 (j)) /= 0 loop
i := Integer (Unsigned_32 (i) xor Unsigned_32 (j));
j := j / 2;
end loop;
i := Integer (Unsigned_32 (i) xor Unsigned_32 (j));
while
Integer (Unsigned_32 (i) and (Shift_Left (1, w) - 1)) /=
code_stack (table_level)
loop
table_level := table_level - 1;
w := w - bits (table_level);
end loop;
end loop;
end loop;
if full_trace then
pragma Warnings (Off, "this code can never be executed and has been deleted");
Ada.Text_IO.Put_Line ("finished]");
pragma Warnings (On, "this code can never be executed and has been deleted");
end if;
huft_incomplete := y /= 0 and then g /= 1;
exception
when others =>
HufT_free (tl);
raise;
end HufT_build;
end UnZip.Decompress.Huffman;