static void InitAtoms(void) {
int i;
AtomHashTableSize = MaxHash;
HashChain =
(AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash);
if (HashChain == NULL) {
Yap_Error(SYSTEM_ERROR_FATAL, MkIntTerm(0),
"allocating initial atom table");
}
for (i = 0; i < MaxHash; ++i) {
INIT_RWLOCK(HashChain[i].AERWLock);
HashChain[i].Entry = NIL;
}
NOfAtoms = 0;
#if OLD_STYLE_INITIAL_ATOMS
Yap_LookupAtomWithAddress("**", (AtomEntry *)&(SF_STORE->AtFoundVar));
Yap_ReleaseAtom(AtomFoundVar);
Yap_LookupAtomWithAddress("?", (AtomEntry *)&(SF_STORE->AtFreeTerm));
Yap_ReleaseAtom(AtomFreeTerm);
Yap_LookupAtomWithAddress("[]", (AtomEntry *)&(SF_STORE->AtNil));
Yap_LookupAtomWithAddress(".", (AtomEntry *)&(SF_STORE->AtDot));
#else
SF_STORE->AtFoundVar = Yap_LookupAtom("**");
Yap_ReleaseAtom(AtomFoundVar);
SF_STORE->AtFreeTerm = Yap_LookupAtom("?");
Yap_ReleaseAtom(AtomFreeTerm);
SF_STORE->AtNil = Yap_LookupAtom("[]");
SF_STORE->AtDot = Yap_LookupAtom(".");
#endif
}
static void YAPCatchError() {
if (LOCAL_CommittedError != nullptr &&
LOCAL_CommittedError->errorNo != YAP_NO_ERROR) {
// Yap_PopTermFromDB(info->errorTerm);
// throw throw YAPError( );
Term es[2];
es[0] = TermError;
es[1] = MkErrorTerm(LOCAL_CommittedError);
Functor f = Yap_MkFunctor(Yap_LookupAtom("print_message"), 2);
YAP_RunGoalOnce(Yap_MkApplTerm(f, 2, es));
// Yap_PopTermFromDB(info->errorTerm);
// throw throw YAPError( SOURCE(), );
} else if (LOCAL_ActiveError != nullptr &&
LOCAL_ActiveError->errorNo != YAP_NO_ERROR) {
// Yap_PopTermFromDB(info->errorTerm);
// throw throw YAPError( );
Term es[2];
es[0] = TermError;
es[1] = MkErrorTerm(LOCAL_ActiveError);
Functor f = Yap_MkFunctor(Yap_LookupAtom("print_message"), 2);
YAP_RunGoalOnce(Yap_MkApplTerm(f, 2, es));
// Yap_PopTermFromDB(info->errorTerm);
// throw throw YAPError( SOURCE(), );
}
}
void
Yap_InitConstExps(void)
{
unsigned int i;
ExpEntry *p;
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
AtomEntry *ae = RepAtom(Yap_LookupAtom(InitConstTab[i].OpName));
if (ae == NULL) {
Yap_EvalError(RESOURCE_ERROR_HEAP,TermNil,"at InitConstExps");
return;
}
WRITE_LOCK(ae->ARWLock);
if (Yap_GetExpPropHavingLock(ae, 0)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
p = (ExpEntry *) Yap_AllocAtomSpace(sizeof(ExpEntry));
p->KindOfPE = ExpProperty;
p->ArityOfEE = 0;
p->ENoOfEE = 0;
p->FOfEE = InitConstTab[i].f;
AddPropToAtom(ae, (PropEntry *)p);
WRITE_UNLOCK(ae->ARWLock);
}
}
/* Gets the info about an operator in a prop */
Atom Yap_GetOp(OpEntry *pp, int *prio, int fix) {
int n;
SMALLUNSGN p;
if (fix == 0) {
p = pp->Prefix;
if (p & DcrrpFlag)
n = 6, *prio = (p ^ DcrrpFlag);
else
n = 7, *prio = p;
} else if (fix == 1) {
p = pp->Posfix;
if (p & DcrlpFlag)
n = 4, *prio = (p ^ DcrlpFlag);
else
n = 5, *prio = p;
} else {
p = pp->Infix;
if ((p & DcrrpFlag) && (p & DcrlpFlag))
n = 1, *prio = (p ^ (DcrrpFlag | DcrlpFlag));
else if (p & DcrrpFlag)
n = 3, *prio = (p ^ DcrrpFlag);
else if (p & DcrlpFlag)
n = 2, *prio = (p ^ DcrlpFlag);
else
n = 4, *prio = p;
}
return Yap_LookupAtom(optypes[n]);
}
static void SetOp(int p, int type, char *at, Term m) {
#if DEBUG
if (GLOBAL_Option[5])
fprintf(stderr, "[setop %d %s %s]\n", p, optypes[type], at);
#endif
OpDec(p, optypes[type], Yap_LookupAtom(at), m);
}
static Int file_base_name(USES_REGS1) { /* file_base_name(Stream,N) */
Term t = Deref(ARG1);
Atom at;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "file_base_name/2");
return FALSE;
}
at = AtomOfTerm(t);
const char *c = RepAtom(at)->StrOfAE;
const char *s;
#if HAVE_BASENAME && 0 // DISABLED: Linux basename is not compatible with
// file_base_name in SWI and GNU
char c1[YAP_FILENAME_MAX + 1];
strncpy(c1, c, YAP_FILENAME_MAX);
s = basename(c1);
#else
Int i = strlen(c);
while (i && !Yap_dir_separator((int)c[--i]))
;
if (Yap_dir_separator((int)c[i])) {
i++;
}
s = c + i;
#endif
return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(s)));
}
static Int file_directory_name(USES_REGS1) { /* file_directory_name(Stream,N) */
Term t = Deref(ARG1);
Atom at;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "file_directory_name/2");
return false;
}
at = AtomOfTerm(t);
const char *c = RepAtom(at)->StrOfAE;
#if HAVE_BASENAME && 0 // DISABLED: Linux basename is not compatible with
// file_base_name in SWI and GNU
const char *s;
char c1[YAP_FILENAME_MAX + 1];
strncpy(c1, c, YAP_FILENAME_MAX);
s = dirname(c1);
#else
char s[YAP_FILENAME_MAX + 1];
Int i = strlen(c);
strncpy(s, c, YAP_FILENAME_MAX);
while (--i) {
if (Yap_dir_separator((int)c[i]))
break;
}
if (i == 0) {
s[0] = '.';
i = 1;
}
s[i] = '\0';
#endif
return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(s)));
}
static Term
VarNames(VarEntry *p,Term l USES_REGS)
{
if (p != NULL) {
if (strcmp(p->VarRep, "_") != 0) {
Term t[2];
Term o;
t[0] = MkAtomTerm(Yap_LookupAtom(p->VarRep));
t[1] = p->VarAdr;
o = Yap_MkApplTerm(FunctorEq, 2, t);
o = MkPairTerm(o, VarNames(p->VarRight,
VarNames(p->VarLeft,l PASS_REGS) PASS_REGS));
if (HR > ASP-4096) {
save_machine_regs();
siglongjmp(LOCAL_IOBotch,1);
}
return(o);
} else {
return VarNames(p->VarRight,VarNames(p->VarLeft,l PASS_REGS) PASS_REGS);
}
} else {
return (l);
}
}
VarEntry *Yap_LookupVar(const char *var) /* lookup variable in variables table
* */
{
CACHE_REGS
VarEntry *p;
Atom vat = Yap_LookupAtom(var);
#if DEBUG
if (GLOBAL_Option[4])
fprintf(stderr, "[LookupVar %s]", var);
#endif
if (var[0] != '_' || var[1] != '\0') {
VarEntry **op = &LOCAL_VarTable;
UInt hv;
p = LOCAL_VarTable;
hv = HashFunction((unsigned char *)var) % AtomHashTableSize;
while (p != NULL) {
CELL hpv = p->hv;
if (hv == hpv) {
Int scmp;
if ((scmp = strcmp(var, RepAtom(p->VarRep)->StrOfAE)) == 0) {
p->refs++;
return (p);
} else if (scmp < 0) {
op = &(p->VarLeft);
p = p->VarLeft;
} else {
op = &(p->VarRight);
p = p->VarRight;
}
} else if (hv < hpv) {
op = &(p->VarLeft);
p = p->VarLeft;
} else {
op = &(p->VarRight);
p = p->VarRight;
}
}
p = (VarEntry *)Yap_AllocScannerMemory(sizeof(VarEntry));
*op = p;
p->VarLeft = p->VarRight = NULL;
p->hv = hv;
p->refs = 1L;
p->VarRep = vat;
} else {
/* anon var */
p = (VarEntry *)Yap_AllocScannerMemory(sizeof(VarEntry));
p->VarLeft = LOCAL_AnonVarTable;
LOCAL_AnonVarTable = p;
p->VarRight = NULL;
p->refs = 0L;
p->hv = 1L;
p->VarRep = vat;
}
p->VarAdr = TermNil;
return (p);
}
YAPApplTerm::YAPApplTerm(const std::string f, YAPTerm a1) {
BACKUP_H();
arity_t arity = 1;
Functor ff = Yap_MkFunctor(Yap_LookupAtom(f.c_str()), arity);
Term o = Yap_MkNewApplTerm(ff, arity);
Term *tt = RepAppl(o) + 1;
tt[0] = a1.term();
mk(o);
RECOVER_H();
}
YAPApplTerm::YAPApplTerm(const char *f, std::vector<YAPTerm> ts) : YAPTerm() {
BACKUP_H();
arity_t arity = ts.size();
std::vector<Term> tt(arity);
for (arity_t i = 0; i < arity; i++)
tt[i] = ts[i].term();
Functor ff = Yap_MkFunctor(Yap_LookupAtom(f), arity);
t = Yap_MkApplTerm(ff, arity, &tt[0]);
RECOVER_H();
}
static int
OpDec(int p, const char *type, Atom a, Term m)
{
int i;
AtomEntry *ae = RepAtom(a);
OpEntry *info;
if (m == TermProlog)
m = PROLOG_MODULE;
else if (m == USER_MODULE)
m = PROLOG_MODULE;
for (i = 1; i <= 7; ++i)
if (strcmp(type, optypes[i]) == 0)
break;
if (i > 7) {
Yap_Error(DOMAIN_ERROR_OPERATOR_SPECIFIER,MkAtomTerm(Yap_LookupAtom(type)),"op/3");
return(FALSE);
}
if (p) {
if (i == 1 || i == 2 || i == 4)
p |= DcrlpFlag;
if (i == 1 || i == 3 || i == 6)
p |= DcrrpFlag;
}
WRITE_LOCK(ae->ARWLock);
info = Yap_GetOpPropForAModuleHavingALock(ae, m);
if (EndOfPAEntr(info)) {
info = (OpEntry *) Yap_AllocAtomSpace(sizeof(OpEntry));
info->KindOfPE = Ord(OpProperty);
info->OpModule = m;
info->OpName = a;
//LOCK(OpListLock);
info->OpNext = OpList;
OpList = info;
//UNLOCK(OpListLock);
AddPropToAtom(ae, (PropEntry *)info);
INIT_RWLOCK(info->OpRWLock);
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
info->Prefix = info->Infix = info->Posfix = 0;
} else {
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
}
if (i <= 3) {
GET_LD
if (truePrologFlag(PLFLAG_ISO) &&
info->Posfix != 0) /* there is a posfix operator */ {
/* ISO dictates */
WRITE_UNLOCK(info->OpRWLock);
Yap_Error(PERMISSION_ERROR_CREATE_OPERATOR,MkAtomTerm(a),"op/3");
return FALSE;
}
info->Infix = p;
} else if (i <= 5) {
YAPApplTerm::YAPApplTerm(const std::string f, std::vector<YAPTerm> ts) {
BACKUP_H();
arity_t arity = ts.size();
Functor ff = Yap_MkFunctor(Yap_LookupAtom(f.c_str()), arity);
Term o = Yap_MkNewApplTerm(ff, arity);
Term *tt = RepAppl(o) + 1;
for (arity_t i = 0; i < arity; i++)
tt[i] = ts[i].term();
mk(o);
RECOVER_H();
}
static Term readFromBuffer(const char *s, Term opts) {
Term rval;
int sno;
encoding_t enc = ENC_ISO_UTF8;
sno = Yap_open_buf_read_stream(
(char *)s, strlen_utf8((unsigned char *)s), &enc, MEM_BUF_USER,
Yap_LookupAtom(Yap_StrPrefix((char *)s, 16)), TermNone);
rval = Yap_read_term(sno, opts, 3);
Yap_CloseStream(sno);
return rval;
}
static bool
has_encoding(int sno,
Term t2 USES_REGS) { /* '$set_output'(+Stream,-ErrorMessage) */
if (!IsVarTerm(t2) && !(isatom(t2))) {
return FALSE;
}
if (0 && IsAtomTerm(t2)) {
encoding_t e = enc_id(RepAtom(AtomOfTerm(t2))->StrOfAE);
GLOBAL_Stream[sno].encoding = e;
return true;
} else {
const char *s = enc_name(LOCAL_encoding);
return Yap_unify(t2, MkAtomTerm(Yap_LookupAtom(s)));
}
}
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
Yap_FindExecutable(char *name)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*Yap_argv[0] == '/') {
if (oktox(Yap_argv[0])) {
strcpy(Yap_FileNameBuf, Yap_argv[0]);
Yap_TrueFileName(Yap_FileNameBuf, YapExecutable, TRUE);
return;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = Yap_FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, Yap_argv[0]);
if (*cp)
cp++;
if (!oktox(Yap_FileNameBuf))
continue;
Yap_TrueFileName(Yap_FileNameBuf, YapExecutable, TRUE);
return;
}
/* one last try for dual systems */
strcpy(Yap_FileNameBuf, Yap_argv[0]);
Yap_TrueFileName(Yap_FileNameBuf, YapExecutable, TRUE);
if (oktox(YapExecutable))
return;
else
Yap_Error(SYSTEM_ERROR,MkAtomTerm(Yap_LookupAtom(YapExecutable)),
"cannot find file being executed");
}
bool Yap_Warning(const char *s, ...) {
CACHE_REGS
va_list ap;
PredEntry *pred;
bool rc;
Term ts[2];
const char *fmt;
char tmpbuf[MAXPATHLEN];
yap_error_number err;
LOCAL_DoingUndefp = true;
if (LOCAL_PrologMode & InErrorMode && (err = LOCAL_ActiveError->errorNo)) {
fprintf(stderr, "%% Warning %s WITHIN ERROR %s %s\n", s,
Yap_errorClassName(Yap_errorClass(err)), Yap_errorName(err));
Yap_RestartYap(1);
}
LOCAL_PrologMode |= InErrorMode;
pred = RepPredProp(PredPropByFunc(FunctorPrintMessage,
PROLOG_MODULE)); // PROCEDURE_print_message2
va_start(ap, s);
fmt = va_arg(ap, char *);
if (fmt != NULL) {
#if HAVE_VSNPRINTF
vsnprintf(tmpbuf, MAXPATHLEN - 1, fmt, ap);
#else
(void)vsprintf(tmpbuf, fmt, ap);
#endif
} else {
return false;
}
va_end(ap);
if (pred->OpcodeOfPred == UNDEF_OPCODE || pred->OpcodeOfPred == FAIL_OPCODE) {
fprintf(stderr, "warning message: %s\n", tmpbuf);
LOCAL_DoingUndefp = false;
LOCAL_PrologMode &= ~InErrorMode;
return false;
}
ts[1] = MkAtomTerm(AtomWarning);
ts[0] = MkAtomTerm(Yap_LookupAtom(tmpbuf));
rc = Yap_execute_pred(pred, ts, true PASS_REGS);
LOCAL_PrologMode &= ~InErrorMode;
return rc;
}
bool Yap_Warning(const char *s, ...) {
CACHE_REGS
va_list ap;
PredEntry *pred;
bool rc;
Term ts[2];
const char *format;
char tmpbuf[MAXPATHLEN];
if (LOCAL_within_print_message) {
/* error within error */
fprintf(stderr, "%% WARNING WITHIN WARNING\n");
Yap_RestartYap(1);
}
LOCAL_DoingUndefp = true;
LOCAL_within_print_message = true;
pred = RepPredProp(PredPropByFunc(FunctorPrintMessage,
PROLOG_MODULE)); // PROCEDURE_print_message2
va_start(ap, s);
format = va_arg(ap, char *);
if (format != NULL) {
#if HAVE_VSNPRINTF
vsnprintf(tmpbuf, MAXPATHLEN - 1, format, ap);
#else
(void)vsprintf(tmpbuf, format, ap);
#endif
} else
return false;
va_end(ap);
if (pred->OpcodeOfPred == UNDEF_OPCODE||
pred->OpcodeOfPred == FAIL_OPCODE) {
fprintf(stderr, "warning message: %s\n", tmpbuf);
LOCAL_DoingUndefp = false;
LOCAL_within_print_message = false;
return false;
}
ts[1] = MkAtomTerm(AtomWarning);
ts[0] = MkAtomTerm(Yap_LookupAtom(tmpbuf));
rc = Yap_execute_pred(pred, ts, true PASS_REGS);
return rc;
}
void
Yap_InitBinaryExps(void)
{
unsigned int i;
ExpEntry *p;
for (i = 0; i < sizeof(InitBinTab)/sizeof(InitBinEntry); ++i) {
AtomEntry *ae = RepAtom(Yap_LookupAtom(InitBinTab[i].OpName));
if (ae == NULL) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"at InitBinaryExps");
return;
}
WRITE_LOCK(ae->ARWLock);
if (Yap_GetExpPropHavingLock(ae, 2)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
p = (ExpEntry *) Yap_AllocAtomSpace(sizeof(ExpEntry));
p->KindOfPE = ExpProperty;
p->ArityOfEE = 2;
p->ENoOfEE = 2;
p->FOfEE = InitBinTab[i].f;
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
Yap_InitCPred("is", 4, p_binary_is, TestPredFlag | SafePredFlag);
Yap_InitCPred("$binary_op_as_integer", 2, p_binary_op_as_integer, TestPredFlag|SafePredFlag);
Yap_InitAsmPred("$plus", 3, _plus, export_p_plus, SafePredFlag);
Yap_InitAsmPred("$minus", 3, _minus, export_p_minus, SafePredFlag);
Yap_InitAsmPred("$times", 3, _times, export_p_times, SafePredFlag);
Yap_InitAsmPred("$div", 3, _div, export_p_div, SafePredFlag);
Yap_InitAsmPred("$and", 3, _and, export_p_and, SafePredFlag);
Yap_InitAsmPred("$or", 3, _or, export_p_or, SafePredFlag);
Yap_InitAsmPred("$sll", 3, _sll, export_p_sll, SafePredFlag);
Yap_InitAsmPred("$slr", 3, _slr, export_p_slr, SafePredFlag);
}
static Int
p_socket_accept(USES_REGS1)
{
Term t1 = Deref(ARG1);
int sno;
socket_info status;
socket_domain domain;
int ofd, fd;
Term out;
if ((sno = Yap_CheckSocketStream(t1, "socket_accept/3")) < 0) {
return (FALSE);
}
ofd = Yap_GetStreamFd(sno);
status = Yap_GetSocketStatus(sno);
if (status != server_socket) {
/* ok, this should be an error, as you are trying to bind */
return(FALSE);
}
domain = Yap_GetSocketDomain(sno);
#if HAVE_SYS_UN_H
if (domain == af_unix) {
struct sockaddr_un caddr;
unsigned int len;
memset((void *)&caddr,(int) 0, sizeof(caddr));
if ((fd=accept(ofd, (struct sockaddr *)&caddr, &len)) < 0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (accept: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (accept)");
#endif
}
/* ignore 2nd argument */
out = Yap_InitSocketStream(fd, server_session_socket, af_unix );
} else
#endif
if (domain == af_inet) {
struct sockaddr_in caddr;
Term tcli;
char *s;
#if _WIN32 || defined(__MINGW32__)
int len;
#else
unsigned int len;
#endif
len = sizeof(caddr);
memset((void *)&caddr,(int) 0, sizeof(caddr));
if (invalid_socket_fd(fd=accept(ofd, (struct sockaddr *)&caddr, &len))) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (accept: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (accept)");
#endif
return(FALSE);
}
if ((s = inet_ntoa(caddr.sin_addr)) == NULL) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (inet_ntoa: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_accept/3 (inet_ntoa)");
#endif
}
tcli = MkAtomTerm(Yap_LookupAtom(s));
if (!Yap_unify(ARG2,tcli))
return(FALSE);
out = Yap_InitSocketStream(fd, server_session_socket, af_inet );
} else
return(FALSE);
if (out == TermNil) return(FALSE);
return(Yap_unify(out,ARG3));
}
/**
* Syntax Error Handler
*
* @par tokptr: the sequence of tokens
* @par sno: the stream numbet
*
* Implicit arguments:
* +
*/
Term Yap_syntax_error(TokEntry *errtok, int sno) {
CACHE_REGS
Term info;
Term startline, errline, endline;
Term tf[4];
Term *tailp = tf + 3;
CELL *Hi = HR;
TokEntry *tok = LOCAL_tokptr;
Int cline = tok->TokPos;
startline = MkIntegerTerm(cline);
if (errtok != LOCAL_toktide) {
errtok = LOCAL_toktide;
}
LOCAL_Error_TYPE = YAP_NO_ERROR;
errline = MkIntegerTerm(errtok->TokPos);
if (LOCAL_ErrorMessage)
tf[0] = MkStringTerm(LOCAL_ErrorMessage);
else
tf[0] = MkStringTerm("");
while (tok) {
Term ts[2];
if (HR > ASP - 1024) {
errline = MkIntegerTerm(0);
endline = MkIntegerTerm(0);
/* for some reason moving this earlier confuses gcc on solaris */
HR = Hi;
break;
}
if (tok->TokPos != cline) {
*tailp = MkPairTerm(TermNewLine, TermNil);
tailp = RepPair(*tailp) + 1;
cline = tok->TokPos;
}
if (tok == errtok && tok->Tok != Error_tok) {
*tailp = MkPairTerm(MkAtomTerm(AtomError), TermNil);
tailp = RepPair(*tailp) + 1;
}
info = tok->TokInfo;
switch (tok->Tok) {
case Name_tok: {
Term t0[1];
if (info) {
t0[0] = MkAtomTerm((Atom)info);
} else {
t0[0] = TermNil;
}
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomAtom, 1), 1, t0);
} break;
case QuasiQuotes_tok: {
Term t0[2];
t0[0] = MkAtomTerm(Yap_LookupAtom("<QQ>"));
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomAtom, 1), 1, t0);
} break;
case WQuasiQuotes_tok: {
Term t0[2];
t0[0] = MkAtomTerm(Yap_LookupAtom("<WideQQ>"));
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomAtom, 1), 1, t0);
} break;
case Number_tok:
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomNumber, 1), 1, &(tok->TokInfo));
break;
case Var_tok: {
Term t[2];
VarEntry *varinfo = (VarEntry *)info;
t[0] = MkIntTerm(0);
t[1] = Yap_CharsToString(varinfo->VarRep, ENC_ISO_LATIN1 PASS_REGS);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomGVar, 2), 2, t);
} break;
case String_tok: {
Term t0 =
Yap_CharsToTDQ((char *)info, CurrentModule, ENC_ISO_LATIN1 PASS_REGS);
if (!t0) {
return 0;
}
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString, 1), 1, &t0);
} break;
case WString_tok: {
Term t0 = Yap_WCharsToTDQ((wchar_t *)info, CurrentModule PASS_REGS);
if (!t0)
return 0;
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString, 1), 1, &t0);
} break;
case BQString_tok: {
Term t0 =
Yap_CharsToTBQ((char *)info, CurrentModule, ENC_ISO_LATIN1 PASS_REGS);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString, 1), 1, &t0);
} break;
case WBQString_tok: {
Term t0 = Yap_WCharsToTBQ((wchar_t *)info, CurrentModule PASS_REGS);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString, 1), 1, &t0);
} break;
case Error_tok: {
ts[0] = MkAtomTerm(AtomError);
} break;
case eot_tok:
endline = MkIntegerTerm(tok->TokPos);
ts[0] = MkAtomTerm(Yap_LookupAtom("EOT"));
break;
case Ponctuation_tok: {
char s[2];
s[1] = '\0';
if ((info) == 'l') {
s[0] = '(';
} else {
s[0] = (char)info;
}
ts[0] = MkAtomTerm(Yap_LookupAtom(s));
}
}
tok = tok->TokNext;
if (!tok)
break;
*tailp = MkPairTerm(ts[0], TermNil);
tailp = RepPair(*tailp) + 1;
}
{
Term t[3];
t[0] = startline;
t[1] = errline;
t[2] = endline;
tf[1] = Yap_MkApplTerm(Yap_MkFunctor(AtomBetween, 3), 3, t);
}
/* 0: id */
/* 1: strat, error, end line */
/*2 msg */
/* file */
tf[2] = Yap_StreamUserName(sno);
clean_vars(LOCAL_VarTable);
clean_vars(LOCAL_AnonVarTable);
Term terr = Yap_MkApplTerm(FunctorSyntaxError, 4, tf);
Term tn[2];
tn[0] = Yap_MkApplTerm(FunctorShortSyntaxError, 1, &terr);
tn[1] = TermNil;
terr = Yap_MkApplTerm(FunctorError, 2, tn);
#if DEBUG
if (Yap_ExecutionMode == YAP_BOOT_MODE) {
fprintf(stderr, "SYNTAX ERROR while booting: ");
Yap_DebugPlWriteln(terr);
}
#endif
return terr;
}
static bool
has_encoding(int sno,
Term t2 USES_REGS) { /* '$set_output'(+Stream,-ErrorMessage) */
const char *s = enc_name(GLOBAL_Stream[sno].encoding);
return Yap_unify(t2, MkAtomTerm(Yap_LookupAtom(s)));
}
void eam_pass(CInstr *ppc)
{
int alloc_found=0;
int body=0;
while (ppc) {
switch ((int) ppc->op) {
case get_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_val_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_num_op:
case get_atom_op:
emit_inst(_get_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case get_list_op:
emit_inst(_get_list_op);
emit_par(ppc->new1);
break;
case get_struct_op:
emit_inst(_get_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor ) ppc->new4));
break;
case unify_last_local_op:
case unify_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case unify_last_val_op:
case unify_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_var_op:
case unify_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_atom_op:
case unify_last_num_op:
emit_inst(_unify_last_atom_op);
emit_par(ppc->new4);
break;
case unify_num_op:
case unify_atom_op:
emit_inst(_unify_atom_op);
emit_par(ppc->new4);
break;
case unify_list_op:
emit_inst(_unify_list_op);
break;
case unify_last_list_op:
emit_inst(_unify_last_list_op);
break;
case unify_struct_op:
emit_inst(_unify_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case unify_last_struct_op:
emit_inst(_unify_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case put_unsafe_op:
/*
printf("Got a put_unsafe...\n");
emit_inst(_put_unsafe_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
*/
case put_val_op:
/*
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
break;
} else {
emit_inst(_put_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
}
*/
case put_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_put_var_P_op);
else emit_inst(_put_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case put_num_op:
case put_atom_op:
emit_inst(_put_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case put_list_op:
emit_inst(_put_list_op);
emit_par(ppc->new1);
break;
case put_struct_op:
emit_inst(_put_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case write_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_write_var_P_op);
else emit_inst(_write_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_num_op:
case write_atom_op:
emit_inst(_write_atom_op);
emit_par(ppc->new4);
break;
case write_list_op:
emit_inst(_write_list_op);
break;
case write_last_list_op:
emit_inst(_write_last_list_op);
break;
case write_struct_op:
emit_inst(_write_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_last_struct_op:
emit_inst(_write_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case fail_op:
emit_inst(_fail_op);
break;
case cutexit_op:
printf("cutexit \n");
exit(1);
break;
case cut_op:
emit_inst(_cut_op);
break;
case commit_op:
emit_inst(_commit_op);
break;
case procceed_op:
emit_inst(_proceed_op);
break;
case pop_op:
emit_inst(_pop_op);
emit_par(ppc->new4);
break;
case save_b_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_b_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_b_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_pair_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_pair_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_pair_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_appl_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_appl_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_appl_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case std_base_op:
emit_inst(_std_base+ppc->new4);
break;
case safe_call_op:
if (ppc->new1==1) {
emit_inst(_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_safe_call_binary_op);
} else {
emit_inst(_safe_call_op);
}
emit_par(ppc->new4);
break;
case direct_safe_call_op:
if (ppc->new1==1) {
emit_inst(_direct_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_direct_safe_call_binary_op);
} else {
emit_inst(_direct_safe_call_op);
}
emit_par(ppc->new4);
break;
case call_op:
emit_inst(_call_op);
emit_par(ppc->new4);
break;
case skip_while_var_op:
emit_inst(_skip_while_var);
break;
case wait_while_var_op:
emit_inst(_wait_while_var);
break;
case force_wait_op:
emit_inst(_force_wait);
break;
case write_op:
if (ppc->new1=='\n') {
static Atom a=NULL;
if (a==NULL) a=Yap_LookupAtom("\n");
emit_inst(_put_atom_op);
emit_par(1);
emit_par((Cell) MkAtomTerm(a));
}
emit_inst(_write_call);
break;
case is_op:
emit_inst(_is_call);
break;
case equal_op:
emit_inst(_equal_call);
break;
case either_op:
emit_inst(_either_op);
emit_par(ppc->new1);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orelse_op:
emit_inst(_orelse_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orlast_op:
emit_inst(_orlast_op);
break;
case create_first_box_op:
case create_box_op:
case create_last_box_op:
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
alloc_found=1;
break;
case remove_box_op:
case remove_last_box_op:
break;
case jump_op:
emit_inst(_jump_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case label_op:
if (pass==0) labels[ppc->new4] = get_addr();
break;
case run_op:
/* se ficar vazio, retirar no eam_am.c o +5 das linhas pc=clause->code+5 no only_1_clause e no call */
emit_inst(_try_me_op);
emit_par(0);
emit_par(0);
emit_par(0);
emit_par(0);
break;
case only_1_clause_op:
emit_inst(_only_1_clause_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case try_me_op:
emit_inst(_try_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case retry_me_op:
emit_inst(_retry_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case trust_me_op:
emit_inst(_trust_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case body_op:
if (next_not_nop_inst(ppc->nextInst)==procceed_op) {
//emit_inst(_proceed_op);
break;
} else if (next_not_nop_inst(ppc->nextInst)==fail_op) {
//emit_inst(_fail_op);
break;
}
if (ppc->new4!=0) {
emit_inst(_prepare_calls);
emit_par(ppc->new4); /* nr_calls */
}
body=1;
break;
case prepare_tries:
emit_inst(_prepare_tries);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case exit_op:
emit_inst(_exit_eam);
break;
case mark_initialized_pvars_op:
break;
case fetch_args_for_bccall:
case bccall_op:
printf("[ Fatal Error: fetch and bccall instructions not supported ]\n");
exit(1);
break;
case endgoal_op:
case nop_op:
case name_op:
break;
default:
if (pass) {
printf("[ Sorry, there is at least one unsupported instruction in your code... %3d] %d\n",ppc->op,exit_op);
printf("[ please note that beam still does not support a lot of builtins ]\n");
}
emit_inst(_fail_op);
}
ppc = ppc->nextInst;
}
emit_inst(_exit_eam);
emit_par(-1);
}
/* Return a list of files for a directory */
static Int list_directory(USES_REGS1) {
Term tf = MkAtomTerm(Yap_LookupAtom("[]"));
yhandle_t sl = Yap_InitSlot(tf);
VFS_t *vfsp;
char *buf = (char *)AtomName(AtomOfTerm(ARG1));
if ((vfsp = vfs_owner(buf))) {
void *de;
const char *dp;
if ((de = vfsp->opendir(vfsp, buf)) == NULL) {
PlIOError(PERMISSION_ERROR_INPUT_STREAM, ARG1, "%s in list_directory",
strerror(errno));
}
while ((dp = vfsp->nextdir( de))) {
YAP_Term ti = MkAtomTerm(Yap_LookupAtom(dp));
Yap_PutInHandle(sl, MkPairTerm(ti, Yap_GetFromHandle(sl)));
}
vfsp->closedir( de);
} else {
#if defined(__MINGW32__) || _MSC_VER
struct _finddata_t c_file;
char bs[BUF_SIZE];
long hFile;
bs[0] = '\0';
#if HAVE_STRNCPY
strncpy(bs, buf, BUF_SIZE);
#else
strcpy(bs, buf);
#endif
#if HAVE_STRNCAT
strncat(bs, "/*", BUF_SIZE);
#else
strcat(bs, "/*");
#endif
if ((hFile = _findfirst(bs, &c_file)) == -1L) {
return (Yap_unify(ARG2, tf));
}
Yap_PutInSlot(sl, MkPairTerm(MkAtomTerm(Yap_LookupAtom(c_file.name)),
Yap_GetFromSlot(sl)));
while (_findnext(hFile, &c_file) == 0) {
Term ti = MkAtomTerm(Yap_LookupAtom(c_file.name));
Yap_PutInSlot(sl, MkPairTerm(ti, Yap_GetFromSlot(sl)));
}
_findclose(hFile);
#elif HAVE_OPENDIR
{
DIR *de;
struct dirent *dp;
if ((de = opendir(buf)) == NULL) {
PlIOError(PERMISSION_ERROR_INPUT_STREAM, ARG1, "%s in list_directory",
strerror(errno));
return false;
}
while ((dp = readdir(de))) {
Term ti = MkAtomTerm(Yap_LookupAtom(dp->d_name));
Yap_PutInSlot(sl, MkPairTerm(ti, Yap_GetFromSlot(sl)));
}
closedir(de);
}
#endif /* HAVE_OPENDIR */
}
tf = Yap_GetFromSlot(sl);
return Yap_unify(ARG2, tf);
}
PL_find_blob_type(const char* name)
{
Atom at = Yap_LookupAtom((char *)name);
return YAP_find_blob_type((YAP_Atom)at);
}
static void InitVersion(void) {
Yap_PutValue(AtomVersionNumber, MkAtomTerm(Yap_LookupAtom(YAP_FULL_VERSION)));
}
void Yap_InitCPred(const char *Name, arity_t Arity, CPredicate code,
pred_flags_t flags) {
CACHE_REGS
Atom atom = NIL;
PredEntry *pe = NULL;
yamop *p_code;
StaticClause *cl = NULL;
Functor f = NULL;
while (atom == NIL) {
if (flags & UserCPredFlag)
atom = Yap_LookupAtom(Name);
else
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
if (Arity) {
while (!f) {
f = Yap_MkFunctor(atom, Arity);
if (!f && !Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
}
while (pe == NULL) {
if (Arity)
pe = RepPredProp(PredPropByFunc(f, CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom, CurrentModule));
if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
}
if (pe->PredFlags & CPredFlag) {
/* already exists */
flags = update_flags_from_prolog(flags, pe);
cl = ClauseCodeToStaticClause(pe->CodeOfPred);
if ((flags | StandardPredFlag | CPredFlag) != pe->PredFlags) {
Yap_ClauseSpace -= cl->ClSize;
Yap_FreeCodeSpace((ADDR)cl);
cl = NULL;
}
}
p_code = cl->ClCode;
while (!cl) {
UInt sz;
if (flags & SafePredFlag) {
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(p_code, Osbpp), p), l);
} else {
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(NEXTOP(p_code, e), p), Osbpp), p),
l);
}
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
if (!cl) {
if (!Yap_growheap(FALSE, sz, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name);
return;
}
} else {
Yap_ClauseSpace += sz;
cl->ClFlags = StaticMask;
cl->ClNext = NULL;
cl->ClSize = sz;
cl->usc.ClLine = Yap_source_line_no();
p_code = cl->ClCode;
}
}
pe->CodeOfPred = p_code;
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
pe->cs.f_code = code;
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_allocate);
p_code = NEXTOP(p_code, e);
}
if (flags & UserCPredFlag)
p_code->opc = Yap_opcode(_call_usercpred);
else
p_code->opc = Yap_opcode(_call_cpred);
p_code->y_u.Osbpp.bmap = NULL;
p_code->y_u.Osbpp.s = -Signed(RealEnvSize);
p_code->y_u.Osbpp.p = p_code->y_u.Osbpp.p0 = pe;
p_code = NEXTOP(p_code, Osbpp);
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate);
p_code->y_u.p.p = pe;
p_code = NEXTOP(p_code, p);
}
p_code->opc = Yap_opcode(_procceed);
p_code->y_u.p.p = pe;
p_code = NEXTOP(p_code, p);
p_code->opc = Yap_opcode(_Ystop);
p_code->y_u.l.l = cl->ClCode;
pe->OpcodeOfPred = pe->CodeOfPred->opc;
}
this code is no being maintained anymore
#include <stdio.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <a.out.h>
#define oktox(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
#define oktow(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
#ifdef mips
#define MAXSECTIONS 100
#else
#define MAXSECTIONS 20
#endif /* mips */
#ifdef sgi
#include <symbol.h>
#endif /* sgi */
#define N_TXTOFF(x) (sizeof(struct filehdr)+(x).f_opthdr+(x).f_nscns*sizeof(struct scnhdr))
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
char *
Yap_FindExecutable(void)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*GLOBAL_argv[0] == '/') {
if (oktox(GLOBAL_argv[0])) {
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
return NULL;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = LOCAL_FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, GLOBAL_argv[0]);
if (*cp)
cp++;
if (!oktox(LOCAL_FileNameBuf))
continue;
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
return GLOBAL_Executable;
}
/* one last try for dual systems */
strcpy(LOCAL_FileNameBuf, GLOBAL_argv[0]);
Yap_TrueFileName(LOCAL_FileNameBuf, GLOBAL_Executable, TRUE);
if (oktox(GLOBAL_Executable))
return GLOBAL_Executable;
else
Yap_Error(SYSTEM_ERROR_INTERNAL,MkAtomTerm(Yap_LookupAtom(GLOBAL_Executable)),
"cannot find file being executed");
return NULL;
}
static Term
syntax_error (TokEntry * tokptr, IOSTREAM *st, Term *outp)
{
CACHE_REGS
Term info;
int count = 0, out = 0;
Int start, err = 0, end;
Term tf[7];
Term *error = tf+3;
CELL *Hi = H;
/* make sure to globalise variable */
start = tokptr->TokPos;
clean_vars(LOCAL_VarTable);
clean_vars(LOCAL_AnonVarTable);
while (1) {
Term ts[2];
if (H > ASP-1024) {
tf[3] = TermNil;
err = 0;
end = 0;
/* for some reason moving this earlier confuses gcc on solaris */
H = Hi;
break;
}
if (tokptr == LOCAL_toktide) {
err = tokptr->TokPos;
out = count;
}
info = tokptr->TokInfo;
switch (tokptr->Tok) {
case Name_tok:
{
Term t0[1];
t0[0] = MkAtomTerm((Atom)info);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomAtom,1),1,t0);
}
break;
case Number_tok:
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomNumber,1),1,&(tokptr->TokInfo));
break;
case Var_tok:
{
Term t[3];
VarEntry *varinfo = (VarEntry *)info;
t[0] = MkIntTerm(0);
t[1] = Yap_StringToList(varinfo->VarRep);
if (varinfo->VarAdr == TermNil) {
t[2] = varinfo->VarAdr = MkVarTerm();
} else {
t[2] = varinfo->VarAdr;
}
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomGVar,3),3,t);
}
break;
case String_tok:
{
Term t0 = Yap_StringToList((char *)info);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
}
break;
case WString_tok:
{
Term t0 = Yap_WideStringToList((wchar_t *)info);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
}
break;
case Error_tok:
case eot_tok:
break;
case Ponctuation_tok:
{
char s[2];
s[1] = '\0';
if (Ord (info) == 'l') {
s[0] = '(';
} else {
s[0] = (char)info;
}
ts[0] = MkAtomTerm(Yap_LookupAtom(s));
}
}
if (tokptr->Tok == Ord (eot_tok)) {
*error = TermNil;
end = tokptr->TokPos;
break;
} else if (tokptr->Tok != Ord (Error_tok)) {
ts[1] = MkIntegerTerm(tokptr->TokPos);
*error =
MkPairTerm(Yap_MkApplTerm(FunctorMinus,2,ts),TermNil);
error = RepPair(*error)+1;
count++;
}
tokptr = tokptr->TokNext;
}
/* now we can throw away tokens, so we can unify and possibly overwrite TR */
Yap_unify(*outp, MkVarTerm());
if (IsVarTerm(*outp) && (VarOfTerm(*outp) > H || VarOfTerm(*outp) < H0)) {
tf[0] = Yap_MkNewApplTerm(Yap_MkFunctor(AtomRead,1),1);
} else {
tf[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomRead,1),1,outp);
}
{
Term t[3];
t[0] = MkIntegerTerm(start);
t[1] = MkIntegerTerm(err);
t[2] = MkIntegerTerm(end);
tf[1] = Yap_MkApplTerm(Yap_MkFunctor(AtomBetween,3),3,t);
}
tf[2] = MkAtomTerm(AtomHERE);
tf[4] = MkIntegerTerm(out);
tf[5] = MkIntegerTerm(err);
tf[6] = StreamName(st);
return(Yap_MkApplTerm(FunctorSyntaxError,7,tf));
}