*)
type bitstring = string * int * int
+type t = bitstring
+
(* Functions to create and load bitstrings. *)
let empty_bitstring = "", 0, 0
module I = struct
(* Bitwise operations on ints. Note that we assume int <= 31 bits. *)
- let (<<) = (lsl)
- let (>>) = (lsr)
+ external (<<<) : int -> int -> int = "%lslint"
+ external (>>>) : int -> int -> int = "%lsrint"
external to_int : int -> int = "%identity"
let zero = 0
let one = 1
(* Create a mask 0-31 bits wide. *)
let mask bits =
if bits < 30 then
- (one << bits) - 1
+ (one <<< bits) - 1
else if bits = 30 then
max_int
else if bits = 31 then
if bits <= 8 then v
else if bits <= 16 then (
let shift = bits-8 in
- let v1 = v >> shift in
- let v2 = (v land (mask shift)) << 8 in
+ let v1 = v >>> shift in
+ let v2 = ((v land (mask shift)) <<< 8) in
v2 lor v1
) else if bits <= 24 then (
let shift = bits - 16 in
- let v1 = v >> (8+shift) in
- let v2 = ((v >> shift) land ff) << 8 in
- let v3 = (v land (mask shift)) << 16 in
+ let v1 = v >>> (8+shift) in
+ let v2 = ((v >>> shift) land ff) <<< 8 in
+ let v3 = (v land (mask shift)) <<< 16 in
v3 lor v2 lor v1
) else (
let shift = bits - 24 in
- let v1 = v >> (16+shift) in
- let v2 = ((v >> (8+shift)) land ff) << 8 in
- let v3 = ((v >> shift) land ff) << 16 in
- let v4 = (v land (mask shift)) << 24 in
+ let v1 = v >>> (16+shift) in
+ let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
+ let v3 = ((v >>> shift) land ff) <<< 16 in
+ let v4 = (v land (mask shift)) <<< 24 in
v4 lor v3 lor v2 lor v1
)
*)
let rec map_bytes_be g f v bits =
if bits >= 8 then (
- map_bytes_be g f (v >> 8) (bits-8);
+ map_bytes_be g f (v >>> 8) (bits-8);
let lsb = v land ff in
f (to_int lsb)
) else if bits > 0 then (
if bits >= 8 then (
let lsb = v land ff in
f (to_int lsb);
- map_bytes_le g f (v >> 8) (bits-8)
+ map_bytes_le g f (v >>> 8) (bits-8)
) else if bits > 0 then (
let lsb = v land (mask bits) in
g (to_int lsb) bits
* as possible to the I module above, to make it easier to track
* down bugs.
*)
- let (<<) = Int32.shift_left
- let (>>) = Int32.shift_right_logical
+ let (<<<) = Int32.shift_left
+ let (>>>) = Int32.shift_right_logical
let (land) = Int32.logand
let (lor) = Int32.logor
let lnot = Int32.lognot
(* Create a mask so many bits wide. *)
let mask bits =
if bits < 31 then
- pred (one << bits)
+ pred (one <<< bits)
else if bits = 31 then
max_int
else if bits = 32 then
if bits <= 8 then v
else if bits <= 16 then (
let shift = bits-8 in
- let v1 = v >> shift in
- let v2 = (v land (mask shift)) << 8 in
+ let v1 = v >>> shift in
+ let v2 = (v land (mask shift)) <<< 8 in
v2 lor v1
) else if bits <= 24 then (
let shift = bits - 16 in
- let v1 = v >> (8+shift) in
- let v2 = ((v >> shift) land ff) << 8 in
- let v3 = (v land (mask shift)) << 16 in
+ let v1 = v >>> (8+shift) in
+ let v2 = ((v >>> shift) land ff) <<< 8 in
+ let v3 = (v land (mask shift)) <<< 16 in
v3 lor v2 lor v1
) else (
let shift = bits - 24 in
- let v1 = v >> (16+shift) in
- let v2 = ((v >> (8+shift)) land ff) << 8 in
- let v3 = ((v >> shift) land ff) << 16 in
- let v4 = (v land (mask shift)) << 24 in
+ let v1 = v >>> (16+shift) in
+ let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
+ let v3 = ((v >>> shift) land ff) <<< 16 in
+ let v4 = (v land (mask shift)) <<< 24 in
v4 lor v3 lor v2 lor v1
)
*)
let rec map_bytes_be g f v bits =
if bits >= 8 then (
- map_bytes_be g f (v >> 8) (bits-8);
+ map_bytes_be g f (v >>> 8) (bits-8);
let lsb = v land ff in
f (to_int lsb)
) else if bits > 0 then (
if bits >= 8 then (
let lsb = v land ff in
f (to_int lsb);
- map_bytes_le g f (v >> 8) (bits-8)
+ map_bytes_le g f (v >>> 8) (bits-8)
) else if bits > 0 then (
let lsb = v land (mask bits) in
g (to_int lsb) bits
* as possible to the I/I32 modules above, to make it easier to track
* down bugs.
*)
- let (<<) = Int64.shift_left
- let (>>) = Int64.shift_right_logical
+ let (<<<) = Int64.shift_left
+ let (>>>) = Int64.shift_right_logical
let (land) = Int64.logand
let (lor) = Int64.logor
let lnot = Int64.lognot
(* Create a mask so many bits wide. *)
let mask bits =
if bits < 63 then
- pred (one << bits)
+ pred (one <<< bits)
else if bits = 63 then
max_int
else if bits = 64 then
*)
let rec map_bytes_be g f v bits =
if bits >= 8 then (
- map_bytes_be g f (v >> 8) (bits-8);
+ map_bytes_be g f (v >>> 8) (bits-8);
let lsb = v land ff in
f (to_int lsb)
) else if bits > 0 then (
if bits >= 8 then (
let lsb = v land ff in
f (to_int lsb);
- map_bytes_le g f (v >> 8) (bits-8)
+ map_bytes_le g f (v >>> 8) (bits-8)
) else if bits > 0 then (
let lsb = v land (mask bits) in
g (to_int lsb) bits
let construct_int64_ne_unsigned =
if nativeendian = BigEndian
then construct_int64_be_unsigned
- else (*construct_int64_le_unsigned*)
- fun _ _ _ _ -> failwith "construct_int64_le_unsigned"
+ else construct_int64_le_unsigned
let construct_int64_ee_unsigned = function
| BigEndian -> construct_int64_be_unsigned
- | LittleEndian -> (*construct_int64_le_unsigned*)
- (fun _ _ _ _ -> failwith "construct_int64_le_unsigned")
+ | LittleEndian -> construct_int64_le_unsigned
| NativeEndian -> construct_int64_ne_unsigned
(* Construct from a string of bytes, exact multiple of 8 bits
Buffer.add_bits buf data len
+(* Concatenate bitstrings. *)
+let concat bs =
+ let buf = Buffer.create () in
+ List.iter (construct_bitstring buf) bs;
+ Buffer.contents buf
+
(*----------------------------------------------------------------------*)
(* Extract a string from a bitstring. *)
-
let string_of_bitstring (data, off, len) =
if off land 7 = 0 && len land 7 = 0 then
(* Easy case: everything is byte-aligned. *)
raise exn
(*----------------------------------------------------------------------*)
+(* Comparison. *)
+let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
+ (* In the fully-aligned case, this is reduced to string comparison ... *)
+ if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
+ then (
+ (* ... but we have to do that by hand because the bits may
+ * not extend to the full length of the underlying string.
+ *)
+ let off1 = off1 lsr 3 and off2 = off2 lsr 3
+ and len1 = len1 lsr 3 and len2 = len2 lsr 3 in
+ let rec loop i =
+ if i < len1 && i < len2 then (
+ let c1 = String.unsafe_get data1 (off1 + i)
+ and c2 = String.unsafe_get data2 (off2 + i) in
+ let r = compare c1 c2 in
+ if r <> 0 then r
+ else loop (i+1)
+ )
+ else len1 - len2
+ in
+ loop 0
+ )
+ else (
+ (* Slow/unaligned. *)
+ let str1 = string_of_bitstring bs1
+ and str2 = string_of_bitstring bs2 in
+ let r = String.compare str1 str2 in
+ if r <> 0 then r else len1 - len2
+ )
+
+let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
+ if len1 <> len2 then false
+ else if bs1 = bs2 then true
+ else 0 = compare bs1 bs2
+
+(*----------------------------------------------------------------------*)
+(* Bit get/set functions. *)
+
+let index_out_of_bounds () = invalid_arg "index out of bounds"
+
+let put (data, off, len) n v =
+ if n < 0 || n >= len then index_out_of_bounds ()
+ else (
+ let i = off+n in
+ let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
+ let c = Char.code data.[si] in
+ let c = if v <> 0 then c lor mask else c land (lnot mask) in
+ data.[si] <- Char.unsafe_chr c
+ )
+
+let set bits n = put bits n 1
+
+let clear bits n = put bits n 0
+
+let get (data, off, len) n =
+ if n < 0 || n >= len then index_out_of_bounds ()
+ else (
+ let i = off+n in
+ let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
+ let c = Char.code data.[si] in
+ c land mask
+ )
+
+let is_set bits n = get bits n <> 0
+
+let is_clear bits n = get bits n = 0
+
+(*----------------------------------------------------------------------*)
(* Display functions. *)
let isprint c =