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