000001| (* Bitstring library.
000002| * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
000003| *
000004| * This library is free software; you can redistribute it and/or
000005| * modify it under the terms of the GNU Lesser General Public
000006| * License as published by the Free Software Foundation; either
000007| * version 2 of the License, or (at your option) any later version,
000008| * with the OCaml linking exception described in COPYING.LIB.
000009| *
000010| * This library is distributed in the hope that it will be useful,
000011| * but WITHOUT ANY WARRANTY; without even the implied warranty of
000012| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
000013| * Lesser General Public License for more details.
000014| *
000015| * You should have received a copy of the GNU Lesser General Public
000016| * License along with this library; if not, write to the Free Software
000017| * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
000018| *
000019| * $Id: bitstring.ml 153 2008-08-26 08:24:31Z richard.wm.jones $
000020| *)
000021|
000022| open Printf
000023|
000024| include Bitstring_types
000025| include Bitstring_config
000026|
000027| (* Enable runtime debug messages. Must also have been enabled
000028| * in pa_bitstring.ml.
000029| *)
000030| let debug = (*[28]*)ref false
000031|
000032| (* Exceptions. *)
000033| exception Construct_failure of string * string * int * int
000034|
000035| (* A bitstring is simply the data itself (as a string), and the
000036| * bitoffset and the bitlength within the string. Note offset/length
000037| * are counted in bits, not bytes.
000038| *)
000039| type bitstring = string * int * int
000040|
000041| (* Functions to create and load bitstrings. *)
000042| let empty_bitstring = (*[28]*)"", 0, 0
000043|
000044| let make_bitstring len c =
000045| (*[1197538]*)if len >= 0 then (*[1197538]*)String.make ((len+7) lsr 3) c, 0, len
000046| else
000047| (*[0]*)invalid_arg (
000048| sprintf "make_bitstring/create_bitstring: len %d < 0" len
000049| )
000050|
000051| let create_bitstring len = (*[1]*)make_bitstring len '\000'
000052|
000053| let zeroes_bitstring = (*[28]*)create_bitstring
000054|
000055| let ones_bitstring len = (*[1197537]*)make_bitstring len '\xff'
000056|
000057| let bitstring_of_string str = (*[2]*)str, 0, String.length str lsl 3
000058|
000059| let bitstring_of_chan chan =
000060| (*[0]*)let tmpsize = 16384 in
000061| (*[0]*)let buf = Buffer.create tmpsize in
000062| (*[0]*)let tmp = String.create tmpsize in
000063| (*[0]*)let n = ref 0 in
000064| (*[0]*)while (*[0]*)n := input chan tmp 0 tmpsize; !(*[0]*)n > 0 do
000065| (*[0]*)Buffer.add_substring buf tmp 0 !n;
000066| done;
000067| (*[0]*)Buffer.contents buf, 0, Buffer.length buf lsl 3
000068|
000069| let bitstring_of_chan_max chan max =
000070| (*[0]*)let tmpsize = 16384 in
000071| (*[0]*)let buf = Buffer.create tmpsize in
000072| (*[0]*)let tmp = String.create tmpsize in
000073| (*[0]*)let len = ref 0 in
000074| (*[0]*)let rec loop () =
000075| (*[0]*)if !len < max then (
000076| (*[0]*)let r = min tmpsize (max - !len) in
000077| (*[0]*)let n = input chan tmp 0 r in
000078| (*[0]*)if n > 0 then (
000079| (*[0]*)Buffer.add_substring buf tmp 0 n;
000080| (*[0]*)len (*[0]*):= !len + n;
000081| (*[0]*)loop ()
000082| )
000083| )
000084| in
000085| (*[0]*)loop (*[0]*)();
000086| (*[0]*)Buffer.contents buf, 0, !len lsl 3
000087|
000088| let bitstring_of_file_descr fd =
000089| (*[0]*)let tmpsize = 16384 in
000090| (*[0]*)let buf = Buffer.create tmpsize in
000091| (*[0]*)let tmp = String.create tmpsize in
000092| (*[0]*)let n = ref 0 in
000093| (*[0]*)while (*[0]*)n := Unix.read fd tmp 0 tmpsize; !(*[0]*)n > 0 do
000094| (*[0]*)Buffer.add_substring buf tmp 0 !n;
000095| done;
000096| (*[0]*)Buffer.contents buf, 0, Buffer.length buf lsl 3
000097|
000098| let bitstring_of_file_descr_max fd max =
000099| (*[0]*)let tmpsize = 16384 in
000100| (*[0]*)let buf = Buffer.create tmpsize in
000101| (*[0]*)let tmp = String.create tmpsize in
000102| (*[0]*)let len = ref 0 in
000103| (*[0]*)let rec loop () =
000104| (*[0]*)if !len < max then (
000105| (*[0]*)let r = min tmpsize (max - !len) in
000106| (*[0]*)let n = Unix.read fd tmp 0 r in
000107| (*[0]*)if n > 0 then (
000108| (*[0]*)Buffer.add_substring buf tmp 0 n;
000109| (*[0]*)len (*[0]*):= !len + n;
000110| (*[0]*)loop ()
000111| )
000112| )
000113| in
000114| (*[0]*)loop (*[0]*)();
000115| (*[0]*)Buffer.contents buf, 0, !len lsl 3
000116|
000117| let bitstring_of_file fname =
000118| (*[0]*)let chan = open_in_bin fname in
000119| (*[0]*)try
000120| (*[0]*)let bs = bitstring_of_chan chan in
000121| (*[0]*)close_in (*[0]*)chan;
000122| (*[0]*)bs
000123| with exn ->
000124| (*[0]*)close_in (*[0]*)chan;
000125| (*[0]*)raise exn
000126|
000127| let bitstring_length (_, _, len) = (*[1523677]*)len
000128|
000129| let subbitstring (data, off, len) off' len' =
000130| (*[0]*)let off = off + off' in
000131| (*[0]*)if len < off' + len' then (*[0]*)invalid_arg "subbitstring";
000132| ((*[0]*)data, off, len')
000133|
000134| let dropbits n (data, off, len) =
000135| (*[335487]*)let off = off + n in
000136| (*[335487]*)let len = len - n in
000137| (*[335487]*)if len < 0 then (*[0]*)invalid_arg "dropbits";
000138| ((*[335487]*)data, off, len)
000139|
000140| let takebits n (data, off, len) =
000141| (*[0]*)if len < n then (*[0]*)invalid_arg "takebits";
000142| ((*[0]*)data, off, n)
000143|
000144| (*----------------------------------------------------------------------*)
000145| (* Bitwise functions.
000146| *
000147| * We try to isolate all bitwise functions within these modules.
000148| *)
000149|
000150| module I = struct
000151| (* Bitwise operations on ints. Note that we assume int <= 31 bits. *)
000152| external (<<<) : int -> int -> int = "%lslint"
000153| external (>>>) : int -> int -> int = "%lsrint"
000154| external to_int : int -> int = "%identity"
000155| let zero = (*[28]*)0
000156| let one = (*[28]*)1
000157| let minus_one = (*[28]*)-1
000158| let ff = (*[28]*)0xff
000159|
000160| (* Create a mask 0-31 bits wide. *)
000161| let mask bits =
000162| (*[2]*)if bits < 30 then
000163| ((*[2]*)one <<< bits) - 1
000164| else (*[0]*)if bits = 30 then
000165| (*[0]*)max_int
000166| else (*[0]*)if bits = 31 then
000167| (*[0]*)minus_one
000168| else
000169| (*[0]*)invalid_arg "Bitstring.I.mask"
000170|
000171| (* Byte swap an int of a given size. *)
000172| let byteswap v bits =
000173| (*[0]*)if bits <= 8 then (*[0]*)v
000174| else (*[0]*)if bits <= 16 then (
000175| (*[0]*)let shift = bits-8 in
000176| (*[0]*)let v1 = v >>> shift in
000177| (*[0]*)let v2 = ((v land (mask shift)) <<< 8) in
000178| v2 (*[0]*)lor v1
000179| ) else (*[0]*)if bits <= 24 then (
000180| (*[0]*)let shift = bits - 16 in
000181| (*[0]*)let v1 = v >>> (8+shift) in
000182| (*[0]*)let v2 = ((v >>> shift) land ff) <<< 8 in
000183| (*[0]*)let v3 = (v land (mask shift)) <<< 16 in
000184| v3 lor v2 (*[0]*)lor v1
000185| ) else (
000186| (*[0]*)let shift = bits - 24 in
000187| (*[0]*)let v1 = v >>> (16+shift) in
000188| (*[0]*)let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
000189| (*[0]*)let v3 = ((v >>> shift) land ff) <<< 16 in
000190| (*[0]*)let v4 = (v land (mask shift)) <<< 24 in
000191| v4 lor v3 lor v2 (*[0]*)lor v1
000192| )
000193|
000194| (* Check a value is in range 0 .. 2^bits-1. *)
000195| let range_unsigned v bits =
000196| (*[2]*)let mask = lnot (mask bits) in
000197| (v (*[2]*)land mask) = zero
000198|
000199| (* Call function g on the top bits, then f on each full byte
000200| * (big endian - so start at top).
000201| *)
000202| let rec map_bytes_be g f v bits =
000203| (*[6]*)if bits >= 8 then (
000204| (*[4]*)map_bytes_be g f (v >>> 8) (*[4]*)(bits-8);
000205| (*[4]*)let lsb = v land ff in
000206| (*[4]*)f (to_int lsb)
000207| ) else (*[2]*)if bits > 0 then (
000208| (*[0]*)let lsb = v land (mask bits) in
000209| (*[0]*)g (to_int lsb) bits
000210| )
000211|
000212| (* Call function g on the top bits, then f on each full byte
000213| * (little endian - so start at root).
000214| *)
000215| let rec map_bytes_le g f v bits =
000216| (*[0]*)if bits >= 8 then (
000217| (*[0]*)let lsb = v land ff in
000218| (*[0]*)f (*[0]*)(to_int lsb);
000219| (*[0]*)map_bytes_le g f (v >>> 8) (bits-8)
000220| ) else (*[0]*)if bits > 0 then (
000221| (*[0]*)let lsb = v land (mask bits) in
000222| (*[0]*)g (to_int lsb) bits
000223| )
000224| end
000225|
000226| module I32 = struct
000227| (* Bitwise operations on int32s. Note we try to keep it as similar
000228| * as possible to the I module above, to make it easier to track
000229| * down bugs.
000230| *)
000231| let (<<<) = (*[28]*)Int32.shift_left
000232| let (>>>) = (*[28]*)Int32.shift_right_logical
000233| let (land) = (*[28]*)Int32.logand
000234| let (lor) = (*[28]*)Int32.logor
000235| let lnot = (*[28]*)Int32.lognot
000236| let pred = (*[28]*)Int32.pred
000237| let max_int = (*[28]*)Int32.max_int
000238| let to_int = (*[28]*)Int32.to_int
000239| let zero = (*[28]*)Int32.zero
000240| let one = (*[28]*)Int32.one
000241| let minus_one = (*[28]*)Int32.minus_one
000242| let ff = (*[28]*)0xff_l
000243|
000244| (* Create a mask so many bits wide. *)
000245| let mask bits =
000246| (*[12]*)if bits < 31 then
000247| (*[12]*)pred (one <<< bits)
000248| else (*[0]*)if bits = 31 then
000249| (*[0]*)max_int
000250| else (*[0]*)if bits = 32 then
000251| (*[0]*)minus_one
000252| else
000253| (*[0]*)invalid_arg "Bitstring.I32.mask"
000254|
000255| (* Byte swap an int of a given size. *)
000256| let byteswap v bits =
000257| (*[12]*)if bits <= 8 then (*[0]*)v
000258| else (*[12]*)if bits <= 16 then (
000259| (*[0]*)let shift = bits-8 in
000260| (*[0]*)let v1 = v >>> shift in
000261| (*[0]*)let v2 = (v land (mask shift)) <<< 8 in
000262| v2 (*[0]*)lor v1
000263| ) else (*[12]*)if bits <= 24 then (
000264| (*[0]*)let shift = bits - 16 in
000265| (*[0]*)let v1 = v >>> (8+shift) in
000266| (*[0]*)let v2 = ((v >>> shift) land ff) <<< 8 in
000267| (*[0]*)let v3 = (v land (mask shift)) <<< 16 in
000268| v3 lor v2 (*[0]*)lor v1
000269| ) else (
000270| (*[12]*)let shift = bits - 24 in
000271| (*[12]*)let v1 = v >>> (16+shift) in
000272| (*[12]*)let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
000273| (*[12]*)let v3 = ((v >>> shift) land ff) <<< 16 in
000274| (*[12]*)let v4 = (v land (mask shift)) <<< 24 in
000275| v4 lor v3 lor v2 (*[12]*)lor v1
000276| )
000277|
000278| (* Check a value is in range 0 .. 2^bits-1. *)
000279| let range_unsigned v bits =
000280| (*[0]*)let mask = lnot (mask bits) in
000281| (v (*[0]*)land mask) = zero
000282|
000283| (* Call function g on the top bits, then f on each full byte
000284| * (big endian - so start at top).
000285| *)
000286| let rec map_bytes_be g f v bits =
000287| (*[0]*)if bits >= 8 then (
000288| (*[0]*)map_bytes_be g f (v >>> 8) (*[0]*)(bits-8);
000289| (*[0]*)let lsb = v land ff in
000290| (*[0]*)f (to_int lsb)
000291| ) else (*[0]*)if bits > 0 then (
000292| (*[0]*)let lsb = v land (mask bits) in
000293| (*[0]*)g (to_int lsb) bits
000294| )
000295|
000296| (* Call function g on the top bits, then f on each full byte
000297| * (little endian - so start at root).
000298| *)
000299| let rec map_bytes_le g f v bits =
000300| (*[0]*)if bits >= 8 then (
000301| (*[0]*)let lsb = v land ff in
000302| (*[0]*)f (*[0]*)(to_int lsb);
000303| (*[0]*)map_bytes_le g f (v >>> 8) (bits-8)
000304| ) else (*[0]*)if bits > 0 then (
000305| (*[0]*)let lsb = v land (mask bits) in
000306| (*[0]*)g (to_int lsb) bits
000307| )
000308| end
000309|
000310| module I64 = struct
000311| (* Bitwise operations on int64s. Note we try to keep it as similar
000312| * as possible to the I/I32 modules above, to make it easier to track
000313| * down bugs.
000314| *)
000315| let (<<<) = (*[28]*)Int64.shift_left
000316| let (>>>) = (*[28]*)Int64.shift_right_logical
000317| let (land) = (*[28]*)Int64.logand
000318| let (lor) = (*[28]*)Int64.logor
000319| let lnot = (*[28]*)Int64.lognot
000320| let pred = (*[28]*)Int64.pred
000321| let max_int = (*[28]*)Int64.max_int
000322| let to_int = (*[28]*)Int64.to_int
000323| let zero = (*[28]*)Int64.zero
000324| let one = (*[28]*)Int64.one
000325| let minus_one = (*[28]*)Int64.minus_one
000326| let ff = (*[28]*)0xff_L
000327|
000328| (* Create a mask so many bits wide. *)
000329| let mask bits =
000330| (*[669050]*)if bits < 63 then
000331| (*[664100]*)pred (one <<< bits)
000332| else (*[4950]*)if bits = 63 then
000333| (*[4950]*)max_int
000334| else (*[0]*)if bits = 64 then
000335| (*[0]*)minus_one
000336| else
000337| (*[0]*)invalid_arg "Bitstring.I64.mask"
000338|
000339| (* Byte swap an int of a given size. *)
000340| (* let byteswap v bits = *)
000341|
000342| (* Check a value is in range 0 .. 2^bits-1. *)
000343| let range_unsigned v bits =
000344| (*[351850]*)let mask = lnot (mask bits) in
000345| (v (*[351850]*)land mask) = zero
000346|
000347| (* Call function g on the top bits, then f on each full byte
000348| * (big endian - so start at top).
000349| *)
000350| let rec map_bytes_be g f v bits =
000351| (*[1460650]*)if bits >= 8 then (
000352| (*[1108800]*)map_bytes_be g f (v >>> 8) (*[1108800]*)(bits-8);
000353| (*[1108800]*)let lsb = v land ff in
000354| (*[1108800]*)f (to_int lsb)
000355| ) else (*[34650]*)if bits > 0 then (
000356| (*[317200]*)let lsb = v land (mask bits) in
000357| (*[317200]*)g (to_int lsb) bits
000358| )
000359|
000360| (* Call function g on the top bits, then f on each full byte
000361| * (little endian - so start at root).
000362| *)
000363| let rec map_bytes_le g f v bits =
000364| (*[0]*)if bits >= 8 then (
000365| (*[0]*)let lsb = v land ff in
000366| (*[0]*)f (*[0]*)(to_int lsb);
000367| (*[0]*)map_bytes_le g f (v >>> 8) (bits-8)
000368| ) else (*[0]*)if bits > 0 then (
000369| (*[0]*)let lsb = v land (mask bits) in
000370| (*[0]*)g (to_int lsb) bits
000371| )
000372| end
000373|
000374| (*----------------------------------------------------------------------*)
000375| (* Extraction functions.
000376| *
000377| * NB: internal functions, called from the generated macros, and
000378| * the parameters should have been checked for sanity already).
000379| *)
000380|
000381| (* Extract and convert to numeric. A single bit is returned as
000382| * a boolean. There are no endianness or signedness considerations.
000383| *)
000384| let extract_bit data off len _ = (* final param is always 1 *)
000385| (*[2515152]*)let byteoff = off lsr 3 in
000386| (*[2515152]*)let bitmask = 1 lsl (7 - (off land 7)) in
000387| (*[2515152]*)let b = Char.code data.[byteoff] land bitmask <> 0 in
000388| (*[2515152]*)b (*, off+1, len-1*)
000389|
000390| (* Returns 8 bit unsigned aligned bytes from the string.
000391| * If the string ends then this returns 0's.
000392| *)
000393| let _get_byte data byteoff strlen =
000394| (*[9813846]*)if strlen > byteoff then (*[9247619]*)Char.code data.[byteoff] else (*[566227]*)0
000395| let _get_byte32 data byteoff strlen =
000396| (*[72]*)if strlen > byteoff then (*[72]*)Int32.of_int (Char.code data.[byteoff]) else (*[0]*)0l
000397| let _get_byte64 data byteoff strlen =
000398| (*[1626200]*)if strlen > byteoff then (*[1517793]*)Int64.of_int (Char.code data.[byteoff]) else (*[108407]*)0L
000399|
000400| (* Extract [2..8] bits. Because the result fits into a single
000401| * byte we don't have to worry about endianness, only signedness.
000402| *)
000403| let extract_char_unsigned data off len flen =
000404| (*[5009970]*)let byteoff = off lsr 3 in
000405|
000406| (* Optimize the common (byte-aligned) case. *)
000407| (*[5009970]*)if off land 7 = 0 then (
000408| (*[103047]*)let byte = Char.code data.[byteoff] in
000409| byte (*[103047]*)lsr (8 - flen) (*, off+flen, len-flen*)
000410| ) else (
000411| (* Extract the 16 bits at byteoff and byteoff+1 (note that the
000412| * second byte might not exist in the original string).
000413| *)
000414| (*[4906923]*)let strlen = String.length data in
000415|
000416| (*[4906923]*)let word =
000417| (_get_byte data byteoff strlen lsl 8) +
000418| _get_byte data (byteoff+1) strlen in
000419|
000420| (* Mask off the top bits. *)
000421| (*[4906923]*)let bitmask = (1 lsl (16 - (off land 7))) - 1 in
000422| (*[4906923]*)let word = word land bitmask in
000423| (* Shift right to get rid of the bottom bits. *)
000424| (*[4906923]*)let shift = 16 - ((off land 7) + flen) in
000425| (*[4906923]*)let word = word lsr shift in
000426|
000427| (*[4906923]*)word (*, off+flen, len-flen*)
000428| )
000429|
000430| (* Extract [9..31] bits. We have to consider endianness and signedness. *)
000431| let extract_int_be_unsigned data off len flen =
000432| (*[0]*)let byteoff = off lsr 3 in
000433|
000434| (*[0]*)let strlen = String.length data in
000435|
000436| (*[0]*)let word =
000437| (* Optimize the common (byte-aligned) case. *)
000438| if off land 7 = 0 then (
000439| (*[0]*)let word =
000440| (_get_byte data byteoff strlen lsl 23) +
000441| (_get_byte data (byteoff+1) strlen lsl 15) +
000442| (_get_byte data (byteoff+2) strlen lsl 7) +
000443| (_get_byte data (byteoff+3) strlen lsr 1) in
000444| word (*[0]*)lsr (31 - flen)
000445| ) else (*[0]*)if flen <= 24 then (
000446| (* Extract the 31 bits at byteoff .. byteoff+3. *)
000447| (*[0]*)let word =
000448| (_get_byte data byteoff strlen lsl 23) +
000449| (_get_byte data (byteoff+1) strlen lsl 15) +
000450| (_get_byte data (byteoff+2) strlen lsl 7) +
000451| (_get_byte data (byteoff+3) strlen lsr 1) in
000452| (* Mask off the top bits. *)
000453| (*[0]*)let bitmask = (1 lsl (31 - (off land 7))) - 1 in
000454| (*[0]*)let word = word land bitmask in
000455| (* Shift right to get rid of the bottom bits. *)
000456| (*[0]*)let shift = 31 - ((off land 7) + flen) in
000457| word (*[0]*)lsr shift
000458| ) else (
000459| (* Extract the next 31 bits, slow method. *)
000460| (*[0]*)let word =
000461| let c0 = extract_char_unsigned data off len 8
000462| and off = off + 8 and len = len - 8 in
000463| (*[0]*)let c1 = extract_char_unsigned data off len 8
000464| and off = off + 8 and len = len - 8 in
000465| (*[0]*)let c2 = extract_char_unsigned data off len 8
000466| and off = off + 8 and len = len - 8 in
000467| (*[0]*)let c3 = extract_char_unsigned data off len 7 in
000468| (c0 (*[0]*)lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
000469| word (*[0]*)lsr (31 - flen)
000470| ) in
000471| (*[0]*)word (*, off+flen, len-flen*)
000472|
000473| let extract_int_le_unsigned data off len flen =
000474| (*[0]*)let v = extract_int_be_unsigned data off len flen in
000475| (*[0]*)let v = I.byteswap v flen in
000476| (*[0]*)v
000477|
000478| let extract_int_ne_unsigned =
000479| (*[28]*)if nativeendian = BigEndian
000480| then (*[0]*)extract_int_be_unsigned
000481| else (*[28]*)extract_int_le_unsigned
000482|
000483| let extract_int_ee_unsigned = function
000484| | BigEndian -> (*[0]*)extract_int_be_unsigned
000485| | LittleEndian -> (*[0]*)extract_int_le_unsigned
000486| | NativeEndian -> (*[0]*)extract_int_ne_unsigned
000487|
000488| let _make_int32_be c0 c1 c2 c3 =
000489| (*[18]*)Int32.logor
000490| (Int32.logor
000491| (Int32.logor
000492| (Int32.shift_left c0 24)
000493| (Int32.shift_left c1 16))
000494| (Int32.shift_left c2 8))
000495| c3
000496|
000497| let _make_int32_le c0 c1 c2 c3 =
000498| (*[0]*)Int32.logor
000499| (Int32.logor
000500| (Int32.logor
000501| (Int32.shift_left c3 24)
000502| (Int32.shift_left c2 16))
000503| (Int32.shift_left c1 8))
000504| c0
000505|
000506| (* Extract exactly 32 bits. We have to consider endianness and signedness. *)
000507| let extract_int32_be_unsigned data off len flen =
000508| (*[18]*)let byteoff = off lsr 3 in
000509|
000510| (*[18]*)let strlen = String.length data in
000511|
000512| (*[18]*)let word =
000513| (* Optimize the common (byte-aligned) case. *)
000514| if off land 7 = 0 then (
000515| (*[18]*)let word =
000516| let c0 = _get_byte32 data byteoff strlen in
000517| (*[18]*)let c1 = _get_byte32 data (byteoff+1) strlen in
000518| (*[18]*)let c2 = _get_byte32 data (byteoff+2) strlen in
000519| (*[18]*)let c3 = _get_byte32 data (byteoff+3) strlen in
000520| (*[18]*)_make_int32_be c0 c1 c2 c3 in
000521| (*[18]*)Int32.shift_right_logical word (32 - flen)
000522| ) else (
000523| (* Extract the next 32 bits, slow method. *)
000524| (*[0]*)let word =
000525| let c0 = extract_char_unsigned data off len 8
000526| and off = off + 8 and len = len - 8 in
000527| (*[0]*)let c1 = extract_char_unsigned data off len 8
000528| and off = off + 8 and len = len - 8 in
000529| (*[0]*)let c2 = extract_char_unsigned data off len 8
000530| and off = off + 8 and len = len - 8 in
000531| (*[0]*)let c3 = extract_char_unsigned data off len 8 in
000532| (*[0]*)let c0 = Int32.of_int c0 in
000533| (*[0]*)let c1 = Int32.of_int c1 in
000534| (*[0]*)let c2 = Int32.of_int c2 in
000535| (*[0]*)let c3 = Int32.of_int c3 in
000536| (*[0]*)_make_int32_be c0 c1 c2 c3 in
000537| (*[0]*)Int32.shift_right_logical word (32 - flen)
000538| ) in
000539| (*[18]*)word (*, off+flen, len-flen*)
000540|
000541| let extract_int32_le_unsigned data off len flen =
000542| (*[12]*)let v = extract_int32_be_unsigned data off len flen in
000543| (*[12]*)let v = I32.byteswap v flen in
000544| (*[12]*)v
000545|
000546| let extract_int32_ne_unsigned =
000547| (*[28]*)if nativeendian = BigEndian
000548| then (*[0]*)extract_int32_be_unsigned
000549| else (*[28]*)extract_int32_le_unsigned
000550|
000551| let extract_int32_ee_unsigned = function
000552| | BigEndian -> (*[6]*)extract_int32_be_unsigned
000553| | LittleEndian -> (*[6]*)extract_int32_le_unsigned
000554| | NativeEndian -> (*[6]*)extract_int32_ne_unsigned
000555|
000556| let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
000557| (*[657463]*)Int64.logor
000558| (Int64.logor
000559| (Int64.logor
000560| (Int64.logor
000561| (Int64.logor
000562| (Int64.logor
000563| (Int64.logor
000564| (Int64.shift_left c0 56)
000565| (Int64.shift_left c1 48))
000566| (Int64.shift_left c2 40))
000567| (Int64.shift_left c3 32))
000568| (Int64.shift_left c4 24))
000569| (Int64.shift_left c5 16))
000570| (Int64.shift_left c6 8))
000571| c7
000572|
000573| let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
000574| (*[0]*)_make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
000575|
000576| (* Extract [1..64] bits. We have to consider endianness and signedness. *)
000577| let extract_int64_be_unsigned data off len flen =
000578| (*[657463]*)let byteoff = off lsr 3 in
000579|
000580| (*[657463]*)let strlen = String.length data in
000581|
000582| (*[657463]*)let word =
000583| (* Optimize the common (byte-aligned) case. *)
000584| if off land 7 = 0 then (
000585| (*[203275]*)let word =
000586| let c0 = _get_byte64 data byteoff strlen in
000587| (*[203275]*)let c1 = _get_byte64 data (byteoff+1) strlen in
000588| (*[203275]*)let c2 = _get_byte64 data (byteoff+2) strlen in
000589| (*[203275]*)let c3 = _get_byte64 data (byteoff+3) strlen in
000590| (*[203275]*)let c4 = _get_byte64 data (byteoff+4) strlen in
000591| (*[203275]*)let c5 = _get_byte64 data (byteoff+5) strlen in
000592| (*[203275]*)let c6 = _get_byte64 data (byteoff+6) strlen in
000593| (*[203275]*)let c7 = _get_byte64 data (byteoff+7) strlen in
000594| (*[203275]*)_make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
000595| (*[203275]*)Int64.shift_right_logical word (64 - flen)
000596| ) else (
000597| (* Extract the next 64 bits, slow method. *)
000598| (*[454188]*)let word =
000599| let c0 = extract_char_unsigned data off len 8
000600| and off = off + 8 and len = len - 8 in
000601| (*[454188]*)let c1 = extract_char_unsigned data off len 8
000602| and off = off + 8 and len = len - 8 in
000603| (*[454188]*)let c2 = extract_char_unsigned data off len 8
000604| and off = off + 8 and len = len - 8 in
000605| (*[454188]*)let c3 = extract_char_unsigned data off len 8
000606| and off = off + 8 and len = len - 8 in
000607| (*[454188]*)let c4 = extract_char_unsigned data off len 8
000608| and off = off + 8 and len = len - 8 in
000609| (*[454188]*)let c5 = extract_char_unsigned data off len 8
000610| and off = off + 8 and len = len - 8 in
000611| (*[454188]*)let c6 = extract_char_unsigned data off len 8
000612| and off = off + 8 and len = len - 8 in
000613| (*[454188]*)let c7 = extract_char_unsigned data off len 8 in
000614| (*[454188]*)let c0 = Int64.of_int c0 in
000615| (*[454188]*)let c1 = Int64.of_int c1 in
000616| (*[454188]*)let c2 = Int64.of_int c2 in
000617| (*[454188]*)let c3 = Int64.of_int c3 in
000618| (*[454188]*)let c4 = Int64.of_int c4 in
000619| (*[454188]*)let c5 = Int64.of_int c5 in
000620| (*[454188]*)let c6 = Int64.of_int c6 in
000621| (*[454188]*)let c7 = Int64.of_int c7 in
000622| (*[454188]*)_make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
000623| (*[454188]*)Int64.shift_right_logical word (64 - flen)
000624| ) in
000625| (*[657463]*)word (*, off+flen, len-flen*)
000626|
000627| let extract_int64_le_unsigned data off len flen =
000628| (*[0]*)let byteoff = off lsr 3 in
000629|
000630| (*[0]*)let strlen = String.length data in
000631|
000632| (*[0]*)let word =
000633| (* Optimize the common (byte-aligned) case. *)
000634| if off land 7 = 0 then (
000635| (*[0]*)let word =
000636| let c0 = _get_byte64 data byteoff strlen in
000637| (*[0]*)let c1 = _get_byte64 data (byteoff+1) strlen in
000638| (*[0]*)let c2 = _get_byte64 data (byteoff+2) strlen in
000639| (*[0]*)let c3 = _get_byte64 data (byteoff+3) strlen in
000640| (*[0]*)let c4 = _get_byte64 data (byteoff+4) strlen in
000641| (*[0]*)let c5 = _get_byte64 data (byteoff+5) strlen in
000642| (*[0]*)let c6 = _get_byte64 data (byteoff+6) strlen in
000643| (*[0]*)let c7 = _get_byte64 data (byteoff+7) strlen in
000644| (*[0]*)_make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
000645| (*[0]*)Int64.logand word (I64.mask flen)
000646| ) else (
000647| (* Extract the next 64 bits, slow method. *)
000648| (*[0]*)let word =
000649| let c0 = extract_char_unsigned data off len 8
000650| and off = off + 8 and len = len - 8 in
000651| (*[0]*)let c1 = extract_char_unsigned data off len 8
000652| and off = off + 8 and len = len - 8 in
000653| (*[0]*)let c2 = extract_char_unsigned data off len 8
000654| and off = off + 8 and len = len - 8 in
000655| (*[0]*)let c3 = extract_char_unsigned data off len 8
000656| and off = off + 8 and len = len - 8 in
000657| (*[0]*)let c4 = extract_char_unsigned data off len 8
000658| and off = off + 8 and len = len - 8 in
000659| (*[0]*)let c5 = extract_char_unsigned data off len 8
000660| and off = off + 8 and len = len - 8 in
000661| (*[0]*)let c6 = extract_char_unsigned data off len 8
000662| and off = off + 8 and len = len - 8 in
000663| (*[0]*)let c7 = extract_char_unsigned data off len 8 in
000664| (*[0]*)let c0 = Int64.of_int c0 in
000665| (*[0]*)let c1 = Int64.of_int c1 in
000666| (*[0]*)let c2 = Int64.of_int c2 in
000667| (*[0]*)let c3 = Int64.of_int c3 in
000668| (*[0]*)let c4 = Int64.of_int c4 in
000669| (*[0]*)let c5 = Int64.of_int c5 in
000670| (*[0]*)let c6 = Int64.of_int c6 in
000671| (*[0]*)let c7 = Int64.of_int c7 in
000672| (*[0]*)_make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
000673| (*[0]*)Int64.logand word (I64.mask flen)
000674| ) in
000675| (*[0]*)word (*, off+flen, len-flen*)
000676|
000677| let extract_int64_ne_unsigned =
000678| (*[28]*)if nativeendian = BigEndian
000679| then (*[0]*)extract_int64_be_unsigned
000680| else (*[28]*)extract_int64_le_unsigned
000681|
000682| let extract_int64_ee_unsigned = function
000683| | BigEndian -> (*[0]*)extract_int64_be_unsigned
000684| | LittleEndian -> (*[0]*)extract_int64_le_unsigned
000685| | NativeEndian -> (*[0]*)extract_int64_ne_unsigned
000686|
000687| external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
000688|
000689| external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
000690|
000691| external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
000692|
000693| external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
000694|
000695| external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
000696|
000697| external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
000698|
000699| (*
000700| external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
000701|
000702| external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
000703|
000704| external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
000705|
000706| external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
000707|
000708| external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
000709|
000710| external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
000711| *)
000712|
000713| external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc"
000714|
000715| external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc"
000716|
000717| external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc"
000718|
000719| external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc"
000720|
000721| external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc"
000722|
000723| external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc"
000724|
000725| (*
000726| external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc"
000727|
000728| external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc"
000729|
000730| external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc"
000731|
000732| external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc"
000733|
000734| external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc"
000735|
000736| external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc"
000737|
000738| external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc"
000739|
000740| external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc"
000741|
000742| external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc"
000743|
000744| external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc"
000745|
000746| external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc"
000747|
000748| external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc"
000749|
000750| external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc"
000751|
000752| external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc"
000753|
000754| external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc"
000755|
000756| external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc"
000757|
000758| external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc"
000759|
000760| external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc"
000761| *)
000762|
000763| external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc"
000764|
000765| external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc"
000766|
000767| external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc"
000768|
000769| external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc"
000770|
000771| external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc"
000772|
000773| external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc"
000774|
000775| (*----------------------------------------------------------------------*)
000776| (* Constructor functions. *)
000777|
000778| module Buffer = struct
000779| type t = {
000780| buf : Buffer.t;
000781| mutable len : int; (* Length in bits. *)
000782| (* Last byte in the buffer (if len is not aligned). We store
000783| * it outside the buffer because buffers aren't mutable.
000784| *)
000785| mutable last : int;
000786| }
000787|
000788| let create () =
000789| (* XXX We have almost enough information in the generator to
000790| * choose a good initial size.
000791| *)
000792| (*[452559]*){ buf = Buffer.create 128; len = 0; last = 0 }
000793|
000794| let contents { buf = buf; len = len; last = last } =
000795| (*[452559]*)let data =
000796| if len land 7 = 0 then
000797| (*[58202]*)Buffer.contents buf
000798| else
000799| (*[394357]*)Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
000800| (*[452559]*)data, 0, len
000801|
000802| (* Add exactly 8 bits. *)
000803| let add_byte ({ buf = buf; len = len; last = last } as t) byte =
000804| (*[8142106]*)if (*[8142106]*)byte < 0 || (*[8142106]*)byte > 255 then (*[0]*)invalid_arg "Bitstring.Buffer.add_byte";
000805| (*[8142106]*)let shift = len land 7 in
000806| (*[8142106]*)if shift = 0 then
000807| (* Target buffer is byte-aligned. *)
000808| (*[519924]*)Buffer.add_char buf (Char.chr byte)
000809| else (
000810| (* Target buffer is unaligned. 'last' is meaningful. *)
000811| (*[7622182]*)let first = byte lsr shift in
000812| (*[7622182]*)let second = (byte lsl (8 - shift)) land 0xff in
000813| (*[7622182]*)Buffer.add_char buf (*[7622182]*)(Char.chr (last lor first));
000814| (*[7622182]*)t.last <- second
000815| );
000816| (*[8142106]*)t.len <- t.len + 8
000817|
000818| (* Add exactly 1 bit. *)
000819| let add_bit ({ buf = buf; len = len; last = last } as t) bit =
000820| (*[4192108]*)let shift = 7 - (len land 7) in
000821| (*[4192108]*)if shift > 0 then
000822| (* Somewhere in the middle of 'last'. *)
000823| (*[3692102]*)t.last <- last lor ((if bit then (*[2903776]*)1 else (*[788326]*)0) lsl shift)
000824| else (
000825| (* Just a single spare bit in 'last'. *)
000826| (*[500006]*)let last = last lor if bit then (*[391339]*)1 else (*[108667]*)0 in
000827| (*[500006]*)Buffer.add_char buf (*[500006]*)(Char.chr last);
000828| (*[500006]*)t.last <- 0
000829| );
000830| (*[4192108]*)t.len <- len + 1
000831|
000832| (* Add a small number of bits (definitely < 8). This uses a loop
000833| * to call add_bit so it's slow.
000834| *)
000835| let _add_bits t c slen =
000836| (*[317200]*)if (*[317200]*)slen < 1 || (*[317200]*)slen >= 8 then (*[0]*)invalid_arg "Bitstring.Buffer._add_bits";
000837| (*[317200]*)for i = slen-1 downto 0 do
000838| (*[1268791]*)let bit = c land (1 lsl i) <> 0 in
000839| (*[1268791]*)add_bit t bit
000840| done
000841|
000842| let add_bits ({ buf = buf; len = len } as t) str slen =
000843| (*[23330]*)if slen > 0 then (
000844| (*[1272292]*)if len land 7 = 0 then (
000845| (*[525820]*)if slen land 7 = 0 then
000846| (* Common case - everything is byte-aligned. *)
000847| (*[58261]*)Buffer.add_substring buf str 0 (slen lsr 3)
000848| else (
000849| (* Target buffer is aligned. Copy whole bytes then leave the
000850| * remaining bits in last.
000851| *)
000852| (*[467559]*)let slenbytes = slen lsr 3 in
000853| (*[335078]*)if slenbytes > 0 then (*[132481]*)Buffer.add_substring buf str 0 slenbytes;
000854| (*[467559]*)let last = Char.code str.[slenbytes] in (* last char *)
000855| (*[467559]*)let mask = 0xff lsl (8 - (slen land 7)) in
000856| (*[467559]*)t.last <- last land mask
000857| );
000858| (*[525820]*)t.len <- len + slen
000859| ) else (
000860| (* Target buffer is unaligned. Copy whole bytes using
000861| * add_byte which knows how to deal with an unaligned
000862| * target buffer, then call add_bit for the remaining < 8 bits.
000863| *
000864| * XXX This is going to be dog-slow.
000865| *)
000866| (*[746472]*)let slenbytes = slen lsr 3 in
000867| (*[746472]*)for i = 0 to slenbytes-1 do
000868| (*[5829660]*)let byte = Char.code str.[i] in
000869| (*[5829660]*)add_byte t byte
000870| done;
000871| (*[746472]*)let bitsleft = slen - (slenbytes lsl 3) in
000872| (*[136479]*)if bitsleft > 0 then (
000873| (*[609993]*)let c = Char.code str.[slenbytes] in
000874| (*[609993]*)for i = 0 to bitsleft - 1 do
000875| (*[2423817]*)let bit = c land (0x80 lsr i) <> 0 in
000876| (*[2423817]*)add_bit t bit
000877| done
000878| )
000879| );
000880| )
000881| end
000882|
000883| (* Construct a single bit. *)
000884| let construct_bit buf b _ _ =
000885| (*[0]*)Buffer.add_bit buf b
000886|
000887| (* Construct a field, flen = [2..8]. *)
000888| let construct_char_unsigned buf v flen exn =
000889| (*[1203570]*)let max_val = 1 lsl flen in
000890| (*[1203570]*)if (*[1203570]*)v < 0 || (*[1203570]*)v >= max_val then (*[0]*)raise exn;
000891| (*[1203570]*)if flen = 8 then
000892| (*[1203570]*)Buffer.add_byte buf v
000893| else
000894| (*[0]*)Buffer._add_bits buf v flen
000895|
000896| (* Construct a field of up to 31 bits. *)
000897| let construct_int_be_unsigned buf v flen exn =
000898| (* Check value is within range. *)
000899| (*[2]*)if not (I.range_unsigned v flen) then (*[0]*)raise exn;
000900| (* Add the bytes. *)
000901| (*[2]*)I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
000902|
000903| (* Construct a field of up to 31 bits. *)
000904| let construct_int_le_unsigned buf v flen exn =
000905| (* Check value is within range. *)
000906| (*[0]*)if not (I.range_unsigned v flen) then (*[0]*)raise exn;
000907| (* Add the bytes. *)
000908| (*[0]*)I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
000909|
000910| let construct_int_ne_unsigned =
000911| (*[28]*)if nativeendian = BigEndian
000912| then (*[0]*)construct_int_be_unsigned
000913| else (*[28]*)construct_int_le_unsigned
000914|
000915| let construct_int_ee_unsigned = function
000916| | BigEndian -> (*[0]*)construct_int_be_unsigned
000917| | LittleEndian -> (*[0]*)construct_int_le_unsigned
000918| | NativeEndian -> (*[0]*)construct_int_ne_unsigned
000919|
000920| (* Construct a field of exactly 32 bits. *)
000921| let construct_int32_be_unsigned buf v flen _ =
000922| (*[6]*)Buffer.add_byte buf
000923| (Int32.to_int (Int32.shift_right_logical v 24));
000924| (*[6]*)Buffer.add_byte buf
000925| (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
000926| (*[6]*)Buffer.add_byte buf
000927| (*[6]*)(Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
000928| (*[6]*)Buffer.add_byte buf
000929| (Int32.to_int (Int32.logand v 0xff_l))
000930|
000931| let construct_int32_le_unsigned buf v flen _ =
000932| (*[12]*)Buffer.add_byte buf
000933| (Int32.to_int (Int32.logand v 0xff_l));
000934| (*[12]*)Buffer.add_byte buf
000935| (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
000936| (*[12]*)Buffer.add_byte buf
000937| (*[12]*)(Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
000938| (*[12]*)Buffer.add_byte buf
000939| (Int32.to_int (Int32.shift_right_logical v 24))
000940|
000941| let construct_int32_ne_unsigned =
000942| (*[28]*)if nativeendian = BigEndian
000943| then (*[0]*)construct_int32_be_unsigned
000944| else (*[28]*)construct_int32_le_unsigned
000945|
000946| let construct_int32_ee_unsigned = function
000947| | BigEndian -> (*[6]*)construct_int32_be_unsigned
000948| | LittleEndian -> (*[6]*)construct_int32_le_unsigned
000949| | NativeEndian -> (*[6]*)construct_int32_ne_unsigned
000950|
000951| (* Construct a field of up to 64 bits. *)
000952| let construct_int64_be_unsigned buf v flen exn =
000953| (* Check value is within range. *)
000954| (*[351850]*)if not (I64.range_unsigned v flen) then (*[0]*)raise exn;
000955| (* Add the bytes. *)
000956| (*[351850]*)I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
000957|
000958| (* Construct a field of up to 64 bits. *)
000959| let construct_int64_le_unsigned buf v flen exn =
000960| (* Check value is within range. *)
000961| (*[0]*)if not (I64.range_unsigned v flen) then (*[0]*)raise exn;
000962| (* Add the bytes. *)
000963| (*[0]*)I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
000964|
000965| let construct_int64_ne_unsigned =
000966| (*[28]*)if nativeendian = BigEndian
000967| then (*[0]*)construct_int64_be_unsigned
000968| else (*construct_int64_le_unsigned*)
000969| fun _ _ _ _ -> (*[0]*)failwith "construct_int64_le_unsigned"
000970|
000971| let construct_int64_ee_unsigned = function
000972| | BigEndian -> (*[0]*)construct_int64_be_unsigned
000973| | LittleEndian -> (*construct_int64_le_unsigned*)
000974| (fun _ _ _ _ -> (*[0]*)failwith "construct_int64_le_unsigned")
000975| | NativeEndian -> (*[0]*)construct_int64_ne_unsigned
000976|
000977| (* Construct from a string of bytes, exact multiple of 8 bits
000978| * in length of course.
000979| *)
000980| let construct_string buf str =
000981| (*[89505]*)let len = String.length str in
000982| (*[89505]*)Buffer.add_bits buf str (len lsl 3)
000983|
000984| (* Construct from a bitstring. *)
000985| let construct_bitstring buf (data, off, len) =
000986| (* Add individual bits until we get to the next byte boundary of
000987| * the underlying string.
000988| *)
000989| (*[1197537]*)let blen = 7 - ((off + 7) land 7) in
000990| (*[1197537]*)let blen = min blen len in
000991| (*[1197537]*)let rec loop off len blen =
000992| (*[1197537]*)if blen = 0 then ((*[1197537]*)off, len)
000993| else (
000994| (*[0]*)let b = extract_bit data off len 1
000995| and off = off + 1 and len = len + 1 in
000996| (*[0]*)Buffer.add_bit buf (*[0]*)b;
000997| (*[0]*)loop off len (blen-1)
000998| )
000999| in
001000| (*[1197537]*)let off, len = loop off len blen in
001001| (*[1197537]*)assert ((*[1197537]*)len = 0 || (off (*[1174272]*)land 7) = 0);
001002|
001003| (* Add the remaining 'len' bits. *)
001004| (*[1197537]*)let data =
001005| let off = off lsr 3 in
001006| (* XXX dangerous allocation *)
001007| (*[1197537]*)if off = 0 then (*[1197537]*)data
001008| else (*[0]*)String.sub data off (String.length data - off) in
001009|
001010| (*[1197537]*)Buffer.add_bits buf data len
001011|
001012| (*----------------------------------------------------------------------*)
001013| (* Extract a string from a bitstring. *)
001014|
001015| let string_of_bitstring (data, off, len) =
001016| (*[63963]*)if off (*[63963]*)land 7 = 0 && len (*[8535]*)land 7 = 0 then
001017| (* Easy case: everything is byte-aligned. *)
001018| (*[8022]*)String.sub data (off lsr 3) (len lsr 3)
001019| else (
001020| (* Bit-twiddling case. *)
001021| (*[55941]*)let strlen = (len + 7) lsr 3 in
001022| (*[55941]*)let str = String.make strlen '\000' in
001023| (*[55941]*)let rec loop data off len i =
001024| (*[305313]*)if len >= 8 then (
001025| (*[249372]*)let c = extract_char_unsigned data off len 8
001026| and off = off + 8 and len = len - 8 in
001027| (*[249372]*)str.[i] (*[249372]*)<- Char.chr c;
001028| (*[249372]*)loop data off len (i+1)
001029| ) else (*[52179]*)if len > 0 then (
001030| (*[3762]*)let c = extract_char_unsigned data off len len in
001031| (*[3762]*)str.[i] <- Char.chr (c lsl (8-len))
001032| )
001033| in
001034| (*[55941]*)loop data off len (*[55941]*)0;
001035| (*[55941]*)str
001036| )
001037|
001038| (* To channel. *)
001039|
001040| let bitstring_to_chan ((data, off, len) as bits) chan =
001041| (* Fail if the bitstring length isn't a multiple of 8. *)
001042| (*[0]*)if len land 7 <> 0 then (*[0]*)invalid_arg "bitstring_to_chan";
001043|
001044| (*[0]*)if off land 7 = 0 then
001045| (* Easy case: string is byte-aligned. *)
001046| (*[0]*)output chan data (off lsr 3) (len lsr 3)
001047| else (
001048| (* Bit-twiddling case: reuse string_of_bitstring *)
001049| (*[0]*)let str = string_of_bitstring bits in
001050| (*[0]*)output_string chan str
001051| )
001052|
001053| let bitstring_to_file bits filename =
001054| (*[0]*)let chan = open_out_bin filename in
001055| (*[0]*)try
001056| (*[0]*)bitstring_to_chan bits chan;
001057| (*[0]*)close_out chan
001058| with exn ->
001059| (*[0]*)close_out (*[0]*)chan;
001060| (*[0]*)raise exn
001061|
001062| (*----------------------------------------------------------------------*)
001063| (* Display functions. *)
001064|
001065| let isprint c =
001066| (*[0]*)let c = Char.code c in
001067| (*[0]*)c (*[0]*)>= 32 && (*[0]*)c < 127
001068|
001069| let hexdump_bitstring chan (data, off, len) =
001070| (*[0]*)let count = ref 0 in
001071| (*[0]*)let off = ref off in
001072| (*[0]*)let len = ref len in
001073| (*[0]*)let linelen = ref 0 in
001074| (*[0]*)let linechars = String.make 16 ' ' in
001075|
001076| (*[0]*)fprintf chan "00000000 ";
001077|
001078| (*[0]*)while !len > 0 do
001079| (*[0]*)let bits = min !len 8 in
001080| (*[0]*)let byte = extract_char_unsigned data !off !len bits in
001081| (*[0]*)off := !off + bits; (*[0]*)len (*[0]*):= !len - bits;
001082|
001083| (*[0]*)let byte = byte lsl (8-bits) in
001084| (*[0]*)fprintf chan "%02x " byte;
001085|
001086| (*[0]*)incr count;
001087| (*[0]*)linechars.[!linelen] <-
001088| (let c = Char.chr byte in
001089| (*[0]*)if isprint c then (*[0]*)c else (*[0]*)'.');
001090| (*[0]*)incr linelen;
001091| (*[0]*)if !linelen = 8 then (*[0]*)fprintf chan " ";
001092| (*[0]*)if !linelen = 16 then (
001093| (*[0]*)fprintf chan " |%s|\n%08x " linechars !count;
001094| (*[0]*)linelen (*[0]*):= 0;
001095| (*[0]*)for i = 0 to 15 do (*[0]*)linechars.[i] <- ' ' done
001096| )
001097| done;
001098|
001099| (*[0]*)if !linelen > 0 then (
001100| (*[0]*)let skip = (16 - !linelen) * 3 + if !linelen < 8 then (*[0]*)1 else (*[0]*)0 in
001101| (*[0]*)for i = 0 to skip-1 do (*[0]*)fprintf chan " " done;
001102| (*[0]*)fprintf chan " |%s|\n%!" linechars
001103| ) else
001104| (*[0]*)fprintf chan "\n%!"