2 * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
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.
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.
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
24 (* Enable runtime debug messages. Must also have been enabled
29 let package = "ocaml-bitstring"
31 type endian
= BigEndian
| LittleEndian
| NativeEndian
33 let string_of_endian = function
34 | BigEndian
-> "bigendian"
35 | LittleEndian
-> "littleendian"
36 | NativeEndian
-> "nativeendian"
38 let nativeendian = @NATIVEENDIAN
@
41 exception Construct_failure
of string * string * int * int
43 (* A bitstring is simply the data itself (as a string), and the
44 * bitoffset and the bitlength within the string. Note offset/length
45 * are counted in bits, not bytes.
47 type bitstring
= string * int * int
51 (* Functions to create and load bitstrings. *)
52 let empty_bitstring = "", 0, 0
54 let make_bitstring len c
=
55 if len
>= 0 then String.make
((len
+7) lsr 3) c
, 0, len
58 sprintf
"make_bitstring/create_bitstring: len %d < 0" len
61 let create_bitstring len
= make_bitstring len '
\000'
63 let zeroes_bitstring = create_bitstring
65 let ones_bitstring len
= make_bitstring len '
\xff'
67 let bitstring_of_string str
= str
, 0, String.length str
lsl 3
69 let bitstring_of_chan chan
=
70 let tmpsize = 16384 in
71 let buf = Buffer.create
tmpsize in
72 let tmp = String.create
tmpsize in
74 while n := input chan
tmp 0 tmpsize; !n > 0 do
75 Buffer.add_substring
buf tmp 0 !n;
77 Buffer.contents
buf, 0, Buffer.length
buf lsl 3
79 let bitstring_of_chan_max chan max
=
80 let tmpsize = 16384 in
81 let buf = Buffer.create
tmpsize in
82 let tmp = String.create
tmpsize in
86 let r = min
tmpsize (max
- !len) in
87 let n = input chan
tmp 0 r in
89 Buffer.add_substring
buf tmp 0 n;
96 Buffer.contents
buf, 0, !len lsl 3
98 let bitstring_of_file_descr fd
=
99 let tmpsize = 16384 in
100 let buf = Buffer.create
tmpsize in
101 let tmp = String.create
tmpsize in
103 while n := Unix.read fd
tmp 0 tmpsize; !n > 0 do
104 Buffer.add_substring
buf tmp 0 !n;
106 Buffer.contents
buf, 0, Buffer.length
buf lsl 3
108 let bitstring_of_file_descr_max fd max
=
109 let tmpsize = 16384 in
110 let buf = Buffer.create
tmpsize in
111 let tmp = String.create
tmpsize in
115 let r = min
tmpsize (max
- !len) in
116 let n = Unix.read fd
tmp 0 r in
118 Buffer.add_substring
buf tmp 0 n;
125 Buffer.contents
buf, 0, !len lsl 3
127 let bitstring_of_file fname
=
128 let chan = open_in_bin fname
in
130 let bs = bitstring_of_chan chan in
137 let bitstring_length (_
, _
, len) = len
139 let subbitstring (data
, off
, len) off'
len'
=
140 let off = off + off'
in
141 if len < off'
+ len'
then invalid_arg
"subbitstring";
144 let dropbits n (data
, off, len) =
147 if len < 0 then invalid_arg
"dropbits";
150 let takebits n (data
, off, len) =
151 if len < n then invalid_arg
"takebits";
154 (*----------------------------------------------------------------------*)
155 (* Bitwise functions.
157 * We try to isolate all bitwise functions within these modules.
161 (* Bitwise operations on ints. Note that we assume int <= 31 bits. *)
162 external (<<<) : int -> int -> int = "%lslint"
163 external (>>>) : int -> int -> int = "%lsrint"
164 external to_int
: int -> int = "%identity"
170 (* Create a mask 0-31 bits wide. *)
174 else if bits
= 30 then
176 else if bits
= 31 then
179 invalid_arg
"Bitstring.I.mask"
181 (* Byte swap an int of a given size. *)
182 let byteswap v bits
=
184 else if bits
<= 16 then (
185 let shift = bits
-8 in
186 let v1 = v
>>> shift in
187 let v2 = ((v
land (mask shift)) <<< 8) in
189 ) else if bits
<= 24 then (
190 let shift = bits
- 16 in
191 let v1 = v
>>> (8+shift) in
192 let v2 = ((v
>>> shift) land ff) <<< 8 in
193 let v3 = (v
land (mask shift)) <<< 16 in
196 let shift = bits
- 24 in
197 let v1 = v
>>> (16+shift) in
198 let v2 = ((v
>>> (8+shift)) land ff) <<< 8 in
199 let v3 = ((v
>>> shift) land ff) <<< 16 in
200 let v4 = (v
land (mask shift)) <<< 24 in
201 v4 lor v3 lor v2 lor v1
204 (* Check a value is in range 0 .. 2^bits-1. *)
205 let range_unsigned v bits
=
206 let mask = lnot
(mask bits
) in
209 (* Call function g on the top bits, then f on each full byte
210 * (big endian - so start at top).
212 let rec map_bytes_be g f v bits
=
214 map_bytes_be g f
(v
>>> 8) (bits
-8);
215 let lsb = v
land ff in
217 ) else if bits
> 0 then (
218 let lsb = v
land (mask bits
) in
222 (* Call function g on the top bits, then f on each full byte
223 * (little endian - so start at root).
225 let rec map_bytes_le g f v bits
=
227 let lsb = v
land ff in
229 map_bytes_le g f
(v
>>> 8) (bits
-8)
230 ) else if bits
> 0 then (
231 let lsb = v
land (mask bits
) in
237 (* Bitwise operations on int32s. Note we try to keep it as similar
238 * as possible to the I module above, to make it easier to track
241 let (<<<) = Int32.shift_left
242 let (>>>) = Int32.shift_right_logical
243 let (land) = Int32.logand
244 let (lor) = Int32.logor
245 let lnot = Int32.lognot
246 let pred = Int32.pred
247 let max_int = Int32.max_int
248 let to_int = Int32.to_int
249 let zero = Int32.zero
251 let minus_one = Int32.minus_one
254 (* Create a mask so many bits wide. *)
258 else if bits
= 31 then
260 else if bits
= 32 then
263 invalid_arg
"Bitstring.I32.mask"
265 (* Byte swap an int of a given size. *)
266 let byteswap v bits
=
268 else if bits
<= 16 then (
269 let shift = bits
-8 in
270 let v1 = v
>>> shift in
271 let v2 = (v
land (mask shift)) <<< 8 in
273 ) else if bits
<= 24 then (
274 let shift = bits
- 16 in
275 let v1 = v
>>> (8+shift) in
276 let v2 = ((v
>>> shift) land ff) <<< 8 in
277 let v3 = (v
land (mask shift)) <<< 16 in
280 let shift = bits
- 24 in
281 let v1 = v
>>> (16+shift) in
282 let v2 = ((v
>>> (8+shift)) land ff) <<< 8 in
283 let v3 = ((v
>>> shift) land ff) <<< 16 in
284 let v4 = (v
land (mask shift)) <<< 24 in
285 v4 lor v3 lor v2 lor v1
288 (* Check a value is in range 0 .. 2^bits-1. *)
289 let range_unsigned v bits
=
290 let mask = lnot (mask bits
) in
293 (* Call function g on the top bits, then f on each full byte
294 * (big endian - so start at top).
296 let rec map_bytes_be g f v bits
=
298 map_bytes_be g f
(v
>>> 8) (bits
-8);
299 let lsb = v
land ff in
301 ) else if bits
> 0 then (
302 let lsb = v
land (mask bits
) in
306 (* Call function g on the top bits, then f on each full byte
307 * (little endian - so start at root).
309 let rec map_bytes_le g f v bits
=
311 let lsb = v
land ff in
313 map_bytes_le g f
(v
>>> 8) (bits
-8)
314 ) else if bits
> 0 then (
315 let lsb = v
land (mask bits
) in
321 (* Bitwise operations on int64s. Note we try to keep it as similar
322 * as possible to the I/I32 modules above, to make it easier to track
325 let (<<<) = Int64.shift_left
326 let (>>>) = Int64.shift_right_logical
327 let (land) = Int64.logand
328 let (lor) = Int64.logor
329 let lnot = Int64.lognot
330 let pred = Int64.pred
331 let max_int = Int64.max_int
332 let to_int = Int64.to_int
333 let zero = Int64.zero
335 let minus_one = Int64.minus_one
338 (* Create a mask so many bits wide. *)
342 else if bits
= 63 then
344 else if bits
= 64 then
347 invalid_arg
"Bitstring.I64.mask"
349 (* Byte swap an int of a given size. *)
350 (* let byteswap v bits = *)
352 (* Check a value is in range 0 .. 2^bits-1. *)
353 let range_unsigned v bits
=
354 let mask = lnot (mask bits
) in
357 (* Call function g on the top bits, then f on each full byte
358 * (big endian - so start at top).
360 let rec map_bytes_be g f v bits
=
362 map_bytes_be g f
(v
>>> 8) (bits
-8);
363 let lsb = v
land ff in
365 ) else if bits
> 0 then (
366 let lsb = v
land (mask bits
) in
370 (* Call function g on the top bits, then f on each full byte
371 * (little endian - so start at root).
373 let rec map_bytes_le g f v bits
=
375 let lsb = v
land ff in
377 map_bytes_le g f
(v
>>> 8) (bits
-8)
378 ) else if bits
> 0 then (
379 let lsb = v
land (mask bits
) in
384 (*----------------------------------------------------------------------*)
385 (* Extraction functions.
387 * NB: internal functions, called from the generated macros, and
388 * the parameters should have been checked for sanity already).
391 (* Extract and convert to numeric. A single bit is returned as
392 * a boolean. There are no endianness or signedness considerations.
394 let extract_bit data
off len _
= (* final param is always 1 *)
395 let byteoff = off lsr 3 in
396 let bitmask = 1 lsl (7 - (off land 7)) in
397 let b = Char.code data
.[byteoff] land bitmask <> 0 in
400 (* Returns 8 bit unsigned aligned bytes from the string.
401 * If the string ends then this returns 0's.
403 let _get_byte data
byteoff strlen
=
404 if strlen
> byteoff then Char.code data
.[byteoff] else 0
405 let _get_byte32 data
byteoff strlen
=
406 if strlen
> byteoff then Int32.of_int
(Char.code data
.[byteoff]) else 0l
407 let _get_byte64 data
byteoff strlen
=
408 if strlen
> byteoff then Int64.of_int
(Char.code data
.[byteoff]) else 0L
410 (* Extract [2..8] bits. Because the result fits into a single
411 * byte we don't have to worry about endianness, only signedness.
413 let extract_char_unsigned data
off len flen
=
414 let byteoff = off lsr 3 in
416 (* Optimize the common (byte-aligned) case. *)
417 if off land 7 = 0 then (
418 let byte = Char.code data
.[byteoff] in
419 byte lsr (8 - flen
) (*, off+flen, len-flen*)
421 (* Extract the 16 bits at byteoff and byteoff+1 (note that the
422 * second byte might not exist in the original string).
424 let strlen = String.length data
in
427 (_get_byte data
byteoff strlen lsl 8) +
428 _get_byte data
(byteoff+1) strlen in
430 (* Mask off the top bits. *)
431 let bitmask = (1 lsl (16 - (off land 7))) - 1 in
432 let word = word land bitmask in
433 (* Shift right to get rid of the bottom bits. *)
434 let shift = 16 - ((off land 7) + flen
) in
435 let word = word lsr shift in
437 word (*, off+flen, len-flen*)
440 (* Extract [9..31] bits. We have to consider endianness and signedness. *)
441 let extract_int_be_unsigned data
off len flen
=
442 let byteoff = off lsr 3 in
444 let strlen = String.length data
in
447 (* Optimize the common (byte-aligned) case. *)
448 if off land 7 = 0 then (
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
455 ) else if flen
<= 24 then (
456 (* Extract the 31 bits at byteoff .. byteoff+3. *)
458 (_get_byte data
byteoff strlen lsl 23) +
459 (_get_byte data
(byteoff+1) strlen lsl 15) +
460 (_get_byte data
(byteoff+2) strlen lsl 7) +
461 (_get_byte data
(byteoff+3) strlen lsr 1) in
462 (* Mask off the top bits. *)
463 let bitmask = (1 lsl (31 - (off land 7))) - 1 in
464 let word = word land bitmask in
465 (* Shift right to get rid of the bottom bits. *)
466 let shift = 31 - ((off land 7) + flen
) in
469 (* Extract the next 31 bits, slow method. *)
471 let c0 = extract_char_unsigned data
off len 8
472 and off = off + 8 and len = len - 8 in
473 let c1 = extract_char_unsigned data
off len 8
474 and off = off + 8 and len = len - 8 in
475 let c2 = extract_char_unsigned data
off len 8
476 and off = off + 8 and len = len - 8 in
477 let c3 = extract_char_unsigned data
off len 7 in
478 (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
481 word (*, off+flen, len-flen*)
483 let extract_int_le_unsigned data
off len flen
=
484 let v = extract_int_be_unsigned data
off len flen
in
485 let v = I.byteswap v flen
in
488 let extract_int_ne_unsigned =
489 if nativeendian = BigEndian
490 then extract_int_be_unsigned
491 else extract_int_le_unsigned
493 let extract_int_ee_unsigned = function
494 | BigEndian
-> extract_int_be_unsigned
495 | LittleEndian
-> extract_int_le_unsigned
496 | NativeEndian
-> extract_int_ne_unsigned
498 let _make_int32_be c0 c1 c2 c3 =
502 (Int32.shift_left
c0 24)
503 (Int32.shift_left
c1 16))
504 (Int32.shift_left
c2 8))
507 let _make_int32_le c0 c1 c2 c3 =
511 (Int32.shift_left
c3 24)
512 (Int32.shift_left
c2 16))
513 (Int32.shift_left
c1 8))
516 (* Extract exactly 32 bits. We have to consider endianness and signedness. *)
517 let extract_int32_be_unsigned data
off len flen
=
518 let byteoff = off lsr 3 in
520 let strlen = String.length data
in
523 (* Optimize the common (byte-aligned) case. *)
524 if off land 7 = 0 then (
526 let c0 = _get_byte32 data
byteoff strlen in
527 let c1 = _get_byte32 data
(byteoff+1) strlen in
528 let c2 = _get_byte32 data
(byteoff+2) strlen in
529 let c3 = _get_byte32 data
(byteoff+3) strlen in
530 _make_int32_be c0 c1 c2 c3 in
531 Int32.shift_right_logical
word (32 - flen
)
533 (* Extract the next 32 bits, slow method. *)
535 let c0 = extract_char_unsigned data
off len 8
536 and off = off + 8 and len = len - 8 in
537 let c1 = extract_char_unsigned data
off len 8
538 and off = off + 8 and len = len - 8 in
539 let c2 = extract_char_unsigned data
off len 8
540 and off = off + 8 and len = len - 8 in
541 let c3 = extract_char_unsigned data
off len 8 in
542 let c0 = Int32.of_int
c0 in
543 let c1 = Int32.of_int
c1 in
544 let c2 = Int32.of_int
c2 in
545 let c3 = Int32.of_int
c3 in
546 _make_int32_be c0 c1 c2 c3 in
547 Int32.shift_right_logical
word (32 - flen
)
549 word (*, off+flen, len-flen*)
551 let extract_int32_le_unsigned data
off len flen
=
552 let v = extract_int32_be_unsigned data
off len flen
in
553 let v = I32.byteswap v flen
in
556 let extract_int32_ne_unsigned =
557 if nativeendian = BigEndian
558 then extract_int32_be_unsigned
559 else extract_int32_le_unsigned
561 let extract_int32_ee_unsigned = function
562 | BigEndian
-> extract_int32_be_unsigned
563 | LittleEndian
-> extract_int32_le_unsigned
564 | NativeEndian
-> extract_int32_ne_unsigned
566 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7
=
574 (Int64.shift_left
c0 56)
575 (Int64.shift_left
c1 48))
576 (Int64.shift_left
c2 40))
577 (Int64.shift_left
c3 32))
578 (Int64.shift_left c4
24))
579 (Int64.shift_left c5
16))
580 (Int64.shift_left c6
8))
583 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7
=
584 _make_int64_be c7 c6 c5 c4
c3 c2 c1 c0
586 (* Extract [1..64] bits. We have to consider endianness and signedness. *)
587 let extract_int64_be_unsigned data
off len flen
=
588 let byteoff = off lsr 3 in
590 let strlen = String.length data
in
593 (* Optimize the common (byte-aligned) case. *)
594 if off land 7 = 0 then (
596 let c0 = _get_byte64 data
byteoff strlen in
597 let c1 = _get_byte64 data
(byteoff+1) strlen in
598 let c2 = _get_byte64 data
(byteoff+2) strlen in
599 let c3 = _get_byte64 data
(byteoff+3) strlen in
600 let c4 = _get_byte64 data
(byteoff+4) strlen in
601 let c5 = _get_byte64 data
(byteoff+5) strlen in
602 let c6 = _get_byte64 data
(byteoff+6) strlen in
603 let c7 = _get_byte64 data
(byteoff+7) strlen in
604 _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
605 Int64.shift_right_logical
word (64 - flen
)
607 (* Extract the next 64 bits, slow method. *)
609 let c0 = extract_char_unsigned data
off len 8
610 and off = off + 8 and len = len - 8 in
611 let c1 = extract_char_unsigned data
off len 8
612 and off = off + 8 and len = len - 8 in
613 let c2 = extract_char_unsigned data
off len 8
614 and off = off + 8 and len = len - 8 in
615 let c3 = extract_char_unsigned data
off len 8
616 and off = off + 8 and len = len - 8 in
617 let c4 = extract_char_unsigned data
off len 8
618 and off = off + 8 and len = len - 8 in
619 let c5 = extract_char_unsigned data
off len 8
620 and off = off + 8 and len = len - 8 in
621 let c6 = extract_char_unsigned data
off len 8
622 and off = off + 8 and len = len - 8 in
623 let c7 = extract_char_unsigned data
off len 8 in
624 let c0 = Int64.of_int
c0 in
625 let c1 = Int64.of_int
c1 in
626 let c2 = Int64.of_int
c2 in
627 let c3 = Int64.of_int
c3 in
628 let c4 = Int64.of_int
c4 in
629 let c5 = Int64.of_int
c5 in
630 let c6 = Int64.of_int
c6 in
631 let c7 = Int64.of_int
c7 in
632 _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
633 Int64.shift_right_logical
word (64 - flen
)
635 word (*, off+flen, len-flen*)
637 let extract_int64_le_unsigned data
off len flen
=
638 let byteoff = off lsr 3 in
640 let strlen = String.length data
in
643 (* Optimize the common (byte-aligned) case. *)
644 if off land 7 = 0 then (
646 let c0 = _get_byte64 data
byteoff strlen in
647 let c1 = _get_byte64 data
(byteoff+1) strlen in
648 let c2 = _get_byte64 data
(byteoff+2) strlen in
649 let c3 = _get_byte64 data
(byteoff+3) strlen in
650 let c4 = _get_byte64 data
(byteoff+4) strlen in
651 let c5 = _get_byte64 data
(byteoff+5) strlen in
652 let c6 = _get_byte64 data
(byteoff+6) strlen in
653 let c7 = _get_byte64 data
(byteoff+7) strlen in
654 _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
655 Int64.logand
word (I64.mask flen
)
657 (* Extract the next 64 bits, slow method. *)
659 let c0 = extract_char_unsigned data
off len 8
660 and off = off + 8 and len = len - 8 in
661 let c1 = extract_char_unsigned data
off len 8
662 and off = off + 8 and len = len - 8 in
663 let c2 = extract_char_unsigned data
off len 8
664 and off = off + 8 and len = len - 8 in
665 let c3 = extract_char_unsigned data
off len 8
666 and off = off + 8 and len = len - 8 in
667 let c4 = extract_char_unsigned data
off len 8
668 and off = off + 8 and len = len - 8 in
669 let c5 = extract_char_unsigned data
off len 8
670 and off = off + 8 and len = len - 8 in
671 let c6 = extract_char_unsigned data
off len 8
672 and off = off + 8 and len = len - 8 in
673 let c7 = extract_char_unsigned data
off len 8 in
674 let c0 = Int64.of_int
c0 in
675 let c1 = Int64.of_int
c1 in
676 let c2 = Int64.of_int
c2 in
677 let c3 = Int64.of_int
c3 in
678 let c4 = Int64.of_int
c4 in
679 let c5 = Int64.of_int
c5 in
680 let c6 = Int64.of_int
c6 in
681 let c7 = Int64.of_int
c7 in
682 _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
683 Int64.logand
word (I64.mask flen
)
685 word (*, off+flen, len-flen*)
687 let extract_int64_ne_unsigned =
688 if nativeendian = BigEndian
689 then extract_int64_be_unsigned
690 else extract_int64_le_unsigned
692 let extract_int64_ee_unsigned = function
693 | BigEndian
-> extract_int64_be_unsigned
694 | LittleEndian
-> extract_int64_le_unsigned
695 | NativeEndian
-> extract_int64_ne_unsigned
697 external extract_fastpath_int16_be_unsigned
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
699 external extract_fastpath_int16_le_unsigned
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
701 external extract_fastpath_int16_ne_unsigned
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
703 external extract_fastpath_int16_be_signed
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
705 external extract_fastpath_int16_le_signed
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
707 external extract_fastpath_int16_ne_signed
: string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
710 external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
712 external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
714 external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
716 external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
718 external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
720 external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
723 external extract_fastpath_int32_be_unsigned
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc"
725 external extract_fastpath_int32_le_unsigned
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc"
727 external extract_fastpath_int32_ne_unsigned
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc"
729 external extract_fastpath_int32_be_signed
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc"
731 external extract_fastpath_int32_le_signed
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc"
733 external extract_fastpath_int32_ne_signed
: string -> int -> int32
-> int32
= "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc"
736 external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc"
738 external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc"
740 external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc"
742 external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc"
744 external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc"
746 external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc"
748 external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc"
750 external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc"
752 external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc"
754 external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc"
756 external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc"
758 external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc"
760 external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc"
762 external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc"
764 external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc"
766 external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc"
768 external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc"
770 external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc"
773 external extract_fastpath_int64_be_unsigned
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc"
775 external extract_fastpath_int64_le_unsigned
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc"
777 external extract_fastpath_int64_ne_unsigned
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc"
779 external extract_fastpath_int64_be_signed
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc"
781 external extract_fastpath_int64_le_signed
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc"
783 external extract_fastpath_int64_ne_signed
: string -> int -> int64
-> int64
= "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc"
785 (*----------------------------------------------------------------------*)
786 (* Constructor functions. *)
788 module Buffer
= struct
791 mutable len : int; (* Length in bits. *)
792 (* Last byte in the buffer (if len is not aligned). We store
793 * it outside the buffer because buffers aren't mutable.
799 (* XXX We have almost enough information in the generator to
800 * choose a good initial size.
802 { buf = Buffer.create 128; len = 0; last
= 0 }
804 let contents { buf = buf; len = len; last
= last
} =
806 if len land 7 = 0 then
809 Buffer.contents buf ^
(String.make
1 (Char.chr last
)) in
812 (* Add exactly 8 bits. *)
813 let add_byte ({ buf = buf; len = len; last
= last
} as t
) byte =
814 if byte < 0 || byte > 255 then invalid_arg
"Bitstring.Buffer.add_byte";
815 let shift = len land 7 in
817 (* Target buffer is byte-aligned. *)
818 Buffer.add_char
buf (Char.chr
byte)
820 (* Target buffer is unaligned. 'last' is meaningful. *)
821 let first = byte lsr shift in
822 let second = (byte lsl (8 - shift)) land 0xff in
823 Buffer.add_char
buf (Char.chr
(last
lor first));
828 (* Add exactly 1 bit. *)
829 let add_bit ({ buf = buf; len = len; last
= last
} as t
) bit
=
830 let shift = 7 - (len land 7) in
832 (* Somewhere in the middle of 'last'. *)
833 t
.last
<- last
lor ((if bit
then 1 else 0) lsl shift)
835 (* Just a single spare bit in 'last'. *)
836 let last = last lor if bit
then 1 else 0 in
837 Buffer.add_char
buf (Char.chr
last);
842 (* Add a small number of bits (definitely < 8). This uses a loop
843 * to call add_bit so it's slow.
845 let _add_bits t c slen
=
846 if slen
< 1 || slen
>= 8 then invalid_arg
"Bitstring.Buffer._add_bits";
847 for i
= slen
-1 downto 0 do
848 let bit = c
land (1 lsl i
) <> 0 in
852 let add_bits ({ buf = buf; len = len } as t
) str slen
=
854 if len land 7 = 0 then (
855 if slen
land 7 = 0 then
856 (* Common case - everything is byte-aligned. *)
857 Buffer.add_substring
buf str
0 (slen
lsr 3)
859 (* Target buffer is aligned. Copy whole bytes then leave the
860 * remaining bits in last.
862 let slenbytes = slen
lsr 3 in
863 if slenbytes > 0 then Buffer.add_substring
buf str
0 slenbytes;
864 let last = Char.code str
.[slenbytes] in (* last char *)
865 let mask = 0xff lsl (8 - (slen
land 7)) in
866 t
.last <- last land mask
870 (* Target buffer is unaligned. Copy whole bytes using
871 * add_byte which knows how to deal with an unaligned
872 * target buffer, then call add_bit for the remaining < 8 bits.
874 * XXX This is going to be dog-slow.
876 let slenbytes = slen
lsr 3 in
877 for i
= 0 to slenbytes-1 do
878 let byte = Char.code str
.[i
] in
881 let bitsleft = slen
- (slenbytes lsl 3) in
882 if bitsleft > 0 then (
883 let c = Char.code str
.[slenbytes] in
884 for i
= 0 to bitsleft - 1 do
885 let bit = c land (0x80 lsr i
) <> 0 in
893 (* Construct a single bit. *)
894 let construct_bit buf b _ _
=
897 (* Construct a field, flen = [2..8]. *)
898 let construct_char_unsigned buf v flen exn
=
899 let max_val = 1 lsl flen
in
900 if v < 0 || v >= max_val then raise exn
;
902 Buffer.add_byte buf v
904 Buffer._add_bits buf v flen
906 (* Construct a field of up to 31 bits. *)
907 let construct_int_be_unsigned buf v flen exn
=
908 (* Check value is within range. *)
909 if not
(I.range_unsigned v flen
) then raise exn
;
911 I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
913 (* Construct a field of up to 31 bits. *)
914 let construct_int_le_unsigned buf v flen exn
=
915 (* Check value is within range. *)
916 if not
(I.range_unsigned v flen
) then raise exn
;
918 I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
920 let construct_int_ne_unsigned =
921 if nativeendian = BigEndian
922 then construct_int_be_unsigned
923 else construct_int_le_unsigned
925 let construct_int_ee_unsigned = function
926 | BigEndian
-> construct_int_be_unsigned
927 | LittleEndian
-> construct_int_le_unsigned
928 | NativeEndian
-> construct_int_ne_unsigned
930 (* Construct a field of exactly 32 bits. *)
931 let construct_int32_be_unsigned buf v flen _
=
933 (Int32.to_int (Int32.shift_right_logical
v 24));
935 (Int32.to_int ((Int32.logand
(Int32.shift_right_logical
v 16) 0xff_l
)));
937 (Int32.to_int ((Int32.logand
(Int32.shift_right_logical
v 8) 0xff_l
)));
939 (Int32.to_int (Int32.logand
v 0xff_l
))
941 let construct_int32_le_unsigned buf v flen _
=
943 (Int32.to_int (Int32.logand
v 0xff_l
));
945 (Int32.to_int ((Int32.logand
(Int32.shift_right_logical
v 8) 0xff_l
)));
947 (Int32.to_int ((Int32.logand
(Int32.shift_right_logical
v 16) 0xff_l
)));
949 (Int32.to_int (Int32.shift_right_logical
v 24))
951 let construct_int32_ne_unsigned =
952 if nativeendian = BigEndian
953 then construct_int32_be_unsigned
954 else construct_int32_le_unsigned
956 let construct_int32_ee_unsigned = function
957 | BigEndian
-> construct_int32_be_unsigned
958 | LittleEndian
-> construct_int32_le_unsigned
959 | NativeEndian
-> construct_int32_ne_unsigned
961 (* Construct a field of up to 64 bits. *)
962 let construct_int64_be_unsigned buf v flen exn
=
963 (* Check value is within range. *)
964 if not
(I64.range_unsigned v flen
) then raise exn
;
966 I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
968 (* Construct a field of up to 64 bits. *)
969 let construct_int64_le_unsigned buf v flen exn
=
970 (* Check value is within range. *)
971 if not
(I64.range_unsigned v flen
) then raise exn
;
973 I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
975 let construct_int64_ne_unsigned =
976 if nativeendian = BigEndian
977 then construct_int64_be_unsigned
978 else construct_int64_le_unsigned
980 let construct_int64_ee_unsigned = function
981 | BigEndian
-> construct_int64_be_unsigned
982 | LittleEndian
-> construct_int64_le_unsigned
983 | NativeEndian
-> construct_int64_ne_unsigned
985 (* Construct from a string of bytes, exact multiple of 8 bits
986 * in length of course.
988 let construct_string buf str
=
989 let len = String.length str
in
990 Buffer.add_bits buf str
(len lsl 3)
992 (* Construct from a bitstring. *)
993 let construct_bitstring buf (data, off, len) =
994 (* Add individual bits until we get to the next byte boundary of
995 * the underlying string.
997 let blen = 7 - ((off + 7) land 7) in
998 let blen = min
blen len in
999 let rec loop off len blen =
1000 if blen = 0 then (off, len)
1002 let b = extract_bit data off len 1
1003 and off = off + 1 and len = len + 1 in
1004 Buffer.add_bit buf b;
1005 loop off len (blen-1)
1008 let off, len = loop off len blen in
1009 assert (len = 0 || (off land 7) = 0);
1011 (* Add the remaining 'len' bits. *)
1013 let off = off lsr 3 in
1014 (* XXX dangerous allocation *)
1015 if off = 0 then data
1016 else String.sub
data off (String.length
data - off) in
1018 Buffer.add_bits buf data len
1020 (* Concatenate bitstrings. *)
1022 let buf = Buffer.create () in
1023 List.iter
(construct_bitstring buf) bs;
1026 (*----------------------------------------------------------------------*)
1027 (* Extract a string from a bitstring. *)
1028 let string_of_bitstring (data, off, len) =
1029 if off land 7 = 0 && len land 7 = 0 then
1030 (* Easy case: everything is byte-aligned. *)
1031 String.sub
data (off lsr 3) (len lsr 3)
1033 (* Bit-twiddling case. *)
1034 let strlen = (len + 7) lsr 3 in
1035 let str = String.make
strlen '
\000'
in
1036 let rec loop data off len i
=
1038 let c = extract_char_unsigned data off len 8
1039 and off = off + 8 and len = len - 8 in
1040 str.[i
] <- Char.chr
c;
1041 loop data off len (i
+1)
1042 ) else if len > 0 then (
1043 let c = extract_char_unsigned data off len len in
1044 str.[i
] <- Char.chr
(c lsl (8-len))
1047 loop data off len 0;
1053 let bitstring_to_chan ((data, off, len) as bits
) chan =
1054 (* Fail if the bitstring length isn't a multiple of 8. *)
1055 if len land 7 <> 0 then invalid_arg
"bitstring_to_chan";
1057 if off land 7 = 0 then
1058 (* Easy case: string is byte-aligned. *)
1059 output
chan data (off lsr 3) (len lsr 3)
1061 (* Bit-twiddling case: reuse string_of_bitstring *)
1062 let str = string_of_bitstring bits
in
1063 output_string
chan str
1066 let bitstring_to_file bits filename
=
1067 let chan = open_out_bin filename
in
1069 bitstring_to_chan bits
chan;
1075 (*----------------------------------------------------------------------*)
1077 let compare ((data1
, off1
, len1
) as bs1
) ((data2
, off2
, len2
) as bs2
) =
1078 (* In the fully-aligned case, this is reduced to string comparison ... *)
1079 if off1
land 7 = 0 && len1
land 7 = 0 && off2
land 7 = 0 && len2
land 7 = 0
1081 (* ... but we have to do that by hand because the bits may
1082 * not extend to the full length of the underlying string.
1084 let off1 = off1 lsr 3 and off2
= off2
lsr 3
1085 and len1
= len1
lsr 3 and len2
= len2
lsr 3 in
1087 if i
< len1
&& i
< len2
then (
1088 let c1 = String.unsafe_get data1
(off1 + i
)
1089 and c2 = String.unsafe_get data2
(off2
+ i
) in
1090 let r = compare c1 c2 in
1099 (* Slow/unaligned. *)
1100 let str1 = string_of_bitstring bs1
1101 and str2
= string_of_bitstring bs2
in
1102 let r = String.compare str1 str2
in
1103 if r <> 0 then r else len1
- len2
1106 let equals ((_
, _
, len1
) as bs1
) ((_
, _
, len2
) as bs2
) =
1107 if len1
<> len2
then false
1108 else if bs1
= bs2
then true
1109 else 0 = compare bs1 bs2
1111 (*----------------------------------------------------------------------*)
1112 (* Bit get/set functions. *)
1114 let index_out_of_bounds () = invalid_arg
"index out of bounds"
1116 let put (data, off, len) n v =
1117 if n < 0 || n >= len then index_out_of_bounds ()
1120 let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1121 let c = Char.code
data.[si] in
1122 let c = if v <> 0 then c lor mask else c land (lnot mask) in
1123 data.[si] <- Char.unsafe_chr
c
1126 let set bits
n = put bits
n 1
1128 let clear bits
n = put bits
n 0
1130 let get (data, off, len) n =
1131 if n < 0 || n >= len then index_out_of_bounds ()
1134 let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1135 let c = Char.code
data.[si] in
1139 let is_set bits
n = get bits
n <> 0
1141 let is_clear bits
n = get bits
n = 0
1143 (*----------------------------------------------------------------------*)
1144 (* Display functions. *)
1147 let c = Char.code
c in
1150 let hexdump_bitstring chan (data, off, len) =
1151 let count = ref 0 in
1152 let off = ref off in
1153 let len = ref len in
1154 let linelen = ref 0 in
1155 let linechars = String.make
16 ' '
in
1157 fprintf
chan "00000000 ";
1160 let bits = min
!len 8 in
1161 let byte = extract_char_unsigned data !off !len bits in
1162 off := !off + bits; len := !len - bits;
1164 let byte = byte lsl (8-bits) in
1165 fprintf
chan "%02x " byte;
1168 linechars.[!linelen] <-
1169 (let c = Char.chr
byte in
1170 if isprint c then c else '
.'
);
1172 if !linelen = 8 then fprintf
chan " ";
1173 if !linelen = 16 then (
1174 fprintf
chan " |%s|\n%08x " linechars !count;
1176 for i = 0 to 15 do linechars.[i] <- ' '
done
1180 if !linelen > 0 then (
1181 let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1182 for i = 0 to skip-1 do fprintf
chan " " done;
1183 fprintf
chan " |%s|\n%!" linechars