cairo_bool_t
plcairo_extend_to_term(cairo_extend_t extend,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_extend_t: %d ---> term: 0x%lx", extend, t);
if ( !ATOM_cairo_extend_none )
{
ATOM_cairo_extend_none = PL_new_atom("CAIRO_EXTEND_NONE");
ATOM_cairo_extend_repeat = PL_new_atom("CAIRO_EXTEND_REPEAT");
ATOM_cairo_extend_reflect = PL_new_atom("CAIRO_EXTEND_REFLECT");
ATOM_cairo_extend_pad = PL_new_atom("CAIRO_EXTEND_PAD");
}
if ( extend == CAIRO_EXTEND_NONE )
{ PL_put_atom(t0, ATOM_cairo_extend_none);
}
else if ( extend == CAIRO_EXTEND_REPEAT )
{ PL_put_atom(t0, ATOM_cairo_extend_repeat);
}
else if ( extend == CAIRO_EXTEND_REFLECT )
{ PL_put_atom(t0, ATOM_cairo_extend_reflect);
}
else if ( extend == CAIRO_EXTEND_PAD )
{ PL_put_atom(t0, ATOM_cairo_extend_pad);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
static int parse_quasi_quotations(ReadData _PL_rd ARG_LD) {
if (_PL_rd->qq_tail) {
term_t av;
int rc;
if (!PL_unify_nil(_PL_rd->qq_tail))
return FALSE;
if (!_PL_rd->quasi_quotations) {
if ((av = PL_new_term_refs(2)) && PL_put_term(av + 0, _PL_rd->qq) &&
#if __YAP_PROLOG__
PL_put_atom(av + 1, YAP_SWIAtomFromAtom(_PL_rd->module->AtomOfME)) &&
#else
PL_put_atom(av + 1, _PL_rd->module->name) &&
#endif
PL_cons_functor_v(av, FUNCTOR_dparse_quasi_quotations2, av)) {
term_t ex;
rc = callProlog(MODULE_system, av + 0, PL_Q_CATCH_EXCEPTION, &ex);
if (rc)
return TRUE;
_PL_rd->exception = ex;
_PL_rd->has_exception = TRUE;
}
return FALSE;
} else
return TRUE;
} else if (_PL_rd->quasi_quotations) /* user option, but no quotes */
{
return PL_unify_nil(_PL_rd->quasi_quotations);
} else
return TRUE;
}
cairo_bool_t
plcairo_ps_level_to_term(cairo_ps_level_t level,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_ps_level_t: %d ---> term: 0x%lx", level, t);
if ( !ATOM_cairo_ps_level_2 )
{
ATOM_cairo_ps_level_2 = PL_new_atom("CAIRO_PS_LEVEL_2");
ATOM_cairo_ps_level_3 = PL_new_atom("CAIRO_PS_LEVEL_3");
}
if ( level == CAIRO_PS_LEVEL_2 )
{ PL_put_atom(t0, ATOM_cairo_ps_level_2);
}
else if ( level == CAIRO_PS_LEVEL_3 )
{ PL_put_atom(t0, ATOM_cairo_ps_level_3);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
static int
defOperator(Module m, atom_t name, int type, int priority, int force)
{ GET_LD
Symbol s;
operator *op;
int t = (type & OP_MASK); /* OP_PREFIX, ... */
DEBUG(7, Sdprintf(":- op(%d, %s, %s) in module %s\n",
priority,
PL_atom_chars(operatorTypeToAtom(type)),
PL_atom_chars(name),
PL_atom_chars(m->name)));
assert(t>=OP_PREFIX && t<=OP_POSTFIX);
if ( !force && !SYSTEM_MODE )
{ if ( name == ATOM_comma ||
(name == ATOM_bar && ((t&OP_MASK) != OP_INFIX ||
(priority < 1001 && priority != 0))) )
{ GET_LD
atom_t action = (name == ATOM_comma ? ATOM_modify : ATOM_create);
term_t t = PL_new_term_ref();
PL_put_atom(t, name);
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
action, ATOM_operator, t);
}
}
LOCK();
if ( !m->operators )
m->operators = newOperatorTable(8);
if ( (s = lookupHTable(m->operators, (void *)name)) )
{ op = s->value;
} else if ( priority < 0 )
{ UNLOCK(); /* already inherited: do not change */
return TRUE;
} else
{ op = allocHeapOrHalt(sizeof(*op));
op->priority[OP_PREFIX] = -1;
op->priority[OP_INFIX] = -1;
op->priority[OP_POSTFIX] = -1;
op->type[OP_PREFIX] = OP_INHERIT;
op->type[OP_INFIX] = OP_INHERIT;
op->type[OP_POSTFIX] = OP_INHERIT;
}
op->priority[t] = priority;
op->type[t] = (priority >= 0 ? type : OP_INHERIT);
if ( !s )
{ PL_register_atom(name);
addHTable(m->operators, (void *)name, op);
}
UNLOCK();
return TRUE;
}
static foreign_t
uri_query_components(term_t string, term_t list)
{ pl_wchar_t *s;
size_t len;
if ( PL_get_wchars(string, &len, &s, CVT_ATOM|CVT_STRING|CVT_LIST) )
{ return unify_query_string_components(list, len, s);
} else if ( PL_is_list(list) )
{ term_t tail = PL_copy_term_ref(list);
term_t head = PL_new_term_ref();
term_t nv = PL_new_term_refs(2);
charbuf out;
int rc;
fill_flags();
init_charbuf(&out);
while( PL_get_list(tail, head, tail) )
{ atom_t fname;
int arity;
if ( PL_is_functor(head, FUNCTOR_equal2) ||
PL_is_functor(head, FUNCTOR_pair2) )
{ _PL_get_arg(1, head, nv+0);
_PL_get_arg(2, head, nv+1);
} else if ( PL_get_name_arity(head, &fname, &arity) && arity == 1 )
{ PL_put_atom(nv+0, fname);
_PL_get_arg(1, head, nv+1);
} else
{ free_charbuf(&out);
return type_error("name_value", head);
}
if ( out.here != out.base )
add_charbuf(&out, '&');
if ( !add_encoded_term_charbuf(&out, nv+0, ESC_QNAME) )
{ free_charbuf(&out);
return FALSE;
}
add_charbuf(&out, '=');
if ( !add_encoded_term_charbuf(&out, nv+1, ESC_QVALUE) )
{ free_charbuf(&out);
return FALSE;
}
}
rc = PL_unify_wchars(string, PL_ATOM, out.here-out.base, out.base);
free_charbuf(&out);
return rc;
} else
{ return PL_get_wchars(string, &len, &s,
CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION);
}
return FALSE;
}
static int
put_name_arity(term_t t, functor_t f)
{ GET_LD
FunctorDef fdef = valueFunctor(f);
term_t a;
if ( (a=PL_new_term_refs(2)) )
{ PL_put_atom(a+0, fdef->name);
return (PL_put_integer(a+1, fdef->arity) &&
PL_cons_functor(t, FUNCTOR_divide2, a+0, a+1));
}
return FALSE;
}
int
printMessage(atom_t severity, ...)
{ GET_LD
wakeup_state wstate;
term_t av;
predicate_t pred = PROCEDURE_print_message2;
va_list args;
int rc;
if ( ++LD->in_print_message >= OK_RECURSIVE*3 )
fatalError("printMessage(): recursive call\n");
if ( !saveWakeup(&wstate, TRUE PASS_LD) )
{ LD->in_print_message--;
return FALSE;
}
av = PL_new_term_refs(2);
va_start(args, severity);
PL_put_atom(av+0, severity);
rc = PL_unify_termv(av+1, args);
va_end(args);
if ( rc )
{ if ( isDefinedProcedure(pred) && LD->in_print_message <= OK_RECURSIVE )
{ rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION,
pred, av);
} else if ( LD->in_print_message <= OK_RECURSIVE*2 )
{ Sfprintf(Serror, "Message: ");
if ( ReadingSource )
Sfprintf(Serror, "%s:%d ",
PL_atom_chars(source_file_name), (int)source_line_no);
rc = PL_write_term(Serror, av+1, 1200, 0);
Sfprintf(Serror, "\n");
} else /* in_print_message == 2 */
{ Sfprintf(Serror, "printMessage(): recursive call\n");
}
}
restoreWakeup(&wstate PASS_LD);
LD->in_print_message--;
return rc;
}
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;
}
static int
get_exe(term_t exe, p_options *info)
{ int arity;
term_t arg = PL_new_term_ref();
if ( !PL_get_name_arity(exe, &info->exe_name, &arity) )
return type_error(exe, "callable");
PL_put_atom(arg, info->exe_name);
#ifdef __WINDOWS__
if ( !PL_get_wchars(arg, NULL, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC) )
return FALSE;
if ( !win_command_line(exe, arity, info->exe, &info->cmdline) )
return FALSE;
#else /*__WINDOWS__*/
if ( !PL_get_chars(arg, &info->exe, CVT_ATOM|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
return FALSE;
if ( !(info->argv = PL_malloc((arity+2)*sizeof(char*))) )
return PL_resource_error("memory");
memset(info->argv, 0, (arity+2)*sizeof(char*));
if ( !(info->argv[0] = PL_malloc(strlen(info->exe)+1)) )
return PL_resource_error("memory");
strcpy(info->argv[0], info->exe);
{ int i;
for(i=1; i<=arity; i++)
{ _PL_get_arg(i, exe, arg);
if ( !PL_get_chars(arg, &info->argv[i],
CVT_ATOMIC|CVT_EXCEPTION|BUF_MALLOC|REP_FN) )
return FALSE;
}
info->argv[i] = NULL;
}
#endif /*__WINDOWS__*/
return TRUE;
}
cairo_bool_t
plcairo_pattern_type_to_term(cairo_pattern_type_t pattern_type,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_pattern_type_t: %d ---> term: 0x%lx", pattern_type, t);
if ( !ATOM_cairo_pattern_type_solid )
{
ATOM_cairo_pattern_type_solid = PL_new_atom("CAIRO_PATTERN_TYPE_SOLID");
ATOM_cairo_pattern_type_surface = PL_new_atom("CAIRO_PATTERN_TYPE_SURFACE");
ATOM_cairo_pattern_type_linear = PL_new_atom("CAIRO_PATTERN_TYPE_LINEAR");
ATOM_cairo_pattern_type_radial = PL_new_atom("CAIRO_PATTERN_TYPE_RADIAL");
ATOM_cairo_pattern_type_mesh = PL_new_atom("CAIRO_PATTERN_TYPE_MESH");
ATOM_cairo_pattern_type_raster_source = PL_new_atom("CAIRO_PATTERN_TYPE_RASTER_SOURCE");
}
if ( pattern_type == CAIRO_PATTERN_TYPE_SOLID )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_solid);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_SURFACE )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_surface);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_LINEAR )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_linear);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_RADIAL )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_radial);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_MESH )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_mesh);
}
else if ( pattern_type == CAIRO_PATTERN_TYPE_RASTER_SOURCE )
{ PL_put_atom(t0, ATOM_cairo_pattern_type_raster_source);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
cairo_bool_t
plcairo_filter_to_term(cairo_filter_t filter,
term_t t)
{
term_t t0 = PL_new_term_ref();
PLCAIRO_debug(" cairo_filter_t: %d ---> term: 0x%lx", filter, t);
if ( !ATOM_cairo_filter_fast )
{
ATOM_cairo_filter_fast = PL_new_atom("CAIRO_FILTER_FAST");
ATOM_cairo_filter_good = PL_new_atom("CAIRO_FILTER_GOOD");
ATOM_cairo_filter_best = PL_new_atom("CAIRO_FILTER_BEST");
ATOM_cairo_filter_nearest = PL_new_atom("CAIRO_FILTER_NEAREST");
ATOM_cairo_filter_bilinear = PL_new_atom("CAIRO_FILTER_BILINEAR");
ATOM_cairo_filter_gaussian = PL_new_atom("CAIRO_FILTER_GAUSSIAN");
}
if ( filter == CAIRO_FILTER_FAST )
{ PL_put_atom(t0, ATOM_cairo_filter_fast);
}
else if ( filter == CAIRO_FILTER_GOOD )
{ PL_put_atom(t0, ATOM_cairo_filter_good);
}
else if ( filter == CAIRO_FILTER_BEST )
{ PL_put_atom(t0, ATOM_cairo_filter_best);
}
else if ( filter == CAIRO_FILTER_NEAREST )
{ PL_put_atom(t0, ATOM_cairo_filter_nearest);
}
else if ( filter == CAIRO_FILTER_BILINEAR )
{ PL_put_atom(t0, ATOM_cairo_filter_bilinear);
}
else if ( filter == CAIRO_FILTER_GAUSSIAN )
{ PL_put_atom(t0, ATOM_cairo_filter_gaussian);
}
else
{ g_assert_not_reached();
}
return PL_unify(t, t0);
}
word
pl_write_term3(term_t stream, term_t term, term_t opts)
{ GET_LD
bool quoted = FALSE;
bool ignore_ops = FALSE;
int numbervars = -1; /* not set */
bool portray = FALSE;
term_t gportray = 0;
bool bqstring = truePrologFlag(PLFLAG_BACKQUOTED_STRING);
int charescape = -1; /* not set */
atom_t mname = ATOM_user;
atom_t attr = ATOM_nil;
atom_t blobs = ATOM_nil;
int priority = 1200;
bool partial = FALSE;
bool cycles = TRUE;
term_t varnames = 0;
int local_varnames;
IOSTREAM *s = NULL;
write_options options;
int rc;
memset(&options, 0, sizeof(options));
options.spacing = ATOM_standard;
if ( !scan_options(opts, 0, ATOM_write_option, write_term_options,
"ed, &ignore_ops, &numbervars, &portray, &gportray,
&charescape, &options.max_depth, &mname,
&bqstring, &attr, &priority, &partial, &options.spacing,
&blobs, &cycles, &varnames) )
fail;
if ( attr == ATOM_nil )
{ options.flags |= LD->prolog_flag.write_attributes;
} else
{ int mask = writeAttributeMask(attr);
if ( !mask )
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
options.flags |= mask;
}
if ( blobs != ATOM_nil )
{ int mask = writeBlobMask(blobs);
if ( mask < 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
options.flags |= mask;
}
if ( priority < 0 || priority > OP_MAXPRIORITY )
{ term_t t = PL_new_term_ref();
PL_put_integer(t, priority);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_operator_priority, t);
}
switch( options.spacing )
{ case ATOM_standard:
case ATOM_next_argument:
break;
default:
{ term_t t = PL_new_term_ref();
PL_put_atom(t, options.spacing);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_spacing, t);
}
}
options.module = lookupModule(mname);
if ( charescape == TRUE ||
(charescape == -1
#ifndef __YAP_PROLOG__
&& True(options.module, M_CHARESCAPE)
#endif
) )
options.flags |= PL_WRT_CHARESCAPES;
if ( gportray )
{ options.portray_goal = gportray;
if ( !put_write_options(opts, &options) ||
!PL_qualify(options.portray_goal, options.portray_goal) )
return FALSE;
portray = TRUE;
}
if ( numbervars == -1 )
numbervars = (portray ? TRUE : FALSE);
if ( quoted ) options.flags |= PL_WRT_QUOTED;
if ( ignore_ops ) options.flags |= PL_WRT_IGNOREOPS;
if ( numbervars ) options.flags |= PL_WRT_NUMBERVARS;
if ( portray ) options.flags |= PL_WRT_PORTRAY;
if ( bqstring ) options.flags |= PL_WRT_BACKQUOTED_STRING;
if ( !cycles ) options.flags |= PL_WRT_NO_CYCLES;
local_varnames = (varnames && False(&options, PL_WRT_NUMBERVARS));
BEGIN_NUMBERVARS(local_varnames);
if ( varnames )
{ if ( (rc=bind_varnames(varnames PASS_LD)) )
options.flags |= PL_WRT_VARNAMES;
else
goto out;
}
if ( !(rc=getTextOutputStream(stream, &s)) )
goto out;
options.out = s;
if ( !partial )
PutOpenToken(EOF, s); /* reset this */
if ( (options.flags & PL_WRT_QUOTED) && !(s->flags&SIO_REPPL) )
{ s->flags |= SIO_REPPL;
rc = writeTopTerm(term, priority, &options);
s->flags &= ~SIO_REPPL;
} else
{ rc = writeTopTerm(term, priority, &options);
}
out:
END_NUMBERVARS(local_varnames);
return (!s || streamStatus(s)) && rc;
}
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;
}
bool
scan_options(term_t options, int flags, atom_t optype,
const opt_spec *specs, ...)
{ GET_LD
va_list args;
const opt_spec *s;
optvalue values[MAXOPTIONS];
term_t list = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
term_t val = PL_new_term_ref();
int n;
if ( truePrologFlag(PLFLAG_ISO) )
flags |= OPT_ALL;
va_start(args, specs);
for( n=0, s = specs; s->name; s++, n++ )
values[n].ptr = va_arg(args, void *);
va_end(args);
while ( PL_get_list(list, head, list) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_equals && arity == 2 )
{ _PL_get_arg(1, head, tmp);
if ( !PL_get_atom(tmp, &name) )
goto itemerror;
_PL_get_arg(2, head, val);
} else if ( arity == 1 )
{ _PL_get_arg(1, head, val);
} else if ( arity == 0 )
PL_put_atom(val, ATOM_true);
} else if ( PL_is_variable(head) )
{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
} else
{ itemerror:
return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
}
for( n=0, s = specs; s->name; n++, s++ )
{ if ( s->name == name )
{ switch((s->type & OPT_TYPE_MASK))
{ case OPT_BOOL:
{ int bval;
if ( !PL_get_bool_ex(val, &bval) )
return FALSE;
*values[n].b = bval;
break;
}
case OPT_INT:
{ if ( !PL_get_integer_ex(val, values[n].i) )
return FALSE;
break;
}
case OPT_LONG:
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
break;
}
case OPT_NATLONG:
{ if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
if ( *(values[n].l) <= 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_one, val);
break;
}
case OPT_SIZE:
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].sz = (size_t)-1;
else if ( !PL_get_size_ex(val, values[n].sz) )
return FALSE;
break;
}
case OPT_DOUBLE:
{ if ( !PL_get_float_ex(val, values[n].f) )
return FALSE;
break;
}
case OPT_STRING:
{ char *str;
if ( !PL_get_chars(val, &str, CVT_ALL|CVT_EXCEPTION) ) /* copy? */
return FALSE;
*values[n].s = str;
break;
}
case OPT_ATOM:
{ atom_t a;
if ( !PL_get_atom_ex(val, &a) )
return FALSE;
*values[n].a = a;
break;
}
#ifdef O_LOCALE
case OPT_LOCALE:
{ PL_locale *l;
PL_locale **lp = values[n].ptr;
if ( !getLocaleEx(val, &l) )
return FALSE;
*lp = l;
break;
}
#endif
case OPT_TERM:
{ *values[n].t = val;
val = PL_new_term_ref(); /* can't reuse anymore */
break;
}
default:
assert(0);
fail;
}
break;
}
}
if ( !s->name && (flags & OPT_ALL) )
goto itemerror;
}
if ( !PL_get_nil(list) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
succeed;
}
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);
}
