bitmatch.ml

   1 (* Bitmatch 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  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22
  23 include Bitmatch_types
  24 include Bitmatch_config
  25
  26 (* Enable runtime debug messages.  Must also have been enabled
  27  * in pa_bitmatch.ml.
  28  *)
  29 let debug = ref false
  30
  31 (* Exceptions. *)
  32 exception Construct_failure of string * string * int * int
  33
  34 (* A bitstring is simply the data itself (as a string), and the
  35  * bitoffset and the bitlength within the string.  Note offset/length
  36  * are counted in bits, not bytes.
  37  *)
  38 type bitstring = string * int * int
  39
  40 (* Functions to create and load bitstrings. *)
  41 let empty_bitstring = "", 0, 0
  42
  43 let make_bitstring len c =
  44   if len >= 0 then String.make ((len+7) lsr 3) c, 0, len
  45   else
  46     invalid_arg (
  47       sprintf "make_bitstring/create_bitstring: len %d < 0" len
  48     )
  49
  50 let create_bitstring len = make_bitstring len '\000'
  51
  52 let zeroes_bitstring = create_bitstring
  53
  54 let ones_bitstring len = make_bitstring len '\xff'
  55
  56 let bitstring_of_string str = str, 0, String.length str lsl 3
  57
  58 let bitstring_of_chan chan =
  59   let tmpsize = 16384 in
  60   let buf = Buffer.create tmpsize in
  61   let tmp = String.create tmpsize in
  62   let n = ref 0 in
  63   while n := input chan tmp 0 tmpsize; !n > 0 do
  64     Buffer.add_substring buf tmp 0 !n;
  65   done;
  66   Buffer.contents buf, 0, Buffer.length buf lsl 3
  67
  68 let bitstring_of_chan_max chan max =
  69   let tmpsize = 16384 in
  70   let buf = Buffer.create tmpsize in
  71   let tmp = String.create tmpsize in
  72   let len = ref 0 in
  73   let rec loop () =
  74     if !len < max then (
  75       let r = min tmpsize (max - !len) in
  76       let n = input chan tmp 0 r in
  77       if n > 0 then (
  78         Buffer.add_substring buf tmp 0 n;
  79         len := !len + n;
  80         loop ()
  81       )
  82     )
  83   in
  84   loop ();
  85   Buffer.contents buf, 0, !len lsl 3
  86
  87 let bitstring_of_file_descr fd =
  88   let tmpsize = 16384 in
  89   let buf = Buffer.create tmpsize in
  90   let tmp = String.create tmpsize in
  91   let n = ref 0 in
  92   while n := Unix.read fd tmp 0 tmpsize; !n > 0 do
  93     Buffer.add_substring buf tmp 0 !n;
  94   done;
  95   Buffer.contents buf, 0, Buffer.length buf lsl 3
  96
  97 let bitstring_of_file_descr_max fd max =
  98   let tmpsize = 16384 in
  99   let buf = Buffer.create tmpsize in
 100   let tmp = String.create tmpsize in
 101   let len = ref 0 in
 102   let rec loop () =
 103     if !len < max then (
 104       let r = min tmpsize (max - !len) in
 105       let n = Unix.read fd tmp 0 r in
 106       if n > 0 then (
 107         Buffer.add_substring buf tmp 0 n;
 108         len := !len + n;
 109         loop ()
 110       )
 111     )
 112   in
 113   loop ();
 114   Buffer.contents buf, 0, !len lsl 3
 115
 116 let bitstring_of_file fname =
 117   let chan = open_in_bin fname in
 118   try
 119     let bs = bitstring_of_chan chan in
 120     close_in chan;
 121     bs
 122   with exn ->
 123     close_in chan;
 124     raise exn
 125
 126 let bitstring_length (_, _, len) = len
 127
 128 (*----------------------------------------------------------------------*)
 129 (* Bitwise functions.
 130  *
 131  * We try to isolate all bitwise functions within these modules.
 132  *)
 133
 134 module I = struct
 135   (* Bitwise operations on ints.  Note that we assume int <= 31 bits. *)
 136   let (<<) = (lsl)
 137   let (>>) = (lsr)
 138   external to_int : int -> int = "%identity"
 139   let zero = 0
 140   let one = 1
 141   let minus_one = -1
 142   let ff = 0xff
 143
 144   (* Create a mask so many bits wide. *)
 145   let mask bits =
 146     if bits < 30 then
 147       pred (one << bits)
 148     else if bits = 30 then
 149       max_int
 150     else if bits = 31 then
 151       minus_one
 152     else
 153       invalid_arg "Bitmatch.I.mask"
 154
 155   (* Byte swap an int of a given size. *)
 156   let byteswap v bits =
 157     if bits <= 8 then v
 158     else if bits <= 16 then (
 159       let shift = bits-8 in
 160       let v1 = v >> shift in
 161       let v2 = (v land (mask shift)) << 8 in
 162       v2 lor v1
 163     ) else if bits <= 24 then (
 164       let shift = bits - 16 in
 165       let v1 = v >> (8+shift) in
 166       let v2 = ((v >> shift) land ff) << 8 in
 167       let v3 = (v land (mask shift)) << 16 in
 168       v3 lor v2 lor v1
 169     ) else (
 170       let shift = bits - 24 in
 171       let v1 = v >> (16+shift) in
 172       let v2 = ((v >> (8+shift)) land ff) << 8 in
 173       let v3 = ((v >> shift) land ff) << 16 in
 174       let v4 = (v land (mask shift)) << 24 in
 175       v4 lor v3 lor v2 lor v1
 176     )
 177
 178   (* Check a value is in range 0 .. 2^bits-1. *)
 179   let range_unsigned v bits =
 180     let mask = lnot (mask bits) in
 181     (v land mask) = zero
 182
 183   (* Call function g on the top bits, then f on each full byte
 184    * (big endian - so start at top).
 185    *)
 186   let rec map_bytes_be g f v bits =
 187     if bits >= 8 then (
 188       map_bytes_be g f (v >> 8) (bits-8);
 189       let lsb = v land ff in
 190       f (to_int lsb)
 191     ) else if bits > 0 then (
 192       let lsb = v land (mask bits) in
 193       g (to_int lsb) bits
 194     )
 195 end
 196
 197 module I32 = struct
 198   (* Bitwise operations on int32s.  Note we try to keep it as similar
 199    * as possible to the I module above, to make it easier to track
 200    * down bugs.
 201    *)
 202   let (<<) = Int32.shift_left
 203   let (>>) = Int32.shift_right_logical
 204   let (land) = Int32.logand
 205   let (lor) = Int32.logor
 206   let lnot = Int32.lognot
 207   let pred = Int32.pred
 208   let max_int = Int32.max_int
 209   let to_int = Int32.to_int
 210   let zero = Int32.zero
 211   let one = Int32.one
 212   let minus_one = Int32.minus_one
 213   let ff = 0xff_l
 214
 215   (* Create a mask so many bits wide. *)
 216   let mask bits =
 217     if bits < 31 then
 218       pred (one << bits)
 219     else if bits = 31 then
 220       max_int
 221     else if bits = 32 then
 222       minus_one
 223     else
 224       invalid_arg "Bitmatch.I32.mask"
 225
 226   (* Byte swap an int of a given size. *)
 227   let byteswap v bits =
 228     if bits <= 8 then v
 229     else if bits <= 16 then (
 230       let shift = bits-8 in
 231       let v1 = v >> shift in
 232       let v2 = (v land (mask shift)) << 8 in
 233       v2 lor v1
 234     ) else if bits <= 24 then (
 235       let shift = bits - 16 in
 236       let v1 = v >> (8+shift) in
 237       let v2 = ((v >> shift) land ff) << 8 in
 238       let v3 = (v land (mask shift)) << 16 in
 239       v3 lor v2 lor v1
 240     ) else (
 241       let shift = bits - 24 in
 242       let v1 = v >> (16+shift) in
 243       let v2 = ((v >> (8+shift)) land ff) << 8 in
 244       let v3 = ((v >> shift) land ff) << 16 in
 245       let v4 = (v land (mask shift)) << 24 in
 246       v4 lor v3 lor v2 lor v1
 247     )
 248
 249   (* Check a value is in range 0 .. 2^bits-1. *)
 250   let range_unsigned v bits =
 251     let mask = lnot (mask bits) in
 252     (v land mask) = zero
 253
 254   (* Call function g on the top bits, then f on each full byte
 255    * (big endian - so start at top).
 256    *)
 257   let rec map_bytes_be g f v bits =
 258     if bits >= 8 then (
 259       map_bytes_be g f (v >> 8) (bits-8);
 260       let lsb = v land ff in
 261       f (to_int lsb)
 262     ) else if bits > 0 then (
 263       let lsb = v land (mask bits) in
 264       g (to_int lsb) bits
 265     )
 266 end
 267
 268 module I64 = struct
 269   (* Bitwise operations on int64s.  Note we try to keep it as similar
 270    * as possible to the I/I32 modules above, to make it easier to track
 271    * down bugs.
 272    *)
 273   let (<<) = Int64.shift_left
 274   let (>>) = Int64.shift_right_logical
 275   let (land) = Int64.logand
 276   let (lor) = Int64.logor
 277   let lnot = Int64.lognot
 278   let pred = Int64.pred
 279   let max_int = Int64.max_int
 280   let to_int = Int64.to_int
 281   let zero = Int64.zero
 282   let one = Int64.one
 283   let minus_one = Int64.minus_one
 284   let ff = 0xff_L
 285
 286   (* Create a mask so many bits wide. *)
 287   let mask bits =
 288     if bits < 63 then
 289       pred (one << bits)
 290     else if bits = 63 then
 291       max_int
 292     else if bits = 64 then
 293       minus_one
 294     else
 295       invalid_arg "Bitmatch.I64.mask"
 296
 297   (* Byte swap an int of a given size. *)
 298   (* let byteswap v bits = *)
 299
 300   (* Check a value is in range 0 .. 2^bits-1. *)
 301   let range_unsigned v bits =
 302     let mask = lnot (mask bits) in
 303     (v land mask) = zero
 304
 305   (* Call function g on the top bits, then f on each full byte
 306    * (big endian - so start at top).
 307    *)
 308   let rec map_bytes_be g f v bits =
 309     if bits >= 8 then (
 310       map_bytes_be g f (v >> 8) (bits-8);
 311       let lsb = v land ff in
 312       f (to_int lsb)
 313     ) else if bits > 0 then (
 314       let lsb = v land (mask bits) in
 315       g (to_int lsb) bits
 316     )
 317 end
 318
 319 (*----------------------------------------------------------------------*)
 320 (* Extraction functions.
 321  *
 322  * NB: internal functions, called from the generated macros, and
 323  * the parameters should have been checked for sanity already).
 324  *)
 325
 326 (* Bitstrings. *)
 327 let extract_bitstring data off len flen =
 328   (data, off, flen), off+flen, len-flen
 329
 330 let extract_remainder data off len =
 331   (data, off, len), off+len, 0
 332
 333 (* Extract and convert to numeric.  A single bit is returned as
 334  * a boolean.  There are no endianness or signedness considerations.
 335  *)
 336 let extract_bit data off len _ =        (* final param is always 1 *)
 337   let byteoff = off lsr 3 in
 338   let bitmask = 1 lsl (7 - (off land 7)) in
 339   let b = Char.code data.[byteoff] land bitmask <> 0 in
 340   b, off+1, len-1
 341
 342 (* Returns 8 bit unsigned aligned bytes from the string.
 343  * If the string ends then this returns 0's.
 344  *)
 345 let _get_byte data byteoff strlen =
 346   if strlen > byteoff then Char.code data.[byteoff] else 0
 347 let _get_byte32 data byteoff strlen =
 348   if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
 349 let _get_byte64 data byteoff strlen =
 350   if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
 351
 352 (* Extract [2..8] bits.  Because the result fits into a single
 353  * byte we don't have to worry about endianness, only signedness.
 354  *)
 355 let extract_char_unsigned data off len flen =
 356   let byteoff = off lsr 3 in
 357
 358   (* Optimize the common (byte-aligned) case. *)
 359   if off land 7 = 0 then (
 360     let byte = Char.code data.[byteoff] in
 361     byte lsr (8 - flen), off+flen, len-flen
 362   ) else (
 363     (* Extract the 16 bits at byteoff and byteoff+1 (note that the
 364      * second byte might not exist in the original string).
 365      *)
 366     let strlen = String.length data in
 367
 368     let word =
 369       (_get_byte data byteoff strlen lsl 8) +
 370         _get_byte data (byteoff+1) strlen in
 371
 372     (* Mask off the top bits. *)
 373     let bitmask = (1 lsl (16 - (off land 7))) - 1 in
 374     let word = word land bitmask in
 375     (* Shift right to get rid of the bottom bits. *)
 376     let shift = 16 - ((off land 7) + flen) in
 377     let word = word lsr shift in
 378
 379     word, off+flen, len-flen
 380   )
 381
 382 (* Extract [9..31] bits.  We have to consider endianness and signedness. *)
 383 let extract_int_be_unsigned data off len flen =
 384   let byteoff = off lsr 3 in
 385
 386   let strlen = String.length data in
 387
 388   let word =
 389     (* Optimize the common (byte-aligned) case. *)
 390     if off land 7 = 0 then (
 391       let word =
 392         (_get_byte data byteoff strlen lsl 23) +
 393           (_get_byte data (byteoff+1) strlen lsl 15) +
 394           (_get_byte data (byteoff+2) strlen lsl 7) +
 395           (_get_byte data (byteoff+3) strlen lsr 1) in
 396       word lsr (31 - flen)
 397     ) else if flen <= 24 then (
 398       (* Extract the 31 bits at byteoff .. byteoff+3. *)
 399       let word =
 400         (_get_byte data byteoff strlen lsl 23) +
 401           (_get_byte data (byteoff+1) strlen lsl 15) +
 402           (_get_byte data (byteoff+2) strlen lsl 7) +
 403           (_get_byte data (byteoff+3) strlen lsr 1) in
 404       (* Mask off the top bits. *)
 405       let bitmask = (1 lsl (31 - (off land 7))) - 1 in
 406       let word = word land bitmask in
 407       (* Shift right to get rid of the bottom bits. *)
 408       let shift = 31 - ((off land 7) + flen) in
 409       word lsr shift
 410     ) else (
 411       (* Extract the next 31 bits, slow method. *)
 412       let word =
 413         let c0, off, len = extract_char_unsigned data off len 8 in
 414         let c1, off, len = extract_char_unsigned data off len 8 in
 415         let c2, off, len = extract_char_unsigned data off len 8 in
 416         let c3, off, len = extract_char_unsigned data off len 7 in
 417         (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
 418       word lsr (31 - flen)
 419     ) in
 420   word, off+flen, len-flen
 421
 422 let extract_int_le_unsigned data off len flen =
 423   let v, off, len = extract_int_be_unsigned data off len flen in
 424   let v = I.byteswap v flen in
 425   v, off, len
 426
 427 let extract_int_ne_unsigned =
 428   if nativeendian = BigEndian
 429   then extract_int_be_unsigned
 430   else extract_int_le_unsigned
 431
 432 let extract_int_ee_unsigned = function
 433   | BigEndian -> extract_int_be_unsigned
 434   | LittleEndian -> extract_int_le_unsigned
 435   | NativeEndian -> extract_int_ne_unsigned
 436
 437 let _make_int32_be c0 c1 c2 c3 =
 438   Int32.logor
 439     (Int32.logor
 440        (Int32.logor
 441           (Int32.shift_left c0 24)
 442           (Int32.shift_left c1 16))
 443        (Int32.shift_left c2 8))
 444     c3
 445
 446 let _make_int32_le c0 c1 c2 c3 =
 447   Int32.logor
 448     (Int32.logor
 449        (Int32.logor
 450           (Int32.shift_left c3 24)
 451           (Int32.shift_left c2 16))
 452        (Int32.shift_left c1 8))
 453     c0
 454
 455 (* Extract exactly 32 bits.  We have to consider endianness and signedness. *)
 456 let extract_int32_be_unsigned data off len flen =
 457   let byteoff = off lsr 3 in
 458
 459   let strlen = String.length data in
 460
 461   let word =
 462     (* Optimize the common (byte-aligned) case. *)
 463     if off land 7 = 0 then (
 464       let word =
 465         let c0 = _get_byte32 data byteoff strlen in
 466         let c1 = _get_byte32 data (byteoff+1) strlen in
 467         let c2 = _get_byte32 data (byteoff+2) strlen in
 468         let c3 = _get_byte32 data (byteoff+3) strlen in
 469         _make_int32_be c0 c1 c2 c3 in
 470       Int32.shift_right_logical word (32 - flen)
 471     ) else (
 472       (* Extract the next 32 bits, slow method. *)
 473       let word =
 474         let c0, off, len = extract_char_unsigned data off len 8 in
 475         let c1, off, len = extract_char_unsigned data off len 8 in
 476         let c2, off, len = extract_char_unsigned data off len 8 in
 477         let c3, _, _ = extract_char_unsigned data off len 8 in
 478         let c0 = Int32.of_int c0 in
 479         let c1 = Int32.of_int c1 in
 480         let c2 = Int32.of_int c2 in
 481         let c3 = Int32.of_int c3 in
 482         _make_int32_be c0 c1 c2 c3 in
 483       Int32.shift_right_logical word (32 - flen)
 484     ) in
 485   word, off+flen, len-flen
 486
 487 let extract_int32_le_unsigned data off len flen =
 488   let v, off, len = extract_int32_be_unsigned data off len flen in
 489   let v = I32.byteswap v flen in
 490   v, off, len
 491
 492 let extract_int32_ne_unsigned =
 493   if nativeendian = BigEndian
 494   then extract_int32_be_unsigned
 495   else extract_int32_le_unsigned
 496
 497 let extract_int32_ee_unsigned = function
 498   | BigEndian -> extract_int32_be_unsigned
 499   | LittleEndian -> extract_int32_le_unsigned
 500   | NativeEndian -> extract_int32_ne_unsigned
 501
 502 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
 503   Int64.logor
 504     (Int64.logor
 505        (Int64.logor
 506           (Int64.logor
 507              (Int64.logor
 508                 (Int64.logor
 509                    (Int64.logor
 510                       (Int64.shift_left c0 56)
 511                       (Int64.shift_left c1 48))
 512                    (Int64.shift_left c2 40))
 513                 (Int64.shift_left c3 32))
 514              (Int64.shift_left c4 24))
 515           (Int64.shift_left c5 16))
 516        (Int64.shift_left c6 8))
 517     c7
 518
 519 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
 520   _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
 521
 522 (* Extract [1..64] bits.  We have to consider endianness and signedness. *)
 523 let extract_int64_be_unsigned data off len flen =
 524   let byteoff = off lsr 3 in
 525
 526   let strlen = String.length data in
 527
 528   let word =
 529     (* Optimize the common (byte-aligned) case. *)
 530     if off land 7 = 0 then (
 531       let word =
 532         let c0 = _get_byte64 data byteoff strlen in
 533         let c1 = _get_byte64 data (byteoff+1) strlen in
 534         let c2 = _get_byte64 data (byteoff+2) strlen in
 535         let c3 = _get_byte64 data (byteoff+3) strlen in
 536         let c4 = _get_byte64 data (byteoff+4) strlen in
 537         let c5 = _get_byte64 data (byteoff+5) strlen in
 538         let c6 = _get_byte64 data (byteoff+6) strlen in
 539         let c7 = _get_byte64 data (byteoff+7) strlen in
 540         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 541       Int64.shift_right_logical word (64 - flen)
 542     ) else (
 543       (* Extract the next 64 bits, slow method. *)
 544       let word =
 545         let c0, off, len = extract_char_unsigned data off len 8 in
 546         let c1, off, len = extract_char_unsigned data off len 8 in
 547         let c2, off, len = extract_char_unsigned data off len 8 in
 548         let c3, off, len = extract_char_unsigned data off len 8 in
 549         let c4, off, len = extract_char_unsigned data off len 8 in
 550         let c5, off, len = extract_char_unsigned data off len 8 in
 551         let c6, off, len = extract_char_unsigned data off len 8 in
 552         let c7, _, _ = extract_char_unsigned data off len 8 in
 553         let c0 = Int64.of_int c0 in
 554         let c1 = Int64.of_int c1 in
 555         let c2 = Int64.of_int c2 in
 556         let c3 = Int64.of_int c3 in
 557         let c4 = Int64.of_int c4 in
 558         let c5 = Int64.of_int c5 in
 559         let c6 = Int64.of_int c6 in
 560         let c7 = Int64.of_int c7 in
 561         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 562       Int64.shift_right_logical word (64 - flen)
 563     ) in
 564   word, off+flen, len-flen
 565
 566 let extract_int64_le_unsigned data off len flen =
 567   let byteoff = off lsr 3 in
 568
 569   let strlen = String.length data in
 570
 571   let word =
 572     (* Optimize the common (byte-aligned) case. *)
 573     if off land 7 = 0 then (
 574       let word =
 575         let c0 = _get_byte64 data byteoff strlen in
 576         let c1 = _get_byte64 data (byteoff+1) strlen in
 577         let c2 = _get_byte64 data (byteoff+2) strlen in
 578         let c3 = _get_byte64 data (byteoff+3) strlen in
 579         let c4 = _get_byte64 data (byteoff+4) strlen in
 580         let c5 = _get_byte64 data (byteoff+5) strlen in
 581         let c6 = _get_byte64 data (byteoff+6) strlen in
 582         let c7 = _get_byte64 data (byteoff+7) strlen in
 583         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 584       Int64.logand word (I64.mask flen)
 585     ) else (
 586       (* Extract the next 64 bits, slow method. *)
 587       let word =
 588         let c0, off, len = extract_char_unsigned data off len 8 in
 589         let c1, off, len = extract_char_unsigned data off len 8 in
 590         let c2, off, len = extract_char_unsigned data off len 8 in
 591         let c3, off, len = extract_char_unsigned data off len 8 in
 592         let c4, off, len = extract_char_unsigned data off len 8 in
 593         let c5, off, len = extract_char_unsigned data off len 8 in
 594         let c6, off, len = extract_char_unsigned data off len 8 in
 595         let c7, _, _ = extract_char_unsigned data off len 8 in
 596         let c0 = Int64.of_int c0 in
 597         let c1 = Int64.of_int c1 in
 598         let c2 = Int64.of_int c2 in
 599         let c3 = Int64.of_int c3 in
 600         let c4 = Int64.of_int c4 in
 601         let c5 = Int64.of_int c5 in
 602         let c6 = Int64.of_int c6 in
 603         let c7 = Int64.of_int c7 in
 604         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 605       Int64.logand word (I64.mask flen)
 606     ) in
 607   word, off+flen, len-flen
 608
 609 let extract_int64_ne_unsigned =
 610   if nativeendian = BigEndian
 611   then extract_int64_be_unsigned
 612   else extract_int64_le_unsigned
 613
 614 let extract_int64_ee_unsigned = function
 615   | BigEndian -> extract_int64_be_unsigned
 616   | LittleEndian -> extract_int64_le_unsigned
 617   | NativeEndian -> extract_int64_ne_unsigned
 618
 619 (*----------------------------------------------------------------------*)
 620 (* Constructor functions. *)
 621
 622 module Buffer = struct
 623   type t = {
 624     buf : Buffer.t;
 625     mutable len : int;                  (* Length in bits. *)
 626     (* Last byte in the buffer (if len is not aligned).  We store
 627      * it outside the buffer because buffers aren't mutable.
 628      *)
 629     mutable last : int;
 630   }
 631
 632   let create () =
 633     (* XXX We have almost enough information in the generator to
 634      * choose a good initial size.
 635      *)
 636     { buf = Buffer.create 128; len = 0; last = 0 }
 637
 638   let contents { buf = buf; len = len; last = last } =
 639     let data =
 640       if len land 7 = 0 then
 641         Buffer.contents buf
 642       else
 643         Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
 644     data, 0, len
 645
 646   (* Add exactly 8 bits. *)
 647   let add_byte ({ buf = buf; len = len; last = last } as t) byte =
 648     if byte < 0 || byte > 255 then invalid_arg "Bitmatch.Buffer.add_byte";
 649     let shift = len land 7 in
 650     if shift = 0 then
 651       (* Target buffer is byte-aligned. *)
 652       Buffer.add_char buf (Char.chr byte)
 653     else (
 654       (* Target buffer is unaligned.  'last' is meaningful. *)
 655       let first = byte lsr shift in
 656       let second = (byte lsl (8 - shift)) land 0xff in
 657       Buffer.add_char buf (Char.chr (last lor first));
 658       t.last <- second
 659     );
 660     t.len <- t.len + 8
 661
 662   (* Add exactly 1 bit. *)
 663   let add_bit ({ buf = buf; len = len; last = last } as t) bit =
 664     let shift = 7 - (len land 7) in
 665     if shift > 0 then
 666       (* Somewhere in the middle of 'last'. *)
 667       t.last <- last lor ((if bit then 1 else 0) lsl shift)
 668     else (
 669       (* Just a single spare bit in 'last'. *)
 670       let last = last lor if bit then 1 else 0 in
 671       Buffer.add_char buf (Char.chr last);
 672       t.last <- 0
 673     );
 674     t.len <- len + 1
 675
 676   (* Add a small number of bits (definitely < 8).  This uses a loop
 677    * to call add_bit so it's slow.
 678    *)
 679   let _add_bits t c slen =
 680     if slen < 1 || slen >= 8 then invalid_arg "Bitmatch.Buffer._add_bits";
 681     for i = slen-1 downto 0 do
 682       let bit = c land (1 lsl i) <> 0 in
 683       add_bit t bit
 684     done
 685
 686   let add_bits ({ buf = buf; len = len } as t) str slen =
 687     if slen > 0 then (
 688       if len land 7 = 0 then (
 689         if slen land 7 = 0 then
 690           (* Common case - everything is byte-aligned. *)
 691           Buffer.add_substring buf str 0 (slen lsr 3)
 692         else (
 693           (* Target buffer is aligned.  Copy whole bytes then leave the
 694            * remaining bits in last.
 695            *)
 696           let slenbytes = slen lsr 3 in
 697           if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes;
 698           let last = Char.code str.[slenbytes] in (* last char *)
 699           let mask = 0xff lsl (8 - (slen land 7)) in
 700           t.last <- last land mask
 701         );
 702         t.len <- len + slen
 703       ) else (
 704         (* Target buffer is unaligned.  Copy whole bytes using
 705          * add_byte which knows how to deal with an unaligned
 706          * target buffer, then call add_bit for the remaining < 8 bits.
 707          *
 708          * XXX This is going to be dog-slow.
 709          *)
 710         let slenbytes = slen lsr 3 in
 711         for i = 0 to slenbytes-1 do
 712           let byte = Char.code str.[i] in
 713           add_byte t byte
 714         done;
 715         let bitsleft = slen - (slenbytes lsl 3) in
 716         if bitsleft > 0 then (
 717           let c = Char.code str.[slenbytes] in
 718           for i = 0 to bitsleft - 1 do
 719             let bit = c land (0x80 lsr i) <> 0 in
 720             add_bit t bit
 721           done
 722         )
 723       );
 724     )
 725 end
 726
 727 (* Construct a single bit. *)
 728 let construct_bit buf b _ _ =
 729   Buffer.add_bit buf b
 730
 731 (* Construct a field, flen = [2..8]. *)
 732 let construct_char_unsigned buf v flen exn =
 733   let max_val = 1 lsl flen in
 734   if v < 0 || v >= max_val then raise exn;
 735   if flen = 8 then
 736     Buffer.add_byte buf v
 737   else
 738     Buffer._add_bits buf v flen
 739
 740 (* Construct a field of up to 31 bits. *)
 741 let construct_int_be_unsigned buf v flen exn =
 742   (* Check value is within range. *)
 743   if not (I.range_unsigned v flen) then raise exn;
 744   (* Add the bytes. *)
 745   I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 746
 747 let construct_int_ne_unsigned =
 748   if nativeendian = BigEndian
 749   then construct_int_be_unsigned
 750   else (*construct_int_le_unsigned*)
 751     fun _ _ _ _ -> failwith "construct_int_le_unsigned"
 752
 753 let construct_int_ee_unsigned = function
 754   | BigEndian -> construct_int_be_unsigned
 755   | LittleEndian -> (*construct_int_le_unsigned*)
 756       (fun _ _ _ _ -> failwith "construct_int_le_unsigned")
 757   | NativeEndian -> construct_int_ne_unsigned
 758
 759 (* Construct a field of exactly 32 bits. *)
 760 let construct_int32_be_unsigned buf v flen _ =
 761   Buffer.add_byte buf
 762     (Int32.to_int (Int32.shift_right_logical v 24));
 763   Buffer.add_byte buf
 764     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 765   Buffer.add_byte buf
 766     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 767   Buffer.add_byte buf
 768     (Int32.to_int (Int32.logand v 0xff_l))
 769
 770 let construct_int32_le_unsigned buf v flen _ =
 771   Buffer.add_byte buf
 772     (Int32.to_int (Int32.logand v 0xff_l));
 773   Buffer.add_byte buf
 774     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 775   Buffer.add_byte buf
 776     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 777   Buffer.add_byte buf
 778     (Int32.to_int (Int32.shift_right_logical v 24))
 779
 780 let construct_int32_ne_unsigned =
 781   if nativeendian = BigEndian
 782   then construct_int32_be_unsigned
 783   else construct_int32_le_unsigned
 784
 785 let construct_int32_ee_unsigned = function
 786   | BigEndian -> construct_int32_be_unsigned
 787   | LittleEndian -> construct_int32_le_unsigned
 788   | NativeEndian -> construct_int32_ne_unsigned
 789
 790 (* Construct a field of up to 64 bits. *)
 791 let construct_int64_be_unsigned buf v flen exn =
 792   (* Check value is within range. *)
 793   if not (I64.range_unsigned v flen) then raise exn;
 794   (* Add the bytes. *)
 795   I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 796
 797 let construct_int64_ne_unsigned =
 798   if nativeendian = BigEndian
 799   then construct_int64_be_unsigned
 800   else (*construct_int64_le_unsigned*)
 801     fun _ _ _ _ -> failwith "construct_int64_le_unsigned"
 802
 803 let construct_int64_ee_unsigned = function
 804   | BigEndian -> construct_int64_be_unsigned
 805   | LittleEndian -> (*construct_int64_le_unsigned*)
 806       (fun _ _ _ _ -> failwith "construct_int64_le_unsigned")
 807   | NativeEndian -> construct_int64_ne_unsigned
 808
 809 (* Construct from a string of bytes, exact multiple of 8 bits
 810  * in length of course.
 811  *)
 812 let construct_string buf str =
 813   let len = String.length str in
 814   Buffer.add_bits buf str (len lsl 3)
 815
 816 (* Construct from a bitstring. *)
 817 let construct_bitstring buf (data, off, len) =
 818   (* Add individual bits until we get to the next byte boundary of
 819    * the underlying string.
 820    *)
 821   let blen = 7 - ((off + 7) land 7) in
 822   let blen = min blen len in
 823   let rec loop off len blen =
 824     if blen = 0 then (off, len)
 825     else (
 826       let b, off, len = extract_bit data off len 1 in
 827       Buffer.add_bit buf b;
 828       loop off len (blen-1)
 829     )
 830   in
 831   let off, len = loop off len blen in
 832   assert (len = 0 || (off land 7) = 0);
 833
 834   (* Add the remaining 'len' bits. *)
 835   let data =
 836     let off = off lsr 3 in
 837     (* XXX dangerous allocation *)
 838     if off = 0 then data
 839     else String.sub data off (String.length data - off) in
 840
 841   Buffer.add_bits buf data len
 842
 843 (*----------------------------------------------------------------------*)
 844 (* Extract a string from a bitstring. *)
 845
 846 let string_of_bitstring (data, off, len) =
 847   if off land 7 = 0 && len land 7 = 0 then
 848     (* Easy case: everything is byte-aligned. *)
 849     String.sub data (off lsr 3) (len lsr 3)
 850   else (
 851     (* Bit-twiddling case. *)
 852     let strlen = (len + 7) lsr 3 in
 853     let str = String.make strlen '\000' in
 854     let rec loop data off len i =
 855       if len >= 8 then (
 856         let c, off, len = extract_char_unsigned data off len 8 in
 857         str.[i] <- Char.chr c;
 858         loop data off len (i+1)
 859       ) else if len > 0 then (
 860         let c, _, _ = extract_char_unsigned data off len len in
 861         str.[i] <- Char.chr (c lsl (8-len))
 862       )
 863     in
 864     loop data off len 0;
 865     str
 866   )
 867
 868 (* To channel. *)
 869
 870 let bitstring_to_chan ((data, off, len) as bits) chan =
 871   (* Fail if the bitstring length isn't a multiple of 8. *)
 872   if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
 873
 874   if off land 7 = 0 then
 875     (* Easy case: string is byte-aligned. *)
 876     output chan data (off lsr 3) (len lsr 3)
 877   else (
 878     (* Bit-twiddling case: reuse string_of_bitstring *)
 879     let str = string_of_bitstring bits in
 880     output_string chan str
 881   )
 882
 883 let bitstring_to_file bits filename =
 884   let chan = open_out_bin filename in
 885   try
 886     bitstring_to_chan bits chan;
 887     close_out chan
 888   with exn ->
 889     close_out chan;
 890     raise exn
 891
 892 (*----------------------------------------------------------------------*)
 893 (* Display functions. *)
 894
 895 let isprint c =
 896   let c = Char.code c in
 897   c >= 32 && c < 127
 898
 899 let hexdump_bitstring chan (data, off, len) =
 900   let count = ref 0 in
 901   let off = ref off in
 902   let len = ref len in
 903   let linelen = ref 0 in
 904   let linechars = String.make 16 ' ' in
 905
 906   fprintf chan "00000000  ";
 907
 908   while !len > 0 do
 909     let bits = min !len 8 in
 910     let byte, off', len' = extract_char_unsigned data !off !len bits in
 911     off := off'; len := len';
 912
 913     let byte = byte lsl (8-bits) in
 914     fprintf chan "%02x " byte;
 915
 916     incr count;
 917     linechars.[!linelen] <-
 918       (let c = Char.chr byte in
 919        if isprint c then c else '.');
 920     incr linelen;
 921     if !linelen = 8 then fprintf chan " ";
 922     if !linelen = 16 then (
 923       fprintf chan " |%s|\n%08x  " linechars !count;
 924       linelen := 0;
 925       for i = 0 to 15 do linechars.[i] <- ' ' done
 926     )
 927   done;
 928
 929   if !linelen > 0 then (
 930     let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
 931     for i = 0 to skip-1 do fprintf chan " " done;
 932     fprintf chan " |%s|\n%!" linechars
 933   ) else
 934     fprintf chan "\n%!"