[163] | 1 | open Util;; |
---|
| 2 | |
---|
[87] | 3 | type bit = bool |
---|
| 4 | type 'a vect = bit list |
---|
| 5 | type nibble = [`Four] vect |
---|
| 6 | type byte7 = [`Seven] vect |
---|
| 7 | type byte = [`Eight] vect |
---|
| 8 | type word = [`Sixteen] vect |
---|
| 9 | type word11 = [`Eleven] vect |
---|
[86] | 10 | |
---|
[92] | 11 | type sizes = [ `Four | `Seven | `Eight | `Eleven | `Sixteen ] |
---|
| 12 | |
---|
[87] | 13 | let mk_nibble b1 b2 b3 b4 = [b1; b2; b3; b4] |
---|
| 14 | let from_nibble = |
---|
| 15 | function |
---|
| 16 | [b1; b2; b3; b4] -> b1,b2,b3,b4 |
---|
| 17 | | _ -> assert false |
---|
| 18 | let mk_byte n1 n2 = n1 @ n2 |
---|
[95] | 19 | let mk_byte_from_bits ((b1,b2,b3,b4),(b5,b6,b7,b8)) = ([b1;b2;b3;b4;b5;b6;b7;b8] : [`Eight] vect) |
---|
[87] | 20 | let from_byte = |
---|
| 21 | function |
---|
| 22 | b1::b2::b3::b4::r -> [b1;b2;b3;b4],r |
---|
| 23 | | _ -> assert false |
---|
[97] | 24 | let bits_of_byte = |
---|
| 25 | function |
---|
| 26 | [b1;b2;b3;b4;b5;b6;b7;b8] -> (b1,b2,b3,b4),(b5,b6,b7,b8) |
---|
| 27 | | _ -> assert false |
---|
[87] | 28 | let mk_byte7 b1 b2 b3 n1 = b1::b2::b3::n1 |
---|
| 29 | let from_byte7 = |
---|
| 30 | function |
---|
| 31 | b1::b2::b3::r -> b1,b2,b3,r |
---|
| 32 | | _ -> assert false |
---|
| 33 | let mk_word = mk_byte |
---|
| 34 | let from_word = |
---|
| 35 | function |
---|
| 36 | b1::b2::b3::b4::b5::b6::b7::b8::r -> [b1;b2;b3;b4;b5;b6;b7;b8],r |
---|
| 37 | | _ -> assert false |
---|
| 38 | let mk_word11 = mk_byte7 |
---|
| 39 | let from_word11 = from_byte7 |
---|
[86] | 40 | |
---|
[163] | 41 | let get_bit l index = |
---|
[87] | 42 | try |
---|
[163] | 43 | List.nth (List.rev l) index |
---|
[162] | 44 | with (Failure _ | Invalid_argument _) -> assert false |
---|
[86] | 45 | |
---|
[87] | 46 | let set_bit l index new_val = |
---|
| 47 | try |
---|
| 48 | let rec aux index l = |
---|
| 49 | match index, l with |
---|
| 50 | _, [] -> raise (Invalid_argument "") |
---|
| 51 | | 0,_::tl -> new_val::tl |
---|
| 52 | | n,hd::tl -> hd::(aux (n-1) tl) in |
---|
[162] | 53 | List.rev (aux index (List.rev l)) |
---|
| 54 | with Invalid_argument "" -> assert false |
---|
[86] | 55 | |
---|
[87] | 56 | let (-&-) l1 l2 = List.map2 (fun b1 b2 -> b1 & b2) l1 l2 |
---|
| 57 | let (-|-) l1 l2 = List.map2 (fun b1 b2 -> b1 || b2) l1 l2 |
---|
| 58 | let xor b1 b2 = b1 <> b2 |
---|
| 59 | let (-^-) l1 l2 = List.map2 xor l1 l2 |
---|
[95] | 60 | let complement l1 = List.map (not) l1 |
---|
[86] | 61 | |
---|
[87] | 62 | let iter_bits f v = String.concat "" (List.map f v) |
---|
| 63 | let map_bits = List.map |
---|
| 64 | let map2_bits = List.map2 |
---|
[86] | 65 | |
---|
[98] | 66 | let string_of_bit = function false -> "0" | true -> "1" |
---|
| 67 | let string_of_vect l = String.concat "" (List.map string_of_bit l) |
---|
[86] | 68 | |
---|
[87] | 69 | let full_add l r c = List.fold_right2 (fun b1 b2 (c,r) -> b1 & b2 || c & (b1 || b2),xor (xor b1 b2) c::r) l r (c,[]) |
---|
| 70 | let half_add l r = full_add l r false |
---|
[86] | 71 | |
---|
[147] | 72 | let sign_extension = |
---|
| 73 | function |
---|
| 74 | [] -> assert false |
---|
| 75 | | (he::_) as l -> |
---|
| 76 | [he;he;he;he;he;he;he;he] @ l |
---|
| 77 | ;; |
---|
| 78 | |
---|
| 79 | |
---|
[88] | 80 | let rec split_last = |
---|
| 81 | function |
---|
| 82 | [] -> assert false |
---|
| 83 | | [he] -> he,[] |
---|
| 84 | | he::tl -> |
---|
| 85 | let l,res = split_last tl in |
---|
| 86 | l,he::res |
---|
[86] | 87 | |
---|
[88] | 88 | let shift_left = |
---|
| 89 | function |
---|
| 90 | [] -> assert false |
---|
| 91 | | _::tl -> tl @ [false] |
---|
[87] | 92 | let shift_right l = false :: snd (split_last l) |
---|
[88] | 93 | let rotate_left = |
---|
| 94 | function |
---|
| 95 | [] -> assert false |
---|
| 96 | | he::tl -> tl @ [he] |
---|
| 97 | let rotate_right l = |
---|
| 98 | let he,tl = split_last l in |
---|
| 99 | he::tl |
---|
| 100 | |
---|
[140] | 101 | (* CSC: can overflow!!! *) |
---|
[88] | 102 | let int_of_vect v = |
---|
| 103 | let rec aux pow v = |
---|
| 104 | match v with |
---|
| 105 | [] -> 0 |
---|
| 106 | | hd::tl -> |
---|
| 107 | if hd = true then |
---|
| 108 | pow + (aux (pow * 2) tl) |
---|
| 109 | else |
---|
| 110 | aux (pow * 2) tl |
---|
| 111 | in |
---|
| 112 | aux 1 (List.rev v) |
---|
[89] | 113 | |
---|
| 114 | let size_lookup = |
---|
| 115 | function |
---|
| 116 | `Four -> 4 |
---|
| 117 | | `Seven -> 7 |
---|
| 118 | | `Eight -> 8 |
---|
| 119 | | `Eleven -> 11 |
---|
| 120 | | `Sixteen -> 16 |
---|
| 121 | |
---|
| 122 | let rec pow v p = |
---|
| 123 | if p = 0 then |
---|
| 124 | 1 |
---|
| 125 | else |
---|
| 126 | v * (pow v (p - 1)) |
---|
| 127 | |
---|
| 128 | let divide_with_remainder x y = (x / y, x mod y) |
---|
| 129 | |
---|
| 130 | let rec aux i = |
---|
| 131 | if i < 0 then |
---|
| 132 | raise (Invalid_argument "Negative index") |
---|
| 133 | else |
---|
| 134 | let (d, r) = divide_with_remainder i 2 in |
---|
| 135 | if (d, r) = (0, 0) then |
---|
| 136 | [] |
---|
| 137 | else if r = 0 then |
---|
| 138 | false :: aux d |
---|
| 139 | else |
---|
| 140 | true :: aux d |
---|
| 141 | |
---|
[138] | 142 | let rec pad i l = if i = 0 then l else false :: (pad (i - 1) l) |
---|
| 143 | |
---|
[89] | 144 | let vect_of_int i size = |
---|
| 145 | let big_list = List.rev (aux i) in |
---|
[138] | 146 | if List.length big_list > size_lookup size then |
---|
[89] | 147 | raise (Invalid_argument "Size not big enough") |
---|
| 148 | else |
---|
[138] | 149 | let diff = size_lookup size - List.length big_list in |
---|
| 150 | pad diff big_list |
---|
[89] | 151 | |
---|
[138] | 152 | let zero size = pad (size_lookup size) [] |
---|
[140] | 153 | |
---|
| 154 | (* CSC: can overflow!!! *) |
---|
[142] | 155 | (* CSC: only works properly with bytes!!! *) |
---|
[140] | 156 | let hex_string_of_vect v = Printf.sprintf "%0 2X" (int_of_vect v);; |
---|