CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
CAMLparam1 (symbol);
CAMLlocal1 (result);
void *sym,*sym2;
#define optsym(n) getsym(handle,unit,n)
char *unit;
void (*entrypoint)(void);
unit = String_val(symbol);
sym = optsym("__frametable");
if (NULL != sym) caml_register_frametable(sym);
sym = optsym("");
if (NULL != sym) caml_register_dyn_global(sym);
sym = optsym("__data_begin");
sym2 = optsym("__data_end");
if (NULL != sym && NULL != sym2)
caml_page_table_add(In_static_data, sym, sym2);
sym = optsym("__code_begin");
sym2 = optsym("__code_end");
if (NULL != sym && NULL != sym2)
caml_page_table_add(In_code_area, sym, sym2);
entrypoint = optsym("__entry");
if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0);
else result = Val_unit;
#undef optsym
CAMLreturn (result);
}
PREFIX void ml_Elm_Transit_Del_Cb(void* data, Elm_Transit* tr)
{
value* v_fun = (value*) data;
caml_callback(*v_fun, (value) tr);
caml_remove_global_root(v_fun);
free(v_fun);
}
void print_ast_node(paranode n) {
CAMLparam0();
CAMLlocal1(v);
v = ((paranode_t*)n)->v;
caml_callback(*ocaml_print_ast_node, v);
CAMLreturn0;
}
value* arith_abs(value* val1)
{
value a;
CLOSURE("arith_abs");
a = caml_callback(*closure, *val1);
return fcl_wrap(a);
}
value* fd2e(value* in)
{
value a;
CLOSURE ("fd2e");
a = caml_callback(*closure, *in);
return fcl_wrap(a);
}
bool check_mems_taint( memorylog_entry* memlog, unsigned int cnt )
{
CAMLparam0();
CAMLlocal4( addrs, ret, v, tupl );
static value *proc_check_mems_taint = NULL;
if ( !proc_check_mems_taint ) {
proc_check_mems_taint = caml_named_value( "check_mems_taint" );
}
addrs = Val_emptylist;
for ( unsigned int i = 0; i < cnt; i ++ ) {
tupl = caml_alloc_tuple( 2 );
Store_field( tupl, 0, caml_copy_nativeint( memlog[i].addr ) );
Store_field( tupl, 1, Val_int( memlog[i].size * 8 ) );
v = caml_alloc_small( 2, 0 );
Field( v, 0 ) = tupl;
Field( v, 1 ) = addrs;
addrs = v;
}
ret = caml_callback( *proc_check_mems_taint, addrs );
CAMLreturnT( bool, Bool_val( ret ) );
}
void OCamlApp::HandleGenericEvent(wxEvent& _evt)
{
wxEvent* event_c = &_evt;
value event_v = Val_abstract(WXCLASS_wxEvent, (wxEvent*) event_c);
value callback_v = ((OCamlCallback*)(_evt.m_callbackUserData))->get();
caml_callback( callback_v, event_v );
}
value* i2e(int in)
{
value a;
CLOSURE ("i2e");
a = caml_callback(*closure, Val_int(in));
return fcl_wrap(a);
}
int function_in_wrapper(void){
printf("Calling back into OCaml...\n");
CAMLlocal2(provided_to_wrapper_v, from_callback);
provided_to_wrapper_v = *caml_named_value("provided_to_wrapper");
from_callback = caml_callback(provided_to_wrapper_v, Val_unit);
return 0;
}
void QSingleFunc::run()
{
// call callback there
caml_leave_blocking_section();
caml_callback(_saved_callback, Val_unit);
caml_enter_blocking_section();
}
void hunpos_tagger_tag(Hunpos hp, int n, void* tokens, const char* (*get_token)(void*,int, int*), void* tags, void (*add_tag)(void*,int,const char*, int*), int* error)
{
CAMLparam0();
CAMLlocal3 (return_value, list, v);
int i;
list = Val_emptylist; /* the [] */
*error = 0;
for(i = 0; i< n; i ++)
{
/* Allocate a cons cell */
v = caml_alloc_small(2, 0);
const char* token = get_token(tokens, i, error);
if (*error != 0) CAMLreturn0;
Store_field (v, 0, caml_copy_string(token) );
Store_field (v, 1, list );
list = v;
}
return_value = caml_callback(*((value*)hp), list);
return_value = Field(return_value,1);
i = 0;
while(return_value != Val_emptylist) {
char* s = String_val(Field(return_value, Tag_cons));
add_tag(tags, i++, s, error);
if (*error != 0) CAMLreturn0;
return_value = Field(return_value, 1);
}
CAMLreturn0;
}
CAMLprim value wrapper_bdd_allsat(value r) {
CAMLparam1(r);
BDD bdd = BDD_val(r);
value* f = caml_named_value("__allsat_handler");
void handler(char* varset, int size) {
CAMLlocal2(tl,v);
int i = 0;
tl = Val_emptylist;
//printf("size : %d\n", size);
for (i = 0 ; i < size; i++) {
//printf("%d : %d\n", i, varset[i]);
// variants in ocaml range from 0 to n-1 !!!
switch (varset[i]) {
case 0 :
v = Val_int(0);
break; // False
case 1 :
v = Val_int(1);
break; // True
case -1 :
v = Val_int(2);
break; // Unknown
default :
caml_failwith("Unknown variable value");
break;
}
if (varset[i] != -1) {
tl = append(tuple(Val_int(i),v),tl);
}
}
caml_callback(*f,tl);
CAMLreturn0;
}
int sundials_ml_residual_wrapper(realtype tt, N_Vector yy, N_Vector yp, N_Vector rr, void* user_data) {
value res = Field(*(value*)user_data, 0);
value num_state = Field(*(value*)user_data, 1);
double* t = (double*)Field(num_state, 0);
*t = tt;
double* old_yp = Caml_ba_array_val(Field(num_state, 1))->data;
double* old_yy = Caml_ba_array_val(Field(num_state, 2))->data;
double* old_rr = Caml_ba_array_val(Field(num_state, 3))->data;
double* new_yy = NV_DATA_S(yy);
double* new_yp = NV_DATA_S(yp);
double* new_rr = NV_DATA_S(rr);
Caml_ba_array_val(Field(num_state, 1))->data = new_yp;
Caml_ba_array_val(Field(num_state, 2))->data = new_yy;
Caml_ba_array_val(Field(num_state, 3))->data = new_rr;
value ret = caml_callback(res, num_state);
/* because we might have triggered a GC cycle, num_state can be invalid */
num_state = Field(*(value*)user_data, 1);
Caml_ba_array_val(Field(num_state, 1))->data = old_yp;
Caml_ba_array_val(Field(num_state, 2))->data = old_yy;
Caml_ba_array_val(Field(num_state, 3))->data = old_rr;
return Int_val (ret);
}
static uint64 on_state_change (utp_callback_arguments *a)
{
CAMLparam0 ();
value *cb;
static value *on_connect_fun = NULL;
static value *on_writable_fun = NULL;
static value *on_eof_fun = NULL;
static value *on_close_fun = NULL;
if (on_connect_fun == NULL) on_connect_fun = caml_named_value ("utp_on_connect");
if (on_writable_fun == NULL) on_writable_fun = caml_named_value ("utp_on_writable");
if (on_eof_fun == NULL) on_eof_fun = caml_named_value ("utp_on_eof");
if (on_close_fun == NULL) on_close_fun = caml_named_value ("utp_on_close");
switch (a->state) {
case UTP_STATE_CONNECT:
cb = on_connect_fun;
break;
case UTP_STATE_WRITABLE:
cb = on_writable_fun;
break;
case UTP_STATE_EOF:
cb = on_eof_fun;
break;
case UTP_STATE_DESTROYING:
UTP_DEBUG ("destroying socket");
cb = on_close_fun;
break;
default:
UTP_DEBUG ("unknown state change: %d", a->state);
cb = NULL;
break;
}
if (cb) caml_callback (*cb, Val_utp_socket (a->socket));
CAMLreturn (0);
}
int sundials_ml_event_wrapper(realtype tt, N_Vector yy, N_Vector yp, realtype *gout, void* user_data) {
value ev = Field(*(value*)user_data, 2);
value ev_state = Field(*(value*)user_data, 3);
double* t = (double*)Field(ev_state, 0);
*t = tt;
double* old_y = Caml_ba_array_val(Field(ev_state, 1))->data;
double* old_yp = Caml_ba_array_val(Field(ev_state, 2))->data;
double* old_gi = Caml_ba_array_val(Field(ev_state, 3))->data;
double* new_y = NV_DATA_S(yy);
double* new_yp = NV_DATA_S(yp);
Caml_ba_array_val(Field(ev_state, 1))->data = new_y;
Caml_ba_array_val(Field(ev_state, 2))->data = new_yp;
Caml_ba_array_val(Field(ev_state, 3))->data = gout;
value ret = caml_callback(ev, ev_state);
/* because we might have triggered a GC cycle, num_state can be invalid */
ev_state = Field(*(value*)user_data, 3);
Caml_ba_array_val(Field(ev_state, 1))->data = old_y;
Caml_ba_array_val(Field(ev_state, 2))->data = old_yp;
Caml_ba_array_val(Field(ev_state, 3))->data = old_gi;
return Int_val (ret);
}
value* e2fd(value* in)
{
value a;
CLOSURE ("e2fd");
a = caml_callback(*closure, *in);
return fcl_wrap(a);
}
value* sorting_sort(value* in)
{
value a;
CLOSURE ("Sorting.sort");
a = caml_callback(*closure, *in);
return fcl_wrap(a);
}
PREFIX Eina_Bool ml_Elm_Naviframe_Item_Pop_Cb(void* data, Elm_Object_Item* it)
{
value* v_fun = (value*) data;
Eina_Bool b = Bool_val(caml_callback(*v_fun, (value) it));
return b;
}
void set_multithreading(int val) {
CAMLparam0();
CAMLlocal1(ocaml_bool);
ocaml_bool = Val_bool(val);
caml_callback(*ocaml_set_multithreading, ocaml_bool);
CAMLreturn0;
}
void val_minmax(value* in, int* min, int* max)
{
value a;
CLOSURE ("Fd.min_max");
a = caml_callback(*closure, *in);
*min = Int_val(Field(a, 0));
*max = Int_val(Field(a, 1));
return;
}
/** Parakeet parameter configuration **/
void set_vectorize(int val) {
CAMLparam0();
CAMLlocal1(ocaml_bool);
ocaml_bool = Val_bool(val);
caml_callback(*ocaml_set_vectorize, ocaml_bool);
CAMLreturn0;
}
bool OCamlApp::OnInit (void){
wxInitAllImageHandlers();
if(initHandler != NULL){
value closure_v = initHandler->get();
caml_callback(closure_v,
Val_abstract(WXCLASS_wxApp, (wxApp*)this));
}
return true;
}
Evas_Event_Flags ml_Elm_Gesture_Event_Cb(void* data, void* event_info)
{
CAMLparam0();
CAMLlocal1(v_event_info);
value* v_fun = data;
v_event_info = copy_voidp(event_info);
caml_callback(*v_fun, v_event_info);
CAMLreturnT(Evas_Event_Flags, EVAS_EVENT_FLAG_ON_HOLD);
}
void proc_end( unsigned int bbl_cnt )
{
CAMLparam0();
value *proc_end_closure = caml_named_value( "proc_end" );
caml_callback( *proc_end_closure, caml_copy_int32( bbl_cnt ) );
CAMLreturn0;
}
paranode get_prim(char* prim_name) {
CAMLparam0();
CAMLlocal1(prim);
// build the var expression
prim = caml_callback(*ocaml_get_prim, caml_copy_string(prim_name));
// build the node and return
CAMLreturnT(paranode, mk_root(prim));
}
void ml_Elm_Gen_Item_Del_Cb_free(void* data, Evas_Object* obj)
{
CAMLparam0();
CAMLlocal1(v_obj);
value* v_class = data;
v_obj = copy_Evas_Object(obj);
caml_callback(Field(*v_class, 4), v_obj);
ml_remove_value(v_class);
CAMLreturn0;
}
static void appsrc_need_data_cb(GstAppSrc *gas, guint length, gpointer user_data)
{
appsrc *as = (appsrc*)user_data;
caml_c_thread_register();
caml_acquire_runtime_system();
caml_callback(as->need_data_cb, Val_int(length));
caml_release_runtime_system();
caml_c_thread_unregister();
}
static inline void notice_ml(void *cb, const char *msg)
{
value v_msg;
/* CR mmottl for mmottl: this is not reliable and can lead to segfaults,
because the runtime lock may already be held (but not usually).
A runtime feature is needed to fully support this. */
caml_leave_blocking_section();
v_msg = make_string(msg);
caml_callback(((np_callback *) cb)->v_cb, v_msg);
caml_enter_blocking_section();
}
value* goals_array_solve_all(value** val, long len)
{
value array, all;
size_t i = 0;
CLOSURE("Gools.Array.solve_all");
// À la barbare
array = caml_alloc(len, 0);
for(; i < len; ++i)
Store_field(array, i, val[i][0]);
all = caml_callback(*closure, array);
return fcl_wrap(all);
}
void QWidget_twin::acceptDrops() {
CAMLparam0();
CAMLlocal3(camlobj,_ans,meth);
printf("Calling QSpinBox::acceptDrops of object = %p\n",this);
GET_CAML_OBJECT(this,the_caml_object)
camlobj = (value) the_caml_object;
meth = caml_get_public_method( camlobj, caml_hash_variant("acceptDrops"));
assert(meth!=0);
_ans = caml_callback(meth, camlobj);;
bool ans = Bool_val(_ans);;
CAMLreturnT(bool,ans);
}
