static void registerWakeup(Word name, Word value ARG_LD) { Word wake; Word tail = valTermRef(LD->attvar.tail); assert(gTop+6 <= gMax && tTop+4 <= tMax); wake = gTop; gTop += 4; wake[0] = FUNCTOR_wakeup3; wake[1] = needsRef(*name) ? makeRef(name) : *name; wake[2] = needsRef(*value) ? makeRef(value) : *value; wake[3] = ATOM_nil; if ( *tail ) { Word t; /* Non-empty list */ deRef2(tail, t); TrailAssignment(t); *t = consPtr(wake, TAG_COMPOUND|STG_GLOBAL); TrailAssignment(tail); /* on local stack! */ *tail = makeRef(wake+3); DEBUG(1, Sdprintf("appended to wakeup\n")); } else /* empty list */ { Word head = valTermRef(LD->attvar.head); assert(isVar(*head)); TrailAssignment(head); /* See (*) */ *head = consPtr(wake, TAG_COMPOUND|STG_GLOBAL); TrailAssignment(tail); *tail = makeRef(wake+3); LD->alerted |= ALERT_WAKEUP; DEBUG(1, Sdprintf("new wakeup\n")); } }
static int compare_term_refs(const void *a, const void *b, void *arg) { const int *ip1 = a; const int *ip2 = b; order_term_refs *ctx = arg; GET_LDARG(ctx->ld); Word p = valTermRef(ctx->av[*ip1*2]); Word q = valTermRef(ctx->av[*ip2*2]); assert(!isRef(*p)); assert(!isRef(*q)); return (*p<*q ? -1 : *p>*q ? 1 : 0); }
int PL_get_attr__LD(term_t t, term_t a ARG_LD) { Word p = valTermRef(t); deRef(p); if ( isAttVar(*p) ) { Word ap = valPAttVar(*p); *valTermRef(a) = makeRef(ap); /* reference, so we can assign */ succeed; } fail; }
static int dict_ordered(Word data, int count, int ex ARG_LD) { int ordered = TRUE; Word n1, n2; if ( count > 0 ) { data++; /* skip to key */ deRef2(data, n1); if ( !is_key(*n1) ) return -1; } for(; count > 1; count--, data += 2, n1=n2) { deRef2(data+2, n2); if ( !is_key(*n2) ) return -1; if ( *n1 < *n2 ) continue; if ( *n1 > *n2 ) ordered = FALSE; if ( *n1 == *n2 ) { if ( ex ) { term_t t = PL_new_term_ref(); *valTermRef(t) = linkVal(n1); PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, t); } return -2; } } return ordered; }
int dict_order_term_refs(term_t *av, int *indexes, int count ARG_LD) { order_term_refs ctx; ctx.ld = LD; ctx.av = av; sort_r(indexes, count, sizeof(int), compare_term_refs, &ctx); if ( count > 1 ) { word k = *valTermRef(av[indexes[0]*2]); int i; for(i=1; i<count; i++) { word k2 = *valTermRef(av[indexes[i]*2]); if ( k == k2 ) return i; k = k2; } } return 0; }
static int get_create_dict_ex(term_t t, term_t dt ARG_LD) { Word p = valTermRef(t); deRef(p); if ( isTerm(*p) ) { Functor f = valueTerm(*p); FunctorDef fd = valueFunctor(f->definition); if ( fd->name == ATOM_dict && fd->arity%2 == 1 ) /* does *not* validate ordering */ { *valTermRef(dt) = *p; return TRUE; } } if ( PL_get_dict_ex(t, 0, dt, DICT_GET_ALL) ) { assert(isTerm(*valTermRef(dt))); return TRUE; } return PL_type_error("dict", t); }
static int get_dict_ex(term_t t, Word dp, int ex ARG_LD) { Word p = valTermRef(t); deRef(p); if ( isTerm(*p) ) { Functor f = valueTerm(*p); FunctorDef fd = valueFunctor(f->definition); if ( fd->name == ATOM_dict && fd->arity%2 == 1 ) /* does *not* validate ordering */ { *dp = *p; return TRUE; } } if ( !ex ) return FALSE; PL_type_error("dict", t); return FALSE; }
Assuming Tree is a term x(Key, Left, Right, ...), find a (sub) node for operating on Value. If a node with Key == Value is found Arg is unified to 1. If such a node is not found Arg is 2 if the tree must get a new left-node and 3 if it must get a new right-node. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static PRED_IMPL("$btree_find_node", 4, btree_find_node, 0) { PRED_LD Word t, k; Functor f; functor_t fd; int arity; k = valTermRef(A1); t = valTermRef(A2); deRef(k); deRef(t); if ( !isTerm(*t) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_btree, A2); f = valueTerm(*t); fd = f->definition; arity = arityFunctor(fd); if ( arity < 3 ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_btree, A2); for(;;) { Word a = &f->arguments[0];
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; }
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; } }