diff --git a/config/Makefile.in b/config/Makefile.in index 19b136c2..37d5fd29 100644 --- a/config/Makefile.in +++ b/config/Makefile.in @@ -69,7 +69,6 @@ endif EXTLIB=src/utils/extlib CDK=src/utils/cdk -BITSTRING=src/utils/bitstring LIB=src/utils/lib NET=src/utils/net RSS=src/utils/ocamlrss @@ -90,7 +89,7 @@ SRC_SOULSEEK=src/networks/soulseek SRC_DIRECTCONNECT=src/networks/direct_connect SRC_FILETP=src/networks/fileTP -SUBDIRS=$(EXTLIB) $(CDK) $(BITSTRING) $(LIB) $(RSS) $(XML) $(NET) tools \ +SUBDIRS=$(EXTLIB) $(CDK) $(LIB) $(RSS) $(XML) $(NET) tools \ $(COMMON) $(DRIVER) $(MP3) src/config/$(OS_FILES) INCLUDES += $(foreach file, $(SUBDIRS), -I $(file)) -I +camlp4 $(NUMS_INCLUDE) @@ -134,10 +133,6 @@ ifeq ("$(OS_FILES2)", "cygwin") LIBS_flags += -cclib "resfile.o" endif -BITSTRING_SRCS = \ - $(BITSTRING)/bitstring.ml \ - $(BITSTRING)/bitstring_c.c - ifeq ("$(BZIP2)", "yes") LIBS_flags += -cclib -lbz2 CDK_SRCS += $(CDK)/bzlib.ml $(CDK)/bzip2.ml @@ -436,12 +431,6 @@ FASTTRACK_SRCS= \ $(SRC_FASTTRACK)/fasttrackInteractive.mlt \ $(SRC_FASTTRACK)/fasttrackMain.mlt -$(BITSTRING)/bitstring_persistent.cmo: $(BITSTRING)/bitstring_persistent.ml $(BITSTRING)/bitstring_persistent.cmi build/bitstring.cma - $(OCAMLC) -I $(BITSTRING) -I +camlp4 camlp4lib.cma -c $< - -$(BITSTRING)/pa_bitstring.cmo: $(BITSTRING)/pa_bitstring.mlt $(BITSTRING)/bitstring_persistent.cmo build/bitstring.cma - $(OCAMLC) -I $(BITSTRING) -I +camlp4 camlp4lib.cma -pp '$(CAMLP4OF) -impl' -c $^ - BITTORRENT_SRCS= \ $(SRC_BITTORRENT)/bencode.ml \ $(SRC_BITTORRENT)/bTRate.ml \ @@ -535,7 +524,7 @@ MLSPLIT_SRCS = \ MAKE_TORRENT_SRCS = \ $(MAGIC_SRCS) $(EXTLIB_SRCS) $(CDK_SRCS) $(LIB_SRCS) $(NET_SRCS) $(MP3TAG_SRCS) \ - $(COMMON_SRCS) $(COMMON_CLIENT_SRCS) $(BITSTRING_SRCS) $(BITTORRENT_SRCS) \ + $(COMMON_SRCS) $(COMMON_CLIENT_SRCS) $(BITTORRENT_SRCS) \ tools/make_torrent.ml BT_DHT_NODE_SRCS = \ @@ -583,32 +572,24 @@ DRIVER_SRCS+= \ ICONS_CMXA=icons.cmxa CDK_CMXA=cdk.cmxa -BITSTRING_CMXA= -BITSTRING_CMA= MLNET_SRCS= -ifeq ("$(DONKEY)", "yes") -BITSTRING_CMXA=bitstring.cmxa -BITSTRING_CMA=bitstring.cma -endif ifeq ("$(BITTORRENT)", "yes") LIBS_byte += $(NUMS_INCLUDE) nums.cma LIBS_opt += $(NUMS_INCLUDE) nums.cmxa -BITSTRING_CMXA=bitstring.cmxa -BITSTRING_CMA=bitstring.cma endif MLNET_SRCS+= $(MAIN_SRCS) -MLNET_CMXA=extlib.cmxa $(CDK_CMXA) $(BITSTRING_CMXA) magic.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa +MLNET_CMXA=extlib.cmxa $(CDK_CMXA) magic.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa -TESTS_CMXA=extlib.cmxa $(CDK_CMXA) $(BITSTRING_CMXA) magic.cmxa common.cmxa client.cmxa core.cmxa +TESTS_CMXA=extlib.cmxa $(CDK_CMXA) magic.cmxa common.cmxa client.cmxa core.cmxa TESTS_SRCS=tools/tests.ml ifeq ("$(GUI)", "newgui2") mlnet+gui_CMXA= \ - $(BITSTRING_CMXA) magic.cmxa extlib.cmxa cdk.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa \ + magic.cmxa extlib.cmxa cdk.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa \ icons.cmxa guibase.cmxa gui.cmxa else mlnet+gui_CMXA= \ - $(BITSTRING_CMXA) magic.cmxa extlib.cmxa cdk.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa \ + magic.cmxa extlib.cmxa cdk.cmxa common.cmxa client.cmxa core.cmxa driver.cmxa \ gmisc.cmxa icons.cmxa guibase.cmxa gui.cmxa endif @@ -1138,7 +1119,7 @@ top: mldonkeytop runtop: top ./mldonkeytop $(INCLUDES) -TOP_CMXA+=$(BITSTRING_CMA) extlib.cmxa cdk.cmxa magic.cmxa common.cmxa client.cmxa core.cmxa +TOP_CMXA+=extlib.cmxa cdk.cmxa magic.cmxa common.cmxa client.cmxa core.cmxa TOP_SRCS= define([[EXPAND_LIB]],[[ @@ -1182,13 +1163,6 @@ endif ifeq ("$2", "DONKEY") $1_SRCS+= $(CRYPTOPP_SRCS) -$1_CMXA+= $(BITSTRING_CMXA) -$1+gui_CMXA+= $(BITSTRING_CMXA) -else -ifeq ("$2", "BITTORRENT") -$1_CMXA+= $(BITSTRING_CMXA) -$1+gui_CMXA+= $(BITSTRING_CMXA) -endif endif $1_CMXA+= extlib.cmxa cdk.cmxa magic.cmxa common.cmxa client.cmxa $1.cmxa driver.cmxa @@ -1224,7 +1198,6 @@ EXPAND_DRIVER(mlslsk,SOULSEEK,soulseek) libextlib_SRCS= $(EXTLIB_SRCS) libcdk_SRCS= $(CDK_SRCS) $(LIB_SRCS) $(NET_SRCS) $(MP3TAG_SRCS) libmagic_SRCS= $(MAGIC_SRCS) -libbitstring_SRCS= $(BITSTRING_SRCS) libcommon_SRCS= $(COMMON_SRCS) libclient_SRCS= $(COMMON_CLIENT_SRCS) ifeq ("$(GUI)", "newgui2") @@ -1241,7 +1214,6 @@ EXPAND_LIB(libextlib,extlib) EXPAND_LIB(libicons,icons) EXPAND_LIB(libcdk,cdk) EXPAND_LIB(libmagic,magic) -EXPAND_LIB(libbitstring,bitstring) EXPAND_LIB(libupnp_natpmp,upnp_natpmp) EXPAND_LIB(libcommon,common) EXPAND_LIB(libclient,client) @@ -1333,7 +1305,7 @@ $2.byte.static: $($1_OBJS) $($1_CMOS) $($1_CMAS) # $5 = if set link GD code # $6 = if set link CryptoPP code (only for targets mlnet, mldonkey) # $7 = if set link libmagic code (only for p2p core, not for GUIs, tools etc.) -# $8 = if set link libbitstring code (only for Bittorrent p2p core) +# $8 = external lib # $9 = if set link libminiupnpc & libnatpmp code EXPAND(mldonkey,mldonkey,NO,mldonkey,GD,CRYPTOPP,MAGIC,BITSTRING,UPNP_NATPMP) @@ -1501,8 +1473,6 @@ releaseclean: clean moreclean rm -f src/networks/bittorrent/bTUdpTracker.ml rm -f src/networks/donkey/donkeySui.ml rm -f src/networks/donkey/donkeyNodesDat.ml - rm -f src/utils/bitstring/bitstring.ml - rm -f src/utils/bitstring/bitstring_persistent.ml rm -f src/utils/lib/autoconf.ml rm -f src/utils/lib/autoconf.ml.new rm -f src/utils/lib/gAutoconf.ml @@ -1849,9 +1819,6 @@ rpm: sourcedist .mlcpp.ml: @$(CPP) -x c -DOCAMLVERSION_MAJOR=$(OCAMLVERSION_MAJOR) -P $< $(FIX_BROKEN_CPP) > $@ -%.ml: %.mlp $(BITSTRING)/pa_bitstring.cmo - $(CAMLP4OF) build/bitstring.cma $(BITSTRING)/bitstring_persistent.cmo $(BITSTRING)/pa_bitstring.cmo -impl $< -o $@ - .mll.ml : @$(OCAMLLEX) -q $< diff --git a/config/configure.in b/config/configure.in index 3f991556..4b8a3b2e 100644 --- a/config/configure.in +++ b/config/configure.in @@ -1580,7 +1580,6 @@ AC_OUTPUT(\ Makefile.config \ mldonkey.rc \ $AUTOCONF.new $GTK_AUTOCONF.new \ - ../src/utils/bitstring/bitstring.ml \ ../src/utils/lib/magic.ml \ ../src/networks/donkey/donkeySui.ml \ ../src/daemon/driver/driverGraphics.ml \ diff --git a/src/utils/bitstring/bitstring.ml.in b/src/utils/bitstring/bitstring.ml.in deleted file mode 100644 index fa89e0ce..00000000 --- a/src/utils/bitstring/bitstring.ml.in +++ /dev/null @@ -1,1185 +0,0 @@ -(* Bitstring library. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - *) - -open Printf - -(* Enable runtime debug messages. Must also have been enabled - * in pa_bitstring.ml. - *) -let debug = ref false -let version = "2.0.2" -let package = "ocaml-bitstring" - -type endian = BigEndian | LittleEndian | NativeEndian - -let string_of_endian = function - | BigEndian -> "bigendian" - | LittleEndian -> "littleendian" - | NativeEndian -> "nativeendian" - -let nativeendian = @NATIVEENDIAN@ - -(* Exceptions. *) -exception Construct_failure of string * string * int * int - -(* A bitstring is simply the data itself (as a string), and the - * bitoffset and the bitlength within the string. Note offset/length - * are counted in bits, not bytes. - *) -type bitstring = string * int * int - -type t = bitstring - -(* Functions to create and load bitstrings. *) -let empty_bitstring = "", 0, 0 - -let make_bitstring len c = - if len >= 0 then String.make ((len+7) lsr 3) c, 0, len - else - invalid_arg ( - sprintf "make_bitstring/create_bitstring: len %d < 0" len - ) - -let create_bitstring len = make_bitstring len '\000' - -let zeroes_bitstring = create_bitstring - -let ones_bitstring len = make_bitstring len '\xff' - -let bitstring_of_string str = str, 0, String.length str lsl 3 - -let bitstring_of_chan chan = - let tmpsize = 16384 in - let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in - let n = ref 0 in - while n := input chan tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; - done; - Buffer.contents buf, 0, Buffer.length buf lsl 3 - -let bitstring_of_chan_max chan max = - let tmpsize = 16384 in - let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in - let len = ref 0 in - let rec loop () = - if !len < max then ( - let r = min tmpsize (max - !len) in - let n = input chan tmp 0 r in - if n > 0 then ( - Buffer.add_substring buf tmp 0 n; - len := !len + n; - loop () - ) - ) - in - loop (); - Buffer.contents buf, 0, !len lsl 3 - -let bitstring_of_file_descr fd = - let tmpsize = 16384 in - let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in - let n = ref 0 in - while n := Unix.read fd tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; - done; - Buffer.contents buf, 0, Buffer.length buf lsl 3 - -let bitstring_of_file_descr_max fd max = - let tmpsize = 16384 in - let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in - let len = ref 0 in - let rec loop () = - if !len < max then ( - let r = min tmpsize (max - !len) in - let n = Unix.read fd tmp 0 r in - if n > 0 then ( - Buffer.add_substring buf tmp 0 n; - len := !len + n; - loop () - ) - ) - in - loop (); - Buffer.contents buf, 0, !len lsl 3 - -let bitstring_of_file fname = - let chan = open_in_bin fname in - try - let bs = bitstring_of_chan chan in - close_in chan; - bs - with exn -> - close_in chan; - raise exn - -let bitstring_length (_, _, len) = len - -let subbitstring (data, off, len) off' len' = - let off = off + off' in - if len < off' + len' then invalid_arg "subbitstring"; - (data, off, len') - -let dropbits n (data, off, len) = - let off = off + n in - let len = len - n in - if len < 0 then invalid_arg "dropbits"; - (data, off, len) - -let takebits n (data, off, len) = - if len < n then invalid_arg "takebits"; - (data, off, n) - -(*----------------------------------------------------------------------*) -(* Bitwise functions. - * - * We try to isolate all bitwise functions within these modules. - *) - -module I = struct - (* Bitwise operations on ints. Note that we assume int <= 31 bits. *) - external (<<<) : int -> int -> int = "%lslint" - external (>>>) : int -> int -> int = "%lsrint" - external to_int : int -> int = "%identity" - let zero = 0 - let one = 1 - let minus_one = -1 - let ff = 0xff - - (* Create a mask 0-31 bits wide. *) - let mask bits = - if bits < 30 then - (one <<< bits) - 1 - else if bits = 30 then - max_int - else if bits = 31 then - minus_one - else - invalid_arg "Bitstring.I.mask" - - (* Byte swap an int of a given size. *) - let byteswap v bits = - 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 - 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 - 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 - v4 lor v3 lor v2 lor v1 - ) - - (* Check a value is in range 0 .. 2^bits-1. *) - let range_unsigned v bits = - let mask = lnot (mask bits) in - (v land mask) = zero - - (* Call function g on the top bits, then f on each full byte - * (big endian - so start at top). - *) - let rec map_bytes_be g f v bits = - if bits >= 8 then ( - map_bytes_be g f (v >>> 8) (bits-8); - let lsb = v land ff in - f (to_int lsb) - ) else if bits > 0 then ( - let lsb = v land (mask bits) in - g (to_int lsb) bits - ) - - (* Call function g on the top bits, then f on each full byte - * (little endian - so start at root). - *) - let rec map_bytes_le g f v bits = - if bits >= 8 then ( - let lsb = v land ff in - f (to_int lsb); - 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 - ) -end - -module I32 = struct - (* Bitwise operations on int32s. Note we try to keep it as similar - * 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 (land) = Int32.logand - let (lor) = Int32.logor - let lnot = Int32.lognot - let pred = Int32.pred - let max_int = Int32.max_int - let to_int = Int32.to_int - let zero = Int32.zero - let one = Int32.one - let minus_one = Int32.minus_one - let ff = 0xff_l - - (* Create a mask so many bits wide. *) - let mask bits = - if bits < 31 then - pred (one <<< bits) - else if bits = 31 then - max_int - else if bits = 32 then - minus_one - else - invalid_arg "Bitstring.I32.mask" - - (* Byte swap an int of a given size. *) - let byteswap v bits = - 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 - 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 - 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 - v4 lor v3 lor v2 lor v1 - ) - - (* Check a value is in range 0 .. 2^bits-1. *) - let range_unsigned v bits = - let mask = lnot (mask bits) in - (v land mask) = zero - - (* Call function g on the top bits, then f on each full byte - * (big endian - so start at top). - *) - let rec map_bytes_be g f v bits = - if bits >= 8 then ( - map_bytes_be g f (v >>> 8) (bits-8); - let lsb = v land ff in - f (to_int lsb) - ) else if bits > 0 then ( - let lsb = v land (mask bits) in - g (to_int lsb) bits - ) - - (* Call function g on the top bits, then f on each full byte - * (little endian - so start at root). - *) - let rec map_bytes_le g f v bits = - if bits >= 8 then ( - let lsb = v land ff in - f (to_int lsb); - 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 - ) -end - -module I64 = struct - (* Bitwise operations on int64s. Note we try to keep it as similar - * 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 (land) = Int64.logand - let (lor) = Int64.logor - let lnot = Int64.lognot - let pred = Int64.pred - let max_int = Int64.max_int - let to_int = Int64.to_int - let zero = Int64.zero - let one = Int64.one - let minus_one = Int64.minus_one - let ff = 0xff_L - - (* Create a mask so many bits wide. *) - let mask bits = - if bits < 63 then - pred (one <<< bits) - else if bits = 63 then - max_int - else if bits = 64 then - minus_one - else - invalid_arg "Bitstring.I64.mask" - - (* Byte swap an int of a given size. *) - (* let byteswap v bits = *) - - (* Check a value is in range 0 .. 2^bits-1. *) - let range_unsigned v bits = - let mask = lnot (mask bits) in - (v land mask) = zero - - (* Call function g on the top bits, then f on each full byte - * (big endian - so start at top). - *) - let rec map_bytes_be g f v bits = - if bits >= 8 then ( - map_bytes_be g f (v >>> 8) (bits-8); - let lsb = v land ff in - f (to_int lsb) - ) else if bits > 0 then ( - let lsb = v land (mask bits) in - g (to_int lsb) bits - ) - - (* Call function g on the top bits, then f on each full byte - * (little endian - so start at root). - *) - let rec map_bytes_le g f v bits = - if bits >= 8 then ( - let lsb = v land ff in - f (to_int lsb); - 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 - ) -end - -(*----------------------------------------------------------------------*) -(* Extraction functions. - * - * NB: internal functions, called from the generated macros, and - * the parameters should have been checked for sanity already). - *) - -(* Extract and convert to numeric. A single bit is returned as - * a boolean. There are no endianness or signedness considerations. - *) -let extract_bit data off len _ = (* final param is always 1 *) - let byteoff = off lsr 3 in - let bitmask = 1 lsl (7 - (off land 7)) in - let b = Char.code data.[byteoff] land bitmask <> 0 in - b (*, off+1, len-1*) - -(* Returns 8 bit unsigned aligned bytes from the string. - * If the string ends then this returns 0's. - *) -let _get_byte data byteoff strlen = - if strlen > byteoff then Char.code data.[byteoff] else 0 -let _get_byte32 data byteoff strlen = - if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l -let _get_byte64 data byteoff strlen = - if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L - -(* Extract [2..8] bits. Because the result fits into a single - * byte we don't have to worry about endianness, only signedness. - *) -let extract_char_unsigned data off len flen = - let byteoff = off lsr 3 in - - (* Optimize the common (byte-aligned) case. *) - if off land 7 = 0 then ( - let byte = Char.code data.[byteoff] in - byte lsr (8 - flen) (*, off+flen, len-flen*) - ) else ( - (* Extract the 16 bits at byteoff and byteoff+1 (note that the - * second byte might not exist in the original string). - *) - let strlen = String.length data in - - let word = - (_get_byte data byteoff strlen lsl 8) + - _get_byte data (byteoff+1) strlen in - - (* Mask off the top bits. *) - let bitmask = (1 lsl (16 - (off land 7))) - 1 in - let word = word land bitmask in - (* Shift right to get rid of the bottom bits. *) - let shift = 16 - ((off land 7) + flen) in - let word = word lsr shift in - - word (*, off+flen, len-flen*) - ) - -(* Extract [9..31] bits. We have to consider endianness and signedness. *) -let extract_int_be_unsigned data off len flen = - let byteoff = off lsr 3 in - - let strlen = String.length data in - - let word = - (* Optimize the common (byte-aligned) case. *) - if off land 7 = 0 then ( - let word = - (_get_byte data byteoff strlen lsl 23) + - (_get_byte data (byteoff+1) strlen lsl 15) + - (_get_byte data (byteoff+2) strlen lsl 7) + - (_get_byte data (byteoff+3) strlen lsr 1) in - word lsr (31 - flen) - ) else if flen <= 24 then ( - (* Extract the 31 bits at byteoff .. byteoff+3. *) - let word = - (_get_byte data byteoff strlen lsl 23) + - (_get_byte data (byteoff+1) strlen lsl 15) + - (_get_byte data (byteoff+2) strlen lsl 7) + - (_get_byte data (byteoff+3) strlen lsr 1) in - (* Mask off the top bits. *) - let bitmask = (1 lsl (31 - (off land 7))) - 1 in - let word = word land bitmask in - (* Shift right to get rid of the bottom bits. *) - let shift = 31 - ((off land 7) + flen) in - word lsr shift - ) else ( - (* Extract the next 31 bits, slow method. *) - let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 7 in - (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in - word lsr (31 - flen) - ) in - word (*, off+flen, len-flen*) - -let extract_int_le_unsigned data off len flen = - let v = extract_int_be_unsigned data off len flen in - let v = I.byteswap v flen in - v - -let extract_int_ne_unsigned = - if nativeendian = BigEndian - then extract_int_be_unsigned - else extract_int_le_unsigned - -let extract_int_ee_unsigned = function - | BigEndian -> extract_int_be_unsigned - | LittleEndian -> extract_int_le_unsigned - | NativeEndian -> extract_int_ne_unsigned - -let _make_int32_be c0 c1 c2 c3 = - Int32.logor - (Int32.logor - (Int32.logor - (Int32.shift_left c0 24) - (Int32.shift_left c1 16)) - (Int32.shift_left c2 8)) - c3 - -let _make_int32_le c0 c1 c2 c3 = - Int32.logor - (Int32.logor - (Int32.logor - (Int32.shift_left c3 24) - (Int32.shift_left c2 16)) - (Int32.shift_left c1 8)) - c0 - -(* Extract exactly 32 bits. We have to consider endianness and signedness. *) -let extract_int32_be_unsigned data off len flen = - let byteoff = off lsr 3 in - - let strlen = String.length data in - - let word = - (* Optimize the common (byte-aligned) case. *) - if off land 7 = 0 then ( - let word = - let c0 = _get_byte32 data byteoff strlen in - let c1 = _get_byte32 data (byteoff+1) strlen in - let c2 = _get_byte32 data (byteoff+2) strlen in - let c3 = _get_byte32 data (byteoff+3) strlen in - _make_int32_be c0 c1 c2 c3 in - Int32.shift_right_logical word (32 - flen) - ) else ( - (* Extract the next 32 bits, slow method. *) - let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 8 in - let c0 = Int32.of_int c0 in - let c1 = Int32.of_int c1 in - let c2 = Int32.of_int c2 in - let c3 = Int32.of_int c3 in - _make_int32_be c0 c1 c2 c3 in - Int32.shift_right_logical word (32 - flen) - ) in - word (*, off+flen, len-flen*) - -let extract_int32_le_unsigned data off len flen = - let v = extract_int32_be_unsigned data off len flen in - let v = I32.byteswap v flen in - v - -let extract_int32_ne_unsigned = - if nativeendian = BigEndian - then extract_int32_be_unsigned - else extract_int32_le_unsigned - -let extract_int32_ee_unsigned = function - | BigEndian -> extract_int32_be_unsigned - | LittleEndian -> extract_int32_le_unsigned - | NativeEndian -> extract_int32_ne_unsigned - -let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 = - Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.logor - (Int64.shift_left c0 56) - (Int64.shift_left c1 48)) - (Int64.shift_left c2 40)) - (Int64.shift_left c3 32)) - (Int64.shift_left c4 24)) - (Int64.shift_left c5 16)) - (Int64.shift_left c6 8)) - c7 - -let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 = - _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0 - -(* Extract [1..64] bits. We have to consider endianness and signedness. *) -let extract_int64_be_unsigned data off len flen = - let byteoff = off lsr 3 in - - let strlen = String.length data in - - let word = - (* Optimize the common (byte-aligned) case. *) - if off land 7 = 0 then ( - let word = - let c0 = _get_byte64 data byteoff strlen in - let c1 = _get_byte64 data (byteoff+1) strlen in - let c2 = _get_byte64 data (byteoff+2) strlen in - let c3 = _get_byte64 data (byteoff+3) strlen in - let c4 = _get_byte64 data (byteoff+4) strlen in - let c5 = _get_byte64 data (byteoff+5) strlen in - let c6 = _get_byte64 data (byteoff+6) strlen in - let c7 = _get_byte64 data (byteoff+7) strlen in - _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in - Int64.shift_right_logical word (64 - flen) - ) else ( - (* Extract the next 64 bits, slow method. *) - let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c4 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c5 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c6 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c7 = extract_char_unsigned data off len 8 in - let c0 = Int64.of_int c0 in - let c1 = Int64.of_int c1 in - let c2 = Int64.of_int c2 in - let c3 = Int64.of_int c3 in - let c4 = Int64.of_int c4 in - let c5 = Int64.of_int c5 in - let c6 = Int64.of_int c6 in - let c7 = Int64.of_int c7 in - _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in - Int64.shift_right_logical word (64 - flen) - ) in - word (*, off+flen, len-flen*) - -let extract_int64_le_unsigned data off len flen = - let byteoff = off lsr 3 in - - let strlen = String.length data in - - let word = - (* Optimize the common (byte-aligned) case. *) - if off land 7 = 0 then ( - let word = - let c0 = _get_byte64 data byteoff strlen in - let c1 = _get_byte64 data (byteoff+1) strlen in - let c2 = _get_byte64 data (byteoff+2) strlen in - let c3 = _get_byte64 data (byteoff+3) strlen in - let c4 = _get_byte64 data (byteoff+4) strlen in - let c5 = _get_byte64 data (byteoff+5) strlen in - let c6 = _get_byte64 data (byteoff+6) strlen in - let c7 = _get_byte64 data (byteoff+7) strlen in - _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in - Int64.logand word (I64.mask flen) - ) else ( - (* Extract the next 64 bits, slow method. *) - let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c4 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c5 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c6 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c7 = extract_char_unsigned data off len 8 in - let c0 = Int64.of_int c0 in - let c1 = Int64.of_int c1 in - let c2 = Int64.of_int c2 in - let c3 = Int64.of_int c3 in - let c4 = Int64.of_int c4 in - let c5 = Int64.of_int c5 in - let c6 = Int64.of_int c6 in - let c7 = Int64.of_int c7 in - _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in - Int64.logand word (I64.mask flen) - ) in - word (*, off+flen, len-flen*) - -let extract_int64_ne_unsigned = - if nativeendian = BigEndian - then extract_int64_be_unsigned - else extract_int64_le_unsigned - -let extract_int64_ee_unsigned = function - | BigEndian -> extract_int64_be_unsigned - | LittleEndian -> extract_int64_le_unsigned - | NativeEndian -> extract_int64_ne_unsigned - -external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc" - -external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc" - -external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc" - -external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc" - -external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc" - -external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc" - -(* -external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc" - -external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc" - -external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc" - -external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc" - -external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc" - -external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc" -*) - -external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc" - -external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc" - -external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc" - -external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc" - -external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc" - -external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc" - -(* -external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc" - -external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc" - -external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc" - -external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc" - -external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc" - -external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc" - -external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc" - -external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc" - -external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc" - -external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc" - -external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc" - -external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc" - -external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc" - -external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc" - -external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc" - -external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc" - -external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc" - -external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc" -*) - -external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc" - -external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc" - -external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc" - -external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc" - -external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc" - -external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc" - -(*----------------------------------------------------------------------*) -(* Constructor functions. *) - -module Buffer = struct - type t = { - buf : Buffer.t; - mutable len : int; (* Length in bits. *) - (* Last byte in the buffer (if len is not aligned). We store - * it outside the buffer because buffers aren't mutable. - *) - mutable last : int; - } - - let create () = - (* XXX We have almost enough information in the generator to - * choose a good initial size. - *) - { buf = Buffer.create 128; len = 0; last = 0 } - - let contents { buf = buf; len = len; last = last } = - let data = - if len land 7 = 0 then - Buffer.contents buf - else - Buffer.contents buf ^ (String.make 1 (Char.chr last)) in - data, 0, len - - (* Add exactly 8 bits. *) - let add_byte ({ buf = buf; len = len; last = last } as t) byte = - if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte"; - let shift = len land 7 in - if shift = 0 then - (* Target buffer is byte-aligned. *) - Buffer.add_char buf (Char.chr byte) - else ( - (* Target buffer is unaligned. 'last' is meaningful. *) - let first = byte lsr shift in - let second = (byte lsl (8 - shift)) land 0xff in - Buffer.add_char buf (Char.chr (last lor first)); - t.last <- second - ); - t.len <- t.len + 8 - - (* Add exactly 1 bit. *) - let add_bit ({ buf = buf; len = len; last = last } as t) bit = - let shift = 7 - (len land 7) in - if shift > 0 then - (* Somewhere in the middle of 'last'. *) - t.last <- last lor ((if bit then 1 else 0) lsl shift) - else ( - (* Just a single spare bit in 'last'. *) - let last = last lor if bit then 1 else 0 in - Buffer.add_char buf (Char.chr last); - t.last <- 0 - ); - t.len <- len + 1 - - (* Add a small number of bits (definitely < 8). This uses a loop - * to call add_bit so it's slow. - *) - let _add_bits t c slen = - if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits"; - for i = slen-1 downto 0 do - let bit = c land (1 lsl i) <> 0 in - add_bit t bit - done - - let add_bits ({ buf = buf; len = len; last = _ } as t) str slen = - if slen > 0 then ( - if len land 7 = 0 then ( - if slen land 7 = 0 then - (* Common case - everything is byte-aligned. *) - Buffer.add_substring buf str 0 (slen lsr 3) - else ( - (* Target buffer is aligned. Copy whole bytes then leave the - * remaining bits in last. - *) - let slenbytes = slen lsr 3 in - if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes; - let last = Char.code str.[slenbytes] in (* last char *) - let mask = 0xff lsl (8 - (slen land 7)) in - t.last <- last land mask - ); - t.len <- len + slen - ) else ( - (* Target buffer is unaligned. Copy whole bytes using - * add_byte which knows how to deal with an unaligned - * target buffer, then call add_bit for the remaining < 8 bits. - * - * XXX This is going to be dog-slow. - *) - let slenbytes = slen lsr 3 in - for i = 0 to slenbytes-1 do - let byte = Char.code str.[i] in - add_byte t byte - done; - let bitsleft = slen - (slenbytes lsl 3) in - if bitsleft > 0 then ( - let c = Char.code str.[slenbytes] in - for i = 0 to bitsleft - 1 do - let bit = c land (0x80 lsr i) <> 0 in - add_bit t bit - done - ) - ); - ) -end - -(* Construct a single bit. *) -let construct_bit buf b _ _ = - Buffer.add_bit buf b - -(* Construct a field, flen = [2..8]. *) -let construct_char_unsigned buf v flen exn = - let max_val = 1 lsl flen in - if v < 0 || v >= max_val then raise exn; - if flen = 8 then - Buffer.add_byte buf v - else - Buffer._add_bits buf v flen - -(* Construct a field of up to 31 bits. *) -let construct_int_be_unsigned buf v flen exn = - (* Check value is within range. *) - if not (I.range_unsigned v flen) then raise exn; - (* Add the bytes. *) - I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen - -(* Construct a field of up to 31 bits. *) -let construct_int_le_unsigned buf v flen exn = - (* Check value is within range. *) - if not (I.range_unsigned v flen) then raise exn; - (* Add the bytes. *) - I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen - -let construct_int_ne_unsigned = - if nativeendian = BigEndian - then construct_int_be_unsigned - else construct_int_le_unsigned - -let construct_int_ee_unsigned = function - | BigEndian -> construct_int_be_unsigned - | LittleEndian -> construct_int_le_unsigned - | NativeEndian -> construct_int_ne_unsigned - -(* Construct a field of exactly 32 bits. *) -let construct_int32_be_unsigned buf v flen _ = - Buffer.add_byte buf - (Int32.to_int (Int32.shift_right_logical v 24)); - Buffer.add_byte buf - (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l))); - Buffer.add_byte buf - (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l))); - Buffer.add_byte buf - (Int32.to_int (Int32.logand v 0xff_l)) - -let construct_int32_le_unsigned buf v flen _ = - Buffer.add_byte buf - (Int32.to_int (Int32.logand v 0xff_l)); - Buffer.add_byte buf - (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l))); - Buffer.add_byte buf - (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l))); - Buffer.add_byte buf - (Int32.to_int (Int32.shift_right_logical v 24)) - -let construct_int32_ne_unsigned = - if nativeendian = BigEndian - then construct_int32_be_unsigned - else construct_int32_le_unsigned - -let construct_int32_ee_unsigned = function - | BigEndian -> construct_int32_be_unsigned - | LittleEndian -> construct_int32_le_unsigned - | NativeEndian -> construct_int32_ne_unsigned - -(* Construct a field of up to 64 bits. *) -let construct_int64_be_unsigned buf v flen exn = - (* Check value is within range. *) - if not (I64.range_unsigned v flen) then raise exn; - (* Add the bytes. *) - I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen - -(* Construct a field of up to 64 bits. *) -let construct_int64_le_unsigned buf v flen exn = - (* Check value is within range. *) - if not (I64.range_unsigned v flen) then raise exn; - (* Add the bytes. *) - I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen - -let construct_int64_ne_unsigned = - if nativeendian = BigEndian - then construct_int64_be_unsigned - else construct_int64_le_unsigned - -let construct_int64_ee_unsigned = function - | BigEndian -> construct_int64_be_unsigned - | LittleEndian -> construct_int64_le_unsigned - | NativeEndian -> construct_int64_ne_unsigned - -(* Construct from a string of bytes, exact multiple of 8 bits - * in length of course. - *) -let construct_string buf str = - let len = String.length str in - Buffer.add_bits buf str (len lsl 3) - -(* Construct from a bitstring. *) -let construct_bitstring buf (data, off, len) = - (* Add individual bits until we get to the next byte boundary of - * the underlying string. - *) - let blen = 7 - ((off + 7) land 7) in - let blen = min blen len in - let rec loop off len blen = - if blen = 0 then (off, len) - else ( - let b = extract_bit data off len 1 - and off = off + 1 and len = len + 1 in - Buffer.add_bit buf b; - loop off len (blen-1) - ) - in - let off, len = loop off len blen in - assert (len = 0 || (off land 7) = 0); - - (* Add the remaining 'len' bits. *) - let data = - let off = off lsr 3 in - (* XXX dangerous allocation *) - if off = 0 then data - else String.sub data off (String.length data - off) in - - 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. *) - String.sub data (off lsr 3) (len lsr 3) - else ( - (* Bit-twiddling case. *) - let strlen = (len + 7) lsr 3 in - let str = String.make strlen '\000' in - let rec loop data off len i = - if len >= 8 then ( - let c = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - str.[i] <- Char.chr c; - loop data off len (i+1) - ) else if len > 0 then ( - let c = extract_char_unsigned data off len len in - str.[i] <- Char.chr (c lsl (8-len)) - ) - in - loop data off len 0; - str - ) - -(* To channel. *) - -let bitstring_to_chan ((data, off, len) as bits) chan = - (* Fail if the bitstring length isn't a multiple of 8. *) - if len land 7 <> 0 then invalid_arg "bitstring_to_chan"; - - if off land 7 = 0 then - (* Easy case: string is byte-aligned. *) - output chan data (off lsr 3) (len lsr 3) - else ( - (* Bit-twiddling case: reuse string_of_bitstring *) - let str = string_of_bitstring bits in - output_string chan str - ) - -let bitstring_to_file bits filename = - let chan = open_out_bin filename in - try - bitstring_to_chan bits chan; - close_out chan - with exn -> - close_out chan; - 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 = - let c = Char.code c in - c >= 32 && c < 127 - -let hexdump_bitstring chan (data, off, len) = - let count = ref 0 in - let off = ref off in - let len = ref len in - let linelen = ref 0 in - let linechars = String.make 16 ' ' in - - fprintf chan "00000000 "; - - while !len > 0 do - let bits = min !len 8 in - let byte = extract_char_unsigned data !off !len bits in - off := !off + bits; len := !len - bits; - - let byte = byte lsl (8-bits) in - fprintf chan "%02x " byte; - - incr count; - linechars.[!linelen] <- - (let c = Char.chr byte in - if isprint c then c else '.'); - incr linelen; - if !linelen = 8 then fprintf chan " "; - if !linelen = 16 then ( - fprintf chan " |%s|\n%08x " linechars !count; - linelen := 0; - for i = 0 to 15 do linechars.[i] <- ' ' done - ) - done; - - if !linelen > 0 then ( - let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in - for i = 0 to skip-1 do fprintf chan " " done; - fprintf chan " |%s|\n%!" linechars - ) else - fprintf chan "\n%!" diff --git a/src/utils/bitstring/bitstring.mli b/src/utils/bitstring/bitstring.mli deleted file mode 100644 index b6654c02..00000000 --- a/src/utils/bitstring/bitstring.mli +++ /dev/null @@ -1,1081 +0,0 @@ -(** Bitstring library. *) -(* Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - *) - -(** - {{:#reference}Jump straight to the reference section for - documentation on types and functions}. - - {2 Introduction} - - Bitstring adds Erlang-style bitstrings and matching over bitstrings - as a syntax extension and library for OCaml. You can use - this module to both parse and generate binary formats, for - example, communications protocols, disk formats and binary files. - - {{:http://code.google.com/p/bitstring/}OCaml bitstring website} - - This library used to be called "bitmatch". - - {2 Examples} - - A function which can parse IPv4 packets: - -{[ -let display pkt = - bitmatch pkt with - (* IPv4 packet header - 0 1 2 3 - 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | 4 | IHL |Type of Service| Total Length | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Identification |Flags| Fragment Offset | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Time to Live | Protocol | Header Checksum | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Source Address | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Destination Address | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - | Options | Padding | - +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ - *) - | { 4 : 4; hdrlen : 4; tos : 8; length : 16; - identification : 16; flags : 3; fragoffset : 13; - ttl : 8; protocol : 8; checksum : 16; - source : 32; - dest : 32; - options : (hdrlen-5)*32 : bitstring; - payload : -1 : bitstring } -> - - printf "IPv4:\n"; - printf " header length: %d * 32 bit words\n" hdrlen; - printf " type of service: %d\n" tos; - printf " packet length: %d bytes\n" length; - printf " identification: %d\n" identification; - printf " flags: %d\n" flags; - printf " fragment offset: %d\n" fragoffset; - printf " ttl: %d\n" ttl; - printf " protocol: %d\n" protocol; - printf " checksum: %d\n" checksum; - printf " source: %lx dest: %lx\n" source dest; - printf " header options + padding:\n"; - Bitstring.hexdump_bitstring stdout options; - printf " packet payload:\n"; - Bitstring.hexdump_bitstring stdout payload - - | { version : 4 } -> - eprintf "unknown IP version %d\n" version; - exit 1 - - | { _ } as pkt -> - eprintf "data is smaller than one nibble:\n"; - Bitstring.hexdump_bitstring stderr pkt; - exit 1 -]} - - A program which can parse - {{:http://lxr.linux.no/linux/include/linux/ext3_fs.h}Linux EXT3 filesystem superblocks}: - -{[ -let bits = Bitstring.bitstring_of_file "tests/ext3_sb" - -let () = - bitmatch bits with - | { s_inodes_count : 32 : littleendian; (* Inodes count *) - s_blocks_count : 32 : littleendian; (* Blocks count *) - s_r_blocks_count : 32 : littleendian; (* Reserved blocks count *) - s_free_blocks_count : 32 : littleendian; (* Free blocks count *) - s_free_inodes_count : 32 : littleendian; (* Free inodes count *) - s_first_data_block : 32 : littleendian; (* First Data Block *) - s_log_block_size : 32 : littleendian; (* Block size *) - s_log_frag_size : 32 : littleendian; (* Fragment size *) - s_blocks_per_group : 32 : littleendian; (* # Blocks per group *) - s_frags_per_group : 32 : littleendian; (* # Fragments per group *) - s_inodes_per_group : 32 : littleendian; (* # Inodes per group *) - s_mtime : 32 : littleendian; (* Mount time *) - s_wtime : 32 : littleendian; (* Write time *) - s_mnt_count : 16 : littleendian; (* Mount count *) - s_max_mnt_count : 16 : littleendian; (* Maximal mount count *) - 0xef53 : 16 : littleendian } -> (* Magic signature *) - - printf "ext3 superblock:\n"; - printf " s_inodes_count = %ld\n" s_inodes_count; - printf " s_blocks_count = %ld\n" s_blocks_count; - printf " s_free_inodes_count = %ld\n" s_free_inodes_count; - printf " s_free_blocks_count = %ld\n" s_free_blocks_count - - | { _ } -> - eprintf "not an ext3 superblock!\n%!"; - exit 2 -]} - - Constructing packets for a simple binary message - protocol: - -{[ -(* - +---------------+---------------+--------------------------+ - | type | subtype | parameter | - +---------------+---------------+--------------------------+ - <-- 16 bits --> <-- 16 bits --> <------- 32 bits --------> - - All fields are in network byte order. -*) - -let make_message typ subtype param = - (BITSTRING { - typ : 16; - subtype : 16; - param : 32 - }) ;; -]} - - {2 Loading, creating bitstrings} - - The basic data type is the {!bitstring}, a string of bits of - arbitrary length. Bitstrings can be any length in bits and - operations do not need to be byte-aligned (although they will - generally be more efficient if they are byte-aligned). - - Internally a bitstring is stored as a normal OCaml [string] - together with an offset and length, where the offset and length are - measured in bits. Thus one can efficiently form substrings of - bitstrings, overlay a bitstring on existing data, and load and save - bitstrings from files or other external sources. - - To load a bitstring from a file use {!bitstring_of_file} or - {!bitstring_of_chan}. - - There are also functions to create bitstrings from arbitrary data. - See the {{:#reference}reference} below. - - {2 Matching bitstrings with patterns} - - Use the [bitmatch] operator (part of the syntax extension) to break - apart a bitstring into its fields. [bitmatch] works a lot like the - OCaml [match] operator. - - The general form of [bitmatch] is: - - [bitmatch] {i bitstring-expression} [with] - - [| {] {i pattern} [} ->] {i code} - - [| {] {i pattern} [} ->] {i code} - - [|] ... - - As with normal match, the statement attempts to match the - bitstring against each pattern in turn. If none of the patterns - match then the standard library [Match_failure] exception is - thrown. - - Patterns look a bit different from normal match patterns. They - consist of a list of bitfields separated by [;] where each bitfield - contains a bind variable, the width (in bits) of the field, and - other information. Some example patterns: - -{[ -bitmatch bits with - -| { version : 8; name : 8; param : 8 } -> ... - - (* Bitstring of at least 3 bytes. First byte is the version - number, second byte is a field called name, third byte is - a field called parameter. *) - -| { flag : 1 } -> - printf "flag is %b\n" flag - - (* A single flag bit (mapped into an OCaml boolean). *) - -| { len : 4; data : 1+len } -> - printf "len = %d, data = 0x%Lx\n" len data - - (* A 4-bit length, followed by 1-16 bits of data, where the - length of the data is computed from len. *) - -| { ipv6_source : 128 : bitstring; - ipv6_dest : 128 : bitstring } -> ... - - (* IPv6 source and destination addresses. Each is 128 bits - and is mapped into a bitstring type which will be a substring - of the main bitstring expression. *) -]} - - You can also add conditional when-clauses: - -{[ -| { version : 4 } - when version = 4 || version = 6 -> ... - - (* Only match and run the code when version is 4 or 6. If - it isn't we will drop through to the next case. *) -]} - - Note that the pattern is only compared against the first part of - the bitstring (there may be more data in the bitstring following - the pattern, which is not matched). In terms of regular - expressions you might say that the pattern matches [^pattern], not - [^pattern$]. To ensure that the bitstring contains only the - pattern, add a length -1 bitstring to the end and test that its - length is zero in the when-clause: - -{[ -| { n : 4; - rest : -1 : bitstring } - when Bitstring.bitstring_length rest = 0 -> ... - - (* Only matches exactly 4 bits. *) -]} - - Normally the first part of each field is a binding variable, - but you can also match a constant, as in: - -{[ -| { (4|6) : 4 } -> ... - - (* Only matches if the first 4 bits contain either - the integer 4 or the integer 6. *) -]} - - One may also match on strings: - -{[ -| { "MAGIC" : 5*8 : string } -> ... - - (* Only matches if the string "MAGIC" appears at the start - of the input. *) -]} - - {3:patternfieldreference Pattern field reference} - - The exact format of each pattern field is: - - [pattern : length [: qualifier [,qualifier ...]]] - - [pattern] is the pattern, binding variable name, or constant to - match. [length] is the length in bits which may be either a - constant or an expression. The length expression is just an OCaml - expression and can use any values defined in the program, and refer - back to earlier fields (but not to later fields). - - Integers can only have lengths in the range \[1..64\] bits. See the - {{:#integertypes}integer types} section below for how these are - mapped to the OCaml int/int32/int64 types. This is checked - at compile time if the length expression is constant, otherwise it is - checked at runtime and you will get a runtime exception eg. in - the case of a computed length expression. - - A bitstring field of length -1 matches all the rest of the - bitstring (thus this is only useful as the last field in a - pattern). - - A bitstring field of length 0 matches an empty bitstring - (occasionally useful when matching optional subfields). - - Qualifiers are a list of identifiers/expressions which control the type, - signedness and endianness of the field. Permissible qualifiers are: - - - [int]: field has an integer type - - [string]: field is a string type - - [bitstring]: field is a bitstring type - - [signed]: field is signed - - [unsigned]: field is unsigned - - [bigendian]: field is big endian - a.k.a network byte order - - [littleendian]: field is little endian - a.k.a Intel byte order - - [nativeendian]: field is same endianness as the machine - - [endian (expr)]: [expr] should be an expression which evaluates to - a {!endian} type, ie. [LittleEndian], [BigEndian] or [NativeEndian]. - The expression is an arbitrary OCaml expression and can use the - value of earlier fields in the bitmatch. - - [offset (expr)]: see {{:#computedoffsets}computed offsets} below. - - The default settings are [int], [unsigned], [bigendian], no offset. - - Note that many of these qualifiers cannot be used together, - eg. bitstrings do not have endianness. The syntax extension should - give you a compile-time error if you use incompatible qualifiers. - - {3 Other cases in bitmatch} - - As well as a list of fields, it is possible to name the - bitstring and/or have a default match case: - -{[ -| { _ } -> ... - - (* Default match case. *) - -| { _ } as pkt -> ... - - (* Default match case, with 'pkt' bound to the whole bitstring. *) -]} - - {2 Constructing bitstrings} - - Bitstrings may be constructed using the [BITSTRING] operator (as an - expression). The [BITSTRING] operator takes a list of fields, - similar to the list of fields for matching: - -{[ -let version = 1 ;; -let data = 10 ;; -let bits = - BITSTRING { - version : 4; - data : 12 - } ;; - - (* Constructs a 16-bit bitstring with the first four bits containing - the integer 1, and the following 12 bits containing the integer 10, - arranged in network byte order. *) - -Bitstring.hexdump_bitstring stdout bits ;; - - (* Prints: - - 00000000 10 0a |.. | - *) -]} - - The format of each field is the same as for pattern fields (see - {{:#patternfieldreference}Pattern field reference section}), and - things like computed length fields, fixed value fields, insertion - of bitstrings within bitstrings, etc. are all supported. - - {3 Construction exception} - - The [BITSTRING] operator may throw a {!Construct_failure} - exception at runtime. - - Runtime errors include: - - - int field length not in the range \[1..64\] - - a bitstring with a length declared which doesn't have the - same length at runtime - - trying to insert an out of range value into an int field - (eg. an unsigned int field which is 2 bits wide can only - take values in the range \[0..3\]). - - {2:integertypes Integer types} - - Integer types are mapped to OCaml types [bool], [int], [int32] or - [int64] using a system which tries to ensure that (a) the types are - reasonably predictable and (b) the most efficient type is - preferred. - - The rules are slightly different depending on whether the bit - length expression in the field is a compile-time constant or a - computed expression. - - Detection of compile-time constants is quite simplistic so only - simple integer literals and simple expressions (eg. [5*8]) are - recognized as constants. - - In any case the bit size of an integer is limited to the range - \[1..64\]. This is detected as a compile-time error if that is - possible, otherwise a runtime check is added which can throw an - [Invalid_argument] exception. - - The mapping is thus: - - {v - Bit size ---- OCaml type ---- - Constant Computed expression - - 1 bool int64 - 2..31 int int64 - 32 int32 int64 - 33..64 int64 int64 - v} - - A possible future extension may allow people with 64 bit computers - to specify a more optimal [int] type for bit sizes in the range - [32..63]. If this was implemented then such code {i could not even - be compiled} on 32 bit platforms, so it would limit portability. - - Another future extension may be to allow computed - expressions to assert min/max range for the bit size, - allowing a more efficient data type than int64 to be - used. (Of course under such circumstances there would - still need to be a runtime check to enforce the - size). - - {2 Advanced pattern-matching features} - - {3:computedoffsets Computed offsets} - - You can add an [offset(..)] qualifier to bitmatch patterns in order - to move the current offset within the bitstring forwards. - - For example: - -{[ -bitmatch bits with -| { field1 : 8; - field2 : 8 : offset(160) } -> ... -]} - - matches [field1] at the start of the bitstring and [field2] - at 160 bits into the bitstring. The middle 152 bits go - unmatched (ie. can be anything). - - The generated code is efficient. If field lengths and offsets - are known to be constant at compile time, then almost all - runtime checks are avoided. Non-constant field lengths and/or - non-constant offsets can result in more runtime checks being added. - - Note that moving the offset backwards, and moving the offset in - [BITSTRING] constructors, are both not supported at present. - - {3 Check expressions} - - You can add a [check(expr)] qualifier to bitmatch patterns. - If the expression evaluates to false then the current match case - fails to match (in other words, we fall through to the next - match case - there is no error). - - For example: -{[ -bitmatch bits with -| { field : 16 : check (field > 100) } -> ... -]} - - Note the difference between a check expression and a when-clause - is that the when-clause is evaluated after all the fields have - been matched. On the other hand a check expression is evaluated - after the individual field has been matched, which means it is - potentially more efficient (if the check expression fails then - we don't waste any time matching later fields). - - We wanted to use the notation [when(expr)] here, but because - [when] is a reserved word we could not do this. - - {3 Bind expressions} - - A bind expression is used to change the value of a matched - field. For example: -{[ -bitmatch bits with -| { len : 16 : bind (len * 8); - field : len : bitstring } -> ... -]} - - In the example, after 'len' has been matched, its value would - be multiplied by 8, so the width of 'field' is the matched - value multiplied by 8. - - In the general case: -{[ -| { field : ... : bind (expr) } -> ... -]} - evaluates the following after the field has been matched: -{[ - let field = expr in - (* remaining fields *) -]} - - {3 Order of evaluation of check() and bind()} - - The choice is arbitrary, but we have chosen that check expressions - are evaluated first, and bind expressions are evaluated after. - - This means that the result of bind() is {i not} available in - the check expression. - - Note that this rule applies regardless of the order of check() - and bind() in the source code. - - {3 save_offset_to} - - Use [save_offset_to(variable)] to save the current bit offset - within the match to a variable (strictly speaking, to a pattern). - This variable is then made available in any [check()] and [bind()] - clauses in the current field, {i and} to any later fields, and - to the code after the [->]. - - For example: -{[ -bitmatch bits with -| { len : 16; - _ : len : bitstring; - field : 16 : save_offset_to (field_offset) } -> - printf "field is at bit offset %d in the match\n" field_offset -]} - - (In that example, [field_offset] should always have the value - [len+16]). - - {2 Named patterns and persistent patterns} - - Please see {!Bitstring_persistent} for documentation on this subject. - - {2 Compiling} - - Using the compiler directly you can do: - - {v - ocamlc -I +bitstring \ - -pp "camlp4of bitstring.cma bitstring_persistent.cma \ - `ocamlc -where`/bitstring/pa_bitstring.cmo" \ - unix.cma bitstring.cma test.ml -o test - v} - - Simpler method using findlib: - - {v - ocamlfind ocamlc \ - -package bitstring,bitstring.syntax -syntax bitstring.syntax \ - -linkpkg test.ml -o test - v} - - {2 Security and type safety} - - {3 Security on input} - - The main concerns for input are buffer overflows and denial - of service. - - It is believed that this library is robust against attempted buffer - overflows. In addition to OCaml's normal bounds checks, we check - that field lengths are >= 0, and many additional checks. - - Denial of service attacks are more problematic. We only work - forwards through the bitstring, thus computation will eventually - terminate. As for computed lengths, code such as this is thought - to be secure: - - {[ - bitmatch bits with - | { len : 64; - buffer : Int64.to_int len : bitstring } -> - ]} - - The [len] field can be set arbitrarily large by an attacker, but - when pattern-matching against the [buffer] field this merely causes - a test such as [if len <= remaining_size] to fail. Even if the - length is chosen so that [buffer] bitstring is allocated, the - allocation of sub-bitstrings is efficient and doesn't involve an - arbitary-sized allocation or any copying. - - However the above does not necessarily apply to strings used in - matching, since they may cause the library to use the - {!Bitstring.string_of_bitstring} function, which allocates a string. - So you should take care if you use the [string] type particularly - with a computed length that is derived from external input. - - The main protection against attackers should be to ensure that the - main program will only read input bitstrings up to a certain - length, which is outside the scope of this library. - - {3 Security on output} - - As with the input side, computed lengths are believed to be - safe. For example: - - {[ - let len = read_untrusted_source () in - let buffer = allocate_bitstring () in - BITSTRING { - buffer : len : bitstring - } - ]} - - This code merely causes a check that buffer's length is the same as - [len]. However the program function [allocate_bitstring] must - refuse to allocate an oversized buffer (but that is outside the - scope of this library). - - {3 Order of evaluation} - - In [bitmatch] statements, fields are evaluated left to right. - - Note that the when-clause is evaluated {i last}, so if you are - relying on the when-clause to filter cases then your code may do a - lot of extra and unncessary pattern-matching work on fields which - may never be needed just to evaluate the when-clause. Either - rearrange the code to do only the first part of the match, - followed by the when-clause, followed by a second inner bitmatch, - or use a [check()] qualifier within fields. - - {3 Safety} - - The current implementation is believed to be fully type-safe, - and makes compile and run-time checks where appropriate. If - you find a case where a check is missing please submit a - bug report or a patch. - - {2 Limits} - - These are thought to be the current limits: - - Integers: \[1..64\] bits. - - Bitstrings (32 bit platforms): maximum length is limited - by the string size, ie. 16 MBytes. - - Bitstrings (64 bit platforms): maximum length is thought to be - limited by the string size, ie. effectively unlimited. - - Bitstrings must be loaded into memory before we can match against - them. Thus available memory may be considered a limit for some - applications. - - {2:reference Reference} - {3 Types} -*) - -type bitstring = string * int * int -(** [bitstring] is the basic type used to store bitstrings. - - The type contains the underlying data (a string), - the current bit offset within the string and the - current bit length of the string (counting from the - bit offset). Note that the offset and length are - in {b bits}, not bytes. - - Normally you don't need to use the bitstring type - directly, since there are functions and syntax - extensions which hide the details. - - See also {!bitstring_of_string}, {!bitstring_of_file}, - {!hexdump_bitstring}, {!bitstring_length}. -*) - -type t = bitstring -(** [t] is a synonym for the {!bitstring} type. - - This allows you to use this module with functors like - [Set] and [Map] from the stdlib. *) - -(** {3 Exceptions} *) - -exception Construct_failure of string * string * int * int -(** [Construct_failure (message, file, line, char)] may be - raised by the [BITSTRING] constructor. - - Common reasons are that values are out of range of - the fields that contain them, or that computed lengths - are impossible (eg. negative length bitfields). - - [message] is the error message. - - [file], [line] and [char] point to the original source - location of the [BITSTRING] constructor that failed. -*) - -(** {3 Bitstring comparison} *) - -val compare : bitstring -> bitstring -> int -(** [compare bs1 bs2] compares two bitstrings and returns zero - if they are equal, a negative number if [bs1 < bs2], or a - positive number if [bs1 > bs2]. - - This tests "semantic equality" which is not affected by - the offset or alignment of the underlying representation - (see {!bitstring}). - - The ordering is total and lexicographic. *) - -val equals : bitstring -> bitstring -> bool -(** [equals] returns true if and only if the two bitstrings are - semantically equal. It is the same as calling [compare] and - testing if the result is [0], but usually more efficient. *) - -(** {3 Bitstring manipulation} *) - -val bitstring_length : bitstring -> int -(** [bitstring_length bitstring] returns the length of - the bitstring in bits. - - Note this just returns the third field in the {!bitstring} tuple. *) - -val subbitstring : bitstring -> int -> int -> bitstring -(** [subbitstring bits off len] returns a sub-bitstring - of the bitstring, starting at offset [off] bits and - with length [len] bits. - - If the original bitstring is not long enough to do this - then the function raises [Invalid_argument "subbitstring"]. - - Note that this function just changes the offset and length - fields of the {!bitstring} tuple, so is very efficient. *) - -val dropbits : int -> bitstring -> bitstring -(** Drop the first n bits of the bitstring and return a new - bitstring which is shorter by n bits. - - If the length of the original bitstring is less than n bits, - this raises [Invalid_argument "dropbits"]. - - Note that this function just changes the offset and length - fields of the {!bitstring} tuple, so is very efficient. *) - -val takebits : int -> bitstring -> bitstring -(** Take the first n bits of the bitstring and return a new - bitstring which is exactly n bits long. - - If the length of the original bitstring is less than n bits, - this raises [Invalid_argument "takebits"]. - - Note that this function just changes the offset and length - fields of the {!bitstring} tuple, so is very efficient. *) - -val concat : bitstring list -> bitstring -(** Concatenate a list of bitstrings together into a single - bitstring. *) - -(** {3 Constructing bitstrings} *) - -val empty_bitstring : bitstring -(** [empty_bitstring] is the empty, zero-length bitstring. *) - -val create_bitstring : int -> bitstring -(** [create_bitstring n] creates an [n] bit bitstring - containing all zeroes. *) - -val make_bitstring : int -> char -> bitstring -(** [make_bitstring n c] creates an [n] bit bitstring - containing the repeated 8 bit pattern in [c]. - - For example, [make_bitstring 16 '\x5a'] will create - the bitstring [0x5a5a] or in binary [0101 1010 0101 1010]. - - Note that the length is in bits, not bytes. The length does NOT - need to be a multiple of 8. *) - -val zeroes_bitstring : int -> bitstring -(** [zeroes_bitstring] creates an [n] bit bitstring of all 0's. - - Actually this is the same as {!create_bitstring}. *) - -val ones_bitstring : int -> bitstring -(** [ones_bitstring] creates an [n] bit bitstring of all 1's. *) - -val bitstring_of_string : string -> bitstring -(** [bitstring_of_string str] creates a bitstring - of length [String.length str * 8] (bits) containing the - bits in [str]. - - Note that the bitstring uses [str] as the underlying - string (see the representation of {!bitstring}) so you - should not change [str] after calling this. *) - -val bitstring_of_file : string -> bitstring -(** [bitstring_of_file filename] loads the named file - into a bitstring. *) - -val bitstring_of_chan : in_channel -> bitstring -(** [bitstring_of_chan chan] loads the contents of - the input channel [chan] as a bitstring. - - The length of the final bitstring is determined - by the remaining input in [chan], but will always - be a multiple of 8 bits. - - See also {!bitstring_of_chan_max}. *) - -val bitstring_of_chan_max : in_channel -> int -> bitstring -(** [bitstring_of_chan_max chan max] works like - {!bitstring_of_chan} but will only read up to - [max] bytes from the channel (or fewer if the end of input - occurs before that). *) - -val bitstring_of_file_descr : Unix.file_descr -> bitstring -(** [bitstring_of_file_descr fd] loads the contents of - the file descriptor [fd] as a bitstring. - - See also {!bitstring_of_chan}, {!bitstring_of_file_descr_max}. *) - -val bitstring_of_file_descr_max : Unix.file_descr -> int -> bitstring -(** [bitstring_of_file_descr_max fd max] works like - {!bitstring_of_file_descr} but will only read up to - [max] bytes from the channel (or fewer if the end of input - occurs before that). *) - -(** {3 Converting bitstrings} *) - -val string_of_bitstring : bitstring -> string -(** [string_of_bitstring bitstring] converts a bitstring to a string - (eg. to allow comparison). - - This function is inefficient. In the best case when the bitstring - is nicely byte-aligned we do a [String.sub] operation. If the - bitstring isn't aligned then this involves a lot of bit twiddling - and is particularly inefficient. - - If the bitstring is not a multiple of 8 bits wide then the - final byte of the string contains the high bits set to the - remaining bits and the low bits set to 0. *) - -val bitstring_to_file : bitstring -> string -> unit -(** [bitstring_to_file bits filename] writes the bitstring [bits] - to the file [filename]. It overwrites the output file. - - Some restrictions apply, see {!bitstring_to_chan}. *) - -val bitstring_to_chan : bitstring -> out_channel -> unit -(** [bitstring_to_file bits filename] writes the bitstring [bits] - to the channel [chan]. - - Channels are made up of bytes, bitstrings can be any bit length - including fractions of bytes. So this function only works - if the length of the bitstring is an exact multiple of 8 bits - (otherwise it raises [Invalid_argument "bitstring_to_chan"]). - - Furthermore the function is efficient only in the case where - the bitstring is stored fully aligned, otherwise it has to - do inefficient bit twiddling like {!string_of_bitstring}. - - In the common case where the bitstring was generated by the - [BITSTRING] operator and is an exact multiple of 8 bits wide, - then this function will always work efficiently. -*) - -(** {3 Printing bitstrings} *) - -val hexdump_bitstring : out_channel -> bitstring -> unit -(** [hexdump_bitstring chan bitstring] prints the bitstring - to the output channel in a format similar to the - Unix command [hexdump -C]. *) - -(** {3 Bitstring buffer} *) - -module Buffer : sig - type t - val create : unit -> t - val contents : t -> bitstring - val add_bits : t -> string -> int -> unit - val add_bit : t -> bool -> unit - val add_byte : t -> int -> unit -end -(** Buffers are mainly used by the [BITSTRING] constructor, but - may also be useful for end users. They work much like the - standard library [Buffer] module. *) - -(** {3 Get/set bits} - - These functions let you manipulate individual bits in the - bitstring. However they are not particularly efficient and you - should generally use the [bitmatch] and [BITSTRING] operators when - building and parsing bitstrings. - - These functions all raise [Invalid_argument "index out of bounds"] - if the index is out of range of the bitstring. -*) - -val set : bitstring -> int -> unit - (** [set bits n] sets the [n]th bit in the bitstring to 1. *) - -val clear : bitstring -> int -> unit - (** [clear bits n] sets the [n]th bit in the bitstring to 0. *) - -val is_set : bitstring -> int -> bool - (** [is_set bits n] is true if the [n]th bit is set to 1. *) - -val is_clear : bitstring -> int -> bool - (** [is_clear bits n] is true if the [n]th bit is set to 0. *) - -val put : bitstring -> int -> int -> unit - (** [put bits n v] sets the [n]th bit in the bitstring to 1 - if [v] is not zero, or to 0 if [v] is zero. *) - -val get : bitstring -> int -> int - (** [get bits n] returns the [n]th bit (returns non-zero or 0). *) - -(** {3 Miscellaneous} *) - -val package : string -(** The package name, always ["ocaml-bitstring"] *) - -val version : string -(** The package version as a string. *) - -val debug : bool ref -(** Set this variable to true to enable extended debugging. - This only works if debugging was also enabled in the - [pa_bitstring.ml] file at compile time, otherwise it - does nothing. *) - -type endian = BigEndian | LittleEndian | NativeEndian - -val string_of_endian : endian -> string - -val nativeendian : endian - -(**/**) - -(* Private functions, called from generated code. Do not use - * these directly - they are not safe. - *) - -(* 'extract' functions are used in bitmatch statements. *) - -val extract_bit : string -> int -> int -> int -> bool - -val extract_char_unsigned : string -> int -> int -> int -> int - -val extract_int_be_unsigned : string -> int -> int -> int -> int - -val extract_int_le_unsigned : string -> int -> int -> int -> int - -val extract_int_ne_unsigned : string -> int -> int -> int -> int - -val extract_int_ee_unsigned : endian -> string -> int -> int -> int -> int - -val extract_int32_be_unsigned : string -> int -> int -> int -> int32 - -val extract_int32_le_unsigned : string -> int -> int -> int -> int32 - -val extract_int32_ne_unsigned : string -> int -> int -> int -> int32 - -val extract_int32_ee_unsigned : endian -> string -> int -> int -> int -> int32 - -val extract_int64_be_unsigned : string -> int -> int -> int -> int64 - -val extract_int64_le_unsigned : string -> int -> int -> int -> int64 - -val extract_int64_ne_unsigned : string -> int -> int -> int -> int64 - -val extract_int64_ee_unsigned : endian -> string -> int -> int -> int -> int64 - -external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc" - -external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc" - -external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc" - -external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc" - -external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc" - -external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc" - -(* -external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc" - -external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc" - -external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc" - -external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc" - -external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc" - -external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc" -*) - -external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc" - -external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc" - -external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc" - -external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc" - -external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc" - -external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc" - -(* -external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc" - -external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc" - -external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc" - -external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc" - -external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc" - -external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc" - -external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc" - -external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc" - -external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc" - -external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc" - -external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc" - -external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc" - -external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc" - -external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc" - -external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc" - -external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc" - -external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc" - -external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc" -*) - -external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc" - -external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc" - -external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc" - -external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc" - -external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc" - -external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc" - -(* 'construct' functions are used in BITSTRING constructors. *) -val construct_bit : Buffer.t -> bool -> int -> exn -> unit - -val construct_char_unsigned : Buffer.t -> int -> int -> exn -> unit - -val construct_int_be_unsigned : Buffer.t -> int -> int -> exn -> unit - -val construct_int_le_unsigned : Buffer.t -> int -> int -> exn -> unit - -val construct_int_ne_unsigned : Buffer.t -> int -> int -> exn -> unit - -val construct_int_ee_unsigned : endian -> Buffer.t -> int -> int -> exn -> unit - -val construct_int32_be_unsigned : Buffer.t -> int32 -> int -> exn -> unit - -val construct_int32_le_unsigned : Buffer.t -> int32 -> int -> exn -> unit - -val construct_int32_ne_unsigned : Buffer.t -> int32 -> int -> exn -> unit - -val construct_int32_ee_unsigned : endian -> Buffer.t -> int32 -> int -> exn -> unit - -val construct_int64_be_unsigned : Buffer.t -> int64 -> int -> exn -> unit - -val construct_int64_le_unsigned : Buffer.t -> int64 -> int -> exn -> unit - -val construct_int64_ne_unsigned : Buffer.t -> int64 -> int -> exn -> unit - -val construct_int64_ee_unsigned : endian -> Buffer.t -> int64 -> int -> exn -> unit - -val construct_string : Buffer.t -> string -> unit - -val construct_bitstring : Buffer.t -> bitstring -> unit diff --git a/src/utils/bitstring/bitstring_c.c b/src/utils/bitstring/bitstring_c.c deleted file mode 100644 index fb3e4064..00000000 --- a/src/utils/bitstring/bitstring_c.c +++ /dev/null @@ -1,141 +0,0 @@ -/* Bitstring library. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - */ - -/* This file contains hand-coded, optimized C implementations of - * certain very frequently used functions. - */ - -#include "../../../config/config.h" - -#include -#include -#include -#if defined(HAVE_BYTESWAP_H) -#include -#else -#include "byteswap.h" -#endif - -#include -#include - -/* Fastpath functions. These are used in the common case for reading - * ints where the following conditions are known to be true: - * (a) the int size is a whole number of bytes (eg. 16, 24, 32, etc bits) - * (b) the access in the match is byte-aligned - * (c) the access in the underlying bitstring is byte-aligned - * - * These functions are all "noalloc" meaning they must not perform - * any OCaml allocations. For this reason, when the function returns - * an int32 or int64, the OCaml code passes in the pre-allocated pointer - * to the return value. - * - * The final offset in the string is calculated by the OCaml (caller) - * code. All we need to do is to read the string+offset and byteswap, - * sign-extend as necessary. - * - * There is one function for every combination of: - * (i) int size: 16, 32, 64 bits - * (ii) endian: bigendian, littleendian, nativeendian - * (iii) signed and unsigned - * - * XXX Future work: Expand this to 24, 40, 48, 56 bits. This - * requires some extra work because sign-extension won't "just happen". - */ - -#ifdef ARCH_BIG_ENDIAN -#define swap_be(size,v) -#define swap_le(size,v) v = bswap_##size (v) -#define swap_ne(size,v) -#else -#define swap_be(size,v) v = bswap_##size (v) -#define swap_le(size,v) -#define swap_ne(size,v) -#endif - -#define fastpath1(size,endian,signed,type) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv) \ - { \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - return Val_int (r); \ - } - -fastpath1(16,be,unsigned,uint16_t) -fastpath1(16,le,unsigned,uint16_t) -fastpath1(16,ne,unsigned,uint16_t) -fastpath1(16,be,signed,int16_t) -fastpath1(16,le,signed,int16_t) -fastpath1(16,ne,signed,int16_t) - -#define fastpath2(size,endian,signed,type,rval) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv, value rv) \ - { \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - rval(rv) = r; \ - return rv; \ - } - -fastpath2(32,be,unsigned,uint32_t,Int32_val) -fastpath2(32,le,unsigned,uint32_t,Int32_val) -fastpath2(32,ne,unsigned,uint32_t,Int32_val) -fastpath2(32,be,signed,int32_t,Int32_val) -fastpath2(32,le,signed,int32_t,Int32_val) -fastpath2(32,ne,signed,int32_t,Int32_val) - -/* Special care needs to be taken on ARCH_ALIGN_INT64 platforms - (hppa and sparc in Debian). */ - -#ifdef ARCH_ALIGN_INT64 -#include -#include -#define fastpath3(size,endian,signed,type,rval) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv, value rv) \ - { \ - CAMLparam3(strv, offv, rv); \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - CAMLreturn(caml_copy_int64(r)); \ - } - -#else -#define fastpath3 fastpath2 -#endif - -fastpath3(64,be,unsigned,uint64_t,Int64_val) -fastpath3(64,le,unsigned,uint64_t,Int64_val) -fastpath3(64,ne,unsigned,uint64_t,Int64_val) -fastpath3(64,be,signed,int64_t,Int64_val) -fastpath3(64,le,signed,int64_t,Int64_val) -fastpath3(64,ne,signed,int64_t,Int64_val) diff --git a/src/utils/bitstring/bitstring_persistent.mlc4 b/src/utils/bitstring/bitstring_persistent.mlc4 deleted file mode 100644 index ff97a653..00000000 --- a/src/utils/bitstring/bitstring_persistent.mlc4 +++ /dev/null @@ -1,274 +0,0 @@ -(* Bitstring persistent patterns. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - *) - -open Printf - -open Camlp4.PreCast -open Syntax -open Ast - -type patt = Camlp4.PreCast.Syntax.Ast.patt -type expr = Camlp4.PreCast.Syntax.Ast.expr -type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t - -(* Field. In bitmatch (patterns) the type is [patt field]. In - * BITSTRING (constructor) the type is [expr field]. - *) -type 'a field = { - field : 'a; (* field ('a is either patt or expr) *) - flen : expr; (* length in bits, may be non-const *) - endian : endian_expr; (* endianness *) - signed : bool; (* true if signed, false if unsigned *) - t : field_type; (* type *) - _loc : Loc.t; (* location in source code *) - offset : expr option; (* offset expression *) - check : expr option; (* check expression [patterns only] *) - bind : expr option; (* bind expression [patterns only] *) - save_offset_to : patt option; (* save_offset_to [patterns only] *) -} -and field_type = Int | String | Bitstring (* field type *) -and endian_expr = - | ConstantEndian of Bitstring.endian (* a constant little/big/nativeendian *) - | EndianExpr of expr (* an endian expression *) - -type pattern = patt field list - -type constructor = expr field list - -type named = string * alt -and alt = - | Pattern of pattern - | Constructor of constructor - -(* Work out if an expression is an integer constant. - * - * Returns [Some i] if so (where i is the integer value), else [None]. - * - * Fairly simplistic algorithm: we can only detect simple constant - * expressions such as [k], [k+c], [k-c] etc. - *) -let rec expr_is_constant = function - | <:expr< $int:i$ >> -> (* Literal integer constant. *) - Some (int_of_string i) - | <:expr< $a$ + $b$ >> -> (* Addition of constants. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a+b) - | _ -> None) - | <:expr< $a$ - $b$ >> -> (* Subtraction. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a-b) - | _ -> None) - | <:expr< $a$ * $b$ >> -> (* Multiplication. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a*b) - | _ -> None) - | <:expr< $a$ / $b$ >> -> (* Division. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a/b) - | _ -> None) - | <:expr< $a$ lsl $b$ >> -> (* Shift left. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a lsl b) - | _ -> None) - | <:expr< $a$ lsr $b$ >> -> (* Shift right. *) - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> Some (a lsr b) - | _ -> None) - | _ -> None (* Anything else is not constant. *) - -let string_of_field_type = function - | Int -> "int" - | String -> "string" - | Bitstring -> "bitstring" - -let patt_printer = function - | <:patt< $lid:id$ >> -> id - | <:patt< _ >> -> "_" - | _ -> "[pattern]" - -let rec expr_printer = function - | <:expr< $lid:id$ >> -> id - | <:expr< $int:i$ >> -> i - | <:expr< $lid:op$ $a$ $b$ >> -> - sprintf "%s %s %s" op (expr_printer a) (expr_printer b) - | _ -> "[expr]" - -let _string_of_field { flen = flen; - endian = endian; signed = signed; t = t; - _loc = _loc; - offset = offset; check = check; bind = bind; - save_offset_to = save_offset_to; field = _ } = - let flen = expr_printer flen in - let endian = - match endian with - | ConstantEndian endian -> Bitstring.string_of_endian endian - | EndianExpr expr -> sprintf "endian(%s)" (expr_printer expr) in - let signed = if signed then "signed" else "unsigned" in - let t = string_of_field_type t in - - let offset = - match offset with - | None -> "" - | Some expr -> sprintf ", offset(%s)" (expr_printer expr) in - - let check = - match check with - | None -> "" - | Some expr -> sprintf ", check(%s)" (expr_printer expr) in - - let bind = - match bind with - | None -> "" - | Some expr -> sprintf ", bind(%s)" (expr_printer expr) in - - let save_offset_to = - match save_offset_to with - | None -> "" - | Some patt -> - match patt with - | <:patt< $lid:id$ >> -> sprintf ", save_offset_to(%s)" id - | _ -> sprintf ", save_offset_to([patt])" in - - let loc_fname = Loc.file_name _loc in - let loc_line = Loc.start_line _loc in - let loc_char = Loc.start_off _loc - Loc.start_bol _loc in - - sprintf "%s : %s, %s, %s%s%s%s%s (* %S:%d %d *)" - flen t endian signed offset check bind save_offset_to - loc_fname loc_line loc_char - -let string_of_pattern_field ({ field = patt; _ } as field) = - sprintf "%s : %s" (patt_printer patt) (_string_of_field field) - -and string_of_constructor_field ({ field = expr; _ } as field) = - sprintf "%s : %s" (expr_printer expr) (_string_of_field field) - -let string_of_pattern pattern = - "{ " ^ - String.concat ";\n " (List.map string_of_pattern_field pattern) ^ - " }\n" - -let string_of_constructor constructor = - "{ " ^ - String.concat ";\n " (List.map string_of_constructor_field constructor) ^ - " }\n" - -let named_to_channel chan n = Marshal.to_channel chan n [] - -let named_to_string n = Marshal.to_string n [] - -let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n [] - -let named_from_channel = Marshal.from_channel - -let named_from_string = Marshal.from_string - -let create_pattern_field _loc = - { - field = <:patt< _ >>; - flen = <:expr< 32 >>; - endian = ConstantEndian Bitstring.BigEndian; - signed = false; - t = Int; - _loc = _loc; - offset = None; - check = None; - bind = None; - save_offset_to = None; - } - -let set_lident_patt field id = - let _loc = field._loc in - { field with field = <:patt< $lid:id$ >> } -let set_int_patt field i = - let _loc = field._loc in - { field with field = <:patt< $`int:i$ >> } -let set_string_patt field str = - let _loc = field._loc in - { field with field = <:patt< $str:str$ >> } -let set_unbound_patt field = - let _loc = field._loc in - { field with field = <:patt< _ >> } -let set_patt field patt = { field with field = patt } -let set_length_int field flen = - let _loc = field._loc in - { field with flen = <:expr< $`int:flen$ >> } -let set_length field flen = { field with flen = flen } -let set_endian field endian = { field with endian = ConstantEndian endian } -let set_endian_expr field expr = { field with endian = EndianExpr expr } -let set_signed field signed = { field with signed = signed } -let set_type_int field = { field with t = Int } -let set_type_string field = { field with t = String } -let set_type_bitstring field = { field with t = Bitstring } -let set_location field loc = { field with _loc = loc } -let set_offset_int field i = - let _loc = field._loc in - { field with offset = Some <:expr< $`int:i$ >> } -let set_offset field expr = { field with offset = Some expr } -let set_no_offset field = { field with offset = None } -let set_check field expr = { field with check = Some expr } -let set_no_check field = { field with check = None } -let set_bind field expr = { field with bind = Some expr } -let set_no_bind field = { field with bind = None } -let set_save_offset_to field patt = { field with save_offset_to = Some patt } -let set_save_offset_to_lident field id = - let _loc = field._loc in - { field with save_offset_to = Some <:patt< $lid:id$ >> } -let set_no_save_offset_to field = { field with save_offset_to = None } - -let create_constructor_field _loc = - { - field = <:expr< 0 >>; - flen = <:expr< 32 >>; - endian = ConstantEndian Bitstring.BigEndian; - signed = false; - t = Int; - _loc = _loc; - offset = None; - check = None; - bind = None; - save_offset_to = None; - } - -let set_lident_expr field id = - let _loc = field._loc in - { field with field = <:expr< $lid:id$ >> } -let set_int_expr field i = - let _loc = field._loc in - { field with field = <:expr< $`int:i$ >> } -let set_string_expr field str = - let _loc = field._loc in - { field with field = <:expr< $str:str$ >> } -let set_expr field expr = - let _loc = field._loc in - { field with field = expr } - -let get_patt field = field.field -let get_expr field = field.field -let get_length field = field.flen -let get_endian field = field.endian -let get_signed field = field.signed -let get_type field = field.t -let get_location field = field._loc -let get_offset field = field.offset -let get_check field = field.check -let get_bind field = field.bind -let get_save_offset_to field = field.save_offset_to diff --git a/src/utils/bitstring/bitstring_persistent.mli b/src/utils/bitstring/bitstring_persistent.mli deleted file mode 100644 index 250306af..00000000 --- a/src/utils/bitstring/bitstring_persistent.mli +++ /dev/null @@ -1,539 +0,0 @@ -(** Bitstring persistent patterns. *) -(* Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - *) - -(** - {b Warning:} This documentation is for ADVANCED USERS ONLY. - If you are not an advanced user, you are probably looking - for {{:Bitstring.html}the Bitstring documentation}. - - {{:#reference}Jump straight to the reference section for - documentation on types and functions}. - - {2 Introduction} - - Bitstring allows you to name sets of fields and reuse them - elsewhere. For example if you frequently need to parse - Pascal-style strings in the form length byte + string, then you - could name the [{ strlen : 8 : int; str : strlen*8 : string }] - pattern and reuse it everywhere by name. - - These are called {b persistent patterns}. - - The basic usage is: - -{v -(* Create a persistent pattern called 'pascal_string' which - * matches Pascal-style strings (length byte + string). - *) -let bitmatch pascal_string = - \{ strlen : 8 : int; - str : strlen*8 : string } - -let is_pascal_string bits = - bitmatch bits with - | \{ :pascal_string } -> - printf "matches a Pascal string %s, len %d bytes\n" - str strlen -v} - - or: - -{v -(* Load a persistent pattern from a file. *) -open bitmatch "pascal.bmpp" - -let is_pascal_string bits = - bitmatch bits with - | \{ :pascal_string } -> - printf "matches a Pascal string %s, len %d bytes\n" - str strlen -v} - - {3 Important notes} - - There are some important things you should know about - persistent patterns before you decide to use them: - - 'Persistent' refers to the fact that they can be saved into binary - files. However these binary files use OCaml [Marshal] module and - depend (sometimes) on the version of OCaml used to generate them - and (sometimes) the version of bitstring used. So your build system - should rebuild these files from source when your code is rebuilt. - - Persistent patterns are syntactic. They work in the same way - as cutting and pasting (or [#include]-ing) code. For example - if a persistent pattern binds a field named [len], then any - uses of [len] following in the surrounding pattern could - be affected. - - Programs which generate and manipulate persistent patterns have to - link to camlp4. Since camlp4 in OCaml >= 3.10 is rather large, we - have placed this code into this separate submodule, so that - programs which just use bitstring don't need to pull in the whole of - camlp4. This restriction does not apply to code which only uses - persistent patterns but does not generate them. If the distinction - isn't clear, use [ocamlobjinfo] to look at the dependencies of your - [*.cmo] files. - - Persistent patterns can be generated in several ways, but they - can only be {i used} by the [pa_bitstring] syntax extension. - This means they are purely compile-time constructs. You - cannot use them to make arbitrary patterns and run those - patterns (not unless your program runs [ocamlc] to make a [*.cmo] - file then dynamically links to the [*.cmo] file). - - {2 Named patterns} - - A named pattern is a way to name a pattern and use it later - in the same source file. To name a pattern, use: - - [let bitmatch name = { fields ... } ;;] - - and you can then use the name later on inside another pattern, - by prefixing the name with a colon. - For example: - - [bitmatch bits with { :name } -> ...] - - You can nest named patterns within named patterns to any depth. - - Currently the use of named patterns is somewhat limited. - The restrictions are: - - Named patterns can only be used within the same source file, and - the names occupy a completely separate namespace from anything - else in the source file. - - The [let bitmatch] syntax only works at the top level. We may - add a [let bitmatch ... in] for inner levels later. - - Because you cannot rename the bound identifiers in named - patterns, you can effectively only use them once in a - pattern. For example, [{ :name; :name }] is legal, but - any bindings in the first name would be overridden by - the second name. - - There are no "named constructors" yet, but the machinery - is in place to do this, and we may add them later. - - {2 Persistent patterns in files} - - More useful than just naming patterns, you can load - persistent patterns from external files. The patterns - in these external files can come from a variety of sources: - for example, in the [cil-tools] subdirectory are some - {{:http://cil.sf.net/}Cil-based} tools for importing C - structures from header files. You can also generate - your own files or write your own tools, as described below. - - To use the persistent pattern(s) from a file do: - - [open bitmatch "filename.bmpp" ;;] - - A list of zero or more {!named} patterns are read from the file - and each is bound to a name (as contained in the file), - and then the patterns can be used with the usual [:name] - syntax described above. - - {3 Extension} - - The standard extension is [.bmpp]. This is just a convention - and you can use any extension you want. - - {3 Directory search order} - - If the filename is an absolute or explicit path, then we try to - load it from that path and stop if it fails. See the [Filename] - module in the standard OCaml library for the definitions of - "absolute path" and "explicit path". Otherwise we use the - following directory search order: - - - Relative to the current directory - - Relative to the OCaml library directory - - {3 bitstring-objinfo} - - The [bitstring-objinfo] command can be run on a file in order - to print out the patterns in the file. - - {3 Constructors} - - We haven't implemented persistent constructors yet, although - the machinery is in place to make this happen. Any constructors - found in the file are ignored. - - {2 Creating your own persistent patterns} - - If you want to write a tool to import bitstrings from an - exotic location or markup language, you will need - to use the functions found in the {{:#reference}reference section}. - - I will describe using an example here of how you would - programmatically create a persistent pattern which - matches Pascal-style "length byte + data" strings. - Firstly note that there are two fields, so our pattern - will be a list of length 2 and type {!pattern}. - - You will need to create a camlp4 location object ([Loc.t]) - describing the source file. This source file is used - to generate useful error messages for the user, so - you may want to set it to be the name and location in - the file that your tool reads for input. By convention, - locations are bound to name [_loc]: - - {v - let _loc = Loc.move_line 42 (Loc.mk "input.xml") - v} - - Create a pattern field representing a length field which is 8 bits wide, - bound to the identifier [len]: - - {v - let len_field = create_pattern_field _loc - let len_field = set_length_int len_field 8 - let len_field = set_lident_patt len_field "len" - v} - - Create a pattern field representing a string of [len*8] bits. - Note that the use of [<:expr< >>] quotation requires - you to preprocess your source with [camlp4of] - (see {{:http://brion.inria.fr/gallium/index.php/Reflective_OCaml}this - page on Reflective OCaml}). - - {v - let str_field = create_pattern_field _loc - let str_field = set_length str_field <:expr< len*8 >> - let str_field = set_lident_patt str_field "str" - let str_field = set_type_string str_field - v} - - Join the two fields together and name it: - - {v - let pattern = [len_field; str_field] - let named_pattern = "pascal_string", Pattern pattern - v} - - Save it to a file: - - {v - let chan = open_out "output.bmpp" in - named_to_channel chan named_pattern; - close_out chan - v} - - You can now use this pattern in another program like this: - - {v - open bitmatch "output.bmpp" ;; - let parse_pascal_string bits = - bitmatch bits with - | \{ :pascal_string } -> str, len - | \{ _ } -> invalid_arg "not a Pascal string" - v} - - You can write more than one named pattern to the output file, and - they will all be loaded at the same time by [open bitmatch ".."] - (obviously you should give each pattern a different name). To do - this, just call {!named_to_channel} as many times as needed. - - {2:reference Reference} - - {3 Types} -*) - -type patt = Camlp4.PreCast.Syntax.Ast.patt -type expr = Camlp4.PreCast.Syntax.Ast.expr -type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t -(** Just short names for the camlp4 types. *) - -type 'a field -(** A field in a persistent pattern or persistent constructor. *) - -type pattern = patt field list -(** A persistent pattern (used in [bitmatch] operator), is just a - list of pattern fields. *) - -type constructor = expr field list -(** A persistent constructor (used in [BITSTRING] operator), is just a - list of constructor fields. *) - -type named = string * alt -and alt = - | Pattern of pattern (** Pattern *) - | Constructor of constructor (** Constructor *) -(** A named pattern or constructor. - - The name is used when binding a pattern from a file, but - is otherwise ignored. *) - -(** {3 Printers} *) - -val string_of_pattern : pattern -> string -val string_of_constructor : constructor -> string -val string_of_pattern_field : patt field -> string -val string_of_constructor_field : expr field -> string -(** Convert patterns, constructors or individual fields - into printable strings for debugging purposes. - - The strings look similar to the syntax used by bitmatch, but - some things cannot be printed fully, eg. length expressions. *) - -(** {3 Persistence} *) - -val named_to_channel : out_channel -> named -> unit -(** Save a pattern/constructor to an output channel. *) - -val named_to_string : named -> string -(** Serialize a pattern/constructor to a string. *) - -val named_to_buffer : string -> int -> int -> named -> int -(** Serialize a pattern/constructor to part of a string, return the length. *) - -val named_from_channel : in_channel -> named -(** Load a pattern/constructor from an output channel. - - Note: This is not type safe. The pattern/constructor must - have been written out under the same version of OCaml and - the same version of bitstring. *) - -val named_from_string : string -> int -> named -(** Load a pattern/constructor from a string at offset within the string. - - Note: This is not type safe. The pattern/constructor must - have been written out under the same version of OCaml and - the same version of bitstring. *) - -(** {3 Create pattern fields} - - These fields are used in pattern matches ([bitmatch]). *) - -val create_pattern_field : loc_t -> patt field -(** Create a pattern field. - - The pattern is unbound, the type is set to [int], bit length to [32], - endianness to [BigEndian], signedness to unsigned ([false]), - source code location to the [_loc] parameter, and no offset expression. - - To create a complete field you need to call the [set_*] - functions. For example, to create [{ len : 8 : int }] - you would do: - -{v - let field = create_pattern_field _loc in - let field = set_lident_patt field "len" in - let field = set_length_int field 8 in -v} -*) - -val set_lident_patt : patt field -> string -> patt field -(** Sets the pattern to the pattern binding an identifier - given in the string. - - The effect is that the field [{ len : 8 : int }] could - be created by calling [set_lident_patt field "len"]. *) - -val set_int_patt : patt field -> int -> patt field -(** Sets the pattern field to the pattern which matches an integer. - - The effect is that the field [{ 2 : 8 : int }] could - be created by calling [set_int_patt field 2]. *) - -val set_string_patt : patt field -> string -> patt field -(** Sets the pattern field to the pattern which matches a string. - - The effect is that the field [{ "MAGIC" : 8*5 : string }] could - be created by calling [set_int_patt field "MAGIC"]. *) - -val set_unbound_patt : patt field -> patt field -(** Sets the pattern field to the unbound pattern (usually written [_]). - - The effect is that the field [{ _ : 8 : int }] could - be created by calling [set_unbound_patt field]. *) - -val set_patt : patt field -> patt -> patt field -(** Sets the pattern field to an arbitrary OCaml pattern match. *) - -val set_length_int : 'a field -> int -> 'a field -(** Sets the length in bits of a field to a constant integer. - - The effect is that the field [{ len : 8 : string }] could - be created by calling [set_length field 8]. *) - -val set_length : 'a field -> expr -> 'a field -(** Sets the length in bits of a field to an OCaml expression. - - The effect is that the field [{ len : 2*i : string }] could - be created by calling [set_length field <:expr< 2*i >>]. *) - -val set_endian : 'a field -> Bitstring.endian -> 'a field -(** Sets the endianness of a field to the constant endianness. - - The effect is that the field [{ _ : 16 : bigendian }] could - be created by calling [set_endian field Bitstring.BigEndian]. *) - -val set_endian_expr : 'a field -> expr -> 'a field -(** Sets the endianness of a field to an endianness expression. - - The effect is that the field [{ _ : 16 : endian(e) }] could - be created by calling [set_endian_expr field e]. *) - -val set_signed : 'a field -> bool -> 'a field -(** Sets the signedness of a field to a constant signedness. - - The effect is that the field [{ _ : 16 : signed }] could - be created by calling [set_signed field true]. *) - -val set_type_int : 'a field -> 'a field -(** Sets the type of a field to [int]. - - The effect is that the field [{ _ : 16 : int }] could - be created by calling [set_type_int field]. *) - -val set_type_string : 'a field -> 'a field -(** Sets the type of a field to [string]. - - The effect is that the field [{ str : 16 : string }] could - be created by calling [set_type_string field]. *) - -val set_type_bitstring : 'a field -> 'a field -(** Sets the type of a field to [bitstring]. - - The effect is that the field [{ _ : 768 : bitstring }] could - be created by calling [set_type_bitstring field]. *) - -val set_location : 'a field -> loc_t -> 'a field -(** Sets the source code location of a field. This is used when - pa_bitstring displays error messages. *) - -val set_offset_int : 'a field -> int -> 'a field -(** Set the offset expression for a field to the given number. - - The effect is that the field [{ _ : 8 : offset(160) }] could - be created by calling [set_offset_int field 160]. *) - -val set_offset : 'a field -> expr -> 'a field -(** Set the offset expression for a field to the given expression. - - The effect is that the field [{ _ : 8 : offset(160) }] could - be created by calling [set_offset_int field <:expr< 160 >>]. *) - -val set_no_offset : 'a field -> 'a field -(** Remove the offset expression from a field. The field will - follow the previous field, or if it is the first field will - be at offset zero. *) - -val set_check : 'a field -> expr -> 'a field -(** Set the check expression for a field to the given expression. *) - -val set_no_check : 'a field -> 'a field -(** Remove the check expression from a field. *) - -val set_bind : 'a field -> expr -> 'a field -(** Set the bind-expression for a field to the given expression. *) - -val set_no_bind : 'a field -> 'a field -(** Remove the bind-expression from a field. *) - -val set_save_offset_to : 'a field -> patt -> 'a field -(** Set the save_offset_to pattern for a field to the given pattern. *) - -val set_save_offset_to_lident : 'a field -> string -> 'a field -(** Set the save_offset_to pattern for a field to identifier. *) - -val set_no_save_offset_to : 'a field -> 'a field -(** Remove the save_offset_to from a field. *) - -(** {3 Create constructor fields} - - These fields are used in constructors ([BITSTRING]). *) - -val create_constructor_field : loc_t -> expr field -(** Create a constructor field. - - The defaults are the same as for {!create_pattern_field} - except that the expression is initialized to [0]. -*) - -val set_lident_expr : expr field -> string -> expr field -(** Sets the expression in a constructor field to an expression - which uses the identifier. - - The effect is that the field [{ len : 8 : int }] could - be created by calling [set_lident_expr field "len"]. *) - -val set_int_expr : expr field -> int -> expr field -(** Sets the expression to the value of the integer. - - The effect is that the field [{ 2 : 8 : int }] could - be created by calling [set_int_expr field 2]. *) - -val set_string_expr : expr field -> string -> expr field -(** Sets the expression to the value of the string. - - The effect is that the field [{ "MAGIC" : 8*5 : string }] could - be created by calling [set_int_expr field "MAGIC"]. *) - -val set_expr : expr field -> expr -> expr field -(** Sets the expression field to an arbitrary OCaml expression. *) - -(** {3 Accessors} *) - -val get_patt : patt field -> patt -(** Get the pattern from a pattern field. *) - -val get_expr : expr field -> expr -(** Get the expression from an expression field. *) - -val get_length : 'a field -> expr -(** Get the length in bits from a field. Note that what is returned - is an OCaml expression, since lengths can be non-constant. *) - -type endian_expr = - | ConstantEndian of Bitstring.endian - | EndianExpr of expr - -val get_endian : 'a field -> endian_expr -(** Get the endianness of a field. This is an {!endian_expr} which - could be a constant or an OCaml expression. *) - -val get_signed : 'a field -> bool -(** Get the signedness of a field. *) - -type field_type = Int | String | Bitstring - -val get_type : 'a field -> field_type -(** Get the type of a field, [Int], [String] or [Bitstring]. *) - -val get_location : 'a field -> loc_t -(** Get the source code location of a field. *) - -val get_offset : 'a field -> expr option -(** Get the offset expression of a field, or [None] if there is none. *) - -val get_check : 'a field -> expr option -(** Get the check expression of a field, or [None] if there is none. *) - -val get_bind : 'a field -> expr option -(** Get the bind expression of a field, or [None] if there is none. *) - -val get_save_offset_to : 'a field -> patt option -(** Get the save_offset_to pattern of a field, or [None] if there is none. *) diff --git a/src/utils/bitstring/byteswap.h b/src/utils/bitstring/byteswap.h deleted file mode 100644 index 5e4652e2..00000000 --- a/src/utils/bitstring/byteswap.h +++ /dev/null @@ -1,54 +0,0 @@ -/* byteswap.h - Byte swapping - Copyright (C) 2005, 2007 Free Software Foundation, Inc. - Written by Oskar Liljeblad , 2005. - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -/* NB: - - This file is from Gnulib, and in accordance with the convention - there, the real license of this file comes from the module - definition. It is really LGPLv2+. - - - RWMJ. 2008/08/23 -*/ - -#ifndef _GL_BYTESWAP_H -#define _GL_BYTESWAP_H - -/* Given an unsigned 16-bit argument X, return the value corresponding to - X with reversed byte order. */ -#define bswap_16(x) ((((x) & 0x00FF) << 8) | \ - (((x) & 0xFF00) >> 8)) - -/* Given an unsigned 32-bit argument X, return the value corresponding to - X with reversed byte order. */ -#define bswap_32(x) ((((x) & 0x000000FF) << 24) | \ - (((x) & 0x0000FF00) << 8) | \ - (((x) & 0x00FF0000) >> 8) | \ - (((x) & 0xFF000000) >> 24)) - -/* Given an unsigned 64-bit argument X, return the value corresponding to - X with reversed byte order. */ -#define bswap_64(x) ((((x) & 0x00000000000000FFULL) << 56) | \ - (((x) & 0x000000000000FF00ULL) << 40) | \ - (((x) & 0x0000000000FF0000ULL) << 24) | \ - (((x) & 0x00000000FF000000ULL) << 8) | \ - (((x) & 0x000000FF00000000ULL) >> 8) | \ - (((x) & 0x0000FF0000000000ULL) >> 24) | \ - (((x) & 0x00FF000000000000ULL) >> 40) | \ - (((x) & 0xFF00000000000000ULL) >> 56)) - -#endif /* _GL_BYTESWAP_H */ diff --git a/src/utils/bitstring/pa_bitstring.mlt b/src/utils/bitstring/pa_bitstring.mlt deleted file mode 100644 index 9d84f388..00000000 --- a/src/utils/bitstring/pa_bitstring.mlt +++ /dev/null @@ -1,1193 +0,0 @@ -(* Bitstring syntax extension. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version, - * with the OCaml linking exception described in COPYING.LIB. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ - *) - -open Printf - -open Camlp4.PreCast -open Syntax -open Ast - -open Bitstring -module P = Bitstring_persistent - -(* If this is true then we emit some debugging code which can - * be useful to tell what is happening during matches. You - * also need to do 'Bitstring.debug := true' in your main program. - * - * If this is false then no extra debugging code is emitted. - *) -let debug = false - -(* Hashtable storing named persistent patterns. *) -let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13 - -let locfail _loc msg = Loc.raise _loc (Failure msg) - -(* Work out if an expression is an integer constant. - * - * Returns [Some i] if so (where i is the integer value), else [None]. - * - * Fairly simplistic algorithm: we can only detect simple constant - * expressions such as [k], [k+c], [k-c] etc. - *) -let rec expr_is_constant = function - | <:expr< $int:i$ >> -> (* Literal integer constant. *) - Some (int_of_string i) - | <:expr< $lid:op$ $a$ $b$ >> -> - (match expr_is_constant a, expr_is_constant b with - | Some a, Some b -> (* Integer binary operations. *) - let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/); - (* NB: explicit fun .. -> is necessary here to work - * around a camlp4 bug in OCaml 3.10.0. - *) - "land", (fun a b -> a land b); - "lor", (fun a b -> a lor b); - "lxor", (fun a b -> a lxor b); - "lsl", (fun a b -> a lsl b); - "lsr", (fun a b -> a lsr b); - "asr", (fun a b -> a asr b); - "mod", (fun a b -> a mod b)] in - (try Some ((List.assoc op ops) a b) with Not_found -> None) - | _ -> None) - | _ -> None - -(* Generate a fresh, unique symbol each time called. *) -let gensym = - let i = ref 1000 in - fun name -> - incr i; let i = !i in - sprintf "__pabitstring_%s_%d" name i - -(* Used to keep track of which qualifiers we've seen in parse_field. *) -type whatset_t = { - endian_set : bool; signed_set : bool; type_set : bool; - offset_set : bool; check_set : bool; bind_set : bool; - save_offset_to_set : bool; -} -let noneset = { - endian_set = false; signed_set = false; type_set = false; - offset_set = false; check_set = false; bind_set = false; - save_offset_to_set = false -} - -(* Deal with the qualifiers which appear for a field of both types. *) -let parse_field _loc field qs = - let fail = locfail _loc in - - let whatset, field = - match qs with - | None -> noneset, field - | Some qs -> - let check already_set msg = if already_set then fail msg in - let apply_qualifier (whatset, field) = - function - | "endian", Some expr -> - check whatset.endian_set "an endian flag has been set already"; - let field = P.set_endian_expr field expr in - { whatset with endian_set = true }, field - | "endian", None -> - fail "qualifier 'endian' should be followed by an expression" - | "offset", Some expr -> - check whatset.offset_set "an offset has been set already"; - let field = P.set_offset field expr in - { whatset with offset_set = true }, field - | "offset", None -> - fail "qualifier 'offset' should be followed by an expression" - | "check", Some expr -> - check whatset.check_set "a check-qualifier has been set already"; - let field = P.set_check field expr in - { whatset with check_set = true }, field - | "check", None -> - fail "qualifier 'check' should be followed by an expression" - | "bind", Some expr -> - check whatset.bind_set "a bind expression has been set already"; - let field = P.set_bind field expr in - { whatset with bind_set = true }, field - | "bind", None -> - fail "qualifier 'bind' should be followed by an expression" - | "save_offset_to", Some expr (* XXX should be a pattern *) -> - check whatset.save_offset_to_set - "a save_offset_to-qualifier has been set already"; - let id = - match expr with - | <:expr< $lid:id$ >> -> id - | _ -> - failwith "pa_bitstring: internal error: save_offset_to only supports simple identifiers at the moment. In future we should support full patterns." in - let field = P.set_save_offset_to_lident field id in - { whatset with save_offset_to_set = true }, field - | "save_offset_to", None -> - fail "qualifier 'save_offset_to' should be followed by a binding expression" - | s, Some _ -> - fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression") - | qual, None -> - let endian_quals = ["bigendian", BigEndian; - "littleendian", LittleEndian; - "nativeendian", NativeEndian] in - let sign_quals = ["signed", true; "unsigned", false] in - let type_quals = ["int", P.set_type_int; - "string", P.set_type_string; - "bitstring", P.set_type_bitstring] in - if List.mem_assoc qual endian_quals then ( - check whatset.endian_set "an endian flag has been set already"; - let field = P.set_endian field (List.assoc qual endian_quals) in - { whatset with endian_set = true }, field - ) else if List.mem_assoc qual sign_quals then ( - check whatset.signed_set "a signed flag has been set already"; - let field = P.set_signed field (List.assoc qual sign_quals) in - { whatset with signed_set = true }, field - ) else if List.mem_assoc qual type_quals then ( - check whatset.type_set "a type flag has been set already"; - let field = (List.assoc qual type_quals) field in - { whatset with type_set = true }, field - ) else - fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in - List.fold_left apply_qualifier (noneset, field) qs in - - (* If type is set to string or bitstring then endianness and - * signedness qualifiers are meaningless and must not be set. - *) - let () = - let t = P.get_type field in - if (t = P.Bitstring || t = P.String) && - (whatset.endian_set || whatset.signed_set) then - fail "string types and endian or signed qualifiers cannot be mixed" in - - (* Default endianness, signedness, type if not set already. *) - let field = - if whatset.endian_set then field else P.set_endian field BigEndian in - let field = - if whatset.signed_set then field else P.set_signed field false in - let field = - if whatset.type_set then field else P.set_type_int field in - - field - -type functype = ExtractFunc | ConstructFunc - -(* Choose the right constructor function. *) -let build_bitstring_call _loc functype length endian signed = - match functype, length, endian, signed with - (* XXX The meaning of signed/unsigned breaks down at - * 31, 32, 63 and 64 bits. - *) - | (ExtractFunc, Some 1, _, _) -> <:expr< Bitstring.extract_bit >> - | (ConstructFunc, Some 1, _, _) -> <:expr< Bitstring.construct_bit >> - | (functype, Some (2|3|4|5|6|7|8), _, signed) -> - let funcname = match functype with - | ExtractFunc -> "extract" - | ConstructFunc -> "construct" in - let sign = if signed then "signed" else "unsigned" in - let call = sprintf "%s_char_%s" funcname sign in - <:expr< Bitstring.$lid:call$ >> - | (functype, len, endian, signed) -> - let funcname = match functype with - | ExtractFunc -> "extract" - | ConstructFunc -> "construct" in - let t = match len with - | Some i when i <= 31 -> "int" - | Some 32 -> "int32" - | _ -> "int64" in - let sign = if signed then "signed" else "unsigned" in - match endian with - | P.ConstantEndian constant -> - let endianness = match constant with - | BigEndian -> "be" - | LittleEndian -> "le" - | NativeEndian -> "ne" in - let call = sprintf "%s_%s_%s_%s" funcname t endianness sign in - <:expr< Bitstring.$lid:call$ >> - | P.EndianExpr expr -> - let call = sprintf "%s_%s_%s_%s" funcname t "ee" sign in - <:expr< Bitstring.$lid:call$ $expr$ >> - -(* Generate the code for a constructor, ie. 'BITSTRING ...'. *) -let output_constructor _loc fields = - (* This function makes code to raise a Bitstring.Construct_failure exception - * containing a message and the current _loc context. - * (Thanks to Bluestorm for suggesting this). - *) - let construct_failure _loc msg = - <:expr< - Bitstring.Construct_failure - ($`str:msg$, - $`str:Loc.file_name _loc$, - $`int:Loc.start_line _loc$, - $`int:Loc.start_off _loc - Loc.start_bol _loc$) - >> - in - let raise_construct_failure _loc msg = - <:expr< raise $construct_failure _loc msg$ >> - in - - (* Bitstrings are created like the 'Buffer' module (in fact, using - * the Buffer module), by appending snippets to a growing buffer. - * This is reasonably efficient and avoids a lot of garbage. - *) - let buffer = gensym "buffer" in - - (* General exception which is raised inside the constructor functions - * when an int expression is out of range at runtime. - *) - let exn = gensym "exn" in - let exn_used = ref false in - - (* Convert each field to a simple bitstring-generating expression. *) - let fields = List.map ( - fun field -> - let fexpr = P.get_expr field in - let flen = P.get_length field in - let endian = P.get_endian field in - let signed = P.get_signed field in - let t = P.get_type field in - let _loc = P.get_location field in - - let fail = locfail _loc in - - (* offset(), check(), bind(), save_offset_to() not supported in - * constructors. - * - * Implementation of forward-only offsets is fairly - * straightforward: we would need to just calculate the length of - * padding here and add it to what has been constructed. For - * general offsets, including going backwards, that would require - * a rethink in how we construct bitstrings. - *) - if P.get_offset field <> None then - fail "offset expressions are not supported in BITSTRING constructors"; - if P.get_check field <> None then - fail "check expressions are not supported in BITSTRING constructors"; - if P.get_bind field <> None then - fail "bind expressions are not supported in BITSTRING constructors"; - if P.get_save_offset_to field <> None then - fail "save_offset_to is not supported in BITSTRING constructors"; - - (* Is flen an integer constant? If so, what is it? This - * is very simple-minded and only detects simple constants. - *) - let flen_is_const = expr_is_constant flen in - - let int_construct_const (i, endian, signed) = - build_bitstring_call _loc ConstructFunc (Some i) endian signed in - let int_construct (endian, signed) = - build_bitstring_call _loc ConstructFunc None endian signed in - - let expr = - match t, flen_is_const with - (* Common case: int field, constant flen. - * - * Range checks are done inside the construction function - * because that's a lot simpler w.r.t. types. It might - * be better to move them here. XXX - *) - | P.Int, Some i when i > 0 && i <= 64 -> - let construct_fn = int_construct_const (i,endian,signed) in - exn_used := true; - - <:expr< - $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$ - >> - - | P.Int, Some _ -> - fail "length of int field must be [1..64]" - - (* Int field, non-constant length. We need to perform a runtime - * test to ensure the length is [1..64]. - * - * Range checks are done inside the construction function - * because that's a lot simpler w.r.t. types. It might - * be better to move them here. XXX - *) - | P.Int, None -> - let construct_fn = int_construct (endian,signed) in - exn_used := true; - - <:expr< - if $flen$ >= 1 && $flen$ <= 64 then - $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ - else - $raise_construct_failure _loc "length of int field must be [1..64]"$ - >> - - (* String, constant length > 0, must be a multiple of 8. *) - | P.String, Some i when i > 0 && i land 7 = 0 -> - let bs = gensym "bs" in - let j = i lsr 3 in - <:expr< - let $lid:bs$ = $fexpr$ in - if String.length $lid:bs$ = $`int:j$ then - Bitstring.construct_string $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of string does not match declaration"$ - >> - - (* String, constant length -1, means variable length string - * with no checks. - *) - | P.String, Some (-1) -> - <:expr< Bitstring.construct_string $lid:buffer$ $fexpr$ >> - - (* String, constant length = 0 is probably an error, and so is - * any other value. - *) - | P.String, Some _ -> - fail "length of string must be > 0 and a multiple of 8, or the special value -1" - - (* String, non-constant length. - * We check at runtime that the length is > 0, a multiple of 8, - * and matches the declared length. - *) - | P.String, None -> - let bslen = gensym "bslen" in - let bs = gensym "bs" in - <:expr< - let $lid:bslen$ = $flen$ in - if $lid:bslen$ > 0 then ( - if $lid:bslen$ land 7 = 0 then ( - let $lid:bs$ = $fexpr$ in - if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then - Bitstring.construct_string $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of string does not match declaration"$ - ) else - $raise_construct_failure _loc "length of string must be a multiple of 8"$ - ) else - $raise_construct_failure _loc "length of string must be > 0"$ - >> - - (* Bitstring, constant length >= 0. *) - | P.Bitstring, Some i when i >= 0 -> - let bs = gensym "bs" in - <:expr< - let $lid:bs$ = $fexpr$ in - if Bitstring.bitstring_length $lid:bs$ = $`int:i$ then - Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of bitstring does not match declaration"$ - >> - - (* Bitstring, constant length -1, means variable length bitstring - * with no checks. - *) - | P.Bitstring, Some (-1) -> - <:expr< Bitstring.construct_bitstring $lid:buffer$ $fexpr$ >> - - (* Bitstring, constant length < -1 is an error. *) - | P.Bitstring, Some _ -> - fail "length of bitstring must be >= 0 or the special value -1" - - (* Bitstring, non-constant length. - * We check at runtime that the length is >= 0 and matches - * the declared length. - *) - | P.Bitstring, None -> - let bslen = gensym "bslen" in - let bs = gensym "bs" in - <:expr< - let $lid:bslen$ = $flen$ in - if $lid:bslen$ >= 0 then ( - let $lid:bs$ = $fexpr$ in - if Bitstring.bitstring_length $lid:bs$ = $lid:bslen$ then - Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of bitstring does not match declaration"$ - ) else - $raise_construct_failure _loc "length of bitstring must be > 0"$ - >> in - expr - ) fields in - - (* Create the final bitstring. Start by creating an empty buffer - * and then evaluate each expression above in turn which will - * append some more to the bitstring buffer. Finally extract - * the bitstring. - * - * XXX We almost have enough information to be able to guess - * a good initial size for the buffer. - *) - let fields = - match fields with - | [] -> <:expr< [] >> - | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in - - let expr = - <:expr< - let $lid:buffer$ = Bitstring.Buffer.create () in - $fields$; - Bitstring.Buffer.contents $lid:buffer$ - >> in - - if !exn_used then - <:expr< - let $lid:exn$ = $construct_failure _loc "value out of range"$ in - $expr$ - >> - else - expr - -(* Generate the code for a bitmatch statement. '_loc' is the - * location, 'bs' is the bitstring parameter, 'cases' are - * the list of cases to test against. - *) -let output_bitmatch _loc bs cases = - (* These symbols are used through the generated code to record our - * current position within the bitstring: - * - * data - original bitstring data (string, never changes) - * off - current offset within data (int, increments as we move through - * the bitstring) - * len - current remaining length within data (int, decrements as - * we move through the bitstring) - * - * Also: - * - * original_off - saved offset at the start of the match (never changes) - * original_len - saved length at the start of the match (never changes) - * off_aligned - true if the original offset is byte-aligned (allows - * us to make some common optimizations) - *) - let data = gensym "data" - and off = gensym "off" - and len = gensym "len" - and original_off = gensym "original_off" - and original_len = gensym "original_len" - and off_aligned = gensym "off_aligned" - - (* This is where the result will be stored (a reference). *) - and result = gensym "result" in - - (* This generates the field extraction code for each - * field in a single case. There must be enough remaining data - * in the bitstring to satisfy the field. - * - * As we go through the fields, symbols 'data', 'off' and 'len' - * track our position and remaining length in the bitstring. - * - * The whole thing is a lot of nested 'if'/'match' statements. - * Code is generated from the inner-most (last) field outwards. - *) - let rec output_field_extraction inner = function - | [] -> inner - | field :: fields -> - let fpatt = P.get_patt field in - let flen = P.get_length field in - let endian = P.get_endian field in - let signed = P.get_signed field in - let t = P.get_type field in - let _loc = P.get_location field in - - let fail = locfail _loc in - - (* Is flen (field len) an integer constant? If so, what is it? - * This will be [Some i] if it's a constant or [None] if it's - * non-constant or we couldn't determine. - *) - let flen_is_const = expr_is_constant flen in - - (* Surround the inner expression by check and bind clauses, so: - * if $check$ then - * let $bind...$ in - * $inner$ - * where the check and bind are switched on only if they are - * present in the field. (In the common case when neither - * clause is present, expr = inner). Note the order of the - * check & bind is visible to the user and defined in the - * documentation, so it must not change. - *) - let expr = inner in - let expr = - match P.get_bind field with - | None -> expr - | Some bind_expr -> - <:expr< let $fpatt$ = $bind_expr$ in $expr$ >> in - let expr = - match P.get_check field with - | None -> expr - | Some check_expr -> - <:expr< if $check_expr$ then $expr$ >> in - - (* Compute the offset of this field within the match, if it - * can be known at compile time. - * - * Actually, we'll compute two things: the 'natural_field_offset' - * is the offset assuming this field had no offset() qualifier - * (in other words, its position, immediately following the - * preceding field). 'field_offset' is the real field offset - * taking into account any offset() qualifier. - * - * This will be [Some i] if our current offset is known - * at compile time, or [None] if we can't determine it. - *) - let natural_field_offset, field_offset = - let has_constant_offset field = - match P.get_offset field with - | None -> false - | Some expr -> - match expr_is_constant expr with - | None -> false - | Some i -> true - in - let get_constant_offset field = - match P.get_offset field with - | None -> assert false - | Some expr -> - match expr_is_constant expr with - | None -> assert false - | Some i -> i - in - - let has_constant_len field = - match expr_is_constant (P.get_length field) with - | None -> false - | Some i when i > 0 -> true - | Some _ -> false - in - let get_constant_len field = - match expr_is_constant (P.get_length field) with - | None -> assert false - | Some i when i > 0 -> i - | Some _ -> assert false - in - - (* NB: We are looping over the PRECEDING fields in reverse order. *) - let rec loop = function - (* first field has constant offset 0 *) - | [] -> Some 0 - (* preceding field with constant offset & length *) - | f :: _ - when has_constant_offset f && has_constant_len f -> - Some (get_constant_offset f + get_constant_len f) - (* preceding field with no offset & constant length *) - | f :: fs - when P.get_offset f = None && has_constant_len f -> - (match loop fs with - | None -> None - | Some offset -> Some (offset + get_constant_len f)) - (* else, can't work out the offset *) - | _ -> None - in - - let natural_field_offset = loop fields in - - let field_offset = - match P.get_offset field with - | None -> natural_field_offset - | Some expr -> (* has an offset() clause *) - match expr_is_constant expr with - | None -> None - | i -> i in - - natural_field_offset, field_offset in - - (* Also compute if the field_offset is known to be byte-aligned at - * compile time, which is usually both the common and best possible - * case for generating optimized code. - * - * This is None if not aligned / don't know. - * Or Some byte_offset if we can work it out. - *) - let field_offset_aligned = - match field_offset with - | None -> None (* unknown, assume no *) - | Some off when off land 7 = 0 -> Some (off lsr 3) - | Some _ -> None in (* definitely no *) - - (* Now build the code which matches a single field. *) - let int_extract_const i endian signed = - build_bitstring_call _loc ExtractFunc (Some i) endian signed in - let int_extract endian signed = - build_bitstring_call _loc ExtractFunc None endian signed in - - let expr = - match t, flen_is_const, field_offset_aligned, endian, signed with - (* Very common cases: int field, constant 8/16/32/64 bit - * length, aligned to the match at a known offset. We - * still have to check if the bitstring is aligned (can only - * be known at runtime) but we may be able to directly access - * the bytes in the string. - *) - | P.Int, Some 8, Some field_byte_offset, _, _ -> - let extract_fn = int_extract_const 8 endian signed in - - (* The fast-path code when everything is aligned. *) - let fastpath = - <:expr< - let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - Char.code (String.unsafe_get $lid:data$ o) - >> in - - <:expr< - if $lid:len$ >= 8 then ( - let v = - if $lid:off_aligned$ then - $fastpath$ - else - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ 8 in - let $lid:off$ = $lid:off$ + 8 - and $lid:len$ = $lid:len$ - 8 in - match v with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - | P.Int, Some ((16|32|64) as i), - Some field_byte_offset, (P.ConstantEndian _ as endian), signed -> - let extract_fn = int_extract_const i endian signed in - - (* The fast-path code when everything is aligned. *) - let fastpath = - let fastpath_call = - let endian = match endian with - | P.ConstantEndian BigEndian -> "be" - | P.ConstantEndian LittleEndian -> "le" - | P.ConstantEndian NativeEndian -> "ne" - | P.EndianExpr _ -> assert false in - let signed = if signed then "signed" else "unsigned" in - let name = - sprintf "extract_fastpath_int%d_%s_%s" i endian signed in - match i with - | 16 -> - <:expr< Bitstring.$lid:name$ $lid:data$ o >> - | 32 -> - <:expr< - (* must allocate a new zero each time *) - let zero = Int32.of_int 0 in - Bitstring.$lid:name$ $lid:data$ o zero - >> - | 64 -> - <:expr< - (* must allocate a new zero each time *) - let zero = Int64.of_int 0 in - Bitstring.$lid:name$ $lid:data$ o zero - >> - | _ -> assert false in - <:expr< - (* Starting offset within the string. *) - let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - $fastpath_call$ - >> in - - let slowpath = - <:expr< - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ - >> in - - <:expr< - if $lid:len$ >= $`int:i$ then ( - let v = - if $lid:off_aligned$ then $fastpath$ else $slowpath$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match v with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - (* Common case: int field, constant flen *) - | P.Int, Some i, _, _, _ when i > 0 && i <= 64 -> - let extract_fn = int_extract_const i endian signed in - let v = gensym "val" in - <:expr< - if $lid:len$ >= $`int:i$ then ( - let $lid:v$ = - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - | P.Int, Some _, _, _, _ -> - fail "length of int field must be [1..64]" - - (* Int field, non-const flen. We have to test the range of - * the field at runtime. If outside the range it's a no-match - * (not an error). - *) - | P.Int, None, _, _, _ -> - let extract_fn = int_extract endian signed in - let v = gensym "val" in - <:expr< - if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then ( - let $lid:v$ = - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - (* String, constant flen > 0. - * The field is at a known byte-aligned offset so we may - * be able to optimize the substring extraction. - *) - | P.String, Some i, Some field_byte_offset, _, _ - when i > 0 && i land 7 = 0 -> - let fastpath = - <:expr< - (* Starting offset within the string. *) - let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - String.sub $lid:data$ o $`int:(i lsr 3)$ - >> in - - let slowpath = - <:expr< - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $`int:i$) - >> in - - let cond = - <:expr< - if $lid:off_aligned$ then $fastpath$ else $slowpath$ - >> in - - <:expr< - if $lid:len$ >= $`int:i$ then ( - let str = $cond$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match str with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> - - (* String, constant flen > 0. *) - | P.String, Some i, None, _, _ when i > 0 && i land 7 = 0 -> - <:expr< - if $lid:len$ >= $`int:i$ then ( - let str = - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $`int:i$) in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match str with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> - - (* String, constant flen = -1, means consume all the - * rest of the input. - * XXX It should be possible to optimize this for known byte - * offset, but the optimization is tricky because the end/length - * of the string may not be byte-aligned. - *) - | P.String, Some i, _, _, _ when i = -1 -> - let str = gensym "str" in - - <:expr< - let $lid:str$ = - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $lid:len$) in - let $lid:off$ = $lid:off$ + $lid:len$ in - let $lid:len$ = 0 in - match $lid:str$ with - | $fpatt$ when true -> $expr$ - | _ -> () - >> - - | P.String, Some _, _, _, _ -> - fail "length of string must be > 0 and a multiple of 8, or the special value -1" - - (* String field, non-const flen. We check the flen is > 0 - * and a multiple of 8 (-1 is not allowed here), at runtime. - *) - | P.String, None, _, _, _ -> - let bs = gensym "bs" in - <:expr< - if $flen$ >= 0 && $flen$ <= $lid:len$ - && $flen$ land 7 = 0 then ( - let $lid:bs$ = ($lid:data$, $lid:off$, $flen$) in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - match Bitstring.string_of_bitstring $lid:bs$ with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> - - (* Bitstring, constant flen >= 0. - * At the moment all we can do is assign the bitstring to an - * identifier. - *) - | P.Bitstring, Some i, _, _, _ when i >= 0 -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - if $lid:len$ >= $`int:i$ then ( - let $lid:ident$ = ($lid:data$, $lid:off$, $`int:i$) in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - $expr$ - ) - >> - - (* Bitstring, constant flen = -1, means consume all the - * rest of the input. - *) - | P.Bitstring, Some i, _, _, _ when i = -1 -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - let $lid:ident$ = ($lid:data$, $lid:off$, $lid:len$) in - let $lid:off$ = $lid:off$ + $lid:len$ in - let $lid:len$ = 0 in - $expr$ - >> - - | P.Bitstring, Some _, _, _, _ -> - fail "length of bitstring must be >= 0 or the special value -1" - - (* Bitstring field, non-const flen. We check the flen is >= 0 - * (-1 is not allowed here) at runtime. - *) - | P.Bitstring, None, _, _, _ -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - if $flen$ >= 0 && $flen$ <= $lid:len$ then ( - let $lid:ident$ = ($lid:data$, $lid:off$, $flen$) in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - $expr$ - ) - >> - in - - (* Computed offset: only offsets forward are supported. - * - * We try hard to optimize this based on what we know. Are - * we at a predictable offset now? (Look at the outer 'fields' - * list and see if they all have constant field length starting - * at some constant offset). Is this offset constant? - * - * Based on this we can do a lot of the computation at - * compile time, or defer it to runtime only if necessary. - * - * In all cases, the off and len fields get updated. - *) - let expr = - match P.get_offset field with - | None -> expr (* common case: there was no offset expression *) - | Some offset_expr -> - (* This will be [Some i] if offset is a constant expression - * or [None] if it's a non-constant. - *) - let requested_offset = expr_is_constant offset_expr in - - (* Look at the field offset (if known) and requested offset - * cases and determine what code to generate. - *) - match natural_field_offset, requested_offset with - (* This is the good case: both the field offset and - * the requested offset are constant, so we can remove - * almost all the runtime checks. - *) - | Some natural_field_offset, Some requested_offset -> - let move = requested_offset - natural_field_offset in - if move < 0 then - fail (sprintf "requested offset is less than the field offset (%d < %d)" requested_offset natural_field_offset); - (* Add some code to move the offset and length by a - * constant amount, and a runtime test that len >= 0 - * (XXX possibly the runtime test is unnecessary?) - *) - <:expr< - let $lid:off$ = $lid:off$ + $`int:move$ in - let $lid:len$ = $lid:len$ - $`int:move$ in - if $lid:len$ >= 0 then $expr$ - >> - (* In any other case, we need to use runtime checks. - * - * XXX It's not clear if a backwards move detected at runtime - * is merely a match failure, or a runtime error. At the - * moment it's just a match failure since bitmatch generally - * doesn't raise runtime errors. - *) - | _ -> - let move = gensym "move" in - <:expr< - let $lid:move$ = - $offset_expr$ - ($lid:off$ - $lid:original_off$) in - if $lid:move$ >= 0 then ( - let $lid:off$ = $lid:off$ + $lid:move$ in - let $lid:len$ = $lid:len$ - $lid:move$ in - if $lid:len$ >= 0 then $expr$ - ) - >> in (* end of computed offset code *) - - (* save_offset_to(patt) saves the current offset into a variable. *) - let expr = - match P.get_save_offset_to field with - | None -> expr (* no save_offset_to *) - | Some patt -> - <:expr< - let $patt$ = $lid:off$ - $lid:original_off$ in - $expr$ - >> in - - (* Emit extra debugging code. *) - let expr = - if not debug then expr else ( - let field = P.string_of_pattern_field field in - - <:expr< - if !Bitstring.debug then ( - Printf.eprintf "PA_BITSTRING: TEST:\n"; - Printf.eprintf " %s\n" $str:field$; - Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$; - (*Bitstring.hexdump_bitstring stderr - ($lid:data$,$lid:off$,$lid:len$);*) - ); - $expr$ - >> - ) in - - output_field_extraction expr fields - in - - (* Convert each case in the match. *) - let cases = List.map ( - fun (fields, bind, whenclause, code) -> - let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in - let inner = - match whenclause with - | Some whenclause -> - <:expr< if $whenclause$ then $inner$ >> - | None -> inner in - let inner = - match bind with - | Some name -> - <:expr< - let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in - $inner$ - >> - | None -> inner in - output_field_extraction inner (List.rev fields) - ) cases in - - (* Join them into a single expression. - * - * Don't do it with a normal fold_right because that leaves - * 'raise Exit; ()' at the end which causes a compiler warning. - * Hence a bit of complexity here. - * - * Note that the number of cases is always >= 1 so List.hd is safe. - *) - let cases = List.rev cases in - let cases = - List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>) - (List.hd cases) (List.tl cases) in - - (* The final code just wraps the list of cases in a - * try/with construct so that each case is tried in - * turn until one case matches (that case sets 'result' - * and raises 'Exit' to leave the whole statement). - * If result isn't set by the end then we will raise - * Match_failure with the location of the bitmatch - * statement in the original code. - *) - let loc_fname = Loc.file_name _loc in - let loc_line = string_of_int (Loc.start_line _loc) in - let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in - - <:expr< - (* Note we save the original offset/length at the start of the match - * in 'original_off'/'original_len' symbols. 'data' never changes. - * This code also ensures that if original_off/original_len/off_aligned - * aren't actually used, we don't get a warning. - *) - let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in - let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in - let $lid:off_aligned$ = $lid:off$ land 7 = 0 in - ignore $lid:off_aligned$; - let $lid:result$ = ref None in - (try - $cases$ - with Exit -> ()); - match ! $lid:result$ with - | Some x -> x - | None -> raise (Match_failure ($str:loc_fname$, - $int:loc_line$, $int:loc_char$)) - >> - -(* Add a named pattern. *) -let add_named_pattern _loc name pattern = - Hashtbl.add pattern_hash name pattern - -(* Expand a named pattern from the pattern_hash. *) -let expand_named_pattern _loc name = - try Hashtbl.find pattern_hash name - with Not_found -> - locfail _loc (sprintf "named pattern not found: %s" name) - -(* Add named patterns from a file. See the documentation on the - * directory search path in bitstring_persistent.mli -let load_patterns_from_file _loc filename = - let chan = - if Filename.is_relative filename && Filename.is_implicit filename then ( - (* Try current directory. *) - try open_in filename - with _ -> - (* Try OCaml library directory. *) - try open_in (Filename.concat Bitstring_config.ocamllibdir filename) - with exn -> Loc.raise _loc exn - ) else ( - try open_in filename - with exn -> Loc.raise _loc exn - ) in - let names = ref [] in - (try - let rec loop () = - let name = P.named_from_channel chan in - names := name :: !names - in - loop () - with End_of_file -> () - ); - close_in chan; - let names = List.rev !names in - List.iter ( - function - | name, P.Pattern patt -> - if patt = [] then - locfail _loc (sprintf "pattern %s: no fields" name); - add_named_pattern _loc name patt - | _, P.Constructor _ -> () (* just ignore these for now *) - ) names - *) - -EXTEND Gram - GLOBAL: expr str_item; - - (* Qualifiers are a list of identifiers ("string", "bigendian", etc.) - * followed by an optional expression (used in certain cases). Note - * that we are careful not to declare any explicit reserved words. - *) - qualifiers: [ - [ LIST0 - [ q = LIDENT; - e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ] - SEP "," ] - ]; - - (* Field used in the bitmatch operator (a pattern). This can actually - * return multiple fields, in the case where the 'field' is a named - * persitent pattern. - *) - patt_field: [ - [ fpatt = patt; ":"; len = expr LEVEL "top"; - qs = OPT [ ":"; qs = qualifiers -> qs ] -> - let field = P.create_pattern_field _loc in - let field = P.set_patt field fpatt in - let field = P.set_length field len in - [parse_field _loc field qs] (* Normal, single field. *) - | ":"; name = LIDENT -> - expand_named_pattern _loc name (* Named -> list of fields. *) - ] - ]; - - (* Case inside bitmatch operator. *) - patt_fields: [ - [ "{"; - fields = LIST0 patt_field SEP ";"; - "}" -> - List.concat fields - ] - ]; - - patt_case: [ - [ fields = patt_fields; - bind = OPT [ "as"; name = LIDENT -> name ]; - whenclause = OPT [ "when"; e = expr -> e ]; "->"; - code = expr -> - (fields, bind, whenclause, code) - ] - ]; - - (* Field used in the BITSTRING constructor (an expression). *) - constr_field: [ - [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top"; - qs = OPT [ ":"; qs = qualifiers -> qs ] -> - let field = P.create_constructor_field _loc in - let field = P.set_expr field fexpr in - let field = P.set_length field len in - parse_field _loc field qs - ] - ]; - - constr_fields: [ - [ "{"; - fields = LIST0 constr_field SEP ";"; - "}" -> - fields - ] - ]; - - (* 'bitmatch' expressions. *) - expr: LEVEL ";" [ - [ "bitmatch"; - bs = expr; "with"; OPT "|"; - cases = LIST1 patt_case SEP "|" -> - output_bitmatch _loc bs cases - ] - - (* Constructor. *) - | [ "BITSTRING"; - fields = constr_fields -> - output_constructor _loc fields - ] - ]; - - (* Named persistent patterns. - * - * NB: Currently only allowed at the top level. We can probably lift - * this restriction later if necessary. We only deal with patterns - * at the moment, not constructors, but the infrastructure to do - * constructors is in place. - *) - str_item: LEVEL "top" [ - [ "let"; "bitmatch"; - name = LIDENT; "="; fields = patt_fields -> - add_named_pattern _loc name fields; - (* The statement disappears, but we still need a str_item so ... *) - <:str_item< >> - (* - | "open"; "bitmatch"; filename = STRING -> - load_patterns_from_file _loc filename; - <:str_item< >> - *) - ] - ]; - -END