Lib/ocaml/swig.ml

   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)