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 include Bitstring_types
25 include Bitstring_config
27 (* Enable runtime debug messages. Must also have been enabled
33 exception Construct_failure of string * string * int * int
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.
39 type bitstring = string * int * int
41 (* Functions to create and load bitstrings. *)
42 let empty_bitstring = "", 0, 0
44 let make_bitstring len c =
45 if len >= 0 then String.make ((len+7) lsr 3) c, 0, len
48 sprintf "make_bitstring/create_bitstring: len %d < 0" len
51 let create_bitstring len = make_bitstring len '\000'
53 let zeroes_bitstring = create_bitstring
55 let ones_bitstring len = make_bitstring len '\xff'
57 let bitstring_of_string str = str, 0, String.length str lsl 3
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
64 while n := input chan tmp 0 tmpsize; !n > 0 do
65 Buffer.add_substring buf tmp 0 !n;
67 Buffer.contents buf, 0, Buffer.length buf lsl 3
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
76 let r = min tmpsize (max - !len) in
77 let n = input chan tmp 0 r in
79 Buffer.add_substring buf tmp 0 n;
86 Buffer.contents buf, 0, !len lsl 3
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
93 while n := Unix.read fd tmp 0 tmpsize; !n > 0 do
94 Buffer.add_substring buf tmp 0 !n;
96 Buffer.contents buf, 0, Buffer.length buf lsl 3
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
105 let r = min tmpsize (max - !len) in
106 let n = Unix.read fd tmp 0 r in
108 Buffer.add_substring buf tmp 0 n;
115 Buffer.contents buf, 0, !len lsl 3
117 let bitstring_of_file fname =
118 let chan = open_in_bin fname in
120 let bs = bitstring_of_chan chan in
127 let bitstring_length (_, _, len) = len
129 let subbitstring (data, off, len) off' len' =
130 let off = off + off' in
131 if len < off' + len' then invalid_arg "subbitstring";
134 let dropbits n (data, off, len) =
137 if len < 0 then invalid_arg "dropbits";
140 let takebits n (data, off, len) =
141 if len < n then invalid_arg "takebits";
144 (*----------------------------------------------------------------------*)
145 (* Bitwise functions.
147 * We try to isolate all bitwise functions within these modules.
151 (* Bitwise operations on ints. Note that we assume int <= 31 bits. *)
154 external to_int : int -> int = "%identity"
160 (* Create a mask 0-31 bits wide. *)
161 external mask : int -> int = "ocaml_bitstring_I_mask" "noalloc"
163 (* Byte swap an int of a given size. *)
164 let byteswap v bits =
166 else if bits <= 16 then (
167 let shift = bits-8 in
168 let v1 = v >> shift in
169 let v2 = (v land (mask shift)) << 8 in
171 ) else if bits <= 24 then (
172 let shift = bits - 16 in
173 let v1 = v >> (8+shift) in
174 let v2 = ((v >> shift) land ff) << 8 in
175 let v3 = (v land (mask shift)) << 16 in
178 let shift = bits - 24 in
179 let v1 = v >> (16+shift) in
180 let v2 = ((v >> (8+shift)) land ff) << 8 in
181 let v3 = ((v >> shift) land ff) << 16 in
182 let v4 = (v land (mask shift)) << 24 in
183 v4 lor v3 lor v2 lor v1
186 (* Check a value is in range 0 .. 2^bits-1. *)
187 let range_unsigned v bits =
188 let mask = lnot (mask bits) in
191 (* Call function g on the top bits, then f on each full byte
192 * (big endian - so start at top).
194 let rec map_bytes_be g f v bits =
196 map_bytes_be g f (v >> 8) (bits-8);
197 let lsb = v land ff in
199 ) else if bits > 0 then (
200 let lsb = v land (mask bits) in
204 (* Call function g on the top bits, then f on each full byte
205 * (little endian - so start at root).
207 let rec map_bytes_le g f v bits =
209 let lsb = v land ff in
211 map_bytes_le g f (v >> 8) (bits-8)
212 ) else if bits > 0 then (
213 let lsb = v land (mask bits) in
219 (* Bitwise operations on int32s. Note we try to keep it as similar
220 * as possible to the I module above, to make it easier to track
223 let (<<) = Int32.shift_left
224 let (>>) = Int32.shift_right_logical
225 let (land) = Int32.logand
226 let (lor) = Int32.logor
227 let lnot = Int32.lognot
228 let pred = Int32.pred
229 let max_int = Int32.max_int
230 let to_int = Int32.to_int
231 let zero = Int32.zero
233 let minus_one = Int32.minus_one
236 (* Create a mask so many bits wide. *)
240 else if bits = 31 then
242 else if bits = 32 then
245 invalid_arg "Bitstring.I32.mask"
247 (* Byte swap an int of a given size. *)
248 let byteswap v bits =
250 else if bits <= 16 then (
251 let shift = bits-8 in
252 let v1 = v >> shift in
253 let v2 = (v land (mask shift)) << 8 in
255 ) else if bits <= 24 then (
256 let shift = bits - 16 in
257 let v1 = v >> (8+shift) in
258 let v2 = ((v >> shift) land ff) << 8 in
259 let v3 = (v land (mask shift)) << 16 in
262 let shift = bits - 24 in
263 let v1 = v >> (16+shift) in
264 let v2 = ((v >> (8+shift)) land ff) << 8 in
265 let v3 = ((v >> shift) land ff) << 16 in
266 let v4 = (v land (mask shift)) << 24 in
267 v4 lor v3 lor v2 lor v1
270 (* Check a value is in range 0 .. 2^bits-1. *)
271 let range_unsigned v bits =
272 let mask = lnot (mask bits) in
275 (* Call function g on the top bits, then f on each full byte
276 * (big endian - so start at top).
278 let rec map_bytes_be g f v bits =
280 map_bytes_be g f (v >> 8) (bits-8);
281 let lsb = v land ff in
283 ) else if bits > 0 then (
284 let lsb = v land (mask bits) in
288 (* Call function g on the top bits, then f on each full byte
289 * (little endian - so start at root).
291 let rec map_bytes_le g f v bits =
293 let lsb = v land ff in
295 map_bytes_le g f (v >> 8) (bits-8)
296 ) else if bits > 0 then (
297 let lsb = v land (mask bits) in
303 (* Bitwise operations on int64s. Note we try to keep it as similar
304 * as possible to the I/I32 modules above, to make it easier to track
307 let (<<) = Int64.shift_left
308 let (>>) = Int64.shift_right_logical
309 let (land) = Int64.logand
310 let (lor) = Int64.logor
311 let lnot = Int64.lognot
312 let pred = Int64.pred
313 let max_int = Int64.max_int
314 let to_int = Int64.to_int
315 let zero = Int64.zero
317 let minus_one = Int64.minus_one
320 (* Create a mask so many bits wide. *)
324 else if bits = 63 then
326 else if bits = 64 then
329 invalid_arg "Bitstring.I64.mask"
331 (* Byte swap an int of a given size. *)
332 (* let byteswap v bits = *)
334 (* Check a value is in range 0 .. 2^bits-1. *)
335 let range_unsigned v bits =
336 let mask = lnot (mask bits) in
339 (* Call function g on the top bits, then f on each full byte
340 * (big endian - so start at top).
342 let rec map_bytes_be g f v bits =
344 map_bytes_be g f (v >> 8) (bits-8);
345 let lsb = v land ff in
347 ) else if bits > 0 then (
348 let lsb = v land (mask bits) in
352 (* Call function g on the top bits, then f on each full byte
353 * (little endian - so start at root).
355 let rec map_bytes_le g f v bits =
357 let lsb = v land ff in
359 map_bytes_le g f (v >> 8) (bits-8)
360 ) else if bits > 0 then (
361 let lsb = v land (mask bits) in
366 (*----------------------------------------------------------------------*)
367 (* Extraction functions.
369 * NB: internal functions, called from the generated macros, and
370 * the parameters should have been checked for sanity already).
374 let extract_bitstring data off len flen =
375 (data, off, flen) (*, off+flen, len-flen*)
377 let extract_remainder data off len =
378 (data, off, len) (*, off+len, 0*)
380 (* Extract and convert to numeric. A single bit is returned as
381 * a boolean. There are no endianness or signedness considerations.
383 let extract_bit data off len _ = (* final param is always 1 *)
384 let byteoff = off lsr 3 in
385 let bitmask = 1 lsl (7 - (off land 7)) in
386 let b = Char.code data.[byteoff] land bitmask <> 0 in
389 (* Returns 8 bit unsigned aligned bytes from the string.
390 * If the string ends then this returns 0's.
392 let _get_byte data byteoff strlen =
393 if strlen > byteoff then Char.code data.[byteoff] else 0
394 let _get_byte32 data byteoff strlen =
395 if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
396 let _get_byte64 data byteoff strlen =
397 if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
399 (* Extract [2..8] bits. Because the result fits into a single
400 * byte we don't have to worry about endianness, only signedness.
402 let extract_char_unsigned data off len flen =
403 let byteoff = off lsr 3 in
405 (* Optimize the common (byte-aligned) case. *)
406 if off land 7 = 0 then (
407 let byte = Char.code data.[byteoff] in
408 byte lsr (8 - flen) (*, off+flen, len-flen*)
410 (* Extract the 16 bits at byteoff and byteoff+1 (note that the
411 * second byte might not exist in the original string).
413 let strlen = String.length data in
416 (_get_byte data byteoff strlen lsl 8) +
417 _get_byte data (byteoff+1) strlen in
419 (* Mask off the top bits. *)
420 let bitmask = (1 lsl (16 - (off land 7))) - 1 in
421 let word = word land bitmask in
422 (* Shift right to get rid of the bottom bits. *)
423 let shift = 16 - ((off land 7) + flen) in
424 let word = word lsr shift in
426 word (*, off+flen, len-flen*)
429 (* Extract [9..31] bits. We have to consider endianness and signedness. *)
430 let extract_int_be_unsigned data off len flen =
431 let byteoff = off lsr 3 in
433 let strlen = String.length data in
436 (* Optimize the common (byte-aligned) case. *)
437 if off land 7 = 0 then (
439 (_get_byte data byteoff strlen lsl 23) +
440 (_get_byte data (byteoff+1) strlen lsl 15) +
441 (_get_byte data (byteoff+2) strlen lsl 7) +
442 (_get_byte data (byteoff+3) strlen lsr 1) in
444 ) else if flen <= 24 then (
445 (* Extract the 31 bits at byteoff .. byteoff+3. *)
447 (_get_byte data byteoff strlen lsl 23) +
448 (_get_byte data (byteoff+1) strlen lsl 15) +
449 (_get_byte data (byteoff+2) strlen lsl 7) +
450 (_get_byte data (byteoff+3) strlen lsr 1) in
451 (* Mask off the top bits. *)
452 let bitmask = (1 lsl (31 - (off land 7))) - 1 in
453 let word = word land bitmask in
454 (* Shift right to get rid of the bottom bits. *)
455 let shift = 31 - ((off land 7) + flen) in
458 (* Extract the next 31 bits, slow method. *)
460 let c0 = extract_char_unsigned data off len 8
461 and off = off + 8 and len = len - 8 in
462 let c1 = extract_char_unsigned data off len 8
463 and off = off + 8 and len = len - 8 in
464 let c2 = extract_char_unsigned data off len 8
465 and off = off + 8 and len = len - 8 in
466 let c3 = extract_char_unsigned data off len 7 in
467 (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
470 word (*, off+flen, len-flen*)
472 let extract_int_le_unsigned data off len flen =
473 let v = extract_int_be_unsigned data off len flen in
474 let v = I.byteswap v flen in
477 let extract_int_ne_unsigned =
478 if nativeendian = BigEndian
479 then extract_int_be_unsigned
480 else extract_int_le_unsigned
482 let extract_int_ee_unsigned = function
483 | BigEndian -> extract_int_be_unsigned
484 | LittleEndian -> extract_int_le_unsigned
485 | NativeEndian -> extract_int_ne_unsigned
487 let _make_int32_be c0 c1 c2 c3 =
491 (Int32.shift_left c0 24)
492 (Int32.shift_left c1 16))
493 (Int32.shift_left c2 8))
496 let _make_int32_le c0 c1 c2 c3 =
500 (Int32.shift_left c3 24)
501 (Int32.shift_left c2 16))
502 (Int32.shift_left c1 8))
505 (* Extract exactly 32 bits. We have to consider endianness and signedness. *)
506 let extract_int32_be_unsigned data off len flen =
507 let byteoff = off lsr 3 in
509 let strlen = String.length data in
512 (* Optimize the common (byte-aligned) case. *)
513 if off land 7 = 0 then (
515 let c0 = _get_byte32 data byteoff strlen in
516 let c1 = _get_byte32 data (byteoff+1) strlen in
517 let c2 = _get_byte32 data (byteoff+2) strlen in
518 let c3 = _get_byte32 data (byteoff+3) strlen in
519 _make_int32_be c0 c1 c2 c3 in
520 Int32.shift_right_logical word (32 - flen)
522 (* Extract the next 32 bits, slow method. *)
524 let c0 = extract_char_unsigned data off len 8
525 and off = off + 8 and len = len - 8 in
526 let c1 = extract_char_unsigned data off len 8
527 and off = off + 8 and len = len - 8 in
528 let c2 = extract_char_unsigned data off len 8
529 and off = off + 8 and len = len - 8 in
530 let c3 = extract_char_unsigned data off len 8 in
531 let c0 = Int32.of_int c0 in
532 let c1 = Int32.of_int c1 in
533 let c2 = Int32.of_int c2 in
534 let c3 = Int32.of_int c3 in
535 _make_int32_be c0 c1 c2 c3 in
536 Int32.shift_right_logical word (32 - flen)
538 word (*, off+flen, len-flen*)
540 let extract_int32_le_unsigned data off len flen =
541 let v = extract_int32_be_unsigned data off len flen in
542 let v = I32.byteswap v flen in
545 let extract_int32_ne_unsigned =
546 if nativeendian = BigEndian
547 then extract_int32_be_unsigned
548 else extract_int32_le_unsigned
550 let extract_int32_ee_unsigned = function
551 | BigEndian -> extract_int32_be_unsigned
552 | LittleEndian -> extract_int32_le_unsigned
553 | NativeEndian -> extract_int32_ne_unsigned
555 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
563 (Int64.shift_left c0 56)
564 (Int64.shift_left c1 48))
565 (Int64.shift_left c2 40))
566 (Int64.shift_left c3 32))
567 (Int64.shift_left c4 24))
568 (Int64.shift_left c5 16))
569 (Int64.shift_left c6 8))
572 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
573 _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
575 (* Extract [1..64] bits. We have to consider endianness and signedness. *)
576 let extract_int64_be_unsigned data off len flen =
577 let byteoff = off lsr 3 in
579 let strlen = String.length data in
582 (* Optimize the common (byte-aligned) case. *)
583 if off land 7 = 0 then (
585 let c0 = _get_byte64 data byteoff strlen in
586 let c1 = _get_byte64 data (byteoff+1) strlen in
587 let c2 = _get_byte64 data (byteoff+2) strlen in
588 let c3 = _get_byte64 data (byteoff+3) strlen in
589 let c4 = _get_byte64 data (byteoff+4) strlen in
590 let c5 = _get_byte64 data (byteoff+5) strlen in
591 let c6 = _get_byte64 data (byteoff+6) strlen in
592 let c7 = _get_byte64 data (byteoff+7) strlen in
593 _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
594 Int64.shift_right_logical word (64 - flen)
596 (* Extract the next 64 bits, slow method. *)
598 let c0 = extract_char_unsigned data off len 8
599 and off = off + 8 and len = len - 8 in
600 let c1 = extract_char_unsigned data off len 8
601 and off = off + 8 and len = len - 8 in
602 let c2 = extract_char_unsigned data off len 8
603 and off = off + 8 and len = len - 8 in
604 let c3 = extract_char_unsigned data off len 8
605 and off = off + 8 and len = len - 8 in
606 let c4 = extract_char_unsigned data off len 8
607 and off = off + 8 and len = len - 8 in
608 let c5 = extract_char_unsigned data off len 8
609 and off = off + 8 and len = len - 8 in
610 let c6 = extract_char_unsigned data off len 8
611 and off = off + 8 and len = len - 8 in
612 let c7 = extract_char_unsigned data off len 8 in
613 let c0 = Int64.of_int c0 in
614 let c1 = Int64.of_int c1 in
615 let c2 = Int64.of_int c2 in
616 let c3 = Int64.of_int c3 in
617 let c4 = Int64.of_int c4 in
618 let c5 = Int64.of_int c5 in
619 let c6 = Int64.of_int c6 in
620 let c7 = Int64.of_int c7 in
621 _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
622 Int64.shift_right_logical word (64 - flen)
624 word (*, off+flen, len-flen*)
626 let extract_int64_le_unsigned data off len flen =
627 let byteoff = off lsr 3 in
629 let strlen = String.length data in
632 (* Optimize the common (byte-aligned) case. *)
633 if off land 7 = 0 then (
635 let c0 = _get_byte64 data byteoff strlen in
636 let c1 = _get_byte64 data (byteoff+1) strlen in
637 let c2 = _get_byte64 data (byteoff+2) strlen in
638 let c3 = _get_byte64 data (byteoff+3) strlen in
639 let c4 = _get_byte64 data (byteoff+4) strlen in
640 let c5 = _get_byte64 data (byteoff+5) strlen in
641 let c6 = _get_byte64 data (byteoff+6) strlen in
642 let c7 = _get_byte64 data (byteoff+7) strlen in
643 _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
644 Int64.logand word (I64.mask flen)
646 (* Extract the next 64 bits, slow method. *)
648 let c0 = extract_char_unsigned data off len 8
649 and off = off + 8 and len = len - 8 in
650 let c1 = extract_char_unsigned data off len 8
651 and off = off + 8 and len = len - 8 in
652 let c2 = extract_char_unsigned data off len 8
653 and off = off + 8 and len = len - 8 in
654 let c3 = extract_char_unsigned data off len 8
655 and off = off + 8 and len = len - 8 in
656 let c4 = extract_char_unsigned data off len 8
657 and off = off + 8 and len = len - 8 in
658 let c5 = extract_char_unsigned data off len 8
659 and off = off + 8 and len = len - 8 in
660 let c6 = extract_char_unsigned data off len 8
661 and off = off + 8 and len = len - 8 in
662 let c7 = extract_char_unsigned data off len 8 in
663 let c0 = Int64.of_int c0 in
664 let c1 = Int64.of_int c1 in
665 let c2 = Int64.of_int c2 in
666 let c3 = Int64.of_int c3 in
667 let c4 = Int64.of_int c4 in
668 let c5 = Int64.of_int c5 in
669 let c6 = Int64.of_int c6 in
670 let c7 = Int64.of_int c7 in
671 _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
672 Int64.logand word (I64.mask flen)
674 word (*, off+flen, len-flen*)
676 let extract_int64_ne_unsigned =
677 if nativeendian = BigEndian
678 then extract_int64_be_unsigned
679 else extract_int64_le_unsigned
681 let extract_int64_ee_unsigned = function
682 | BigEndian -> extract_int64_be_unsigned
683 | LittleEndian -> extract_int64_le_unsigned
684 | NativeEndian -> extract_int64_ne_unsigned
686 (*----------------------------------------------------------------------*)
687 (* Constructor functions. *)
689 module Buffer = struct
692 mutable len : int; (* Length in bits. *)
693 (* Last byte in the buffer (if len is not aligned). We store
694 * it outside the buffer because buffers aren't mutable.
700 (* XXX We have almost enough information in the generator to
701 * choose a good initial size.
703 { buf = Buffer.create 128; len = 0; last = 0 }
705 let contents { buf = buf; len = len; last = last } =
707 if len land 7 = 0 then
710 Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
713 (* Add exactly 8 bits. *)
714 let add_byte ({ buf = buf; len = len; last = last } as t) byte =
715 if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte";
716 let shift = len land 7 in
718 (* Target buffer is byte-aligned. *)
719 Buffer.add_char buf (Char.chr byte)
721 (* Target buffer is unaligned. 'last' is meaningful. *)
722 let first = byte lsr shift in
723 let second = (byte lsl (8 - shift)) land 0xff in
724 Buffer.add_char buf (Char.chr (last lor first));
729 (* Add exactly 1 bit. *)
730 let add_bit ({ buf = buf; len = len; last = last } as t) bit =
731 let shift = 7 - (len land 7) in
733 (* Somewhere in the middle of 'last'. *)
734 t.last <- last lor ((if bit then 1 else 0) lsl shift)
736 (* Just a single spare bit in 'last'. *)
737 let last = last lor if bit then 1 else 0 in
738 Buffer.add_char buf (Char.chr last);
743 (* Add a small number of bits (definitely < 8). This uses a loop
744 * to call add_bit so it's slow.
746 let _add_bits t c slen =
747 if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits";
748 for i = slen-1 downto 0 do
749 let bit = c land (1 lsl i) <> 0 in
753 let add_bits ({ buf = buf; len = len } as t) str slen =
755 if len land 7 = 0 then (
756 if slen land 7 = 0 then
757 (* Common case - everything is byte-aligned. *)
758 Buffer.add_substring buf str 0 (slen lsr 3)
760 (* Target buffer is aligned. Copy whole bytes then leave the
761 * remaining bits in last.
763 let slenbytes = slen lsr 3 in
764 if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes;
765 let last = Char.code str.[slenbytes] in (* last char *)
766 let mask = 0xff lsl (8 - (slen land 7)) in
767 t.last <- last land mask
771 (* Target buffer is unaligned. Copy whole bytes using
772 * add_byte which knows how to deal with an unaligned
773 * target buffer, then call add_bit for the remaining < 8 bits.
775 * XXX This is going to be dog-slow.
777 let slenbytes = slen lsr 3 in
778 for i = 0 to slenbytes-1 do
779 let byte = Char.code str.[i] in
782 let bitsleft = slen - (slenbytes lsl 3) in
783 if bitsleft > 0 then (
784 let c = Char.code str.[slenbytes] in
785 for i = 0 to bitsleft - 1 do
786 let bit = c land (0x80 lsr i) <> 0 in
794 (* Construct a single bit. *)
795 let construct_bit buf b _ _ =
798 (* Construct a field, flen = [2..8]. *)
799 let construct_char_unsigned buf v flen exn =
800 let max_val = 1 lsl flen in
801 if v < 0 || v >= max_val then raise exn;
803 Buffer.add_byte buf v
805 Buffer._add_bits buf v flen
807 (* Construct a field of up to 31 bits. *)
808 let construct_int_be_unsigned buf v flen exn =
809 (* Check value is within range. *)
810 if not (I.range_unsigned v flen) then raise exn;
812 I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
814 (* Construct a field of up to 31 bits. *)
815 let construct_int_le_unsigned buf v flen exn =
816 (* Check value is within range. *)
817 if not (I.range_unsigned v flen) then raise exn;
819 I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
821 let construct_int_ne_unsigned =
822 if nativeendian = BigEndian
823 then construct_int_be_unsigned
824 else construct_int_le_unsigned
826 let construct_int_ee_unsigned = function
827 | BigEndian -> construct_int_be_unsigned
828 | LittleEndian -> construct_int_le_unsigned
829 | NativeEndian -> construct_int_ne_unsigned
831 (* Construct a field of exactly 32 bits. *)
832 let construct_int32_be_unsigned buf v flen _ =
834 (Int32.to_int (Int32.shift_right_logical v 24));
836 (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
838 (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
840 (Int32.to_int (Int32.logand v 0xff_l))
842 let construct_int32_le_unsigned buf v flen _ =
844 (Int32.to_int (Int32.logand v 0xff_l));
846 (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
848 (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
850 (Int32.to_int (Int32.shift_right_logical v 24))
852 let construct_int32_ne_unsigned =
853 if nativeendian = BigEndian
854 then construct_int32_be_unsigned
855 else construct_int32_le_unsigned
857 let construct_int32_ee_unsigned = function
858 | BigEndian -> construct_int32_be_unsigned
859 | LittleEndian -> construct_int32_le_unsigned
860 | NativeEndian -> construct_int32_ne_unsigned
862 (* Construct a field of up to 64 bits. *)
863 let construct_int64_be_unsigned buf v flen exn =
864 (* Check value is within range. *)
865 if not (I64.range_unsigned v flen) then raise exn;
867 I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
869 (* Construct a field of up to 64 bits. *)
870 let construct_int64_le_unsigned buf v flen exn =
871 (* Check value is within range. *)
872 if not (I64.range_unsigned v flen) then raise exn;
874 I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
876 let construct_int64_ne_unsigned =
877 if nativeendian = BigEndian
878 then construct_int64_be_unsigned
879 else (*construct_int64_le_unsigned*)
880 fun _ _ _ _ -> failwith "construct_int64_le_unsigned"
882 let construct_int64_ee_unsigned = function
883 | BigEndian -> construct_int64_be_unsigned
884 | LittleEndian -> (*construct_int64_le_unsigned*)
885 (fun _ _ _ _ -> failwith "construct_int64_le_unsigned")
886 | NativeEndian -> construct_int64_ne_unsigned
888 (* Construct from a string of bytes, exact multiple of 8 bits
889 * in length of course.
891 let construct_string buf str =
892 let len = String.length str in
893 Buffer.add_bits buf str (len lsl 3)
895 (* Construct from a bitstring. *)
896 let construct_bitstring buf (data, off, len) =
897 (* Add individual bits until we get to the next byte boundary of
898 * the underlying string.
900 let blen = 7 - ((off + 7) land 7) in
901 let blen = min blen len in
902 let rec loop off len blen =
903 if blen = 0 then (off, len)
905 let b = extract_bit data off len 1
906 and off = off + 1 and len = len + 1 in
907 Buffer.add_bit buf b;
908 loop off len (blen-1)
911 let off, len = loop off len blen in
912 assert (len = 0 || (off land 7) = 0);
914 (* Add the remaining 'len' bits. *)
916 let off = off lsr 3 in
917 (* XXX dangerous allocation *)
919 else String.sub data off (String.length data - off) in
921 Buffer.add_bits buf data len
923 (*----------------------------------------------------------------------*)
924 (* Extract a string from a bitstring. *)
926 let string_of_bitstring (data, off, len) =
927 if off land 7 = 0 && len land 7 = 0 then
928 (* Easy case: everything is byte-aligned. *)
929 String.sub data (off lsr 3) (len lsr 3)
931 (* Bit-twiddling case. *)
932 let strlen = (len + 7) lsr 3 in
933 let str = String.make strlen '\000' in
934 let rec loop data off len i =
936 let c = extract_char_unsigned data off len 8
937 and off = off + 8 and len = len - 8 in
938 str.[i] <- Char.chr c;
939 loop data off len (i+1)
940 ) else if len > 0 then (
941 let c = extract_char_unsigned data off len len in
942 str.[i] <- Char.chr (c lsl (8-len))
951 let bitstring_to_chan ((data, off, len) as bits) chan =
952 (* Fail if the bitstring length isn't a multiple of 8. *)
953 if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
955 if off land 7 = 0 then
956 (* Easy case: string is byte-aligned. *)
957 output chan data (off lsr 3) (len lsr 3)
959 (* Bit-twiddling case: reuse string_of_bitstring *)
960 let str = string_of_bitstring bits in
961 output_string chan str
964 let bitstring_to_file bits filename =
965 let chan = open_out_bin filename in
967 bitstring_to_chan bits chan;
973 (*----------------------------------------------------------------------*)
974 (* Display functions. *)
977 let c = Char.code c in
980 let hexdump_bitstring chan (data, off, len) =
984 let linelen = ref 0 in
985 let linechars = String.make 16 ' ' in
987 fprintf chan "00000000 ";
990 let bits = min !len 8 in
991 let byte = extract_char_unsigned data !off !len bits in
992 off := !off + bits; len := !len - bits;
994 let byte = byte lsl (8-bits) in
995 fprintf chan "%02x " byte;
998 linechars.[!linelen] <-
999 (let c = Char.chr byte in
1000 if isprint c then c else '.');
1002 if !linelen = 8 then fprintf chan " ";
1003 if !linelen = 16 then (
1004 fprintf chan " |%s|\n%08x " linechars !count;
1006 for i = 0 to 15 do linechars.[i] <- ' ' done
1010 if !linelen > 0 then (
1011 let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1012 for i = 0 to skip-1 do fprintf chan " " done;
1013 fprintf chan " |%s|\n%!" linechars