1. -- See bzip2.ads for legal stuff 
  2. -- 
  3. -- Documentation pointers: 
  4. -- 
  5. --   Burrows - Wheeler transform 
  6. --     http://en.wikipedia.org/wiki/Burrows%E2%80%93Wheeler_transform 
  7. --   MTF Move - To - Front 
  8. --     http://fr.wikipedia.org/wiki/Move - To - Front 
  9. -- 
  10. -- Translated on 20 - Oct - 2009 by (New) P2Ada v. 15 - Nov - 2006 
  11. -- 
  12. -- with Ada.Text_IO;                       use Ada.Text_IO; 
  13.  
  14. with Ada.Unchecked_Deallocation; 
  15.  
  16. package body BZip2 is 
  17.  
  18.    procedure Decompress is 
  19.  
  20.       max_groups     : constant := 6; 
  21.       max_alpha_size : constant := 258; 
  22.       max_code_len   : constant := 23; 
  23.       group_size     : constant := 50; 
  24.       max_selectors  : constant := 2 + (900_000 / group_size); 
  25.  
  26.       sub_block_size : constant := 100_000; 
  27.  
  28.       type Length_array is array (Integer range <>) of Natural; 
  29.  
  30.       block_randomized : Boolean := False; 
  31.       block_size : Natural; 
  32.  
  33.       use Interfaces; 
  34.  
  35.       type Tcardinal_array is array (Integer range <>) of Unsigned_32; 
  36.       type Pcardinal_array is access Tcardinal_array; 
  37.       procedure Dispose is new Ada.Unchecked_Deallocation (Tcardinal_array, Pcardinal_array); 
  38.       tt : Pcardinal_array; 
  39.       tt_count : Natural; 
  40.  
  41.       rle_run_left : Natural := 0; 
  42.       rle_run_data : Unsigned_8 := 0; 
  43.       decode_available : Natural := Natural'Last; 
  44.       block_origin : Natural := 0; 
  45.       read_data : Unsigned_8 := 0; 
  46.       bits_available : Natural := 0; 
  47.       inuse_count : Natural; 
  48.       seq_to_unseq : array (0 .. 255) of Natural; 
  49.       global_alpha_size : Natural; 
  50.       group_count : Natural; 
  51.       -- 
  52.       selector_count : Natural; 
  53.       selector, selector_mtf : array (0 .. max_selectors) of Unsigned_8; 
  54.       -- 
  55.       type Alpha_U32_array is array (0 .. max_alpha_size) of Unsigned_32; 
  56.       type Alpha_Nat_array is array (0 .. max_alpha_size) of Natural; 
  57.  
  58.       len   : array (0 .. max_groups) of Alpha_Nat_array; 
  59.       global_limit, 
  60.       global_base, 
  61.       global_perm  : array (0 .. max_groups) of Alpha_U32_array; 
  62.       -- 
  63.       minlens : Length_array (0 .. max_groups); 
  64.       cftab : array (0 .. 257) of Natural; 
  65.       -- 
  66.       end_reached : Boolean := False; 
  67.  
  68.       in_buf : Buffer (1 .. input_buffer_size); 
  69.       in_idx : Natural := in_buf'Last + 1; 
  70.  
  71.       function Read_byte return Unsigned_8 is 
  72.          res : Unsigned_8; 
  73.       begin 
  74.          if in_idx > in_buf'Last then 
  75.             Read (in_buf); 
  76.             in_idx := in_buf'First; 
  77.          end if; 
  78.          res := in_buf (in_idx); 
  79.          in_idx := in_idx + 1; 
  80.          return res; 
  81.       end Read_byte; 
  82.  
  83.       procedure hb_create_decode_tables (limit, base, perm : in out Alpha_U32_array; 
  84.                                          length            :        Alpha_Nat_array; 
  85.                                          min_len, max_len  :        Natural; 
  86.                                          alpha_size        :        Integer) is 
  87.  
  88.          pp, idx : Integer; 
  89.          vec : Unsigned_32; 
  90.  
  91.       begin 
  92.          pp := 0; 
  93.          for i in min_len .. max_len loop 
  94.             for j in 0 .. alpha_size - 1 loop 
  95.                if length (j) = i then 
  96.                   perm (pp) := Unsigned_32 (j); 
  97.                   pp := pp + 1; 
  98.                end if; 
  99.             end loop; 
  100.          end loop; 
  101.          for i in 0 .. max_code_len - 1 loop 
  102.             base (i) := 0; 
  103.             limit (i) := 0; 
  104.          end loop; 
  105.          for i in 0 .. alpha_size - 1 loop 
  106.             idx := length (i) + 1; 
  107.             base (idx) := base (idx) + 1; 
  108.          end loop; 
  109.          for i in 1 .. max_code_len - 1 loop 
  110.             base (i) := base (i) + base (i - 1); 
  111.          end loop; 
  112.          vec := 0; 
  113.          for i in min_len .. max_len loop 
  114.             vec := vec + base (i + 1) - base (i); 
  115.             limit (i) := vec - 1; 
  116.             vec := vec * 2; 
  117.          end loop; 
  118.          for i in min_len + 1 .. max_len loop 
  119.             base (i) := (limit (i - 1) + 1) * 2 - base (i); 
  120.          end loop; 
  121.       end hb_create_decode_tables; 
  122.  
  123.       procedure Init is 
  124.          magic : String (1 .. 3); 
  125.          b : Unsigned_8; 
  126.       begin 
  127.          --  Read the magic. 
  128.          for i in magic'Range loop 
  129.             b := Read_byte; 
  130.             magic (i) := Character'Val (b); 
  131.          end loop; 
  132.          if magic /= "BZh" then 
  133.             raise bad_header_magic; 
  134.          end if; 
  135.          --  Read the block size and allocate the working array. 
  136.          b := Read_byte; 
  137.          block_size := Natural (b) - Character'Pos ('0'); 
  138.          tt := new Tcardinal_array (0 .. block_size * sub_block_size); 
  139.       end Init; 
  140.  
  141.       function get_bits (n : Natural) return Unsigned_8 is 
  142.          Result_get_bits  : Unsigned_8; 
  143.          data : Unsigned_8; 
  144.       begin 
  145.          if n > bits_available then 
  146.             data := Read_byte; 
  147.             Result_get_bits := Shift_Right (read_data, 8 - n) or Shift_Right (data, 8 - (n - bits_available)); 
  148.             read_data := Shift_Left (data, n - bits_available); 
  149.             bits_available := bits_available + 8; 
  150.          else 
  151.             Result_get_bits := Shift_Right (read_data, 8 - n); 
  152.             read_data := Shift_Left (read_data, n); 
  153.          end if; 
  154.          bits_available := bits_available - n; 
  155.          return Result_get_bits; 
  156.       end get_bits; 
  157.  
  158.       function get_bits_32 (n : Natural) return Unsigned_32 is 
  159.       begin 
  160.          return Unsigned_32 (get_bits (n)); 
  161.       end get_bits_32; 
  162.  
  163.       function get_boolean return Boolean is 
  164.       begin 
  165.          return Boolean'Val (get_bits (1)); 
  166.       end get_boolean; 
  167.  
  168.       function get_byte return Unsigned_8 is 
  169.       begin 
  170.          return get_bits (8); 
  171.       end get_byte; 
  172.  
  173.       function get_cardinal24 return Unsigned_32 is 
  174.       begin 
  175.          return Shift_Left (get_bits_32 (8), 16) or Shift_Left (get_bits_32 (8), 8) or get_bits_32 (8); 
  176.       end get_cardinal24; 
  177.  
  178.       function get_cardinal return Unsigned_32 is 
  179.       begin 
  180.          return Shift_Left (get_bits_32 (8), 24)  or 
  181.            Shift_Left (get_bits_32 (8), 16)  or 
  182.            Shift_Left (get_bits_32 (8), 8)  or 
  183.            get_bits_32 (8); 
  184.       end get_cardinal; 
  185.  
  186.       --  Receive the mapping table. To save space, the inuse set is stored in pieces 
  187.       --  of 16 bits. First 16 bits are stored which pieces of 16 bits are used, then 
  188.       --  the pieces follow. 
  189.       procedure receive_mapping_table is 
  190.          inuse16 : array (0 .. 15) of Boolean; 
  191.          --* inuse : array (0 .. 255) of Boolean; -- for dump purposes 
  192.       begin 
  193.          inuse16 := (others => False); 
  194.          --  Receive the first 16 bits which tell which pieces are stored. 
  195.          for i in 0 .. 15 loop 
  196.             inuse16 (i) := get_boolean; 
  197.          end loop; 
  198.          --  Receive the used pieces. 
  199.          --* inuse := (others => False); 
  200.          inuse_count := 0; 
  201.          for i in 0 .. 15 loop 
  202.             if inuse16 (i) then 
  203.                for j in 0 .. 15 loop 
  204.                   if get_boolean then 
  205.                      --* inuse (16*i + j) := True; 
  206.                      seq_to_unseq (inuse_count) := 16 * i + j; 
  207.                      inuse_count := inuse_count + 1; 
  208.                   end if; 
  209.                end loop; 
  210.             end if; 
  211.          end loop; 
  212.       end receive_mapping_table; 
  213.  
  214.       --  Receives the selectors. 
  215.       procedure receive_selectors is 
  216.          j : Unsigned_8; 
  217.       begin 
  218.          group_count := Natural (get_bits (3)); 
  219.          selector_count := Natural (Shift_Left (get_bits_32 (8), 7) or get_bits_32 (7)); 
  220.          for i in 0 .. selector_count - 1 loop 
  221.             j := 0; 
  222.             while get_boolean loop 
  223.                j := j + 1; 
  224.                if j > 5 then 
  225.                   raise data_error; 
  226.                end if; 
  227.             end loop; 
  228.             selector_mtf (i) := j; 
  229.          end loop; 
  230.       end receive_selectors; 
  231.  
  232.       --  Undo the MTF values for the selectors. 
  233.       procedure undo_mtf_values is 
  234.          pos : array (0 .. max_groups) of Natural; 
  235.          v, tmp : Natural; 
  236.       begin 
  237.          for w in 0 .. group_count - 1 loop 
  238.             pos (w) := w; 
  239.          end loop; 
  240.          for i in 0 .. selector_count - 1 loop 
  241.             v := Natural (selector_mtf (i)); 
  242.             tmp := pos (v); 
  243.             while v /= 0 loop 
  244.                pos (v) := pos (v - 1); 
  245.                v := v - 1; 
  246.             end loop; 
  247.             pos (0) := tmp; 
  248.             selector (i) := Unsigned_8 (tmp); 
  249.          end loop; 
  250.       end undo_mtf_values; 
  251.  
  252.       procedure receive_coding_tables is 
  253.          curr : Natural; 
  254.       begin 
  255.          for t in 0 .. group_count - 1 loop 
  256.             curr := Natural (get_bits (5)); 
  257.             for i in 0 .. global_alpha_size - 1 loop 
  258.                loop 
  259.                   if curr not in 1 .. 20 then 
  260.                      raise data_error; 
  261.                   end if; 
  262.                   exit when not get_boolean; 
  263.                   if get_boolean then 
  264.                      curr := curr - 1; 
  265.                   else 
  266.                      curr := curr + 1; 
  267.                   end if; 
  268.                end loop; 
  269.                len (t) (i) := curr; 
  270.             end loop; 
  271.          end loop; 
  272.       end receive_coding_tables; 
  273.  
  274.       --  Builds the Huffman tables. 
  275.       procedure make_hufftab is 
  276.          minlen, maxlen : Natural; 
  277.       begin 
  278.          for t in 0 .. group_count - 1 loop 
  279.             minlen := 32; 
  280.             maxlen := 0; 
  281.             for i in 0 .. global_alpha_size - 1 loop 
  282.                if len (t) (i) > maxlen then 
  283.                   maxlen := len (t) (i); 
  284.                end if; 
  285.                if len (t) (i) < minlen then 
  286.                   minlen := len (t) (i); 
  287.                end if; 
  288.             end loop; 
  289.             hb_create_decode_tables (global_limit (t), global_base (t), global_perm (t), len (t), 
  290.                                      minlen, maxlen, global_alpha_size); 
  291.             minlens (t) := minlen; 
  292.          end loop; 
  293.       end make_hufftab; 
  294.  
  295.       ------------------------- 
  296.       -- MTF - Move To Front -- 
  297.       ------------------------- 
  298.  
  299.       procedure receive_mtf_values is 
  300.          -- 
  301.          mtfa_size : constant := 4096; 
  302.          mtfl_size : constant := 16; 
  303.          mtfbase : array (0 .. 256 / mtfl_size - 1) of Natural; 
  304.          mtfa : array (0 .. mtfa_size - 1) of Natural; 
  305.          -- 
  306.          procedure init_mtf is 
  307.             k : Natural := mtfa_size - 1; 
  308.          begin 
  309.             for i in reverse 0 .. 256  /  mtfl_size - 1 loop 
  310.                for j in reverse 0 .. mtfl_size - 1 loop 
  311.                   mtfa (k) := i * mtfl_size + j; 
  312.                   k := k - 1; 
  313.                end loop; 
  314.                mtfbase (i) := k + 1; 
  315.             end loop; 
  316.          end init_mtf; 
  317.          -- 
  318.          group_pos, group_no : Integer; 
  319.          gminlen, gsel : Natural; 
  320.          -- 
  321.          function get_mtf_value return Unsigned_32 is 
  322.             zn : Natural; 
  323.             zvec : Unsigned_32; 
  324.          begin 
  325.             if group_pos = 0 then 
  326.                group_no := group_no + 1; 
  327.                group_pos := group_size; 
  328.                gsel := Natural (selector (group_no)); 
  329.                gminlen := minlens (gsel); 
  330.             end if; 
  331.             group_pos := group_pos - 1; 
  332.             zn := gminlen; 
  333.             zvec := get_bits_32 (zn); 
  334.             while zvec > global_limit (gsel) (zn) loop 
  335.                zn := zn + 1; 
  336.                zvec := Shift_Left (zvec, 1) or get_bits_32 (1); 
  337.             end loop; 
  338.             return global_perm (gsel) (Natural (zvec - global_base (gsel) (zn))); 
  339.          end get_mtf_value; 
  340.          -- 
  341.          procedure move_mtf_block is 
  342.             j, k : Natural; 
  343.          begin 
  344.             k := mtfa_size; 
  345.             for i in reverse 0 .. 256  /  mtfl_size - 1 loop 
  346.                j := mtfbase (i); 
  347.                mtfa (k - 16 .. k - 1) := mtfa (j .. j + 15); 
  348.                k := k - 16; 
  349.                mtfbase (i) := k; 
  350.             end loop; 
  351.          end move_mtf_block; 
  352.          -- 
  353.          run_b : constant := 1; 
  354.          t : Natural; 
  355.          next_sym : Unsigned_32; 
  356.          es : Natural; 
  357.          n, nn : Natural; 
  358.          p, q : Natural; -- indexes mtfa 
  359.          u, v : Natural; -- indexes mtfbase 
  360.          lno, off : Natural; 
  361.       begin -- receive_mtf_values 
  362.          group_no := -1; 
  363.          group_pos := 0; 
  364.          t := 0; 
  365.          cftab := (others => 0); 
  366.          init_mtf; 
  367.          next_sym := get_mtf_value; 
  368.          -- 
  369.          while Natural (next_sym) /= inuse_count + 1 loop 
  370.             if next_sym <= run_b then 
  371.                es := 0; 
  372.                n := 0; 
  373.                loop 
  374.                   es := es + Natural (Shift_Left (next_sym + 1, n)); 
  375.                   n := n + 1; 
  376.                   next_sym := get_mtf_value; 
  377.                   exit when next_sym > run_b; 
  378.                end loop; 
  379.                n := seq_to_unseq (mtfa (mtfbase (0))); 
  380.                cftab (n) := cftab (n) + es; 
  381.                if t + es > sub_block_size * block_size then 
  382.                   raise data_error; 
  383.                end if; 
  384.                while es > 0 loop 
  385.                   tt.all (t) := Unsigned_32 (n); 
  386.                   es := es - 1; 
  387.                   t := t + 1; 
  388.                end loop; 
  389.             else 
  390.                nn := Natural (next_sym - 1); 
  391.                if nn < mtfl_size then 
  392.                   -- Avoid the costs of the general case. 
  393.                   p := mtfbase (0); 
  394.                   q := p + nn; 
  395.                   n := mtfa (q); 
  396.                   loop 
  397.                      mtfa (q) := mtfa (q - 1); 
  398.                      q := q - 1; 
  399.                      exit when q = p; 
  400.                   end loop; 
  401.                   mtfa (q) := n; 
  402.                else 
  403.                   --  General case. 
  404.                   lno := nn   /   mtfl_size; 
  405.                   off := nn  mod  mtfl_size; 
  406.                   p := mtfbase (lno); 
  407.                   q := p + off; 
  408.                   n := mtfa (q); 
  409.                   while q /= p loop 
  410.                      mtfa (q) := mtfa (q - 1); 
  411.                      q := q - 1; 
  412.                   end loop; 
  413.                   u := mtfbase'First; 
  414.                   v := u + lno; 
  415.                   loop 
  416.                      mtfa (mtfbase (v)) := mtfa (mtfbase (v - 1) + mtfl_size - 1); 
  417.                      v := v - 1; 
  418.                      mtfbase (v) := mtfbase (v) - 1; 
  419.                      exit when v = u; 
  420.                   end loop; 
  421.                   mtfa (mtfbase (v)) := n; 
  422.                   if mtfbase (v) = 0 then 
  423.                      move_mtf_block; 
  424.                   end if; 
  425.                end if; 
  426.                cftab (seq_to_unseq (n)) := cftab (seq_to_unseq (n)) + 1; 
  427.                tt.all (t) := Unsigned_32 (seq_to_unseq (n)); 
  428.                t := t + 1; 
  429.                if t > sub_block_size * block_size then 
  430.                   raise data_error; 
  431.                end if; 
  432.                next_sym := get_mtf_value; 
  433.             end if; 
  434.          end loop; 
  435.          tt_count := t; 
  436.          --  Setup cftab to facilitate generation of T^ ( - 1). 
  437.          t := 0; 
  438.          for i in 0 .. 256 loop 
  439.             nn := cftab (i); 
  440.             cftab (i) := t; 
  441.             t := t + nn; 
  442.          end loop; 
  443.       end receive_mtf_values; 
  444.  
  445.       procedure detransform is 
  446.          a : Unsigned_32; 
  447.          p, q, r, i255 : Natural; 
  448.       begin 
  449.          a := 0; 
  450.          p := tt'First; 
  451.          q := p + tt_count; 
  452.          while p /= q loop 
  453.             i255 := Natural (tt.all (p) and 16#ff#); 
  454.             r := cftab (i255); 
  455.             cftab (i255) := cftab (i255) + 1; 
  456.             tt.all (r) := tt.all (r) or a; 
  457.             a := a + 256; 
  458.             p := p + 1; 
  459.          end loop; 
  460.       end detransform; 
  461.  
  462.       -- Cyclic redundancy check to verify uncompressed block data integrity 
  463.  
  464.       package CRC is 
  465.  
  466.          procedure Init (CRC_Value : out Unsigned_32); 
  467.          function  Final (CRC_Value : Unsigned_32) return Unsigned_32; 
  468.          procedure Update (CRC_Value : in out Unsigned_32; val : Unsigned_8); 
  469.          pragma Inline (Update); 
  470.  
  471.       end CRC; 
  472.  
  473.       package body CRC is 
  474.  
  475.          CRC32_Table : 
  476.          constant array (Unsigned_32'(0) .. 255) of Unsigned_32 := ( 
  477.                                                                     16#00000000#, 16#04c11db7#, 16#09823b6e#, 16#0d4326d9#, 
  478.                                                                     16#130476dc#, 16#17c56b6b#, 16#1a864db2#, 16#1e475005#, 
  479.                                                                     16#2608edb8#, 16#22c9f00f#, 16#2f8ad6d6#, 16#2b4bcb61#, 
  480.                                                                     16#350c9b64#, 16#31cd86d3#, 16#3c8ea00a#, 16#384fbdbd#, 
  481.                                                                     16#4c11db70#, 16#48d0c6c7#, 16#4593e01e#, 16#4152fda9#, 
  482.                                                                     16#5f15adac#, 16#5bd4b01b#, 16#569796c2#, 16#52568b75#, 
  483.                                                                     16#6a1936c8#, 16#6ed82b7f#, 16#639b0da6#, 16#675a1011#, 
  484.                                                                     16#791d4014#, 16#7ddc5da3#, 16#709f7b7a#, 16#745e66cd#, 
  485.                                                                     16#9823b6e0#, 16#9ce2ab57#, 16#91a18d8e#, 16#95609039#, 
  486.                                                                     16#8b27c03c#, 16#8fe6dd8b#, 16#82a5fb52#, 16#8664e6e5#, 
  487.                                                                     16#be2b5b58#, 16#baea46ef#, 16#b7a96036#, 16#b3687d81#, 
  488.                                                                     16#ad2f2d84#, 16#a9ee3033#, 16#a4ad16ea#, 16#a06c0b5d#, 
  489.                                                                     16#d4326d90#, 16#d0f37027#, 16#ddb056fe#, 16#d9714b49#, 
  490.                                                                     16#c7361b4c#, 16#c3f706fb#, 16#ceb42022#, 16#ca753d95#, 
  491.                                                                     16#f23a8028#, 16#f6fb9d9f#, 16#fbb8bb46#, 16#ff79a6f1#, 
  492.                                                                     16#e13ef6f4#, 16#e5ffeb43#, 16#e8bccd9a#, 16#ec7dd02d#, 
  493.                                                                     16#34867077#, 16#30476dc0#, 16#3d044b19#, 16#39c556ae#, 
  494.                                                                     16#278206ab#, 16#23431b1c#, 16#2e003dc5#, 16#2ac12072#, 
  495.                                                                     16#128e9dcf#, 16#164f8078#, 16#1b0ca6a1#, 16#1fcdbb16#, 
  496.                                                                     16#018aeb13#, 16#054bf6a4#, 16#0808d07d#, 16#0cc9cdca#, 
  497.                                                                     16#7897ab07#, 16#7c56b6b0#, 16#71159069#, 16#75d48dde#, 
  498.                                                                     16#6b93dddb#, 16#6f52c06c#, 16#6211e6b5#, 16#66d0fb02#, 
  499.                                                                     16#5e9f46bf#, 16#5a5e5b08#, 16#571d7dd1#, 16#53dc6066#, 
  500.                                                                     16#4d9b3063#, 16#495a2dd4#, 16#44190b0d#, 16#40d816ba#, 
  501.                                                                     16#aca5c697#, 16#a864db20#, 16#a527fdf9#, 16#a1e6e04e#, 
  502.                                                                     16#bfa1b04b#, 16#bb60adfc#, 16#b6238b25#, 16#b2e29692#, 
  503.                                                                     16#8aad2b2f#, 16#8e6c3698#, 16#832f1041#, 16#87ee0df6#, 
  504.                                                                     16#99a95df3#, 16#9d684044#, 16#902b669d#, 16#94ea7b2a#, 
  505.                                                                     16#e0b41de7#, 16#e4750050#, 16#e9362689#, 16#edf73b3e#, 
  506.                                                                     16#f3b06b3b#, 16#f771768c#, 16#fa325055#, 16#fef34de2#, 
  507.                                                                     16#c6bcf05f#, 16#c27dede8#, 16#cf3ecb31#, 16#cbffd686#, 
  508.                                                                     16#d5b88683#, 16#d1799b34#, 16#dc3abded#, 16#d8fba05a#, 
  509.                                                                     16#690ce0ee#, 16#6dcdfd59#, 16#608edb80#, 16#644fc637#, 
  510.                                                                     16#7a089632#, 16#7ec98b85#, 16#738aad5c#, 16#774bb0eb#, 
  511.                                                                     16#4f040d56#, 16#4bc510e1#, 16#46863638#, 16#42472b8f#, 
  512.                                                                     16#5c007b8a#, 16#58c1663d#, 16#558240e4#, 16#51435d53#, 
  513.                                                                     16#251d3b9e#, 16#21dc2629#, 16#2c9f00f0#, 16#285e1d47#, 
  514.                                                                     16#36194d42#, 16#32d850f5#, 16#3f9b762c#, 16#3b5a6b9b#, 
  515.                                                                     16#0315d626#, 16#07d4cb91#, 16#0a97ed48#, 16#0e56f0ff#, 
  516.                                                                     16#1011a0fa#, 16#14d0bd4d#, 16#19939b94#, 16#1d528623#, 
  517.                                                                     16#f12f560e#, 16#f5ee4bb9#, 16#f8ad6d60#, 16#fc6c70d7#, 
  518.                                                                     16#e22b20d2#, 16#e6ea3d65#, 16#eba91bbc#, 16#ef68060b#, 
  519.                                                                     16#d727bbb6#, 16#d3e6a601#, 16#dea580d8#, 16#da649d6f#, 
  520.                                                                     16#c423cd6a#, 16#c0e2d0dd#, 16#cda1f604#, 16#c960ebb3#, 
  521.                                                                     16#bd3e8d7e#, 16#b9ff90c9#, 16#b4bcb610#, 16#b07daba7#, 
  522.                                                                     16#ae3afba2#, 16#aafbe615#, 16#a7b8c0cc#, 16#a379dd7b#, 
  523.                                                                     16#9b3660c6#, 16#9ff77d71#, 16#92b45ba8#, 16#9675461f#, 
  524.                                                                     16#8832161a#, 16#8cf30bad#, 16#81b02d74#, 16#857130c3#, 
  525.                                                                     16#5d8a9099#, 16#594b8d2e#, 16#5408abf7#, 16#50c9b640#, 
  526.                                                                     16#4e8ee645#, 16#4a4ffbf2#, 16#470cdd2b#, 16#43cdc09c#, 
  527.                                                                     16#7b827d21#, 16#7f436096#, 16#7200464f#, 16#76c15bf8#, 
  528.                                                                     16#68860bfd#, 16#6c47164a#, 16#61043093#, 16#65c52d24#, 
  529.                                                                     16#119b4be9#, 16#155a565e#, 16#18197087#, 16#1cd86d30#, 
  530.                                                                     16#029f3d35#, 16#065e2082#, 16#0b1d065b#, 16#0fdc1bec#, 
  531.                                                                     16#3793a651#, 16#3352bbe6#, 16#3e119d3f#, 16#3ad08088#, 
  532.                                                                     16#2497d08d#, 16#2056cd3a#, 16#2d15ebe3#, 16#29d4f654#, 
  533.                                                                     16#c5a92679#, 16#c1683bce#, 16#cc2b1d17#, 16#c8ea00a0#, 
  534.                                                                     16#d6ad50a5#, 16#d26c4d12#, 16#df2f6bcb#, 16#dbee767c#, 
  535.                                                                     16#e3a1cbc1#, 16#e760d676#, 16#ea23f0af#, 16#eee2ed18#, 
  536.                                                                     16#f0a5bd1d#, 16#f464a0aa#, 16#f9278673#, 16#fde69bc4#, 
  537.                                                                     16#89b8fd09#, 16#8d79e0be#, 16#803ac667#, 16#84fbdbd0#, 
  538.                                                                     16#9abc8bd5#, 16#9e7d9662#, 16#933eb0bb#, 16#97ffad0c#, 
  539.                                                                     16#afb010b1#, 16#ab710d06#, 16#a6322bdf#, 16#a2f33668#, 
  540.                                                                     16#bcb4666d#, 16#b8757bda#, 16#b5365d03#, 16#b1f740b4# 
  541.                                                                    ); 
  542.  
  543.          procedure Update (CRC_Value : in out Unsigned_32; val : Unsigned_8) is 
  544.          begin 
  545.             CRC_Value := 
  546.               CRC32_Table (16#FF# and (Shift_Right (CRC_Value, 24) xor Unsigned_32 (val))) 
  547.               xor 
  548.                 Shift_Left (CRC_Value, 8); 
  549.          end Update; 
  550.  
  551.          procedure Init (CRC_Value : out Unsigned_32) is 
  552.          begin 
  553.             CRC_Value := 16#FFFF_FFFF#; 
  554.          end Init; 
  555.  
  556.          function Final (CRC_Value : Unsigned_32) return Unsigned_32 is 
  557.          begin 
  558.             return not CRC_Value; 
  559.          end Final; 
  560.  
  561.       end CRC; 
  562.  
  563.       compare_final_CRC : Boolean := False; 
  564.       stored_blockcrc, mem_stored_blockcrc, computed_crc : Unsigned_32; 
  565.  
  566.       -- Decode a new compressed block. 
  567.       function decode_block return Boolean is 
  568.          magic : String (1 .. 6); 
  569.       begin 
  570.          for i in 1 .. 6 loop 
  571.             magic (i) := Character'Val (get_byte); 
  572.          end loop; 
  573.          if magic = "1AY&SY" then 
  574.             if check_CRC then 
  575.                if compare_final_CRC then 
  576.                   null; -- initialisation is delayed until the rle buffer is empty 
  577.                else 
  578.                   CRC.Init (computed_crc); -- Initialize for next block. 
  579.                end if; 
  580.             end if; 
  581.             stored_blockcrc := get_cardinal; 
  582.             block_randomized := get_boolean; 
  583.             block_origin := Natural (get_cardinal24); 
  584.             --  Receive the mapping table. 
  585.             receive_mapping_table; 
  586.             global_alpha_size := inuse_count + 2; 
  587.             --  Receive the selectors. 
  588.             receive_selectors; 
  589.             --  Undo the MTF values for the selectors. 
  590.             undo_mtf_values; 
  591.             --  Receive the coding tables. 
  592.             receive_coding_tables; 
  593.             --  Build the Huffman tables. 
  594.             make_hufftab; 
  595.             --  Receive the MTF values. 
  596.             receive_mtf_values; 
  597.             --  Undo the Burrows Wheeler transformation. 
  598.             detransform; 
  599.             decode_available := tt_count; 
  600.             return True; 
  601.          elsif magic = Character'Val (16#17#) & "rE8P" & Character'Val (16#90#) then 
  602.             return False; 
  603.          else 
  604.             raise bad_block_magic; 
  605.          end if; 
  606.       end decode_block; 
  607.  
  608.       next_rle_idx : Integer := -2; 
  609.       buf : Buffer (1 .. output_buffer_size); 
  610.       last : Natural; 
  611.  
  612.       procedure Read is 
  613.          shorten : Natural := 0; 
  614.  
  615.          procedure rle_read is 
  616.             rle_len : Natural; 
  617.             data : Unsigned_8; 
  618.             idx : Integer := buf'First; 
  619.             count : Integer := buf'Length; 
  620.             -- 
  621.             procedure rle_write is 
  622.                pragma Inline (rle_write); 
  623.             begin 
  624.                loop 
  625.                   buf (idx) := data; 
  626.                   idx := idx + 1; 
  627.                   count := count - 1; 
  628.                   rle_len := rle_len - 1; 
  629.                   if check_CRC then 
  630.                      CRC.Update (computed_crc, data); 
  631.                      if rle_len = 0 and then compare_final_CRC then 
  632.                         if CRC.Final (computed_crc) /= mem_stored_blockcrc then 
  633.                            raise block_crc_check_failed; 
  634.                         end if; 
  635.                         compare_final_CRC := False; 
  636.                         CRC.Init (computed_crc); -- Initialize for next block. 
  637.                      end if; 
  638.                   end if; 
  639.                   exit when rle_len = 0 or else count = 0; 
  640.                end loop; 
  641.             end rle_write; 
  642.             -- 
  643.             -- handle extreme cases of data of length 1, 2 
  644.             input_dried : exception; 
  645.             -- 
  646.             -- Make next_rle_idx index to the next decoded byte. 
  647.             -- If next_rle_idx did index to the last 
  648.             -- byte in the current block, decode the next block. 
  649.             -- 
  650.             procedure consume_rle is 
  651.                pragma Inline (consume_rle); 
  652.             begin 
  653.                next_rle_idx := Integer (Shift_Right (tt.all (next_rle_idx), 8)); 
  654.                decode_available := decode_available - 1; 
  655.                if decode_available = 0 then 
  656.                   compare_final_CRC := True; 
  657.                   mem_stored_blockcrc := stored_blockcrc; 
  658.                   -- ^ There might be a new block when last block's 
  659.                   --   rle is finally emptied. 
  660.                   -- 
  661.                   -- ** New block 
  662.                   if decode_block then 
  663.                      next_rle_idx := Natural (Shift_Right (tt.all (block_origin), 8)); 
  664.                   else 
  665.                      next_rle_idx := -1; 
  666.                      end_reached := True; 
  667.                   end if; 
  668.                   -- ** 
  669.                   if end_reached then 
  670.                      raise input_dried; 
  671.                   end if; 
  672.                end if; 
  673.             end consume_rle; 
  674.             -- 
  675.             function rle_byte return Unsigned_8 is 
  676.                pragma Inline (rle_byte); 
  677.             begin 
  678.                return Unsigned_8 (tt.all (next_rle_idx) and 16#FF#); 
  679.             end rle_byte; 
  680.             -- 
  681.             function rle_possible return Boolean is 
  682.                pragma Inline (rle_possible); 
  683.             begin 
  684.                return decode_available > 0 and then data = rle_byte; 
  685.             end rle_possible; 
  686.             -- 
  687.          begin -- rle_read 
  688.             rle_len := rle_run_left; 
  689.             data := rle_run_data; 
  690.             if block_randomized then 
  691.                raise randomized_not_yet_implemented; 
  692.             end if; 
  693.             if rle_len /= 0 then 
  694.                rle_write; 
  695.                if count = 0 then 
  696.                   shorten := 0; 
  697.                   rle_run_data := data; 
  698.                   rle_run_left := rle_len; 
  699.                   return; 
  700.                end if; 
  701.             end if; 
  702.             begin 
  703.                -- The big loop 
  704.                loop 
  705.                   if decode_available = 0 or else end_reached then 
  706.                      exit; 
  707.                   end if; 
  708.                   rle_len := 1; 
  709.                   data := rle_byte; 
  710.                   consume_rle; 
  711.                   if rle_possible then 
  712.                      rle_len := rle_len + 1; 
  713.                      consume_rle; 
  714.                      if rle_possible then 
  715.                         rle_len := rle_len + 1; 
  716.                         consume_rle; 
  717.                         if rle_possible then 
  718.                            consume_rle; 
  719.                            rle_len := rle_len + Natural (rle_byte) + 1; 
  720.                            consume_rle; 
  721.                         end if; 
  722.                      end if; 
  723.                   end if; 
  724.                   rle_write; 
  725.                   exit when count = 0; 
  726.                end loop; 
  727.             exception 
  728.                when input_dried => rle_write; 
  729.             end; 
  730.             shorten := count; 
  731.             rle_run_data := data; 
  732.             rle_run_left := rle_len; 
  733.          end rle_read; 
  734.  
  735.       begin -- read 
  736.          last := buf'Last; 
  737.          if decode_available = Natural'Last then 
  738.             --  Initialize the rle process: 
  739.             --       - Decode a block 
  740.             --       - Initialize pointer. 
  741.             if decode_block then 
  742.                next_rle_idx := Natural (Shift_Right (tt.all (block_origin), 8)); 
  743.             else 
  744.                next_rle_idx := -1; 
  745.                end_reached := True; 
  746.             end if; 
  747.          end if; 
  748.          rle_read; 
  749.          last := last - shorten; 
  750.       end Read; 
  751.  
  752.    begin 
  753.       Init; 
  754.       loop 
  755.          Read; 
  756.          Write (buf (1 .. last)); 
  757.          exit when end_reached and then rle_run_left = 0; 
  758.       end loop; 
  759.       Dispose (tt); pragma Unreferenced (tt); 
  760.    end Decompress; 
  761.  
  762. end BZip2;