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 off' < 0 || len' < 0 || off' > len - 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 || n < 0 then invalid_arg "dropbits";
 140   (data, off, len)
 141
 142 let takebits n (data, off, len) =
 143   if len < n || n < 0 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 ||
 165       (bits < 32 && Sys.word_size = 64) then
 166       (one <<< bits) - 1
 167     else if bits = 30 then
 168       max_int
 169     else if bits = 31 then
 170       minus_one
 171     else
 172       invalid_arg "Bitstring.I.mask"
 173
 174   (* Byte swap an int of a given size. *)
 175   let byteswap v bits =
 176     if bits <= 8 then v
 177     else if bits <= 16 then (
 178       let shift = bits-8 in
 179       let v1 = v >>> shift in
 180       let v2 = ((v land (mask shift)) <<< 8) in
 181       v2 lor v1
 182     ) else if bits <= 24 then (
 183       let shift = bits - 16 in
 184       let v1 = v >>> (8+shift) in
 185       let v2 = ((v >>> shift) land ff) <<< 8 in
 186       let v3 = (v land (mask shift)) <<< 16 in
 187       v3 lor v2 lor v1
 188     ) else (
 189       let shift = bits - 24 in
 190       let v1 = v >>> (16+shift) in
 191       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
 192       let v3 = ((v >>> shift) land ff) <<< 16 in
 193       let v4 = (v land (mask shift)) <<< 24 in
 194       v4 lor v3 lor v2 lor v1
 195     )
 196
 197   (* Check a value is in range 0 .. 2^bits-1. *)
 198   let range_unsigned v bits =
 199     let mask = lnot (mask bits) in
 200     (v land mask) = zero
 201
 202   let range_signed v bits =
 203     if
 204       v >= zero
 205     then
 206       range_unsigned v bits
 207     else
 208       if
 209         bits = 31 && Sys.word_size = 32
 210       then
 211         v >= min_int
 212       else
 213         pred (minus_one <<< pred bits) < v
 214
 215   (* Call function g on the top bits, then f on each full byte
 216    * (big endian - so start at top).
 217    *)
 218   let rec map_bytes_be g f v bits =
 219     if bits >= 8 then (
 220       map_bytes_be g f (v >>> 8) (bits-8);
 221       let lsb = v land ff in
 222       f (to_int lsb)
 223     ) else if bits > 0 then (
 224       let lsb = v land (mask bits) in
 225       g (to_int lsb) bits
 226     )
 227
 228   (* Call function g on the top bits, then f on each full byte
 229    * (little endian - so start at root).
 230    *)
 231   let rec map_bytes_le g f v bits =
 232     if bits >= 8 then (
 233       let lsb = v land ff in
 234       f (to_int lsb);
 235       map_bytes_le g f (v >>> 8) (bits-8)
 236     ) else if bits > 0 then (
 237       let lsb = v land (mask bits) in
 238       g (to_int lsb) bits
 239     )
 240 end
 241
 242 module I32 = struct
 243   (* Bitwise operations on int32s.  Note we try to keep it as similar
 244    * as possible to the I module above, to make it easier to track
 245    * down bugs.
 246    *)
 247   let (<<<) = Int32.shift_left
 248   let (>>>) = Int32.shift_right_logical
 249   let (land) = Int32.logand
 250   let (lor) = Int32.logor
 251   let lnot = Int32.lognot
 252   let pred = Int32.pred
 253   let max_int = Int32.max_int
 254   let to_int = Int32.to_int
 255   let zero = Int32.zero
 256   let one = Int32.one
 257   let minus_one = Int32.minus_one
 258   let ff = 0xff_l
 259
 260   (* Create a mask so many bits wide. *)
 261   let mask bits =
 262     if bits < 31 then
 263       pred (one <<< bits)
 264     else if bits = 31 then
 265       max_int
 266     else if bits = 32 then
 267       minus_one
 268     else
 269       invalid_arg "Bitstring.I32.mask"
 270
 271   (* Byte swap an int of a given size. *)
 272   let byteswap v bits =
 273     if bits <= 8 then v
 274     else if bits <= 16 then (
 275       let shift = bits-8 in
 276       let v1 = v >>> shift in
 277       let v2 = (v land (mask shift)) <<< 8 in
 278       v2 lor v1
 279     ) else if bits <= 24 then (
 280       let shift = bits - 16 in
 281       let v1 = v >>> (8+shift) in
 282       let v2 = ((v >>> shift) land ff) <<< 8 in
 283       let v3 = (v land (mask shift)) <<< 16 in
 284       v3 lor v2 lor v1
 285     ) else (
 286       let shift = bits - 24 in
 287       let v1 = v >>> (16+shift) in
 288       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
 289       let v3 = ((v >>> shift) land ff) <<< 16 in
 290       let v4 = (v land (mask shift)) <<< 24 in
 291       v4 lor v3 lor v2 lor v1
 292     )
 293
 294   (* Check a value is in range 0 .. 2^bits-1. *)
 295   let range_unsigned v bits =
 296     let mask = lnot (mask bits) in
 297     (v land mask) = zero
 298
 299   (* Call function g on the top bits, then f on each full byte
 300    * (big endian - so start at top).
 301    *)
 302   let rec map_bytes_be g f v bits =
 303     if bits >= 8 then (
 304       map_bytes_be g f (v >>> 8) (bits-8);
 305       let lsb = v land ff in
 306       f (to_int lsb)
 307     ) else if bits > 0 then (
 308       let lsb = v land (mask bits) in
 309       g (to_int lsb) bits
 310     )
 311
 312   (* Call function g on the top bits, then f on each full byte
 313    * (little endian - so start at root).
 314    *)
 315   let rec map_bytes_le g f v bits =
 316     if bits >= 8 then (
 317       let lsb = v land ff in
 318       f (to_int lsb);
 319       map_bytes_le g f (v >>> 8) (bits-8)
 320     ) else if bits > 0 then (
 321       let lsb = v land (mask bits) in
 322       g (to_int lsb) bits
 323     )
 324 end
 325
 326 module I64 = struct
 327   (* Bitwise operations on int64s.  Note we try to keep it as similar
 328    * as possible to the I/I32 modules above, to make it easier to track
 329    * down bugs.
 330    *)
 331   let (<<<) = Int64.shift_left
 332   let (>>>) = Int64.shift_right_logical
 333   let (land) = Int64.logand
 334   let (lor) = Int64.logor
 335   let lnot = Int64.lognot
 336   let pred = Int64.pred
 337   let max_int = Int64.max_int
 338   let to_int = Int64.to_int
 339   let zero = Int64.zero
 340   let one = Int64.one
 341   let minus_one = Int64.minus_one
 342   let ff = 0xff_L
 343
 344   (* Create a mask so many bits wide. *)
 345   let mask bits =
 346     if bits < 63 then
 347       pred (one <<< bits)
 348     else if bits = 63 then
 349       max_int
 350     else if bits = 64 then
 351       minus_one
 352     else
 353       invalid_arg "Bitstring.I64.mask"
 354
 355   (* Byte swap an int of a given size. *)
 356   (* let byteswap v bits = *)
 357
 358   (* Check a value is in range 0 .. 2^bits-1. *)
 359   let range_unsigned v bits =
 360     let mask = lnot (mask bits) in
 361     (v land mask) = zero
 362
 363   (* Call function g on the top bits, then f on each full byte
 364    * (big endian - so start at top).
 365    *)
 366   let rec map_bytes_be g f v bits =
 367     if bits >= 8 then (
 368       map_bytes_be g f (v >>> 8) (bits-8);
 369       let lsb = v land ff in
 370       f (to_int lsb)
 371     ) else if bits > 0 then (
 372       let lsb = v land (mask bits) in
 373       g (to_int lsb) bits
 374     )
 375
 376   (* Call function g on the top bits, then f on each full byte
 377    * (little endian - so start at root).
 378    *)
 379   let rec map_bytes_le g f v bits =
 380     if bits >= 8 then (
 381       let lsb = v land ff in
 382       f (to_int lsb);
 383       map_bytes_le g f (v >>> 8) (bits-8)
 384     ) else if bits > 0 then (
 385       let lsb = v land (mask bits) in
 386       g (to_int lsb) bits
 387     )
 388 end
 389
 390 (*----------------------------------------------------------------------*)
 391 (* Extraction functions.
 392  *
 393  * NB: internal functions, called from the generated macros, and
 394  * the parameters should have been checked for sanity already).
 395  *)
 396
 397 (* Extract and convert to numeric.  A single bit is returned as
 398  * a boolean.  There are no endianness or signedness considerations.
 399  *)
 400 let extract_bit data off len _ =        (* final param is always 1 *)
 401   let byteoff = off lsr 3 in
 402   let bitmask = 1 lsl (7 - (off land 7)) in
 403   let b = Char.code data.[byteoff] land bitmask <> 0 in
 404   b (*, off+1, len-1*)
 405
 406 (* Returns 8 bit unsigned aligned bytes from the string.
 407  * If the string ends then this returns 0's.
 408  *)
 409 let _get_byte data byteoff strlen =
 410   if strlen > byteoff then Char.code data.[byteoff] else 0
 411 let _get_byte32 data byteoff strlen =
 412   if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
 413 let _get_byte64 data byteoff strlen =
 414   if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
 415
 416 (* Extend signed [2..31] bits int to 31 bits int or 63 bits int for 64
 417    bits platform*)
 418 let extend_sign len v =
 419   let b = pred Sys.word_size - len in
 420     (v lsl b) asr b
 421
 422 let extract_and_extend_sign f data off len flen =
 423   let w = f data off len flen in
 424     extend_sign len w
 425
 426 (* Extract [2..8] bits.  Because the result fits into a single
 427  * byte we don't have to worry about endianness, only signedness.
 428  *)
 429 let extract_char_unsigned data off len flen =
 430   let byteoff = off lsr 3 in
 431
 432   (* Optimize the common (byte-aligned) case. *)
 433   if off land 7 = 0 then (
 434     let byte = Char.code data.[byteoff] in
 435     byte lsr (8 - flen) (*, off+flen, len-flen*)
 436   ) else (
 437     (* Extract the 16 bits at byteoff and byteoff+1 (note that the
 438      * second byte might not exist in the original string).
 439      *)
 440     let strlen = String.length data in
 441
 442     let word =
 443       (_get_byte data byteoff strlen lsl 8) +
 444         _get_byte data (byteoff+1) strlen in
 445
 446     (* Mask off the top bits. *)
 447     let bitmask = (1 lsl (16 - (off land 7))) - 1 in
 448     let word = word land bitmask in
 449     (* Shift right to get rid of the bottom bits. *)
 450     let shift = 16 - ((off land 7) + flen) in
 451     let word = word lsr shift in
 452
 453     word (*, off+flen, len-flen*)
 454   )
 455
 456 let extract_char_signed =
 457   extract_and_extend_sign extract_char_unsigned
 458
 459 (* Extract [9..31] bits.  We have to consider endianness and signedness. *)
 460 let extract_int_be_unsigned data off len flen =
 461   let byteoff = off lsr 3 in
 462
 463   let strlen = String.length data in
 464
 465   let word =
 466     (* Optimize the common (byte-aligned) case. *)
 467     if off land 7 = 0 then (
 468       let word =
 469         (_get_byte data byteoff strlen lsl 23) +
 470           (_get_byte data (byteoff+1) strlen lsl 15) +
 471           (_get_byte data (byteoff+2) strlen lsl 7) +
 472           (_get_byte data (byteoff+3) strlen lsr 1) in
 473       word lsr (31 - flen)
 474     ) else if flen <= 24 then (
 475       (* Extract the 31 bits at byteoff .. byteoff+3. *)
 476       let word =
 477         (_get_byte data byteoff strlen lsl 23) +
 478           (_get_byte data (byteoff+1) strlen lsl 15) +
 479           (_get_byte data (byteoff+2) strlen lsl 7) +
 480           (_get_byte data (byteoff+3) strlen lsr 1) in
 481       (* Mask off the top bits. *)
 482       let bitmask = (1 lsl (31 - (off land 7))) - 1 in
 483       let word = word land bitmask in
 484       (* Shift right to get rid of the bottom bits. *)
 485       let shift = 31 - ((off land 7) + flen) in
 486       word lsr shift
 487     ) else (
 488       (* Extract the next 31 bits, slow method. *)
 489       let word =
 490         let c0 = extract_char_unsigned data off len 8
 491         and off = off + 8 and len = len - 8 in
 492         let c1 = extract_char_unsigned data off len 8
 493         and off = off + 8 and len = len - 8 in
 494         let c2 = extract_char_unsigned data off len 8
 495         and off = off + 8 and len = len - 8 in
 496         let c3 = extract_char_unsigned data off len 7 in
 497         (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
 498       word lsr (31 - flen)
 499     ) in
 500   word (*, off+flen, len-flen*)
 501
 502 let extract_int_be_signed =
 503   extract_and_extend_sign extract_int_be_unsigned
 504
 505 let extract_int_le_unsigned data off len flen =
 506   let v = extract_int_be_unsigned data off len flen in
 507   let v = I.byteswap v flen in
 508   v
 509
 510 let extract_int_le_signed =
 511   extract_and_extend_sign extract_int_le_unsigned
 512
 513 let extract_int_ne_unsigned =
 514   if nativeendian = BigEndian
 515   then extract_int_be_unsigned
 516   else extract_int_le_unsigned
 517
 518 let extract_int_ne_signed =
 519   extract_and_extend_sign extract_int_ne_unsigned
 520
 521 let extract_int_ee_unsigned = function
 522   | BigEndian -> extract_int_be_unsigned
 523   | LittleEndian -> extract_int_le_unsigned
 524   | NativeEndian -> extract_int_ne_unsigned
 525
 526 let extract_int_ee_signed e =
 527   extract_and_extend_sign (extract_int_ee_unsigned e)
 528
 529 let _make_int32_be c0 c1 c2 c3 =
 530   Int32.logor
 531     (Int32.logor
 532        (Int32.logor
 533           (Int32.shift_left c0 24)
 534           (Int32.shift_left c1 16))
 535        (Int32.shift_left c2 8))
 536     c3
 537
 538 let _make_int32_le c0 c1 c2 c3 =
 539   Int32.logor
 540     (Int32.logor
 541        (Int32.logor
 542           (Int32.shift_left c3 24)
 543           (Int32.shift_left c2 16))
 544        (Int32.shift_left c1 8))
 545     c0
 546
 547 (* Extract exactly 32 bits.  We have to consider endianness and signedness. *)
 548 let extract_int32_be_unsigned data off len flen =
 549   let byteoff = off lsr 3 in
 550
 551   let strlen = String.length data in
 552
 553   let word =
 554     (* Optimize the common (byte-aligned) case. *)
 555     if off land 7 = 0 then (
 556       let word =
 557         let c0 = _get_byte32 data byteoff strlen in
 558         let c1 = _get_byte32 data (byteoff+1) strlen in
 559         let c2 = _get_byte32 data (byteoff+2) strlen in
 560         let c3 = _get_byte32 data (byteoff+3) strlen in
 561         _make_int32_be c0 c1 c2 c3 in
 562       Int32.shift_right_logical word (32 - flen)
 563     ) else (
 564       (* Extract the next 32 bits, slow method. *)
 565       let word =
 566         let c0 = extract_char_unsigned data off len 8
 567         and off = off + 8 and len = len - 8 in
 568         let c1 = extract_char_unsigned data off len 8
 569         and off = off + 8 and len = len - 8 in
 570         let c2 = extract_char_unsigned data off len 8
 571         and off = off + 8 and len = len - 8 in
 572         let c3 = extract_char_unsigned data off len 8 in
 573         let c0 = Int32.of_int c0 in
 574         let c1 = Int32.of_int c1 in
 575         let c2 = Int32.of_int c2 in
 576         let c3 = Int32.of_int c3 in
 577         _make_int32_be c0 c1 c2 c3 in
 578       Int32.shift_right_logical word (32 - flen)
 579     ) in
 580   word (*, off+flen, len-flen*)
 581
 582 let extract_int32_le_unsigned data off len flen =
 583   let v = extract_int32_be_unsigned data off len flen in
 584   let v = I32.byteswap v flen in
 585   v
 586
 587 let extract_int32_ne_unsigned =
 588   if nativeendian = BigEndian
 589   then extract_int32_be_unsigned
 590   else extract_int32_le_unsigned
 591
 592 let extract_int32_ee_unsigned = function
 593   | BigEndian -> extract_int32_be_unsigned
 594   | LittleEndian -> extract_int32_le_unsigned
 595   | NativeEndian -> extract_int32_ne_unsigned
 596
 597 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
 598   Int64.logor
 599     (Int64.logor
 600        (Int64.logor
 601           (Int64.logor
 602              (Int64.logor
 603                 (Int64.logor
 604                    (Int64.logor
 605                       (Int64.shift_left c0 56)
 606                       (Int64.shift_left c1 48))
 607                    (Int64.shift_left c2 40))
 608                 (Int64.shift_left c3 32))
 609              (Int64.shift_left c4 24))
 610           (Int64.shift_left c5 16))
 611        (Int64.shift_left c6 8))
 612     c7
 613
 614 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
 615   _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
 616
 617 (* Extract [1..64] bits.  We have to consider endianness and signedness. *)
 618 let extract_int64_be_unsigned data off len flen =
 619   let byteoff = off lsr 3 in
 620
 621   let strlen = String.length data in
 622
 623   let word =
 624     (* Optimize the common (byte-aligned) case. *)
 625     if off land 7 = 0 then (
 626       let word =
 627         let c0 = _get_byte64 data byteoff strlen in
 628         let c1 = _get_byte64 data (byteoff+1) strlen in
 629         let c2 = _get_byte64 data (byteoff+2) strlen in
 630         let c3 = _get_byte64 data (byteoff+3) strlen in
 631         let c4 = _get_byte64 data (byteoff+4) strlen in
 632         let c5 = _get_byte64 data (byteoff+5) strlen in
 633         let c6 = _get_byte64 data (byteoff+6) strlen in
 634         let c7 = _get_byte64 data (byteoff+7) strlen in
 635         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 636       Int64.shift_right_logical word (64 - flen)
 637     ) else (
 638       (* Extract the next 64 bits, slow method. *)
 639       let word =
 640         let c0 = extract_char_unsigned data off len 8
 641         and off = off + 8 and len = len - 8 in
 642         let c1 = extract_char_unsigned data off len 8
 643         and off = off + 8 and len = len - 8 in
 644         let c2 = extract_char_unsigned data off len 8
 645         and off = off + 8 and len = len - 8 in
 646         let c3 = extract_char_unsigned data off len 8
 647         and off = off + 8 and len = len - 8 in
 648         let c4 = extract_char_unsigned data off len 8
 649         and off = off + 8 and len = len - 8 in
 650         let c5 = extract_char_unsigned data off len 8
 651         and off = off + 8 and len = len - 8 in
 652         let c6 = extract_char_unsigned data off len 8
 653         and off = off + 8 and len = len - 8 in
 654         let c7 = extract_char_unsigned data off len 8 in
 655         let c0 = Int64.of_int c0 in
 656         let c1 = Int64.of_int c1 in
 657         let c2 = Int64.of_int c2 in
 658         let c3 = Int64.of_int c3 in
 659         let c4 = Int64.of_int c4 in
 660         let c5 = Int64.of_int c5 in
 661         let c6 = Int64.of_int c6 in
 662         let c7 = Int64.of_int c7 in
 663         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
 664       Int64.shift_right_logical word (64 - flen)
 665     ) in
 666   word (*, off+flen, len-flen*)
 667
 668 let extract_int64_le_unsigned data off len flen =
 669   let byteoff = off lsr 3 in
 670
 671   let strlen = String.length data in
 672
 673   let word =
 674     (* Optimize the common (byte-aligned) case. *)
 675     if off land 7 = 0 then (
 676       let word =
 677         let c0 = _get_byte64 data byteoff strlen in
 678         let c1 = _get_byte64 data (byteoff+1) strlen in
 679         let c2 = _get_byte64 data (byteoff+2) strlen in
 680         let c3 = _get_byte64 data (byteoff+3) strlen in
 681         let c4 = _get_byte64 data (byteoff+4) strlen in
 682         let c5 = _get_byte64 data (byteoff+5) strlen in
 683         let c6 = _get_byte64 data (byteoff+6) strlen in
 684         let c7 = _get_byte64 data (byteoff+7) strlen in
 685         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 686       Int64.logand word (I64.mask flen)
 687     ) else (
 688       (* Extract the next 64 bits, slow method. *)
 689       let word =
 690         let c0 = extract_char_unsigned data off len 8
 691         and off = off + 8 and len = len - 8 in
 692         let c1 = extract_char_unsigned data off len 8
 693         and off = off + 8 and len = len - 8 in
 694         let c2 = extract_char_unsigned data off len 8
 695         and off = off + 8 and len = len - 8 in
 696         let c3 = extract_char_unsigned data off len 8
 697         and off = off + 8 and len = len - 8 in
 698         let c4 = extract_char_unsigned data off len 8
 699         and off = off + 8 and len = len - 8 in
 700         let c5 = extract_char_unsigned data off len 8
 701         and off = off + 8 and len = len - 8 in
 702         let c6 = extract_char_unsigned data off len 8
 703         and off = off + 8 and len = len - 8 in
 704         let c7 = extract_char_unsigned data off len 8 in
 705         let c0 = Int64.of_int c0 in
 706         let c1 = Int64.of_int c1 in
 707         let c2 = Int64.of_int c2 in
 708         let c3 = Int64.of_int c3 in
 709         let c4 = Int64.of_int c4 in
 710         let c5 = Int64.of_int c5 in
 711         let c6 = Int64.of_int c6 in
 712         let c7 = Int64.of_int c7 in
 713         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
 714       Int64.logand word (I64.mask flen)
 715     ) in
 716   word (*, off+flen, len-flen*)
 717
 718 let extract_int64_ne_unsigned =
 719   if nativeendian = BigEndian
 720   then extract_int64_be_unsigned
 721   else extract_int64_le_unsigned
 722
 723 let extract_int64_ee_unsigned = function
 724   | BigEndian -> extract_int64_be_unsigned
 725   | LittleEndian -> extract_int64_le_unsigned
 726   | NativeEndian -> extract_int64_ne_unsigned
 727
 728 external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
 729
 730 external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
 731
 732 external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
 733
 734 external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
 735
 736 external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
 737
 738 external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
 739
 740 (*
 741 external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
 742
 743 external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
 744
 745 external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
 746
 747 external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
 748
 749 external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
 750
 751 external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
 752 *)
 753
 754 external extract_fastpath_int32_be_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned"
 755
 756 external extract_fastpath_int32_le_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned"
 757
 758 external extract_fastpath_int32_ne_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned"
 759
 760 external extract_fastpath_int32_be_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed"
 761
 762 external extract_fastpath_int32_le_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed"
 763
 764 external extract_fastpath_int32_ne_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed"
 765
 766 (*
 767 external extract_fastpath_int40_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned"
 768
 769 external extract_fastpath_int40_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned"
 770
 771 external extract_fastpath_int40_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned"
 772
 773 external extract_fastpath_int40_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed"
 774
 775 external extract_fastpath_int40_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed"
 776
 777 external extract_fastpath_int40_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed"
 778
 779 external extract_fastpath_int48_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned"
 780
 781 external extract_fastpath_int48_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned"
 782
 783 external extract_fastpath_int48_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned"
 784
 785 external extract_fastpath_int48_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed"
 786
 787 external extract_fastpath_int48_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed"
 788
 789 external extract_fastpath_int48_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed"
 790
 791 external extract_fastpath_int56_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned"
 792
 793 external extract_fastpath_int56_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned"
 794
 795 external extract_fastpath_int56_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned"
 796
 797 external extract_fastpath_int56_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed"
 798
 799 external extract_fastpath_int56_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed"
 800
 801 external extract_fastpath_int56_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed"
 802 *)
 803
 804 external extract_fastpath_int64_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned"
 805
 806 external extract_fastpath_int64_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned"
 807
 808 external extract_fastpath_int64_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned"
 809
 810 external extract_fastpath_int64_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed"
 811
 812 external extract_fastpath_int64_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed"
 813
 814 external extract_fastpath_int64_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed"
 815
 816 (*----------------------------------------------------------------------*)
 817 (* Constructor functions. *)
 818
 819 module Buffer = struct
 820   type t = {
 821     buf : Buffer.t;
 822     mutable len : int;                  (* Length in bits. *)
 823     (* Last byte in the buffer (if len is not aligned).  We store
 824      * it outside the buffer because buffers aren't mutable.
 825      *)
 826     mutable last : int;
 827   }
 828
 829   let create () =
 830     (* XXX We have almost enough information in the generator to
 831      * choose a good initial size.
 832      *)
 833     { buf = Buffer.create 128; len = 0; last = 0 }
 834
 835   let contents { buf = buf; len = len; last = last } =
 836     let data =
 837       if len land 7 = 0 then
 838         Buffer.contents buf
 839       else
 840         Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
 841     data, 0, len
 842
 843   (* Add exactly 8 bits. *)
 844   let add_byte ({ buf = buf; len = len; last = last } as t) byte =
 845     if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte";
 846     let shift = len land 7 in
 847     if shift = 0 then
 848       (* Target buffer is byte-aligned. *)
 849       Buffer.add_char buf (Char.chr byte)
 850     else (
 851       (* Target buffer is unaligned.  'last' is meaningful. *)
 852       let first = byte lsr shift in
 853       let second = (byte lsl (8 - shift)) land 0xff in
 854       Buffer.add_char buf (Char.chr (last lor first));
 855       t.last <- second
 856     );
 857     t.len <- t.len + 8
 858
 859   (* Add exactly 1 bit. *)
 860   let add_bit ({ buf = buf; len = len; last = last } as t) bit =
 861     let shift = 7 - (len land 7) in
 862     if shift > 0 then
 863       (* Somewhere in the middle of 'last'. *)
 864       t.last <- last lor ((if bit then 1 else 0) lsl shift)
 865     else (
 866       (* Just a single spare bit in 'last'. *)
 867       let last = last lor if bit then 1 else 0 in
 868       Buffer.add_char buf (Char.chr last);
 869       t.last <- 0
 870     );
 871     t.len <- len + 1
 872
 873   (* Add a small number of bits (definitely < 8).  This uses a loop
 874    * to call add_bit so it's slow.
 875    *)
 876   let _add_bits t c slen =
 877     if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits";
 878     for i = slen-1 downto 0 do
 879       let bit = c land (1 lsl i) <> 0 in
 880       add_bit t bit
 881     done
 882
 883   let add_bits ({ buf = buf; len = len } as t) str slen =
 884     if slen > 0 then (
 885       if len land 7 = 0 then (
 886         if slen land 7 = 0 then
 887           (* Common case - everything is byte-aligned. *)
 888           Buffer.add_substring buf str 0 (slen lsr 3)
 889         else (
 890           (* Target buffer is aligned.  Copy whole bytes then leave the
 891            * remaining bits in last.
 892            *)
 893           let slenbytes = slen lsr 3 in
 894           if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes;
 895           let lastidx = min slenbytes (String.length str - 1) in
 896           let last = Char.code str.[lastidx] in (* last char *)
 897           let mask = 0xff lsl (8 - (slen land 7)) in
 898           t.last <- last land mask
 899         );
 900         t.len <- len + slen
 901       ) else (
 902         (* Target buffer is unaligned.  Copy whole bytes using
 903          * add_byte which knows how to deal with an unaligned
 904          * target buffer, then call add_bit for the remaining < 8 bits.
 905          *
 906          * XXX This is going to be dog-slow.
 907          *)
 908         let slenbytes = slen lsr 3 in
 909         for i = 0 to slenbytes-1 do
 910           let byte = Char.code str.[i] in
 911           add_byte t byte
 912         done;
 913         let bitsleft = slen - (slenbytes lsl 3) in
 914         if bitsleft > 0 then (
 915           let c = Char.code str.[slenbytes] in
 916           for i = 0 to bitsleft - 1 do
 917             let bit = c land (0x80 lsr i) <> 0 in
 918             add_bit t bit
 919           done
 920         )
 921       );
 922     )
 923 end
 924
 925 (* Construct a single bit. *)
 926 let construct_bit buf b _ _ =
 927   Buffer.add_bit buf b
 928
 929 (* Construct a field, flen = [2..8]. *)
 930 let construct_char_unsigned buf v flen exn =
 931   let max_val = 1 lsl flen in
 932   if v < 0 || v >= max_val then raise exn;
 933   if flen = 8 then
 934     Buffer.add_byte buf v
 935   else
 936     Buffer._add_bits buf v flen
 937
 938 let construct_char_signed buf v flen exn =
 939   let max_val = 1 lsl flen
 940   and min_val = - (1 lsl pred flen) in
 941     if v < min_val || v >= max_val then
 942         raise exn;
 943     if flen = 8 then
 944       Buffer.add_byte buf (if v >= 0 then v else 256 + v)
 945     else
 946       Buffer._add_bits buf v flen
 947
 948 (* Construct a field of up to 31 bits. *)
 949 let construct_int check_func map_func buf v flen exn =
 950   if not (check_func v flen) then raise exn;
 951   map_func (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 952
 953 let construct_int_be_unsigned =
 954   construct_int I.range_unsigned I.map_bytes_be
 955
 956 let construct_int_be_signed =
 957   construct_int I.range_signed I.map_bytes_be
 958
 959 let construct_int_le_unsigned =
 960   construct_int I.range_unsigned I.map_bytes_le
 961
 962 let construct_int_le_signed =
 963   construct_int I.range_signed I.map_bytes_le
 964
 965 let construct_int_ne_unsigned =
 966   if nativeendian = BigEndian
 967   then construct_int_be_unsigned
 968   else construct_int_le_unsigned
 969
 970 let construct_int_ne_signed =
 971   if nativeendian = BigEndian
 972   then construct_int_be_signed
 973   else construct_int_le_signed
 974
 975 let construct_int_ee_unsigned = function
 976   | BigEndian -> construct_int_be_unsigned
 977   | LittleEndian -> construct_int_le_unsigned
 978   | NativeEndian -> construct_int_ne_unsigned
 979
 980 let construct_int_ee_signed = function
 981   | BigEndian -> construct_int_be_signed
 982   | LittleEndian -> construct_int_le_signed
 983   | NativeEndian -> construct_int_ne_signed
 984
 985 (* Construct a field of exactly 32 bits. *)
 986 let construct_int32_be_unsigned buf v flen _ =
 987   Buffer.add_byte buf
 988     (Int32.to_int (Int32.shift_right_logical v 24));
 989   Buffer.add_byte buf
 990     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 991   Buffer.add_byte buf
 992     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 993   Buffer.add_byte buf
 994     (Int32.to_int (Int32.logand v 0xff_l))
 995
 996 let construct_int32_le_unsigned buf v flen _ =
 997   Buffer.add_byte buf
 998     (Int32.to_int (Int32.logand v 0xff_l));
 999   Buffer.add_byte buf
1000     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
1001   Buffer.add_byte buf
1002     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
1003   Buffer.add_byte buf
1004     (Int32.to_int (Int32.shift_right_logical v 24))
1005
1006 let construct_int32_ne_unsigned =
1007   if nativeendian = BigEndian
1008   then construct_int32_be_unsigned
1009   else construct_int32_le_unsigned
1010
1011 let construct_int32_ee_unsigned = function
1012   | BigEndian -> construct_int32_be_unsigned
1013   | LittleEndian -> construct_int32_le_unsigned
1014   | NativeEndian -> construct_int32_ne_unsigned
1015
1016 (* Construct a field of up to 64 bits. *)
1017 let construct_int64_be_unsigned buf v flen exn =
1018   (* Check value is within range. *)
1019   if not (I64.range_unsigned v flen) then raise exn;
1020   (* Add the bytes. *)
1021   I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
1022
1023 (* Construct a field of up to 64 bits. *)
1024 let construct_int64_le_unsigned buf v flen exn =
1025   (* Check value is within range. *)
1026   if not (I64.range_unsigned v flen) then raise exn;
1027   (* Add the bytes. *)
1028   I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
1029
1030 let construct_int64_ne_unsigned =
1031   if nativeendian = BigEndian
1032   then construct_int64_be_unsigned
1033   else construct_int64_le_unsigned
1034
1035 let construct_int64_ee_unsigned = function
1036   | BigEndian -> construct_int64_be_unsigned
1037   | LittleEndian -> construct_int64_le_unsigned
1038   | NativeEndian -> construct_int64_ne_unsigned
1039
1040 (* Construct from a string of bytes, exact multiple of 8 bits
1041  * in length of course.
1042  *)
1043 let construct_string buf str =
1044   let len = String.length str in
1045   Buffer.add_bits buf str (len lsl 3)
1046
1047 (* Construct from a bitstring. *)
1048 let construct_bitstring buf (data, off, len) =
1049   (* Add individual bits until we get to the next byte boundary of
1050    * the underlying string.
1051    *)
1052   let blen = 7 - ((off + 7) land 7) in
1053   let blen = min blen len in
1054   let rec loop off len blen =
1055     if blen = 0 then (off, len)
1056     else (
1057       let b = extract_bit data off len 1
1058       and off = off + 1 and len = len - 1 in
1059       Buffer.add_bit buf b;
1060       loop off len (blen-1)
1061     )
1062   in
1063   let off, len = loop off len blen in
1064   assert (len = 0 || (off land 7) = 0);
1065
1066   (* Add the remaining 'len' bits. *)
1067   let data =
1068     let off = off lsr 3 in
1069     (* XXX dangerous allocation *)
1070     if off = 0 then data
1071     else String.sub data off (String.length data - off) in
1072
1073   Buffer.add_bits buf data len
1074
1075 (* Concatenate bitstrings. *)
1076 let concat bs =
1077   let buf = Buffer.create () in
1078   List.iter (construct_bitstring buf) bs;
1079   Buffer.contents buf
1080
1081 (*----------------------------------------------------------------------*)
1082 (* Extract a string from a bitstring. *)
1083 let string_of_bitstring (data, off, len) =
1084   if off land 7 = 0 && len land 7 = 0 then
1085     (* Easy case: everything is byte-aligned. *)
1086     String.sub data (off lsr 3) (len lsr 3)
1087   else (
1088     (* Bit-twiddling case. *)
1089     let strlen = (len + 7) lsr 3 in
1090     let str = String.make strlen '\000' in
1091     let rec loop data off len i =
1092       if len >= 8 then (
1093         let c = extract_char_unsigned data off len 8
1094         and off = off + 8 and len = len - 8 in
1095         str.[i] <- Char.chr c;
1096         loop data off len (i+1)
1097       ) else if len > 0 then (
1098         let c = extract_char_unsigned data off len len in
1099         str.[i] <- Char.chr (c lsl (8-len))
1100       )
1101     in
1102     loop data off len 0;
1103     str
1104   )
1105
1106 (* To channel. *)
1107
1108 let bitstring_to_chan ((data, off, len) as bits) chan =
1109   (* Fail if the bitstring length isn't a multiple of 8. *)
1110   if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
1111
1112   if off land 7 = 0 then
1113     (* Easy case: string is byte-aligned. *)
1114     output chan data (off lsr 3) (len lsr 3)
1115   else (
1116     (* Bit-twiddling case: reuse string_of_bitstring *)
1117     let str = string_of_bitstring bits in
1118     output_string chan str
1119   )
1120
1121 let bitstring_to_file bits filename =
1122   let chan = open_out_bin filename in
1123   try
1124     bitstring_to_chan bits chan;
1125     close_out chan
1126   with exn ->
1127     close_out chan;
1128     raise exn
1129
1130 (*----------------------------------------------------------------------*)
1131 (* Comparison. *)
1132 let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
1133   (* In the fully-aligned case, this is reduced to string comparison ... *)
1134   if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
1135   then (
1136     (* ... but we have to do that by hand because the bits may
1137      * not extend to the full length of the underlying string.
1138      *)
1139     let off1 = off1 lsr 3 and off2 = off2 lsr 3
1140     and len1 = len1 lsr 3 and len2 = len2 lsr 3 in
1141     let rec loop i =
1142       if i < len1 && i < len2 then (
1143         let c1 = String.unsafe_get data1 (off1 + i)
1144         and c2 = String.unsafe_get data2 (off2 + i) in
1145         let r = compare c1 c2 in
1146         if r <> 0 then r
1147         else loop (i+1)
1148       )
1149       else len1 - len2
1150     in
1151     loop 0
1152   )
1153   else (
1154     (* Slow/unaligned. *)
1155     let str1 = string_of_bitstring bs1
1156     and str2 = string_of_bitstring bs2 in
1157     let r = String.compare str1 str2 in
1158     if r <> 0 then r else len1 - len2
1159   )
1160
1161 let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
1162   if len1 <> len2 then false
1163   else if bs1 = bs2 then true
1164   else 0 = compare bs1 bs2
1165
1166 let is_zeroes_bitstring ((data, off, len) as bits) =
1167   if off land 7 = 0 && len land 7 = 0 then (
1168     let off = off lsr 3 and len = len lsr 3 in
1169     let rec loop i =
1170       if i < len then (
1171         if String.unsafe_get data (off + i) <> '\000' then false
1172         else loop (i+1)
1173       ) else true
1174     in
1175     loop 0
1176   )
1177   else (
1178     (* Slow/unaligned case. *)
1179     let len = bitstring_length bits in
1180     let zeroes = zeroes_bitstring len in
1181     0 = compare bits zeroes
1182   )
1183
1184 let is_ones_bitstring ((data, off, len) as bits) =
1185   if off land 7 = 0 && len land 7 = 0 then (
1186     let off = off lsr 3 and len = len lsr 3 in
1187     let rec loop i =
1188       if i < len then (
1189         if String.unsafe_get data (off + i) <> '\xff' then false
1190         else loop (i+1)
1191       ) else true
1192     in
1193     loop 0
1194   )
1195   else (
1196     (* Slow/unaligned case. *)
1197     let len = bitstring_length bits in
1198     let ones = ones_bitstring len in
1199     0 = compare bits ones
1200   )
1201
1202 (*----------------------------------------------------------------------*)
1203 (* Bit get/set functions. *)
1204
1205 let index_out_of_bounds () = invalid_arg "index out of bounds"
1206
1207 let put (data, off, len) n v =
1208   if n < 0 || n >= len then index_out_of_bounds ()
1209   else (
1210     let i = off+n in
1211     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1212     let c = Char.code data.[si] in
1213     let c = if v <> 0 then c lor mask else c land (lnot mask) in
1214     data.[si] <- Char.unsafe_chr c
1215   )
1216
1217 let set bits n = put bits n 1
1218
1219 let clear bits n = put bits n 0
1220
1221 let get (data, off, len) n =
1222   if n < 0 || n >= len then index_out_of_bounds ()
1223   else (
1224     let i = off+n in
1225     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1226     let c = Char.code data.[si] in
1227     c land mask
1228   )
1229
1230 let is_set bits n = get bits n <> 0
1231
1232 let is_clear bits n = get bits n = 0
1233
1234 (*----------------------------------------------------------------------*)
1235 (* Display functions. *)
1236
1237 let isprint c =
1238   let c = Char.code c in
1239   c >= 32 && c < 127
1240
1241 let hexdump_bitstring chan (data, off, len) =
1242   let count = ref 0 in
1243   let off = ref off in
1244   let len = ref len in
1245   let linelen = ref 0 in
1246   let linechars = String.make 16 ' ' in
1247
1248   fprintf chan "00000000  ";
1249
1250   while !len > 0 do
1251     let bits = min !len 8 in
1252     let byte = extract_char_unsigned data !off !len bits in
1253     off := !off + bits; len := !len - bits;
1254
1255     let byte = byte lsl (8-bits) in
1256     fprintf chan "%02x " byte;
1257
1258     incr count;
1259     linechars.[!linelen] <-
1260       (let c = Char.chr byte in
1261        if isprint c then c else '.');
1262     incr linelen;
1263     if !linelen = 8 then fprintf chan " ";
1264     if !linelen = 16 then (
1265       fprintf chan " |%s|\n%08x  " linechars !count;
1266       linelen := 0;
1267       for i = 0 to 15 do linechars.[i] <- ' ' done
1268     )
1269   done;
1270
1271   if !linelen > 0 then (
1272     let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1273     for i = 0 to skip-1 do fprintf chan " " done;
1274     fprintf chan " |%s|\n%!" linechars
1275   ) else
1276     fprintf chan "\n%!"
1277
1278 (*----------------------------------------------------------------------*)
1279 (* Alias of functions shadowed by Core. *)
1280
1281 let char_code = Char.code
1282 let int32_of_int = Int32.of_int