char *
DeRefLink(const char *link, char *buf)
{ char tmp[MAXPATHLEN];
char *f;
int n = 20; /* avoid loop! */
while((f=DeRefLink1(link, tmp)) && n-- > 0)
link = f;
if ( n > 0 )
{ strcpy(buf, link);
return buf;
} else
{ GET_LD
atom_t dom = PL_new_atom("dereference");
atom_t typ = PL_new_atom("symlink");
term_t t;
int rc;
rc = ( (t=PL_new_term_ref()) &&
PL_unify_chars(t, PL_ATOM|REP_FN, -1, link) &&
PL_error(NULL, 0, "too many (>20) levels of symbolic links",
ERR_PERMISSION, dom, typ, t) );
(void)rc;
PL_unregister_atom(dom);
PL_unregister_atom(typ);
return NULL;
}
}
static void
cache_expansion(atom_t alias, atom_t local, atom_t uri)
{ int i;
for(i=(++cache_ptr%PREFIX_EXPAND_ENTRIES); ; i = (i+1)%PREFIX_EXPAND_ENTRIES)
{ prefix_cache *c = &cache[i];
if ( __sync_bool_compare_and_swap(&c->locked, 0, 1) )
{ atom_t olocal = c->local;
atom_t ouri = c->uri;
c->local = 0;
c->alias = 0;
c->uri = 0;
c->generation++;
c->uri = uri;
c->alias = alias;
c->local = local;
if ( olocal) PL_unregister_atom(olocal);
if ( ouri) PL_unregister_atom(ouri);
c->locked = 0;
return;
}
}
}
void
flush_prefix_cache(void)
{ int i;
for( i=0; i<PREFIX_EXPAND_ENTRIES; i++)
{ prefix_cache *c = &cache[i];
while( !__sync_bool_compare_and_swap(&c->locked, 0, 1) )
;
{ atom_t olocal = c->local;
atom_t ouri = c->uri;
c->local = 0;
c->alias = 0;
c->uri = 0;
c->generation++;
if ( olocal) PL_unregister_atom(olocal);
if ( ouri) PL_unregister_atom(ouri);
c->locked = 0;
}
}
}
int
PL_permission_error(const char *op, const char *type, term_t obj)
{ atom_t t = PL_new_atom(type);
atom_t o = PL_new_atom(op);
int rc = PL_error(NULL, 0, NULL, ERR_PERMISSION, o, t, obj);
PL_unregister_atom(t);
PL_unregister_atom(o);
return rc;
}
static void
freeOperatorSymbol(Symbol s)
{ operator *op = s->value;
PL_unregister_atom((atom_t) s->name);
freeHeap(op, sizeof(*op));
}
static int
mp_add_to_form(const char *name, size_t nlen,
const char *value, size_t len,
const char *file, void *closure)
{ term_t head = PL_new_term_ref();
term_t tail = (term_t) closure;
term_t val = PL_new_term_ref();
long vl;
double vf;
int rc;
atom_t aname = 0;
if ( isinteger(value, &vl, len) )
rc = PL_put_integer(val, vl);
else if ( isfloat(value, &vf, len) )
rc = PL_put_float(val, vf);
else
rc = PL_unify_chars(val, PL_ATOM|REP_UTF8, len, value);
rc = ( rc &&
PL_unify_list(tail, head, tail) &&
(aname = PL_new_atom_nchars(nlen, name)) &&
PL_unify_term(head,
PL_FUNCTOR, PL_new_functor(aname, 1),
PL_TERM, val) );
if ( aname )
PL_unregister_atom(aname);
return rc;
}
static void
registerBuiltins(const PL_extension *f)
{ Module m = MODULE_system;
for(; f->predicate_name; f++)
{ Procedure proc;
atom_t name = PL_new_atom(f->predicate_name);
functor_t fdef = lookupFunctorDef(name, f->arity);
PL_unregister_atom(name);
if ( (proc = lookupProcedure(fdef, m)) )
{ Definition def = proc->definition;
set(def, P_FOREIGN|HIDE_CHILDS|P_LOCKED);
if ( f->flags & PL_FA_NOTRACE ) clear(def, TRACE_ME);
if ( f->flags & PL_FA_TRANSPARENT ) set(def, P_TRANSPARENT);
if ( f->flags & PL_FA_NONDETERMINISTIC ) set(def, P_NONDET);
if ( f->flags & PL_FA_VARARGS ) set(def, P_VARARG);
if ( f->flags & PL_FA_CREF ) set(def, P_FOREIGN_CREF);
if ( f->flags & PL_FA_ISO ) set(def, P_ISO);
def->impl.foreign.function = f->function;
createForeignSupervisor(def, f->function);
} else
{ assert(0);
}
}
}
static const uri_component_ranges *
base_ranges(term_t t)
{ atom_t a;
if ( PL_get_atom(t, &a) )
{ base_cache *base = myBase();
if ( base->atom != a )
{ size_t len;
pl_wchar_t *s;
if ( base->atom )
{ PL_unregister_atom(base->atom);
PL_free(base->text);
}
if ( !PL_get_wchars(t, &len, &s, CVT_ATOM|BUF_MALLOC) )
return NULL;
base->atom = a;
PL_register_atom(a);
base->text = s;
parse_uri(&base->ranges, len, s);
}
return &base->ranges;
} else
{ type_error("atom", t);
return NULL;
}
}
int
destroySourceFile(SourceFile sf)
{ DEBUG(MSG_SRCFILE,
Sdprintf("Destroying source file %s\n", PL_atom_chars(sf->name)));
clearSourceAdmin(sf);
LOCK();
if ( sf->magic == SF_MAGIC )
{ SourceFile f;
sf->magic = SF_MAGIC_DESTROYING;
f = deleteHTable(GD->files.table, (void*)sf->name);
assert(f);
PL_unregister_atom(sf->name);
putSourceFileArray(sf->index, NULL);
if ( GD->files.no_hole_before > sf->index )
GD->files.no_hole_before = sf->index;
}
UNLOCK();
unallocSourceFile(sf);
return TRUE;
}
static int
add_to_form(const char *name, size_t nlen,
const char *value, size_t len,
void *closure)
{ term_t head = PL_new_term_ref();
term_t tail = (term_t) closure;
term_t val = PL_new_term_ref();
int rc;
atom_t aname = 0;
if ( isnumber(value, len) )
{ rc = unify_number(val, value, len);
} else
{ rc = PL_unify_chars(val, PL_ATOM|REP_UTF8, len, value);
}
rc = ( rc &&
PL_unify_list(tail, head, tail) &&
(aname = PL_new_atom_nchars(nlen, name)) &&
PL_unify_term(head,
PL_FUNCTOR, PL_new_functor(aname, 1),
PL_TERM, val) );
if ( aname )
PL_unregister_atom(aname);
return rc;
}
int
PL_representation_error(const char *representation)
{ atom_t r = PL_new_atom(representation);
int rc = PL_error(NULL, 0, NULL, ERR_REPRESENTATION, r);
PL_unregister_atom(r);
return rc;
}
int
PL_existence_error(const char *type, term_t actual)
{ atom_t a = PL_new_atom(type);
int rc = PL_error(NULL, 0, NULL, ERR_EXISTENCE, a, actual);
PL_unregister_atom(a);
return rc;
}
int
PL_domain_error(const char *expected, term_t actual)
{ atom_t a = PL_new_atom(expected);
int rc = PL_error(NULL, 0, NULL, ERR_DOMAIN, a, actual);
PL_unregister_atom(a);
return rc;
}
int
PL_resource_error(const char *resource)
{ atom_t r = PL_new_atom(resource);
int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);
PL_unregister_atom(r);
return rc;
}
static void
free_base_cache(void *cache)
{ base_cache *base = cache;
if ( PL_query(PL_QUERY_HALTING) )
return;
if ( base->atom )
{ PL_unregister_atom(base->atom);
PL_free(base->text);
}
PL_free(base);
}
static void
stem_destroy_cache(void *buf)
{ stem_cache *cache = buf;
int i;
for(i=0; i<CACHE_SIZE; i++)
{ if ( cache->stemmers[i].stemmer )
{ PL_unregister_atom(cache->stemmers[i].language);
sb_stemmer_delete(cache->stemmers[i].stemmer);
}
}
PL_free(cache);
}
static void
free_cgi_context(cgi_context *ctx)
{ if ( ctx->stream->upstream )
Sset_filter(ctx->stream, NULL);
else
PL_release_stream(ctx->stream);
if ( ctx->data ) free(ctx->data);
if ( ctx->hook ) PL_erase(ctx->hook);
if ( ctx->request ) PL_erase(ctx->request);
if ( ctx->header ) PL_erase(ctx->header);
if ( ctx->connection ) PL_unregister_atom(ctx->connection);
ctx->magic = 0;
PL_free(ctx);
}
static int
ar_close_entry(void *handle)
{ archive_wrapper *ar = handle;
if ( ar->closed_archive )
{ struct archive *a = ar->archive;
ar->archive = NULL;
ar->entry = NULL;
ar->archive = NULL;
ar->symbol = 0;
archive_read_free(a);
}
if ( ar->status == AR_OPENED_ENTRY )
{ PL_unregister_atom(ar->symbol);
ar->status = AR_CLOSED_ENTRY;
}
return 0;
}
int
destroySourceFile(SourceFile sf)
{ Symbol s;
DEBUG(MSG_SRCFILE,
Sdprintf("Destroying source file %s\n", PL_atom_chars(sf->name)));
clearSourceAdmin(sf);
LOCK();
s = lookupHTable(GD->files.table, (void*)sf->name);
assert(s);
deleteSymbolHTable(GD->files.table, s);
PL_unregister_atom(sf->name);
putSourceFileArray(sf->index, NULL);
if ( GD->files.no_hole_before > sf->index )
GD->files.no_hole_before = sf->index;
UNLOCK();
unallocSourceFile(sf);
return TRUE;
}
static foreign_t
pl_rl_add_history(term_t text)
{ atom_t a;
static atom_t last = 0;
if ( PL_get_atom(text, &a) )
{ if ( a != last )
{ TCHAR *s;
if ( last )
PL_unregister_atom(last);
last = a;
PL_register_atom(last);
PL_get_wchars(text, NULL, &s, CVT_ATOM);
rlc_add_history(PL_current_console(), s);
}
return TRUE;
}
return FALSE;
}
static int unify_value(term_t t, clingo_symbol_t v) {
// NOTE: the clingo_symbol_* functions below only fail
// if applied to the wrong type
// they do not allocate
switch (clingo_symbol_type(v)) {
case clingo_symbol_type_number: {
int number;
clingo_symbol_number(v, &number);
return PL_unify_integer(t, number);
}
case clingo_symbol_type_string: {
char const *str;
clingo_symbol_string(v, &str);
return PL_unify_chars(t, PL_STRING | REP_UTF8, (size_t)-1, str);
}
case clingo_symbol_type_infimum: {
return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_hash1, PL_ATOM, ATOM_inf);
}
case clingo_symbol_type_supremum: {
return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_hash1, PL_ATOM, ATOM_sup);
}
case clingo_symbol_type_function: {
// FIXME: functions can have signs represented as -f(x) in gringo
char const *str;
clingo_symbol_t const *args;
size_t size;
int rc;
clingo_symbol_name(v, &str);
clingo_symbol_arguments(v, &args, &size);
if (size == 0) {
if (!(rc =
PL_unify_chars(t, PL_ATOM | REP_UTF8, (size_t)-1, str))) {
goto out_function;
}
} else {
clingo_symbol_t const *it, *ie;
atom_t name;
term_t arg;
int i;
name = PL_new_atom(str);
if (!(rc = PL_unify_functor(t, PL_new_functor(name, size)))) {
goto out_function;
}
PL_unregister_atom(name);
arg = PL_new_term_ref();
for (i = 1, it = args, ie = it + size; it != ie; ++it, i++) {
_PL_get_arg(i, t, arg);
if (!unify_value(arg, *it)) {
goto out_function;
}
}
}
out_function:
return rc;
}
default:
assert(FALSE);
return FALSE;
}
}
int
outOfStack(void *stack, stack_overflow_action how)
{ GET_LD
Stack s = stack;
const char *msg = "out-of-stack";
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);
if ( s->spare != s->def_spare )
{ Sdprintf("[Thread %d]: %s-overflow: spare=%ld\n"
"Last resource exception:\n",
PL_thread_self(), s->name, (long)s->spare);
print_backtrace_named("exception");
}
LD->trim_stack_requested = TRUE;
LD->exception.processing = TRUE;
LD->outofstack = stack;
switch(how)
{ case STACK_OVERFLOW_THROW:
case STACK_OVERFLOW_RAISE:
{ if ( gTop+5 < gMax )
{ Word p = gTop;
p[0] = FUNCTOR_error2; /* see (*) above */
p[1] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
p[2] = PL_new_atom(s->name);
p[3] = FUNCTOR_resource_error1;
p[4] = ATOM_stack;
gTop += 5;
PL_unregister_atom(p[2]);
*valTermRef(LD->exception.bin) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
freezeGlobal(PASS_LD1);
} else
{ Sdprintf("Out of %s-stack. No room for exception term. Aborting.\n", s->name);
*valTermRef(LD->exception.bin) = ATOM_aborted;
}
exception_term = exception_bin;
if ( how == STACK_OVERFLOW_THROW &&
LD->exception.throw_environment )
{ /* see PL_throw() */
longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
}
return FALSE;
}
default:
assert(0);
fail;
}
}