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