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
147
148
149
150
151
152
153
154
155
156
157
158
159
|
(* -*- tuareg -*- *)
open Int32
open Int64
type enum = [ `Int of int ]
type 'a c_obj_t =
C_void
| C_bool of bool
| C_char of char
| C_uchar of char
| C_short of int
| C_ushort of int
| C_int of int
| C_uint of int32
| C_int32 of int32
| C_int64 of int64
| C_float of float
| C_double of float
| C_ptr of int64 * int64
| C_array of 'a c_obj_t array
| C_list of 'a c_obj_t list
| C_obj of (string -> 'a c_obj_t -> 'a c_obj_t)
| C_string of string
| C_enum of 'a
| C_director_core of 'a c_obj_t * 'a c_obj_t option ref
type c_obj = enum c_obj_t
exception BadArgs of string
exception BadMethodName of string * string
exception NotObject of c_obj
exception NotEnumType of c_obj
exception LabelNotFromThisEnum of c_obj
exception InvalidDirectorCall of c_obj
exception NoSuchClass of string
let rec invoke obj =
match obj with
C_obj o -> o
| C_director_core (o,r) -> invoke o
| _ -> raise (NotObject (Obj.magic obj))
let _ = Callback.register "swig_runmethod" invoke
let fnhelper arg =
match arg with C_list l -> l | C_void -> [] | _ -> [ arg ]
let rec get_int x =
match x with
C_bool b -> if b then 1 else 0
| C_char c
| C_uchar c -> (int_of_char c)
| C_short s
| C_ushort s
| C_int s -> s
| C_uint u
| C_int32 u -> (Int32.to_int u)
| C_int64 u -> (Int64.to_int u)
| C_float f -> (int_of_float f)
| C_double d -> (int_of_float d)
| C_ptr (p,q) -> (Int64.to_int p)
| C_obj o -> (try (get_int (o "int" C_void))
with _ -> (get_int (o "&" C_void)))
| _ -> raise (Failure "Can't convert to int")
let rec get_float x =
match x with
C_char c
| C_uchar c -> (float_of_int (int_of_char c))
| C_short s -> (float_of_int s)
| C_ushort s -> (float_of_int s)
| C_int s -> (float_of_int s)
| C_uint u
| C_int32 u -> (float_of_int (Int32.to_int u))
| C_int64 u -> (float_of_int (Int64.to_int u))
| C_float f -> f
| C_double d -> d
| C_obj o -> (try (get_float (o "float" C_void))
with _ -> (get_float (o "double" C_void)))
| _ -> raise (Failure "Can't convert to float")
let rec get_char x =
(char_of_int (get_int x))
let rec get_string x =
match x with
C_string str -> str
| _ -> raise (Failure "Can't convert to string")
let rec get_bool x =
match x with
C_bool b -> b
| _ ->
(try if get_int x != 0 then true else false
with _ -> raise (Failure "Can't convert to bool"))
let disown_object obj =
match obj with
C_director_core (o,r) -> r := None
| _ -> raise (Failure "Not a director core object")
let _ = Callback.register "caml_obj_disown" disown_object
let addr_of obj =
match obj with
C_obj _ -> (invoke obj) "&" C_void
| C_director_core (self,r) -> (invoke self) "&" C_void
| C_ptr _ -> obj
| _ -> raise (Failure "Not a pointer.")
let _ = Callback.register "caml_obj_ptr" addr_of
let make_float f = C_float f
let make_double f = C_double f
let make_string s = C_string s
let make_bool b = C_bool b
let make_char c = C_char c
let make_char_i c = C_char (char_of_int c)
let make_uchar c = C_uchar c
let make_uchar_i c = C_uchar (char_of_int c)
let make_short i = C_short i
let make_ushort i = C_ushort i
let make_int i = C_int i
let make_uint i = C_uint (Int32.of_int i)
let make_int32 i = C_int32 (Int32.of_int i)
let make_int64 i = C_int64 (Int64.of_int i)
let new_derived_object cfun x_class args =
begin
let get_object ob =
match !ob with
None ->
raise (NotObject C_void)
| Some o -> o in
let ob_ref = ref None in
let class_fun class_f ob_r =
(fun meth args -> class_f (get_object ob_r) meth args) in
let new_class = class_fun x_class ob_ref in
let dircore = C_director_core (C_obj new_class,ob_ref) in
let obj =
cfun (match args with
C_list argl -> (C_list ((dircore :: argl)))
| C_void -> (C_list [ dircore ])
| a -> (C_list [ dircore ; a ])) in
ob_ref := Some obj ;
obj
end
let swig_current_type_info = ref C_void
let find_type_info obj = !swig_current_type_info
let _ = Callback.register "swig_find_type_info" find_type_info
let set_type_info obj =
match obj with
C_ptr _ -> swig_current_type_info := obj ;
obj
| _ -> raise (Failure "Internal error: passed non pointer to set_type_info")
let _ = Callback.register "swig_set_type_info" set_type_info
let class_master_list = Hashtbl.create 20
let register_class_byname nm co =
Hashtbl.replace class_master_list nm (Obj.magic co)
let create_class nm arg =
try (Obj.magic (Hashtbl.find class_master_list nm)) arg with _ -> raise (NoSuchClass nm)
|
