package ctypes

You can search for identifiers within the package.

in-package search v0.2.0

Combinators for binding to C libraries without writing any C

Install

dune-project

Dependency

github.com Readme Changelog Edit opam file Versions (37)

Authors

J

Jeremy Yallop

Maintainers

J

Jeremy Yallop <yallop@gmail.com>

Sources

0.23.0.tar.gz

sha256=cae47d815b27dd4c824a007f1145856044542fe2588d23a443ef4eefec360bf1

md5=b1af973ec9cf7867a63714e92df82f2a

doc/src/ctypes/ctypes_coerce.ml.html

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
(*
 * Copyright (c) 2013 Jeremy Yallop.
 *
 * This file is distributed under the terms of the MIT License.
 * See the file LICENSE for details.
 *)

(* Coercions *)

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