PageRenderTime 40ms CodeModel.GetById 8ms RepoModel.GetById 0ms app.codeStats 0ms

/Lib/ocaml/swig.ml

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