Commit | Line | Data |
---|---|---|
920dae64 AT |
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) |