Source file ctypes_coerce.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
[@@@warning "-27"]
open Ctypes_static
type uncoercible_info =
Types : _ typ * _ typ -> uncoercible_info
| Functions : _ fn * _ fn -> uncoercible_info
exception Uncoercible of uncoercible_info
let show_uncoercible = function
Uncoercible (Types (l, r)) ->
let pr ty = Ctypes_type_printing.string_of_typ ty in
Some (Format.sprintf
"Coercion failure: %s is not coercible to %s" (pr l) (pr r))
| Uncoercible (Functions (l, r)) ->
let pr ty = Ctypes_type_printing.string_of_fn ty in
Some (Format.sprintf
"Coercion failure: %s is not coercible to %s" (pr l) (pr r))
| _ -> None
let () = Printexc.register_printer show_uncoercible
let uncoercible : 'a 'b 'c. 'a typ -> 'b typ -> 'c =
fun l r -> raise (Uncoercible (Types (l, r)))
let uncoercible_functions : 'a 'b 'c. 'a fn -> 'b fn -> 'c =
fun l r -> raise (Uncoercible (Functions (l, r)))
let id x = x
type (_, _) coercion =
| Id : ('a, 'a) coercion
| Coercion : ('a -> 'b) -> ('a, 'b) coercion
let ml_prim_coercion :
type a b. a Ctypes_primitive_types.ml_prim -> b Ctypes_primitive_types.ml_prim ->
(a, b) coercion option =
let open Ctypes_primitive_types in
fun l r -> match l, r with
| ML_char, ML_char -> Some Id
| ML_complex, ML_complex -> Some Id
| ML_float, ML_float -> Some Id
| ML_int, ML_int -> Some Id
| ML_int32, ML_int32 -> Some Id
| ML_int64, ML_int64 -> Some Id
| ML_llong, ML_llong -> Some Id
| ML_long, ML_long -> Some Id
| ML_nativeint, ML_nativeint -> Some Id
| ML_size_t, ML_size_t -> Some Id
| ML_uchar, ML_uchar -> Some Id
| ML_bool, ML_bool -> Some Id
| ML_uint, ML_uint -> Some Id
| ML_uint16, ML_uint16 -> Some Id
| ML_uint32, ML_uint32 -> Some Id
| ML_uint64, ML_uint64 -> Some Id
| ML_uint8, ML_uint8 -> Some Id
| ML_ullong, ML_ullong -> Some Id
| ML_ulong, ML_ulong -> Some Id
| ML_ushort, ML_ushort -> Some Id
| l, r -> None
let rec coercion : type a b. a typ -> b typ -> (a, b) coercion =
fun atyp btyp -> match atyp, btyp with
| _, Void -> Coercion ignore
| Primitive l, Primitive r ->
(match Ctypes_primitive_types.(ml_prim_coercion (ml_prim l) (ml_prim r)) with
Some c -> c
| None -> uncoercible atyp btyp)
| View av, b ->
begin match coercion av.ty b with
| Id -> Coercion av.write
| Coercion coerce -> Coercion (fun v -> coerce (av.write v))
end
| a, View bv ->
begin match coercion a bv.ty with
| Id -> Coercion bv.read
| Coercion coerce -> Coercion (fun v -> bv.read (coerce v))
end
| Pointer a, Pointer b ->
begin match coercion a b with
| Id -> Id
| Coercion _ ->
Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b))
| exception Uncoercible _ ->
Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b))
end
| Pointer a, Funptr b ->
Coercion (fun (CPointer p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b))
| Funptr a, Pointer b ->
Coercion (fun (Static_funptr p) -> CPointer (Ctypes_ptr.Fat.coerce p b))
| Funptr a, Funptr b ->
begin match fn_coercion a b with
| Id -> Id
| Coercion _ ->
Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b))
| exception Uncoercible _ ->
Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b))
end
| Qualified (_,l), r
| l, Qualified (_, r) -> coercion l r
| l, r -> uncoercible l r
and fn_coercion : type a b. a fn -> b fn -> (a, b) coercion =
fun afn bfn -> match afn, bfn with
| Function (af, at), Function (bf, bt) ->
begin match coercion bf af, fn_coercion at bt with
| Id, Id -> Id
| Id, Coercion h ->
Coercion (fun g x -> h (g x))
| Coercion f, Id ->
Coercion (fun g x -> g (f x))
| Coercion f, Coercion h ->
Coercion (fun g x -> h (g (f x)))
end
| Returns at, Returns bt -> coercion at bt
| l, r -> uncoercible_functions l r
let coerce : type a b. a typ -> b typ -> a -> b =
fun atyp btyp -> match coercion atyp btyp with
| Id -> id
| Coercion c -> c
let coerce_fn : type a b. a fn -> b fn -> a -> b =
fun afn bfn -> match fn_coercion afn bfn with
| Id -> id
| Coercion c -> c