1. with Interfaces; 
  2. with Ada.Text_IO; 
  3. with Ada.Unchecked_Deallocation; 
  4.  
  5. package body UnZip.Decompress.Huffman is 
  6.  
  7.    -- Note from Pascal source: 
  8.    -- C code by info - zip group, translated to pascal by Christian Ghisler 
  9.    -- based on unz51g.zip 
  10.  
  11.    -- Free huffman tables starting with table where t points to 
  12.  
  13.    procedure HufT_free (tl : in out p_Table_list) is 
  14.  
  15.       procedure  Dispose is new 
  16.         Ada.Unchecked_Deallocation (HufT_table, p_HufT_table); 
  17.       procedure  Dispose is new 
  18.         Ada.Unchecked_Deallocation (Table_list, p_Table_list); 
  19.  
  20.       current : p_Table_list; 
  21.       tcount  : Natural; -- just a stat. Idea : replace table_list with an array 
  22.  
  23.    begin 
  24.       if full_trace then 
  25.          pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  26.          Ada.Text_IO.Put ("[HufT_Free .. . "); 
  27.          tcount := 0; 
  28.          pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  29.       end if; 
  30.       while tl /= null loop 
  31.          Dispose (tl.all.table); -- destroy the Huffman table 
  32.          current := tl; 
  33.          tl     := tl.all.next; 
  34.          Dispose (current);  -- destroy the current node 
  35.          if full_trace then 
  36.             pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  37.             tcount := tcount + 1; 
  38.             pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  39.          end if; 
  40.       end loop; 
  41.       if full_trace then 
  42.          pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  43.          Ada.Text_IO.Put_Line (Integer'Image (tcount) & " tables]"); 
  44.          pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  45.       end if; 
  46.    end HufT_free; 
  47.  
  48.    -- Build huffman table from code lengths given by array b 
  49.  
  50.    procedure HufT_build (b     : Length_array; 
  51.                          s     : Integer; 
  52.                          d, e  : Length_array; 
  53.                          tl    :    out p_Table_list; 
  54.                          m     : in out Integer; 
  55.                          huft_incomplete  :    out Boolean) 
  56.    is 
  57.       use Interfaces; 
  58.  
  59.       b_max   : constant := 16; 
  60.       b_maxp1 : constant := b_max + 1; 
  61.  
  62.       -- bit length count table 
  63.       count  : array (0 .. b_maxp1) of Integer := (others => 0); 
  64.  
  65.       f    : Integer;                    -- i repeats in table every f entries 
  66.       g    : Integer;                    -- max. code length 
  67.       i,                                -- counter, current code 
  68.       j  : Integer;                    -- counter 
  69.       kcc  : Integer;                    -- number of bits in current code 
  70.  
  71.       c_idx, v_idx : Natural;            -- array indices 
  72.  
  73.       current_table_ptr  : p_HufT_table := null; 
  74.       current_node_ptr   : p_Table_list := null; -- curr. node for the curr. table 
  75.       new_node_ptr       : p_Table_list;        -- new node for the new table 
  76.  
  77.       new_entry : HufT;                  -- table entry for structure assignment 
  78.  
  79.       u  : array (0 .. b_max) of p_HufT_table;   -- table stack 
  80.  
  81.       n_max  : constant := 288; 
  82.       -- values in order of bit length 
  83.       v  : array (0 .. n_max) of Integer := (others => 0); 
  84.       el_v, el_v_m_s : Integer; 
  85.  
  86.       w  : Natural := 0;                        -- bits before this table 
  87.  
  88.       offset, code_stack  : array (0 .. b_maxp1) of Integer; 
  89.  
  90.       table_level  : Integer := -1; 
  91.       bits  : array (Integer'(-1) .. b_maxp1) of Integer; 
  92.       -- ^bits (table_level) = # bits in table of level table_level 
  93.  
  94.       y   : Integer;                     -- number of dummy codes added 
  95.       z   : Natural := 0;                 -- number of entries in current table 
  96.       el  : Integer;                     -- length of eob code=code 256 
  97.  
  98.       no_copy_length_array : constant Boolean := d'Length = 0 or else e'Length = 0; 
  99.  
  100.    begin 
  101.       if full_trace then 
  102.          pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  103.          Ada.Text_IO.Put ("[HufT_Build .. ."); 
  104.          pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  105.       end if; 
  106.       tl := null; 
  107.  
  108.       if b'Length > 256 then -- set length of EOB code, if any 
  109.          el := b (256); 
  110.       else 
  111.          el := b_max; 
  112.       end if; 
  113.  
  114.       -- Generate counts for each bit length 
  115.  
  116.       for k in b'Range loop 
  117.          if b (k) > b_max then 
  118.             -- m := 0; -- GNAT 2005 doesn't like it (warning). 
  119.             raise huft_error; 
  120.          end if; 
  121.          count (b (k)) := count (b (k)) + 1; 
  122.       end loop; 
  123.  
  124.       if count (0) = b'Length then 
  125.          m := 0; 
  126.          huft_incomplete := False; -- spotted by Tucker Taft, 19 - Aug - 2004 
  127.          return; -- complete 
  128.       end if; 
  129.  
  130.       -- Find minimum and maximum length, bound m by those 
  131.  
  132.       j := 1; 
  133.       while j <= b_max and then count (j) = 0 loop 
  134.          j := j + 1; 
  135.       end loop; 
  136.       kcc := j; 
  137.       if m < j then 
  138.          m := j; 
  139.       end if; 
  140.       i := b_max; 
  141.       while i > 0 and then count (i) = 0 loop 
  142.          i := i - 1; 
  143.       end loop; 
  144.       g := i; 
  145.       if m > i then 
  146.          m := i; 
  147.       end if; 
  148.  
  149.       -- Adjust last length count to fill out codes, if needed 
  150.  
  151.       y := Integer (Shift_Left (Unsigned_32'(1), j)); -- y := 2 ** j; 
  152.       while j < i loop 
  153.          y := y - count (j); 
  154.          if y < 0 then 
  155.             raise huft_error; 
  156.          end if; 
  157.          y := y * 2; 
  158.          j := j + 1; 
  159.       end loop; 
  160.  
  161.       y := y - count (i); 
  162.       if y < 0 then 
  163.          raise huft_error; 
  164.       end if; 
  165.       count (i) := count (i) + y; 
  166.  
  167.       -- Generate starting offsets into the value table for each length 
  168.  
  169.       offset (1) := 0; 
  170.       j := 0; 
  171.       for idx in 2 .. i loop 
  172.          j := j + count (idx - 1); 
  173.          offset (idx) := j; 
  174.       end loop; 
  175.  
  176.       -- Make table of values in order of bit length 
  177.  
  178.       for idx in b'Range loop 
  179.          j := b (idx); 
  180.          if j /= 0 then 
  181.             v (offset (j)) := idx - b'First; 
  182.             offset (j) := offset (j) + 1; 
  183.          end if; 
  184.       end loop; 
  185.  
  186.       -- Generate huffman codes and for each, make the table entries 
  187.  
  188.       code_stack (0) := 0; 
  189.       i := 0; 
  190.       v_idx := v'First; 
  191.       bits (-1) := 0; 
  192.  
  193.       -- go through the bit lengths (kcc already is bits in shortest code) 
  194.       for k in kcc .. g loop 
  195.  
  196.          for am1 in reverse 0 .. count (k) - 1 loop -- a counts codes of length k 
  197.  
  198.             -- here i is the huffman code of length k bits for value v (v_idx) 
  199.             while k > w + bits (table_level) loop 
  200.  
  201.                w := w + bits (table_level);    -- Length of tables to this position 
  202.                table_level := table_level + 1; 
  203.                z := g - w;                    -- Compute min size table <= m bits 
  204.                if z > m then 
  205.                   z := m; 
  206.                end if; 
  207.                j := k - w; 
  208.                f := Integer (Shift_Left (Unsigned_32'(1), j)); -- f := 2 ** j; 
  209.                if f > am1 + 2 then   -- Try a k - w bit table 
  210.                   f := f - (am1 + 2); 
  211.                   c_idx := k; 
  212.                   loop              -- Try smaller tables up to z bits 
  213.                      j := j + 1; 
  214.                      exit when j >= z; 
  215.                      f := f * 2; 
  216.                      c_idx := c_idx + 1; 
  217.                      exit when f - count (c_idx) <= 0; 
  218.                      f := f - count (c_idx); 
  219.                   end loop; 
  220.                end if; 
  221.  
  222.                if w + j > el and then  w < el  then 
  223.                   j := el - w;       -- Make EOB code end at table 
  224.                end if; 
  225.                if w = 0 then 
  226.                   j := m;  -- Fix : main table always m bits! 
  227.                end if; 
  228.                z := Integer (Shift_Left (Unsigned_32'(1), j)); -- z := 2 ** j; 
  229.                bits (table_level) := j; 
  230.  
  231.                -- Allocate and link new table 
  232.  
  233.                begin 
  234.                   current_table_ptr := new HufT_table (0 .. z); 
  235.                   new_node_ptr      := new Table_list'(current_table_ptr, null); 
  236.                exception 
  237.                   when Storage_Error => 
  238.                      raise huft_out_of_memory; 
  239.                end; 
  240.  
  241.                if current_node_ptr = null then -- first table 
  242.                   tl := new_node_ptr; 
  243.                else 
  244.                   current_node_ptr.all.next := new_node_ptr;   -- not my first .. . 
  245.                end if; 
  246.  
  247.                current_node_ptr := new_node_ptr; -- always non - Null from there 
  248.  
  249.                u (table_level) := current_table_ptr; 
  250.  
  251.                -- Connect to last table, if there is one 
  252.  
  253.                if table_level > 0 then 
  254.                   code_stack (table_level) := i; 
  255.                   new_entry.bits          := bits (table_level - 1); 
  256.                   new_entry.extra_bits    := 16 + j; 
  257.                   new_entry.next_table    := current_table_ptr; 
  258.  
  259.                   j :=  Integer ( 
  260.                                  Shift_Right (Unsigned_32 (i) and 
  261.                                      (Shift_Left (Unsigned_32'(1), w) - 1), 
  262.                                    w - bits (table_level - 1)) 
  263.                                 ); 
  264.  
  265.                   -- Test against bad input! 
  266.  
  267.                   if j > u (table_level - 1)'Last then 
  268.                      raise huft_error; 
  269.                   end if; 
  270.                   u (table_level - 1).all (j) := new_entry; 
  271.                end if; 
  272.  
  273.             end loop; 
  274.  
  275.             -- Set up table entry in new_entry 
  276.  
  277.             new_entry.bits      := k - w; 
  278.             new_entry.next_table := null;   -- Unused 
  279.  
  280.             if v_idx >= b'Length then 
  281.                new_entry.extra_bits := invalid; 
  282.             else 
  283.                el_v := v (v_idx); 
  284.                el_v_m_s := el_v - s; 
  285.                if el_v_m_s < 0 then -- Simple code, raw value 
  286.                   if el_v < 256 then 
  287.                      new_entry.extra_bits := 16; 
  288.                   else 
  289.                      new_entry.extra_bits := 15; 
  290.                   end if; 
  291.                   new_entry.n := el_v; 
  292.                else                    -- Non - simple - > lookup in lists 
  293.                   if no_copy_length_array then 
  294.                      raise huft_error; 
  295.                   end if; 
  296.                   new_entry.extra_bits := e (el_v_m_s); 
  297.                   new_entry.n          := d (el_v_m_s); 
  298.                end if; 
  299.                v_idx := v_idx + 1; 
  300.             end if; 
  301.  
  302.             -- fill code - like entries with new_entry 
  303.             f := Integer (Shift_Left (Unsigned_32'(1), k - w)); 
  304.             -- i.e. f := 2 ** (k - w); 
  305.             j := Integer (Shift_Right (Unsigned_32 (i), w)); 
  306.             while j < z loop 
  307.                current_table_ptr.all (j) := new_entry; 
  308.                j := j + f; 
  309.             end loop; 
  310.  
  311.             -- backwards increment the k - bit code i 
  312.             j := Integer (Shift_Left (Unsigned_32'(1), k - 1)); 
  313.             -- i.e. : j := 2 ** (k - 1) 
  314.             while (Unsigned_32 (i) and Unsigned_32 (j)) /= 0 loop 
  315.                i := Integer (Unsigned_32 (i) xor Unsigned_32 (j)); 
  316.                j :=  j / 2; 
  317.             end loop; 
  318.             i := Integer (Unsigned_32 (i) xor Unsigned_32 (j)); 
  319.  
  320.             -- backup over finished tables 
  321.             while 
  322.               Integer (Unsigned_32 (i) and (Shift_Left (1, w) - 1)) /= 
  323.               code_stack (table_level) 
  324.             loop 
  325.                table_level := table_level - 1; 
  326.                w := w - bits (table_level); -- Size of previous table! 
  327.             end loop; 
  328.  
  329.          end loop;  -- am1 
  330.       end loop;  -- k 
  331.  
  332.       if full_trace then 
  333.          pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  334.          Ada.Text_IO.Put_Line ("finished]"); 
  335.          pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  336.       end if; 
  337.  
  338.       huft_incomplete := y /= 0 and then g /= 1; 
  339.  
  340.    exception 
  341.       when others => 
  342.          HufT_free (tl); 
  343.          raise; 
  344.    end HufT_build; 
  345.  
  346. end UnZip.Decompress.Huffman;