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 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 lastidx = min slenbytes (String.length str - 1) in
 857           let last = Char.code str.[lastidx] in (* last char *)
 858           let mask = 0xff lsl (8 - (slen land 7)) in
 859           t.last <- last land mask
 860         );
 861         t.len <- len + slen
 862       ) else (
 863         (* Target buffer is unaligned.  Copy whole bytes using
 864          * add_byte which knows how to deal with an unaligned
 865          * target buffer, then call add_bit for the remaining < 8 bits.
 866          *
 867          * XXX This is going to be dog-slow.
 868          *)
 869         let slenbytes = slen lsr 3 in
 870         for i = 0 to slenbytes-1 do
 871           let byte = Char.code str.[i] in
 872           add_byte t byte
 873         done;
 874         let bitsleft = slen - (slenbytes lsl 3) in
 875         if bitsleft > 0 then (
 876           let c = Char.code str.[slenbytes] in
 877           for i = 0 to bitsleft - 1 do
 878             let bit = c land (0x80 lsr i) <> 0 in
 879             add_bit t bit
 880           done
 881         )
 882       );
 883     )
 884 end
 885
 886 (* Construct a single bit. *)
 887 let construct_bit buf b _ _ =
 888   Buffer.add_bit buf b
 889
 890 (* Construct a field, flen = [2..8]. *)
 891 let construct_char_unsigned buf v flen exn =
 892   let max_val = 1 lsl flen in
 893   if v < 0 || v >= max_val then raise exn;
 894   if flen = 8 then
 895     Buffer.add_byte buf v
 896   else
 897     Buffer._add_bits buf v flen
 898
 899 (* Construct a field of up to 31 bits. *)
 900 let construct_int_be_unsigned buf v flen exn =
 901   (* Check value is within range. *)
 902   if not (I.range_unsigned v flen) then raise exn;
 903   (* Add the bytes. *)
 904   I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 905
 906 (* Construct a field of up to 31 bits. *)
 907 let construct_int_le_unsigned buf v flen exn =
 908   (* Check value is within range. *)
 909   if not (I.range_unsigned v flen) then raise exn;
 910   (* Add the bytes. *)
 911   I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 912
 913 let construct_int_ne_unsigned =
 914   if nativeendian = BigEndian
 915   then construct_int_be_unsigned
 916   else construct_int_le_unsigned
 917
 918 let construct_int_ee_unsigned = function
 919   | BigEndian -> construct_int_be_unsigned
 920   | LittleEndian -> construct_int_le_unsigned
 921   | NativeEndian -> construct_int_ne_unsigned
 922
 923 (* Construct a field of exactly 32 bits. *)
 924 let construct_int32_be_unsigned buf v flen _ =
 925   Buffer.add_byte buf
 926     (Int32.to_int (Int32.shift_right_logical v 24));
 927   Buffer.add_byte buf
 928     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 929   Buffer.add_byte buf
 930     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 931   Buffer.add_byte buf
 932     (Int32.to_int (Int32.logand v 0xff_l))
 933
 934 let construct_int32_le_unsigned buf v flen _ =
 935   Buffer.add_byte buf
 936     (Int32.to_int (Int32.logand v 0xff_l));
 937   Buffer.add_byte buf
 938     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
 939   Buffer.add_byte buf
 940     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
 941   Buffer.add_byte buf
 942     (Int32.to_int (Int32.shift_right_logical v 24))
 943
 944 let construct_int32_ne_unsigned =
 945   if nativeendian = BigEndian
 946   then construct_int32_be_unsigned
 947   else construct_int32_le_unsigned
 948
 949 let construct_int32_ee_unsigned = function
 950   | BigEndian -> construct_int32_be_unsigned
 951   | LittleEndian -> construct_int32_le_unsigned
 952   | NativeEndian -> construct_int32_ne_unsigned
 953
 954 (* Construct a field of up to 64 bits. *)
 955 let construct_int64_be_unsigned buf v flen exn =
 956   (* Check value is within range. *)
 957   if not (I64.range_unsigned v flen) then raise exn;
 958   (* Add the bytes. *)
 959   I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 960
 961 (* Construct a field of up to 64 bits. *)
 962 let construct_int64_le_unsigned buf v flen exn =
 963   (* Check value is within range. *)
 964   if not (I64.range_unsigned v flen) then raise exn;
 965   (* Add the bytes. *)
 966   I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
 967
 968 let construct_int64_ne_unsigned =
 969   if nativeendian = BigEndian
 970   then construct_int64_be_unsigned
 971   else construct_int64_le_unsigned
 972
 973 let construct_int64_ee_unsigned = function
 974   | BigEndian -> construct_int64_be_unsigned
 975   | LittleEndian -> construct_int64_le_unsigned
 976   | NativeEndian -> construct_int64_ne_unsigned
 977
 978 (* Construct from a string of bytes, exact multiple of 8 bits
 979  * in length of course.
 980  *)
 981 let construct_string buf str =
 982   let len = String.length str in
 983   Buffer.add_bits buf str (len lsl 3)
 984
 985 (* Construct from a bitstring. *)
 986 let construct_bitstring buf (data, off, len) =
 987   (* Add individual bits until we get to the next byte boundary of
 988    * the underlying string.
 989    *)
 990   let blen = 7 - ((off + 7) land 7) in
 991   let blen = min blen len in
 992   let rec loop off len blen =
 993     if blen = 0 then (off, len)
 994     else (
 995       let b = extract_bit data off len 1
 996       and off = off + 1 and len = len - 1 in
 997       Buffer.add_bit buf b;
 998       loop off len (blen-1)
 999     )
1000   in
1001   let off, len = loop off len blen in
1002   assert (len = 0 || (off land 7) = 0);
1003
1004   (* Add the remaining 'len' bits. *)
1005   let data =
1006     let off = off lsr 3 in
1007     (* XXX dangerous allocation *)
1008     if off = 0 then data
1009     else String.sub data off (String.length data - off) in
1010
1011   Buffer.add_bits buf data len
1012
1013 (* Concatenate bitstrings. *)
1014 let concat bs =
1015   let buf = Buffer.create () in
1016   List.iter (construct_bitstring buf) bs;
1017   Buffer.contents buf
1018
1019 (*----------------------------------------------------------------------*)
1020 (* Extract a string from a bitstring. *)
1021 let string_of_bitstring (data, off, len) =
1022   if off land 7 = 0 && len land 7 = 0 then
1023     (* Easy case: everything is byte-aligned. *)
1024     String.sub data (off lsr 3) (len lsr 3)
1025   else (
1026     (* Bit-twiddling case. *)
1027     let strlen = (len + 7) lsr 3 in
1028     let str = String.make strlen '\000' in
1029     let rec loop data off len i =
1030       if len >= 8 then (
1031         let c = extract_char_unsigned data off len 8
1032         and off = off + 8 and len = len - 8 in
1033         str.[i] <- Char.chr c;
1034         loop data off len (i+1)
1035       ) else if len > 0 then (
1036         let c = extract_char_unsigned data off len len in
1037         str.[i] <- Char.chr (c lsl (8-len))
1038       )
1039     in
1040     loop data off len 0;
1041     str
1042   )
1043
1044 (* To channel. *)
1045
1046 let bitstring_to_chan ((data, off, len) as bits) chan =
1047   (* Fail if the bitstring length isn't a multiple of 8. *)
1048   if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
1049
1050   if off land 7 = 0 then
1051     (* Easy case: string is byte-aligned. *)
1052     output chan data (off lsr 3) (len lsr 3)
1053   else (
1054     (* Bit-twiddling case: reuse string_of_bitstring *)
1055     let str = string_of_bitstring bits in
1056     output_string chan str
1057   )
1058
1059 let bitstring_to_file bits filename =
1060   let chan = open_out_bin filename in
1061   try
1062     bitstring_to_chan bits chan;
1063     close_out chan
1064   with exn ->
1065     close_out chan;
1066     raise exn
1067
1068 (*----------------------------------------------------------------------*)
1069 (* Comparison. *)
1070 let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
1071   (* In the fully-aligned case, this is reduced to string comparison ... *)
1072   if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
1073   then (
1074     (* ... but we have to do that by hand because the bits may
1075      * not extend to the full length of the underlying string.
1076      *)
1077     let off1 = off1 lsr 3 and off2 = off2 lsr 3
1078     and len1 = len1 lsr 3 and len2 = len2 lsr 3 in
1079     let rec loop i =
1080       if i < len1 && i < len2 then (
1081         let c1 = String.unsafe_get data1 (off1 + i)
1082         and c2 = String.unsafe_get data2 (off2 + i) in
1083         let r = compare c1 c2 in
1084         if r <> 0 then r
1085         else loop (i+1)
1086       )
1087       else len1 - len2
1088     in
1089     loop 0
1090   )
1091   else (
1092     (* Slow/unaligned. *)
1093     let str1 = string_of_bitstring bs1
1094     and str2 = string_of_bitstring bs2 in
1095     let r = String.compare str1 str2 in
1096     if r <> 0 then r else len1 - len2
1097   )
1098
1099 let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
1100   if len1 <> len2 then false
1101   else if bs1 = bs2 then true
1102   else 0 = compare bs1 bs2
1103
1104 let is_zeroes_bitstring ((data, off, len) as bits) =
1105   if off land 7 = 0 && len land 7 = 0 then (
1106     let off = off lsr 3 and len = len lsr 3 in
1107     let rec loop i =
1108       if i < len then (
1109         if String.unsafe_get data (off + i) <> '\000' then false
1110         else loop (i+1)
1111       ) else true
1112     in
1113     loop 0
1114   )
1115   else (
1116     (* Slow/unaligned case. *)
1117     let len = bitstring_length bits in
1118     let zeroes = zeroes_bitstring len in
1119     0 = compare bits zeroes
1120   )
1121
1122 let is_ones_bitstring ((data, off, len) as bits) =
1123   if off land 7 = 0 && len land 7 = 0 then (
1124     let off = off lsr 3 and len = len lsr 3 in
1125     let rec loop i =
1126       if i < len then (
1127         if String.unsafe_get data (off + i) <> '\xff' then false
1128         else loop (i+1)
1129       ) else true
1130     in
1131     loop 0
1132   )
1133   else (
1134     (* Slow/unaligned case. *)
1135     let len = bitstring_length bits in
1136     let ones = ones_bitstring len in
1137     0 = compare bits ones
1138   )
1139
1140 (*----------------------------------------------------------------------*)
1141 (* Bit get/set functions. *)
1142
1143 let index_out_of_bounds () = invalid_arg "index out of bounds"
1144
1145 let put (data, off, len) n v =
1146   if n < 0 || n >= len then index_out_of_bounds ()
1147   else (
1148     let i = off+n in
1149     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1150     let c = Char.code data.[si] in
1151     let c = if v <> 0 then c lor mask else c land (lnot mask) in
1152     data.[si] <- Char.unsafe_chr c
1153   )
1154
1155 let set bits n = put bits n 1
1156
1157 let clear bits n = put bits n 0
1158
1159 let get (data, off, len) n =
1160   if n < 0 || n >= len then index_out_of_bounds ()
1161   else (
1162     let i = off+n in
1163     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1164     let c = Char.code data.[si] in
1165     c land mask
1166   )
1167
1168 let is_set bits n = get bits n <> 0
1169
1170 let is_clear bits n = get bits n = 0
1171
1172 (*----------------------------------------------------------------------*)
1173 (* Display functions. *)
1174
1175 let isprint c =
1176   let c = Char.code c in
1177   c >= 32 && c < 127
1178
1179 let hexdump_bitstring chan (data, off, len) =
1180   let count = ref 0 in
1181   let off = ref off in
1182   let len = ref len in
1183   let linelen = ref 0 in
1184   let linechars = String.make 16 ' ' in
1185
1186   fprintf chan "00000000  ";
1187
1188   while !len > 0 do
1189     let bits = min !len 8 in
1190     let byte = extract_char_unsigned data !off !len bits in
1191     off := !off + bits; len := !len - bits;
1192
1193     let byte = byte lsl (8-bits) in
1194     fprintf chan "%02x " byte;
1195
1196     incr count;
1197     linechars.[!linelen] <-
1198       (let c = Char.chr byte in
1199        if isprint c then c else '.');
1200     incr linelen;
1201     if !linelen = 8 then fprintf chan " ";
1202     if !linelen = 16 then (
1203       fprintf chan " |%s|\n%08x  " linechars !count;
1204       linelen := 0;
1205       for i = 0 to 15 do linechars.[i] <- ' ' done
1206     )
1207   done;
1208
1209   if !linelen > 0 then (
1210     let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1211     for i = 0 to skip-1 do fprintf chan " " done;
1212     fprintf chan " |%s|\n%!" linechars
1213   ) else
1214     fprintf chan "\n%!"
1215
1216 (*----------------------------------------------------------------------*)
1217 (* Alias of functions shadowed by Core. *)
1218
1219 let char_code = Char.code
1220 let int32_of_int = Int32.of_int