configure: Don't test for camlp4of.opt, test for camlp4of.
[ocaml-bitstring.git] / bitstring.ml
1 (* Bitstring library.
2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
3  *
4  * This library is free software; you can redistribute it and/or
5  * modify it under the terms of the GNU Lesser General Public
6  * License as published by the Free Software Foundation; either
7  * version 2 of the License, or (at your option) any later version,
8  * with the OCaml linking exception described in COPYING.LIB.
9  *
10  * This library is distributed in the hope that it will be useful,
11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13  * Lesser General Public License for more details.
14  *
15  * You should have received a copy of the GNU Lesser General Public
16  * License along with this library; if not, write to the Free Software
17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18  *
19  * $Id$
20  *)
21
22 open Printf
23
24 include Bitstring_types
25 include Bitstring_config
26
27 (* Enable runtime debug messages.  Must also have been enabled
28  * in pa_bitstring.ml.
29  *)
30 let debug = ref false
31
32 (* Exceptions. *)
33 exception Construct_failure of string * string * int * int
34
35 (* A bitstring is simply the data itself (as a string), and the
36  * bitoffset and the bitlength within the string.  Note offset/length
37  * are counted in bits, not bytes.
38  *)
39 type bitstring = string * int * int
40
41 type t = bitstring
42
43 (* Functions to create and load bitstrings. *)
44 let empty_bitstring = "", 0, 0
45
46 let make_bitstring len c =
47   if len >= 0 then String.make ((len+7) lsr 3) c, 0, len
48   else
49     invalid_arg (
50       sprintf "make_bitstring/create_bitstring: len %d < 0" len
51     )
52
53 let create_bitstring len = make_bitstring len '\000'
54
55 let zeroes_bitstring = create_bitstring
56
57 let ones_bitstring len = make_bitstring len '\xff'
58
59 let bitstring_of_string str = str, 0, String.length str lsl 3
60
61 let bitstring_of_chan chan =
62   let tmpsize = 16384 in
63   let buf = Buffer.create tmpsize in
64   let tmp = String.create tmpsize in
65   let n = ref 0 in
66   while n := input chan tmp 0 tmpsize; !n > 0 do
67     Buffer.add_substring buf tmp 0 !n;
68   done;
69   Buffer.contents buf, 0, Buffer.length buf lsl 3
70
71 let bitstring_of_chan_max chan max =
72   let tmpsize = 16384 in
73   let buf = Buffer.create tmpsize in
74   let tmp = String.create tmpsize in
75   let len = ref 0 in
76   let rec loop () =
77     if !len < max then (
78       let r = min tmpsize (max - !len) in
79       let n = input chan tmp 0 r in
80       if n > 0 then (
81         Buffer.add_substring buf tmp 0 n;
82         len := !len + n;
83         loop ()
84       )
85     )
86   in
87   loop ();
88   Buffer.contents buf, 0, !len lsl 3
89
90 let bitstring_of_file_descr fd =
91   let tmpsize = 16384 in
92   let buf = Buffer.create tmpsize in
93   let tmp = String.create tmpsize in
94   let n = ref 0 in
95   while n := Unix.read fd tmp 0 tmpsize; !n > 0 do
96     Buffer.add_substring buf tmp 0 !n;
97   done;
98   Buffer.contents buf, 0, Buffer.length buf lsl 3
99
100 let bitstring_of_file_descr_max fd max =
101   let tmpsize = 16384 in
102   let buf = Buffer.create tmpsize in
103   let tmp = String.create tmpsize in
104   let len = ref 0 in
105   let rec loop () =
106     if !len < max then (
107       let r = min tmpsize (max - !len) in
108       let n = Unix.read fd tmp 0 r in
109       if n > 0 then (
110         Buffer.add_substring buf tmp 0 n;
111         len := !len + n;
112         loop ()
113       )
114     )
115   in
116   loop ();
117   Buffer.contents buf, 0, !len lsl 3
118
119 let bitstring_of_file fname =
120   let chan = open_in_bin fname in
121   try
122     let bs = bitstring_of_chan chan in
123     close_in chan;
124     bs
125   with exn ->
126     close_in chan;
127     raise exn
128
129 let bitstring_length (_, _, len) = len
130
131 let subbitstring (data, off, len) off' len' =
132   let off = off + off' in
133   if off' < 0 || len' < 0 || off' > len - len' then invalid_arg "subbitstring";
134   (data, off, len')
135
136 let dropbits n (data, off, len) =
137   let off = off + n in
138   let len = len - n in
139   if len < 0 || n < 0 then invalid_arg "dropbits";
140   (data, off, len)
141
142 let takebits n (data, off, len) =
143   if len < n || n < 0 then invalid_arg "takebits";
144   (data, off, n)
145
146 (*----------------------------------------------------------------------*)
147 (* Bitwise functions.
148  *
149  * We try to isolate all bitwise functions within these modules.
150  *)
151
152 module I = struct
153   (* Bitwise operations on ints.  Note that we assume int <= 31 bits. *)
154   external (<<<) : int -> int -> int = "%lslint"
155   external (>>>) : int -> int -> int = "%lsrint"
156   external to_int : int -> int = "%identity"
157   let zero = 0
158   let one = 1
159   let minus_one = -1
160   let ff = 0xff
161
162   (* Create a mask 0-31 bits wide. *)
163   let mask bits =
164     if bits < 30 || 
165       (bits < 32 && Sys.word_size = 64) then
166       (one <<< bits) - 1
167     else if bits = 30 then
168       max_int
169     else if bits = 31 then
170       minus_one
171     else
172       invalid_arg "Bitstring.I.mask"
173
174   (* Byte swap an int of a given size. *)
175   let byteswap v bits =
176     if bits <= 8 then v
177     else if bits <= 16 then (
178       let shift = bits-8 in
179       let v1 = v >>> shift in
180       let v2 = ((v land (mask shift)) <<< 8) in
181       v2 lor v1
182     ) else if bits <= 24 then (
183       let shift = bits - 16 in
184       let v1 = v >>> (8+shift) in
185       let v2 = ((v >>> shift) land ff) <<< 8 in
186       let v3 = (v land (mask shift)) <<< 16 in
187       v3 lor v2 lor v1
188     ) else (
189       let shift = bits - 24 in
190       let v1 = v >>> (16+shift) in
191       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
192       let v3 = ((v >>> shift) land ff) <<< 16 in
193       let v4 = (v land (mask shift)) <<< 24 in
194       v4 lor v3 lor v2 lor v1
195     )
196
197   (* Check a value is in range 0 .. 2^bits-1. *)
198   let range_unsigned v bits =
199     let mask = lnot (mask bits) in
200     (v land mask) = zero
201
202   let range_signed v bits =
203     if 
204       v >= zero 
205     then
206       range_unsigned v bits
207     else
208       if
209         bits = 31 && Sys.word_size = 32
210       then
211         v >= min_int            
212       else
213         pred (minus_one <<< pred bits) < v
214
215   (* Call function g on the top bits, then f on each full byte
216    * (big endian - so start at top).
217    *)
218   let rec map_bytes_be g f v bits =
219     if bits >= 8 then (
220       map_bytes_be g f (v >>> 8) (bits-8);
221       let lsb = v land ff in
222       f (to_int lsb)
223     ) else if bits > 0 then (
224       let lsb = v land (mask bits) in
225       g (to_int lsb) bits
226     )
227
228   (* Call function g on the top bits, then f on each full byte
229    * (little endian - so start at root).
230    *)
231   let rec map_bytes_le g f v bits =
232     if bits >= 8 then (
233       let lsb = v land ff in
234       f (to_int lsb);
235       map_bytes_le g f (v >>> 8) (bits-8)
236     ) else if bits > 0 then (
237       let lsb = v land (mask bits) in
238       g (to_int lsb) bits
239     )
240 end
241
242 module I32 = struct
243   (* Bitwise operations on int32s.  Note we try to keep it as similar
244    * as possible to the I module above, to make it easier to track
245    * down bugs.
246    *)
247   let (<<<) = Int32.shift_left
248   let (>>>) = Int32.shift_right_logical
249   let (land) = Int32.logand
250   let (lor) = Int32.logor
251   let lnot = Int32.lognot
252   let pred = Int32.pred
253   let max_int = Int32.max_int
254   let to_int = Int32.to_int
255   let zero = Int32.zero
256   let one = Int32.one
257   let minus_one = Int32.minus_one
258   let ff = 0xff_l
259
260   (* Create a mask so many bits wide. *)
261   let mask bits =
262     if bits < 31 then
263       pred (one <<< bits)
264     else if bits = 31 then
265       max_int
266     else if bits = 32 then
267       minus_one
268     else
269       invalid_arg "Bitstring.I32.mask"
270
271   (* Byte swap an int of a given size. *)
272   let byteswap v bits =
273     if bits <= 8 then v
274     else if bits <= 16 then (
275       let shift = bits-8 in
276       let v1 = v >>> shift in
277       let v2 = (v land (mask shift)) <<< 8 in
278       v2 lor v1
279     ) else if bits <= 24 then (
280       let shift = bits - 16 in
281       let v1 = v >>> (8+shift) in
282       let v2 = ((v >>> shift) land ff) <<< 8 in
283       let v3 = (v land (mask shift)) <<< 16 in
284       v3 lor v2 lor v1
285     ) else (
286       let shift = bits - 24 in
287       let v1 = v >>> (16+shift) in
288       let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
289       let v3 = ((v >>> shift) land ff) <<< 16 in
290       let v4 = (v land (mask shift)) <<< 24 in
291       v4 lor v3 lor v2 lor v1
292     )
293
294   (* Check a value is in range 0 .. 2^bits-1. *)
295   let range_unsigned v bits =
296     let mask = lnot (mask bits) in
297     (v land mask) = zero
298
299   (* Call function g on the top bits, then f on each full byte
300    * (big endian - so start at top).
301    *)
302   let rec map_bytes_be g f v bits =
303     if bits >= 8 then (
304       map_bytes_be g f (v >>> 8) (bits-8);
305       let lsb = v land ff in
306       f (to_int lsb)
307     ) else if bits > 0 then (
308       let lsb = v land (mask bits) in
309       g (to_int lsb) bits
310     )
311
312   (* Call function g on the top bits, then f on each full byte
313    * (little endian - so start at root).
314    *)
315   let rec map_bytes_le g f v bits =
316     if bits >= 8 then (
317       let lsb = v land ff in
318       f (to_int lsb);
319       map_bytes_le g f (v >>> 8) (bits-8)
320     ) else if bits > 0 then (
321       let lsb = v land (mask bits) in
322       g (to_int lsb) bits
323     )
324 end
325
326 module I64 = struct
327   (* Bitwise operations on int64s.  Note we try to keep it as similar
328    * as possible to the I/I32 modules above, to make it easier to track
329    * down bugs.
330    *)
331   let (<<<) = Int64.shift_left
332   let (>>>) = Int64.shift_right_logical
333   let (land) = Int64.logand
334   let (lor) = Int64.logor
335   let lnot = Int64.lognot
336   let pred = Int64.pred
337   let max_int = Int64.max_int
338   let to_int = Int64.to_int
339   let zero = Int64.zero
340   let one = Int64.one
341   let minus_one = Int64.minus_one
342   let ff = 0xff_L
343
344   (* Create a mask so many bits wide. *)
345   let mask bits =
346     if bits < 63 then
347       pred (one <<< bits)
348     else if bits = 63 then
349       max_int
350     else if bits = 64 then
351       minus_one
352     else
353       invalid_arg "Bitstring.I64.mask"
354
355   (* Byte swap an int of a given size. *)
356   (* let byteswap v bits = *)
357
358   (* Check a value is in range 0 .. 2^bits-1. *)
359   let range_unsigned v bits =
360     let mask = lnot (mask bits) in
361     (v land mask) = zero
362
363   (* Call function g on the top bits, then f on each full byte
364    * (big endian - so start at top).
365    *)
366   let rec map_bytes_be g f v bits =
367     if bits >= 8 then (
368       map_bytes_be g f (v >>> 8) (bits-8);
369       let lsb = v land ff in
370       f (to_int lsb)
371     ) else if bits > 0 then (
372       let lsb = v land (mask bits) in
373       g (to_int lsb) bits
374     )
375
376   (* Call function g on the top bits, then f on each full byte
377    * (little endian - so start at root).
378    *)
379   let rec map_bytes_le g f v bits =
380     if bits >= 8 then (
381       let lsb = v land ff in
382       f (to_int lsb);
383       map_bytes_le g f (v >>> 8) (bits-8)
384     ) else if bits > 0 then (
385       let lsb = v land (mask bits) in
386       g (to_int lsb) bits
387     )
388 end
389
390 (*----------------------------------------------------------------------*)
391 (* Extraction functions.
392  *
393  * NB: internal functions, called from the generated macros, and
394  * the parameters should have been checked for sanity already).
395  *)
396
397 (* Extract and convert to numeric.  A single bit is returned as
398  * a boolean.  There are no endianness or signedness considerations.
399  *)
400 let extract_bit data off len _ =        (* final param is always 1 *)
401   let byteoff = off lsr 3 in
402   let bitmask = 1 lsl (7 - (off land 7)) in
403   let b = Char.code data.[byteoff] land bitmask <> 0 in
404   b (*, off+1, len-1*)
405
406 (* Returns 8 bit unsigned aligned bytes from the string.
407  * If the string ends then this returns 0's.
408  *)
409 let _get_byte data byteoff strlen =
410   if strlen > byteoff then Char.code data.[byteoff] else 0
411 let _get_byte32 data byteoff strlen =
412   if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
413 let _get_byte64 data byteoff strlen =
414   if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
415
416 (* Extend signed [2..31] bits int to 31 bits int or 63 bits int for 64
417    bits platform*)
418 let extend_sign len v =
419   let b = pred Sys.word_size - len in
420     (v lsl b) asr b
421
422 let extract_and_extend_sign f data off len flen =
423   let w = f data off len flen in
424     extend_sign len w
425
426 (* Extract [2..8] bits.  Because the result fits into a single
427  * byte we don't have to worry about endianness, only signedness.
428  *)
429 let extract_char_unsigned data off len flen =
430   let byteoff = off lsr 3 in
431
432   (* Optimize the common (byte-aligned) case. *)
433   if off land 7 = 0 then (
434     let byte = Char.code data.[byteoff] in
435     byte lsr (8 - flen) (*, off+flen, len-flen*)
436   ) else (
437     (* Extract the 16 bits at byteoff and byteoff+1 (note that the
438      * second byte might not exist in the original string).
439      *)
440     let strlen = String.length data in
441
442     let word =
443       (_get_byte data byteoff strlen lsl 8) +
444         _get_byte data (byteoff+1) strlen in
445
446     (* Mask off the top bits. *)
447     let bitmask = (1 lsl (16 - (off land 7))) - 1 in
448     let word = word land bitmask in
449     (* Shift right to get rid of the bottom bits. *)
450     let shift = 16 - ((off land 7) + flen) in
451     let word = word lsr shift in
452
453     word (*, off+flen, len-flen*)
454   )
455
456 let extract_char_signed =
457   extract_and_extend_sign extract_char_unsigned
458
459 (* Extract [9..31] bits.  We have to consider endianness and signedness. *)
460 let extract_int_be_unsigned data off len flen =
461   let byteoff = off lsr 3 in
462
463   let strlen = String.length data in
464
465   let word =
466     (* Optimize the common (byte-aligned) case. *)
467     if off land 7 = 0 then (
468       let word =
469         (_get_byte data byteoff strlen lsl 23) +
470           (_get_byte data (byteoff+1) strlen lsl 15) +
471           (_get_byte data (byteoff+2) strlen lsl 7) +
472           (_get_byte data (byteoff+3) strlen lsr 1) in
473       word lsr (31 - flen)
474     ) else if flen <= 24 then (
475       (* Extract the 31 bits at byteoff .. byteoff+3. *)
476       let word =
477         (_get_byte data byteoff strlen lsl 23) +
478           (_get_byte data (byteoff+1) strlen lsl 15) +
479           (_get_byte data (byteoff+2) strlen lsl 7) +
480           (_get_byte data (byteoff+3) strlen lsr 1) in
481       (* Mask off the top bits. *)
482       let bitmask = (1 lsl (31 - (off land 7))) - 1 in
483       let word = word land bitmask in
484       (* Shift right to get rid of the bottom bits. *)
485       let shift = 31 - ((off land 7) + flen) in
486       word lsr shift
487     ) else (
488       (* Extract the next 31 bits, slow method. *)
489       let word =
490         let c0 = extract_char_unsigned data off len 8
491         and off = off + 8 and len = len - 8 in
492         let c1 = extract_char_unsigned data off len 8
493         and off = off + 8 and len = len - 8 in
494         let c2 = extract_char_unsigned data off len 8
495         and off = off + 8 and len = len - 8 in
496         let c3 = extract_char_unsigned data off len 7 in
497         (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
498       word lsr (31 - flen)
499     ) in
500   word (*, off+flen, len-flen*)
501
502 let extract_int_be_signed =
503   extract_and_extend_sign extract_int_be_unsigned
504
505 let extract_int_le_unsigned data off len flen =
506   let v = extract_int_be_unsigned data off len flen in
507   let v = I.byteswap v flen in
508   v
509
510 let extract_int_le_signed =
511   extract_and_extend_sign extract_int_le_unsigned
512
513 let extract_int_ne_unsigned =
514   if nativeendian = BigEndian
515   then extract_int_be_unsigned
516   else extract_int_le_unsigned
517
518 let extract_int_ne_signed = 
519   extract_and_extend_sign extract_int_ne_unsigned
520
521 let extract_int_ee_unsigned = function
522   | BigEndian -> extract_int_be_unsigned
523   | LittleEndian -> extract_int_le_unsigned
524   | NativeEndian -> extract_int_ne_unsigned
525
526 let extract_int_ee_signed e =
527   extract_and_extend_sign (extract_int_ee_unsigned e)
528
529 let _make_int32_be c0 c1 c2 c3 =
530   Int32.logor
531     (Int32.logor
532        (Int32.logor
533           (Int32.shift_left c0 24)
534           (Int32.shift_left c1 16))
535        (Int32.shift_left c2 8))
536     c3
537
538 let _make_int32_le c0 c1 c2 c3 =
539   Int32.logor
540     (Int32.logor
541        (Int32.logor
542           (Int32.shift_left c3 24)
543           (Int32.shift_left c2 16))
544        (Int32.shift_left c1 8))
545     c0
546
547 (* Extract exactly 32 bits.  We have to consider endianness and signedness. *)
548 let extract_int32_be_unsigned data off len flen =
549   let byteoff = off lsr 3 in
550
551   let strlen = String.length data in
552
553   let word =
554     (* Optimize the common (byte-aligned) case. *)
555     if off land 7 = 0 then (
556       let word =
557         let c0 = _get_byte32 data byteoff strlen in
558         let c1 = _get_byte32 data (byteoff+1) strlen in
559         let c2 = _get_byte32 data (byteoff+2) strlen in
560         let c3 = _get_byte32 data (byteoff+3) strlen in
561         _make_int32_be c0 c1 c2 c3 in
562       Int32.shift_right_logical word (32 - flen)
563     ) else (
564       (* Extract the next 32 bits, slow method. *)
565       let word =
566         let c0 = extract_char_unsigned data off len 8
567         and off = off + 8 and len = len - 8 in
568         let c1 = extract_char_unsigned data off len 8
569         and off = off + 8 and len = len - 8 in
570         let c2 = extract_char_unsigned data off len 8
571         and off = off + 8 and len = len - 8 in
572         let c3 = extract_char_unsigned data off len 8 in
573         let c0 = Int32.of_int c0 in
574         let c1 = Int32.of_int c1 in
575         let c2 = Int32.of_int c2 in
576         let c3 = Int32.of_int c3 in
577         _make_int32_be c0 c1 c2 c3 in
578       Int32.shift_right_logical word (32 - flen)
579     ) in
580   word (*, off+flen, len-flen*)
581
582 let extract_int32_le_unsigned data off len flen =
583   let v = extract_int32_be_unsigned data off len flen in
584   let v = I32.byteswap v flen in
585   v
586
587 let extract_int32_ne_unsigned =
588   if nativeendian = BigEndian
589   then extract_int32_be_unsigned
590   else extract_int32_le_unsigned
591
592 let extract_int32_ee_unsigned = function
593   | BigEndian -> extract_int32_be_unsigned
594   | LittleEndian -> extract_int32_le_unsigned
595   | NativeEndian -> extract_int32_ne_unsigned
596
597 let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
598   Int64.logor
599     (Int64.logor
600        (Int64.logor
601           (Int64.logor
602              (Int64.logor
603                 (Int64.logor
604                    (Int64.logor
605                       (Int64.shift_left c0 56)
606                       (Int64.shift_left c1 48))
607                    (Int64.shift_left c2 40))
608                 (Int64.shift_left c3 32))
609              (Int64.shift_left c4 24))
610           (Int64.shift_left c5 16))
611        (Int64.shift_left c6 8))
612     c7
613
614 let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
615   _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
616
617 (* Extract [1..64] bits.  We have to consider endianness and signedness. *)
618 let extract_int64_be_unsigned data off len flen =
619   let byteoff = off lsr 3 in
620
621   let strlen = String.length data in
622
623   let word =
624     (* Optimize the common (byte-aligned) case. *)
625     if off land 7 = 0 then (
626       let word =
627         let c0 = _get_byte64 data byteoff strlen in
628         let c1 = _get_byte64 data (byteoff+1) strlen in
629         let c2 = _get_byte64 data (byteoff+2) strlen in
630         let c3 = _get_byte64 data (byteoff+3) strlen in
631         let c4 = _get_byte64 data (byteoff+4) strlen in
632         let c5 = _get_byte64 data (byteoff+5) strlen in
633         let c6 = _get_byte64 data (byteoff+6) strlen in
634         let c7 = _get_byte64 data (byteoff+7) strlen in
635         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
636       Int64.shift_right_logical word (64 - flen)
637     ) else (
638       (* Extract the next 64 bits, slow method. *)
639       let word =
640         let c0 = extract_char_unsigned data off len 8
641         and off = off + 8 and len = len - 8 in
642         let c1 = extract_char_unsigned data off len 8
643         and off = off + 8 and len = len - 8 in
644         let c2 = extract_char_unsigned data off len 8
645         and off = off + 8 and len = len - 8 in
646         let c3 = extract_char_unsigned data off len 8
647         and off = off + 8 and len = len - 8 in
648         let c4 = extract_char_unsigned data off len 8
649         and off = off + 8 and len = len - 8 in
650         let c5 = extract_char_unsigned data off len 8
651         and off = off + 8 and len = len - 8 in
652         let c6 = extract_char_unsigned data off len 8
653         and off = off + 8 and len = len - 8 in
654         let c7 = extract_char_unsigned data off len 8 in
655         let c0 = Int64.of_int c0 in
656         let c1 = Int64.of_int c1 in
657         let c2 = Int64.of_int c2 in
658         let c3 = Int64.of_int c3 in
659         let c4 = Int64.of_int c4 in
660         let c5 = Int64.of_int c5 in
661         let c6 = Int64.of_int c6 in
662         let c7 = Int64.of_int c7 in
663         _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
664       Int64.shift_right_logical word (64 - flen)
665     ) in
666   word (*, off+flen, len-flen*)
667
668 let extract_int64_le_unsigned data off len flen =
669   let byteoff = off lsr 3 in
670
671   let strlen = String.length data in
672
673   let word =
674     (* Optimize the common (byte-aligned) case. *)
675     if off land 7 = 0 then (
676       let word =
677         let c0 = _get_byte64 data byteoff strlen in
678         let c1 = _get_byte64 data (byteoff+1) strlen in
679         let c2 = _get_byte64 data (byteoff+2) strlen in
680         let c3 = _get_byte64 data (byteoff+3) strlen in
681         let c4 = _get_byte64 data (byteoff+4) strlen in
682         let c5 = _get_byte64 data (byteoff+5) strlen in
683         let c6 = _get_byte64 data (byteoff+6) strlen in
684         let c7 = _get_byte64 data (byteoff+7) strlen in
685         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
686       Int64.logand word (I64.mask flen)
687     ) else (
688       (* Extract the next 64 bits, slow method. *)
689       let word =
690         let c0 = extract_char_unsigned data off len 8
691         and off = off + 8 and len = len - 8 in
692         let c1 = extract_char_unsigned data off len 8
693         and off = off + 8 and len = len - 8 in
694         let c2 = extract_char_unsigned data off len 8
695         and off = off + 8 and len = len - 8 in
696         let c3 = extract_char_unsigned data off len 8
697         and off = off + 8 and len = len - 8 in
698         let c4 = extract_char_unsigned data off len 8
699         and off = off + 8 and len = len - 8 in
700         let c5 = extract_char_unsigned data off len 8
701         and off = off + 8 and len = len - 8 in
702         let c6 = extract_char_unsigned data off len 8
703         and off = off + 8 and len = len - 8 in
704         let c7 = extract_char_unsigned data off len 8 in
705         let c0 = Int64.of_int c0 in
706         let c1 = Int64.of_int c1 in
707         let c2 = Int64.of_int c2 in
708         let c3 = Int64.of_int c3 in
709         let c4 = Int64.of_int c4 in
710         let c5 = Int64.of_int c5 in
711         let c6 = Int64.of_int c6 in
712         let c7 = Int64.of_int c7 in
713         _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
714       Int64.logand word (I64.mask flen)
715     ) in
716   word (*, off+flen, len-flen*)
717
718 let extract_int64_ne_unsigned =
719   if nativeendian = BigEndian
720   then extract_int64_be_unsigned
721   else extract_int64_le_unsigned
722
723 let extract_int64_ee_unsigned = function
724   | BigEndian -> extract_int64_be_unsigned
725   | LittleEndian -> extract_int64_le_unsigned
726   | NativeEndian -> extract_int64_ne_unsigned
727
728 external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
729
730 external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
731
732 external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
733
734 external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
735
736 external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
737
738 external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
739
740 (*
741 external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
742
743 external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
744
745 external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
746
747 external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
748
749 external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
750
751 external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
752 *)
753
754 external extract_fastpath_int32_be_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned"
755
756 external extract_fastpath_int32_le_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned"
757
758 external extract_fastpath_int32_ne_unsigned : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned"
759
760 external extract_fastpath_int32_be_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed"
761
762 external extract_fastpath_int32_le_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed"
763
764 external extract_fastpath_int32_ne_signed : string -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed"
765
766 (*
767 external extract_fastpath_int40_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned"
768
769 external extract_fastpath_int40_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned"
770
771 external extract_fastpath_int40_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned"
772
773 external extract_fastpath_int40_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed"
774
775 external extract_fastpath_int40_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed"
776
777 external extract_fastpath_int40_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed"
778
779 external extract_fastpath_int48_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned"
780
781 external extract_fastpath_int48_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned"
782
783 external extract_fastpath_int48_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned"
784
785 external extract_fastpath_int48_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed"
786
787 external extract_fastpath_int48_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed"
788
789 external extract_fastpath_int48_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed"
790
791 external extract_fastpath_int56_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned"
792
793 external extract_fastpath_int56_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned"
794
795 external extract_fastpath_int56_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned"
796
797 external extract_fastpath_int56_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed"
798
799 external extract_fastpath_int56_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed"
800
801 external extract_fastpath_int56_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed"
802 *)
803
804 external extract_fastpath_int64_be_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned"
805
806 external extract_fastpath_int64_le_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned"
807
808 external extract_fastpath_int64_ne_unsigned : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned"
809
810 external extract_fastpath_int64_be_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed"
811
812 external extract_fastpath_int64_le_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed"
813
814 external extract_fastpath_int64_ne_signed : string -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed"
815
816 (*----------------------------------------------------------------------*)
817 (* Constructor functions. *)
818
819 module Buffer = struct
820   type t = {
821     buf : Buffer.t;
822     mutable len : int;                  (* Length in bits. *)
823     (* Last byte in the buffer (if len is not aligned).  We store
824      * it outside the buffer because buffers aren't mutable.
825      *)
826     mutable last : int;
827   }
828
829   let create () =
830     (* XXX We have almost enough information in the generator to
831      * choose a good initial size.
832      *)
833     { buf = Buffer.create 128; len = 0; last = 0 }
834
835   let contents { buf = buf; len = len; last = last } =
836     let data =
837       if len land 7 = 0 then
838         Buffer.contents buf
839       else
840         Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
841     data, 0, len
842
843   (* Add exactly 8 bits. *)
844   let add_byte ({ buf = buf; len = len; last = last } as t) byte =
845     if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte";
846     let shift = len land 7 in
847     if shift = 0 then
848       (* Target buffer is byte-aligned. *)
849       Buffer.add_char buf (Char.chr byte)
850     else (
851       (* Target buffer is unaligned.  'last' is meaningful. *)
852       let first = byte lsr shift in
853       let second = (byte lsl (8 - shift)) land 0xff in
854       Buffer.add_char buf (Char.chr (last lor first));
855       t.last <- second
856     );
857     t.len <- t.len + 8
858
859   (* Add exactly 1 bit. *)
860   let add_bit ({ buf = buf; len = len; last = last } as t) bit =
861     let shift = 7 - (len land 7) in
862     if shift > 0 then
863       (* Somewhere in the middle of 'last'. *)
864       t.last <- last lor ((if bit then 1 else 0) lsl shift)
865     else (
866       (* Just a single spare bit in 'last'. *)
867       let last = last lor if bit then 1 else 0 in
868       Buffer.add_char buf (Char.chr last);
869       t.last <- 0
870     );
871     t.len <- len + 1
872
873   (* Add a small number of bits (definitely < 8).  This uses a loop
874    * to call add_bit so it's slow.
875    *)
876   let _add_bits t c slen =
877     if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits";
878     for i = slen-1 downto 0 do
879       let bit = c land (1 lsl i) <> 0 in
880       add_bit t bit
881     done
882
883   let add_bits ({ buf = buf; len = len } as t) str slen =
884     if slen > 0 then (
885       if len land 7 = 0 then (
886         if slen land 7 = 0 then
887           (* Common case - everything is byte-aligned. *)
888           Buffer.add_substring buf str 0 (slen lsr 3)
889         else (
890           (* Target buffer is aligned.  Copy whole bytes then leave the
891            * remaining bits in last.
892            *)
893           let slenbytes = slen lsr 3 in
894           if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes;
895           let lastidx = min slenbytes (String.length str - 1) in
896           let last = Char.code str.[lastidx] in (* last char *)
897           let mask = 0xff lsl (8 - (slen land 7)) in
898           t.last <- last land mask
899         );
900         t.len <- len + slen
901       ) else (
902         (* Target buffer is unaligned.  Copy whole bytes using
903          * add_byte which knows how to deal with an unaligned
904          * target buffer, then call add_bit for the remaining < 8 bits.
905          *
906          * XXX This is going to be dog-slow.
907          *)
908         let slenbytes = slen lsr 3 in
909         for i = 0 to slenbytes-1 do
910           let byte = Char.code str.[i] in
911           add_byte t byte
912         done;
913         let bitsleft = slen - (slenbytes lsl 3) in
914         if bitsleft > 0 then (
915           let c = Char.code str.[slenbytes] in
916           for i = 0 to bitsleft - 1 do
917             let bit = c land (0x80 lsr i) <> 0 in
918             add_bit t bit
919           done
920         )
921       );
922     )
923 end
924
925 (* Construct a single bit. *)
926 let construct_bit buf b _ _ =
927   Buffer.add_bit buf b
928
929 (* Construct a field, flen = [2..8]. *)
930 let construct_char_unsigned buf v flen exn =
931   let max_val = 1 lsl flen in
932   if v < 0 || v >= max_val then raise exn;
933   if flen = 8 then
934     Buffer.add_byte buf v
935   else
936     Buffer._add_bits buf v flen
937
938 let construct_char_signed buf v flen exn =
939   let max_val = 1 lsl flen 
940   and min_val = - (1 lsl pred flen) in
941     if v < min_val || v >= max_val then
942         raise exn;
943     if flen = 8 then
944       Buffer.add_byte buf (if v >= 0 then v else 256 + v)
945     else 
946       Buffer._add_bits buf v flen
947
948 (* Construct a field of up to 31 bits. *)
949 let construct_int check_func map_func buf v flen exn =
950   if not (check_func v flen) then raise exn;
951   map_func (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
952
953 let construct_int_be_unsigned =
954   construct_int I.range_unsigned I.map_bytes_be
955
956 let construct_int_be_signed =
957   construct_int I.range_signed I.map_bytes_be
958
959 let construct_int_le_unsigned =
960   construct_int I.range_unsigned I.map_bytes_le
961
962 let construct_int_le_signed =
963   construct_int I.range_signed I.map_bytes_le
964
965 let construct_int_ne_unsigned =
966   if nativeendian = BigEndian
967   then construct_int_be_unsigned
968   else construct_int_le_unsigned
969
970 let construct_int_ne_signed =
971   if nativeendian = BigEndian
972   then construct_int_be_signed
973   else construct_int_le_signed
974
975 let construct_int_ee_unsigned = function
976   | BigEndian -> construct_int_be_unsigned
977   | LittleEndian -> construct_int_le_unsigned
978   | NativeEndian -> construct_int_ne_unsigned
979
980 let construct_int_ee_signed = function
981   | BigEndian -> construct_int_be_signed
982   | LittleEndian -> construct_int_le_signed
983   | NativeEndian -> construct_int_ne_signed
984
985 (* Construct a field of exactly 32 bits. *)
986 let construct_int32_be_unsigned buf v flen _ =
987   Buffer.add_byte buf
988     (Int32.to_int (Int32.shift_right_logical v 24));
989   Buffer.add_byte buf
990     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
991   Buffer.add_byte buf
992     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
993   Buffer.add_byte buf
994     (Int32.to_int (Int32.logand v 0xff_l))
995
996 let construct_int32_le_unsigned buf v flen _ =
997   Buffer.add_byte buf
998     (Int32.to_int (Int32.logand v 0xff_l));
999   Buffer.add_byte buf
1000     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
1001   Buffer.add_byte buf
1002     (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
1003   Buffer.add_byte buf
1004     (Int32.to_int (Int32.shift_right_logical v 24))
1005
1006 let construct_int32_ne_unsigned =
1007   if nativeendian = BigEndian
1008   then construct_int32_be_unsigned
1009   else construct_int32_le_unsigned
1010
1011 let construct_int32_ee_unsigned = function
1012   | BigEndian -> construct_int32_be_unsigned
1013   | LittleEndian -> construct_int32_le_unsigned
1014   | NativeEndian -> construct_int32_ne_unsigned
1015
1016 (* Construct a field of up to 64 bits. *)
1017 let construct_int64_be_unsigned buf v flen exn =
1018   (* Check value is within range. *)
1019   if not (I64.range_unsigned v flen) then raise exn;
1020   (* Add the bytes. *)
1021   I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
1022
1023 (* Construct a field of up to 64 bits. *)
1024 let construct_int64_le_unsigned buf v flen exn =
1025   (* Check value is within range. *)
1026   if not (I64.range_unsigned v flen) then raise exn;
1027   (* Add the bytes. *)
1028   I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
1029
1030 let construct_int64_ne_unsigned =
1031   if nativeendian = BigEndian
1032   then construct_int64_be_unsigned
1033   else construct_int64_le_unsigned
1034
1035 let construct_int64_ee_unsigned = function
1036   | BigEndian -> construct_int64_be_unsigned
1037   | LittleEndian -> construct_int64_le_unsigned
1038   | NativeEndian -> construct_int64_ne_unsigned
1039
1040 (* Construct from a string of bytes, exact multiple of 8 bits
1041  * in length of course.
1042  *)
1043 let construct_string buf str =
1044   let len = String.length str in
1045   Buffer.add_bits buf str (len lsl 3)
1046
1047 (* Construct from a bitstring. *)
1048 let construct_bitstring buf (data, off, len) =
1049   (* Add individual bits until we get to the next byte boundary of
1050    * the underlying string.
1051    *)
1052   let blen = 7 - ((off + 7) land 7) in
1053   let blen = min blen len in
1054   let rec loop off len blen =
1055     if blen = 0 then (off, len)
1056     else (
1057       let b = extract_bit data off len 1
1058       and off = off + 1 and len = len - 1 in
1059       Buffer.add_bit buf b;
1060       loop off len (blen-1)
1061     )
1062   in
1063   let off, len = loop off len blen in
1064   assert (len = 0 || (off land 7) = 0);
1065
1066   (* Add the remaining 'len' bits. *)
1067   let data =
1068     let off = off lsr 3 in
1069     (* XXX dangerous allocation *)
1070     if off = 0 then data
1071     else String.sub data off (String.length data - off) in
1072
1073   Buffer.add_bits buf data len
1074
1075 (* Concatenate bitstrings. *)
1076 let concat bs =
1077   let buf = Buffer.create () in
1078   List.iter (construct_bitstring buf) bs;
1079   Buffer.contents buf
1080
1081 (*----------------------------------------------------------------------*)
1082 (* Extract a string from a bitstring. *)
1083 let string_of_bitstring (data, off, len) =
1084   if off land 7 = 0 && len land 7 = 0 then
1085     (* Easy case: everything is byte-aligned. *)
1086     String.sub data (off lsr 3) (len lsr 3)
1087   else (
1088     (* Bit-twiddling case. *)
1089     let strlen = (len + 7) lsr 3 in
1090     let str = String.make strlen '\000' in
1091     let rec loop data off len i =
1092       if len >= 8 then (
1093         let c = extract_char_unsigned data off len 8
1094         and off = off + 8 and len = len - 8 in
1095         str.[i] <- Char.chr c;
1096         loop data off len (i+1)
1097       ) else if len > 0 then (
1098         let c = extract_char_unsigned data off len len in
1099         str.[i] <- Char.chr (c lsl (8-len))
1100       )
1101     in
1102     loop data off len 0;
1103     str
1104   )
1105
1106 (* To channel. *)
1107
1108 let bitstring_to_chan ((data, off, len) as bits) chan =
1109   (* Fail if the bitstring length isn't a multiple of 8. *)
1110   if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
1111
1112   if off land 7 = 0 then
1113     (* Easy case: string is byte-aligned. *)
1114     output chan data (off lsr 3) (len lsr 3)
1115   else (
1116     (* Bit-twiddling case: reuse string_of_bitstring *)
1117     let str = string_of_bitstring bits in
1118     output_string chan str
1119   )
1120
1121 let bitstring_to_file bits filename =
1122   let chan = open_out_bin filename in
1123   try
1124     bitstring_to_chan bits chan;
1125     close_out chan
1126   with exn ->
1127     close_out chan;
1128     raise exn
1129
1130 (*----------------------------------------------------------------------*)
1131 (* Comparison. *)
1132 let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
1133   (* In the fully-aligned case, this is reduced to string comparison ... *)
1134   if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
1135   then (
1136     (* ... but we have to do that by hand because the bits may
1137      * not extend to the full length of the underlying string.
1138      *)
1139     let off1 = off1 lsr 3 and off2 = off2 lsr 3
1140     and len1 = len1 lsr 3 and len2 = len2 lsr 3 in
1141     let rec loop i =
1142       if i < len1 && i < len2 then (
1143         let c1 = String.unsafe_get data1 (off1 + i)
1144         and c2 = String.unsafe_get data2 (off2 + i) in
1145         let r = compare c1 c2 in
1146         if r <> 0 then r
1147         else loop (i+1)
1148       )
1149       else len1 - len2
1150     in
1151     loop 0
1152   )
1153   else (
1154     (* Slow/unaligned. *)
1155     let str1 = string_of_bitstring bs1
1156     and str2 = string_of_bitstring bs2 in
1157     let r = String.compare str1 str2 in
1158     if r <> 0 then r else len1 - len2
1159   )
1160
1161 let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
1162   if len1 <> len2 then false
1163   else if bs1 = bs2 then true
1164   else 0 = compare bs1 bs2
1165
1166 let is_zeroes_bitstring ((data, off, len) as bits) =
1167   if off land 7 = 0 && len land 7 = 0 then (
1168     let off = off lsr 3 and len = len lsr 3 in
1169     let rec loop i =
1170       if i < len then (
1171         if String.unsafe_get data (off + i) <> '\000' then false
1172         else loop (i+1)
1173       ) else true
1174     in
1175     loop 0
1176   )
1177   else (
1178     (* Slow/unaligned case. *)
1179     let len = bitstring_length bits in
1180     let zeroes = zeroes_bitstring len in
1181     0 = compare bits zeroes
1182   )
1183
1184 let is_ones_bitstring ((data, off, len) as bits) =
1185   if off land 7 = 0 && len land 7 = 0 then (
1186     let off = off lsr 3 and len = len lsr 3 in
1187     let rec loop i =
1188       if i < len then (
1189         if String.unsafe_get data (off + i) <> '\xff' then false
1190         else loop (i+1)
1191       ) else true
1192     in
1193     loop 0
1194   )
1195   else (
1196     (* Slow/unaligned case. *)
1197     let len = bitstring_length bits in
1198     let ones = ones_bitstring len in
1199     0 = compare bits ones
1200   )
1201
1202 (*----------------------------------------------------------------------*)
1203 (* Bit get/set functions. *)
1204
1205 let index_out_of_bounds () = invalid_arg "index out of bounds"
1206
1207 let put (data, off, len) n v =
1208   if n < 0 || n >= len then index_out_of_bounds ()
1209   else (
1210     let i = off+n in
1211     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1212     let c = Char.code data.[si] in
1213     let c = if v <> 0 then c lor mask else c land (lnot mask) in
1214     data.[si] <- Char.unsafe_chr c
1215   )
1216
1217 let set bits n = put bits n 1
1218
1219 let clear bits n = put bits n 0
1220
1221 let get (data, off, len) n =
1222   if n < 0 || n >= len then index_out_of_bounds ()
1223   else (
1224     let i = off+n in
1225     let si = i lsr 3 and mask = 0x80 lsr (i land 7) in
1226     let c = Char.code data.[si] in
1227     c land mask
1228   )
1229
1230 let is_set bits n = get bits n <> 0
1231
1232 let is_clear bits n = get bits n = 0
1233
1234 (*----------------------------------------------------------------------*)
1235 (* Display functions. *)
1236
1237 let isprint c =
1238   let c = Char.code c in
1239   c >= 32 && c < 127
1240
1241 let hexdump_bitstring chan (data, off, len) =
1242   let count = ref 0 in
1243   let off = ref off in
1244   let len = ref len in
1245   let linelen = ref 0 in
1246   let linechars = String.make 16 ' ' in
1247
1248   fprintf chan "00000000  ";
1249
1250   while !len > 0 do
1251     let bits = min !len 8 in
1252     let byte = extract_char_unsigned data !off !len bits in
1253     off := !off + bits; len := !len - bits;
1254
1255     let byte = byte lsl (8-bits) in
1256     fprintf chan "%02x " byte;
1257
1258     incr count;
1259     linechars.[!linelen] <-
1260       (let c = Char.chr byte in
1261        if isprint c then c else '.');
1262     incr linelen;
1263     if !linelen = 8 then fprintf chan " ";
1264     if !linelen = 16 then (
1265       fprintf chan " |%s|\n%08x  " linechars !count;
1266       linelen := 0;
1267       for i = 0 to 15 do linechars.[i] <- ' ' done
1268     )
1269   done;
1270
1271   if !linelen > 0 then (
1272     let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in
1273     for i = 0 to skip-1 do fprintf chan " " done;
1274     fprintf chan " |%s|\n%!" linechars
1275   ) else
1276     fprintf chan "\n%!"
1277
1278 (*----------------------------------------------------------------------*)
1279 (* Alias of functions shadowed by Core. *)
1280
1281 let char_code = Char.code
1282 let int32_of_int = Int32.of_int