1(* -*- tuareg -*- *)
2open Int32
3open Int64
4
5type enum = [ `Int of int ]
6
7type 'a c_obj_t =
8    C_void
9  | C_bool of bool
10  | C_char of char
11  | C_uchar of char
12  | C_short of int
13  | C_ushort of int
14  | C_int of int
15  | C_uint of int32
16  | C_int32 of int32
17  | C_int64 of int64
18  | C_float of float
19  | C_double of float
20  | C_ptr of int64 * int64
21  | C_array of 'a c_obj_t array
22  | C_list of 'a c_obj_t list
23  | C_obj of (string -> 'a c_obj_t -> 'a c_obj_t)
24  | C_string of string
25  | C_enum of 'a
26  | C_director_core of 'a c_obj_t * 'a c_obj_t option ref
27
28type c_obj = enum c_obj_t
29
30exception BadArgs of string
31exception BadMethodName of string * string
32exception NotObject of c_obj
33exception NotEnumType of c_obj
34exception LabelNotFromThisEnum of c_obj
35exception InvalidDirectorCall of c_obj
36exception NoSuchClass of string
37let rec invoke obj =
38  match obj with
39      C_obj o -> o
40    | C_director_core (o,r) -> invoke o
41    | _ -> raise (NotObject (Obj.magic obj))
42let _ = Callback.register "swig_runmethod" invoke
43
44let fnhelper arg =
45  match arg with C_list l -> l | C_void -> [] | _ -> [ arg ]
46
47let director_core_helper fnargs =
48  try
49    match List.hd fnargs with
50      | C_director_core (o,r) -> fnargs
51      | _ -> C_void :: fnargs
52  with Failure _ -> C_void :: fnargs
53
54let rec get_int x =
55  match x with
56      C_bool b -> if b then 1 else 0
57    | C_char c
58    | C_uchar c -> (int_of_char c)
59    | C_short s
60    | C_ushort s
61    | C_int s -> s
62    | C_uint u
63    | C_int32 u -> (Int32.to_int u)
64    | C_int64 u -> (Int64.to_int u)
65    | C_float f -> (int_of_float f)
66    | C_double d -> (int_of_float d)
67    | C_ptr (p,q) -> (Int64.to_int p)
68    | C_obj o -> (try (get_int (o "int" C_void))
69		  with _ -> (get_int (o "&" C_void)))
70    | _ -> raise (Failure "Can't convert to int")
71
72let rec get_float x =
73  match x with
74      C_char c
75    | C_uchar c -> (float_of_int (int_of_char c))
76    | C_short s -> (float_of_int s)
77    | C_ushort s -> (float_of_int s)
78    | C_int s -> (float_of_int s)
79    | C_uint u
80    | C_int32 u -> (float_of_int (Int32.to_int u))
81    | C_int64 u -> (float_of_int (Int64.to_int u))
82    | C_float f -> f
83    | C_double d -> d
84    | C_obj o -> (try (get_float (o "float" C_void))
85		  with _ -> (get_float (o "double" C_void)))
86    | _ -> raise (Failure "Can't convert to float")
87
88let rec get_char x =
89  (char_of_int (get_int x))
90
91let rec get_string x =
92  match x with
93      C_string str -> str
94    | _ -> raise (Failure "Can't convert to string")
95
96let rec get_bool x =
97  match x with
98      C_bool b -> b
99    | _ ->
100	(try if get_int x != 0 then true else false
101	 with _ -> raise (Failure "Can't convert to bool"))
102
103let disown_object obj =
104  match obj with
105      C_director_core (o,r) -> r := None
106    | _ -> raise (Failure "Not a director core object")
107let _ = Callback.register "caml_obj_disown" disown_object
108let addr_of obj =
109  match obj with
110      C_obj _ -> (invoke obj) "&" C_void
111    | C_director_core (self,r) -> (invoke self) "&" C_void
112    | C_ptr _ -> obj
113    | _ -> raise (Failure "Not a pointer.")
114let _ = Callback.register "caml_obj_ptr" addr_of
115
116let make_float f = C_float f
117let make_double f = C_double f
118let make_string s = C_string s
119let make_bool b = C_bool b
120let make_char c = C_char c
121let make_char_i c = C_char (char_of_int c)
122let make_uchar c = C_uchar c
123let make_uchar_i c = C_uchar (char_of_int c)
124let make_short i = C_short i
125let make_ushort i = C_ushort i
126let make_int i = C_int i
127let make_uint i = C_uint (Int32.of_int i)
128let make_int32 i = C_int32 (Int32.of_int i)
129let make_int64 i = C_int64 (Int64.of_int i)
130
131let new_derived_object cfun x_class args =
132  begin
133    let get_object ob =
134      match !ob with
135          None ->
136    raise (NotObject C_void)
137        | Some o -> o in
138    let ob_ref = ref None in
139    let class_fun class_f ob_r =
140      (fun meth args -> class_f (get_object ob_r) meth args) in
141    let new_class = class_fun x_class ob_ref in
142    let dircore = C_director_core (C_obj new_class,ob_ref) in
143    let obj =
144    cfun (match args with
145            C_list argl -> (C_list ((dircore :: argl)))
146	  | C_void -> (C_list [ dircore ])
147          | a -> (C_list [ dircore ; a ])) in
148    ob_ref := Some obj ;
149      obj
150  end
151
152let swig_current_type_info = ref C_void
153let find_type_info obj = !swig_current_type_info
154let _ = Callback.register "swig_find_type_info" find_type_info
155let set_type_info obj =
156  match obj with
157    C_ptr _ -> swig_current_type_info := obj ;
158               obj
159    | _ -> raise (Failure "Internal error: passed non pointer to set_type_info")
160let _ = Callback.register "swig_set_type_info" set_type_info
161
162let class_master_list = Hashtbl.create 20
163let register_class_byname nm co =
164  Hashtbl.replace class_master_list nm (Obj.magic co)
165let create_class nm =
166  try (Obj.magic (Hashtbl.find class_master_list nm)) with _ -> raise (NoSuchClass nm)
167