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