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); }