static void
call_prolog_goal(prolog_goal *g)
{ fid_t fid;
static predicate_t pred = NULL;
int rc;
if ( !pred )
pred = PL_predicate("call", 1, "user");
if ( (fid = PL_open_foreign_frame()) )
{ term_t t = PL_new_term_ref();
term_t vars;
rc = PL_recorded(g->goal, t);
PL_erase(g->goal);
g->goal = 0;
g->state = G_RUNNING;
if ( rc )
{ qid_t qid;
int flags = PL_Q_NORMAL;
if ( g->acknowledge )
{ flags |= PL_Q_CATCH_EXCEPTION;
vars = PL_new_term_ref();
if ( !PL_get_arg(2, t, vars) || /* Goal-Vars */
!PL_get_arg(1, t, t) )
{ PL_warning("ERROR: in_pce_thread: bad goal-vars term");
}
} else
{ vars = 0;
}
if ( (qid = PL_open_query(g->module, flags, pred, t)) )
{ rc = PL_next_solution(qid);
if ( rc )
{ g->state = G_TRUE;
if ( vars )
g->result = PL_record(vars);
} else
{ term_t ex;
if ( g->acknowledge && (ex=PL_exception(qid)) )
{ g->result = PL_record(ex);
g->state = G_ERROR;
} else
{ g->state = G_FALSE;
}
}
PL_cut_query(qid);
} else
PL_warning("ERROR: pce: out of global stack");
}
PL_discard_foreign_frame(fid);
} else
PL_warning("ERROR: pce: out of global stack");
}
static int
set_term(record_t *r, term_t t)
{ if ( *r )
PL_erase(*r);
*r = PL_record(t);
return TRUE;
}
static int
init_prolog_goal(prolog_goal *g, term_t goal, int acknowledge)
{ term_t plain = PL_new_term_ref();
g->module = NULL;
g->acknowledge = acknowledge;
g->state = G_WAITING;
if ( !PL_strip_module(goal, &g->module, plain) )
return FALSE;
if ( !(PL_is_compound(plain) || PL_is_atom(plain)) )
return type_error(goal, "callable");
g->goal = PL_record(plain);
return TRUE;
}
foreign_t add_handler(term_t server, term_t msg, term_t types, term_t goal)
{
my_server_thread s;
lo_method method;
char *pattern, *typespec;
char buffer[256]; // !! space for up to 255 arguments
int rc;
rc = get_server(server,&s)
&& get_msg(msg,&pattern)
&& get_types(types,buffer,256,&typespec);
if (rc) {
record_t goal_record=PL_record(goal);
method = lo_server_add_method(s->s, pattern, typespec, prolog_handler, (void *)goal_record);
}
return rc;
}
static foreign_t
alarm4_gen(time_abs_rel abs_rel, term_t time, term_t callable,
term_t id, term_t options)
{ Event ev;
double t;
module_t m = NULL;
unsigned long flags = 0L;
if ( options )
{ term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
while( PL_get_list(tail, head, tail) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( arity == 1 )
{ term_t arg = PL_new_term_ref();
_PL_get_arg(1, head, arg);
if ( name == ATOM_remove )
{ int t = FALSE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( t )
flags |= EV_REMOVE;
} else if ( name == ATOM_install )
{ int t = TRUE;
if ( !pl_get_bool_ex(arg, &t) )
return FALSE;
if ( !t )
flags |= EV_NOINSTALL;
}
}
}
}
if ( !PL_get_nil(tail) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 4, options, "list");
}
if ( !PL_get_float(time, &t) )
return pl_error(NULL, 0, NULL, ERR_ARGTYPE, 1,
time, "number");
if ( !(ev = allocEvent()) )
return FALSE;
if (abs_rel==TIME_REL)
setTimeEvent(ev, t);
else
setTimeEventAbs(ev,t);
if ( !unify_timer(id, ev) )
{ freeEvent(ev); /* not linked: no need to lock */
return FALSE;
}
ev->flags = flags;
PL_strip_module(callable, &m, callable);
ev->module = m;
ev->goal = PL_record(callable);
if ( !(ev->flags & EV_NOINSTALL) )
{ int rc;
if ( (rc=installEvent(ev)) != TRUE )
{ freeEvent(ev); /* not linked: no need to lock */
return alarm_error(id, rc);
}
}
return TRUE;
}
