package conan

  1. Overview
  2. Docs

Source file size.ml

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
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