blob: ca190a25fbaceafaf05a5a01b1be9d669fe1ff7b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
/* -*- C++ -*- */
/***********************************************************************
* director.swg
*
* This file contains support for director classes that proxy
* method calls from C++ to Ocaml extensions.
*
* Modified for Ocaml by : Art Yerkes
* Original Author : Mark Rose (mrose@stm.lbl.gov)
************************************************************************/
%insert(runtime) %{
#ifdef __cplusplus
#include <string>
/* base class for director exceptions */
class SWIG_DIRECTOR_EXCEPTION {
protected:
std::string _msg;
public:
SWIG_DIRECTOR_EXCEPTION(const char* msg="") {
}
const char *getMessage() { return _msg.c_str(); }
virtual ~SWIG_DIRECTOR_EXCEPTION() { }
};
/* type mismatch in the return value from a ocaml method call */
class SWIG_DIRECTOR_TYPE_MISMATCH: public SWIG_DIRECTOR_EXCEPTION {
public:
SWIG_DIRECTOR_TYPE_MISMATCH(const char* msg="") {
_msg = "Swig director type mismatch: ";
_msg += msg;
failwith((char *)_msg.c_str());
}
};
/* any ocaml exception that occurs during a director method call */
class SWIG_DIRECTOR_METHOD_EXCEPTION: public SWIG_DIRECTOR_EXCEPTION { };
/* simple thread abstraction for pthreads or win32 */
#ifdef __THREAD__
#define __PTHREAD__
#if defined(_WIN32) || defined(__WIN32__)
#define pthread_mutex_lock EnterCriticalSection
#define pthread_mutex_unlock LeaveCriticalSection
#define pthread_mutex_t CRITICAL_SECTION
#define MUTEX_INIT(var) CRITICAL_SECTION var
#else
#include <pthread.h>
#define MUTEX_INIT(var) pthread_mutex_t var = PTHREAD_MUTEX_INITIALIZER
#endif
#endif
/* director base class */
class __DIRECTOR__ {
private:
/* pointer to the wrapped ocaml object */
value _self;
/* flag indicating whether the object is owned by ocaml or c++ */
mutable int _disown;
/* shared flag for breaking recursive director calls */
static int _up;
#ifdef __PTHREAD__
/* locks for sharing the _up flag in a threaded environment */
static pthread_mutex_t _mutex_up;
static int _mutex_active;
static pthread_t _mutex_thread;
#endif
/* reset the _up flag once the routing direction has been determined */
#ifdef __PTHREAD__
void __clear_up() const {
__DIRECTOR__::_up = 0;
__DIRECTOR__::_mutex_active = 0;
pthread_mutex_unlock(&_mutex_up);
}
#else
void __clear_up() const {
__DIRECTOR__::_up = 0;
}
#endif
public:
/* the default constructor should not be called */
__DIRECTOR__() {
assert(0);
}
/* wrap a ocaml object, optionally taking ownership */
__DIRECTOR__(value self, int disown): _self(self), _disown(disown) {
}
/* discard our reference at destruction */
virtual ~__DIRECTOR__() {
__disown();
// Disown is safe here because we're just divorcing a reference that
// points to us.
}
/* return a pointer to the wrapped ocaml object */
value __get_self() const {
return _self;
}
/* get the _up flag to determine if the method call should be routed
* to the c++ base class or through the wrapped ocaml object
*/
#ifdef __PTHREAD__
int __get_up() const {
if (__DIRECTOR__::_mutex_active) {
if (pthread_equal(__DIRECTOR__::_mutex_thread, pthread_self())) {
int up = _up;
__clear_up();
return up;
}
}
return 0;
}
#else
int __get_up() const {
int up = _up;
_up = 0;
return up;
}
#endif
/* set the _up flag if the next method call should be directed to
* the c++ base class rather than the wrapped ocaml object
*/
#ifdef __PTHREAD__
void __set_up() const {
pthread_mutex_lock(&__DIRECTOR__::_mutex_up);
__DIRECTOR__::_mutex_thread = pthread_self();
__DIRECTOR__::_mutex_active = 1;
__DIRECTOR__::_up = 1;
}
#else
void __set_up() const {
__DIRECTOR__::_up = 1;
}
#endif
/* acquire ownership of the wrapped ocaml object (the sense of "disown"
* is from ocaml) */
void __disown() const {
assert(_self);
if (!_disown) {
_disown=1;
callback(*caml_named_value("caml_obj_disown"),_self);
}
}
};
int __DIRECTOR__::_up = 0;
#ifdef __PTHREAD__
MUTEX_INIT(__DIRECTOR__::_mutex_up);
pthread_t __DIRECTOR__::_mutex_thread;
int __DIRECTOR__::_mutex_active = 0;
#endif
#endif /* __cplusplus */
%}
%insert(mli) %{
val new_derived_object:
(c_obj -> c_obj) ->
(c_obj -> string -> c_obj -> c_obj) ->
c_obj -> c_obj
%}
%insert(ml) %{
let new_derived_object cfun x_class args =
begin
let get_object ob =
match !ob with
None ->
raise (NotObject C_void)
| Some o -> o in
let class_fun class_f ob_r =
(fun meth args -> class_f (get_object ob_r) meth args) in
let ob_ref = ref None in
let new_class = class_fun x_class ob_ref in
let obj =
cfun (match args with
C_list argl ->
(C_list ((C_obj new_class) :: argl))
| a -> (C_list [ C_director_core
(C_obj new_class,ob_ref) ; a ])) in
ob_ref := Some obj ;
obj
end
%}
|
