int
outOfStack(void *stack, stack_overflow_action how)
{ GET_LD
Stack s = stack;
const char *msg = "unhandled stack overflow";
if ( LD->outofstack )
{ Sdprintf("[Thread %d]: failed to recover from %s-overflow\n",
PL_thread_self(), s->name);
print_backtrace_named(msg);
save_backtrace("crash");
print_backtrace_named("crash");
fatalError("Sorry, cannot continue");
return FALSE; /* NOTREACHED */
}
save_backtrace(msg);
LD->trim_stack_requested = TRUE;
LD->exception.processing = TRUE;
LD->outofstack = stack;
switch(how)
{ case STACK_OVERFLOW_THROW:
case STACK_OVERFLOW_RAISE:
{ fid_t fid;
blockGC(0 PASS_LD);
if ( (fid=PL_open_foreign_frame()) )
{ PL_clearsig(SIG_GC);
s->gced_size = 0; /* after handling, all is new */
if ( !PL_unify_term(LD->exception.tmp,
PL_FUNCTOR, FUNCTOR_error2,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_stack,
PL_CHARS, s->name) )
fatalError("Out of stack inside out-of-stack handler");
if ( how == STACK_OVERFLOW_THROW )
{ PL_close_foreign_frame(fid);
unblockGC(0 PASS_LD);
PL_throw(LD->exception.tmp);
warning("Out of %s stack while not in Prolog!?", s->name);
assert(0);
} else
{ PL_raise_exception(LD->exception.tmp);
}
PL_close_foreign_frame(fid);
}
unblockGC(0 PASS_LD);
fail;
}
}
assert(0);
fail;
}
/*************************
* swi_list_length
*************************/
int
swi_list_length(term_t pl_list)
{
fid_t frame;
predicate_t pr_length;
term_t pl_args, pl_length;
int length;
frame = PL_open_foreign_frame();
pr_length = PL_predicate("length", 2, NULL);
pl_args = PL_new_term_refs(2);
pl_length = pl_args + 1;
length = -1;
if (!PL_unify(pl_args, pl_list) ||
!PL_call_predicate(NULL, PL_Q_NORMAL, pr_length, pl_args))
goto out;
PL_get_integer(pl_length, &length);
out:
PL_discard_foreign_frame(frame);
return length;
}
static int
put_write_options(term_t opts_in, write_options *options)
{ GET_LD
term_t newlist = PL_new_term_ref();
term_t precopt = PL_new_term_ref();
fid_t fid = PL_open_foreign_frame();
term_t head = PL_new_term_ref();
term_t tail = PL_copy_term_ref(opts_in);
term_t newhead = PL_new_term_ref();
term_t newtail = PL_copy_term_ref(newlist);
int rc = TRUE;
while(rc && PL_get_list(tail, head, tail))
{ if ( !PL_is_functor(head, FUNCTOR_priority1) )
rc = ( PL_unify_list(newtail, newhead, newtail) &&
PL_unify(newhead, head) );
}
if ( rc )
{ rc = ( PL_unify_list(newtail, head, newtail) &&
PL_unify_functor(head, FUNCTOR_priority1) &&
PL_get_arg(1, head, precopt) &&
PL_unify_nil(newtail) );
}
if ( rc )
{ options->write_options = newlist;
options->prec_opt = precopt;
}
PL_close_foreign_frame(fid);
return rc;
}
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 bool call_function(clingo_location_t loc, char const *name,
clingo_symbol_t const *in, size_t ilen, void *closure,
clingo_symbol_callback_t *cb, void *cb_closure) {
(void)loc;
(void)closure;
static predicate_t pred = 0;
fid_t fid = 0;
qid_t qid = 0;
term_t av;
bool rc = true;
if (!pred) {
pred = PL_predicate("inject_values", 3, "clingo");
}
if (!(fid = PL_open_foreign_frame())) {
rc = false;
clingo_set_error(clingo_error_runtime, "prolog error");
goto out;
}
av = PL_new_term_refs(3);
PL_put_atom_chars(av + 0, name);
if (!(rc = unify_list_from_span(av + 1, in, ilen))) {
clingo_set_error(clingo_error_runtime, "prolog error");
goto out;
}
if ((qid = PL_open_query(NULL, PL_Q_PASS_EXCEPTION, pred, av))) {
while (PL_next_solution(qid)) {
clingo_symbol_t value;
if (!(rc = get_value(av + 2, &value, FALSE))) {
goto out;
}
if (!(rc = cb(&value, 1, cb_closure))) {
goto out;
}
}
if (PL_exception(0)) {
rc = false;
clingo_set_error(clingo_error_runtime, "prolog error");
goto out;
}
}
out:
if (qid) {
PL_close_query(qid);
}
if (fid) {
PL_close_foreign_frame(fid);
}
return rc;
}
int
query_loop(atom_t goal, int loop)
{ GET_LD
int rc;
int clear_stacks = (LD->query == NULL);
do
{ fid_t fid;
qid_t qid = 0;
term_t except = 0;
predicate_t p;
if ( !resetProlog(clear_stacks) )
goto error;
if ( !(fid = PL_open_foreign_frame()) )
goto error;
p = PL_pred(PL_new_functor(goal, 0), MODULE_system);
if ( (qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0)) )
{ rc = PL_next_solution(qid);
} else
{ error:
except = exception_term;
rc = FALSE; /* Won't get any better */
break;
}
if ( !rc && (except = PL_exception(qid)) )
{ atom_t a;
tracemode(FALSE, NULL);
debugmode(DBG_OFF, NULL);
setPrologFlagMask(PLFLAG_LASTCALL);
if ( PL_get_atom(except, &a) && a == ATOM_aborted )
{
#ifdef O_DEBUGGER
callEventHook(PLEV_ABORT);
#endif
printMessage(ATOM_informational, PL_ATOM, ATOM_aborted);
}
}
if ( qid ) PL_close_query(qid);
if ( fid ) PL_discard_foreign_frame(fid);
if ( !except )
break;
} while(loop);
return rc;
}
void default_op_parser(EtalisExecNode* operatorNode,term_t t)
{
assert(operatorNode != NULL);
PL_open_foreign_frame();
operatorNode->leftChild=(EtalisEventNode*)malloc(sizeof(EtalisEventNode));
operatorNode->rightChild=NULL;
operatorNode->condition=NULL;
operatorNode->window_size=0;
term_t _left_event=t;
atom_t _left_event_name;
PL_get_name_arity(_left_event,&_left_event_name,&((operatorNode->leftChild)->event.arity));
strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name));
}
static bool
clearSourceAdmin(SourceFile sf)
{ GET_LD
int rc = FALSE;
fid_t fid = PL_open_foreign_frame();
term_t name = PL_new_term_ref();
static predicate_t pred = NULL;
if ( !pred )
pred = PL_predicate("$clear_source_admin", 1, "system");
PL_put_atom(name, sf->name);
rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, name);
PL_discard_foreign_frame(fid);
return rc;
}
int
query_loop(atom_t goal, int loop)
{ GET_LD
int rc;
int clear_stacks = (LD->query == NULL);
do
{ fid_t fid;
qid_t qid = 0;
term_t except = 0;
predicate_t p;
if ( !resetProlog(clear_stacks) )
goto error;
if ( !(fid = PL_open_foreign_frame()) )
goto error;
p = PL_pred(PL_new_functor(goal, 0), MODULE_system);
if ( (qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0)) )
{ rc = PL_next_solution(qid);
} else
{ error:
except = exception_term;
rc = -1; /* Won't get any better */
break;
}
if ( !rc && (except = PL_exception(qid)) )
{ restore_after_exception(except);
rc = -1;
}
if ( qid ) PL_close_query(qid);
if ( fid ) PL_discard_foreign_frame(fid);
if ( !except )
break;
} while(loop);
return rc;
}
void initpyswipl() {
char *plargs[3];
term_t swipl_load;
fid_t swipl_fid;
/**********************************************************/
/* Initialize the prolog kernel. */
/* The kernel is embedded (linked in) so I am setting the */
/* the startup path to be the current directory. Also, */
/* I'm sending the -q flag to supress the startup banner. */
/**********************************************************/
plargs[0]="./";
plargs[1]="-q";
plargs[2]="-nosignals";
PL_initialise(3,plargs);
/**********************************************************/
/* Load the pyrun predicate. */
/* The pyrun.pl file has to be in the current working */
/* directory. */
/**********************************************************/
swipl_fid=PL_open_foreign_frame();
swipl_load=PL_new_term_ref();
/**********************************************************/
/* Changed by Nathan Denny July 18, 2001 */
/* No longer necessary to include pyrun.pl */
/**********************************************************/
/*PL_chars_to_term("consult('pyrun.pl')", swipl_load);*/
PL_chars_to_term("assert(pyrun(GoalString,BindingList):-(atom_codes(A,GoalString),atom_to_term(A,Goal,BindingList),call(Goal))).", swipl_load);
PL_call(swipl_load,NULL);
PL_discard_foreign_frame(swipl_fid);
/**********************************************************/
/* Call the Python module initializer. */
/**********************************************************/
(void) Py_InitModule("pyswipl",pyswiplMethods);
}
static char *prolog_iniciar(modulo_t *modulo, GHashTable *argumentos) {
prolog_dato_t *prolog = (prolog_dato_t*)modulo->m_dato;
char *av[10];
int ac = 0;
av[ac++] = "prolog";
av[ac++] = "-g";
av[ac++] = "true";
av[ac++] = "-f";
av[ac++] = "none";
if(!PL_initialise(ac, av)) {
PL_halt(-1);
}
prolog->m_fid = PL_open_foreign_frame();
g_hash_table_insert(modulo->m_tabla, PUERTO_SALIDA, 0);
g_hash_table_insert(modulo->m_tabla, PUERTO_ORDEN, 0);
g_hash_table_insert(modulo->m_tabla, PUERTO_PARAMETRO, 0);
return "iniciado";
}
/*************************
* libprolog_load_file
*************************/
int
libprolog_load_file(char *path, int extension)
{
char *loader = extension ? "load_foreign_library" : "consult";
predicate_t pr_loader;
fid_t frame;
qid_t qid;
term_t pl_path;
int success;
/*
* load the given file (native prolog or foreign library)
*
* Notes:
* The prolog predicate consult/1 does not seem to fail or raise an
* exception upon errors. It merely produces an error message and
* tries to continue or gives up processing the input file. In either
* case it succeeds (ie. the goal consult(path) is always proven in
* the prolog sense).
*
* This default behaviour is not acceptable for us. As a library we
* want to let our caller know whether loading was successful or not.
* Otherwise it would be impossible to write even remotely reliable
* applications using this library.
*
* To detect errors we have special prolog glue code that hooks into
* SWI Prologs user:message_hook and lets us know about errors
* (libprolog:mark_error) if loading is active (libprolog:loading).
* Currently the glue code prints an error message but it would be
* fairly easy to collect the errors here and let our caller print
* them if needed. For the time being this glue code lives in policy.pl
* but will eventually be separated out (to libprolog.pl ?).
*/
libprolog_clear_errors();
libprolog_load_start();
frame = PL_open_foreign_frame();
pr_loader = PL_predicate(loader, 1, NULL);
pl_path = PL_new_term_ref();
PL_put_atom_chars(pl_path, path);
qid = PL_open_query(NULL, NORMAL_QUERY_FLAGS, pr_loader, pl_path);
success = PL_next_solution(qid);
if (PL_exception(qid)) {
#if 0
char **exception = collect_exception(qid, &exception);
libprolog_dump_exception(exception);
#endif
success = FALSE;
}
PL_close_query(qid);
PL_discard_foreign_frame(frame);
libprolog_load_done();
if (libprolog_has_errors())
return FALSE;
else
return success;
}
static foreign_t
current_alarms(term_t time, term_t goal, term_t id, term_t status,
term_t matching)
{ Event ev;
term_t next = PL_new_term_ref();
term_t g = PL_new_term_ref();
term_t tail = PL_copy_term_ref(matching);
term_t head = PL_new_term_ref();
term_t av = PL_new_term_refs(4);
pthread_t self = pthread_self();
LOCK();
ev = TheSchedule()->first;
for(; ev; ev = ev->next)
{ atom_t s;
double at;
fid_t fid;
if ( !pthread_equal(self, ev->thread_id) )
continue;
fid = PL_open_foreign_frame();
if ( ev->flags & EV_DONE )
s = ATOM_done;
else if ( ev == TheSchedule()->scheduled )
s = ATOM_next;
else
s = ATOM_scheduled;
if ( !PL_unify_atom(status, s) )
goto nomatch;
PL_recorded(ev->goal, g);
if ( !PL_unify_term(goal,
PL_FUNCTOR, FUNCTOR_module2,
PL_ATOM, PL_module_name(ev->module),
PL_TERM, g) )
goto nomatch;
at = (double)ev->at.tv_sec + (double)ev->at.tv_usec / 1000000.0;
if ( !PL_unify_float(time, at) )
goto nomatch;
if ( !unify_timer(id, ev) )
goto nomatch;
PL_discard_foreign_frame(fid);
if ( !PL_put_float(av+0, at) || /* time */
!PL_recorded(ev->goal, av+1) || /* goal */
!PL_put_variable(av+2) || /* id */
!unify_timer(av+2, ev) ||
!PL_put_atom(av+3, s) || /* status */
!PL_cons_functor_v(next, FUNCTOR_alarm4, av) )
{ PL_close_foreign_frame(fid);
UNLOCK();
return FALSE;
}
if ( PL_unify_list(tail, head, tail) &&
PL_unify(head, next) )
{ continue;
} else
{ PL_close_foreign_frame(fid);
UNLOCK();
return FALSE;
}
nomatch:
PL_discard_foreign_frame(fid);
}
UNLOCK();
return PL_unify_nil(tail);
}
void parse_seq_op_ (EtalisExecNode* operatorNode,term_t t)
{
assert(operatorNode != NULL);
fid_t fid = PL_open_foreign_frame();
/*get components of the operator*/
term_t _level_1 = PL_new_term_refs(2);
term_t _left_event=_level_1;
term_t _right_event=_level_1+1;
atom_t _left_event_name,_right_event_name;
int temp_arity,i=0;
/* TODO check for embedded operators, if operator -> parse right function ; else get atomic events */
PL_get_arg(1,t,_left_event);
PL_get_name_arity(_left_event,&_left_event_name,&temp_arity);
char * tt = PL_atom_chars(_left_event_name);
i=0;
while(strcmp(CEP_LUT_[i].CEP_name,PL_atom_chars(_left_event_name)) != 0 && i<LUT_Size) i++; /* #CONT */
if(i != LUT_Size) /*The operator is found in the CEP_LUT_*/ /* create a temp event */
{
EtalisEventNode* TempEvent = (EtalisEventNode*)calloc(1,sizeof(EtalisEventNode)); /* this temp event is the complex event of the embedded operation */
TempEvent->event.arity = 0;
strcpy(TempEvent->event.name,"temp_"); /* TODO Temp Events */ /* Temp Events have no arguments */
TempEvent->parentNode = operatorNode;
strcpy(TempEvent->parentNode->name,tt);
TempEvent->is_temp = ETALIS_TRUE;
operatorNode->leftChild = TempEvent;
EtalisExecNode* NewNodeRule = (EtalisExecNode*)calloc(1,sizeof(EtalisExecNode)); /* binarization and allocation of the embedded operator */
TempEvent->childNode = NewNodeRule;
NewNodeRule->parentEvent = TempEvent;
TempEvent->trigger = _seq_win_cep_l;
switch (CEP_LUT_[i].CEP_arity)
{
case 1:
break;
case 2:
/* found embedded */
CEP_LUT_[i].parser_func(NewNodeRule,_left_event);
break;
default:
printf("error compiling the rules\n");
}
}
else /* an atomic event has been found */
{
operatorNode->leftChild = (EtalisEventNode*) calloc(1,sizeof(EtalisEventNode));
PL_get_name_arity(_left_event,&_left_event_name,(int *)&((operatorNode->leftChild)->event.arity));
strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name));
operatorNode->leftChild->childNode = NULL;
operatorNode->leftChild->parentNode=operatorNode;
operatorNode->leftChild->is_temp = ETALIS_FALSE;
if (operatorNode->parentEvent->is_temp)
strcat(operatorNode->parentEvent->event.name,operatorNode->leftChild->event.name);
operatorNode->leftChild->trigger = _seq_win_cep_l;
}
PL_get_arg(2,t,_right_event);
operatorNode->rightChild = (EtalisEventNode*) calloc(1,sizeof(EtalisEventNode));
PL_get_name_arity(_right_event,&_right_event_name,(int *)&(operatorNode->rightChild->event.arity));
strcpy(operatorNode->rightChild->event.name,PL_atom_chars(_right_event_name));
operatorNode->rightChild->childNode = NULL;
operatorNode->rightChild->parentNode = operatorNode;
operatorNode->rightChild->is_temp = ETALIS_FALSE;
PL_discard_foreign_frame(fid);
if (operatorNode->parentEvent->is_temp)
{
strcat(operatorNode->parentEvent->event.name,operatorNode->rightChild->event.name);
operatorNode->rightChild->trigger = _seq_win_cep_l;
}
else /* event is latest event in the call list */
{
operatorNode->rightChild->trigger = _seq_batch_r;
}
;
}
/* parse the time window constraints */
void parse_within_op_(EtalisExecNode* operatorNode,term_t t)
{
assert(operatorNode != NULL);
fid_t fid = PL_open_foreign_frame();
EtalisEventNode* opt_t = (EtalisEventNode*)malloc(2*sizeof(EtalisEventNode)); /* memory alignement for L1 cache optimization */
operatorNode->leftChild=opt_t;
memset(operatorNode->leftChild,0,sizeof(EtalisEventNode));
operatorNode->rightChild=opt_t+1;
operatorNode->condition=NULL;
/* get window size */
term_t winsize = PL_new_term_ref();
PL_get_arg(2,t,winsize);
WINDOW_SIZE_T i; /*get window size*/ /* depending on the target processor, this might be an int, a double or a structure. */ /* defined in WINDOW_SIZE_T : e_time.h */
#if PROCESSOR_SUPPORTS_DOUBLE ==1
if (PL_term_type(winsize) == PL_FLOAT)
PL_get_float(winsize,&i);
else
printf("ERROR: window Size must be a floating number ! \n");
#else /* we don't support double accuracy, fall back to int */
PL_get_integer(winsize, &i);
#endif
operatorNode->window_size=i;
#ifdef DEBUG
printf("--- WITHIN Block detected | Window size: %f\n",i);
#endif
/*
term_t _level_1 = PL_new_term_refs(3);
term_t _left_event=_level_1+1;
term_t _right_event=_level_1+2;
atom_t _left_event_name,_right_event_name;
PL_get_arg(1,t,_level_1);
PL_get_arg(1,_level_1,_left_event);
PL_get_arg(2,_level_1,_right_event);
PL_get_name_arity(_left_event,&_left_event_name,(int*)&((operatorNode->leftChild)->event.arity));
PL_get_name_arity(_right_event,&_right_event_name,(int*)&(operatorNode->rightChild->event.arity));
PL_discard_foreign_frame(fid);
strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name));
strcpy(operatorNode->rightChild->event.name,PL_atom_chars(_right_event_name));
}
*/
}
int
PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
{ GET_LD
char msgbuf[50];
Definition caller;
term_t except, formal, swi, msgterm=0;
va_list args;
int do_throw = FALSE;
fid_t fid;
int rc;
if ( exception_term ) /* do not overrule older exception */
return FALSE;
if ( environment_frame )
caller = environment_frame->predicate;
else
caller = NULL;
if ( id == ERR_FILE_OPERATION &&
!truePrologFlag(PLFLAG_FILEERRORS) )
fail;
if ( msg == MSG_ERRNO )
{ if ( errno == EPLEXCEPTION )
return FALSE;
msg = OsError();
}
LD->exception.processing = TRUE; /* allow using spare stack */
if ( !(fid = PL_open_foreign_frame()) )
goto nomem;
except = PL_new_term_ref();
formal = PL_new_term_ref();
swi = PL_new_term_ref();
/* build (ISO) formal part */
va_start(args, id);
switch(id)
{ case ERR_INSTANTIATION:
err_instantiation:
rc = PL_unify_atom(formal, ATOM_instantiation_error);
break;
case ERR_UNINSTANTIATION:
{ int argn = va_arg(args, int);
term_t bound = va_arg(args, term_t);
if ( !msg && argn > 0 )
{ Ssprintf(msgbuf, "%d-%s argument",
argn, argn == 1 ? "st" : argn == 2 ? "nd" : "th");
msg = msgbuf;
}
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_uninstantiation_error1,
PL_TERM, bound);
break;
}
case ERR_TYPE: /* ERR_INSTANTIATION if var(actual) */
{ atom_t expected = va_arg(args, atom_t);
term_t actual = va_arg(args, term_t);
case_type_error:
if ( expected == ATOM_callable )
rewrite_callable(&expected, actual);
if ( PL_is_variable(actual) && expected != ATOM_variable )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, expected,
PL_TERM, actual);
break;
case ERR_PTR_TYPE: /* atom_t, Word */
{ Word ptr;
expected = va_arg(args, atom_t);
ptr = va_arg(args, Word);
actual = PL_new_term_ref();
*valTermRef(actual) = *ptr;
goto case_type_error;
}
}
case ERR_CHARS_TYPE: /* ERR_INSTANTIATION if var(actual) */
{ const char *expected = va_arg(args, const char*);
term_t actual = va_arg(args, term_t);
if ( PL_is_variable(actual) && !streq(expected, "variable") )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_CHARS, expected,
PL_TERM, actual);
break;
}
case ERR_AR_TYPE: /* arithmetic type error */
{ atom_t expected = va_arg(args, atom_t);
Number num = va_arg(args, Number);
term_t actual = PL_new_term_ref();
rc = (_PL_put_number(actual, num) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, expected,
PL_TERM, actual));
break;
}
case ERR_AR_DOMAIN:
{ atom_t domain = va_arg(args, atom_t);
Number num = va_arg(args, Number);
term_t actual = PL_new_term_ref();
rc = (_PL_put_number(actual, num) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_ATOM, domain,
PL_TERM, actual));
break;
}
case ERR_AR_UNDEF:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_undefined);
break;
}
case ERR_AR_OVERFLOW:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_float_overflow);
break;
}
case ERR_AR_UNDERFLOW:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_float_underflow);
break;
}
case ERR_DOMAIN: /* ERR_INSTANTIATION if var(arg) */
{ atom_t domain = va_arg(args, atom_t);
term_t arg = va_arg(args, term_t);
if ( PL_is_variable(arg) )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_ATOM, domain,
PL_TERM, arg);
break;
}
case ERR_RANGE: /* domain_error(range(low,high), arg) */
{ term_t low = va_arg(args, term_t);
term_t high = va_arg(args, term_t);
term_t arg = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_FUNCTOR, FUNCTOR_range2,
PL_TERM, low,
PL_TERM, high,
PL_TERM, arg);
break;
}
case ERR_REPRESENTATION:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_representation_error1,
PL_ATOM, what);
break;
}
{ Definition def; /* shared variables */
Procedure proc;
term_t pred;
case ERR_MODIFY_STATIC_PROC:
proc = va_arg(args, Procedure);
def = proc->definition;
goto modify_static;
case ERR_MODIFY_STATIC_PREDICATE:
def = va_arg(args, Definition);
modify_static:
rc = ((pred = PL_new_term_ref()) &&
unify_definition(MODULE_user, pred, def, 0,
GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, ATOM_modify,
PL_ATOM, ATOM_static_procedure,
PL_TERM, pred));
break;
}
case ERR_MODIFY_THREAD_LOCAL_PROC:
{ Procedure proc = va_arg(args, Procedure);
term_t pred = PL_new_term_ref();
rc = (unify_definition(MODULE_user, pred, proc->definition, 0,
GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, ATOM_modify,
PL_ATOM, ATOM_thread_local_procedure,
PL_TERM, pred));
break;
}
case ERR_UNDEFINED_PROC:
{ Definition def = va_arg(args, Definition);
Definition clr = va_arg(args, Definition);
term_t pred = PL_new_term_ref();
if ( clr )
caller = clr;
rc = (unify_definition(MODULE_user, pred, def, 0, GP_NAMEARITY) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, ATOM_procedure,
PL_TERM, pred));
break;
}
case ERR_PERMISSION_PROC:
{ atom_t op = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
predicate_t pred = va_arg(args, predicate_t);
term_t pi = PL_new_term_ref();
rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, op,
PL_ATOM, type,
PL_TERM, pi));
break;
}
case ERR_NOT_IMPLEMENTED_PROC:
{ const char *name = va_arg(args, const char *);
int arity = va_arg(args, int);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_not_implemented2,
PL_ATOM, ATOM_procedure,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, name,
PL_INT, arity);
break;
}
case ERR_IMPORT_PROC:
{ predicate_t pred = va_arg(args, predicate_t);
atom_t dest = va_arg(args, atom_t);
atom_t old = va_arg(args, atom_t);
term_t pi = PL_new_term_ref();
rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_FUNCTOR, FUNCTOR_import_into1,
PL_ATOM, dest,
PL_ATOM, ATOM_procedure,
PL_TERM, pi));
if ( rc && old )
{ rc = ( (msgterm = PL_new_term_ref()) &&
PL_unify_term(msgterm,
PL_FUNCTOR_CHARS, "already_from", 1,
PL_ATOM, old) );
}
break;
}
case ERR_FAILED:
{ term_t goal = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_failure_error1,
PL_TERM, goal);
break;
}
case ERR_EVALUATION:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, what);
break;
}
case ERR_NOT_EVALUABLE:
{ functor_t f = va_arg(args, functor_t);
term_t actual = PL_new_term_ref();
rc = (put_name_arity(actual, f) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, ATOM_evaluable,
PL_TERM, actual));
break;
}
case ERR_DIV_BY_ZERO:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_zero_divisor);
break;
}
case ERR_PERMISSION:
{ atom_t op = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, op,
PL_ATOM, type,
PL_TERM, obj);
break;
}
case ERR_OCCURS_CHECK:
{ Word p1 = va_arg(args, Word);
Word p2 = va_arg(args, Word);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_occurs_check2,
PL_TERM, pushWordAsTermRef(p1),
PL_TERM, pushWordAsTermRef(p2));
popTermRef();
popTermRef();
break;
}
case ERR_TIMEOUT:
{ atom_t op = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_timeout_error2,
PL_ATOM, op,
PL_TERM, obj);
break;
}
case ERR_EXISTENCE:
{ atom_t type = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, obj);
break;
}
case ERR_EXISTENCE3:
{ atom_t type = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
term_t in = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error3,
PL_ATOM, type,
PL_TERM, obj,
PL_TERM, in);
break;
}
case ERR_FILE_OPERATION:
{ atom_t action = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
term_t file = va_arg(args, term_t);
switch(errno)
{ case EAGAIN:
action = ATOM_lock; /* Hack for file-locking*/
/*FALLTHROUGH*/
case EACCES:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, action,
PL_ATOM, type,
PL_TERM, file);
break;
case EMFILE:
case ENFILE:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_max_files);
break;
#ifdef EPIPE
case EPIPE:
if ( !msg )
msg = "Broken pipe";
/*FALLTHROUGH*/
#endif
default: /* what about the other cases? */
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, file);
break;
}
break;
}
case ERR_STREAM_OP:
{ atom_t action = va_arg(args, atom_t);
term_t stream = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_io_error2,
PL_ATOM, action,
PL_TERM, stream);
break;
}
case ERR_DDE_OP:
{ const char *op = va_arg(args, const char *);
const char *err = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_dde_error2,
PL_CHARS, op,
PL_CHARS, err);
break;
}
case ERR_SHARED_OBJECT_OP:
{ atom_t action = va_arg(args, atom_t);
const char *err = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shared_object2,
PL_ATOM, action,
PL_CHARS, err);
break;
}
case ERR_NOT_IMPLEMENTED: /* non-ISO */
{ const char *what = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_not_implemented2,
PL_ATOM, ATOM_feature,
PL_CHARS, what);
break;
}
case ERR_RESOURCE:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, what);
break;
}
case ERR_SYNTAX:
{ const char *what = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_syntax_error1,
PL_CHARS, what);
break;
}
case ERR_NOMEM:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
}
case ERR_SYSCALL:
{ const char *op = va_arg(args, const char *);
if ( !msg )
msg = op;
switch(errno)
{ case ENOMEM:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
default:
rc = PL_unify_atom(formal, ATOM_system_error);
break;
}
break;
}
case ERR_SHELL_FAILED:
{ term_t cmd = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shell2,
PL_ATOM, ATOM_execute,
PL_TERM, cmd);
break;
}
case ERR_SHELL_SIGNALLED:
{ term_t cmd = va_arg(args, term_t);
int sig = va_arg(args, int);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shell2,
PL_FUNCTOR, FUNCTOR_signal1,
PL_INT, sig,
PL_TERM, cmd);
break;
}
case ERR_SIGNALLED:
{ int sig = va_arg(args, int);
char *signame = va_arg(args, char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_signal2,
PL_CHARS, signame,
PL_INT, sig);
break;
}
case ERR_CLOSED_STREAM:
{ IOSTREAM *s = va_arg(args, IOSTREAM *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, ATOM_stream,
PL_POINTER, s);
do_throw = TRUE;
break;
}
case ERR_BUSY:
{ atom_t type = va_arg(args, atom_t);
term_t mutex = va_arg(args, term_t);
rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_busy2, type, mutex);
break;
}
case ERR_FORMAT:
{ const char *s = va_arg(args, const char*);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format", 1,
PL_CHARS, s);
break;
}
case ERR_FORMAT_ARG:
{ const char *s = va_arg(args, const char*);
term_t arg = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format_argument_type", 2,
PL_CHARS, s,
PL_TERM, arg);
break;
}
case ERR_DUPLICATE_KEY:
{ term_t key = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_duplicate_key1,
PL_TERM, key);
break;
}
default:
assert(0);
}
va_end(args);
/* build SWI-Prolog context term */
if ( rc && (pred || msg || msgterm || caller) )
{ term_t predterm = PL_new_term_ref();
if ( !msgterm )
msgterm = PL_new_term_ref();
if ( pred )
{ rc = PL_unify_term(predterm,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, pred,
PL_INT, arity);
} else if ( caller )
{ rc = unify_definition(MODULE_user, predterm, caller, 0, GP_NAMEARITY);
}
if ( rc && msg )
{ rc = PL_put_atom_chars(msgterm, msg);
}
if ( rc )
rc = PL_unify_term(swi,
PL_FUNCTOR, FUNCTOR_context2,
PL_TERM, predterm,
PL_TERM, msgterm);
}
if ( rc )
rc = PL_unify_term(except,
PL_FUNCTOR, FUNCTOR_error2,
PL_TERM, formal,
PL_TERM, swi);
if ( !rc )
{ nomem:
fatalError("Cannot report error: no memory");
}
if ( do_throw )
rc = PL_throw(except);
else
rc = PL_raise_exception(except);
PL_close_foreign_frame(fid);
return rc;
}
word
pl_current_functor(term_t name, term_t arity, control_t h)
{ GET_LD
atom_t nm = 0;
size_t index;
int i, last=FALSE;
int ar;
fid_t fid;
switch( ForeignControl(h) )
{ case FRG_FIRST_CALL:
if ( PL_get_atom(name, &nm) &&
PL_get_integer(arity, &ar) )
return isCurrentFunctor(nm, ar) ? TRUE : FALSE;
if ( !(PL_is_integer(arity) || PL_is_variable(arity)) )
return PL_error("current_functor", 2, NULL, ERR_DOMAIN,
ATOM_integer, arity);
if ( !(PL_is_atom(name) || PL_is_variable(name)) )
return PL_error("current_functor", 2, NULL, ERR_DOMAIN,
ATOM_atom, name);
index = 1;
break;
case FRG_REDO:
PL_get_atom(name, &nm);
index = ForeignContextInt(h);
break;
case FRG_CUTTED:
default:
succeed;
}
fid = PL_open_foreign_frame();
LOCK();
for(i=MSB(index); !last; i++)
{ size_t upto = (size_t)2<<i;
FunctorDef *b = GD->functors.array.blocks[i];
if ( upto >= GD->functors.highest )
{ upto = GD->functors.highest;
last = TRUE;
}
for(; index<upto; index++)
{ FunctorDef fd = b[index];
if ( fd && fd->arity > 0 && (!nm || nm == fd->name) )
{ if ( PL_unify_atom(name, fd->name) &&
PL_unify_integer(arity, fd->arity) )
{ UNLOCK();
ForeignRedoInt(index+1);
} else
{ PL_rewind_foreign_frame(fid);
}
}
}
}
UNLOCK();
return FALSE;
}
/********************
* pl_fact_exists
********************/
static foreign_t
pl_fact_exists(term_t pl_name,
term_t pl_fields, term_t pl_list, control_t handle)
{
context_t *ctx;
char *name, factname[64];
fid_t frame;
term_t pl_values;
OhmFact *f;
switch (PL_foreign_control(handle)) {
case PL_FIRST_CALL:
if (!PL_is_list(pl_fields) || /*!PL_is_list(pl_list) ||*/
!PL_get_chars(pl_name, &name, CVT_ALL))
PL_fail;
strncpy(factname, name, sizeof(factname));
factname[sizeof(factname)-1] = '\0';
if ((ctx = malloc(sizeof(*ctx))) == NULL)
PL_fail;
memset(ctx, 0, sizeof(*ctx));
if (get_field_names(ctx, pl_fields) != 0) {
free(ctx);
PL_fail;
}
ctx->store = ohm_fact_store_get_fact_store();
ctx->facts = ohm_fact_store_get_facts_by_name(ctx->store, factname);
break;
case PL_REDO:
ctx = PL_foreign_context_address(handle);
break;
case PL_CUTTED:
ctx = PL_foreign_context_address(handle);
goto nomore;
default:
PL_fail;
}
/* XXX TODO: shouldn't we discard the frame here instead of closing them */
frame = PL_open_foreign_frame();
while (ctx->facts != NULL) {
f = (OhmFact *)ctx->facts->data;
ctx->facts = g_slist_next(ctx->facts);
if (!fact_values(ctx, f, &pl_values) && PL_unify(pl_list, pl_values)) {
PL_close_foreign_frame(frame); /* PL_discard_foreign_frame ??? */
PL_retry_address(ctx);
}
PL_rewind_foreign_frame(frame);
}
PL_close_foreign_frame(frame); /* PL_discard_foreign_frame ??? */
nomore:
if (ctx->fields)
free(ctx->fields);
free(ctx);
PL_fail;
}
static HDDEDATA CALLBACK
DdeCallback(UINT type, UINT fmt, HCONV hconv, HSZ hsz1, HSZ hsz2,
HDDEDATA hData, DWORD dwData1, DWORD dwData2)
{
switch(type)
{ case XTYP_CONNECT:
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_connect3, MODULE_dde);
int rval;
PL_put_atom( argv+0, hszToAtom(hsz2)); /* topic */
PL_put_atom( argv+1, hszToAtom(hsz1)); /* service */
PL_put_integer(argv+2, dwData2 ? 1 : 0); /* same instance */
rval = PL_call_predicate(MODULE_dde, TRUE, pred, argv);
PL_discard_foreign_frame(cid);
return (void *)rval;
}
case XTYP_CONNECT_CONFIRM:
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde);
int plhandle;
if ( (plhandle = allocServerHandle(hconv)) >= 0 )
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde);
PL_put_atom( argv+0, hszToAtom(hsz2)); /* topic */
PL_put_atom( argv+1, hszToAtom(hsz1)); /* service */
PL_put_integer(argv+2, plhandle);
PL_call_predicate(MODULE_dde, TRUE, pred, argv);
PL_discard_foreign_frame(cid);
}
return NULL;
}
case XTYP_DISCONNECT:
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(1);
predicate_t pred = PL_pred(FUNCTOR_dde_disconnect1, MODULE_dde);
int plhandle = findServerHandle(hconv);
if ( plhandle >= 0 && plhandle < MAX_CONVERSATIONS )
server_handle[plhandle] = (HCONV)NULL;
PL_put_integer(argv+0, plhandle);
PL_call_predicate(MODULE_dde, TRUE, pred, argv);
PL_discard_foreign_frame(cid);
return NULL;
}
case XTYP_EXECUTE:
{ int plhandle = findServerHandle(hconv);
HDDEDATA rval = DDE_FNOTPROCESSED;
fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_execute3, MODULE_dde);
DEBUG(0, Sdprintf("Got XTYP_EXECUTE request\n"));
PL_put_integer(argv+0, plhandle);
PL_put_atom( argv+1, hszToAtom(hsz1));
unify_hdata( argv+2, hData);
if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) )
rval = (void *) DDE_FACK;
PL_discard_foreign_frame(cid);
DdeFreeDataHandle(hData);
return rval;
}
case XTYP_REQUEST:
{ HDDEDATA data = (HDDEDATA) NULL;
if ( fmt == CF_TEXT )
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(4);
predicate_t pred = PL_pred(FUNCTOR_dde_request4, MODULE_dde);
int plhandle = findServerHandle(hconv);
PL_put_integer( argv+0, plhandle);
PL_put_atom( argv+1, hszToAtom(hsz1)); /* topic */
PL_put_atom( argv+2, hszToAtom(hsz2)); /* item */
PL_put_variable(argv+3);
if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) )
{ char *s;
if ( PL_get_chars(argv+3, &s, CVT_ALL) )
data = DdeCreateDataHandle(ddeInst, s, strlen(s)+1,
0, hsz2, CF_TEXT, 0);
}
PL_discard_foreign_frame(cid);
}
return data;
}
default:
;
}
return (HDDEDATA)NULL;
}
static HDDEDATA CALLBACK
DdeCallback(UINT type, UINT fmt, HCONV hconv, HSZ hsz1, HSZ hsz2,
HDDEDATA hData, DWORD dwData1, DWORD dwData2)
{ GET_LD
DWORD ddeInst = LD->os.dde_instance;
switch(type)
{ case XTYP_CONNECT:
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_connect3, MODULE_dde);
int rval;
if ( unify_hsz(ddeInst, argv+0, hsz2) && /* topic */
unify_hsz(ddeInst, argv+1, hsz1) && /* service */
PL_unify_integer(argv+2, dwData2 ? 1 : 0) ) /* same instance */
{ rval = PL_call_predicate(MODULE_dde, TRUE, pred, argv);
} else
{ rval = FALSE;
}
PL_discard_foreign_frame(cid);
return (void *)(intptr_t)rval;
}
case XTYP_CONNECT_CONFIRM:
{ int plhandle;
if ( (plhandle = allocServerHandle(hconv)) >= 0 )
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde);
if ( unify_hsz(ddeInst, argv+0, hsz2) && /* topic */
unify_hsz(ddeInst, argv+1, hsz1) && /* service */
PL_unify_integer(argv+2, plhandle) )
PL_call_predicate(MODULE_dde, TRUE, pred, argv);
PL_discard_foreign_frame(cid);
}
return NULL;
}
case XTYP_DISCONNECT:
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(1);
predicate_t pred = PL_pred(FUNCTOR_dde_disconnect1, MODULE_dde);
int plhandle = findServerHandle(hconv);
if ( plhandle >= 0 && plhandle < MAX_CONVERSATIONS )
server_handle[plhandle] = (HCONV)NULL;
PL_put_integer(argv+0, plhandle);
PL_call_predicate(MODULE_dde, TRUE, pred, argv);
PL_discard_foreign_frame(cid);
return NULL;
}
case XTYP_EXECUTE:
{ int plhandle = findServerHandle(hconv);
HDDEDATA rval = DDE_FNOTPROCESSED;
fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(3);
predicate_t pred = PL_pred(FUNCTOR_dde_execute3, MODULE_dde);
DEBUG(1, Sdprintf("Got XTYP_EXECUTE request\n"));
PL_put_integer(argv+0, plhandle);
unify_hsz(ddeInst, argv+1, hsz1);
unify_hdata( argv+2, hData);
if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) )
rval = (void *) DDE_FACK;
PL_discard_foreign_frame(cid);
DdeFreeDataHandle(hData);
return rval;
}
case XTYP_REQUEST:
{ HDDEDATA data = (HDDEDATA) NULL;
if ( fmt == CF_UNICODETEXT )
{ fid_t cid = PL_open_foreign_frame();
term_t argv = PL_new_term_refs(4);
predicate_t pred = PL_pred(FUNCTOR_dde_request4, MODULE_dde);
int plhandle = findServerHandle(hconv);
PL_put_integer( argv+0, plhandle);
unify_hsz(ddeInst, argv+1, hsz1); /* topic */
unify_hsz(ddeInst, argv+2, hsz2); /* item */
if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) )
{ wchar_t *s;
size_t len;
/* TBD: error handling */
if ( PL_get_wchars(argv+3, &len, &s, CVT_ALL) )
data = DdeCreateDataHandle(ddeInst,
(unsigned char*) s,
(DWORD)(len+1)*sizeof(wchar_t),
0, hsz2, CF_UNICODETEXT, 0);
}
PL_discard_foreign_frame(cid);
}
return data;
}
default:
;
}
return (HDDEDATA)NULL;
}
static PyObject* pyswipl_run(PyObject* self_Py, PyObject* args_Py) {
char* goalString;
char* answer;
int answerCount;
PyObject* answerList_Py;
PyObject* answerString_Py;
PyObject* bindingList_Py;
PyObject* binding_Py;
term_t swipl_args;
term_t swipl_goalCharList;
term_t swipl_bindingList;
term_t swipl_head;
term_t swipl_list;
predicate_t swipl_predicate;
qid_t swipl_qid;
fid_t swipl_fid;
/**********************************************************/
/* The queryString_C should be a python string represting */
/* the query to be executed on the prolog system. */
/**********************************************************/
if(!PyArg_ParseTuple(args_Py, "s", &goalString))
return NULL;
else {
/**********************************************************/
/* Create a Python list to hold the lists of bindings. */
/**********************************************************/
//if ( answerList_Py != NULL )
// Py_DECREF(answerList_Py);
answerList_Py=PyList_New(0);
/**********************************************************/
/* Open a foreign frame and initialize the term refs. */
/**********************************************************/
swipl_fid=PL_open_foreign_frame();
swipl_head=PL_new_term_ref(); /* Used in unpacking the binding List */
swipl_args=PL_new_term_refs(2); /* The compound term for arguments to run/2 */
swipl_goalCharList=swipl_args; /* Alias for arg 1 */
swipl_bindingList=swipl_args+1; /* Alias for arg 2 */
/**********************************************************/
/* Pack the query string into the argument compund term. */
/**********************************************************/
PL_put_list_chars(swipl_goalCharList,goalString);
/**********************************************************/
/* Generate a predicate to pyrun/2 */
/**********************************************************/
swipl_predicate=PL_predicate("pyrun",2,NULL);
/**********************************************************/
/* Open the query, and iterate through the solutions. */
/**********************************************************/
swipl_qid=PL_open_query(NULL,PL_Q_NORMAL,swipl_predicate, swipl_args);
while(PL_next_solution(swipl_qid)) {
/**********************************************************/
/* Create a Python list to hold the bindings. */
/**********************************************************/
bindingList_Py=PyList_New(0);
/**********************************************************/
/* Step through the bindings and add each to the list. */
/**********************************************************/
swipl_list=PL_copy_term_ref(swipl_bindingList);
while(PL_get_list(swipl_list, swipl_head, swipl_list)) {
PL_get_chars(swipl_head, &answer, CVT_ALL|CVT_WRITE|BUF_RING);
answerString_Py = PyString_FromString(answer);
PyList_Append(bindingList_Py, answerString_Py);
Py_DECREF(answerString_Py);
}
/**********************************************************/
/* Add this binding list to the list of all solutions. */
/**********************************************************/
PyList_Append(answerList_Py, bindingList_Py);
Py_DECREF(bindingList_Py);
}
/**********************************************************/
/* Free this foreign frame... */
/* Added by Nathan Denny, July 18, 2001. */
/* Fixes a bug with running out of global stack when */
/* asserting _lots_ of facts. */
/**********************************************************/
PL_close_query(swipl_qid);
PL_discard_foreign_frame(swipl_fid);
/**********************************************************/
/* Return the list of solutions. */
/**********************************************************/
return answerList_Py;
}
}
static foreign_t
pl_new_order_table(term_t name, term_t options)
{ OrdTable t = malloc(sizeof(ordtable));
term_t tail = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
exact_table(t);
if ( !PL_get_atom(name, &t->name) )
{ free(t);
return error(ERR_INSTANTIATION, "new_order_table/2", 1, name);
}
while(PL_get_list(tail, head, tail))
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_case_insensitive )
{ case_insensitive_table(t);
} else if ( name == ATOM_iso_latin_1 )
{ iso_latin_1_table(t);
} else if ( name == ATOM_iso_latin_1_case_insensitive )
{ iso_latin_1_case_table(t);
} else if ( name == ATOM_copy && arity == 1 )
{ term_t a = PL_new_term_ref();
OrdTable from;
_PL_get_arg(1, head, a);
if ( get_order_table(a, &from) )
{ copy_table(t, from);
} else
{ free(t);
return FALSE;
}
} else if ( arity == 1 )
{ fid_t fid = PL_open_foreign_frame();
term_t a = PL_new_term_ref();
_PL_get_arg(1, head, a);
if ( !parse_set(t, name, a) )
goto err1;
PL_close_foreign_frame(fid);
} else if ( name == ATOM_eq && arity == 2 )
{ fid_t fid = PL_open_foreign_frame();
term_t c = PL_new_term_ref();
int from, to;
if ( !PL_get_arg(1, head, c) || !get_char(c, &from) ||
!PL_get_arg(2, head, c) || !get_char(c, &to) )
{ free(t);
return FALSE;
}
ORD(t, from) = to;
PL_close_foreign_frame(fid);
} else
goto err1;
} else
{ err1:
free(t);
return error(ERR_INSTANTIATION, "new_order_table/2", 2, options);
}
}
if ( !PL_get_nil(tail) )
goto err1;
register_table(t);
PL_succeed;
}
int
pl_error(const char *pred, int arity, const char *msg, int id, ...)
{ fid_t fid;
term_t except, formal, swi;
int rc;
va_list args;
if ( !(fid=PL_open_foreign_frame()) )
return FALSE;
except = PL_new_term_ref();
formal = PL_new_term_ref();
swi = PL_new_term_ref();
va_start(args, id);
switch(id)
{ case ERR_ERRNO:
{ int err = va_arg(args, int);
const char *action = va_arg(args, const char *);
const char *type = va_arg(args, const char *);
term_t object = va_arg(args, term_t);
if ( !object )
object = PL_new_term_ref();
msg = strerror(err);
switch(err)
{ case ENOMEM:
case EAGAIN: /* fork(); might be other resource */
rc = PL_unify_term(formal,
CompoundArg("resource_error", 1),
AtomArg("no_memory"));
break;
case EACCES:
case EPERM:
{ rc = PL_unify_term(formal,
CompoundArg("permission_error", 3),
AtomArg(action),
AtomArg(type),
PL_TERM, object);
break;
}
case ENOENT:
case ESRCH:
{ rc = PL_unify_term(formal,
CompoundArg("existence_error", 2),
AtomArg(type),
PL_TERM, object);
break;
}
default:
rc = PL_unify_atom_chars(formal, "system_error");
break;
}
break;
}
case ERR_ARGTYPE:
{ int argn = va_arg(args, int); /* argument position (unused) */
term_t actual = va_arg(args, term_t);
atom_t expected = PL_new_atom(va_arg(args, const char*));
(void)argn; /* avoid unused warning */
if ( PL_is_variable(actual) && expected != PL_new_atom("variable") )
rc = PL_unify_atom_chars(formal, "instantiation_error");
else
rc = PL_unify_term(formal,
CompoundArg("type_error", 2),
PL_ATOM, expected,
PL_TERM, actual);
break;
}
case ERR_TYPE:
{ term_t actual = va_arg(args, term_t);
atom_t expected = PL_new_atom(va_arg(args, const char*));
if ( PL_is_variable(actual) && expected != PL_new_atom("variable") )
rc = PL_unify_atom_chars(formal, "instantiation_error");
else
rc = PL_unify_term(formal,
CompoundArg("type_error", 2),
PL_ATOM, expected,
PL_TERM, actual);
break;
}
case ERR_DOMAIN:
{ term_t actual = va_arg(args, term_t);
atom_t expected = PL_new_atom(va_arg(args, const char*));
rc = PL_unify_term(formal,
CompoundArg("domain_error", 2),
PL_ATOM, expected,
PL_TERM, actual);
break;
}
case ERR_EXISTENCE:
{ const char *type = va_arg(args, const char *);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
CompoundArg("existence_error", 2),
PL_CHARS, type,
PL_TERM, obj);
break;
}
case ERR_PERMISSION:
{ term_t obj = va_arg(args, term_t);
const char *op = va_arg(args, const char *);
const char *objtype = va_arg(args, const char *);
rc = PL_unify_term(formal,
CompoundArg("permission_error", 3),
AtomArg(op),
AtomArg(objtype),
PL_TERM, obj);
break;
}
case ERR_NOTIMPLEMENTED:
{ const char *op = va_arg(args, const char *);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
CompoundArg("not_implemented", 2),
AtomArg(op),
PL_TERM, obj);
break;
}
case ERR_RESOURCE:
{ const char *res = va_arg(args, const char *);
rc = PL_unify_term(formal,
CompoundArg("resource_error", 1),
AtomArg(res));
break;
}
case ERR_SYNTAX:
{ const char *culprit = va_arg(args, const char *);
rc = PL_unify_term(formal,
CompoundArg("syntax_error", 1),
AtomArg(culprit));
break;
}
default:
assert(0);
rc = FALSE;
}
va_end(args);
if ( rc && (pred || msg) )
{ term_t predterm = PL_new_term_ref();
term_t msgterm = PL_new_term_ref();
if ( pred )
{ rc = PL_unify_term(predterm,
CompoundArg("/", 2),
AtomArg(pred),
IntArg(arity));
}
if ( msg )
{ rc = PL_put_atom_chars(msgterm, msg);
}
if ( rc )
rc = PL_unify_term(swi,
CompoundArg("context", 2),
PL_TERM, predterm,
PL_TERM, msgterm);
}
if ( rc )
rc = PL_unify_term(except,
CompoundArg("error", 2),
PL_TERM, formal,
PL_TERM, swi);
if ( rc )
rc = PL_raise_exception(except);
PL_close_foreign_frame(fid);
return rc;
}