File: bitstring.ml

package info (click to toggle)
sks 1.1.6-14
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 2,296 kB
  • sloc: ml: 15,228; ansic: 1,069; sh: 358; makefile: 347
file content (308 lines) | stat: -rw-r--r-- 9,308 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
(***********************************************************************)
(* bitstring.ml                                                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* This file is part of SKS.  SKS is free software; you can            *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version.    *)
(*                                                                     *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU   *)
(* General Public License for more details.                            *)
(*                                                                     *)
(* You should have received a copy of the GNU General Public License   *)
(* along with this program; if not, write to the Free Software         *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>.                          *)
(***********************************************************************)

open StdLabels
open MoreLabels

module Unix=UnixLabels

exception Error of string
exception LengthError of string

let width = 8

type t = { a: string;
           bitlength: int;
         }

let bytelength bits =
  bits / width + (if bits mod width = 0 then 0 else 1)

let create bits =
  let bytes = bytelength bits
  in
  { a = Bytes.create bytes;
    bitlength = bits;
  }

let get ba bit =
  let byte_pos = bit / width
  and bit_pos = bit mod width in
  let intval = int_of_char (String.get ba.a byte_pos) in
  (intval lsr (width - bit_pos - 1)) land 1

let lget ba bit = get ba bit = 1

let flip ba bit =
  let byte_pos = bit / width
  and bit_pos = bit mod width in
  let intval = int_of_char (String.get ba.a byte_pos) in
  let new_char = char_of_int ((1 lsl (width - bit_pos - 1)) lxor intval)
  in
  Bytes.set ba.a byte_pos new_char

let set ba bit =
  let byte_pos = bit / width
  and bit_pos = bit mod width in
  let intval = int_of_char (String.get ba.a byte_pos) in
  let new_char = char_of_int ((1 lsl (width - bit_pos - 1)) lor intval)
  in
  Bytes.set ba.a byte_pos new_char

let unset ba bit =
  let byte_pos = bit / width
  and bit_pos = bit mod width in
  let intval = int_of_char (String.get ba.a byte_pos) in
  let new_char = char_of_int ((lnot (1 lsl (width - bit_pos - 1)))
                              land intval)
  in
  Bytes.set ba.a byte_pos new_char

let setval ba bit bool =
  if bool then set ba bit else unset ba bit

(************************************************************)
(* Printing and Conversions *********************************)
(************************************************************)

let print ba =
  for i = 0 to ba.bitlength - 1 do
    if get ba i = 0
    then print_string "0"
    else print_string "1"
  done

let hexprint ba =
  print_string (Utils.hexstring ba.a)

let to_bool_array ba =
  Array.init ~f:(fun i -> lget ba i) ba.bitlength

let to_string ba =
  let string = Bytes.create ba.bitlength in
  for i = 0 to ba.bitlength -1 do
    if get ba i = 0 then Bytes.set string i '0' else Bytes.set string i '1'
  done;
  string

let to_bytes ba =
  let lastbit = (bytelength ba.bitlength)*width - 1 in
  for i = ba.bitlength to lastbit do
    unset ba i
  done;
  String.sub ~pos:0 ~len:(bytelength ba.bitlength) ba.a

let of_bytes string bitlength =
  { bitlength = bitlength;
    a = String.copy string;
  }

let of_byte b =
  { bitlength = width;
    a = String.make 1 (char_of_int (b land 0xFF));
  }

let of_bytes_all string =
  { bitlength = (String.length string) * width;
    a = String.copy string;
  }

let of_int i =
  { bitlength = width * 4;
    a = Utils.bstring_of_int i;
  }

let of_bytes_nocopy string bitlength =
  { bitlength = bitlength;
    a = string;
  }

let of_bytes_all_nocopy string =
  { bitlength = (String.length string) * width;
    a = string;
  }

let to_bytes_nocopy ba =
  let lastbit = (bytelength ba.bitlength)*8 - 1 in
  for i = ba.bitlength to lastbit do
    unset ba i
  done;
  ba.a

(************************************************************)
(************************************************************)
(************************************************************)

let copy ba = { ba with a = String.copy ba.a }

(** returns a copy of bitstring copied into a new bitstring of a new length.
  No guarantees are made as to the contents of the remainder of the bitstring
  if the bitstring length is extended.
 *)
let copy_len ba bitlength =
  let bytes = bytelength bitlength in
  let str = Bytes.create bytes in
  String.blit ~src:ba.a ~src_pos:0
    ~dst:str ~dst_pos:0 ~len:(String.length ba.a);
  { a = str; bitlength = bitlength }

(********************************************************************)
(***  Shifting  *****************************************************)
(********************************************************************)

let shift_pair_left c1 c2 bits=
  let i1 = int_of_char c1
  and i2 = int_of_char c2  in
  let shifted_int =
    (i1 lsl bits) lor (i2 lsr (width - bits))
  in
  char_of_int (shifted_int land 0xFF)

let shift_pair_right c1 c2 bits =
  let i1 = int_of_char c1
  and i2 = int_of_char c2 in
  let shifted_int =
    (i1 lsl (width - bits)) lor (i2 lsr bits)
  in
  char_of_int (shifted_int land 0xFF)

(**********************************)

let shift_left_small ba bits =
  if bits > 0 then
    let bytes = bytelength ba.bitlength in
    for i = 0 to bytes-2 do
      Bytes.set ba.a i (shift_pair_left ba.a.[i] ba.a.[i+1] bits)
    done;
    Bytes.set ba.a (bytes-1) (shift_pair_left ba.a.[bytes-1] '\000' bits)

let shift_right_small ba bits =
  if bits > 0 then
    let bytes = bytelength ba.bitlength in
    for i = bytes-1 downto 1 do
      Bytes.set ba.a i (shift_pair_right ba.a.[i-1] ba.a.[i] bits)
    done;
    Bytes.set ba.a 0 (shift_pair_right '\000' ba.a.[0] bits)

(**********************************)

let rec shift_left ba bits =
  if bits < 0 then
    shift_right ba (-bits)
  else
  let bytelength = bytelength ba.bitlength
  and bytes = bits / width
  and bits = bits mod width in
  if bytes > 0
  then
    begin
      for i = 0 to bytelength - 1 - bytes do
        Bytes.set ba.a i ba.a.[i+bytes];
      done;
      for i = bytelength - bytes to bytelength - 1 do
        Bytes.set ba.a i '\000'
      done
    end;
  shift_left_small ba bits

and shift_right ba bits =
  if bits < 0 then
    shift_left ba (-bits)
  else
    let bytelength = bytelength ba.bitlength
    and bytes = bits / width
    and bits = bits mod width in
    if bytes > 0
    then
      begin
        for i = bytelength - 1 downto bytes do
          Bytes.set ba.a i ba.a.[i-bytes];
        done;
        for i = bytes - 1 downto 0 do
          Bytes.set ba.a i '\000'
        done
      end;
    shift_right_small ba bits

let num_bits ba = ba.bitlength
let num_bytes ba = bytelength ba.bitlength

(********************************************************************)
(********************************************************************)
(********************************************************************)

let rmasks =
  Array.init width ~f:(fun i -> 0xFF lsl (width - i))

(* Later, extend to have optional initial-position arguments *)
let blit ~src ~dst ~len =
  (* these tests are probably redundant, since they'll cause
     exceptions deeper in.  OCaml's lousy traceback features, however, make
     it somewhat useful to have these here. *)
  if len < 0
  then raise (Invalid_argument "Bitstring.blit: negative len");
  if dst.bitlength < len
  then raise (Invalid_argument "Bitstring.blit: dst too short");
  if src.bitlength < len
  then raise (Invalid_argument "Bitstring.blit: src too short");
  let bytelen = len / width
  and bitlen = len mod width in
  String.blit
    ~src:src.a ~src_pos:0
    ~dst:dst.a ~dst_pos:0 ~len:bytelen;
  if bitlen > 0 then
    let srcval = int_of_char (String.get src.a bytelen)
    and dstval = int_of_char (String.get dst.a bytelen) in
    let newdst = (rmasks.(bitlen) land srcval) lor
                 ((lnot rmasks.(bitlen)) land dstval)
    in
    Bytes.set dst.a bytelen (char_of_int newdst)


(* let full_blit ~src ~src_pos ~dst ~dst_pos ~len =  *)


let zero_out bs =
  Bytes.fill bs.a ~pos:0 ~len:(String.length bs.a) '\000'

(*
let extract bs ~pos ~len =
  let first_bit = pos % 8
  let first_byte = pos / 8 in
  let last_byte = (pos + len) / 8 +
                  (if (pos + len) % 8 > 0 then 1 else 0) in
  let byte_len =  last_byte - first_byte + 1 in
  let newbs = Bitstring.create len in
  String.blit
    ~src:bs.a ~src_pos:src_first_byte
    ~dst:newbs.a ~dst_pos:0 ~len:byte_len;
  shift_left newbs first_bit;
*)


(*
let concat bs1 bs2 =
  let newbs = create (bs1.bits + bs2.bits) in
  blit ~src:bs1 ~dst:newbs ~len:(bs1.bits);
*)