/********************
* fact_values
********************/
static int
fact_values(context_t *ctx, OhmFact *fact, term_t *pl_values)
{
int n = ctx->nfield;
term_t list = PL_new_term_ref();
term_t item = PL_new_term_ref();
#ifdef __STRING_ONLY_FIELDS__
char value[64];
#endif
PL_put_nil(list);
while (n-- > 0) {
#ifdef __STRING_ONLY_FIELDS__
if (!fact_field_value(fact, ctx->fields[n], value, sizeof(value)))
return EINVAL;
PL_put_atom_chars(item, value);
#else
if (!fact_field_term(fact, ctx->fields[n], item))
return EINVAL;
#endif
PL_cons_list(list, item, list);
}
*pl_values = list;
return 0;
}
int
break_multipart(char *formdata, size_t len,
const char *boundary,
int (*func)(const char *name,
size_t namelen,
const char *value,
size_t valuelen,
const char *filename,
void *closure),
void *closure)
{ char *enddata = formdata+len;
while(formdata < enddata)
{ char *header;
char *name, *filename;
char *data = NULL;
char *end;
if ( !(formdata=find_boundary(formdata, enddata, boundary)) ||
!(formdata=next_line(formdata)) )
break;
header = formdata;
/* find the end of the header */
for( ; formdata < enddata; formdata++ )
{ char *end;
if ( (end = looking_at_blank_lines(formdata, 2)) )
{ formdata[0] = '\0';
formdata = data = end;
break;
}
}
if ( !data )
break;
if ( !(name = attribute_of_multipart_header("name", header, data)) )
{ term_t t = PL_new_term_ref();
PL_put_atom_chars(t, "name");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "field", t);
}
filename = attribute_of_multipart_header("filename", header, data);
if ( !(formdata=find_boundary(data, enddata, boundary)) )
break;
end = formdata-1;
if ( end[-1] == '\r' )
end--;
end[0] = '\0';
if ( !(func)(name, strlen(name), data, end-data, filename, closure) )
return FALSE;
}
return TRUE;
}
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;
}
/********************
* fact_field_term
********************/
static int
fact_field_term(OhmFact *fact, char *field, term_t term)
{
GValue *value;
int i;
double d;
char *s;
if ((value = ohm_fact_get(fact, field)) == NULL)
return FALSE;
switch (G_VALUE_TYPE(value)) {
case G_TYPE_INT:
i = g_value_get_int(value);
PL_put_integer(term, i);
break;
case G_TYPE_UINT:
i = g_value_get_uint(value);
PL_put_integer(term, i);
break;
case G_TYPE_LONG:
i = g_value_get_long(value);
PL_put_integer(term, i);
break;
case G_TYPE_ULONG:
i = g_value_get_ulong(value);
PL_put_integer(term, i);
break;
case G_TYPE_DOUBLE:
d = g_value_get_double(value);
PL_put_float(term, d);
break;
case G_TYPE_FLOAT:
d = 1.0 * g_value_get_float(value);
PL_put_float(term, d);
break;
case G_TYPE_STRING:
s = (char *)g_value_get_string(value);
PL_put_atom_chars(term, s);
break;
default:
return FALSE;
}
return TRUE;
}
// handle OSC message by calling the associated Prolog goal
static int prolog_handler(const char *path, const char *types, lo_arg **argv,
int argc, lo_message msg, void *user_data)
{
term_t goal = PL_new_term_ref();
term_t term0 = PL_new_term_refs(3);
term_t term1 = term0+1;
term_t term2 = term0+2;
term_t list;
int i, rc=0;
PL_recorded((record_t)user_data,goal); // retrieve the goal term
PL_put_term(term0,goal); // term_t goal encoded in user_data
PL_put_atom_chars(term1,path);
list = PL_copy_term_ref(term2);
for (i=0; i<argc; i++) {
term_t head=PL_new_term_ref();
term_t tail=PL_new_term_ref();
if (!PL_unify_list(list,head,tail)) PL_fail;
switch (types[i]) {
case 'c': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"char",1,PL_INT,(int)argv[i]->c); break;
case 'i': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"int",1,PL_INT,argv[i]->i); break;
case 'h': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"int64",1,PL_INT64,argv[i]->h); break;
case 'f': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"float",1,PL_FLOAT,(double)argv[i]->f); break;
case 'd': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"double",1,PL_DOUBLE,argv[i]->d); break;
case 's': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"string",1,PL_CHARS,&argv[i]->s); break;
case 'S': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"symbol",1,PL_CHARS,&argv[i]->S); break;
case 'T': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"true",0); break;
case 'F': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"false",0); break;
case 'N': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"nil",0); break;
case 'I': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"inf",0); break;
case 'b': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"blob",0); break;
case 't': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"timetag",2,
PL_INT64,(int64_t)argv[i]->t.sec,
PL_INT64,(int64_t)argv[i]->t.frac);
break;
case 'm': rc=PL_unify_term(head,PL_FUNCTOR_CHARS,"midi",4,
PL_INT,(int)argv[i]->m[0], PL_INT,(int)argv[i]->m[1],
PL_INT,(int)argv[i]->m[2], PL_INT,(int)argv[i]->m[3]);
break;
}
if (!rc) PL_fail;
list=tail;
}
return PL_unify_nil(list) && PL_call_predicate(NULL,PL_Q_NORMAL,call3,term0);
}
int
main(int argc, char **argv)
{ char expression[MAXLINE];
char *e = expression;
char *program = argv[0];
char *plav[2];
int n;
/* combine all the arguments in a single string */
for(n=1; n<argc; n++)
{ if ( n != 1 )
*e++ = ' ';
strcpy(e, argv[n]);
e += strlen(e);
}
/* make the argument vector for Prolog */
plav[0] = program;
plav[1] = NULL;
/* initialise Prolog */
if ( !PL_initialise(1, plav) )
PL_halt(1);
/* Lookup calc/1 and make the arguments and call */
{ predicate_t pred = PL_predicate("calc", 1, "user");
term_t h0 = PL_new_term_refs(1);
int rval;
PL_put_atom_chars(h0, expression);
rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred, h0);
PL_halt(rval ? 0 : 1);
}
return 0;
}
int main()
{
char *ancestor(const char *me)
term_t a0 = PL_new_term_refs(3);
term_t a1 = PL_new_term_refs(3);
term_t a2 = PL_new_term_refs(3);
static predicate_t p;
if ( !p )
p = PL_predicate("pere", 3, "teste.pl");
PL_put_atom_chars(a0, me);
PL_open_query(NULL, PL_Q_NORMAL, p, a0);
PL_open_query(NULL, PL_Q_NORMAL, p, a1);
printf("%s", me);
return 0;
}
// ######################################################################
bool SWIProlog::query(const char *predicate, std::vector<std::string> &args)
{
bool ret=false;
#ifdef HAVE_SWI_PROLOG_H
term_t a0 = PL_new_term_refs(args.size());
predicate_t p = NULL;
p = PL_predicate(predicate, args.size(), NULL);
for(uint i=0; i<args.size(); i++)
{
if (args[i].size() != 0)
PL_put_atom_chars(a0+i, args[i].c_str());
}
qid_t query_id= PL_open_query(NULL, (PL_Q_NORMAL|PL_Q_CATCH_EXCEPTION), p, a0);
ret = PL_next_solution(query_id);
if (ret)
{
//fill in the results in the place holdes
for(uint i=0; i<args.size(); i++)
{
if (args[i].size() == 0)
{
char *data;
PL_get_atom_chars(a0+i, &data);
args[i] = std::string(data);
}
}
}
PL_close_query(query_id);
#else
LINFO("SWI prolog not found");
#endif
return ret;
}
// ######################################################################
bool SWIProlog::consult(const char *filename)
{
bool ret = false;
#ifdef HAVE_SWI_PROLOG_H
term_t a0 = PL_new_term_refs(1);
predicate_t p = NULL;
p = PL_predicate("consult", 1, NULL);
PL_put_atom_chars(a0, filename);
qid_t query_id= PL_open_query(NULL, (PL_Q_NORMAL|PL_Q_CATCH_EXCEPTION), p, a0);
ret = PL_next_solution(query_id);
PL_close_query(query_id);
#else
LINFO("SWI prolog not found");
#endif
return ret;
}
/********************
* swi_list_new
********************/
term_t
swi_list_new(char **items, int n, term_t result)
{
term_t list = PL_new_term_ref();
term_t item = PL_new_term_ref();
if (n < 0) { /* NULL-terminated list, calculate items */
n = 0;
if (items)
while (items[n])
n++;
}
PL_put_nil(list);
while (n-- > 0) {
PL_put_atom_chars(item, items[n]);
PL_cons_list(list, item, list);
}
if (result && PL_is_variable(result))
PL_unify(list, result);
return list;
}
int main(int argc, char **argv)
{
char *program = argv[0];
char *plav[2];
char problem[MAXLINE];
char *p = problem;
/* make the argument vector for Prolog */
plav[0] = program;
plav[1] = NULL;
/* initialize Prolog */
if ( !PL_initialise(1, plav) )
PL_halt(1);
/* initialize the input planning problem */
strcpy(p, argv[1]);
printf("%s\n", p);
/* Lookup solve/1 and make the arguments and call */
predicate_t pred = PL_predicate("solve", 1, "user");
term_t h0 = PL_new_term_refs(1);
int rval;
PL_put_atom_chars(h0, problem);
rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred, h0);
PL_halt(rval ? 0 : 1);
return 0;
}
int
get_raw_form_data(char **data, size_t *lenp, int *must_free)
{ char *method;
char *s;
if ( (method = getenv("REQUEST_METHOD")) &&
strcmp(method, "POST") == 0 )
{ char *lenvar = getenv("CONTENT_LENGTH");
char *q;
long len;
if ( !lenvar )
{ term_t env = PL_new_term_ref();
PL_put_atom_chars(env, "CONTENT_LENGTH");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "environment", env);
}
len = atol(lenvar);
if ( len < 0 )
{ term_t t = PL_new_term_ref();
if ( !PL_put_integer(t, len) )
return FALSE;
return pl_error(NULL, 0, "< 0", ERR_DOMAIN, t, "content_length");
}
if ( lenp )
{ if ( *lenp && (size_t)len > *lenp )
{ term_t t = PL_new_term_ref();
char msg[100];
if ( !PL_put_integer(t, len) )
return FALSE;
sprintf(msg, "> %ld", (long)*lenp);
return pl_error(NULL, 0, msg, ERR_DOMAIN, t, "content_length");
}
*lenp = len;
}
q = s = malloc(len+1);
if ( !q )
return pl_error(NULL, 0, NULL, ERR_RESOURCE, "memory");
while(len > 0)
{ int done;
while( (done=read(fileno(stdin), q, len)) > 0 )
{ q+=done;
len-=done;
}
if ( done < 0 )
{ int e;
term_t obj;
no_data:
e = errno;
obj = PL_new_term_ref();
free(s);
PL_put_nil(obj);
return pl_error(NULL, 0, NULL, ERR_ERRNO, e, "read", "cgi_data", obj);
}
}
if ( len == 0 )
{ *q = '\0';
*data = s;
*must_free = TRUE;
return TRUE;
} else
goto no_data;
} else if ( (s = getenv("QUERY_STRING")) )
{ if ( lenp )
*lenp = strlen(s);
*data = s;
*must_free = FALSE;
return TRUE;
} else
{ term_t env = PL_new_term_ref();
PL_put_atom_chars(env, "QUERY_STRING");
return pl_error(NULL, 0, NULL, ERR_EXISTENCE, "environment", env);
}
}
/*************************
* 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;
}
int
sgml2pl_error(plerrorid id, ...)
{ int rc;
term_t except, formal, swi;
va_list args;
char msgbuf[1024];
char *msg = NULL;
if ( !(except = PL_new_term_ref()) ||
!(formal = PL_new_term_ref()) ||
!(swi = PL_new_term_ref()) )
return FALSE;
va_start(args, id);
switch(id)
{ case ERR_ERRNO:
{ int err = va_arg(args, int);
msg = strerror(err);
switch(err)
{ case ENOMEM:
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "resource_error", 1,
PL_CHARS, "no_memory");
break;
case EACCES:
{ const char *file = va_arg(args, const char *);
const char *action = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "permission_error", 3,
PL_CHARS, action,
PL_CHARS, "file",
PL_CHARS, file);
break;
}
case ENOENT:
{ const char *file = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "existence_error", 2,
PL_CHARS, "file",
PL_CHARS, file);
break;
}
default:
rc = PL_unify_atom_chars(formal, "system_error");
break;
}
break;
}
case ERR_TYPE:
{ const char *expected = va_arg(args, const char*);
term_t actual = va_arg(args, term_t);
if ( PL_is_variable(actual) &&
strcmp(expected, "variable") != 0 )
rc = PL_unify_atom_chars(formal, "instantiation_error");
else
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "type_error", 2,
PL_CHARS, expected,
PL_TERM, actual);
break;
}
case ERR_DOMAIN:
{ const char *expected = va_arg(args, const char*);
term_t actual = va_arg(args, term_t);
if ( PL_is_variable(actual) )
rc = PL_unify_atom_chars(formal, "instantiation_error");
else
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "domain_error", 2,
PL_CHARS, 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,
PL_FUNCTOR_CHARS, "existence_error", 2,
PL_CHARS, type,
PL_TERM, obj);
break;
}
case ERR_FAIL:
{ term_t goal = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "goal_failed", 1,
PL_TERM, goal);
break;
}
case ERR_LIMIT:
{ const char *limit = va_arg(args, const char *);
long maxval = va_arg(args, long);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "limit_exceeded", 2,
PL_CHARS, limit,
PL_LONG, maxval);
break;
}
case ERR_MISC:
{ const char *id = va_arg(args, const char *);
const char *fmt = va_arg(args, const char *);
vsprintf(msgbuf, fmt, args);
msg = msgbuf;
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "miscellaneous", 1,
PL_CHARS, id);
break;
}
default:
assert(0);
}
va_end(args);
if ( rc && msg )
{ term_t predterm = PL_new_term_ref();
term_t msgterm = PL_new_term_ref();
if ( !(predterm = PL_new_term_ref()) ||
!(msgterm = PL_new_term_ref()) ||
!PL_put_atom_chars(msgterm, msg) ||
!PL_unify_term(swi,
PL_FUNCTOR_CHARS, "context", 2,
PL_TERM, predterm,
PL_TERM, msgterm) )
rc = FALSE;
}
if ( rc )
rc = PL_unify_term(except,
PL_FUNCTOR_CHARS, "error", 2,
PL_TERM, formal,
PL_TERM, swi);
if ( rc )
return PL_raise_exception(except);
return FALSE;
}
static int
do_create_process(p_options *info)
{ int pid;
if ( !(pid=vfork()) ) /* child */
{ int fd;
PL_cleanup_fork();
if ( info->detached )
setsid();
if ( info->cwd )
{ if ( chdir(info->cwd) )
{ perror(info->cwd);
exit(1);
}
}
/* stdin */
switch( info->streams[0].type )
{ case std_pipe:
dup2(info->streams[0].fd[0], 0);
close(info->streams[0].fd[1]);
break;
case std_null:
if ( (fd = open("/dev/null", O_RDONLY)) >= 0 )
dup2(fd, 0);
break;
case std_std:
break;
}
/* stdout */
switch( info->streams[1].type )
{ case std_pipe:
dup2(info->streams[1].fd[1], 1);
close(info->streams[1].fd[0]);
break;
case std_null:
if ( (fd = open("/dev/null", O_WRONLY)) >= 0 )
dup2(fd, 1);
break;
case std_std:
break;
}
/* stderr */
switch( info->streams[2].type )
{ case std_pipe:
dup2(info->streams[2].fd[1], 2);
close(info->streams[2].fd[0]);
break;
case std_null:
if ( (fd = open("/dev/null", O_WRONLY)) >= 0 )
dup2(fd, 2);
break;
case std_std:
break;
}
if ( info->envp )
execve(info->exe, info->argv, info->envp);
else
execv(info->exe, info->argv);
perror(info->exe);
exit(1);
} else if ( pid < 0 ) /* parent */
{ term_t exe = PL_new_term_ref();
PL_put_atom_chars(exe, info->exe);
return pl_error(NULL, 0, "fork", ERR_ERRNO, errno, "fork", "process", exe);
} else
{ if ( info->pipes > 0 && info->pid == 0 )
{ IOSTREAM *s;
process_context *pc = PL_malloc(sizeof(*pc));
DEBUG(Sdprintf("Wait on pipes\n"));
memset(pc, 0, sizeof(*pc));
pc->magic = PROCESS_MAGIC;
pc->pid = pid;
if ( info->streams[0].type == std_pipe )
{ close(info->streams[0].fd[0]);
s = open_process_pipe(pc, 0, info->streams[0].fd[1]);
PL_unify_stream(info->streams[0].term, s);
}
if ( info->streams[1].type == std_pipe )
{ close(info->streams[1].fd[1]);
s = open_process_pipe(pc, 1, info->streams[1].fd[0]);
PL_unify_stream(info->streams[1].term, s);
}
if ( info->streams[2].type == std_pipe )
{ close(info->streams[2].fd[1]);
s = open_process_pipe(pc, 2, info->streams[2].fd[0]);
PL_unify_stream(info->streams[2].term, s);
}
return TRUE;
} else if ( info->pipes > 0 )
{ IOSTREAM *s;
if ( info->streams[0].type == std_pipe )
{ close(info->streams[0].fd[0]);
s = Sfdopen(info->streams[0].fd[1], "w");
PL_unify_stream(info->streams[0].term, s);
}
if ( info->streams[1].type == std_pipe )
{ close(info->streams[1].fd[1]);
s = Sfdopen(info->streams[1].fd[0], "r");
PL_unify_stream(info->streams[1].term, s);
}
if ( info->streams[2].type == std_pipe )
{ close(info->streams[2].fd[1]);
s = Sfdopen(info->streams[2].fd[0], "r");
PL_unify_stream(info->streams[2].term, s);
}
}
if ( info->pid )
return PL_unify_integer(info->pid, pid);
return wait_success(info->exe_name, pid);
}
}
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;
}
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;
}