From 343ea65fbd231847142e876a5700cee8afbc8e98 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 26 Aug 2008 09:42:05 +0000 Subject: [PATCH] Use ocaml-bisect to compute coverage of tests. --- MANIFEST | 6 + Makefile.in | 43 +- bitstring.ml | 66 +-- cil-tools/Makefile.in | 7 + configure.ac | 18 +- coverage-report/file0000.html | 64 +++ coverage-report/file0001.html | 1136 +++++++++++++++++++++++++++++++++++++++++ coverage-report/file0002.html | 59 +++ coverage-report/file0003.html | 59 +++ coverage-report/index.html | 97 ++++ coverage-report/style.css | 70 +++ 11 files changed, 1585 insertions(+), 40 deletions(-) create mode 100644 coverage-report/file0000.html create mode 100644 coverage-report/file0001.html create mode 100644 coverage-report/file0002.html create mode 100644 coverage-report/file0003.html create mode 100644 coverage-report/index.html create mode 100644 coverage-report/style.css diff --git a/MANIFEST b/MANIFEST index 9947386..ed4e8df 100644 --- a/MANIFEST +++ b/MANIFEST @@ -22,6 +22,12 @@ cil-tools/task_struct.ml configure.ac COPYING COPYING.LIB +coverage-report/file0000.html +coverage-report/file0001.html +coverage-report/file0002.html +coverage-report/file0003.html +coverage-report/style.css +coverage-report/index.html create_test_pattern.ml examples/elf.ml examples/ext3_sb diff --git a/Makefile.in b/Makefile.in index 695d427..a9e0495 100644 --- a/Makefile.in +++ b/Makefile.in @@ -26,6 +26,7 @@ OCAMLDOC = @OCAMLDOC@ INSTALL = @INSTALL@ TIME = @TIME@ GPROF = @GPROF@ +BISECT_REPORT = @BISECT_REPORT@ BYTESWAP_H = @BYTESWAP_H@ @@ -35,10 +36,21 @@ top_srcdir = @top_srcdir@ pkg_cil = @pkg_cil@ pkg_extlib = @pkg_extlib@ +enable_coverage = @enable_coverage@ + OCAMLCFLAGS = -g OCAMLCPACKAGES = +OCAMLCLIBS = -linkpkg OCAMLOPTFLAGS = OCAMLOPTPACKAGES = +OCAMLOPTLIBS = -linkpkg + +ifneq ($(enable_coverage),no) +OCAMLCFLAGS += -I +bisect -pp 'camlp4o $(OCAMLLIB)/bisect/instrument.cma' +OCAMLCLIBS += -I +bisect bisect.cma +OCAMLOPTFLAGS += -I +bisect -pp 'camlp4o $(OCAMLLIB)/bisect/instrument.cma' +OCAMLOPTLIBS += -I +bisect bisect.cmxa +endif OCAMLDOCFLAGS = -html -sort @@ -102,6 +114,7 @@ pa_bitstring.cmo: pa_bitstring.ml bitstring.cma bitstring_persistent.cma bitstring-objinfo: bitstring_objinfo.cmo bitstring.cma bitstring_persistent.cma $(OCAMLFIND) ocamlc -I +camlp4 unix.cma camlp4lib.cma \ + $(OCAMLCLIBS) \ bitstring.cma bitstring_persistent.cma \ $< -o $@ @@ -114,18 +127,21 @@ byteswap.h: byteswap.in.h } > $@-t mv -f $@-t $@ -# Tests and examples. +# Tests. -PP = -pp "camlp4o bitstring.cma bitstring_persistent.cma pa_bitstring.cmo" +ifeq ($(enable_coverage),no) +PP = -pp 'camlp4o bitstring.cma bitstring_persistent.cma pa_bitstring.cmo' +else +PP = -pp 'camlp4o $(OCAMLLIB)/bisect/bisect.cma bitstring.cma bitstring_persistent.cma pa_bitstring.cmo' +endif test: pa_bitstring.cmo bitstring.cma bitstring_persistent.cma tests/test.bmpp @for f in $(TESTS); do \ echo Building $$f; \ - $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) $(PP) \ - -package unix -linkpkg -I . bitstring.cma $$f.ml -o $$f; \ + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) $(PP) -package unix $(OCAMLOPTLIBS) -I . bitstring.cmxa $$f.ml -o $$f.opt; \ if [ $$? -ne 0 ]; then exit 1; fi; \ echo Running $$f; \ - $$f; \ + $$f.opt; \ if [ $$? -ne 0 ]; then exit 1; fi; \ done @for d in $(SUBDIRS); do $(MAKE) -C $$d $@; done @@ -137,6 +153,7 @@ tests/test.bmpp: create_test_pattern create_test_pattern: create_test_pattern.cmo $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -pp camlp4of \ unix.cma -I +camlp4 camlp4lib.cma \ + $(OCAMLCLIBS) \ -I . bitstring.cma bitstring_persistent.cma $< -o $@ create_test_pattern.cmo: create_test_pattern.ml @@ -144,6 +161,20 @@ create_test_pattern.cmo: create_test_pattern.ml unix.cma -I +camlp4 \ -I . -c $< -o $@ +# Coverage of tests. + +ifneq ($(BISECT_REPORT),no) +coverage: + rm -f coverage-report/* + rm -f bisect*.out + $(MAKE) test + $(BISECT_REPORT) -html coverage-report bisect*.out + rm -f bisect*.out + @echo Coverage report is in `pwd`/coverage-report/index.html +endif + +# Examples. + examples: pa_bitstring.cmo bitstring.cma bitstring_persistent.cma @for f in $(EXAMPLES); do \ echo Building $$f; \ @@ -204,7 +235,7 @@ endif clean: rm -f core *~ *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o - rm -f tests/*~ tests/*.cmi tests/*.cmo $(TESTS) + rm -f tests/*~ tests/*.cmi tests/*.cmo tests/*.opt rm -f examples/*~ examples/*.cmi examples/*.cmo $(EXAMPLES) rm -f benchmarks/*~ benchmarks/*.cmi benchmarks/*.cmo rm -f benchmarks/*.opt benchmarks/*.opt.p benchmarks/*.profile diff --git a/bitstring.ml b/bitstring.ml index 8850b59..7ed7a58 100644 --- a/bitstring.ml +++ b/bitstring.ml @@ -149,8 +149,8 @@ let takebits n (data, off, len) = module I = struct (* Bitwise operations on ints. Note that we assume int <= 31 bits. *) - let (<<) = (lsl) - let (>>) = (lsr) + external (<<<) : int -> int -> int = "%lslint" + external (>>>) : int -> int -> int = "%lsrint" external to_int : int -> int = "%identity" let zero = 0 let one = 1 @@ -160,7 +160,7 @@ module I = struct (* Create a mask 0-31 bits wide. *) let mask bits = if bits < 30 then - (one << bits) - 1 + (one <<< bits) - 1 else if bits = 30 then max_int else if bits = 31 then @@ -173,21 +173,21 @@ module I = struct if bits <= 8 then v else if bits <= 16 then ( let shift = bits-8 in - let v1 = v >> shift in - let v2 = (v land (mask shift)) << 8 in + let v1 = v >>> shift in + let v2 = ((v land (mask shift)) <<< 8) in v2 lor v1 ) else if bits <= 24 then ( let shift = bits - 16 in - let v1 = v >> (8+shift) in - let v2 = ((v >> shift) land ff) << 8 in - let v3 = (v land (mask shift)) << 16 in + let v1 = v >>> (8+shift) in + let v2 = ((v >>> shift) land ff) <<< 8 in + let v3 = (v land (mask shift)) <<< 16 in v3 lor v2 lor v1 ) else ( let shift = bits - 24 in - let v1 = v >> (16+shift) in - let v2 = ((v >> (8+shift)) land ff) << 8 in - let v3 = ((v >> shift) land ff) << 16 in - let v4 = (v land (mask shift)) << 24 in + let v1 = v >>> (16+shift) in + let v2 = ((v >>> (8+shift)) land ff) <<< 8 in + let v3 = ((v >>> shift) land ff) <<< 16 in + let v4 = (v land (mask shift)) <<< 24 in v4 lor v3 lor v2 lor v1 ) @@ -201,7 +201,7 @@ module I = struct *) let rec map_bytes_be g f v bits = if bits >= 8 then ( - map_bytes_be g f (v >> 8) (bits-8); + map_bytes_be g f (v >>> 8) (bits-8); let lsb = v land ff in f (to_int lsb) ) else if bits > 0 then ( @@ -216,7 +216,7 @@ module I = struct if bits >= 8 then ( let lsb = v land ff in f (to_int lsb); - map_bytes_le g f (v >> 8) (bits-8) + map_bytes_le g f (v >>> 8) (bits-8) ) else if bits > 0 then ( let lsb = v land (mask bits) in g (to_int lsb) bits @@ -228,8 +228,8 @@ module I32 = struct * as possible to the I module above, to make it easier to track * down bugs. *) - let (<<) = Int32.shift_left - let (>>) = Int32.shift_right_logical + let (<<<) = Int32.shift_left + let (>>>) = Int32.shift_right_logical let (land) = Int32.logand let (lor) = Int32.logor let lnot = Int32.lognot @@ -244,7 +244,7 @@ module I32 = struct (* Create a mask so many bits wide. *) let mask bits = if bits < 31 then - pred (one << bits) + pred (one <<< bits) else if bits = 31 then max_int else if bits = 32 then @@ -257,21 +257,21 @@ module I32 = struct if bits <= 8 then v else if bits <= 16 then ( let shift = bits-8 in - let v1 = v >> shift in - let v2 = (v land (mask shift)) << 8 in + let v1 = v >>> shift in + let v2 = (v land (mask shift)) <<< 8 in v2 lor v1 ) else if bits <= 24 then ( let shift = bits - 16 in - let v1 = v >> (8+shift) in - let v2 = ((v >> shift) land ff) << 8 in - let v3 = (v land (mask shift)) << 16 in + let v1 = v >>> (8+shift) in + let v2 = ((v >>> shift) land ff) <<< 8 in + let v3 = (v land (mask shift)) <<< 16 in v3 lor v2 lor v1 ) else ( let shift = bits - 24 in - let v1 = v >> (16+shift) in - let v2 = ((v >> (8+shift)) land ff) << 8 in - let v3 = ((v >> shift) land ff) << 16 in - let v4 = (v land (mask shift)) << 24 in + let v1 = v >>> (16+shift) in + let v2 = ((v >>> (8+shift)) land ff) <<< 8 in + let v3 = ((v >>> shift) land ff) <<< 16 in + let v4 = (v land (mask shift)) <<< 24 in v4 lor v3 lor v2 lor v1 ) @@ -285,7 +285,7 @@ module I32 = struct *) let rec map_bytes_be g f v bits = if bits >= 8 then ( - map_bytes_be g f (v >> 8) (bits-8); + map_bytes_be g f (v >>> 8) (bits-8); let lsb = v land ff in f (to_int lsb) ) else if bits > 0 then ( @@ -300,7 +300,7 @@ module I32 = struct if bits >= 8 then ( let lsb = v land ff in f (to_int lsb); - map_bytes_le g f (v >> 8) (bits-8) + map_bytes_le g f (v >>> 8) (bits-8) ) else if bits > 0 then ( let lsb = v land (mask bits) in g (to_int lsb) bits @@ -312,8 +312,8 @@ module I64 = struct * as possible to the I/I32 modules above, to make it easier to track * down bugs. *) - let (<<) = Int64.shift_left - let (>>) = Int64.shift_right_logical + let (<<<) = Int64.shift_left + let (>>>) = Int64.shift_right_logical let (land) = Int64.logand let (lor) = Int64.logor let lnot = Int64.lognot @@ -328,7 +328,7 @@ module I64 = struct (* Create a mask so many bits wide. *) let mask bits = if bits < 63 then - pred (one << bits) + pred (one <<< bits) else if bits = 63 then max_int else if bits = 64 then @@ -349,7 +349,7 @@ module I64 = struct *) let rec map_bytes_be g f v bits = if bits >= 8 then ( - map_bytes_be g f (v >> 8) (bits-8); + map_bytes_be g f (v >>> 8) (bits-8); let lsb = v land ff in f (to_int lsb) ) else if bits > 0 then ( @@ -364,7 +364,7 @@ module I64 = struct if bits >= 8 then ( let lsb = v land ff in f (to_int lsb); - map_bytes_le g f (v >> 8) (bits-8) + map_bytes_le g f (v >>> 8) (bits-8) ) else if bits > 0 then ( let lsb = v land (mask bits) in g (to_int lsb) bits diff --git a/cil-tools/Makefile.in b/cil-tools/Makefile.in index 8fbe59c..74174db 100644 --- a/cil-tools/Makefile.in +++ b/cil-tools/Makefile.in @@ -25,6 +25,8 @@ OCAMLMKLIB = @OCAMLMKLIB@ OCAMLDOC = @OCAMLDOC@ INSTALL = @INSTALL@ +enable_coverage = @enable_coverage@ + OCAMLCFLAGS = -g OCAMLCPACKAGES = -package unix,str,extlib,cil -I +camlp4 -I .. OCAMLCLIBS = $(OCAMLCPACKAGES) camlp4lib.cma -linkpkg ../bitstring.cma ../bitstring_persistent.cma @@ -32,6 +34,11 @@ OCAMLOPTFLAGS = OCAMLOPTPACKAGES = $(OCAMLCPACKAGES) OCAMLOPTLIBS = $(OCAMLOPTPACKAGES) camlp4lib.cmxa -linkpkg ../bitstring.cmxa ../bitstring_persistent.cmxa +ifneq ($(enable_coverage),no) +OCAMLCLIBS := -I +bisect bisect.cma $(OCAMLCLIBS) +OCAMLOPTLIBS := -I +bisect bisect.cmxa $(OCAMLOPTLIBS) +endif + PP = -pp "camlp4o -I .. bitstring.cma bitstring_persistent.cma pa_bitstring.cmo" OCAMLDOCFLAGS = -html -sort diff --git a/configure.ac b/configure.ac index c6d2ac7..4a480d3 100644 --- a/configure.ac +++ b/configure.ac @@ -74,10 +74,26 @@ AC_SUBST(pkg_cil) dnl Check for /usr/bin/time and get full path. AC_PATH_PROG(TIME,time,no) +if test "x$TIME" = "xno"; then + AC_MSG_ERROR(['time' command not found]) +fi -dnl Check for gprof. +dnl Check for gprof (optional). AC_CHECK_PROG(GPROF,gprof,gprof,no) +dnl Check for ocaml-bisect (optional) and --enable-coverage. +AC_CHECK_PROG(BISECT_REPORT,bisect-report,bisect-report,no) +AC_ARG_ENABLE([coverage], + [AS_HELP_STRING([--enable-coverage], + [add code coverage information (slow) @<:@default=no@:>@])], + [], + [enable_coverage=no]) + +if test "x$enable_coverage" != "xno" -a "x$BISECT_REPORT" = "xno"; then + AC_MSG_ERROR([You must install ocaml-bisect package to get code coverage]) +fi +AC_SUBST(enable_coverage) + dnl Produce output files. AC_CONFIG_HEADERS([config.h]) AC_CONFIG_FILES([Makefile META bitstring_config.ml cil-tools/Makefile]) diff --git a/coverage-report/file0000.html b/coverage-report/file0000.html new file mode 100644 index 0000000..80eba44 --- /dev/null +++ b/coverage-report/file0000.html @@ -0,0 +1,64 @@ + + + Bisect report + + + +

File: bitstring_config.ml (return to index)

+
+

Statistics:

+ + + + + + + + + + + + + + +
kind coverage
binding 4 / 4 (100 %)
sequence 0 / 0 (- %)
for 0 / 0 (- %)
if/then 0 / 0 (- %)
try 0 / 0 (- %)
while 0 / 0 (- %)
match/function 0 / 0 (- %)
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
+
+

Source:

+ +
000001| (* Bitstring library.
+
000002|  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+
000003|  *
+
000004|  * bitstring_config.ml.  Generated from bitstring_config.ml.in by configure.
+
000005|  *
+
000006|  * This library is free software; you can redistribute it and/or
+
000007|  * modify it under the terms of the GNU Lesser General Public
+
000008|  * License as published by the Free Software Foundation; either
+
000009|  * version 2 of the License, or (at your option) any later version,
+
000010|  * with the OCaml linking exception described in COPYING.LIB.
+
000011|  *
+
000012|  * This library is distributed in the hope that it will be useful,
+
000013|  * but WITHOUT ANY WARRANTY; without even the implied warranty of
+
000014|  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+
000015|  * Lesser General Public License for more details.
+
000016|  *
+
000017|  * You should have received a copy of the GNU Lesser General Public
+
000018|  * License along with this library; if not, write to the Free Software
+
000019|  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
000020|  *
+
000021|  * $Id: bitstring_config.ml.in 142 2008-07-17 15:45:56Z richard.wm.jones $
+
000022|  *)
+
000023|  
+
000024| (* This file contains general configuration settings, set by the
+
000025|  * configure script.
+
000026|  *)
+
000027|  
+
000028| let nativeendian = (*[28]*)Bitstring_types.LittleEndian
+
000029|  
+
000030| let package = (*[28]*)"ocaml-bitstring"
+
000031| let version = (*[28]*)"1.9.7"
+
000032| let ocamllibdir = (*[28]*)"/usr/lib/ocaml"
+ +
+

Generated by Bisect on 2008-08-26 10:36:20

+ + diff --git a/coverage-report/file0001.html b/coverage-report/file0001.html new file mode 100644 index 0000000..1f54bc0 --- /dev/null +++ b/coverage-report/file0001.html @@ -0,0 +1,1136 @@ + + + Bisect report + + + +

File: bitstring.ml (return to index)

+
+

Statistics:

+ + + + + + + + + + + + + + +
kind coverage
binding 119 / 231 (51 %)
sequence 37 / 93 (39 %)
for 3 / 5 (60 %)
if/then 72 / 163 (44 %)
try 0 / 2 (0 %)
while 0 / 3 (0 %)
match/function 41 / 77 (53 %)
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
+
+

Source:

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

Generated by Bisect on 2008-08-26 10:36:20

+ + diff --git a/coverage-report/file0002.html b/coverage-report/file0002.html new file mode 100644 index 0000000..102e516 --- /dev/null +++ b/coverage-report/file0002.html @@ -0,0 +1,59 @@ + + + Bisect report + + + +

File: bitmatch.ml (return to index)

+
+

Statistics:

+ + + + + + + + + + + + + + +
kind coverage
binding 0 / 0 (- %)
sequence 0 / 0 (- %)
for 0 / 0 (- %)
if/then 0 / 0 (- %)
try 0 / 0 (- %)
while 0 / 0 (- %)
match/function 0 / 0 (- %)
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
+
+

Source:

+ +
000001| (** Bitmatch backwards compatibility library. *)
+
000002| (* Bitstring library.
+
000003|  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+
000004|  *
+
000005|  * This library is free software; you can redistribute it and/or
+
000006|  * modify it under the terms of the GNU Lesser General Public
+
000007|  * License as published by the Free Software Foundation; either
+
000008|  * version 2 of the License, or (at your option) any later version,
+
000009|  * with the OCaml linking exception described in COPYING.LIB.
+
000010|  *
+
000011|  * This library is distributed in the hope that it will be useful,
+
000012|  * but WITHOUT ANY WARRANTY; without even the implied warranty of
+
000013|  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+
000014|  * Lesser General Public License for more details.
+
000015|  *
+
000016|  * You should have received a copy of the GNU Lesser General Public
+
000017|  * License along with this library; if not, write to the Free Software
+
000018|  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
000019|  *
+
000020|  * $Id: bitmatch.ml 142 2008-07-17 15:45:56Z richard.wm.jones $
+
000021|  *)
+
000022| (** This is just for backwards compatibility with code
+
000023|     from when the library was called bitmatch.  You should
+
000024|     replace all references to this module with {!Bitstring}.
+
000025| *)
+
000026|  
+
000027| include Bitstring
+ +
+

Generated by Bisect on 2008-08-26 10:36:20

+ + diff --git a/coverage-report/file0003.html b/coverage-report/file0003.html new file mode 100644 index 0000000..7a90889 --- /dev/null +++ b/coverage-report/file0003.html @@ -0,0 +1,59 @@ + + + Bisect report + + + +

File: bitstring_types.ml (return to index)

+
+

Statistics:

+ + + + + + + + + + + + + + +
kind coverage
binding 0 / 0 (- %)
sequence 0 / 0 (- %)
for 0 / 0 (- %)
if/then 0 / 0 (- %)
try 0 / 0 (- %)
while 0 / 0 (- %)
match/function 0 / 3 (0 %)
class expression 0 / 0 (- %)
class initializer 0 / 0 (- %)
class method 0 / 0 (- %)
class value 0 / 0 (- %)
toplevel expression 0 / 0 (- %)
+
+

Source:

+ +
000001| (* Bitstring library.
+
000002|  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+
000003|  *
+
000004|  * This library is free software; you can redistribute it and/or
+
000005|  * modify it under the terms of the GNU Lesser General Public
+
000006|  * License as published by the Free Software Foundation; either
+
000007|  * version 2 of the License, or (at your option) any later version,
+
000008|  * with the OCaml linking exception described in COPYING.LIB.
+
000009|  *
+
000010|  * This library is distributed in the hope that it will be useful,
+
000011|  * but WITHOUT ANY WARRANTY; without even the implied warranty of
+
000012|  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+
000013|  * Lesser General Public License for more details.
+
000014|  *
+
000015|  * You should have received a copy of the GNU Lesser General Public
+
000016|  * License along with this library; if not, write to the Free Software
+
000017|  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
000018|  *
+
000019|  * $Id: bitstring_types.ml 142 2008-07-17 15:45:56Z richard.wm.jones $
+
000020|  *)
+
000021|  
+
000022| type endian = BigEndian | LittleEndian | NativeEndian
+
000023|  
+
000024| let string_of_endian = function
+
000025|   | BigEndian -> (*[0]*)"bigendian"
+
000026|   | LittleEndian -> (*[0]*)"littleendian"
+
000027|   | NativeEndian -> (*[0]*)"nativeendian"
+ +
+

Generated by Bisect on 2008-08-26 10:36:20

+ + diff --git a/coverage-report/index.html b/coverage-report/index.html new file mode 100644 index 0000000..df94381 --- /dev/null +++ b/coverage-report/index.html @@ -0,0 +1,97 @@ + + + Bisect report + + + +

Bisect report

+
+
+

Overall statistics

+ kind coverage + binding 123 / 235 (52 %) + sequence 37 / 93 (39 %) + for 3 / 5 (60 %) + if/then 72 / 163 (44 %) + try 0 / 2 (0 %) + while 0 / 3 (0 %) + match/function 41 / 80 (51 %) + class expression 0 / 0 (- %) + class initializer 0 / 0 (- %) + class method 0 / 0 (- %) + class value 0 / 0 (- %) + toplevel expression 0 / 0 (- %) + +
+
+
+
+
+

Per-file coverage

+ + coverage +   + file + + + + + + + +
+ +  -%
+ +   + bitmatch.ml + + + + + + + +
+ +  47%
+ +   + bitstring.ml + + + + + + + +
+ +  100%
+ +   + bitstring_config.ml + + + + + + + +
+ +  0%
+ +   + bitstring_types.ml + + +
+
+
+
+

Generated by Bisect on 2008-08-26 10:36:20

+ + diff --git a/coverage-report/style.css b/coverage-report/style.css new file mode 100644 index 0000000..df7402b --- /dev/null +++ b/coverage-report/style.css @@ -0,0 +1,70 @@ +body { + background: white; + white-space: nowrap; +} + +.footer { + font-size: smaller; + text-align: center; +} + +.codeSep { + border: none 0; + border-top: 1px solid gray; + height: 1px; +} + +.indexSep { + border: none 0; + border-top: 1px solid gray; + height: 1px; + width: 75%; +} + +.lineNone { white-space: nowrap; background: white; } +.lineAllVisited { white-space: nowrap; background: green; } +.lineAllUnvisited { white-space: nowrap; background: red; } +.lineMixed { white-space: nowrap; background: yellow; } + +table.simple { + border-width: 1px; + border-spacing: 0px; + border-top-style: solid; + border-bottom-style: solid; + border-color: black; +} + +table.simple th { + border-width: 1px; + border-spacing: 0px; + border-bottom-style: solid; + border-color: black; + text-align: center; + font-weight: bold; +} + +table.simple td { + border-width: 1px; + border-spacing: 0px; + border-style: none; +} + +table.gauge { + border-width: 0px; + border-spacing: 0px; + padding: 0px; + border-style: none; + border-collapse: collapse; +} + +table.gauge td { + border-width: 0px; + border-spacing: 0px; + padding: 0px; + border-style: none; + border-collapse: collapse; +} + +.gaugeOK { background: green; } +.gaugeKO { background: red; } + -- 1.8.3.1