bitstring.ml

   1 (* Bitstring library.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version,
   8  * with the OCaml linking exception described in COPYING.LIB.
   9  *
  10  * This library is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18  *
  19  * $Id$
  20  *)
  21
  22 open Printf
  23
  24 include Bitstring_types
  25 include Bitstring_config
  26
  27 (* Enable runtime debug messages.  Must also have been enabled
  28  * in pa_bitstring.ml.
  29  *)
  30 let debug = ref false
  31
  32 (* Exceptions. *)
  33 exception Construct_failure of string * string * int * int
  34
  35 (* A bitstring is simply the data itself (as a string), and the
  36  * bitoffset and the bitlength within the string.  Note offset/length
  37  * are counted in bits, not bytes.
  38  *)
  39 type bitstring = string * int * int
  40
  41 type t = bitstring
  42
  43 (* Functions to create and load bitstrings. *)
  44 let empty_bitstring = "", 0, 0
  45
  46 let make_bitstring len c =
  47   if len >= 0 then String.make ((len+7) lsr 3) c, 0, len
  48   else
  49     invalid_arg (
  50       sprintf "make_bitstring/create_bitstring: len %d < 0" len
  51     )
  52
  53 let create_bitstring len = make_bitstring len '\000'
  54
  55 let zeroes_bitstring = create_bitstring
  56
  57 let ones_bitstring len = make_bitstring len '\xff'
  58
  59 let bitstring_of_string str = str, 0, String.length str lsl 3
  60
  61 let bitstring_of_chan chan =
  62   let tmpsize = 16384 in
  63   let buf = Buffer.create tmpsize in
  64   let tmp = String.create tmpsize in
  65   let n = ref 0 in
  66   while n := input chan tmp 0 tmpsize; !n > 0 do
  67     Buffer.add_substring buf tmp 0 !n;
  68   done;
  69   Buffer.contents buf, 0, Buffer.length buf lsl 3
  70
  71 let bitstring_of_chan_max chan max =
  72   let tmpsize = 16384 in
  73   let buf = Buffer.create tmpsize in
  74   let tmp = String.create tmpsize in
  75   let len = ref 0 in
  76   let rec loop () =
  77     if !len < max then (
  78       let r = min tmpsize (max - !len) in
  79       let n = input chan tmp 0 r in
  80       if n > 0 then (
  81         Buffer.add_substring buf tmp 0 n;
  82         len := !len + n;
  83         loop ()
  84       )
  85     )
  86   in
  87   loop ();
  88   Buffer.contents buf, 0, !len lsl 3
  89
  90 let bitstring_of_file_descr fd =
  91   let tmpsize = 16384 in
  92   let buf = Buffer.create tmpsize in
  93   let tmp = String.create tmpsize in
  94   let n = ref 0 in
  95   while n := Unix.read fd tmp 0 tmpsize; !n > 0 do
  96     Buffer.add_substring buf tmp 0 !n;
  97   done;
  98   Buffer.contents buf, 0, Buffer.length buf lsl 3
  99
 100 let bitstring_of_file_descr_max fd max =
 101   let tmpsize = 16384 in
 102   let buf = Buffer.create tmpsize in
 103   let tmp = String.create tmpsize in
 104   let len = ref 0 in
 105   let rec loop () =
 106     if !len < max then (
 107       let r = min tmpsize (max - !len) in
 108       let n = Unix.read fd tmp 0 r in
 109       if n > 0 then (
 110         Buffer.add_substring buf tmp 0 n;
 111         len := !len + n;
 112         loop ()
 113       )
 114     )
 115   in
 116   loop ();
 117   Buffer.contents buf, 0, !len lsl 3
 118
 119 let bitstring_of_file fname =
 120   let chan = open_in_bin fname in
 121   try
 122     let bs = bitstring_of_chan chan in
 123     close_in chan;
 124     bs
 125   with exn ->
 126     close_in chan;
 127     raise exn
 128
 129 let bitstring_length (_, _, len) = len
 130
 131 let subbitstring (data, off, len) off' len' =
 132   let off = off + off' in
 133   if len < off' + len' then invalid_arg "subbitstring";
 134   (data, off, len')
 135
 136 let dropbits n (data, off, len) =
 137   let off = off + n in
 138   let len = len - n in
 139   if len < 0 then invalid_arg "dropbits";
 140   (data, off, len)
 141
 142 let takebits n (data, off, len) =
 143   if len < n then invalid_arg "takebits";
 144   (data, off, n)
 145
 146 (*----------------------------------------------------------------------*)
 147 (* Bitwise functions.
 148  *
 149  * We try to isolate all bitwise functions within these modules.
 150  *)
 151
 152 module I = struct
 153   (* Bitwise operations on ints.  Note that we assume int <= 31 bits. *)
 154   external (<<<) : int -> int -> int = "%lslint"
 155   external (>>>) : int -> int -> int = "%lsrint"
 156   external to_int : int -> int = "%identity"
 157   let zero = 0
 158   let one = 1
 159   let minus_one = -1
 160   let ff = 0xff
 161
 162   (* Create a mask 0-31 bits wide. *)
 163   let mask bits =
 164     if bits < 30 then
 165       (one <<< bits) - 1
 166     else if bits = 30 then
 167       max_int
 168     else if bits = 31 then
 169       minus_one
 170     else
 171       invalid_arg "Bitstring.I.mask"
 172
 173   (* Byte swap an int of a given size. *)
 174   let byteswap v bits =
 175     if bits <= 8 then v
 176     else if bits <= 16 then (
 177       let shift = bits-8 in
 178       let v1 = v >>> shift in
 179       let v2 = ((v land (mask shift)) <<< 8) in
 180       v2 lor v1
 181     ) else if bits <= 24 then (
 182       let shift = bits - 16 in
 183       let v1 = v >>> (8+shift) in
 184       let v2 = ((v >>> shift) land ff) <<< 8 in
 185       let v3 = (v land (mask shift)) <<< 16 in
 186       v3 lor v2 lor v1
 187     ) else (
 188       let shift = bits - 24 in
 189       let v1 = v >>> (16+shift) in
 190       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
 191       let v3 = ((v >>> shift) land ff) <<< 16 in
 192       let v4 = (v land (mask shift)) <<< 24 in
 193       v4 lor v3 lor v2 lor v1
 194     )
 195
 196   (* Check a value is in range 0 .. 2^bits-1. *)
 197   let range_unsigned v bits =
 198     let mask = lnot (mask bits) in
 199     (v land mask) = zero
 200
 201   (* Call function g on the top bits, then f on each full byte
 202    * (big endian - so start at top).
 203    *)
 204   let rec map_bytes_be g f v bits =
 205     if bits >= 8 then (
 206       map_bytes_be g f (v >>> 8) (bits-8);
 207       let lsb = v land ff in
 208       f (to_int lsb)
 209     ) else if bits > 0 then (
 210       let lsb = v land (mask bits) in
 211       g (to_int lsb) bits
 212     )
 213
 214   (* Call function g on the top bits, then f on each full byte
 215    * (little endian - so start at root).
 216    *)
 217   let rec map_bytes_le g f v bits =
 218     if bits >= 8 then (
 219       let lsb = v land ff in
 220       f (to_int lsb);
 221       map_bytes_le g f (v >>> 8) (bits-8)
 222     ) else if bits > 0 then (
 223       let lsb = v land (mask bits) in
 224       g (to_int lsb) bits
 225     )
 226 end
 227
 228 module I32 = struct
 229   (* Bitwise operations on int32s.  Note we try to keep it as similar
 230    * as possible to the I module above, to make it easier to track
 231    * down bugs.
 232    *)
 233   let (<<<) = Int32.shift_left
 234   let (>>>) = Int32.shift_right_logical
 235   let (land) = Int32.logand
 236   let (lor) = Int32.logor
 237   let lnot = Int32.lognot
 238   let pred = Int32.pred
 239   let max_int = Int32.max_int
 240   let to_int = Int32.to_int
 241   let zero = Int32.zero
 242   let one = Int32.one
 243   let minus_one = Int32.minus_one
 244   let ff = 0xff_l
 245
 246   (* Create a mask so many bits wide. *)
 247   let mask bits =
 248     if bits < 31 then
 249       pred (one <<< bits)
 250     else if bits = 31 then
 251       max_int
 252     else if bits = 32 then
 253       minus_one
 254     else
 255       invalid_arg "Bitstring.I32.mask"
 256
 257   (* Byte swap an int of a given size. *)
 258   let byteswap v bits =
 259     if bits <= 8 then v
 260     else if bits <= 16 then (
 261       let shift = bits-8 in
 262       let v1 = v >>> shift in
 263       let v2 = (v land (mask shift)) <<< 8 in
 264       v2 lor v1
 265     ) else if bits <= 24 then (
 266       let shift = bits - 16 in
 267       let v1 = v >>> (8+shift) in
 268       let v2 = ((v >>> shift) land ff) <<< 8 in
 269       let v3 = (v land (mask shift)) <<< 16 in
 270       v3 lor v2 lor v1
 271     ) else (
 272       let shift = bits - 24 in
 273       let v1 = v >>> (16+shift) in
 274       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
 275       let v3 = ((v >>> shift) land ff) <<< 16 in
 276       let v4 = (v land (mask shift)) <<< 24 in
 277       v4 lor v3 lor v2 lor v1
 278     )
 279
 280   (* Check a value is in range 0 .. 2^bits-1. *)
 281   let range_unsigned v bits =
 282     let mask = lnot (mask bits) in
 283     (v land mask) = zero
 284
 285   (* Call function g on the top bits, then f on each full byte
 286    * (big endian - so start at top).
 287    *)
 288   let rec map_bytes_be g f v bits =
 289     if bits >= 8 then (
 290       map_bytes_be g f (v >>> 8) (bits-8);
 291       let lsb = v land ff in
 292       f (to_int lsb)
 293     ) else if bits > 0 then (
 294       let lsb = v land (mask bits) in
 295       g (to_int lsb) bits
 296     )
 297
 298   (* Call function g on the top bits, then f on each full byte
 299    * (little endian - so start at root).
 300    *)
 301   let rec map_bytes_le g f v bits =
 302     if bits >= 8 then (
 303       let lsb = v land ff in
 304       f (to_int lsb);
 305       map_bytes_le g f (v >>> 8) (bits-8)
 306     ) else if bits > 0 then (
 307       let lsb = v land (mask bits) in
 308       g (to_int lsb) bits
 309     )
 310 end
 311
 312 module I64 = struct
 313   (* Bitwise operations on int64s.  Note we try to keep it as similar
 314    * as possible to the I/I32 modules above, to make it easier to track
 315    * down bugs.
 316    *)
 317   let (<<<) = Int64.shift_left
 318   let (>>>) = Int64.shift_right_logical
 319   let (land) = Int64.logand
 320   let (lor) = Int64.logor
 321   let lnot = Int64.lognot
 322   let pred = Int64.pred
 323   let max_int = Int64.max_int
 324   let to_int = Int64.to_int
 325   let zero = Int64.zero
 326   let one = Int64.one
 327   let minus_one = Int64.minus_one
 328   let ff = 0xff_L
 329
 330   (* Create a mask so many bits wide. *)
 331   let mask bits =
 332     if bits < 63 then
 333       pred (one <<< bits)
 334     else if bits = 63 then
 335       max_int
 336     else if bits = 64 then
 337       minus_one
 338     else
 339       invalid_arg "Bitstring.I64.mask"
 340
 341   (* Byte swap an int of a given size. *)
 342   (* let byteswap v bits = *)
 343
 344   (* Check a value is in range 0 .. 2^bits-1. *)
 345   let range_unsigned v bits =
 346     let mask = lnot (mask bits) in
 347     (v land mask) = zero
 348
 349   (* Call function g on the top bits, then f on each full byte
 350    * (big endian - so start at top).
 351    *)
 352   let rec map_bytes_be g f v bits =
 353     if bits >= 8 then (
 354       map_bytes_be g f (v >>> 8) (bits-8);
 355       let lsb = v land ff in
 356       f (to_int lsb)
 357     ) else if bits > 0 then (
 358       let lsb = v land (mask bits) in
 359       g (to_int lsb) bits
 360     )
 361
 362   (* Call function g on the top bits, then f on each full byte
 363    * (little endian - so start at root).
 364    *)
 365   let rec map_bytes_le g f v bits =
 366     if bits >= 8 then (
 367       let lsb = v land ff in
 368       f (to_int lsb);
 369       map_bytes_le g f (v >>> 8) (bits-8)
 370     ) else if bits > 0 then (
 371       let lsb = v land (mask bits) in
 372       g (to_int lsb) bits
 373     )
 374 end
 375
 376 (*----------------------------------------------------------------------*)
 377 (* Extraction functions.
 378  *
 379  * NB: internal functions, called from the generated macros, and
 380  * the parameters should have been checked for sanity already).
 381  *)
 382
 383 (* Extract and convert to numeric.  A single bit is returned as
 384  * a boolean.  There are no endianness or signedness considerations.
 385  *)
 386 let extract_bit data off len _ =        (* final param is always 1 *)
 387   let byteoff = off lsr 3 in
 388   let bitmask = 1 lsl (7 - (off land 7)) in
 389   let b = Char.code data.[byteoff] land bitmask <> 0 in
 390   b (*, off+1, len-1*)
 391
 392 (* Returns 8 bit unsigned aligned bytes from the string.
 393  * If the string ends then this returns 0's.
 394  *)
 395 let _get_byte data byteoff strlen =
 396   if strlen > byteoff then Char.code data.[byteoff] else 0
 397 let _get_byte32 data byteoff strlen =
 398   if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
 399 let _get_byte64 data byteoff strlen =
 400   if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
 401
 402 (* Extract [2..8] bits.  Because the result fits into a single
 403  * byte we don't have to worry about endianness, only signedness.
 404  *)
 405 let extract_char_unsigned data off len flen =
 406   let byteoff = off lsr 3 in
 407
 408   (* Optimize the common (byte-aligned) case. *)
 409   if off land 7 = 0 then (
 410     let byte = Char.code data.[byteoff] in
 411     byte lsr (8 - flen) (*, off+flen, len-flen*)
 412   ) else (
 413     (* Extract the 16 bits at byteoff and byteoff+1 (note that the
 414      * second byte might not exist in the original string).
 415      *)
 416     let strlen = String.length data in
 417
 418     let word =
 419       (_get_byte data byteoff strlen lsl 8) +
 420         _get_byte data (byteoff+1) strlen in
 421
 422     (* Mask off the top bits. *)
 423     let bitmask = (1 lsl (16 - (off land 7))) - 1 in
 424     let word = word land bitmask in
 425     (* Shift right to get rid of the bottom bits. *)
 426     let shift = 16 - ((off land 7) + flen) in
 427     let word = word lsr shift in
 428
 429     word (*, off+flen, len-flen*)
 430   )
 431
 432 (* Extract [9..31] bits.  We have to consider endianness and signedness. *)
 433 let extract_int_be_unsigned data off len flen =
 434   let byteoff = off lsr 3 in
 435
 436   let strlen = String.length data in
 437
 438   let word =
 439     (* Optimize the common (byte-aligned) case. *)
 440     if off land 7 = 0 then (
 441       let word =
 442         (_get_byte data byteoff strlen lsl 23) +
 443           (_get_byte data (byteoff+1) strlen lsl 15) +
 444           (_get_byte data (byteoff+2) strlen lsl 7) +
 445           (_get_byte data (byteoff+3) strlen lsr 1) in
 446       word lsr (31 - flen)
 447     ) else if flen <= 24 then (
 448       (* Extract the 31 bits at byteoff .. byteoff+3. *)
 449       let word =
 450         (_get_byte data byteoff strlen lsl 23) +
 451           (_get_byte data (byteoff+1) strlen lsl 15) +
 452           (_get_byte data (byteoff+2) strlen lsl 7) +
 453           (_get_byte data (byteoff+3) strlen lsr 1) in
 454       (* Mask off the top bits. *)
 455       let bitmask = (1 lsl (31 - (off land 7))) - 1 in
 456       let word = word land bitmask in
 457       (* Shift right to get rid of the bottom bits. *)
 458       let shift = 31 - ((off land 7) + flen) in
 459       word lsr shift
 460     ) else (
 461       (* Extract the next 31 bits, slow method. *)
 462       let word =
 463         let c0 = extract_char_unsigned data off len 8
 464         and off = off + 8 and len = len - 8 in
 465         let c1 = extract_char_unsigned data off len 8
 466         and off = off + 8 and len = len - 8 in
 467         let c2 = extract_char_unsigned data off len 8
 468         and off = off + 8 and len = len - 8 in
 469         let c3 = extract_char_unsigned data off len 7 in
 470         (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
 471       word lsr (31 - flen)
 472     ) in
 473   word (*, off+flen, len-flen*)
 474
 475 let extract_int_le_unsigned data off len flen =
 476   let v = extract_int_be_unsigned data off len flen in
 477   let v = I.byteswap v flen in
 478   v
 479
 480 let extract_int_ne_unsigned =
 481   if nativeendian = BigEndian
 482   then extract_int_be_unsigned
 483   else extract_int_le_unsigned
 484
 485 let extract_int_ee_unsigned = function
 486   | BigEndian -> extract_int_be_unsigned
 487   | LittleEndian -> extract_int_le_unsigned
 488   | NativeEndian -> extract_int_ne_unsigned
 489
 490 let _make_int32_be c0 c1 c2 c3 =
 491   Int32.logor
 492     (Int32.logor
 493        (Int32.logor
 494           (Int32.shift_left c0 24)
 495           (Int32.shift_left c1 16))
 496        (Int32.shift_left c2 8))
 497     c3
 498
 499 let _make_int32_le c0 c1 c2 c3 =
 500   Int32.logor
 501     (Int32.logor
 502        (Int32.logor
 503           (Int32.shift_left c3 24)
 504           (Int32.shift_left c2 16))
 505        (Int32.shift_left c1 8))
 506     c0
 507
 508 (* Extract exactly 32 bits.  We have to consider endianness and signedness. *)
 509 let extract_int32_be_unsigned data off len flen =
 510   let byteoff = off lsr 3 in
 511
 512   let strlen = String.length data in
 513
 514   let word =
 515     (* Optimize the common (byte-aligned) case. *)
 516     if off land 7 = 0 then (
 517       let word =
 518         let c0 = _get_byte32 data byteoff strlen in
 519         let c1 = _get_byte32 data (byteoff+1) strlen in
 520         let c2 = _get_byte32 data (byteoff+2) strlen in
 521         let c3 = _get_byte32 data (byteoff+3) strlen in
 522         _make_int32_be c0 c1 c2 c3 in
 523       Int32.shift_right_logical word (32 - flen)
 524     ) else (
 525       (* Extract the next 32 bits, slow method. *)
 526       let word =
 527         let c0 = extract_char_unsigned data off len 8
 528         and off = off + 8 and len = len - 8 in
 529         let c1 = extract_char_unsigned data off len 8
 530         and off = off + 8 and len = len - 8 in
 531         let c2 = extract_char_unsigned data off len 8
 532         and off = off + 8 and len = len - 8 in
 533         let c3 = extract_char_unsigned data off len 8 in
 534         let c0 = Int32.of_int c0 in
 535         let c1 = Int32.of_int c1 in
 536         let c2 = Int32.of_int c2 in
 537         let c3 = Int32.of_int c3 in
 538         _make_int32_be c0 c1 c2 c3 in
 539       Int32.shift_right_logical word (32 - flen)
 540     ) in
 541   word (*, off+flen, len-flen*)
 542
 543 let extract_int32_le_unsigned data off len flen =
 544   let v = extract_int32_be_unsigned data off len flen in
 545   let v = I32.byteswap v flen in
 546   v
 547
 548 let extract_int32_ne_unsigned =
 549   if nativeendian = BigEndian
 550   then extract_int32_be_unsigned
 551   else extract_int32_le_unsigned
 552
 553 let extract_int32_ee_unsigned = function
 554   | BigEndian -> extract_int32_be_unsigned
 555   | LittleEndian -> extract_int32_le_unsigned
 556   | NativeEndian -> extract_int32_ne_unsigned
 557
 558 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
 559   Int64.logor
 560     (Int64.logor
 561        (Int64.logor
 562           (Int64.logor
 563              (Int64.logor
 564                 (Int64.logor
 565                    (Int64.logor
 566                       (Int64.shift_left c0 56)
 567                       (Int64.shift_left c1 48))
 568                    (Int64.shift_left c2 40))
 569                 (Int64.shift_left c3 32))
 570              (Int64.shift_left c4 24))
 571           (Int64.shift_left c5 16))
 572        (Int64.shift_left c6 8))
 573     c7
 574
 575 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
 576   _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
 577
 578 (* Extract [1..64] bits.  We have to consider endianness and signedness. *)
 579 let extract_int64_be_unsigned data off len flen =
 580   let byteoff = off lsr 3 in
 581
 582   let strlen = String.length data in
 583
 584   let word =
 585     (* Optimize the common (byte-aligned) case. *)
 586     if off land 7 = 0 then (
 587       let word =
 588         let c0 = _get_byte64 data byteoff strlen in
 589         let c1 = _get_byte64 data (byteoff+1) strlen in
 590         let c2 = _get_byte64 data (byteoff+2) strlen in
 591         let c3 = _get_byte64 data (byteoff+3) strlen in
 592         let c4 = _get_byte64 data (byteoff+4) strlen in
 593         let c5 = _get_byte64 data (byteoff+5) strlen in
 594         let c6 = _get_byte64 data (byteoff+6) strlen in
 595         let c7 = _get_byte64 data (byteoff+7) strlen in
 596         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 597       Int64.shift_right_logical word (64 - flen)
 598     ) else (
 599       (* Extract the next 64 bits, slow method. *)
 600       let word =
 601         let c0 = extract_char_unsigned data off len 8
 602         and off = off + 8 and len = len - 8 in
 603         let c1 = extract_char_unsigned data off len 8
 604         and off = off + 8 and len = len - 8 in
 605         let c2 = extract_char_unsigned data off len 8
 606         and off = off + 8 and len = len - 8 in
 607         let c3 = extract_char_unsigned data off len 8
 608         and off = off + 8 and len = len - 8 in
 609         let c4 = extract_char_unsigned data off len 8
 610         and off = off + 8 and len = len - 8 in
 611         let c5 = extract_char_unsigned data off len 8
 612         and off = off + 8 and len = len - 8 in
 613         let c6 = extract_char_unsigned data off len 8
 614         and off = off + 8 and len = len - 8 in
 615         let c7 = extract_char_unsigned data off len 8 in
 616         let c0 = Int64.of_int c0 in
 617         let c1 = Int64.of_int c1 in
 618         let c2 = Int64.of_int c2 in
 619         let c3 = Int64.of_int c3 in
 620         let c4 = Int64.of_int c4 in
 621         let c5 = Int64.of_int c5 in
 622         let c6 = Int64.of_int c6 in
 623         let c7 = Int64.of_int c7 in
 624         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 625       Int64.shift_right_logical word (64 - flen)
 626     ) in
 627   word (*, off+flen, len-flen*)
 628
 629 let extract_int64_le_unsigned data off len flen =
 630   let byteoff = off lsr 3 in
 631
 632   let strlen = String.length data in
 633
 634   let word =
 635     (* Optimize the common (byte-aligned) case. *)
 636     if off land 7 = 0 then (
 637       let word =
 638         let c0 = _get_byte64 data byteoff strlen in
 639         let c1 = _get_byte64 data (byteoff+1) strlen in
 640         let c2 = _get_byte64 data (byteoff+2) strlen in
 641         let c3 = _get_byte64 data (byteoff+3) strlen in
 642         let c4 = _get_byte64 data (byteoff+4) strlen in
 643         let c5 = _get_byte64 data (byteoff+5) strlen in
 644         let c6 = _get_byte64 data (byteoff+6) strlen in
 645         let c7 = _get_byte64 data (byteoff+7) strlen in
 646         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 647       Int64.logand word (I64.mask flen)
 648     ) else (
 649       (* Extract the next 64 bits, slow method. *)
 650       let word =
 651         let c0 = extract_char_unsigned data off len 8
 652         and off = off + 8 and len = len - 8 in
 653         let c1 = extract_char_unsigned data off len 8
 654         and off = off + 8 and len = len - 8 in
 655         let c2 = extract_char_unsigned data off len 8
 656         and off = off + 8 and len = len - 8 in
 657         let c3 = extract_char_unsigned data off len 8
 658         and off = off + 8 and len = len - 8 in
 659         let c4 = extract_char_unsigned data off len 8
 660         and off = off + 8 and len = len - 8 in
 661         let c5 = extract_char_unsigned data off len 8
 662         and off = off + 8 and len = len - 8 in
 663         let c6 = extract_char_unsigned data off len 8
 664         and off = off + 8 and len = len - 8 in
 665         let c7 = extract_char_unsigned data off len 8 in
 666         let c0 = Int64.of_int c0 in
 667         let c1 = Int64.of_int c1 in
 668         let c2 = Int64.of_int c2 in
 669         let c3 = Int64.of_int c3 in
 670         let c4 = Int64.of_int c4 in
 671         let c5 = Int64.of_int c5 in
 672         let c6 = Int64.of_int c6 in
 673         let c7 = Int64.of_int c7 in
 674         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 675       Int64.logand word (I64.mask flen)
 676     ) in
 677   word (*, off+flen, len-flen*)
 678
 679 let extract_int64_ne_unsigned =
 680   if nativeendian = BigEndian
 681   then extract_int64_be_unsigned
 682   else extract_int64_le_unsigned
 683
 684 let extract_int64_ee_unsigned = function
 685   | BigEndian -> extract_int64_be_unsigned
 686   | LittleEndian -> extract_int64_le_unsigned
 687   | NativeEndian -> extract_int64_ne_unsigned
 688
 689 external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
 690
 691 external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
 692
 693 external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
 694
 695 external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
 696
 697 external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
 698
 699 external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
 700
 701 (*
 702 external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
 703
 704 external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
 705
 706 external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
 707
 708 external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
 709
 710 external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
 711
 712 external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
 713 *)
 714
 715 external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc"
 716
 717 external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc"
 718
 719 external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc"
 720
 721 external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc"
 722
 723 external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc"
 724
 725 external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc"
 726
 727 (*
 728 external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc"
 729
 730 external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc"
 731
 732 external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc"
 733
 734 external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc"
 735
 736 external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc"
 737
 738 external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc"
 739
 740 external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc"
 741
 742 external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc"
 743
 744 external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc"
 745
 746 external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc"
 747
 748 external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc"
 749
 750 external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc"
 751
 752 external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc"
 753
 754 external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc"
 755
 756 external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc"
 757
 758 external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc"
 759
 760 external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc"
 761
 762 external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc"
 763 *)
 764
 765 external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc"
 766
 767 external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc"
 768
 769 external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc"
 770
 771 external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc"
 772
 773 external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc"
 774
 775 external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc"
 776
 777 (*----------------------------------------------------------------------*)
 778 (* Constructor functions. *)
 779
 780 module Buffer = struct
 781   type t = {
 782     buf : Buffer.t;
 783     mutable len : int;                  (* Length in bits. *)
 784     (* Last byte in the buffer (if len is not aligned).  We store
 785      * it outside the buffer because buffers aren't mutable.
 786      *)
 787     mutable last : int;
 788   }
 789
 790   let create () =
 791     (* XXX We have almost enough information in the generator to
 792      * choose a good initial size.
 793      *)
 794     { buf = Buffer.create 128; len = 0; last = 0 }
 795
 796   let contents { buf = buf; len = len; last = last } =
 797     let data =
 798       if len land 7 = 0 then
 799         Buffer.contents buf
 800       else
 801         Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
 802     data, 0, len
 803
 804   (* Add exactly 8 bits. *)
 805   let add_byte ({ buf = buf; len = len; last = last } as t) byte =
 806     if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte";
 807     let shift = len land 7 in
 808     if shift = 0 then
 809       (* Target buffer is byte-aligned. *)
 810       Buffer.add_char buf (Char.chr byte)
 811     else (
 812       (* Target buffer is unaligned.  'last' is meaningful. *)
 813       let first = byte lsr shift in
 814       let second = (byte lsl (8 - shift)) land 0xff in
 815       Buffer.add_char buf (Char.chr (last lor first));
 816       t.last <- second
 817     );
 818     t.len <- t.len + 8
 819
 820   (* Add exactly 1 bit. *)
 821   let add_bit ({ buf = buf; len = len; last = last } as t) bit =
 822     let shift = 7 - (len land 7) in
 823     if shift > 0 then
 824       (* Somewhere in the middle of 'last'. *)
 825       t.last <- last lor ((if bit then 1 else 0) lsl shift)
 826     else (
 827       (* Just a single spare bit in 'last'. *)
 828       let last = last lor if bit then 1 else 0 in
 829       Buffer.add_char buf (Char.chr last);
 830       t.last <- 0
 831     );
 832     t.len <- len + 1
 833
 834   (* Add a small number of bits (definitely < 8).  This uses a loop
 835    * to call add_bit so it's slow.
 836    *)
 837   let _add_bits t c slen =
 838     if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits";
 839     for i = slen-1 downto 0 do
 840       let bit = c land (1 lsl i) <> 0 in
 841       add_bit t bit
 842     done
 843
 844   let add_bits ({ buf = buf; len = len } as t) str slen =
 845     if slen > 0 then (
 846       if len land 7 = 0 then (
 847         if slen land 7 = 0 then
 848           (* Common case - everything is byte-aligned. *)
 849           Buffer.add_substring buf str 0 (slen lsr 3)
 850         else (
 851           (* Target buffer is aligned.  Copy whole bytes then leave the
 852            * remaining bits in last.
 853            *)
 854           let slenbytes = slen lsr 3 in
 855           if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes;
 856           let last = Char.code str.[slenbytes] in (* last char *)
 857           let mask = 0xff lsl (8 - (slen land 7)) in
 858           t.last <- last land mask
 859         );
 860         t.len <- len + slen
 861       ) else (
 862         (* Target buffer is unaligned.  Copy whole bytes using
 863          * add_byte which knows how to deal with an unaligned
 864          * target buffer, then call add_bit for the remaining < 8 bits.
 865          *
 866          * XXX This is going to be dog-slow.
 867          *)
 868         let slenbytes = slen lsr 3 in
 869         for i = 0 to slenbytes-1 do
 870           let byte = Char.code str.[i] in
 871           add_byte t byte
 872         done;
 873         let bitsleft = slen - (slenbytes lsl 3) in
 874         if bitsleft > 0 then (
 875           let c = Char.code str.[slenbytes] in
 876           for i = 0 to bitsleft - 1 do
 877             let bit = c land (0x80 lsr i) <> 0 in
 878             add_bit t bit
 879           done
 880         )
 881       );
 882     )
 883 end
 884
 885 (* Construct a single bit. *)
 886 let construct_bit buf b _ _ =
 887   Buffer.add_bit buf b
 888
 889 (* Construct a field, flen = [2..8]. *)
 890 let construct_char_unsigned buf v flen exn =
 891   let max_val = 1 lsl flen in
 892   if v < 0 || v >= max_val then raise exn;
 893   if flen = 8 then
 894     Buffer.add_byte buf v
 895   else
 896     Buffer._add_bits buf v flen
 897
 898 (* Construct a field of up to 31 bits. *)
 899 let construct_int_be_unsigned buf v flen exn =
 900   (* Check value is within range. *)
 901   if not (I.range_unsigned v flen) then raise exn;
 902   (* Add the bytes. *)
 903   I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 904
 905 (* Construct a field of up to 31 bits. *)
 906 let construct_int_le_unsigned buf v flen exn =
 907   (* Check value is within range. *)
 908   if not (I.range_unsigned v flen) then raise exn;
 909   (* Add the bytes. *)
 910   I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 911
 912 let construct_int_ne_unsigned =
 913   if nativeendian = BigEndian
 914   then construct_int_be_unsigned
 915   else construct_int_le_unsigned
 916
 917 let construct_int_ee_unsigned = function
 918   | BigEndian -> construct_int_be_unsigned
 919   | LittleEndian -> construct_int_le_unsigned
 920   | NativeEndian -> construct_int_ne_unsigned
 921
 922 (* Construct a field of exactly 32 bits. *)
 923 let construct_int32_be_unsigned buf v flen _ =
 924   Buffer.add_byte buf
 925     (Int32.to_int (Int32.shift_right_logical v 24));
 926   Buffer.add_byte buf
 927     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 928   Buffer.add_byte buf
 929     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 930   Buffer.add_byte buf
 931     (Int32.to_int (Int32.logand v 0xff_l))
 932
 933 let construct_int32_le_unsigned buf v flen _ =
 934   Buffer.add_byte buf
 935     (Int32.to_int (Int32.logand v 0xff_l));
 936   Buffer.add_byte buf
 937     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 938   Buffer.add_byte buf
 939     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 940   Buffer.add_byte buf
 941     (Int32.to_int (Int32.shift_right_logical v 24))
 942
 943 let construct_int32_ne_unsigned =
 944   if nativeendian = BigEndian
 945   then construct_int32_be_unsigned
 946   else construct_int32_le_unsigned
 947
 948 let construct_int32_ee_unsigned = function
 949   | BigEndian -> construct_int32_be_unsigned
 950   | LittleEndian -> construct_int32_le_unsigned
 951   | NativeEndian -> construct_int32_ne_unsigned
 952
 953 (* Construct a field of up to 64 bits. *)
 954 let construct_int64_be_unsigned buf v flen exn =
 955   (* Check value is within range. *)
 956   if not (I64.range_unsigned v flen) then raise exn;
 957   (* Add the bytes. *)
 958   I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 959
 960 (* Construct a field of up to 64 bits. *)
 961 let construct_int64_le_unsigned buf v flen exn =
 962   (* Check value is within range. *)
 963   if not (I64.range_unsigned v flen) then raise exn;
 964   (* Add the bytes. *)
 965   I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 966
 967 let construct_int64_ne_unsigned =
 968   if nativeendian = BigEndian
 969   then construct_int64_be_unsigned
 970   else construct_int64_le_unsigned
 971
 972 let construct_int64_ee_unsigned = function
 973   | BigEndian -> construct_int64_be_unsigned
 974   | LittleEndian -> construct_int64_le_unsigned
 975   | NativeEndian -> construct_int64_ne_unsigned
 976
 977 (* Construct from a string of bytes, exact multiple of 8 bits
 978  * in length of course.
 979  *)
 980 let construct_string buf str =
 981   let len = String.length str in
 982   Buffer.add_bits buf str (len lsl 3)
 983
 984 (* Construct from a bitstring. *)
 985 let construct_bitstring buf (data, off, len) =
 986   (* Add individual bits until we get to the next byte boundary of
 987    * the underlying string.
 988    *)
 989   let blen = 7 - ((off + 7) land 7) in
 990   let blen = min blen len in
 991   let rec loop off len blen =
 992     if blen = 0 then (off, len)
 993     else (
 994       let b = extract_bit data off len 1
 995       and off = off + 1 and len = len + 1 in
 996       Buffer.add_bit buf b;
 997       loop off len (blen-1)
 998     )
 999   in
1000   let off, len = loop off len blen in
1001   assert (len = 0 || (off land 7) = 0);
1002
1003   (* Add the remaining 'len' bits. *)
1004   let data =
1005     let off = off lsr 3 in
1006     (* XXX dangerous allocation *)
1007     if off = 0 then data
1008     else String.sub data off (String.length data - off) in
1009
1010   Buffer.add_bits buf data len
1011
1012 (* Concatenate bitstrings. *)
1013 let concat bs =
1014   let buf = Buffer.create () in
1015   List.iter (construct_bitstring buf) bs;
1016   Buffer.contents buf
1017
1018 (*----------------------------------------------------------------------*)
1019 (* Extract a string from a bitstring. *)
1020 let string_of_bitstring (data, off, len) =
1021   if off land 7 = 0 && len land 7 = 0 then
1022     (* Easy case: everything is byte-aligned. *)
1023     String.sub data (off lsr 3) (len lsr 3)
1024   else (
1025     (* Bit-twiddling case. *)
1026     let strlen = (len + 7) lsr 3 in
1027     let str = String.make strlen '\000' in
1028     let rec loop data off len i =
1029       if len >= 8 then (
1030         let c = extract_char_unsigned data off len 8
1031         and off = off + 8 and len = len - 8 in
1032         str.[i] <- Char.chr c;
1033         loop data off len (i+1)
1034       ) else if len > 0 then (
1035         let c = extract_char_unsigned data off len len in
1036         str.[i] <- Char.chr (c lsl (8-len))
1037       )
1038     in
1039     loop data off len 0;
1040     str
1041   )
1042
1043 (* To channel. *)
1044
1045 let bitstring_to_chan ((data, off, len) as bits) chan =
1046   (* Fail if the bitstring length isn't a multiple of 8. *)
1047   if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
1048
1049   if off land 7 = 0 then
1050     (* Easy case: string is byte-aligned. *)
1051     output chan data (off lsr 3) (len lsr 3)
1052   else (
1053     (* Bit-twiddling case: reuse string_of_bitstring *)
1054     let str = string_of_bitstring bits in
1055     output_string chan str
1056   )
1057
1058 let bitstring_to_file bits filename =
1059   let chan = open_out_bin filename in
1060   try
1061     bitstring_to_chan bits chan;
1062     close_out chan
1063   with exn ->
1064     close_out chan;
1065     raise exn
1066
1067 (*----------------------------------------------------------------------*)
1068 (* Comparison. *)
1069 let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
1070   (* In the fully-aligned case, this is reduced to string comparison ... *)
1071   if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
1072   then (
1073     (* ... but we have to do that by hand because the bits may
1074      * not extend to the full length of the underlying string.
1075      *)
1076     let off1 = off1 lsr 3 and off2 = off2 lsr 3
1077     and len1 = len1 lsr 3 and len2 = len2 lsr 3 in
1078     let rec loop i =
1079       if i < len1 && i < len2 then (
1080         let c1 = String.unsafe_get data1 (off1 + i)
1081         and c2 = String.unsafe_get data2 (off2 + i) in
1082         let r = compare c1 c2 in
1083         if r <> 0 then r
1084         else loop (i+1)
1085       )
1086       else len1 - len2
1087     in
1088     loop 0
1089   )
1090   else (
1091     (* Slow/unaligned. *)
1092     let str1 = string_of_bitstring bs1
1093     and str2 = string_of_bitstring bs2 in
1094     let r = String.compare str1 str2 in
1095     if r <> 0 then r else len1 - len2
1096   )
1097
1098 let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
1099   if len1 <> len2 then false
1100   else if bs1 = bs2 then true
1101   else 0 = compare bs1 bs2
1102
1103 (*----------------------------------------------------------------------*)
1104 (* Bit get/set functions. *)
1105
1106 let index_out_of_bounds () = invalid_arg "index out of bounds"
1107
1108 let put (data, off, len) n v =
1109   if n < 0 || n >= len then index_out_of_bounds ()
1110   else (
1111     let i = off+n in
1112     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1113     let c = Char.code data.[si] in
1114     let c = if v <> 0 then c lor mask else c land (lnot mask) in
1115     data.[si] <- Char.unsafe_chr c
1116   )
1117
1118 let set bits n = put bits n 1
1119
1120 let clear bits n = put bits n 0
1121
1122 let get (data, off, len) n =
1123   if n < 0 || n >= len then index_out_of_bounds ()
1124   else (
1125     let i = off+n in
1126     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1127     let c = Char.code data.[si] in
1128     c land mask
1129   )
1130
1131 let is_set bits n = get bits n <> 0
1132
1133 let is_clear bits n = get bits n = 0
1134
1135 (*----------------------------------------------------------------------*)
1136 (* Display functions. *)
1137
1138 let isprint c =
1139   let c = Char.code c in
1140   c >= 32 && c < 127
1141
1142 let hexdump_bitstring chan (data, off, len) =
1143   let count = ref 0 in
1144   let off = ref off in
1145   let len = ref len in
1146   let linelen = ref 0 in
1147   let linechars = String.make 16 ' ' in
1148
1149   fprintf chan "00000000  ";
1150
1151   while !len > 0 do
1152     let bits = min !len 8 in
1153     let byte = extract_char_unsigned data !off !len bits in
1154     off := !off + bits; len := !len - bits;
1155
1156     let byte = byte lsl (8-bits) in
1157     fprintf chan "%02x " byte;
1158
1159     incr count;
1160     linechars.[!linelen] <-
1161       (let c = Char.chr byte in
1162        if isprint c then c else '.');
1163     incr linelen;
1164     if !linelen = 8 then fprintf chan " ";
1165     if !linelen = 16 then (
1166       fprintf chan " |%s|\n%08x  " linechars !count;
1167       linelen := 0;
1168       for i = 0 to 15 do linechars.[i] <- ' ' done
1169     )
1170   done;
1171
1172   if !linelen > 0 then (
1173     let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1174     for i = 0 to skip-1 do fprintf chan " " done;
1175     fprintf chan " |%s|\n%!" linechars
1176   ) else
1177     fprintf chan "\n%!"