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
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
let ( <.> ) f g x = f (g x)
let ok x = Ok x
type t =
| Byte
| Leshort
| Beshort
| Lelong
| Belong
| Melong
| Leid3
| Beid3
| Lequad
| Bequad
let serialize ppf = function
| Byte -> Format.pp_print_string ppf "Conan.Size.byte"
| Leshort -> Format.pp_print_string ppf "Conan.Size.leshort"
| Beshort -> Format.pp_print_string ppf "Conan.Size.beshort"
| Lelong -> Format.pp_print_string ppf "Conan.Size.lelong"
| Belong -> Format.pp_print_string ppf "Conan.Size.belong"
| Melong -> Format.pp_print_string ppf "Conan.Size.melong"
| Leid3 -> Format.pp_print_string ppf "Conan.Size.leid3"
| Beid3 -> Format.pp_print_string ppf "Conan.Size.beid3"
| Lequad -> Format.pp_print_string ppf "Conan.Size.lequad"
| Bequad -> Format.pp_print_string ppf "Conan.Size.bequad"
let byte = Byte
let leshort = Leshort
let beshort = Beshort
let lelong = Lelong
let belong = Belong
let melong = Melong
let leid3 = Leid3
let beid3 = Beid3
let lequad = Lequad
let bequad = Bequad
let short = if Sys.big_endian then Beshort else Leshort
let long = if Sys.big_endian then Belong else Lelong
let id3 = if Sys.big_endian then Beid3 else Leid3
let quad = if Sys.big_endian then Bequad else Lequad
let of_string = function
| "B" | "b" | "C" | "c" -> Byte
| "s" | "h" -> Leshort
| "S" | "H" -> Beshort
| "l" -> Lelong
| "L" -> Belong
| "m" -> Melong
| "i" -> Leid3
| "I" -> Beid3
| "q" -> Lequad
| "Q" -> Bequad
| v -> invalid_arg "Invalid size: %S" v
let is_size = function
| 'Q' | 'q' | 'B' | 'b' | 'C' | 'c' | 's' | 'h' | 'S' | 'H' | 'l' | 'L' | 'm'
| 'i' | 'I' ->
true
| _ -> false
let pp = Format.fprintf
let pp ppf = function
| Byte -> pp ppf "byte"
| Leshort -> pp ppf "leshort"
| Beshort -> pp ppf "beshort"
| Lelong -> pp ppf "lelong"
| Belong -> pp ppf "belong"
| Melong -> pp ppf "melong"
| Leid3 -> pp ppf "leid3"
| Beid3 -> pp ppf "beid3"
| Lequad -> pp ppf "lequad"
| Bequad -> pp ppf "bequad"
open Sigs
external swap16 : int -> int = "%bswap16"
external swap32 : int32 -> int32 = "%bswap_int32"
external swap64 : int64 -> int64 = "%bswap_int64"
let invert { bind; return } syscall =
let ( >>= ) = bind in
let ( >|= ) x f =
x >>= function Ok x -> return (Ok (f x)) | Error err -> return (Error err)
in
let read_int16_ne fd = syscall.read_int16_ne fd >|= swap16 in
let read_int32_ne fd = syscall.read_int32_ne fd >|= swap32 in
let read_int64_ne fd = syscall.read_int64_ne fd >|= swap64 in
{ syscall with read_int16_ne; read_int32_ne; read_int64_ne }
let read :
type s fd error.
s scheduler ->
(fd, error, s) syscall ->
fd ->
t ->
((int64, error) result, s) io =
fun { bind; return } syscall fd s ->
let ( >>= ) = bind in
let ( >?= ) x f =
x >>= function Ok x -> f x | Error err -> return (Error err)
in
let ( >|= ) x f = x >?= fun x -> (return <.> ok) (f x) in
match s with
| Byte -> syscall.read_int8 fd >|= Int64.of_int
| Leshort ->
if Sys.big_endian then
syscall.read_int16_ne fd >|= swap16 >|= Int64.of_int
else syscall.read_int16_ne fd >|= Int64.of_int
| Beshort ->
if Sys.big_endian then syscall.read_int16_ne fd >|= Int64.of_int
else syscall.read_int16_ne fd >|= swap16 >|= Int64.of_int
| Lelong ->
if Sys.big_endian then
syscall.read_int32_ne fd >|= swap32 >|= Int64.of_int32
else syscall.read_int32_ne fd >|= Int64.of_int32
| Belong ->
if Sys.big_endian then syscall.read_int32_ne fd >|= Int64.of_int32
else syscall.read_int32_ne fd >|= swap32 >|= Int64.of_int32
| Lequad ->
if Sys.big_endian then syscall.read_int64_ne fd >|= swap64
else syscall.read_int64_ne fd
| Bequad ->
if Sys.big_endian then syscall.read_int64_ne fd >|= swap64
else syscall.read_int64_ne fd
| s -> invalid_arg "Unsupported size %a" pp s