static foreign_t
archive_next_header(term_t archive, term_t name)
{ archive_wrapper *ar;
int rc;
if ( !get_archive(archive, &ar) )
return FALSE;
if ( ar->status == AR_NEW_ENTRY )
archive_read_data_skip(ar->archive);
if ( ar->status == AR_OPENED_ENTRY )
return PL_permission_error("next_header", "archive", archive);
while ( (rc=archive_read_next_header(ar->archive, &ar->entry)) == ARCHIVE_OK )
{ if ( PL_unify_wchars(name, PL_ATOM, -1,
archive_entry_pathname_w(ar->entry)) )
{ ar->status = AR_NEW_ENTRY;
return TRUE;
}
if ( PL_exception(0) )
return FALSE;
}
if ( rc == ARCHIVE_EOF )
return FALSE; /* simply at the end */
return archive_error(ar);
}
static foreign_t
pl_pce_dispatch(void)
{ pceDispatch(-1, 250);
if ( PL_handle_signals() == -1 || PL_exception(0) )
return FALSE;
return TRUE;
}
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;
}
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;
}
/*************************
* 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
cgi_property(term_t cgi, term_t prop)
{ IOSTREAM *s;
cgi_context *ctx;
term_t arg = PL_new_term_ref();
atom_t name;
int arity;
int rc = TRUE;
if ( !get_cgi_stream(cgi, &s, &ctx) )
return FALSE;
if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
{ rc = type_error(prop, "cgi_property");
goto out;
}
_PL_get_arg(1, prop, arg);
if ( name == ATOM_request )
{ if ( ctx->request )
rc = unify_record(arg, ctx->request);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_header )
{ if ( ctx->header )
rc = unify_record(arg, ctx->header);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_id )
{ rc = PL_unify_int64(arg, ctx->id);
} else if ( name == ATOM_client )
{ rc = PL_unify_stream(arg, ctx->stream);
} else if ( name == ATOM_transfer_encoding )
{ rc = PL_unify_atom(arg, ctx->transfer_encoding);
} else if ( name == ATOM_connection )
{ rc = PL_unify_atom(arg, ctx->connection ? ctx->connection : ATOM_close);
} else if ( name == ATOM_content_length )
{ if ( ctx->transfer_encoding == ATOM_chunked )
rc = PL_unify_int64(arg, ctx->chunked_written);
else
rc = PL_unify_int64(arg, ctx->datasize - ctx->data_offset);
} else if ( name == ATOM_header_codes )
{ if ( ctx->data_offset > 0 )
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->data_offset, ctx->data);
else /* incomplete header */
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->datasize, ctx->data);
} else if ( name == ATOM_state )
{ atom_t state;
switch(ctx->state)
{ case CGI_HDR: state = ATOM_header; break;
case CGI_DATA: state = ATOM_data; break;
case CGI_DISCARDED: state = ATOM_discarded; break;
default:
assert(0);
}
rc = PL_unify_atom(arg, state);
} else
{ rc = existence_error(prop, "cgi_property");
}
out:
if ( !PL_release_stream(s) )
{ if ( PL_exception(0) )
PL_clear_exception();
}
return rc;
}
static foreign_t pl_clingo_solve(term_t ccontrol, term_t assumptions,
term_t Show, term_t Model, control_t h) {
int rc = TRUE;
solve_state *state = NULL;
clingo_symbolic_literal_t *assump_vec = NULL;
int control = PL_foreign_control(h);
if (control == PL_FIRST_CALL) {
size_t alen = 0;
if (!(state = malloc(sizeof(*state)))) {
rc = PL_resource_error("memory");
goto out;
}
memset(state, 0, sizeof(*state));
if (!(rc = get_clingo(ccontrol, &state->ctl))) {
goto out;
}
if (PL_skip_list(assumptions, 0, &alen) != PL_LIST) {
rc = PL_type_error("list", assumptions);
goto out;
}
term_t tail = PL_copy_term_ref(assumptions);
term_t head = PL_new_term_ref();
if (!(assump_vec = malloc(sizeof(*assump_vec) * alen))) {
rc = PL_resource_error("memory");
goto out;
}
memset(assump_vec, 0, sizeof(*assump_vec) * alen);
for (size_t i = 0; PL_get_list(tail, head, tail); i++) {
if (!(rc = clingo_status(get_assumption(head, &assump_vec[i])))) {
goto out;
}
}
if (!(rc = clingo_status(clingo_control_solve_iteratively(
state->ctl->control, assump_vec, alen, &state->it)))) {
goto out;
}
} else {
state = PL_foreign_context_address(h);
}
while (control != PL_PRUNED) {
clingo_model_t *model;
if (!(rc = clingo_status(
clingo_solve_iteratively_next(state->it, &model)))) {
goto out;
}
if (model) {
int show;
if (!(rc = get_show_map(Show, &show))) {
goto out;
}
if (!(rc = unify_model(Model, show, model))) {
if (PL_exception(0)) {
goto out;
}
} else {
PL_retry_address(state);
state = NULL;
break;
}
} else {
rc = FALSE;
break;
}
}
out:
if (assump_vec) {
free(assump_vec);
}
if (state) {
if (state->it) {
clingo_solve_iteratively_close(state->it);
}
free(state);
}
return rc;
}
