static int
unify_mapped_code(term_t to, int ti)
{ switch(ti)
{ case ORD_BREAK:
return PL_unify_atom(to, ATOM_break);
case ORD_IGNORE:
return PL_unify_atom(to, ATOM_ignore);
case ORD_TAG:
return PL_unify_atom(to, ATOM_tag);
default:
return PL_unify_integer(to, ti);
}
}
static int
wait_for_pid(pid_t pid, term_t code, wait_options *opts)
{ pid_t p2;
int status;
if ( opts->has_timeout && opts->timeout == 0.0 )
{ if ( (p2=waitpid(pid, &status, WNOHANG)) == pid )
return unify_exit_status(code, status);
else if ( p2 == 0 )
return PL_unify_atom(code, ATOM_timeout);
else
{ term_t PID;
error:
return ((PID = PL_new_term_ref()) &&
PL_put_integer(PID, pid) &&
pl_error(NULL, 0, "waitpid", ERR_ERRNO,
errno, "wait", "process", PID));
}
}
for(;;)
{ if ( (p2=waitpid(pid, &status, 0)) == pid )
return unify_exit_status(code, status);
if ( p2 == -1 && errno == EINTR )
{ if ( PL_handle_signals() < 0 )
return FALSE;
} else
{ goto error;
}
}
}
static int
wait_for_pid(pid_t pid, term_t code, wait_options *opts)
{ HANDLE *h;
if ( (h=find_process_from_pid(pid, "process_wait")) )
{ ULONG rc;
DWORD timeout;
int wc;
if ( opts->has_timeout )
timeout = (DWORD)(opts->timeout * 1000.0);
else
timeout = INFINITE;
if ( !(wc=wait_process_handle(h, &rc, timeout)) )
return FALSE;
if ( wc == WP_TIMEOUT )
return PL_unify_atom(code, ATOM_timeout);
unregister_process(pid);
return PL_unify_term(code,
PL_FUNCTOR, FUNCTOR_exit1,
PL_LONG, rc);
} else
{ return FALSE;
}
}
static foreign_t
pl_gethostname(term_t name)
{ static atom_t hname;
if ( !hname )
{ char buf[256];
if ( gethostname(buf, sizeof(buf)) == 0 )
{ struct addrinfo *res;
struct addrinfo hints;
memset(&hints, 0, sizeof(hints));
hints.ai_flags = AI_CANONNAME;
if ( getaddrinfo(buf, NULL, &hints, &res) == 0 )
{ hname = PL_new_atom(res->ai_canonname);
freeaddrinfo(res);
}
else
hname = PL_new_atom(buf);
} else
{ return nbio_error(h_errno, TCP_HERRNO);
}
}
return PL_unify_atom(name, hname);
}
word
pl_dwim_match(term_t a1, term_t a2, term_t mm)
{ char *s1, *s2;
atom_t type;
if ( PL_get_chars(a1, &s1, CVT_ALL|BUF_RING) &&
PL_get_chars(a2, &s2, CVT_ALL|BUF_RING) &&
(type = dwimMatch(s1, s2)) &&
PL_unify_atom(mm, type) )
succeed;
fail;
}
foreign_t
pl_lowercase(term_t u, term_t l)
{ char *copy;
char *s, *q;
atom_t la;
if ( !PL_get_atom_chars(u, &s) )
return PL_warning("lowercase/2: instantiation fault");
copy = malloc(strlen(s)+1);
for( q=copy; *s; q++, s++)
*q = (isupper(*s) ? tolower(*s) : *s);
*q = '\0';
la = PL_new_atom(copy);
free(copy);
return PL_unify_atom(l, la);
}
static foreign_t
pl_gethostname(term_t name)
{ static atom_t hname;
if ( !hname )
{ char buf[256];
if ( gethostname(buf, sizeof(buf)) == 0 )
{ struct hostent *he;
if ( (he = gethostbyname(buf)) )
hname = PL_new_atom(he->h_name);
else
hname = PL_new_atom(buf);
} else
{ return nbio_error(h_errno, TCP_HERRNO);
}
}
return PL_unify_atom(name, hname);
}
static foreign_t
pl_compare_strings(term_t ord, term_t t1, term_t t2, term_t result)
{ OrdTable ot;
char *s1, *s2;
size_t len;
int rval;
unsigned int flags = (CVT_ATOM|CVT_STRING|CVT_LIST|BUF_RING|CVT_EXCEPTION);
if ( !get_order_table(ord, &ot) )
return error(ERR_INSTANTIATION, "compare_strings/4", 1, ord);
if ( !PL_get_nchars(t1, &len, &s1, flags) )
return FALSE;
if ( !PL_get_nchars(t2, &len, &s2, flags) )
return FALSE;
rval = compare_strings(s1, s2, len, ot);
return PL_unify_atom(result,
rval == 0 ? ATOM_eq :
rval < 0 ? ATOM_lt :
ATOM_gt);
}
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;
}
static foreign_t
turtle_read_string(term_t C0, term_t Stream, term_t C, term_t Value)
{ int c;
charbuf b;
IOSTREAM *in;
int endlen = 1;
if ( !PL_get_integer(C0, &c) )
return type_error(C0, "code");
if ( c != '"' )
return FALSE;
if ( !PL_get_stream_handle(Stream, &in) )
return FALSE;
init_charbuf(&b);
c = Sgetcode(in);
if ( c == '"' )
{ c = Sgetcode(in);
if ( c == '"' ) /* """...""" */
{ endlen = 3;
c = Sgetcode(in);
} else
{ PL_release_stream(in);
return (PL_unify_integer(C, c) &&
PL_unify_atom(Value, ATOM_));
}
}
for(;;c = Sgetcode(in))
{ if ( c == -1 )
{ free_charbuf(&b);
PL_release_stream(in);
return syntax_error("eof_in_string", in);
} else if ( c == '"' )
{ int count = 1;
for(count=1; count<endlen; )
{ if ( (c=Sgetcode(in)) == '"' )
count++;
else
break;
}
if ( count == endlen )
{ int rc;
c = Sgetcode(in);
rc = (PL_unify_integer(C, c) &&
PL_unify_wchars(Value, PL_ATOM, b.here-b.base, b.base));
free_charbuf(&b);
PL_release_stream(in);
return rc;
}
while(count-- > 0)
add_charbuf(&b, '"');
add_charbuf(&b, c);
} else if ( c == '\\' )
{ int esc;
c = Sgetcode(in);
if ( !string_escape(in, c, &esc) )
{ free_charbuf(&b);
PL_release_stream(in);
return FALSE;
}
add_charbuf(&b, esc);
} else
{ add_charbuf(&b, c);
}
}
}
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;
}
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 int
get_ftm(term_t t, ftm *ftm)
{ GET_LD
term_t tmp = PL_new_term_ref();
int date9;
memset(ftm, 0, sizeof(*ftm));
if ( (date9=PL_is_functor(t, FUNCTOR_date9)) )
{ if ( get_int_arg (1, t, tmp, &ftm->tm.tm_year) &&
get_int_arg (2, t, tmp, &ftm->tm.tm_mon) &&
get_int_arg (3, t, tmp, &ftm->tm.tm_mday) &&
get_int_arg (4, t, tmp, &ftm->tm.tm_hour) &&
get_int_arg (5, t, tmp, &ftm->tm.tm_min) &&
get_float_arg(6, t, tmp, &ftm->sec) &&
get_voff_arg (7, t, tmp, &ftm->utcoff) &&
get_tz_arg (8, t, tmp, &ftm->tzname) &&
get_dst_arg (9, t, tmp, &ftm->isdst) )
{ double fp, ip;
ftm->tm.tm_isdst = (ftm->isdst == -2 ? -1 : ftm->isdst);
fixup:
fp = modf(ftm->sec, &ip);
if ( fp < 0.0 )
{ fp += 1.0;
ip -= 1.0;
}
ftm->tm.tm_sec = (int)ip;
ftm->tm.tm_year -= 1900; /* 1900 based */
ftm->tm.tm_mon--; /* 0-based */
if ( ftm->utcoff == NO_UTC_OFFSET )
{ if ( ftm->tm.tm_isdst < 0 ) /* unknown DST */
{ int offset;
if ( mktime(&ftm->tm) == (time_t)-1 )
return PL_representation_error("dst");
ftm->flags |= HAS_WYDAY;
offset = tz_offset();
if ( ftm->tm.tm_isdst > 0 )
offset -= 3600;
ftm->utcoff = offset;
if ( date9 ) /* variable */
{ _PL_get_arg(7, t, tmp);
if ( !PL_unify_integer(tmp, ftm->utcoff) )
return FALSE;
} else
{ ftm->utcoff = offset;
}
}
if ( ftm->isdst == -2 )
{ ftm->isdst = ftm->tm.tm_isdst;
_PL_get_arg(9, t, tmp);
if ( ftm->isdst < 0 )
{ if ( !PL_unify_atom(tmp, ATOM_minus) )
return FALSE;
} else
{ if ( !PL_unify_bool(tmp, ftm->isdst) )
return FALSE;
}
}
if ( !ftm->tzname )
{ ftm->tzname = tz_name_as_atom(ftm->isdst);
_PL_get_arg(8, t, tmp);
if ( PL_is_variable(tmp) &&
!PL_unify_atom(tmp, ftm->tzname) )
return FALSE;
}
}
succeed;
}
} else if ( PL_is_functor(t, FUNCTOR_date3) )
{ if ( get_int_arg (1, t, tmp, &ftm->tm.tm_year) &&
get_int_arg (2, t, tmp, &ftm->tm.tm_mon) &&
get_int_arg (3, t, tmp, &ftm->tm.tm_mday) )
{ ftm->tm.tm_isdst = -1;
ftm->utcoff = NO_UTC_OFFSET;
goto fixup;
}
}
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_time, t);
}
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);
}
static foreign_t
archive_header_prop(term_t archive, term_t field)
{ archive_wrapper *ar;
functor_t prop;
if ( !get_archive(archive, &ar) )
return FALSE;
if ( !PL_get_functor(field, &prop) )
return PL_type_error("compound", field);
if ( ar->status != AR_NEW_ENTRY )
return PL_permission_error("access", "archive_entry", archive);
if ( prop == FUNCTOR_filetype1 )
{ __LA_MODE_T type = archive_entry_filetype(ar->entry);
atom_t name;
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
switch(type&AE_IFMT)
{ case AE_IFREG: name = ATOM_file; break;
case AE_IFLNK: name = ATOM_link; break;
case AE_IFSOCK: name = ATOM_socket; break;
case AE_IFCHR: name = ATOM_character_device; break;
case AE_IFBLK: name = ATOM_block_device; break;
case AE_IFDIR: name = ATOM_directory; break;
case AE_IFIFO: name = ATOM_fifo; break;
default:
return PL_unify_integer(arg, (type&AE_IFMT));
}
return PL_unify_atom(arg, name);
} else if ( prop == FUNCTOR_mtime1 )
{ time_t stamp = archive_entry_mtime(ar->entry);
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_float(arg, (double)stamp);
} else if ( prop == FUNCTOR_size1 )
{ int64_t size = archive_entry_size(ar->entry);
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_int64(arg, size);
} else if ( prop == FUNCTOR_link_target1 )
{ __LA_MODE_T type = archive_entry_filetype(ar->entry);
const wchar_t *target = NULL;
switch(type&AE_IFMT)
{ case AE_IFLNK:
target = archive_entry_symlink_w(ar->entry);
break;
}
if ( target )
{ term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
return PL_unify_wchars(arg, PL_ATOM, (size_t)-1, target);
}
return FALSE;
} else if ( prop == FUNCTOR_format1 )
{ const char *s = archive_format_name(ar->archive);
if ( s )
{ char lwr[50];
char *o;
term_t arg = PL_new_term_ref();
_PL_get_arg(1, field, arg);
for(o=lwr; *s && o < lwr+sizeof(lwr); )
*o++ = tolower(*s++);
*o = '\0';
return PL_unify_atom_chars(arg, lwr);
}
}
return PL_domain_error("archive_header_property", field);
}
