char * varName(term_t t, char *name) { CACHE_REGS CELL *adr = (CELL *)Yap_GetFromSlot(t); if (IsAttVar(adr)) { Ssprintf(name, "_D%ld", (CELL)adr - (CELL)H0); } else { Ssprintf(name, "_%ld", (CELL)adr - (CELL)H0); } return name; }
static char * vName(Word adr) { GET_LD static char name[32]; deRef(adr); if (adr > (Word) lBase) Ssprintf(name, "_L%ld", (Word)adr - (Word)lBase); else Ssprintf(name, "_G%ld", (Word)adr - (Word)gBase); return name; }
static char * findHome(const char *symbols, int argc, const char **argv) { const char *home = NULL; char envbuf[MAXPATHLEN]; char plp[MAXPATHLEN]; const char *val; if ( (val=longopt("home", argc, argv)) ) { if ( (home=PrologPath(val, plp, sizeof(plp))) ) return store_string(home); return NULL; } if ( (val = exec_var("homevar")) && (home = Getenv(val, envbuf, sizeof(envbuf))) && (home = PrologPath(home, plp, sizeof(plp))) ) return store_string(home); if ( (val = exec_var("home")) && (home = PrologPath(val, plp, sizeof(plp))) ) return store_string(home); #ifdef PLHOMEVAR_1 if ( !(home = Getenv(PLHOMEVAR_1, envbuf, sizeof(envbuf))) ) { #ifdef PLHOMEVAR_2 home = Getenv(PLHOMEVAR_2, envbuf, sizeof(envbuf)); #endif } if ( home && (home = PrologPath(home, plp, sizeof(plp))) && ExistsDirectory(home) ) return store_string(home); #endif #ifdef PLHOMEFILE if ( (home = symbols) ) { char buf[MAXPATHLEN]; char parent[MAXPATHLEN]; IOSTREAM *fd; strcpy(parent, DirName(DirName(AbsoluteFile(home, buf), buf), buf)); Ssprintf(buf, "%s/" PLHOMEFILE, parent); if ( (fd = Sopen_file(buf, "r")) ) { if ( Sfgets(buf, sizeof(buf), fd) ) { size_t l = strlen(buf); while(l > 0 && buf[l-1] <= ' ') l--; buf[l] = EOS; #if O_XOS { char buf2[MAXPATHLEN]; _xos_canonical_filename(buf, buf2, MAXPATHLEN, 0); strcpy(buf, buf2); } #endif if ( !IsAbsolutePath(buf) ) { char buf2[MAXPATHLEN]; Ssprintf(buf2, "%s/%s", parent, buf); home = AbsoluteFile(buf2, plp); } else home = AbsoluteFile(buf, plp); if ( ExistsDirectory(home) ) { Sclose(fd); return store_string(home); } } Sclose(fd); } } #endif /*PLHOMEFILE*/ if ( (home = PrologPath(PLHOME, plp, sizeof(plp))) && ExistsDirectory(home) ) return store_string(home); return NULL; }
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 char * findHome(char *symbols) { char *home = NULL; char envbuf[MAXPATHLEN]; char plp[MAXPATHLEN]; const char *val; if ( (val = exec_var("homevar")) && (home = getenv3(val, envbuf, sizeof(envbuf))) && (home = PrologPath(home, plp)) ) return store_string(home); if ( (val = exec_var("home")) && (home = PrologPath(home, plp)) ) return store_string(home); if ( !(home = getenv3("SWI_HOME_DIR", envbuf, sizeof(envbuf))) ) home = getenv3("SWIPL", envbuf, sizeof(envbuf)); if ( home && (home = PrologPath(home, plp)) && ExistsDirectory(home) ) return store_string(home); if ( (home = symbols) ) { char buf[MAXPATHLEN]; char parent[MAXPATHLEN]; IOSTREAM *fd; strcpy(parent, DirName(DirName(AbsoluteFile(home, buf), buf), buf)); Ssprintf(buf, "%s/swipl", parent); if ( (fd = Sopen_file(buf, "r")) ) { if ( Sfgets(buf, sizeof(buf), fd) ) { int l = strlen(buf); while(l > 0 && buf[l-1] <= ' ') l--; buf[l] = EOS; #if O_XOS { char buf2[MAXPATHLEN]; _xos_canonical_filename(buf, buf2); strcpy(buf, buf2); } #endif if ( !IsAbsolutePath(buf) ) { char buf2[MAXPATHLEN]; Ssprintf(buf2, "%s/%s", parent, buf); home = AbsoluteFile(buf2, plp); } else home = AbsoluteFile(buf, plp); if ( ExistsDirectory(home) ) { Sclose(fd); return store_string(home); } } Sclose(fd); } } if ( (home = PrologPath(PLHOME, plp)) && ExistsDirectory(home) ) return store_string(home); return NULL; }