diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

;Merge ../../yap-6.3

Browse Source
This commit is contained in:
Vitor Santos Costa
2018-06-15 13:50:55 +01:00
parent 521a5df611 d2024c1aed
commit a4dd2efbe7
3178 changed files with 59028 additions and 67702 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
C/absmi.c
View File

@@ -916,9 +916,6 @@ static int interrupt_dexecute(USES_REGS1) {
static void undef_goal(USES_REGS1) {
PredEntry *pe = PredFromDefCode(P);
CELL *b;
CELL *b0;
BEGD(d0);
/* avoid trouble with undefined dynamic procedures */
/* I assume they were not locked beforehand */
@@ -928,6 +925,15 @@ static void undef_goal(USES_REGS1) {
PP = pe;
}
#endif
if (pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag | MultiFileFlag) ) {
#if defined(YAPOR) || defined(THREADS)
UNLOCKPE(19, PP);
PP = NULL;
#endif
CalculateStackGap(PASS_REGS1);
P = FAILCODE;
return;
}
if (UndefCode == NULL || UndefCode->OpcodeOfPred == UNDEF_OPCODE) {
fprintf(stderr,"call to undefined Predicates %s ->", IndicatorOfPred(pe));
Yap_DebugPlWriteln(ARG1);
@@ -937,15 +943,6 @@ static void undef_goal(USES_REGS1) {
#if defined(YAPOR) || defined(THREADS)
UNLOCKPE(19, PP);
PP = NULL;
#endif
CalculateStackGap(PASS_REGS1);
P = FAILCODE;
return;
}
if (pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag | MultiFileFlag) ) {
#if defined(YAPOR) || defined(THREADS)
UNLOCKPE(19, PP);
PP = NULL;
#endif
CalculateStackGap(PASS_REGS1);
P = FAILCODE;
@@ -955,27 +952,16 @@ static void undef_goal(USES_REGS1) {
UNLOCKPE(19, PP);
PP = NULL;
#endif
d0 = pe->ArityOfPE;
if (pe->ModuleOfPred == PROLOG_MODULE) {
if (CurrentModule == PROLOG_MODULE)
HR[0] = MkAtomTerm(Yap_LookupAtom("prolog"));
else
HR[0] = CurrentModule;
if (pe->ArityOfPE == 0) {
d0 = MkAtomTerm((Atom)(pe->FunctorOfPred));
} else {
HR[0] = Yap_Module_Name(pe);
}
b = b0 = HR;
HR += 2;
if (d0 == 0) {
b[1] = MkAtomTerm((Atom)(pe->FunctorOfPred));
} else {
b[1] = AbsAppl(b+2);
d0 = AbsAppl(HR);
*HR++ = (CELL)pe->FunctorOfPred;
b += 3;
HR += d0;
CELL *ip=HR, *imax = HR+pe->ArityOfPE;
HR = imax;
BEGP(pt1);
pt1 = XREGS + 1;
for (; d0 > 0; --d0) {
for (; ip < imax; ip++) {
BEGD(d1);
BEGP(pt0);
pt0 = pt1++;
@@ -983,18 +969,17 @@ static void undef_goal(USES_REGS1) {
deref_head(d1, undef_unk);
undef_nonvar:
/* just copy it to the heap */
*b++ = d1;
*ip = d1;
continue;
derefa_body(d1, pt0, undef_unk, undef_nonvar);
if (pt0 <= HR) {
/* variable is safe */
*b++ = (CELL)pt0;
*ip = (CELL)pt0;
} else {
/* bind it, in case it is a local variable */
d1 = Unsigned(HR);
RESET_VARIABLE(HR);
HR += 1;
d1 = Unsigned(ip);
RESET_VARIABLE(ip);
Bind_Local(pt0, d1);
}
ENDP(pt0);
@@ -1002,9 +987,20 @@ static void undef_goal(USES_REGS1) {
}
ENDP(pt1);
}
ENDD(d0);
ARG1 = AbsPair(b0);
ARG2 = Yap_getUnknownModule(Yap_GetModuleEntry(b0[0]));
ARG1 = AbsPair(HR);
HR[1] = d0;
ENDD(d0);
if (pe->ModuleOfPred == PROLOG_MODULE) {
if (CurrentModule == PROLOG_MODULE)
HR[0] = TermProlog;
else
HR[0] = CurrentModule;
} else {
HR[0] = Yap_Module_Name(pe);
}
ARG2 = Yap_getUnknownModule(Yap_GetModuleEntry(HR[0]));
HR += 2;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred, UndefCode, XREGS + 1);

94
C/args.c
View File

@@ -38,49 +38,44 @@ int Yap_ArgKey(Atom key, const param_t *def, int n) {
return -1;
}
#define failed(e, t, a) failed__(e, t, a PASS_REGS)
#define YAP_XARGINFO(Error, Message)
static xarg *failed__(yap_error_number e, Term t, xarg *a USES_REGS) {
free(a);
LOCAL_ActiveError->errorNo = e;
LOCAL_ActiveError->rawErrorTerm = t;
return NULL;
}
xarg *Yap_ArgListToVector(Term listl, const param_t *def, int n) {
xarg *Yap_ArgListToVector__(const char *file, const char *function, int lineno,
Term listl, const param_t *def, int n,
yap_error_number err) {
CACHE_REGS
listl = Deref(listl);
xarg *a = calloc(n, sizeof(xarg));
xarg *a;
listl = Deref(listl);
if (IsVarTerm(listl)) {
return failed(INSTANTIATION_ERROR, listl, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, listl,
"while opening listl = ArgOfTerm(2, listl ,k)");
}
if (IsApplTerm(listl) && FunctorOfTerm(listl) == FunctorModule)
listl = ArgOfTerm(2, listl);
a = calloc(n, sizeof(xarg));
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsAtomTerm(listl)) {
xarg *na = matchKey(AtomOfTerm(listl), a, n, def);
if (!na) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "match key");
}
} else if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm(listl);
if (IsExtensionFunctor(f)) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "callable");
}
arity_t arity = ArityOfFunctor(f);
if (arity != 1) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "bad arity");
}
xarg *na = matchKey(NameOfFunctor(f), a, n, def);
if (!na) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, err, listl, "no match");
}
na->used = true;
na->tvalue = ArgOfTerm(1, listl);
return a;
} else {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_ATOM, listl, "not atom");
}
listl = MkPairTerm(listl, TermNil);
}
@@ -88,44 +83,45 @@ xarg *Yap_ArgListToVector(Term listl, const param_t *def, int n) {
Term hd = HeadOfTerm(listl);
listl = TailOfTerm(listl);
if (IsVarTerm(hd)) {
return failed(INSTANTIATION_ERROR, hd, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, hd, "sub-element");
}
if (IsVarTerm(listl)) {
return failed(INSTANTIATION_ERROR, listl, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, listl, "sub-list");
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey(AtomOfTerm(hd), a, n, def);
if (!na)
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
Yap_ThrowError__(file, function, lineno, err, hd, "bad match in list");
na->used = true;
na->tvalue = TermNil;
continue;
} else if (IsApplTerm(hd)) {
Functor f = FunctorOfTerm(hd);
if (IsExtensionFunctor(f)) {
return failed(TYPE_ERROR_PARAMETER, hd, a);
Yap_ThrowError__(file, function, lineno, err, hd, "bad compound");
}
arity_t arity = ArityOfFunctor(f);
if (arity != 1) {
return failed(DOMAIN_ERROR_OUT_OF_RANGE, hd, a);
Yap_ThrowError__(file, function, lineno, DOMAIN_ERROR_OUT_OF_RANGE, hd,
"high arity");
}
xarg *na = matchKey(NameOfFunctor(f), a, n, def);
if (!na) {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
Yap_ThrowError__(file, function, lineno, err, hd, "no match");
}
na->used = true;
na->tvalue = ArgOfTerm(1, hd);
} else {
return failed(TYPE_ERROR_PARAMETER, hd, a);
Yap_ThrowError__(file, function, lineno, err, hd, "bad type");
}
}
if (IsVarTerm(listl)) {
return failed(INSTANTIATION_ERROR, listl, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, listl, "unbound");
} else if (listl != TermNil) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "bad list");
}
return a;
}
}
static xarg *matchKey2(Atom key, xarg *e0, int n, const param2_t *def) {
int i;
@@ -138,50 +134,53 @@ static xarg *matchKey2(Atom key, xarg *e0, int n, const param2_t *def) {
}
return NULL;
}
/// Yap_ArgList2ToVector is much the same as before,
/// but assumes parameters also have something called a
/// scope
xarg *Yap_ArgList2ToVector(Term listl, const param2_t *def, int n) {
xarg *Yap_ArgList2ToVector__(const char *file, const char *function, int lineno,Term listl, const param2_t *def, int n, yap_error_number err) {
CACHE_REGS
xarg *a = calloc(n, sizeof(xarg));
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsVarTerm(listl)) {
return failed(INSTANTIATION_ERROR, listl, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, listl, "unbound");
}
if (IsAtomTerm(listl)) {
xarg *na = matchKey2(AtomOfTerm(listl), a, n, def);
if (!na) {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a);
Yap_ThrowError__(file, function, lineno, err,
listl, "bad match");
}
}
if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm(listl);
if (IsExtensionFunctor(f)) {
return failed(TYPE_ERROR_PARAMETER, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_PARAMETER, listl,
"bad compound");
}
arity_t arity = ArityOfFunctor(f);
if (arity != 1) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "bad arity");
}
xarg *na = matchKey2(NameOfFunctor(f), a, n, def);
if (!na) {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a);
Yap_ThrowError__(file, function, lineno, DOMAIN_ERROR_GENERIC_ARGUMENT,
listl, "bad match");
}
} else {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "");
}
listl = MkPairTerm(listl, TermNil);
}
while (IsPairTerm(listl)) {
Term hd = HeadOfTerm(listl);
if (IsVarTerm(hd)) {
return failed(INSTANTIATION_ERROR, hd, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, hd, "");
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey2(AtomOfTerm(hd), a, n, def);
if (!na) {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
Yap_ThrowError__(file, function, lineno, DOMAIN_ERROR_GENERIC_ARGUMENT,
hd, "bad match");
}
na->used = true;
na->tvalue = TermNil;
@@ -189,29 +188,32 @@ xarg *Yap_ArgList2ToVector(Term listl, const param2_t *def, int n) {
} else if (IsApplTerm(hd)) {
Functor f = FunctorOfTerm(hd);
if (IsExtensionFunctor(f)) {
return failed(TYPE_ERROR_PARAMETER, hd, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_PARAMETER, hd, "bad compound");
}
arity_t arity = ArityOfFunctor(f);
if (arity != 1) {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
Yap_ThrowError__(file, function, lineno, DOMAIN_ERROR_GENERIC_ARGUMENT,
hd, "bad arity");
}
xarg *na = matchKey2(NameOfFunctor(f), a, n, def);
if (na) {
na->used = 1;
na->tvalue = ArgOfTerm(1, hd);
} else {
return failed(DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
Yap_ThrowError__(file, function, lineno, err,
hd, "bad key");
}
return a;
} else {
return failed(INSTANTIATION_ERROR, hd, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, hd, "unbound");
}
listl = TailOfTerm(listl);
}
if (IsVarTerm(listl)) {
return failed(INSTANTIATION_ERROR, listl, a);
Yap_ThrowError__(file, function, lineno, INSTANTIATION_ERROR, listl, "");
}
if (TermNil != listl) {
return failed(TYPE_ERROR_LIST, listl, a);
Yap_ThrowError__(file, function, lineno, TYPE_ERROR_LIST, listl, "");
}
return a;
}

1
C/arith0.c
View File

@@ -284,6 +284,7 @@ Yap_InitConstExps(void)
}
}
/* This routine is called from Restore to make sure we have the same arithmetic operators */
int
Yap_ReInitConstExps(void)

879
C/arith1.c
View File

File diff suppressed because it is too large Load Diff

131
C/arith2.c
View File

@@ -213,7 +213,7 @@ p_div2(Term t1, Term t2 USES_REGS) {
Yap_ArithError(EVALUATION_ERROR_ZERO_DIVISOR, t2, "X is " Int_FORMAT " div 0", i1);
if (i1 == Int_MIN && i2 == -1) {
#ifdef USE_GMP
return Yap_gmp_add_ints(Int_MAX, 1);
return Yap_gmp_add_ints(Int_MAX, 1);
#else
Yap_ArithError(EVALUATION_ERROR_INT_OVERFLOW, t1,
"// /2 with %d and %d", i1, i2);
@@ -443,7 +443,7 @@ p_xor(Term t1, Term t2 USES_REGS)
{
switch (ETypeOfTerm(t1)) {
case long_int_e:
switch (ETypeOfTerm(t2)) {
case long_int_e:
/* two integers */
@@ -643,7 +643,7 @@ p_power(Term t1, Term t2 USES_REGS)
}
/* next function is adapted from:
Inline C++ integer exponentiation routines
Inline C++ integer exponentiation routines
Version 1.01
Copyright (C) 1999-2004 John C. Bowman <bowman@math.ualberta.ca>
*/
@@ -654,9 +654,9 @@ ipow(Int x, Int p)
if (p == 0) return ((CELL)1);
if (x == 0 && p > 0) return 0L;
if(p < 0)
if(p < 0)
return (-p % 2) ? x : ((CELL)1);
r = ((CELL)1);
for(;;) {
if(p & 1) {
@@ -1142,32 +1142,20 @@ static InitBinEntry InitBinTab[] = {
{"rdiv", op_rdiv}
};
static Int
static Int
p_binary_is( USES_REGS1 )
{ /* X is Y */
Term t = Deref(ARG2);
Term t1, t2;
yap_error_number err;
Term t1, t2, tout;
if (IsVarTerm(t)) {
Yap_ArithError(INSTANTIATION_ERROR,t, "VAR(X , Y)");
return(FALSE);
}
Yap_ClearExs();
t1 = Yap_Eval(Deref(ARG3));
if ((err = Yap_FoundArithError())) {
Atom name;
if (IsIntTerm(t)) {
Int i = IntOfTerm(t);
name = Yap_NameOfBinaryOp(i);
} else {
name = AtomOfTerm(Deref(ARG2));
}
Yap_EvalError(err,ARG3,"X is ~s/2: error in first argument ", RepAtom(name)->StrOfAE);
return FALSE;
}
Yap_ClearExs();
t1 = Yap_Eval(Deref(ARG3));
t2 = Yap_Eval(Deref(ARG4));
if ((err=Yap_FoundArithError())) {
{
Atom name;
if (IsIntTerm(t)) {
Int i = IntOfTerm(t);
@@ -1175,134 +1163,113 @@ p_binary_is( USES_REGS1 )
} else {
name = AtomOfTerm(Deref(ARG2));
}
Yap_EvalError(err,ARG3,"X is ~s/2: error in first argument ", RepAtom(name)->StrOfAE);
return FALSE;
}
if (IsIntTerm(t)) {
Int i = IntOfTerm(t);
Term tout = eval2(i, t1, t2 PASS_REGS);
if ((err = Yap_FoundArithError()) != YAP_NO_ERROR) {
Term ts[2], terr;
Atom name = Yap_NameOfBinaryOp( i );
Functor f = Yap_MkFunctor( name, 2 );
ts[0] = t1;
ts[1] = t2;
terr = Yap_MkApplTerm( f, 2, ts );
Yap_EvalError(err, terr ,"error in %s/2 ", RepAtom(name)->StrOfAE);
return FALSE;
}
bool go;
do {
go = false;
tout = eval2(i, t1, t2 PASS_REGS);
go = Yap_CheckArithError();
} while (go);
return Yap_unify_constant(ARG1,tout);
}
if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
Term out;
bool go;
int j;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 2)))) {
Yap_EvalError(TYPE_ERROR_EVALUABLE, takeIndicator(t),
"functor %s/2 for arithmetic expression",
RepAtom(name)->StrOfAE);
P = FAILCODE;
return(FALSE);
Yap_EvalError(TYPE_ERROR_EVALUABLE, t, "`%s ", name->StrOfAE
);
}
out= eval2(p->FOfEE, t1, t2 PASS_REGS);
if ((err = Yap_FoundArithError()) != YAP_NO_ERROR) {
Term ts[2], terr;
Functor f = Yap_MkFunctor( name, 2 );
ts[0] = t1;
ts[1] = t2;
terr = Yap_MkApplTerm( f, 2, ts );
Yap_EvalError(err, terr ,"error in ~s/2 ", RepAtom(name)->StrOfAE);
return FALSE;
}
return Yap_unify_constant(ARG1,out);
j = p->FOfEE;
do {
go = false;
Yap_ClearExs();
tout = eval2(j, t1, t2 PASS_REGS);
go = Yap_CheckArithError();
} while (go);
return Yap_unify_constant(ARG1,tout);
}
return FALSE;
}
static Int
static Int
do_arith23(arith2_op op USES_REGS)
{ /* X is Y */
Term t = Deref(ARG1);
Int out;
Term t1, t2;
yap_error_number err;
bool go;
Term t1, t2, out;
Yap_ClearExs();
if (IsVarTerm(t)) {
Yap_EvalError(INSTANTIATION_ERROR,t, "X is Y");
return(FALSE);
}
t1 = Yap_Eval(t);
if (t1 == 0L)
return FALSE;
do {
go = false;
Yap_ClearExs();
t1 = Yap_Eval(t);
t2 = Yap_Eval(Deref(ARG2));
if (t2 == 0L)
return FALSE;
out= eval2(op, t1, t2 PASS_REGS);
if ((err=Yap_FoundArithError())) {
Term ts[2], t;
Functor f = Yap_MkFunctor( Yap_NameOfBinaryOp(op), 2 );
ts[0] = t1;
ts[1] = t2;
t = Yap_MkApplTerm( f, 2, ts );
Yap_EvalError(err, t ,"error in ~s(Y,Z) ",Yap_NameOfBinaryOp(op));
return FALSE;
}
go = Yap_CheckArithError();
} while (go);
return Yap_unify_constant(ARG3,out);
}
static Int
static Int
export_p_plus( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_plus PASS_REGS);
}
static Int
static Int
export_p_minus( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_minus PASS_REGS);
}
static Int
static Int
export_p_times( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_times PASS_REGS);
}
static Int
static Int
export_p_div( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_div PASS_REGS);
}
static Int
static Int
export_p_and( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_and PASS_REGS);
}
static Int
static Int
export_p_or( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_or PASS_REGS);
}
static Int
static Int
export_p_slr( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_slr PASS_REGS);
}
static Int
static Int
export_p_sll( USES_REGS1 )
{ /* X is Y */
return do_arith23(op_sll PASS_REGS);
}
static Int
static Int
p_binary_op_as_integer( USES_REGS1 )
{ /* X is Y */
Term t = Deref(ARG1);
@@ -1317,7 +1284,6 @@ p_binary_op_as_integer( USES_REGS1 )
if (IsAtomTerm(t)) {
Atom name = AtomOfTerm(t);
ExpEntry *p;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 2)))) {
return Yap_unify(ARG1,ARG2);
}
@@ -1376,4 +1342,3 @@ Yap_ReInitBinaryExps(void)
{
return(TRUE);
}

8
C/arrays.c
View File

@@ -15,7 +15,13 @@
* *
*************************************************************************/
/** @defgroup YAPArrays Named Arrays
/**
@file arrays.c
@namespace prolog
@addtogroup YAPArrays Named Arrays
@ingroup extensions
@{

150
C/atomic.c
View File

@@ -1,4 +1,3 @@
/*************************************************************************
* *
* YAP Prolog *
@@ -22,16 +21,21 @@ static char SccsId[] = "%W% %G%";
/**
* @file atomic.c
*
* @namespace prolog
*
*/
/**
* @defgroup Predicates_on_Atoms Predicates on Atoms and Strings
* @ingroup builtins
* @{
@brief The following predicates are used to manipulate atoms, strings, lists of
codes and lists of chars:
\toc
*/
*
* @brief The following predicates are used to manipulate atoms, strings, lists
* of codes and lists of chars:
*
* \toc
*
*/
#define HAS_CACHE_REGS 1
/*
@@ -695,17 +699,14 @@ restart_aux:
static Int number_chars(USES_REGS1) {
Term t1;
int l = push_text_stack();
restart_aux:
t1 = Deref(ARG1);
if (IsNumTerm(t1)) {
Term t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
t1 = Yap_NumberToListOfAtoms(t1 PASS_REGS);
}
if (t1) {
Term t12 = Yap_NumberToListOfAtoms(t1 PASS_REGS);
if (t12 && t2) {
{
pop_text_stack(l);
return Yap_unify(t1, t2);
return Yap_unify(t12, t2);
}
}
} else if (IsVarTerm(t1)) {
@@ -713,25 +714,19 @@ restart_aux:
Term t = Deref(ARG2);
Term tf = Yap_ListToNumber(t PASS_REGS);
if (tf) {
{
pop_text_stack(l);
return Yap_unify(ARG1, tf);
}
pop_text_stack(l);
return Yap_unify(ARG1, tf);
}
} else if (IsVarTerm(t1)) {
LOCAL_Error_TYPE = TYPE_ERROR_NUMBER;
}
/* error handling */
if (LOCAL_Error_TYPE && Yap_HandleError("number_chars/2")) {
goto restart_aux;
}
{
pop_text_stack(l);
LOCAL_ActiveError->errorRawTerm = 0;
Yap_ThrowExistingError();
return false;
}
return true;
}
/** @pred number_atom(? _I_,? _A_)
/** @pred number_atom(? _I_,? _A_){te
@@ -908,7 +903,6 @@ restart_aux:
if (Yap_HandleError("atom_concat/3")) {
goto restart_aux;
}
return false;
}
cut_fail();
}
@@ -959,8 +953,6 @@ restart_aux:
if (LOCAL_Error_TYPE) {
if (Yap_HandleError("atom_concat/3")) {
goto restart_aux;
} else {
return false;
}
}
cut_fail();
@@ -1333,8 +1325,7 @@ restart_aux:
}
while (t1 != TermNil) {
inpv[i].type = YAP_STRING_ATOM,
inpv[i].val.t = HeadOfTerm(t1);
inpv[i].type = YAP_STRING_ATOM, inpv[i].val.t = HeadOfTerm(t1);
i++;
t1 = TailOfTerm(t1);
}
@@ -1372,12 +1363,11 @@ restart_aux:
if (*tailp != TermNil) {
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
} else {
seq_tv_t *inpv = (seq_tv_t *)malloc(n * sizeof(seq_tv_t)), out;
seq_tv_t *inpv = (seq_tv_t *)Malloc(n * sizeof(seq_tv_t));
seq_tv_t *out = (seq_tv_t *)Malloc( sizeof(seq_tv_t));
int i = 0;
if (!inpv) {
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
free(inpv);
goto error;
}
@@ -1387,15 +1377,14 @@ restart_aux:
i++;
t1 = TailOfTerm(t1);
}
out.type = YAP_STRING_STRING;
if (!Yap_Concat_Text(n, inpv, &out PASS_REGS)) {
free(inpv);
out->type = YAP_STRING_STRING;
if (!Yap_Concat_Text(n, inpv, out PASS_REGS)) {
goto error;
}
free(inpv);
if (out.val.t) {
if (out->val.t) {
bool rc = Yap_unify(ARG2, out->val.t);
pop_text_stack(l);
return Yap_unify(ARG2, out.val.t);
return rc;
}
}
error:
@@ -1424,17 +1413,18 @@ restart_aux:
if (*tailp != TermNil) {
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
} else {
seq_tv_t *inpv = (seq_tv_t *)malloc(n * sizeof(seq_tv_t)), out;
seq_tv_t *inpv = (seq_tv_t *)Malloc(n * sizeof(seq_tv_t));
seq_tv_t *out = (seq_tv_t *)Malloc(sizeof(seq_tv_t));
int i = 0;
Atom at;
if (n == 1) {
bool rc = Yap_unify(ARG2, HeadOfTerm(t1));
pop_text_stack(l);
return Yap_unify(ARG2, HeadOfTerm(t1));
return rc;
}
if (!inpv) {
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
free(inpv);
goto error;
}
@@ -1446,16 +1436,15 @@ restart_aux:
i++;
t1 = TailOfTerm(t1);
}
out.type = YAP_STRING_ATOM;
if (!Yap_Concat_Text(n, inpv, &out PASS_REGS)) {
free(inpv);
out->type = YAP_STRING_ATOM;
if (!Yap_Concat_Text(n, inpv, out PASS_REGS)) {
goto error;
}
free(inpv);
at = out.val.a;
at = out->val.a;
pop_text_stack(l);
if (at) {
pop_text_stack(l);
return Yap_unify(ARG2, MkAtomTerm(at));
bool rc = Yap_unify(ARG2, MkAtomTerm(at));
return rc;
}
}
error:
@@ -1464,7 +1453,6 @@ error:
goto restart_aux;
}
{
pop_text_stack(l);
return FALSE;
}
}
@@ -1480,13 +1468,12 @@ restart_aux:
if (*tailp != TermNil) {
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
} else {
seq_tv_t *inpv = (seq_tv_t *)malloc(n * sizeof(seq_tv_t)), out;
seq_tv_t *inpv = (seq_tv_t *)Malloc(n * sizeof(seq_tv_t)), out;
int i = 0;
Atom at;
if (!inpv) {
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
free(inpv);
goto error;
}
@@ -1499,10 +1486,8 @@ restart_aux:
}
out.type = YAP_STRING_STRING;
if (!Yap_Concat_Text(n, inpv, &out PASS_REGS)) {
free(inpv);
goto error;
}
free(inpv);
at = out.val.a;
if (at) {
pop_text_stack(l);
@@ -1532,13 +1517,12 @@ restart_aux:
if (*tailp != TermNil) {
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
} else {
seq_tv_t *inpv = (seq_tv_t *)malloc((n * 2 - 1) * sizeof(seq_tv_t)), out;
seq_tv_t *inpv = (seq_tv_t *)Malloc((n * 2 - 1) * sizeof(seq_tv_t)), out;
int i = 0;
Atom at;
if (!inpv) {
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
free(inpv);
goto error;
}
@@ -1555,10 +1539,8 @@ restart_aux:
}
out.type = YAP_STRING_STRING;
if (!Yap_Concat_Text(2 * n - 1, inpv, &out PASS_REGS)) {
free(inpv);
goto error;
}
free(inpv);
at = out.val.a;
if (at) {
pop_text_stack(l);
@@ -2308,6 +2290,8 @@ static Int cont_sub_atomic(USES_REGS1) {
}
} else if (mask & SUB_ATOM_HAS_SIZE) {
Term nat = build_new_atomic(mask, p, minv, len PASS_REGS);
if (nat == 0)
Yap_ThrowExistingError();
Yap_unify(ARG2, MkIntegerTerm(minv));
Yap_unify(ARG4, MkIntegerTerm(after));
Yap_unify(ARG5, nat);
@@ -2318,6 +2302,8 @@ static Int cont_sub_atomic(USES_REGS1) {
} else if (mask & SUB_ATOM_HAS_MIN) {
after = sz - (minv + len);
Term nat = build_new_atomic(mask, p, minv, len PASS_REGS);
if (nat == 0)
Yap_ThrowExistingError();
Yap_unify(ARG3, MkIntegerTerm(len));
Yap_unify(ARG4, MkIntegerTerm(after));
Yap_unify(ARG5, nat);
@@ -2328,6 +2314,8 @@ static Int cont_sub_atomic(USES_REGS1) {
} else if (mask & SUB_ATOM_HAS_AFTER) {
len = sz - (minv + after);
Term nat = build_new_atomic(mask, p, minv, len PASS_REGS);
if (nat == 0)
Yap_ThrowExistingError();
Yap_unify(ARG2, MkIntegerTerm(minv));
Yap_unify(ARG3, MkIntegerTerm(len));
Yap_unify(ARG5, nat);
@@ -2337,6 +2325,8 @@ static Int cont_sub_atomic(USES_REGS1) {
}
} else {
Term nat = build_new_atomic(mask, p, minv, len PASS_REGS);
if (nat == 0)
Yap_ThrowExistingError();
Yap_unify(ARG2, MkIntegerTerm(minv));
Yap_unify(ARG3, MkIntegerTerm(len));
Yap_unify(ARG4, MkIntegerTerm(after));
@@ -2482,39 +2472,39 @@ static Int sub_atomic(bool sub_atom, bool sub_string USES_REGS) {
(SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_VAL | SUB_ATOM_HAS_AFTER)) {
const unsigned char *sm;
if (sub_atom)
sm = RepAtom(AtomOfTerm(tout))->UStrOfAE;
sm = RepAtom(AtomOfTerm(tout))->UStrOfAE;
else
sm = UStringOfTerm(tout);
sm = UStringOfTerm(tout);
if (mask & SUB_ATOM_HAS_SIZE) {
if (len != strlen_utf8(sm) ) {
cut_fail();
} else {
len = strlen_utf8(sm);
}
if (len != strlen_utf8(sm)) {
cut_fail();
} else {
len = strlen_utf8(sm);
}
}
if (sz != minv+len+after) {
cut_fail();
}
return do_cut(check_sub_string_at(
minv, p, sm, len));
if (sz != minv + len + after) {
cut_fail();
}
return do_cut(check_sub_string_at(minv, p, sm, len));
} else if ((mask & (SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_VAL)) ==
(SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_VAL)) {
if (! Yap_unify(ARG4,MkIntegerTerm(sz-minv-len)) )
cut_fail();
if (sub_atom)
(SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_VAL)) {
if (!Yap_unify(ARG4, MkIntegerTerm(sz - minv - len)))
cut_fail();
if (sub_atom)
return do_cut(check_sub_string_at(
minv, p, RepAtom(AtomOfTerm(tout))->UStrOfAE, len));
else
return do_cut(check_sub_string_at(minv, p, UStringOfTerm(tout), len));
} else if ((mask & (SUB_ATOM_HAS_AFTER | SUB_ATOM_HAS_VAL)) ==
(SUB_ATOM_HAS_AFTER | SUB_ATOM_HAS_VAL)) {
if (! Yap_unify(ARG2,MkIntegerTerm(sz-after-len)) )
cut_fail();
if (!Yap_unify(ARG2, MkIntegerTerm(sz - after - len)))
cut_fail();
if (sub_atom) {
return do_cut(check_sub_string_bef(
sz - after, p, RepAtom(AtomOfTerm(tout))->UStrOfAE));
} else {
return do_cut(check_sub_string_bef(sz - after, p, UStringOfTerm(tout)));}
return do_cut(check_sub_string_bef(sz - after, p, UStringOfTerm(tout)));
}
} else if ((mask & (SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_SIZE)) ==
(SUB_ATOM_HAS_MIN | SUB_ATOM_HAS_SIZE)) {
if (minv + len + after > sz) {

53
C/attvar.c
View File

@@ -8,31 +8,39 @@
* *
**************************************************************************
* *
* File: attvar.c *
* Last rev: *
* mods: *
* comments: YAP support for attributed vars *
* File: attvar.c * Last rev:
** mods: * comments: YAP support for attributed vars *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/**
* @file attvar.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:31:59 2018
*
* @brief attributed variables
* @namespace prolog
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "heapgc.h"
#include "Yatom.h"
#include "attvar.h"
#include "heapgc.h"
#ifndef NULL
#define NULL (void *)0
#endif
/**
@defgroup AttributedVariables_Builtins Low-level support for Attributed Variables
@defgroup AttributedVariables_Builtins Low-level support for Attributed
Variables
@brief Implementation of Attribute Declarations
@ingroup attributes
@ingroup AttributedVariables
@{
*/
@@ -202,7 +210,7 @@ static void WakeAttVar(CELL *pt1, CELL reg2 USES_REGS) {
void Yap_WakeUp(CELL *pt0) {
CACHE_REGS
CELL d0 = *pt0;
CELL d0 = *pt0;
RESET_VARIABLE(pt0);
WakeAttVar(pt0, d0 PASS_REGS);
}
@@ -675,7 +683,6 @@ static Int free_att(USES_REGS1) {
}
}
static Int get_atts(USES_REGS1) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
@@ -887,7 +894,7 @@ static Term AllAttVars(USES_REGS1) {
while (pt < myH) {
switch (*pt) {
case (CELL) FunctorAttVar:
case (CELL)FunctorAttVar:
if (IsUnboundVar(pt + 1)) {
if (ASP - myH < 1024) {
LOCAL_Error_Size = (ASP - HR) * sizeof(CELL);
@@ -901,24 +908,23 @@ static Term AllAttVars(USES_REGS1) {
}
pt += (1 + ATT_RECORD_ARITY);
break;
case (CELL) FunctorDouble:
case (CELL)FunctorDouble:
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
pt += 4;
#else
pt += 3;
#endif
break;
case (CELL) FunctorString:
case (CELL)FunctorString:
pt += 3 + pt[1];
break;
case (CELL) FunctorBigInt: {
Int sz = 3 +
(sizeof(MP_INT) +
(((MP_INT *)(pt + 2))->_mp_alloc * sizeof(mp_limb_t))) /
sizeof(CELL);
case (CELL)FunctorBigInt: {
Int sz = 3 + (sizeof(MP_INT) +
(((MP_INT *)(pt + 2))->_mp_alloc * sizeof(mp_limb_t))) /
sizeof(CELL);
pt += sz;
} break;
case (CELL) FunctorLongInt:
case (CELL)FunctorLongInt:
pt += 3;
break;
default:
@@ -967,7 +973,7 @@ static Int is_attvar(USES_REGS1) {
static Int attvar_bound(USES_REGS1) {
Term t = Deref(ARG1);
return IsVarTerm(t) && IsAttachedTerm(t) &&
!IsUnboundVar(&(RepAttVar(VarOfTerm(t))->Done));
!IsUnboundVar(&(RepAttVar(VarOfTerm(t))->Done));
}
static Int void_term(USES_REGS1) { return Yap_unify(ARG1, TermVoidAtt); }
@@ -1007,7 +1013,7 @@ static Int attvar_bound(USES_REGS1) { return FALSE; }
void Yap_InitAttVarPreds(void) {
CACHE_REGS
Term OldCurrentModule = CurrentModule;
Term OldCurrentModule = CurrentModule;
CurrentModule = ATTRIBUTES_MODULE;
#ifdef COROUTINING
GLOBAL_attas[attvars_ext].bind_op = WakeAttVar;
@@ -1029,8 +1035,7 @@ void Yap_InitAttVarPreds(void) {
Yap_InitCPred("rm_att", 4, rm_att, 0);
Yap_InitCPred("bind_attvar", 1, bind_attvar, SafePredFlag);
Yap_InitCPred("unbind_attvar", 1, unbind_attvar, SafePredFlag);
Yap_InitCPred("modules_with_attributes", 2, modules_with_atts,
SafePredFlag);
Yap_InitCPred("modules_with_attributes", 2, modules_with_atts, SafePredFlag);
Yap_InitCPred("void_term", 1, void_term, SafePredFlag);
Yap_InitCPred("free_term", 1, free_term, SafePredFlag);
Yap_InitCPred("fast_unify_attributed", 2, fast_unify, 0);

11
C/bb.c
View File

@@ -18,6 +18,17 @@
static char SccsId[] = "%W% %G%";
#endif
/**
* @file bb.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:32:54 2018
*
* @brief blackboard
*
* @namespace prolog
*
*/
/** @defgroup BlackBoard The Blackboard
@ingroup builtins

24
C/bignum.c
View File

@@ -17,6 +17,17 @@
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/**
* @file bignum.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:34:59 2018
*
* @brief BigNums and More
* @namespace prolog
*
*
*
*/
#include "Yap.h"
#include "Yatom.h"
@@ -440,7 +451,11 @@ static Int p_is_opaque(USES_REGS1) {
return FALSE;
}
static Int p_is_rational(USES_REGS1) {
/** @pred rational( ?:T )
Checks whether _T_ is a rational number.
*/
static Int p_is_rational(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
@@ -499,13 +514,6 @@ void Yap_InitBigNums(void) {
Yap_InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
Yap_InitCPred("rational", 3, p_rational, 0);
Yap_InitCPred("rational", 1, p_is_rational, SafePredFlag);
/** @pred rational( _T_)
Checks whether `T` is a rational number.
*/
Yap_InitCPred("string", 1, p_is_string, SafePredFlag);
Yap_InitCPred("opaque", 1, p_is_opaque, SafePredFlag);
Yap_InitCPred("nb_set_bit", 2, p_nb_set_bit, SafePredFlag);

147
C/c_interface.c
View File

@@ -1454,8 +1454,7 @@ X_API Term YAP_ReadBuffer(const char *s, Term *tp) {
else
tv = (Term)0;
LOCAL_ErrorMessage = NULL;
const unsigned char *us = (const unsigned char *)s;
while (!(t = Yap_BufferToTermWithPrioBindings(us, TermNil, tv, strlen(s) + 1, GLOBAL_MaxPriority))) {
while (!(t = Yap_BufferToTermWithPrioBindings(s, TermNil, tv, strlen(s) + 1, GLOBAL_MaxPriority))) {
if (LOCAL_ErrorMessage) {
if (!strcmp(LOCAL_ErrorMessage, "Stack Overflow")) {
if (!Yap_dogc(0, NULL PASS_REGS)) {
@@ -1722,11 +1721,14 @@ X_API bool YAP_EnterGoal(YAP_PredEntryPtr ape, CELL *ptr, YAP_dogoalinfo *dgi) {
CACHE_REGS
PredEntry *pe = ape;
bool out;
// fprintf(stderr,"EnterGoal: H=%d ENV=%p B=%d TR=%d P=%p CP=%p Slots=%d\n",HR-H0,LCL0-ENV,LCL0-(CELL*)B,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
BACKUP_MACHINE_REGS();
LOCAL_ActiveError->errorNo = YAP_NO_ERROR;
LOCAL_PrologMode = UserMode;
dgi->p = P;
dgi->cp = CP;
dgi->b0 = LCL0 - (CELL *)B;
dgi->CurSlot = LOCAL_CurSlot;
// ensure our current ENV receives current P.
@@ -1736,7 +1738,13 @@ X_API bool YAP_EnterGoal(YAP_PredEntryPtr ape, CELL *ptr, YAP_dogoalinfo *dgi) {
// slot=%d", pe, pe->CodeOfPred->opc, FAILCODE, Deref(ARG1), Deref(ARG2),
// LOCAL_CurSlot);
dgi->b = LCL0 - (CELL *)B;
dgi->h = HR-H0;
dgi->tr = (CELL*)TR-LCL0;
//fprintf(stderr,"PrepGoal: H=%d ENV=%p B=%d TR=%d P=%p CP=%p Slots=%d\n",
// HR-H0,LCL0-ENV,LCL0-(CELL*)B,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
out = Yap_exec_absmi(true, false);
// fprintf(stderr,"EnterGoal success=%d: H=%d ENV=%p B=%d TR=%d P=%p CP=%p Slots=%d\n", out,HR-H0,LCL0-ENV,LCL0-(CELL*)B,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
dgi->b = LCL0 - (CELL *)B;
if (out) {
dgi->EndSlot = LOCAL_CurSlot;
Yap_StartSlots();
@@ -1750,16 +1758,23 @@ X_API bool YAP_EnterGoal(YAP_PredEntryPtr ape, CELL *ptr, YAP_dogoalinfo *dgi) {
X_API bool YAP_RetryGoal(YAP_dogoalinfo *dgi) {
CACHE_REGS
choiceptr myB;
choiceptr myB, myB0;
bool out;
BACKUP_MACHINE_REGS();
myB = (choiceptr)(LCL0 - dgi->b);
CP = myB->cp_cp;
myB0 = (choiceptr)(LCL0 - dgi->b0);
CP = myB->cp_cp;
/* sanity check */
if (B >= myB) {
if (B >= myB0) {
return false;
}
if (B < myB) {
// get rid of garbage choice-points
B = myB;
}
//fprintf(stderr,"RetryGoal: H=%d ENV=%p B=%d TR=%d P=%p CP=%p Slots=%d\n",
// HR-H0,LCL0-ENV,LCL0-(CELL*)B,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
P = FAILCODE;
/* make sure we didn't leave live slots when we backtrack */
ASP = (CELL *)B;
@@ -1767,6 +1782,7 @@ X_API bool YAP_RetryGoal(YAP_dogoalinfo *dgi) {
out = run_emulator(PASS_REGS1);
if (out) {
dgi->EndSlot = LOCAL_CurSlot;
dgi->b = LCL0-(CELL *)B;
} else {
LOCAL_CurSlot =
dgi->CurSlot; // ignore any slots created within the called goal
@@ -1775,58 +1791,44 @@ X_API bool YAP_RetryGoal(YAP_dogoalinfo *dgi) {
return out;
}
X_API bool YAP_LeaveGoal(bool backtrack, YAP_dogoalinfo *dgi) {
X_API bool YAP_LeaveGoal(bool successful, YAP_dogoalinfo *dgi) {
CACHE_REGS
choiceptr myB;
choiceptr myB, handler;
bool backtrack = false;
// fprintf(stderr,"LeaveGoal success=%d: H=%d ENV=%p B=%ld myB=%ld TR=%d P=%p CP=%p Slots=%d\n", successful,HR-H0,LCL0-ENV,LCL0-(CELL*)B,dgi->b0,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
BACKUP_MACHINE_REGS();
myB = (choiceptr)(LCL0 - dgi->b);
if (B > myB) {
/* someone cut us */
return FALSE;
myB = (choiceptr)(LCL0 - dgi->b0);
handler = B;
while (handler
//&& LOCAL_CBorder > LCL0 - (CELL *)handler
//&& handler->cp_ap != NOCODE
&& handler->cp_b != NULL
&& handler != myB
) {
handler->cp_ap = TRUSTFAILCODE;
handler = handler->cp_b;
}
/* prune away choicepoints */
if (B != myB) {
#ifdef YAPOR
CUT_prune_to(myB);
#endif
B = myB;
if (LOCAL_PrologMode & AsyncIntMode) {
Yap_signal(YAP_FAIL_SIGNAL);
}
/* if backtracking asked for, recover space and bindings */
if (backtrack) {
P = FAILCODE;
B = handler;
if (successful) {
Yap_TrimTrail();
CP = dgi->cp;
P = dgi->p;
} else {
Yap_exec_absmi(true, YAP_EXEC_ABSMI);
/* recover stack space */
LOCAL_CurSlot = dgi->CurSlot;
ENV = YENV = B->cp_env;
HR = B->cp_h;
TR = B->cp_tr;
#ifdef DEPTH_LIMIT
DEPTH = B->cp_depth;
#endif /* DEPTH_LIMIT */
YENV = ENV = B->cp_env;
} else {
Yap_TrimTrail();
// use the current choicepoint
// B=B->cp_b;
ASP=(CELL*)B;
}
/* recover local stack */
#ifdef DEPTH_LIMIT
DEPTH = ENV[E_DEPTH];
#endif
/* make sure we prune C-choicepoints */
if (POP_CHOICE_POINT(B->cp_b)) {
POP_EXECUTE();
}
ENV = (CELL *)(ENV[E_E]);
/* ASP should be set to the top of the local stack when we
did the call */
ASP = B->cp_env;
/* YENV should be set to the current environment */
YENV = ENV = (CELL *)((B->cp_env)[E_E]);
B = B->cp_b;
// SET_BB(B);
HB = PROTECT_FROZEN_H(B);
CP = dgi->cp;
P = dgi->p;
LOCAL_CurSlot = dgi->CurSlot;
RECOVER_MACHINE_REGS();
// fprintf(stderr,"LeftGoal success=%d: H=%d ENV=%p B=%d TR=%d P=%p CP=%p Slots=%d\n", successful,HR-H0,LCL0-ENV,LCL0-(CELL*)B,(CELL*)TR-LCL0, P, CP, LOCAL_CurSlot);
return TRUE;
}
@@ -1955,7 +1957,7 @@ X_API Int YAP_RunGoalOnce(Term t) {
}
// should we catch the exception or pass it through?
// We'll pass it through
Yap_RaiseException();
// Yap_RaiseException();
if (out) {
choiceptr cut_pt, ob;
@@ -2091,9 +2093,7 @@ X_API void YAP_PruneGoal(YAP_dogoalinfo *gi) {
X_API bool YAP_GoalHasException(Term *t) {
CACHE_REGS
BACKUP_MACHINE_REGS();
if (t)
*t = Yap_PeekException();
return Yap_PeekException();
return LOCAL_ActiveError->errorNo != YAP_NO_ERROR;
}
X_API void YAP_ClearExceptions(void) {
@@ -2102,7 +2102,7 @@ X_API void YAP_ClearExceptions(void) {
Yap_ResetException(worker_id);
}
X_API int YAP_InitConsult(int mode, const char *fname, char *full, int *osnop) {
X_API int YAP_InitConsult(int mode, const char *fname, char **full, int *osnop) {
CACHE_REGS
int sno;
BACKUP_MACHINE_REGS();
@@ -2117,19 +2117,25 @@ X_API int YAP_InitConsult(int mode, const char *fname, char *full, int *osnop) {
fl = Yap_AbsoluteFile(fname, true);
if (!fl || !fl[0]) {
pop_text_stack(lvl);
*full = NULL;
return -1;
}
}
bool consulted = (mode == YAP_CONSULT_MODE);
sno = Yap_OpenStream(fl, "r", MkAtomTerm(Yap_LookupAtom(fl)));
if (sno < 0)
return sno;
if (!Yap_ChDir(dirname((char *)fl))) return -1;
sno = Yap_OpenStream(MkStringTerm(fl), "r", MkAtomTerm(Yap_LookupAtom(fl)), LOCAL_encoding);
if (sno < 0 ||
!Yap_ChDir(dirname((char *)fl))) {
pop_text_stack(lvl);
*full = NULL;
return -1;
}
LOCAL_PrologMode = UserMode;
Yap_init_consult(consulted, fl);
GLOBAL_Stream[sno].name = Yap_LookupAtom(fl);
GLOBAL_Stream[sno].user_name = MkAtomTerm(Yap_LookupAtom(fname));
GLOBAL_Stream[sno].encoding = LOCAL_encoding;
pop_text_stack(lvl);
*full = pop_output_text_stack(lvl, fl);
RECOVER_MACHINE_REGS();
UNLOCK(GLOBAL_Stream[sno].streamlock);
return sno;
@@ -2254,11 +2260,12 @@ X_API int YAP_WriteDynamicBuffer(YAP_Term t, char *buf, size_t sze,
return true;
}
X_API char *YAP_CompileClause(Term t) {
X_API bool YAP_CompileClause(Term t) {
CACHE_REGS
yamop *codeaddr;
Term mod = CurrentModule;
Term tn = TermNil;
bool ok = true;
BACKUP_MACHINE_REGS();
@@ -2267,12 +2274,14 @@ X_API char *YAP_CompileClause(Term t) {
ARG1 = t;
YAPEnterCriticalSection();
codeaddr = Yap_cclause(t, 0, mod, t);
if (codeaddr != NULL) {
ok = (codeaddr != NULL);
if (ok) {
t = Deref(ARG1); /* just in case there was an heap overflow */
if (!Yap_addclause(t, codeaddr, TermAssertz, mod, &tn)) {
YAPLeaveCriticalSection();
return LOCAL_ErrorMessage;
ok = false;
}
} else {
ok = false;
}
YAPLeaveCriticalSection();
@@ -2280,10 +2289,14 @@ X_API char *YAP_CompileClause(Term t) {
if (!Yap_locked_growheap(FALSE, 0, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "YAP failed to grow heap: %s",
LOCAL_ErrorMessage);
ok = false;
}
}
RECOVER_MACHINE_REGS();
return (LOCAL_ErrorMessage);
if (!ok) {
return NULL;
}
return ok;
}
X_API void YAP_PutValue(YAP_Atom at, Term t) { Yap_PutValue(at, t); }
@@ -2324,7 +2337,7 @@ X_API void *YAP_RepStreamFromId(int sno) { return GLOBAL_Stream + sno; }
X_API void YAP_CloseAllOpenStreams(void) {
BACKUP_H();
Yap_CloseStreams(FALSE);
Yap_CloseStreams();
RECOVER_H();
}
@@ -2339,7 +2352,9 @@ X_API void YAP_FlushAllStreams(void) {
X_API void YAP_Throw(Term t) {
BACKUP_MACHINE_REGS();
Yap_JumpToEnv(t);
LOCAL_ActiveError->errorNo = THROW_EVENT;
LOCAL_ActiveError->errorGoal = Yap_TermToBuffer(t, LOCAL_encoding, 0);
Yap_JumpToEnv();
RECOVER_MACHINE_REGS();
}
@@ -2347,7 +2362,9 @@ X_API void YAP_AsyncThrow(Term t) {
CACHE_REGS
BACKUP_MACHINE_REGS();
LOCAL_PrologMode |= AsyncIntMode;
Yap_JumpToEnv(t);
LOCAL_ActiveError->errorNo = THROW_EVENT;
LOCAL_ActiveError->errorGoal = Yap_TermToBuffer(t, LOCAL_encoding, 0);
Yap_JumpToEnv();
LOCAL_PrologMode &= ~AsyncIntMode;
RECOVER_MACHINE_REGS();
}

72
C/cdmgr.c
View File

@@ -36,6 +36,7 @@ static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
#include <assert.h>
#include <heapgc.h>
#include <iopreds.h>
#include <Yatom.h>
static void retract_all(PredEntry *, int);
static void add_first_static(PredEntry *, yamop *, int);
@@ -1452,27 +1453,33 @@ static int not_was_reconsulted(PredEntry *p, Term t, int mode) {
return TRUE; /* careful */
}
static void addcl_permission_error(AtomEntry *ap, Int Arity, int in_use) {
static yamop * addcl_permission_error(const char *file, const char *function, int lineno, AtomEntry *ap, Int Arity, int in_use) {
CACHE_REGS
LOCAL_Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
LOCAL_ErrorMessage = Malloc(256);
if (in_use) {
if (Arity == 0)
sprintf(LOCAL_ErrorMessage, "static predicate %s is in use", ap->StrOfAE);
Term culprit;
if (Arity == 0)
culprit = MkAtomTerm(AbsAtom(ap));
else
sprintf(LOCAL_ErrorMessage,
"static predicate %s/" Int_FORMAT " is in use", ap->StrOfAE,
Arity);
} else {
if (Arity == 0)
sprintf(LOCAL_ErrorMessage, "system predicate %s", ap->StrOfAE);
else
sprintf(LOCAL_ErrorMessage, "system predicate %s/" Int_FORMAT,
ap->StrOfAE, Arity);
}
}
culprit = Yap_MkNewApplTerm(Yap_MkFunctor(AbsAtom(ap),Arity), Arity);
return
(in_use ?
(Arity == 0 ?
Yap_Error__(false, file, function, lineno, PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, culprit,
"static predicate %s is in use", ap->StrOfAE)
:
Yap_Error__(false, file, function, lineno, PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, culprit,
"static predicate %s/" Int_FORMAT " is in use", ap->StrOfAE, Arity)
)
:
(Arity == 0 ?
Yap_Error__(false, file, function, lineno, PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, culprit,
"system predicate %s is in use", ap->StrOfAE)
:
Yap_Error__(false, file, function, lineno, PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, culprit,
"system predicate %s/" Int_FORMAT, ap->StrOfAE, Arity)
)
);
}
PredEntry *Yap_PredFromClause(Term t USES_REGS) {
Term cmod = LOCAL_SourceModule;
@@ -1692,6 +1699,9 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
Term tf;
int mode;
if (tmode == 0) {
tmode = TermConsult;
}
if (tmode == TermConsult) {
mode = consult;
} else if (tmode == TermReconsult) {
@@ -1728,7 +1738,7 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
PELOCK(20, p);
/* we are redefining a prolog module predicate */
if (Yap_constPred(p)) {
addcl_permission_error(RepAtom(at), Arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__, RepAtom(at), Arity, FALSE);
UNLOCKPE(30, p);
return false;
}
@@ -1741,7 +1751,7 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
/* The only problem we have now is when we need to throw away
Indexing blocks
*/
if (pflags & IndexedPredFlag) {
if (pflags & IndexedPredFlag && p->cs.p_code.NOfClauses > 1) {
Yap_AddClauseToIndex(p, cp, mode == asserta);
}
if (pflags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
@@ -1761,9 +1771,7 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
sc[2] = MkAtomTerm(LOCAL_SourceFileName);
sc[3] = t;
t = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 4), 4, sc);
sc[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 1), 1, &t);
sc[1] = MkAtomTerm(AtomWarning);
Yap_PrintWarning(Yap_MkApplTerm(Yap_MkFunctor(AtomError, 2), 2, sc));
Yap_PrintWarning(t);
} else if (Yap_multiple(p, tmode PASS_REGS)) {
Term disc[4], sc[4];
if (p->ArityOfPE) {
@@ -1779,9 +1787,7 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
sc[2] = MkAtomTerm(LOCAL_SourceFileName);
sc[3] = t;
t = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 4), 4, sc);
sc[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 1), 1, &t);
sc[1] = MkAtomTerm(AtomWarning);
Yap_PrintWarning(Yap_MkApplTerm(Yap_MkFunctor(AtomError, 2), 2, sc));
Yap_PrintWarning(t);
}
if (mode == consult)
not_was_reconsulted(p, t, true);
@@ -2429,12 +2435,12 @@ static Int new_multifile(USES_REGS1) {
}
if (pe->PredFlags & (TabledPredFlag | ForeignPredFlags)) {
UNLOCKPE(26, pe);
addcl_permission_error(RepAtom(at), arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__,RepAtom(at), arity, FALSE);
return false;
}
if (pe->cs.p_code.NOfClauses) {
UNLOCKPE(26, pe);
addcl_permission_error(RepAtom(at), arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__,RepAtom(at), arity, FALSE);
return false;
}
pe->PredFlags &= ~UndefPredFlag;
@@ -2668,7 +2674,7 @@ static Int mk_dynamic(USES_REGS1) { /* '$make_dynamic'(+P) */
(UserCPredFlag | CArgsPredFlag | NumberDBPredFlag | AtomDBPredFlag |
TestPredFlag | AsmPredFlag | CPredFlag | BinaryPredFlag)) {
UNLOCKPE(30, pe);
addcl_permission_error(RepAtom(at), arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__,RepAtom(at), arity, FALSE);
return false;
}
if (pe->PredFlags & LogUpdatePredFlag) {
@@ -2681,7 +2687,7 @@ static Int mk_dynamic(USES_REGS1) { /* '$make_dynamic'(+P) */
}
if (pe->cs.p_code.NOfClauses != 0) {
UNLOCKPE(26, pe);
addcl_permission_error(RepAtom(at), arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__, RepAtom(at), arity, FALSE);
return false;
}
if (pe->OpcodeOfPred == UNDEF_OPCODE) {
@@ -2717,7 +2723,7 @@ static Int new_meta_pred(USES_REGS1) {
pe = new_pred(Deref(ARG1), Deref(ARG2), "meta_predicate");
if (EndOfPAEntr(pe))
return FALSE;
return false;
PELOCK(30, pe);
arity = pe->ArityOfPE;
if (arity == 0)
@@ -2731,7 +2737,7 @@ static Int new_meta_pred(USES_REGS1) {
}
if (pe->cs.p_code.NOfClauses) {
UNLOCKPE(26, pe);
addcl_permission_error(RepAtom(at), arity, FALSE);
addcl_permission_error(__FILE__, __FUNCTION__, __LINE__, RepAtom(at), arity, FALSE);
return false;
}
pe->PredFlags |= MetaPredFlag;

0
C/cdmgr.c708 in C-function cleanup_dangling_indices Normal file
View File

14
C/cmppreds.c
View File

@@ -16,6 +16,18 @@
* *
*************************************************************************/
/**
* @file cmppreds.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:35:58 2018
*
* @brief comparison
*
* @namespace prolog
*
*
*
*/
/// @file cmppreds.c
/**
@@ -711,7 +723,7 @@ static Int p_acomp(USES_REGS1) { /* $a_compare(?R,+X,+Y) */
}
/**
@pred +_X_ =:= _Y_ is iso
@pred +X '=:=' Y is iso
Equality of arithmetic expressions
The value of the expression _X_ is equal to the value of expression _Y_.

2
C/computils.c
View File

@@ -721,7 +721,7 @@ ShowOp (compiler_vm_op ic, const char *f, struct PSEUDO *cpc)
Yap_DebugPlWrite (MkIntTerm (rn & 1));
break;
case 'w':
Yap_DebugPlWrite (arg);
Yap_DebugPlWrite (MkIntTerm(arg));
break;
case 'o':
Yap_DebugPlWrite ((Term) * cptr++);

4
C/control_absmi_insts.h
View File

@@ -1,5 +1,7 @@
/************************************************************************\
* Cut & Commit Instructions *
* Cut & Commit Inst
ructions *
\************************************************************************/
#ifdef INDENT_CODE

54
C/dbase.c
View File

@@ -18,9 +18,24 @@
static char SccsId[] = "%W% %G%";
#endif
/**
* @file dbase.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:36:46 2018
*
* @brief record and other forms of storing terms.
*
* @namespace prolog
*
*
*
*/
/** @defgroup Internal_Database Internal Data Base
@ingroup builtins
@{
@ingroup builtins
@{
Some programs need global information for, e.g. counting or collecting
data obtained by backtracking. As a rule, to keep this information, the
@@ -259,7 +274,7 @@ static Int p_rcdz(USES_REGS1);
static Int p_rcdzp(USES_REGS1);
static Int p_drcdap(USES_REGS1);
static Int p_drcdzp(USES_REGS1);
static Term GetDBTerm(DBTerm *, int src CACHE_TYPE);
static Term GetDBTerm(const DBTerm *, int src CACHE_TYPE);
static DBProp FetchDBPropFromKey(Term, int, int, char *);
static Int i_recorded(DBProp, Term CACHE_TYPE);
static Int c_recorded(int CACHE_TYPE);
@@ -267,8 +282,8 @@ static Int co_rded(USES_REGS1);
static Int in_rdedp(USES_REGS1);
static Int co_rdedp(USES_REGS1);
static Int p_first_instance(USES_REGS1);
static void ErasePendingRefs(DBTerm *CACHE_TYPE);
static void RemoveDBEntry(DBRef CACHE_TYPE);
static void ErasePendingRefs(const DBTerm *CACHE_TYPE);
static void RemoveDBEntry(const DBRef CACHE_TYPE);
static void EraseLogUpdCl(LogUpdClause *);
static void MyEraseClause(DynamicClause *CACHE_TYPE);
static void PrepareToEraseClause(DynamicClause *, DBRef);
@@ -292,10 +307,10 @@ static void sf_include(SFKeep *);
#endif
static Int p_init_queue(USES_REGS1);
static Int p_enqueue(USES_REGS1);
static void keepdbrefs(DBTerm *CACHE_TYPE);
static void keepdbrefs(const DBTerm *ref USES_REGS);
static Int p_dequeue(USES_REGS1);
static void ErDBE(DBRef CACHE_TYPE);
static void ReleaseTermFromDB(DBTerm *CACHE_TYPE);
static void ReleaseTermFromDB(const DBTerm *ref USES_REGS);
static PredEntry *new_lu_entry(Term);
static PredEntry *new_lu_int_key(Int);
static PredEntry *find_lu_entry(Term);
@@ -2519,7 +2534,7 @@ Int Yap_unify_immediate_ref(DBRef ref USES_REGS) {
}
}
static Term GetDBTerm(DBTerm *DBSP, int src USES_REGS) {
static Term GetDBTerm(const DBTerm *DBSP, int src USES_REGS) {
Term t = DBSP->Entry;
if (IsVarTerm(t)
@@ -3779,7 +3794,7 @@ static Int p_heap_space_info(USES_REGS1) {
* This is called when we are erasing a data base clause, because we may have
* pending references
*/
static void ErasePendingRefs(DBTerm *entryref USES_REGS) {
static void ErasePendingRefs(const DBTerm *entryref USES_REGS) {
DBRef *cp;
DBRef ref;
@@ -3940,11 +3955,11 @@ static void complete_lu_erase(LogUpdClause *clau) {
static void EraseLogUpdCl(LogUpdClause *clau) {
PredEntry *ap;
ap = clau->ClPred;
/* no need to erase what has been erased */
if (!(clau->ClFlags & ErasedMask)) {
/* get ourselves out of the list */
clau->ClFlags |= ErasedMask;
/* get ourselves out of the list */
if (clau->ClNext != NULL) {
clau->ClNext->ClPrev = clau->ClPrev;
}
@@ -3968,7 +3983,6 @@ static void EraseLogUpdCl(LogUpdClause *clau) {
}
ap->cs.p_code.NOfClauses--;
}
clau->ClFlags |= ErasedMask;
#ifndef THREADS
{
LogUpdClause *er_head = DBErasedList;
@@ -4911,17 +4925,21 @@ static Int cont_current_key_integer(USES_REGS1) {
return Yap_unify(term, ARG1) && Yap_unify(term, ARG2);
}
Term Yap_FetchTermFromDB(void *ref) {
Term Yap_FetchTermFromDB(const void *ref) {
CACHE_REGS
if (ref == NULL)
return 0;
return GetDBTerm(ref, FALSE PASS_REGS);
}
Term Yap_FetchClauseTermFromDB(void *ref) {
Term Yap_FetchClauseTermFromDB(const void *ref) {
CACHE_REGS
if (ref == NULL)
return 0;
return GetDBTerm(ref, TRUE PASS_REGS);
}
Term Yap_PopTermFromDB(void *ref) {
Term Yap_PopTermFromDB(const void *ref) {
CACHE_REGS
Term t = GetDBTerm(ref, FALSE PASS_REGS);
@@ -5137,7 +5155,7 @@ static Int p_enqueue_unlocked(USES_REGS1) {
entry itself is still accessible from a trail entry, so we could not remove
the target entry,
*/
static void keepdbrefs(DBTerm *entryref USES_REGS) {
static void keepdbrefs (const DBTerm *entryref USES_REGS) {
DBRef *cp;
DBRef ref;
@@ -5296,7 +5314,7 @@ static Int p_resize_int_keys(USES_REGS1) {
return resize_int_keys(IntegerOfTerm(t1));
}
static void ReleaseTermFromDB(DBTerm *ref USES_REGS) {
static void ReleaseTermFromDB(const DBTerm *ref USES_REGS) {
if (!ref)
return;
keepdbrefs(ref PASS_REGS);
@@ -5304,7 +5322,7 @@ static void ReleaseTermFromDB(DBTerm *ref USES_REGS) {
FreeDBSpace((char *)ref);
}
void Yap_ReleaseTermFromDB(void *ref) {
void Yap_ReleaseTermFromDB(const void *ref) {
CACHE_REGS
ReleaseTermFromDB(ref PASS_REGS);
}

1091
C/errors.c
View File

File diff suppressed because it is too large Load Diff

62
C/eval.c
View File

@@ -17,8 +17,19 @@
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
//! @file eval.c
/**
* @file eval.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 09:37:59 2018
*
* @brief is/2
*
*
* @namespace prolog
*
*
*
*/
//! @{
@@ -91,6 +102,8 @@ static Term get_matrix_element(Term t1, Term t2 USES_REGS) {
}
static Term Eval(Term t USES_REGS) {
eval_context_t ctx;
ctx.p = LOCAL_ctx;
if (IsVarTerm(t)) {
Yap_ArithError(INSTANTIATION_ERROR, t, "in arithmetic");
@@ -134,20 +147,19 @@ static Term Eval(Term t USES_REGS) {
return get_matrix_element(ArgOfTerm(1, t), t2 PASS_REGS);
}
}
ctx.f = fun;
ctx.fp = RepAppl(t);
LOCAL_ctx = &ctx;
*RepAppl(t) = (CELL)AtomFoundVar;
t1 = Eval(ArgOfTerm(1, t) PASS_REGS);
if (t1 == 0L) {
*RepAppl(t) = (CELL)fun;
return FALSE;
}
if (n == 1) {
*RepAppl(t) = (CELL)fun;
LOCAL_ctx = ctx.p;
return Yap_eval_unary(p->FOfEE, t1);
}
t2 = Eval(ArgOfTerm(2, t) PASS_REGS);
*RepAppl(t) = (CELL)fun;
if (t2 == 0L)
return FALSE;
LOCAL_ctx = ctx.p;
return Yap_eval_binary(p->FOfEE, t1, t2);
}
} /* else if (IsPairTerm(t)) */
@@ -161,7 +173,9 @@ static Term Eval(Term t USES_REGS) {
}
}
Term Yap_InnerEval__(Term t USES_REGS) { return Eval(t PASS_REGS); }
Term Yap_InnerEval__(Term t USES_REGS) {
return Eval(t PASS_REGS);
}
#ifdef BEAM
Int BEAM_is(void);
@@ -196,30 +210,18 @@ arithmetic_operators
/// @memberof is/2
static Int p_is(USES_REGS1) { /* X is Y */
Term out;
yap_error_number err;
Term out = TermNil;
bool go;
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Yap_EvalError(INSTANTIATION_ERROR, t, "X is Y");
Yap_ThrowError(INSTANTIATION_ERROR, t, "var(Y) in X is Y");
return (FALSE);
}
Yap_ClearExs();
do {
out = Yap_InnerEval(Deref(ARG2));
if ((err = Yap_FoundArithError()) == YAP_NO_ERROR)
break;
if (err == RESOURCE_ERROR_STACK) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, CP)) {
Yap_EvalError(RESOURCE_ERROR_STACK, ARG2, LOCAL_ErrorMessage);
return FALSE;
}
} else {
Yap_EvalError(err, takeIndicator(ARG2), "X is Exp");
return FALSE;
}
} while (TRUE);
go = false;
out = Yap_Eval(t PASS_REGS);
go = Yap_CheckArithError();
} while (go);
return Yap_unify_constant(ARG1, out);
}
@@ -257,7 +259,7 @@ static Int p_isnan(USES_REGS1) { /* X isnan Y */
}
/**
@pred isinf(? X:float) is det</b>
@pred isinf(? X:float) is det
Interface to the IEE754 `isinf` test.
*/
@@ -387,7 +389,7 @@ void Yap_EvalError__(const char *file, const char *function, int lineno,
buf[0] = '\0';
}
va_end(ap);
Yap_ThrowError__(file, function, lineno, type, where, buf);
Yap_Error__(false, file, function, lineno, type, where, buf);
}
/**

562
C/exec.c
View File

@@ -18,6 +18,19 @@
static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
#endif
/**
* @file exec.c
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
* @date Mon Apr 30 13:48:35 2018
*
* @brief meta-call
*
* @namespace prolog
*
*
*
*/
#include "absmi.h"
#include "attvar.h"
#include "cut_c.h"
@@ -41,7 +54,6 @@ static choiceptr cp_from_integer(Term cpt USES_REGS) {
/**
* Represents a choice-point as an offset to the top of local stack. This should
* *be stable acroos gc or stack shifts.
* @method Yap_cp_as_integer
* @param cp pointer to choice-point
* @return Term with offset
*/
@@ -121,7 +133,8 @@ inline static bool CallMetaCall(Term t, Term mod USES_REGS) {
/**
* Transfer control to a meta-call in ARG1, cut up to B.
* @method Yap_ExecuteCallMetaCall
*
* @param g goal
* @param mod current module
* @return su
*/
@@ -441,8 +454,8 @@ restart_exec:
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
// if (pen->PredFlags & (MetaPredFlag | UndefPredFlag)) {
// Term t = copy_execn_to_heap(f, pt, n, arity, mod PASS_REGS);
//return (CallMetaCall(t0, mod0 PASS_REGS));
// Term t = copy_execn_to_heap(f, pt, n, arity, mod PASS_REGS);
// return (CallMetaCall(t0, mod0 PASS_REGS));
//}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
@@ -770,14 +783,16 @@ static Int Yap_ignore(Term t, bool fail USES_REGS) {
Int oENV = LCL0 - ENV;
Int oYENV = LCL0 - YENV;
Int oB = LCL0 - (CELL *)B;
yap_error_descriptor_t *ctx = malloc(sizeof(yap_error_descriptor_t));
bool newxp = Yap_pushErrorContext(true, ctx);
bool rc = Yap_RunTopGoal(t, false);
if (!rc) {
complete_inner_computation((choiceptr)(LCL0 - oB));
// We'll pass it through
} else {
prune_inner_computation((choiceptr)(LCL0 - oB));
}
Yap_popErrorContext(newxp, true);
P = oP;
CP = oCP;
ENV = LCL0 - oENV;
@@ -817,8 +832,8 @@ static bool watch_cut(Term ext USES_REGS) {
}
CELL *port_pt = deref_ptr(RepAppl(task) + 2);
CELL *completion_pt = deref_ptr(RepAppl(task) + 4);
if ((ex_mode = Yap_HasException())) {
e = Yap_GetException();
if (LOCAL_ActiveError && LOCAL_ActiveError->errorNo != YAP_NO_ERROR) {
e = MkErrorTerm(LOCAL_ActiveError);
Term t;
if (active) {
t = Yap_MkApplTerm(FunctorException, 1, &e);
@@ -834,7 +849,7 @@ static bool watch_cut(Term ext USES_REGS) {
CELL *complete_pt = deref_ptr(RepAppl(task) + 4);
complete_pt[0] = TermTrue;
if (ex_mode) {
Yap_PutException(e);
// Yap_PutException(e);
return true;
}
if (Yap_RaiseException())
@@ -873,8 +888,8 @@ static bool watch_retry(Term d0 USES_REGS) {
// just do the frrpest
if (B >= B0 && !ex_mode && !active)
return true;
if ((ex_mode = Yap_HasException())) {
e = Yap_GetException();
if (LOCAL_ActiveError && LOCAL_ActiveError->errorNo != YAP_NO_ERROR) {
e = MkErrorTerm(LOCAL_ActiveError);
if (active) {
t = Yap_MkApplTerm(FunctorException, 1, &e);
} else {
@@ -893,7 +908,7 @@ static bool watch_retry(Term d0 USES_REGS) {
port_pt[0] = t;
Yap_ignore(cleanup, true);
if (ex_mode) {
Yap_PutException(e);
// Yap_PutException(e);
return true;
}
if (Yap_RaiseException())
@@ -917,7 +932,6 @@ static Int setup_call_catcher_cleanup(USES_REGS1) {
Int oENV = LCL0 - ENV;
Int oYENV = LCL0 - YENV;
bool rc;
Yap_DisableInterrupts(worker_id);
rc = Yap_RunTopGoal(Setup, false);
Yap_EnableInterrupts(worker_id);
@@ -956,6 +970,7 @@ static Int cleanup_on_exit(USES_REGS1) {
while (B->cp_ap->opc == FAIL_OPCODE)
B = B->cp_b;
if (complete) {
return true;
}
@@ -973,6 +988,8 @@ static Int cleanup_on_exit(USES_REGS1) {
complete_pt[0] = TermExit;
}
Yap_ignore(cleanup, false);
if (B0->cp_ap == NOCODE)
B0->cp_ap = TRUSTFAILCODE;
if (Yap_RaiseException()) {
return false;
}
@@ -1228,8 +1245,14 @@ static Int creep_step(USES_REGS1) { /* '$execute_nonstop'(Goal,Mod)
return rc;
}
static Int execute_nonstop(USES_REGS1) { /* '$execute_nonstop'(Goal,Mod)
*/
/**
* @brief Two argument version of non-interruptible execution: this will
* ignore signals including debugging requests.
*
* @return Int succeeds if it can transfer control.
*/
static Int execute_nonstop(USES_REGS1) {
Term t = Deref(ARG1);
Term mod = Deref(ARG2);
unsigned int arity;
@@ -1304,6 +1327,17 @@ static Int execute_nonstop(USES_REGS1) { /* '$execute_nonstop'(Goal,Mod)
}
}
/**
* @brief One argument version of non-interruptible execution: this will
* ignore signals including debugging requests.
*
* @return Int succeeds if it can transfer control.
*/
static Int execute_nonstop1(USES_REGS1) {
ARG2 = CurrentModule;
return execute_nonstop(PASS_REGS1);
}
static Int execute_0(USES_REGS1) { /* '$execute_0'(Goal) */
Term mod = CurrentModule;
Term t = Yap_YapStripModule(Deref(ARG1), &mod);
@@ -1385,16 +1419,20 @@ static Int execute_depth_limit(USES_REGS1) {
#endif
static bool exec_absmi(bool top, yap_reset_t reset_mode USES_REGS) {
int lval, out;
int lval = 0, out;
Int OldBorder = LOCAL_CBorder;
LOCAL_CBorder = LCL0 - (CELL *)B;
// yap_error_descriptor_t *err_info= LOCAL_ActiveError;
LOCAL_CBorder = LCL0 - ENV;
yhandle_t sls = Yap_CurrentSlot();
sigjmp_buf signew, *sighold = LOCAL_RestartEnv;
LOCAL_RestartEnv = &signew;
if (top && (lval = sigsetjmp(signew, 1)) != 0) {
int i = AllocLevel();
if /* top &&*/ ((lval = sigsetjmp(signew, 1)) != 0) {
switch (lval) {
case 1: { /* restart */
/* otherwise, SetDBForThrow will fail entering critical mode */
/* otherwise, SetDBForThrow will fail entering critical mode */
// LOCAL_ActiveError = err_info;
LOCAL_PrologMode = UserMode;
/* find out where to cut to */
/* siglongjmp resets the TR hardware register */
@@ -1409,53 +1447,75 @@ static bool exec_absmi(bool top, yap_reset_t reset_mode USES_REGS) {
LOCAL_Signals = 0;
CalculateStackGap(PASS_REGS1);
LOCAL_PrologMode = UserMode;
Yap_CloseSlots(sls);
P = (yamop *)FAILCODE;
} break;
case 2: {
// LOCAL_ActiveError = err_info;
/* arithmetic exception */
/* must be done here, otherwise siglongjmp will clobber all the
* registers
*/
/* reset the registers so that we don't have trash in abstract
* machine */
pop_text_stack(i);
Yap_set_fpu_exceptions(
getAtomicGlobalPrologFlag(ARITHMETIC_EXCEPTIONS_FLAG));
P = (yamop *)FAILCODE;
LOCAL_PrologMode = UserMode;
Yap_CloseSlots(sls);
} break;
case 3: { /* saved state */
// LOCAL_ActiveError = err_info;
pop_text_stack(i);
LOCAL_CBorder = OldBorder;
LOCAL_RestartEnv = sighold;
LOCAL_PrologMode = UserMode;
Yap_CloseSlots(sls);
return false;
}
case 4:
/* abort */
/* can be called from anywhere, must reset registers,
*/
// LOCAL_ActiveError = err_info;
while (B) {
Yap_JumpToEnv(TermDAbort);
LOCAL_ActiveError->errorNo = ABORT_EVENT;
pop_text_stack(i);
Yap_CloseSlots(sls);
Yap_JumpToEnv();
}
LOCAL_PrologMode &= ~AbortMode;
LOCAL_PrologMode = UserMode;
P = (yamop *)FAILCODE;
LOCAL_RestartEnv = sighold;
Yap_CloseSlots(sls);
pop_text_stack(i);
return false;
break;
case 5:
// going up, unless there is no up to go to. or someone
// but we should inform the caller on what happened.
if (B && B->cp_b && B->cp_b <= (choiceptr)(LCL0 - LOCAL_CBorder)) {
break;
// Yap_regp = old_rs;
// LOCAL_ActiveError = err_info;
restore_TR();
restore_B();
/* H is not so important, because we're gonna backtrack */
restore_H();
/* set stack */
Yap_JumpToEnv();
Yap_CloseTemporaryStreams();
Yap_CloseSlots(sls);
ASP = (CELL *)PROTECT_FROZEN_B(B);
if (B == NULL || B->cp_b == NULL ||
(CELL *)(B->cp_b) > LCL0 - LOCAL_CBorder) {
LOCAL_RestartEnv = sighold;
LOCAL_CBorder = OldBorder;
return false;
}
LOCAL_RestartEnv = sighold;
LOCAL_PrologMode = UserMode;
LOCAL_CBorder = OldBorder;
return false;
default:
/* do nothing */
LOCAL_PrologMode = UserMode;
P = FAILCODE;
}
} else {
LOCAL_PrologMode = UserMode;
}
YENV = ASP;
YENV[E_CB] = Unsigned(B);
@@ -1539,8 +1599,8 @@ bool Yap_exec_absmi(bool top, yap_reset_t has_reset) {
/**
* Fails computation up to choice-point bb
* @method Yap_fail_all
* @param USES_REGS [description]
*
* @param USES_REGS thread support
*/
void Yap_fail_all(choiceptr bb USES_REGS) {
yamop *saved_p, *saved_cp;
@@ -1563,7 +1623,7 @@ void Yap_fail_all(choiceptr bb USES_REGS) {
DEPTH = B->cp_depth;
#endif /* DEPTH_LIMIT */
YENV = ENV = B->cp_env;
/* recover local stack */
/* recover local stack */
#ifdef DEPTH_LIMIT
DEPTH = ENV[E_DEPTH];
#endif
@@ -1745,11 +1805,12 @@ Term Yap_RunTopGoal(Term t, bool handle_errors) {
Yap_Error(INSTANTIATION_ERROR, t, "call/1");
LOCAL_PrologMode &= ~TopGoalMode;
return (FALSE);
} if (IsPairTerm(t)) {
Term ts[2];
ts[0] = t;
ts[1] = (CurrentModule == 0? TermProlog: CurrentModule);
t = Yap_MkApplTerm(FunctorCsult,2,ts);
}
if (IsPairTerm(t)) {
Term ts[2];
ts[0] = t;
ts[1] = (CurrentModule == 0 ? TermProlog : CurrentModule);
t = Yap_MkApplTerm(FunctorCsult, 2, ts);
}
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
@@ -1958,14 +2019,14 @@ static Int cut_up_to_next_disjunction(USES_REGS1) {
return TRUE;
}
/**
/**
* Reset the Prolog engine . If _Hard_ resèt the global stack_el. If
* p_no_use_'soft_float keei
*
* @param mode
* @param hard
*
* @return
*
* @param mode
* @param hard
*
* @return
*/
bool Yap_Reset(yap_reset_t mode, bool hard) {
CACHE_REGS
@@ -2008,7 +2069,7 @@ bool is_cleanup_cp(choiceptr cp_b) {
return pe == PredSafeCallCleanup;
}
static Int JumpToEnv() {
static Int JumpToEnv(USES_REGS1) {
choiceptr handler = B;
/* just keep the throwm object away, we don't need to care about it
*/
@@ -2019,294 +2080,227 @@ static Int JumpToEnv() {
while (handler && Yap_PredForChoicePt(handler, NULL) != PredDollarCatch &&
LOCAL_CBorder < LCL0 - (CELL *)handler && handler->cp_ap != NOCODE &&
handler->cp_b != NULL) {
handler->cp_ap = TRUSTFAILCODE;
handler = handler->cp_b;
}
pop_text_stack(1);
if (LOCAL_PrologMode & AsyncIntMode) {
Yap_signal(YAP_FAIL_SIGNAL);
}
B = handler;
P = FAILCODE;
return true;
}
bool Yap_JumpToEnv(Term t) {
bool Yap_JumpToEnv(void) {
CACHE_REGS
LOCAL_BallTerm = Yap_StoreTermInDB(t, 0);
if (!LOCAL_BallTerm)
return false;
if (LOCAL_PrologMode & TopGoalMode)
return true;
return JumpToEnv(PASS_REGS);
return JumpToEnv(PASS_REGS1);
}
/* This does very nasty stuff!!!!! */
static Int jump_env(USES_REGS1) {
Term t = Deref(ARG1);
Term t = Deref(ARG1), t0 = t;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "throw ball must be bound");
return false;
} else if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorError) {
Term t2;
Yap_find_prolog_culprit(PASS_REGS1);
// LOCAL_Error_TYPE = ERROR_EVENT;
Term t1 = ArgOfTerm(1, t);
if (IsApplTerm(t1) && IsAtomTerm((t2 = ArgOfTerm(1, t1)))) {
LOCAL_ActiveError->errorAsText = RepAtom(AtomOfTerm(t2))->StrOfAE;
LOCAL_ActiveError->classAsText = RepAtom(NameOfFunctor(FunctorOfTerm(t1)))->StrOfAE;
} else if (IsAtomTerm(t)) {
LOCAL_ActiveError->errorAsText = RepAtom(AtomOfTerm(t1))->StrOfAE;
LOCAL_ActiveError->classAsText = NULL;
}
} else {
Yap_find_prolog_culprit(PASS_REGS1);
LOCAL_ActiveError->errorAsText = NULL;
LOCAL_ActiveError->classAsText = NULL;
//return true;
}
LOCAL_ActiveError->prologPredName = NULL;
Yap_PutException(t);
bool out = JumpToEnv(PASS_REGS1);
if (B != NULL && P == FAILCODE && B->cp_ap == NOCODE &&
LCL0 - (CELL *)B > LOCAL_CBorder) {
// we're failing up to the top layer
}
return out;
Yap_ThrowError(INSTANTIATION_ERROR, t,
"throw/1 must be called instantiated");
}
/* set up a meta-call based on . context info */
static Int generate_pred_info(USES_REGS1) {
ARG1 = ARG3 = ENV[-EnvSizeInCells - 1];
ARG4 = ENV[-EnvSizeInCells - 3];
ARG2 = cp_as_integer((choiceptr)ENV[E_CB] PASS_REGS);
return TRUE;
// Yap_DebugPlWriteln(t);
LOCAL_ActiveError = Yap_UserError(t0, LOCAL_ActiveError);
bool out = JumpToEnv(PASS_REGS1);
if (B != NULL && P == FAILCODE && B->cp_ap == NOCODE &&
LCL0 - (CELL *)B > LOCAL_CBorder) {
// we're failing up to the top layer
}
return out;
}
void Yap_InitYaamRegs(int myworker_id, bool full_reset) {
Term h0var;
// getchar();
/* set up a meta-call based on . context info */
static Int generate_pred_info(USES_REGS1) {
ARG1 = ARG3 = ENV[-EnvSizeInCells - 1];
ARG4 = ENV[-EnvSizeInCells - 3];
ARG2 = cp_as_integer((choiceptr)ENV[E_CB] PASS_REGS);
return TRUE;
}
void Yap_InitYaamRegs(int myworker_id, bool full_reset) {
Term h0var;
// getchar();
#if PUSH_REGS
/* Guarantee that after a longjmp we go back to the original abstract
machine registers */
/* Guarantee that after a longjmp we go back to the original abstract
machine registers */
#ifdef THREADS
if (myworker_id) {
REGSTORE *rs = REMOTE_ThreadHandle(myworker_id).default_yaam_regs;
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = rs;
}
/* may be run by worker_id on behalf on myworker_id */
if (myworker_id) {
REGSTORE *rs = REMOTE_ThreadHandle(myworker_id).default_yaam_regs;
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = rs;
}
/* may be run by worker_id on behalf on myworker_id */
#else
Yap_regp = &Yap_standard_regs;
Yap_regp = &Yap_standard_regs;
#endif
#endif /* PUSH_REGS */
CACHE_REGS
Yap_ResetException(worker_id);
Yap_PutValue(AtomBreak, MkIntTerm(0));
TR = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
HR = H0 = ((CELL *) REMOTE_GlobalBase(myworker_id)) +
1; // +1: hack to ensure the gc does not try to mark mistakenly
LCL0 = ASP = (CELL *)REMOTE_LocalBase(myworker_id);
CurrentTrailTop = (tr_fr_ptr)(REMOTE_TrailTop(myworker_id) - MinTrailGap);
/* notice that an initial choice-point and environment
*must* be created for the garbage collector to work */
B = NULL;
ENV = NULL;
P = CP = YESCODE;
CACHE_REGS
Yap_ResetException(LOCAL_ActiveError);
Yap_PutValue(AtomBreak, MkIntTerm(0));
TR = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
HR = H0 = ((CELL *)REMOTE_GlobalBase(myworker_id)) +
1; // +1: hack to ensure the gc does not try to mark mistakenly
LCL0 = ASP = (CELL *)REMOTE_LocalBase(myworker_id);
CurrentTrailTop = (tr_fr_ptr)(REMOTE_TrailTop(myworker_id) - MinTrailGap);
/* notice that an initial choice-point and environment
*must* be created for the garbage collector to work */
B = NULL;
ENV = NULL;
P = CP = YESCODE;
#ifdef DEPTH_LIMIT
DEPTH = RESET_DEPTH();
DEPTH = RESET_DEPTH();
#endif
STATIC_PREDICATES_MARKED = FALSE;
if (full_reset) {
HR = H0+1;
h0var = MkVarTerm();
REMOTE_GcGeneration(myworker_id) = Yap_NewTimedVar(h0var);
REMOTE_GcCurrentPhase(myworker_id) = 0L;
REMOTE_GcPhase(myworker_id) =
Yap_NewTimedVar(MkIntTerm(REMOTE_GcCurrentPhase(myworker_id)));
STATIC_PREDICATES_MARKED = FALSE;
if (full_reset) {
HR = H0 + 1;
h0var = MkVarTerm();
REMOTE_GcGeneration(myworker_id) = Yap_NewTimedVar(h0var);
REMOTE_GcCurrentPhase(myworker_id) = 0L;
REMOTE_GcPhase(myworker_id) =
Yap_NewTimedVar(MkIntTerm(REMOTE_GcCurrentPhase(myworker_id)));
#if COROUTINING
REMOTE_WokenGoals(myworker_id) = Yap_NewTimedVar(TermNil);
h0var = MkVarTerm();
REMOTE_AttsMutableList(myworker_id) = Yap_NewTimedVar(h0var);
REMOTE_WokenGoals(myworker_id) = Yap_NewTimedVar(TermNil);
h0var = MkVarTerm();
REMOTE_AttsMutableList(myworker_id) = Yap_NewTimedVar(h0var);
#endif
Yap_AllocateDefaultArena(128 * 1024, 2, myworker_id);
} else {
HR = Yap_ArenaLimit(REMOTE_GlobalArena(myworker_id));
}
Yap_InitPreAllocCodeSpace(myworker_id);
Yap_AllocateDefaultArena(128 * 1024, 2, myworker_id);
} else {
HR = Yap_ArenaLimit(REMOTE_GlobalArena(myworker_id));
}
Yap_InitPreAllocCodeSpace(myworker_id);
#ifdef FROZEN_STACKS
H_FZ = HR;
H_FZ = HR;
#ifdef YAPOR_SBA
BSEG =
BSEG =
#endif /* YAPOR_SBA */
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
#endif /* FROZEN_STACKS */
CalculateStackGap(PASS_REGS1);
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
CalculateStackGap(PASS_REGS1);
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
#if defined(YAPOR) || defined(THREADS)
LOCAL = REMOTE(myworker_id);
worker_id = myworker_id;
LOCAL = REMOTE(myworker_id);
worker_id = myworker_id;
#endif /* THREADS */
Yap_RebootSlots(myworker_id);
Yap_RebootSlots(myworker_id);
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
PREG_ADDR = NULL;
PP = NULL;
PREG_ADDR = NULL;
#endif
cut_c_initialize(myworker_id);
Yap_PrepGoal(0, NULL, NULL PASS_REGS);
cut_c_initialize(myworker_id);
Yap_PrepGoal(0, NULL, NULL PASS_REGS);
#ifdef FROZEN_STACKS
H_FZ = HR;
H_FZ = HR;
#ifdef YAPOR_SBA
BSEG =
BSEG =
#endif /* YAPOR_SBA */
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
#endif /* FROZEN_STACKS */
CalculateStackGap(PASS_REGS1);
CalculateStackGap(PASS_REGS1);
#ifdef TABLING
/* ensure that LOCAL_top_dep_fr is always valid */
if (REMOTE_top_dep_fr(myworker_id))
DepFr_cons_cp(REMOTE_top_dep_fr(myworker_id)) = NORM_CP(B);
/* ensure that LOCAL_top_dep_fr is always valid */
if (REMOTE_top_dep_fr(myworker_id))
DepFr_cons_cp(REMOTE_top_dep_fr(myworker_id)) = NORM_CP(B);
#endif
}
int Yap_dogc(int extra_args, Term *tp USES_REGS) {
UInt arity;
yamop *nextpc;
int i;
if (P && PREVOP(P, Osbpp)->opc == Yap_opcode(_call_usercpred)) {
arity = PREVOP(P, Osbpp)->y_u.Osbpp.p->ArityOfPE;
nextpc = P;
} else {
arity = 0;
nextpc = CP;
}
Term Yap_GetException(void) {
CACHE_REGS
Term t = 0;
if (LOCAL_BallTerm) {
t = Yap_PopTermFromDB(LOCAL_BallTerm);
}
LOCAL_BallTerm = NULL;
return t;
for (i = 0; i < extra_args; i++) {
XREGS[arity + i + 1] = tp[i];
}
Term Yap_PeekException(void) { return Yap_FetchTermFromDB(LOCAL_BallTerm); }
bool Yap_RaiseException(void) {
if (LOCAL_BallTerm == NULL)
return false;
return JumpToEnv();
if (!Yap_gc(arity + extra_args, ENV, nextpc)) {
return FALSE;
}
bool Yap_PutException(Term t) {
CACHE_REGS
if ((LOCAL_BallTerm = Yap_StoreTermInDB(t, 0)) != NULL)
return true;
return false;
for (i = 0; i < extra_args; i++) {
tp[i] = XREGS[arity + i + 1];
}
return TRUE;
}
bool Yap_ResetException(int wid) {
if (REMOTE_ActiveError(wid)->errorTerm) {
Yap_PopTermFromDB(REMOTE_ActiveError(wid)->errorTerm);
}
REMOTE_ActiveError(wid)->errorTerm = NULL;
return true;
}
void Yap_InitExecFs(void) {
CACHE_REGS
YAP_opaque_handler_t catcher_ops;
memset(&catcher_ops, 0, sizeof(catcher_ops));
catcher_ops.cut_handler = watch_cut;
catcher_ops.fail_handler = watch_retry;
setup_call_catcher_cleanup_tag = YAP_NewOpaqueType(&catcher_ops);
static Int reset_exception(USES_REGS1) { return Yap_ResetException(worker_id); }
static Int get_exception(USES_REGS1) {
Term t = Yap_GetException();
if (t == 0)
return false;
return Yap_unify(t, ARG1);
}
int Yap_dogc(int extra_args, Term *tp USES_REGS) {
UInt arity;
yamop *nextpc;
int i;
if (P && PREVOP(P, Osbpp)->opc == Yap_opcode(_call_usercpred)) {
arity = PREVOP(P, Osbpp)->y_u.Osbpp.p->ArityOfPE;
nextpc = P;
} else {
arity = 0;
nextpc = CP;
}
for (i = 0; i < extra_args; i++) {
XREGS[arity + i + 1] = tp[i];
}
if (!Yap_gc(arity + extra_args, ENV, nextpc)) {
return FALSE;
}
for (i = 0; i < extra_args; i++) {
tp[i] = XREGS[arity + i + 1];
}
return TRUE;
}
void Yap_InitExecFs(void) {
CACHE_REGS
YAP_opaque_handler_t catcher_ops;
memset(&catcher_ops, 0, sizeof(catcher_ops));
catcher_ops.cut_handler = watch_cut;
catcher_ops.fail_handler = watch_retry;
setup_call_catcher_cleanup_tag = YAP_NewOpaqueType(&catcher_ops);
Term cm = CurrentModule;
Yap_InitComma();
Yap_InitCPred("$execute", 1, execute, 0);
Yap_InitCPred("$execute", 2, execute2, 0);
Yap_InitCPred("$execute", 3, execute3, 0);
Yap_InitCPred("$execute", 4, execute4, 0);
Yap_InitCPred("$execute", 5, execute5, 0);
Yap_InitCPred("$execute", 6, execute6, 0);
Yap_InitCPred("$execute", 7, execute7, 0);
Yap_InitCPred("$execute", 8, execute8, 0);
Yap_InitCPred("$execute", 9, execute9, 0);
Yap_InitCPred("$execute", 10, execute10, 0);
Yap_InitCPred("$execute", 11, execute11, 0);
Yap_InitCPred("$execute", 12, execute12, 0);
Yap_InitCPred("$execute_in_mod", 2, execute_in_mod, 0);
Yap_InitCPred("$execute_wo_mod", 2, execute_in_mod, 0);
Yap_InitCPred("call_with_args", 1, execute_0, 0);
Yap_InitCPred("call_with_args", 2, execute_1, 0);
Yap_InitCPred("call_with_args", 3, execute_2, 0);
Yap_InitCPred("call_with_args", 4, execute_3, 0);
Yap_InitCPred("call_with_args", 5, execute_4, 0);
Yap_InitCPred("call_with_args", 6, execute_5, 0);
Yap_InitCPred("call_with_args", 7, execute_6, 0);
Yap_InitCPred("call_with_args", 8, execute_7, 0);
Yap_InitCPred("call_with_args", 9, execute_8, 0);
Yap_InitCPred("call_with_args", 10, execute_9, 0);
Yap_InitCPred("call_with_args", 11, execute_10, 0);
Term cm = CurrentModule;
Yap_InitComma();
Yap_InitCPred("$execute", 1, execute, 0);
Yap_InitCPred("$execute", 2, execute2, 0);
Yap_InitCPred("$execute", 3, execute3, 0);
Yap_InitCPred("$execute", 4, execute4, 0);
Yap_InitCPred("$execute", 5, execute5, 0);
Yap_InitCPred("$execute", 6, execute6, 0);
Yap_InitCPred("$execute", 7, execute7, 0);
Yap_InitCPred("$execute", 8, execute8, 0);
Yap_InitCPred("$execute", 9, execute9, 0);
Yap_InitCPred("$execute", 10, execute10, 0);
Yap_InitCPred("$execute", 11, execute11, 0);
Yap_InitCPred("$execute", 12, execute12, 0);
Yap_InitCPred("$execute_in_mod", 2, execute_in_mod, 0);
Yap_InitCPred("$execute_wo_mod", 2, execute_in_mod, 0);
Yap_InitCPred("call_with_args", 1, execute_0, 0);
Yap_InitCPred("call_with_args", 2, execute_1, 0);
Yap_InitCPred("call_with_args", 3, execute_2, 0);
Yap_InitCPred("call_with_args", 4, execute_3, 0);
Yap_InitCPred("call_with_args", 5, execute_4, 0);
Yap_InitCPred("call_with_args", 6, execute_5, 0);
Yap_InitCPred("call_with_args", 7, execute_6, 0);
Yap_InitCPred("call_with_args", 8, execute_7, 0);
Yap_InitCPred("call_with_args", 9, execute_8, 0);
Yap_InitCPred("call_with_args", 10, execute_9, 0);
Yap_InitCPred("call_with_args", 11, execute_10, 0);
#ifdef DEPTH_LIMIT
Yap_InitCPred("$execute_under_depth_limit", 2, execute_depth_limit, 0);
Yap_InitCPred("$execute_under_depth_limit", 2, execute_depth_limit, 0);
#endif
Yap_InitCPred("$execute0", 2, execute0, NoTracePredFlag);
Yap_InitCPred("$execute_nonstop", 2, execute_nonstop, NoTracePredFlag);
Yap_InitCPred("$creep_step", 2, creep_step, NoTracePredFlag);
Yap_InitCPred("$execute_clause", 4, execute_clause, NoTracePredFlag);
Yap_InitCPred("$current_choice_point", 1, current_choice_point, 0);
Yap_InitCPred("$ ", 1,
current_choice_point, 0);
CurrentModule = HACKS_MODULE;
Yap_InitCPred("current_choice_point", 1, current_choice_point, 0);
Yap_InitCPred("current_choicepoint", 1, current_choice_point, 0);
Yap_InitCPred("env_choice_point", 1, save_env_b, 0);
Yap_InitCPred("cut_at", 1, clean_ifcp, SafePredFlag);
CurrentModule = cm;
Yap_InitCPred("$restore_regs", 1, restore_regs,
NoTracePredFlag | SafePredFlag);
Yap_InitCPred("$restore_regs", 2, restore_regs2,
NoTracePredFlag | SafePredFlag);
Yap_InitCPred("$clean_ifcp", 1, clean_ifcp, SafePredFlag);
Yap_InitCPred("qpack_clean_up_to_disjunction", 0, cut_up_to_next_disjunction,
SafePredFlag);
Yap_InitCPred("$jump_env_and_store_ball", 1, jump_env, 0);
Yap_InitCPred("$generate_pred_info", 4, generate_pred_info, 0);
Yap_InitCPred("$reset_exception", 1, reset_exception, 0);
Yap_InitCPred("_user_expand_goal", 2, _user_expand_goal, 0);
Yap_InitCPred("$do_term_expansion", 2, do_term_expansion, 0);
Yap_InitCPred("$get_exception", 1, get_exception, 0);
Yap_InitCPred("$setup_call_catcher_cleanup", 1, setup_call_catcher_cleanup,
0);
Yap_InitCPred("$cleanup_on_exit", 2, cleanup_on_exit, 0);
Yap_InitCPred("$tag_cleanup", 2, tag_cleanup, 0);
}
Yap_InitCPred("$execute0", 2, execute0, NoTracePredFlag);
Yap_InitCPred("$execute_nonstop", 2, execute_nonstop, NoTracePredFlag);
Yap_InitCPred("$execute_nonstop", 1, execute_nonstop1, NoTracePredFlag);
Yap_InitCPred("$creep_step", 2, creep_step, NoTracePredFlag);
Yap_InitCPred("$execute_clause", 4, execute_clause, NoTracePredFlag);
Yap_InitCPred("$current_choice_point", 1, current_choice_point, 0);
Yap_InitCPred("$current_choicepoint", 1, current_choice_point, 0);
CurrentModule = HACKS_MODULE;
Yap_InitCPred("current_choice_point", 1, current_choice_point, 0);
Yap_InitCPred("current_choicepoint", 1, current_choice_point, 0);
Yap_InitCPred("env_choice_point", 1, save_env_b, 0);
Yap_InitCPred("cut_at", 1, clean_ifcp, SafePredFlag);
CurrentModule = cm;
Yap_InitCPred("$restore_regs", 1, restore_regs,
NoTracePredFlag | SafePredFlag);
Yap_InitCPred("$restore_regs", 2, restore_regs2,
NoTracePredFlag | SafePredFlag);
Yap_InitCPred("$clean_ifcp", 1, clean_ifcp, SafePredFlag);
Yap_InitCPred("qpack_clean_up_to_disjunction", 0, cut_up_to_next_disjunction,
SafePredFlag);
Yap_InitCPred("throw", 1, jump_env, 0);
Yap_InitCPred("$generate_pred_info", 4, generate_pred_info, 0);
Yap_InitCPred("_user_expand_goal", 2, _user_expand_goal, 0);
Yap_InitCPred("$do_term_expansion", 2, do_term_expansion, 0);
Yap_InitCPred("$setup_call_catcher_cleanup", 1, setup_call_catcher_cleanup,
0);
Yap_InitCPred("$cleanup_on_exit", 2, cleanup_on_exit, NoTracePredFlag);
Yap_InitCPred("$tag_cleanup", 2, tag_cleanup, 0);
}

145
C/flags.c
View File

@@ -17,9 +17,27 @@
/** @file C/flags.c
@addtogroup Flags
@ingroup core
@brief Prolog parameter setting,
*/
/*
* @namespace prolog
*/
/**
@{
@defgroup YAPFlags_Impl C-code to handle Prolog flags.
@ingroup YAPFlags
@brief Low-level code to support flags.
Prolog Flags can be:
= thread-local or global
= module-based or module-independent.
= read-only or read-write
= System or User Defined.
= Have type boolean, number, atom constant or may be a general term.
*/
// this is where we define flags
@@ -51,7 +69,9 @@ static Term indexer(Term inp);
static Term stream(Term inp);
static bool getenc(Term inp);
static bool typein(Term inp);
static bool dqf(Term t2);
static bool dqs(Term t2);
static bool bqs(Term t2);
static bool sqf(Term t2);
static bool set_error_stream(Term inp);
static bool set_input_stream(Term inp);
static bool set_output_stream(Term inp);
@@ -64,21 +84,22 @@ static Int set_prolog_flag(USES_REGS1);
#include "YapEval.h"
#include "yapio.h"
#define YAP_FLAG(ID, NAME, WRITABLE, DEF, INIT, HELPER) \
{ NAME, WRITABLE, DEF, INIT, HELPER }
#define YAP_FLAG(ID, NAME, WRITABLE, DEF, INIT, HELPER) { NAME, WRITABLE, DEF, INIT, HELPER }
#define START_LOCAL_FLAGS static flag_info local_flags_setup[] = {
#define END_LOCAL_FLAGS LZERO_FLAG};
#define START_GLOBAL_FLAGS static flag_info global_flags_setup[] = {
#define END_GLOBAL_FLAGS GZERO_FLAG};
#define GZERO_FLAG { NULL, false, NULL, NULL, NULL }
#define LZERO_FLAG { NULL, false, NULL, NULL, NULL }
#define GZERO_FLAG \
{ NULL, false, NULL, NULL, NULL }
#define LZERO_FLAG \
{ NULL, false, NULL, NULL, NULL }
static flag_info global_flags_setup[] = {
#include "YapGFlagInfo.h"
GZERO_FLAG};
static flag_info local_flags_setup[] = {
#include "YapLFlagInfo.h"
LZERO_FLAG};
static Term indexer(Term inp) {
if (inp == TermOff || inp == TermSingle || inp == TermCompact ||
@@ -125,7 +146,7 @@ static bool dqf1(ModEntry *new, Term t2 USES_REGS) {
}
}
static bool dqf(Term t2) {
static bool dqs(Term t2) {
CACHE_REGS
ModEntry *new = Yap_GetModuleEntry(CurrentModule);
return dqf1(new, t2 PASS_REGS);
@@ -159,6 +180,48 @@ static bool bqf1(ModEntry *new, Term t2 USES_REGS) {
}
}
static bool bqs(Term t2) {
CACHE_REGS
ModEntry *new = Yap_GetModuleEntry(CurrentModule);
return bqf1(new, t2 PASS_REGS);
}
static bool sqf1(ModEntry *new, Term t2 USES_REGS) {
new->flags &= ~(SNGQ_CHARS | SNGQ_CODES | SNGQ_ATOM | SNGQ_STRING);
if (IsAtomTerm(t2)) {
if (t2 == TermString) {
new->flags |= SNGQ_STRING;
return true;
} else if (t2 == TermAtom) {
new->flags |= SNGQ_ATOM;
return true;
} else if (t2 == TermCodes) {
new->flags |= SNGQ_CODES;
return true;
} else if (t2 == TermChars) {
new->flags |= SNGQ_CHARS;
return true;
}
Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "bad option %s for backquoted "
"string flag, use one string, "
"atom, codes or chars",
RepAtom(AtomOfTerm(t2))->StrOfAE);
return false;
} else {
Yap_Error(TYPE_ERROR_ATOM, t2, "flag %s is not module-scoped",
RepAtom(AtomOfTerm(t2))->StrOfAE);
return false;
}
}
static bool sqf(Term t2) {
CACHE_REGS
ModEntry *new = Yap_GetModuleEntry(CurrentModule);
return sqf1(new, t2 PASS_REGS);
}
static Term isaccess(Term inp) {
if (inp == TermReadWrite || inp == TermReadOnly)
return inp;
@@ -661,7 +724,7 @@ static bool setYapFlagInModule(Term tflag, Term t2, Term mod) {
flag_term *tarr = GLOBAL_Flags;
if (!(fv->type(t2)))
return false;
if (fv->helper && !(fv->helper(t2)))
return false;
Term tout = tarr[fv->FlagOfVE].at;
@@ -715,9 +778,11 @@ static bool setYapFlagInModule(Term tflag, Term t2, Term mod) {
"bad option %s for character_escapes flag, use true or false",
RepAtom(AtomOfTerm(tflag))->StrOfAE);
return false;
} else if (fv->FlagOfVE == BACKQUOTED_STRING_FLAG) {
} else if (fv->FlagOfVE == BACK_QUOTES_FLAG) {
return bqf1(me, t2 PASS_REGS);
;
} else if (fv->FlagOfVE == SINGLE_QUOTES_FLAG) {
return sqf1(me, t2 PASS_REGS);
}
// bad key?
return false;
@@ -744,7 +809,7 @@ static Term getYapFlagInModule(Term tflag, Term mod) {
} else if (fv->FlagOfVE == CHARACTER_ESCAPES_FLAG) {
if (me->flags & M_CHARESCAPE)
return TermTrue;
} else if (fv->FlagOfVE == BACKQUOTED_STRING_FLAG) {
} else if (fv->FlagOfVE == BACK_QUOTES_FLAG) {
if (me->flags & BCKQ_CHARS)
return TermChars;
if (me->flags & BCKQ_CODES)
@@ -752,6 +817,14 @@ static Term getYapFlagInModule(Term tflag, Term mod) {
if (me->flags & BCKQ_ATOM)
return TermAtom;
return TermString;
} else if (fv->FlagOfVE == SINGLE_QUOTES_FLAG) {
if (me->flags & SNGQ_CHARS)
return TermChars;
if (me->flags & SNGQ_CODES)
return TermCodes;
if (me->flags & SNGQ_ATOM)
return TermAtom;
return TermString;
} else if (fv->FlagOfVE == DOUBLE_QUOTES_FLAG) {
if (me->flags & DBLQ_CHARS)
return TermChars;
@@ -777,7 +850,9 @@ static Int cont_yap_flag(USES_REGS1) {
Term modt = CurrentModule;
tflag = Yap_StripModule(tflag, &modt);
while (i != gmax && i != UNKNOWN_FLAG && i != CHARACTER_ESCAPES_FLAG &&
i != BACKQUOTED_STRING_FLAG)
i != BACK_QUOTES_FLAG &&
i != SINGLE_QUOTES_FLAG &&
i != DOUBLE_QUOTES_FLAG)
i++;
if (i == gmax)
cut_fail();
@@ -982,13 +1057,13 @@ void Yap_setModuleFlags(ModEntry *new, ModEntry *cme) {
Atom at = new->AtomOfME;
if (at == AtomProlog || CurrentModule == PROLOG_MODULE) {
new->flags =
M_SYSTEM | UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING;
M_SYSTEM | UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING |SNGQ_ATOM;
if (at == AtomUser)
new->flags = UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING;
new->flags = UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING |SNGQ_ATOM;
} else if (cme && cme->flags && cme != new) {
new->flags = cme->flags;
} else {
new->flags = (UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING);
new->flags = (UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING |SNGQ_ATOM);
}
// printf("cme=%s new=%s flags=%x\n",cme,at->StrOfAE,new->flags);
}
@@ -1034,7 +1109,9 @@ bool setYapFlag(Term tflag, Term t2) {
switch (fv->FlagOfVE) {
case UNKNOWN_FLAG:
case CHARACTER_ESCAPES_FLAG:
case BACKQUOTED_STRING_FLAG:
case BACK_QUOTES_FLAG:
case DOUBLE_QUOTES_FLAG:
case SINGLE_QUOTES_FLAG:
return setYapFlagInModule(tflag, t2, CurrentModule);
default:
tarr = GLOBAL_Flags;
@@ -1135,7 +1212,7 @@ static Int set_prolog_flag(USES_REGS1) {
After executing this goal, YAP keeps information on the source
of the predicates that will be consulted. This enables the use of
[listing/0](@ref listing), `listing/1` and [clause/2](@ref clause) for those
listing/0, listing/1 and clause/2 for those
clauses.
The same as `source_mode(_,on)` or as declaring all newly defined
@@ -1318,7 +1395,7 @@ static bool setInitialValue(bool bootstrap, flag_func f, const char *s,
return false;
}
CACHE_REGS
const unsigned char *us = (const unsigned char *)s;
const char *us = (const char *)s;
t0 = Yap_BufferToTermWithPrioBindings(us, TermNil, 0L, strlen(s) + 1, GLOBAL_MaxPriority);
if (!t0)
return false;
@@ -1367,7 +1444,7 @@ do_prolog_flag_property(Term tflag,
prolog_flag_property_choices_t i;
bool rc = true;
args = Yap_ArgList2ToVector(opts, prolog_flag_property_defs,
PROLOG_FLAG_PROPERTY_END);
PROLOG_FLAG_PROPERTY_END, DOMAIN_ERROR_PROLOG_FLAG);
if (args == NULL) {
Yap_Error(LOCAL_Error_TYPE, opts, NULL);
return false;
@@ -1419,7 +1496,9 @@ do_prolog_flag_property(Term tflag,
if (fv->global) {
if (fv->FlagOfVE == UNKNOWN_FLAG ||
fv->FlagOfVE == CHARACTER_ESCAPES_FLAG ||
fv->FlagOfVE == BACKQUOTED_STRING_FLAG)
fv->FlagOfVE == SINGLE_QUOTES_FLAG ||
fv->FlagOfVE == DOUBLE_QUOTES_FLAG ||
fv->FlagOfVE == BACK_QUOTES_FLAG)
Yap_unify(TermModule, args[PROLOG_FLAG_PROPERTY_SCOPE].tvalue);
rc = rc &&
Yap_unify(TermGlobal, args[PROLOG_FLAG_PROPERTY_SCOPE].tvalue);
@@ -1452,7 +1531,9 @@ static Int cont_prolog_flag_property(USES_REGS1) { /* current_prolog_flag */
lab = MkAtomTerm(Yap_LookupAtom(local_flags_setup[i - gmax].name));
} else {
if (i == UNKNOWN_FLAG || i == CHARACTER_ESCAPES_FLAG ||
i == BACKQUOTED_STRING_FLAG) {
i == SINGLE_QUOTES_FLAG ||
i == DOUBLE_QUOTES_FLAG ||
i == BACK_QUOTES_FLAG) {
Term labs[2];
labs[0] = MkVarTerm();
labs[1] = MkAtomTerm(Yap_LookupAtom(global_flags_setup[i].name));
@@ -1531,7 +1612,7 @@ static Int do_create_prolog_flag(USES_REGS1) {
Term tflag = Deref(ARG1), tval = Deref(ARG2), opts = Deref(ARG3);
args = Yap_ArgList2ToVector(opts, prolog_flag_property_defs,
PROLOG_FLAG_PROPERTY_END);
PROLOG_FLAG_PROPERTY_END, DOMAIN_ERROR_PROLOG_FLAG);
if (args == NULL) {
Yap_Error(LOCAL_Error_TYPE, opts, NULL);
return false;
@@ -1639,9 +1720,9 @@ void Yap_InitFlags(bool bootstrap) {
Yap_InitCPredBack("current_prolog_flag", 2, 1, current_prolog_flag,
cont_yap_flag, 0);
TR = tr0;
/** @pred prolog_flag(? _Flag_,- _Value__)
/** @pred prolog_flag( ?Flag, - Value)
Obtain the value for a YAP Prolog flag, same as current_prolog_flag/2_.
Obtain the value for a YAP Prolog flag, same as current_prolog_flag/2.
*/
Yap_InitCPredBack("prolog_flag", 3, 1, current_prolog_flag, cont_yap_flag,
0);
@@ -1663,3 +1744,5 @@ void Yap_InitFlags(bool bootstrap) {
}
/* Accessing and changing the flags for a predicate */
// @}

2
C/globals.c
View File

@@ -1249,7 +1249,7 @@ Term Yap_SaveTerm(Term t0) {
CACHE_REGS
Term to;
to = CopyTermToArena(
t0, LOCAL_GlobalArena, FALSE, TRUE, 2, &LOCAL_GlobalArena,
Deref(t0), LOCAL_GlobalArena, FALSE, TRUE, 2, &LOCAL_GlobalArena,
garena_overflow_size(ArenaPt(LOCAL_GlobalArena) PASS_REGS) PASS_REGS);
if (to == 0L)
return to;

4
C/index.c
View File

@@ -633,8 +633,10 @@ type_of_verb(rest,passive).
*/
#include <absmi.h>
#include <Yatom.h>
#include "absmi.h"
#include "YapCompile.h"
#if DEBUG
#include "yapio.h"

8
C/init.c
View File

@@ -165,8 +165,10 @@ The following is the list of the declarations of the predefined operators:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:-op(1200,fx,['?-', ':-']).
:-op(1200,xfx,[':-','-->']).
:-op(1150,fx,[block,dynamic,mode,public,multifile,meta_predicate,
sequential,table,initialization]).
:-op(1150,fx,[block,
discontiguous,dynamic,
initialization,mode,multifile,meta_predicate,
public,sequential,table]).
:-op(1100,xfy,[';','|']).
:-op(1050,xfy,->).
:-op(1000,xfy,',').
@@ -1476,7 +1478,7 @@ void Yap_exit(int value) {
run_halt_hooks(value);
Yap_ShutdownLoadForeign();
}
Yap_CloseStreams(false);
Yap_CloseStreams();
Yap_CloseReadline();
#if USE_SYSTEM_MALLOC
#endif

4
C/inlines.c
View File

@@ -21,10 +21,11 @@
@file inlines.c
@{
@defgroup YAP_Inlines Inlined Tests nad Ter Manipulation
@ingroup builtins
@{
*/
@@ -1208,3 +1209,4 @@ cont_genarg( USES_REGS1 )
}
// @}

5
C/load_foreign.c
View File

@@ -45,6 +45,9 @@ Int p_load_foreign(USES_REGS1) {
StringList new;
bool returncode = FALSE;
yhandle_t CurSlot = Yap_StartSlots();
#if __ANDROID__
return true;
#endif
// Yap_DebugPlWrite(ARG1); printf("%s\n", " \n");
// Yap_DebugPlWrite(ARG2); printf("%s\n", " \n");
@@ -94,7 +97,7 @@ Int p_load_foreign(USES_REGS1) {
} else {
f = RepAtom(libs->name)->StrOfAE;
}
Yap_Error(SYSTEM_ERROR_OPERATING_SYSTEM, ARG3,
Yap_Error(SYSTEM_ERROR_OPERATING_SYSTEM, ARG3,
"Foreign module %s does not have initialization function %s", f,
InitProcName);
return false;

2
C/modules.c
View File

@@ -14,6 +14,8 @@
* comments: module support *
* *
*************************************************************************/
#ifdef SCCSLookupSystemModule
static char SccsId[] = "%W% %G%";
#endif

115
C/parser.c
View File

@@ -18,121 +18,6 @@
static char SccsId[] = "%W% %G%";
#endif
/**
@addtogroup YAPSyntax
describe the syntax for Prolog terms. In a second level we describe
the \a tokens from which Prolog \a terms are
built.
@defgroup Formal_Syntax Syntax of Terms
@ingroup YAPSyntax
@{
Below, we describe the syntax of YAP terms from the different
classes of tokens defined above. The formalism used will be <em>BNF</em>,
extended where necessary with attributes denoting integer precedence or
operator type.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
term
----> subterm(1200) end_of_term_marker
subterm(N) ----> term(M) [M <= N]
term(N) ----> op(N, fx) subterm(N-1)
| op(N, fy) subterm(N)
| subterm(N-1) op(N, xfx) subterm(N-1)
| subterm(N-1) op(N, xfy) subterm(N)
| subterm(N) op(N, yfx) subterm(N-1)
| subterm(N-1) op(N, xf)
| subterm(N) op(N, yf)
term(0) ----> atom '(' arguments ')'
| '(' subterm(1200) ')'
| '{' subterm(1200) '}'
| list
| string
| number
| atom
| variable
arguments ----> subterm(999)
| subterm(999) ',' arguments
list ----> '[]'
| '[' list_expr ']'
list_expr ----> subterm(999)
| subterm(999) list_tail
list_tail ----> ',' list_expr
| ',..' subterm(999)
| '|' subterm(999)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notes:
+ \a op(N,T) denotes an atom which has been previously declared with type
\a T and base precedence \a N.
+ Since ',' is itself a pre-declared operator with type \a xfy and
precedence 1000, is \a subterm starts with a '(', \a op must be
followed by a space to avoid ambiguity with the case of a functor
followed by arguments, e.g.:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ (a,b) [the same as '+'(','(a,b)) of arity one]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
versus
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(a,b) [the same as '+'(a,b) of arity two]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
In the first rule for term(0) no blank space should exist between
\a atom and '('.
+
Each term to be read by the YAP parser must end with a single
dot, followed by a blank (in the sense mentioned in the previous
paragraph). When a name consisting of a single dot could be taken for
the end of term marker, the ambiguity should be avoided by surrounding the
dot with single quotes.
@}
*/
/*
* Description:
*
* parser: produces a prolog term from an array of tokens
*
* parser usage: the parser takes its input from an array of token descriptions
* addressed by the global variable 'tokptr' and produces a Term as result. A
* macro 'NextToken' should be defined in 'yap.h' for advancing 'tokptr' from
* one token to the next. In the distributed version this macro also updates
* a variable named 'toktide' for keeping track of how far the parser went
* before failling with a syntax error. The parser should be invoked with
* 'tokptr' pointing to the first token. The last token should have type
* 'eot_tok'. The parser return either a Term. Syntactic errors are signaled
* by a return value 0. The parser builds new terms on the 'global stack' and
* also uses an auxiliary stack pointed to by 'AuxSp'. In the distributed
* version this auxiliary stack is assumed to grow downwards. This
* assumption, however, is only relevant to routine 'ParseArgs', and to the
* variable toktide. conclusion: set tokptr pointing to first token set AuxSp
* Call Parse
*
* VSC: Working whithout known bugs in 87/4/6
*
* LD: -I or +I evaluated by parser 87/4/28
*
* LD: parser extended 87/4/28
*
*/
#include "Yap.h"
#include "YapEval.h"

2
C/qlyr.c
View File

@@ -89,7 +89,7 @@ static void QLYR_ERROR__(const char *file, const char *function, int lineno,
qlfr_err_t my_err) {
// __android_log_print(ANDROID_LOG_INFO, "YAP ", "error %s in saved state
// %s",GLOBAL_RestoreFile, qlyr_error[my_err]);
Yap_Error__(file, function, lineno, SYSTEM_ERROR_SAVED_STATE, TermNil, "error %s in saved state %s",
Yap_Error__(false, file, function, lineno, SYSTEM_ERROR_SAVED_STATE, TermNil, "error %s in saved state %s",
GLOBAL_RestoreFile, qlyr_error[my_err]);
Yap_exit(1);
}

4
C/save.c
View File

@@ -559,7 +559,7 @@ static Int do_save(int mode USES_REGS) {
Yap_Error(TYPE_ERROR_LIST, t1, "save/1");
return FALSE;
}
Yap_CloseStreams(TRUE);
Yap_CloseStreams();
if ((splfild = open_file(LOCAL_FileNameBuf, O_WRONLY | O_CREAT)) < 0) {
Yap_Error(SYSTEM_ERROR_INTERNAL,
MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf)),
@@ -1322,7 +1322,7 @@ static int commit_to_saved_state(const char *s, CELL *Astate, CELL *ATrail,
strcpy(tmp, Yap_AbsoluteFile(s, true));
fprintf(stderr, "%% Restoring file %s\n", tmp);
}
Yap_CloseStreams(TRUE);
Yap_CloseStreams();
}
#ifdef DEBUG_RESTORE4
/*

34
C/scanner.c
View File

@@ -667,7 +667,7 @@ static Term float_send(char *s, int sign) {
#endif
{
CACHE_REGS
return (MkEvalFl(f));
return MkFloatTerm(f);
}
}
@@ -874,7 +874,7 @@ do_switch:
static int num_send_error_message(char s[]) {
CACHE_REGS
LOCAL_ErrorMessage = s;
return TermNil;
return MkStringTerm(s);
}
#define number_overflow() \
@@ -921,7 +921,7 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *st, int sign) {
}
if (ch == '\'') {
if (base > 36) {
return num_send_error_message("Admissible bases are 0..36");
Yap_ThrowError(SYNTAX_ERROR, MkIntegerTerm(base), "Admissible bases are 0..36");
}
might_be_float = FALSE;
if (--left == 0)
@@ -969,7 +969,9 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *st, int sign) {
*sp++ = ch;
ch = getchr(st);
if (!my_isxdigit(ch, 'F', 'f')) {
Yap_InitError(SYNTAX_ERROR, TermNil, "empty hexadecimal number 0x%C",ch) ;
Term t = ( Yap_local.ActiveError->errorRawTerm ? Yap_local.ActiveError->errorRawTerm : MkIntegerTerm(ch) );
Yap_local.ActiveError->errorRawTerm = 0;
Yap_ThrowError(SYNTAX_ERROR, t, "invalid hexadecimal digit 0x%C",ch) ;
return 0;
}
while (my_isxdigit(ch, 'F', 'f')) {
@@ -992,17 +994,21 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *st, int sign) {
base = 8;
ch = getchr(st);
if (ch < '0' || ch > '7') {
Yap_InitError(SYNTAX_ERROR, TermNil, "empty octal number 0b%C", ch) ;
Term t = ( Yap_local.ActiveError->errorRawTerm ? Yap_local.ActiveError->errorRawTerm : MkIntegerTerm(ch) );
Yap_local.ActiveError->errorRawTerm = 0;
Yap_ThrowError(SYNTAX_ERROR, t, "invalid octal digit 0x%C",ch) ;
return 0;
}
} else if (ch == 'b' && base == 0) {
might_be_float = false;
base = 2;
ch = getchr(st);
if (ch < '0' || ch > '1') {
Yap_InitError(SYNTAX_ERROR, TermNil, "empty binary 0b%C", ch) ;
return 0;
}
if (ch < '0' || ch > '1') {
Term t = ( Yap_local.ActiveError->errorRawTerm ? Yap_local.ActiveError->errorRawTerm : MkIntegerTerm(ch) );
Yap_local.ActiveError->errorRawTerm = 0;
Yap_ThrowError(SYNTAX_ERROR, t, "invalid binary digit 0x%C",ch) ;
return 0;
}
} else {
@@ -1032,7 +1038,6 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *st, int sign) {
if (has_dot) {
unsigned char *dp;
int dc;
if (chtype(ch = getchr(st)) != NU) {
if (ch == 'e' || ch == 'E') {
if (trueGlobalPrologFlag(ISO_FLAG))
@@ -1173,12 +1178,9 @@ Term Yap_scan_num(StreamDesc *inp, bool error_on) {
while (isspace(ch = getchr(inp)))
;
#endif
if (LOCAL_ErrorMessage != NULL || ch != -1 || cherr) {
Yap_clean_tokenizer(old_tr, NULL, NULL);
Yap_InitError(SYNTAX_ERROR, ARG2, "while converting stream %d to number", inp-GLOBAL_Stream );
return 0;
}
if (ch == EOF)
return out;
return 0;
}
#define CHECK_SPACE() \
@@ -1671,6 +1673,8 @@ TokEntry *Yap_tokenizer(struct stream_desc *st, bool store_comments,
int pch;
if (ch == '.' && (pch = Yap_peek(st - GLOBAL_Stream)) &&
(chtype(pch) == BS || chtype(pch) == EF || pch == '%')) {
if (chtype(ch) != EF)
getchr(st);
t->Tok = Ord(kind = eot_tok);
// consume...
if (pch == '%') {

402
C/stack.c
View File

@@ -115,7 +115,7 @@ static PredEntry *PredForChoicePt(yamop *p_code, op_numbers *opn) {
*opn = opnum;
switch (opnum) {
case _Nstop:
return NULL;
return PredFail;
case _jump:
p_code = p_code->y_u.l.l;
break;
@@ -209,7 +209,7 @@ static PredEntry *PredForChoicePt(yamop *p_code, op_numbers *opn) {
*
* usually pretty straightforward, it can fall in trouble with
8 OR-P or tabling.
*/
*/
PredEntry *Yap_PredForChoicePt(choiceptr cp, op_numbers *op) {
if (cp == NULL)
return NULL;
@@ -268,8 +268,8 @@ bool Yap_search_for_static_predicate_in_use(PredEntry *p,
/* check first environments that are younger than our latest choicepoint */
if (check_everything && env_ptr) {
/*
I do not need to check environments for asserts,
only for retracts
I do not need to check environments for asserts,
only for retracts
*/
while (env_ptr && b_ptr > (choiceptr)env_ptr) {
yamop *cp = (yamop *)env_ptr[E_CP];
@@ -284,9 +284,9 @@ bool Yap_search_for_static_predicate_in_use(PredEntry *p,
}
/* now mark the choicepoint */
if (b_ptr)
if (b_ptr) {
pe = PredForChoicePt(b_ptr->cp_ap, NULL);
else
} else
return false;
if (pe == p) {
if (check_everything)
@@ -537,6 +537,41 @@ static Int find_code_in_clause(PredEntry *pp, yamop *codeptr, void **startp,
return (0);
}
/*
static bool put_clause_loc(yap_error_descriptor_t *t, void *clcode, PredEntry
*pp) {
CACHE_REGS
if (pp->PredFlags & LogUpdatePredFlag) {
LogUpdClause *cl = clcode;
if (cl->ClFlags & FactMask) {
t->prologPredLine = cl->lusl.ClLine;
} else {
t->prologPredLine = cl->lusl.ClSource->ag.line_number;
}
} else if (pp->PredFlags & DynamicPredFlag) {
// DynamicClause *cl;
// cl = ClauseCodeToDynamicClause(clcode);
return false;
} else if (pp->PredFlags & MegaClausePredFlag) {
MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
t->prologPredLine = mcl->ClLine;
} else {
StaticClause *cl;
cl = clcode;
if (cl->ClFlags & FactMask) {
t->prologPredLine = cl->usc.ClLine;
} else if (cl->ClFlags & SrcMask) {
t->prologPredLine = cl->usc.ClSource->ag.line_number;
} else
return MkIntTerm(0);
}
return MkIntTerm(0);
}
*/
static Term clause_loc(void *clcode, PredEntry *pp) {
CACHE_REGS
@@ -1086,54 +1121,55 @@ static Term clause_info(yamop *codeptr, PredEntry *pp) {
return Yap_MkApplTerm(FunctorModule, 2, ts);
}
bool set_clause_info(yamop *codeptr, PredEntry *pp) {
yap_error_descriptor_t *set_clause_info(yap_error_descriptor_t *t,
yamop *codeptr, PredEntry *pp) {
CACHE_REGS
Term ts[2];
void *begin;
if (pp->ArityOfPE == 0) {
LOCAL_ActiveError->prologPredName =
RepAtom((Atom)pp->FunctorOfPred)->StrOfAE;
LOCAL_ActiveError->prologPredArity = 0;
t->prologPredName = AtomName((Atom)pp->FunctorOfPred);
t->prologPredArity = 0;
} else {
LOCAL_ActiveError->prologPredName =
RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE;
LOCAL_ActiveError->prologPredArity = pp->ArityOfPE;
t->prologPredName = AtomName(NameOfFunctor(pp->FunctorOfPred));
t->prologPredArity = pp->ArityOfPE;
}
LOCAL_ActiveError->prologPredModule =
t->prologPredModule =
(pp->ModuleOfPred ? RepAtom(AtomOfTerm(pp->ModuleOfPred))->StrOfAE
: "prolog");
LOCAL_ActiveError->prologPredFile = RepAtom(pp->src.OwnerFile)->StrOfAE;
t->prologPredFile = RepAtom(pp->src.OwnerFile)->StrOfAE;
if (codeptr->opc == UNDEF_OPCODE) {
LOCAL_ActiveError->prologPredFirstLine = 0;
LOCAL_ActiveError->prologPredLine = 0;
LOCAL_ActiveError->prologPredLastLine = 0;
return true;
t->prologPredFirstLine = 0;
t->prologPredLine = 0;
t->prologPredLastLine = 0;
return t;
} else if (pp->cs.p_code.NOfClauses) {
if ((LOCAL_ActiveError->prologPredCl =
find_code_in_clause(pp, codeptr, &begin, NULL)) <= 0) {
LOCAL_ActiveError->prologPredLine = 0;
if ((t->prologPredCl = find_code_in_clause(pp, codeptr, &begin, NULL)) <=
0) {
t->prologPredLine = 0;
} else {
LOCAL_ActiveError->prologPredLine = IntegerOfTerm(clause_loc(begin, pp));
t->prologPredLine = IntegerOfTerm(clause_loc(begin, pp));
}
if (pp->PredFlags & LogUpdatePredFlag) {
LOCAL_ActiveError->prologPredFirstLine = IntegerOfTerm(
ts[0] = clause_loc(
ClauseCodeToLogUpdClause(pp->cs.p_code.FirstClause), pp));
LOCAL_ActiveError->prologPredLastLine = IntegerOfTerm(
ts[1] = clause_loc(ClauseCodeToLogUpdClause(pp->cs.p_code.LastClause),
pp));
t->prologPredFirstLine =
clause_loc(ClauseCodeToLogUpdClause(pp->cs.p_code.FirstClause), pp);
t->prologPredLastLine =
clause_loc(ClauseCodeToLogUpdClause(pp->cs.p_code.LastClause), pp);
} else {
LOCAL_ActiveError->prologPredFirstLine = IntegerOfTerm(
t->prologPredFirstLine = IntegerOfTerm(
ts[0] = clause_loc(
ClauseCodeToStaticClause(pp->cs.p_code.FirstClause), pp));
LOCAL_ActiveError->prologPredLastLine = IntegerOfTerm(
t->prologPredLastLine = IntegerOfTerm(
ts[1] = clause_loc(ClauseCodeToStaticClause(pp->cs.p_code.LastClause),
pp));
}
return true;
return t;
} else {
return false;
t->prologPredFirstLine = 0;
t->prologPredLine = t->errorLine;
t->prologPredLastLine = 0;
t->prologPredFile = t->errorFile;
return t;
}
}
@@ -1161,33 +1197,47 @@ static Term error_culprit(bool internal USES_REGS) {
return TermNil;
}
bool Yap_find_prolog_culprit(USES_REGS1) {
yap_error_descriptor_t *
Yap_prolog_add_culprit(yap_error_descriptor_t *t PASS_REGS) {
PredEntry *pe;
void *startp, *endp;
// case number 1: Yap_Error called from built-in.
pe = ClauseInfoForCode(P, &startp, &endp PASS_REGS);
if (pe && (CurrentModule == 0 || !(pe->PredFlags & HiddenPredFlag))) {
return set_clause_info(P, pe);
return set_clause_info(t, P, pe);
} else {
CELL *curENV = ENV;
yamop *curCP = CP;
choiceptr curB = B;
PredEntry *pe = EnvPreg(curCP);
while (curCP != YESCODE) {
curENV = (CELL *)(curENV[E_E]);
if (curENV < ASP || curENV >= LCL0) {
break;
if (curENV) {
pe = EnvPreg(curCP);
curENV = (CELL *)(curENV[E_E]);
if (curENV < ASP || curENV >= LCL0) {
break;
}
curCP = (yamop *)curENV[E_CP];
if (pe == NULL) {
pe = PredMetaCall;
}
if (pe->ModuleOfPred || !(pe->PredFlags & HiddenPredFlag))
return set_clause_info(t, curCP, pe);
curCP = (yamop *)(curENV[E_CP]);
} else if (0) {
if (curB->cp_ap != NOCODE && curB->cp_ap != TRUSTFAILCODE &&
curB->cp_ap != FAILCODE) {
pe = curB->cp_ap->y_u.Otapl.p;
if (pe && (pe->ModuleOfPred || !(pe->PredFlags & HiddenPredFlag)))
return set_clause_info(t, curB->cp_ap, pe);
}
curB = curB->cp_b;
}
pe = EnvPreg(curCP);
if (pe == NULL) {
pe = PredMetaCall;
}
if (pe->ModuleOfPred)
return set_clause_info(curCP, pe);
curCP = (yamop *)(curENV[E_CP]);
}
}
return TermNil;
return NULL;
}
static Term all_calls(bool internal USES_REGS) {
@@ -1211,19 +1261,20 @@ static Term all_calls(bool internal USES_REGS) {
return Yap_MkApplTerm(f, 6, ts);
}
/**
* report the current status of the stacks up to level $N$
*
* @param depth
*
* @return data on the current program counter
*/
Term Yap_all_calls(void) {
CACHE_REGS
return all_calls(true PASS_REGS);
}
/**
* @pred current_stack( +Depth )
*
* report the current status of the stacks up to level $N$
*
* @param Depth
*
* @return data on the current Prolog stack.
*/
static Int current_stack(USES_REGS1) {
Term t;
while ((t = all_calls(false PASS_REGS)) == 0L) {
@@ -1340,15 +1391,15 @@ void Yap_dump_code_area_for_profiler(void) {
while (pp != NULL) {
/* if (pp->ArityOfPE) {
fprintf(stderr,"%s/%d %p\n",
RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE,
pp->ArityOfPE,
pp);
} else {
fprintf(stderr,"%s %p\n",
RepAtom((Atom)(pp->FunctorOfPred))->StrOfAE,
pp);
}*/
fprintf(stderr,"\%s/%d %p\n",
RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE,
pp->ArityOfPE,
pp);
} else {
fprintf(stderr,"\%s %p\n",
RepAtom((Atom)(pp->FunctorOfPred))->StrOfAE,
pp);
}*/
add_code_in_pred(pp);
pp = pp->NextPredOfModule;
}
@@ -1745,23 +1796,83 @@ void Yap_dump_stack(void) {
/* check if handled */
if (handled_exception(PASS_REGS1))
return;
#if DEBUG
fprintf(stderr, "%% YAP regs: P=%p, CP=%p, ASP=%p, H=%p, TR=%p, HeapTop=%p\n",
#if DEBU
fprintf(stderr, "\% YAP regs: P=%p, CP=%p, ASP=%p, H=%p, TR=%p, HeapTop=%p\n",
P, CP, ASP, HR, TR, HeapTop);
fprintf(stderr, "%% YAP mode: %ux\n", (unsigned int)LOCAL_PrologMode);
if (LOCAL_ErrorMessage)
fprintf(stderr, "%% LOCAL_ErrorMessage: %s\n", LOCAL_ErrorMessage);
#endif
fprintf(stderr, "\% \n% =====================================\n\%\n");
fprintf(stderr, "\% \n% YAP Status:\n");
fprintf(stderr, "\% \n\% -------------------------------------\n\%\n");
yap_error_descriptor_t errno = LOCAL_Error_TYPE;
yap_error_class_number classno = Yap_errorClass(errno);
fprintf(stderr, "\% Error STATUS: %s/%s\n\n", Yap_errorName(errno),
Yap_errorName(classno));
fprintf(stderr, "\% Execution mode\n");
if (LOCAL_PrologMode & BootMode)
fprintf(stderr, "\% Bootstrap\n");
if (LOCAL_PrologMode & UserMode)
fprintf(stderr, "\% User Prolo\n");
if (LOCAL_PrologMode & CritMode)
fprintf(stderr, "\% Exclusive Access Mode\n");
if (LOCAL_PrologMode & AbortMode)
fprintf(stderr, "\% Abort\n");
if (LOCAL_PrologMode & InterruptMode)
fprintf(stderr, "\% Interrupt\n");
if (LOCAL_PrologMode & InErrorMode)
fprintf(stderr, "\% Error\n");
if (LOCAL_PrologMode & ConsoleGetcMode)
fprintf(stderr, "\% Prompt Console\n");
if (LOCAL_PrologMode & ExtendStackMode)
fprintf(stderr, "\% Stack expansion \n");
if (LOCAL_PrologMode & GrowHeapMode)
fprintf(stderr, "\% Data Base Expansion\n");
if (LOCAL_PrologMode & GrowStackMode)
fprintf(stderr, "\% User Prolog\n");
if (LOCAL_PrologMode & GCMode)
fprintf(stderr, "\% Garbage Collection\n");
if (LOCAL_PrologMode & ErrorHandlingMode)
fprintf(stderr, "\% Error handler\n");
if (LOCAL_PrologMode & CCallMode)
fprintf(stderr, "\% System Foreign Code\n");
if (LOCAL_PrologMode & UnifyMode)
fprintf(stderr, "\% Off-line Foreign Code\n");
if (LOCAL_PrologMode & UserCCallMode)
fprintf(stderr, "\% User Foreig C\n");
if (LOCAL_PrologMode & MallocMode)
fprintf(stderr, "\% Heap Allocaror\n");
if (LOCAL_PrologMode & SystemMode)
fprintf(stderr, "\% Prolog Internals\n");
if (LOCAL_PrologMode & AsyncIntMode)
fprintf(stderr, "\% Async Interruot mode\n");
if (LOCAL_PrologMode & InReadlineMode)
fprintf(stderr, "\% Readline Console\n");
if (LOCAL_PrologMode & TopGoalMode)
fprintf(stderr, "\% Creating new query\n");
fprintf(stderr, "\% \n\% -------------------------------------\n\%\n");
fprintf(stderr, "\% \n% YAP Program :\n");
fprintf(stderr, "\% \n\% -------------------------------------\n\%\n");
fprintf(stderr, "\% Program Position\n\n", Yap_errorName(errno),
Yap_errorName(classno);
Yap_detect_bug_location(CP, FIND_PRED_FROM_ANYWHERE, 256);
fprintf(stderr, "\% PC: %s\n", (char *)HR);
Yap_detect_bug_location(CP, FIND_PRED_FROM_ANYWHERE, 256);
fprintf(stderr, "\% Continuation: %s\n", (char *)HR);
Yap_detect_bug_location(B->cp_ap, FIND_PRED_FROM_ANYWHERE, 256);
fprintf(stderr, "\% Alternative: %s\n", (char *)HR);
if (HR > ASP || HR > LCL0) {
fprintf(stderr, "%% YAP ERROR: Global Collided against Local (%p--%p)\n",
fprintf(stderr, "\% YAP ERROR: Global Collided against Local (%p--%p)\n",
HR, ASP);
} else if (HeapTop > (ADDR)LOCAL_GlobalBase) {
fprintf(stderr,
"%% YAP ERROR: Code Space Collided against Global (%p--%p)\n",
"\% YAP ERROR: Code Space Collided against Global (%p--%p)\n",
HeapTop, LOCAL_GlobalBase);
} else {
#if !USE_SYSTEM_MALLOC
fprintf(stderr, "%ldKB of Code Space (%p--%p)\n",
fprintf(stderr, "\%ldKB of Code Space (%p--%p)\n",
(long int)((CELL)HeapTop - (CELL)Yap_HeapBase) / 1024, Yap_HeapBase,
HeapTop);
#if USE_DL_MALLOC
@@ -1774,18 +1885,14 @@ void Yap_dump_stack(void) {
}
#endif
#endif
Yap_detect_bug_location(P, FIND_PRED_FROM_ANYWHERE, 256);
fprintf(stderr, "%%\n%% PC: %s\n", (char *)HR);
Yap_detect_bug_location(CP, FIND_PRED_FROM_ANYWHERE, 256);
fprintf(stderr, "%% Continuation: %s\n", (char *)HR);
fprintf(stderr, "%% %luKB of Global Stack (%p--%p)\n",
fprintf(stderr, "\% %luKB of Global Stack (%p--%p)\n",
(unsigned long int)(sizeof(CELL) * (HR - H0)) / 1024, H0, HR);
fprintf(stderr, "%% %luKB of Local Stack (%p--%p)\n",
fprintf(stderr, "\% %luKB of Local Stack (%p--%p)\n",
(unsigned long int)(sizeof(CELL) * (LCL0 - ASP)) / 1024, ASP, LCL0);
fprintf(stderr, "%% %luKB of Trail (%p--%p)\n",
fprintf(stderr, "\% %luKB of Trail (%p--%p)\n",
(unsigned long int)((ADDR)TR - LOCAL_TrailBase) / 1024,
LOCAL_TrailBase, TR);
fprintf(stderr, "%% Performed %ld garbage collections\n",
fprintf(stderr, "\% Performed %ld garbage collections\n",
(unsigned long int)LOCAL_GcCalls);
#if LOW_LEVEL_TRACER
{
@@ -1800,20 +1907,20 @@ void Yap_dump_stack(void) {
}
}
#endif
fprintf(stderr, "%% All Active Calls and\n");
fprintf(stderr, "%% Goals With Alternatives Open (Global In "
fprintf(stderr, "\% All Active Calls and\n");
fprintf(stderr, "\% Goals With Alternatives Open (Global In "
"Use--Local In Use)\n%%\n");
while (b_ptr != NULL) {
while (env_ptr && env_ptr <= (CELL *)b_ptr) {
Yap_detect_bug_location(ipc, FIND_PRED_FROM_ENV, 256);
if (env_ptr == (CELL *)b_ptr && (choiceptr)env_ptr[E_CB] > b_ptr) {
b_ptr = b_ptr->cp_b;
fprintf(stderr, "%% %s\n", tp);
fprintf(stderr, "\% %s\n", tp);
} else {
fprintf(stderr, "%% %s\n", tp);
}
if (!max_count--) {
fprintf(stderr, "%% .....\n");
fprintf(stderr, "\% .....\n");
return;
}
ipc = (yamop *)(env_ptr[E_CP]);
@@ -1821,7 +1928,7 @@ void Yap_dump_stack(void) {
}
if (b_ptr) {
if (!max_count--) {
fprintf(stderr, "%% .....\n");
fprintf(stderr, "\%\** .....\n");
return;
}
if (b_ptr->cp_ap && /* tabling */
@@ -1830,7 +1937,7 @@ void Yap_dump_stack(void) {
b_ptr->cp_ap->opc != Yap_opcode(_Nstop)) {
/* we can safely ignore ; because there is always an upper env */
Yap_detect_bug_location(b_ptr->cp_ap, FIND_PRED_FROM_CP, 256);
fprintf(stderr, "%% %s (%luKB--%luKB)\n", tp,
fprintf(stderr, "\% %s (%luKB--%luKB)\n", tp,
(unsigned long int)((b_ptr->cp_h - H0) * sizeof(CELL) / 1024),
(unsigned long int)((ADDR)LCL0 - (ADDR)b_ptr) / 1024);
}
@@ -1895,7 +2002,7 @@ void DumpActiveGoals(USES_REGS1) {
op_numbers opnum;
if (!ONLOCAL(b_ptr) || b_ptr->cp_b == NULL)
break;
fprintf(stderr, "%p ", b_ptr);
fprintf(stderr, "\%p ", b_ptr);
pe = Yap_PredForChoicePt(b_ptr, &opnum);
if (opnum == _Nstop) {
fprintf(stderr, " ********** C-Code Interface Boundary ***********\n");
@@ -1983,41 +2090,40 @@ void Yap_detect_bug_location(yamop *yap_pc, int where_from, int psize) {
if ((cl = Yap_PredForCode(yap_pc, where_from, &pred_name, &pred_arity,
&pred_module)) == 0) {
/* system predicate */
fprintf(stderr, "%s", "meta-call");
fprintf(stderr, "\%s", "meta-call");
} else if (pred_module == 0) {
fprintf(stderr, "in prolog:%s/%lu", RepAtom(pred_name)->StrOfAE,
(unsigned long int)pred_arity);
} else if (cl < 0) {
fprintf(stderr, "%s:%s/%lu", RepAtom(AtomOfTerm(pred_module))->StrOfAE,
fprintf(stderr, "\%s:%s/%lu", RepAtom(AtomOfTerm(pred_module))->StrOfAE,
RepAtom(pred_name)->StrOfAE, (unsigned long int)pred_arity);
} else {
fprintf(stderr, "%s:%s/%lu at clause %lu",
fprintf(stderr, "\%s:%s/%lu at clause %lu",
RepAtom(AtomOfTerm(pred_module))->StrOfAE,
RepAtom(pred_name)->StrOfAE, (unsigned long int)pred_arity,
(unsigned long int)cl);
}
}
static Term build_bug_location(yamop *codeptr, PredEntry *pe) {
static yap_error_descriptor_t *add_bug_location(yap_error_descriptor_t *p,
yamop *codeptr, PredEntry *pe) {
CACHE_REGS
Term p[5];
if (pe->ModuleOfPred == PROLOG_MODULE)
p[0] = TermProlog;
p->prologPredModule = AtomName(AtomProlog);
else
p[0] = pe->ModuleOfPred;
p->prologPredModule = AtomName(AtomOfTerm(pe->ModuleOfPred));
if (pe->ArityOfPE)
p[1] = MkAtomTerm(NameOfFunctor(pe->FunctorOfPred));
p->prologPredName = AtomName(NameOfFunctor(pe->FunctorOfPred));
else
p[1] = MkAtomTerm((Atom)pe->FunctorOfPred);
p[2] = MkIntegerTerm(pe->ArityOfPE);
p[3] = TermNil;
p[4] = MkIntTerm(0);
p->prologPredName = AtomName((Atom)(pe->FunctorOfPred));
p->prologPredArity = pe->ArityOfPE;
p->prologPredFile = AtomName(pe->src.OwnerFile);
p->prologPredLine = 0;
if (pe->src.OwnerFile) {
p[3] = MkAtomTerm(pe->src.OwnerFile);
if (pe->PredFlags & MegaClausePredFlag) {
MegaClause *mcl;
mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
p[4] = MkIntegerTerm(mcl->ClLine);
p->prologPredLine = mcl->ClLine;
} else {
void *clcode;
if (find_code_in_clause(pe, codeptr, &clcode, NULL) > 0) {
@@ -2025,71 +2131,76 @@ static Term build_bug_location(yamop *codeptr, PredEntry *pe) {
LogUpdClause *cl = clcode;
if (cl->ClFlags & FactMask) {
p[4] = MkIntegerTerm(cl->lusl.ClLine);
} else {
p[4] = MkIntegerTerm(cl->lusl.ClSource->ag.line_number);
p->prologPredLine = cl->lusl.ClSource->ag.line_number;
}
} else if (pe->PredFlags & DynamicPredFlag) {
p[4] = MkIntTerm(0);
p->prologPredLine = 0;
} else {
StaticClause *cl;
cl = clcode;
if (cl->ClFlags & FactMask) {
p[4] = MkIntTerm(cl->usc.ClLine);
p->prologPredLine = MkIntTerm(cl->usc.ClLine);
} else if (cl->ClFlags & SrcMask) {
p[4] = MkIntTerm(cl->usc.ClSource->ag.line_number);
p->prologPredLine = cl->usc.ClSource->ag.line_number;
} else
p[4] = MkIntTerm(0);
p->prologPredLine = 0;
}
} else {
p[4] = MkIntTerm(0);
p->prologPredLine = 0;
}
}
}
else if (pe->OpcodeOfPred == UNDEF_OPCODE) {
RESET_VARIABLE(p + 3);
RESET_VARIABLE(p + 4);
}
else {
} else if (pe->OpcodeOfPred == UNDEF_OPCODE) {
p->prologPredFile = "undefined";
} else {
// by default, user_input
p[3] = MkAtomTerm(AtomUserIn);
p[4] = MkIntTerm(0);
p->prologPredFile = AtomName(AtomUserIn);
p->prologPredLine = 0;
}
return Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("p"), 5), 5, p);
return p;
}
Term Yap_pc_location(yamop *pc, choiceptr b_ptr, CELL *env) {
yap_error_descriptor_t *Yap_pc_add_location(yap_error_descriptor_t *t,
void *pc0, void *b_ptr0,
void *env0) {
CACHE_REGS
yamop *codeptr = pc;
yamop *xc = pc0;
// choiceptr b_ptr = b_ptr0;
// CELL *env = env0;
PredEntry *pe;
if (PP == NULL) {
if (PredForCode(pc, NULL, NULL, NULL, &pe) <= 0)
return TermNil;
if (PredForCode(xc, NULL, NULL, NULL, &pe) <= 0)
return NULL;
} else
pe = PP;
if (pe != NULL
// pe->ModuleOfPred != PROLOG_MODULE &&
// &&!(pe->PredFlags & HiddenPredFlag)
) {
return build_bug_location(codeptr, pe);
return add_bug_location(t, xc, pe);
}
return TermNil;
return NULL;
}
Term Yap_env_location(yamop *cp, choiceptr b_ptr, CELL *env, Int ignore_first) {
yap_error_descriptor_t *Yap_env_add_location(yap_error_descriptor_t *t,
void *cp0, void *b_ptr0,
void *env0, YAP_Int ignore_first) {
yamop *cp = cp0;
choiceptr b_ptr = b_ptr0;
CELL *env = env0;
while (true) {
if (b_ptr == NULL || env == NULL)
return TermNil;
return NULL;
PredEntry *pe = EnvPreg(cp);
if (pe == PredTrue)
return TermNil;
return NULL;
if (ignore_first <= 0 &&
pe
// pe->ModuleOfPred != PROLOG_MODULE &&s
&& !(pe->PredFlags & HiddenPredFlag)) {
return build_bug_location(cp, pe);
return add_bug_location(t, cp, pe);
} else {
if (NULL && b_ptr && b_ptr->cp_env < env) {
cp = b_ptr->cp_cp;
@@ -2104,14 +2215,43 @@ Term Yap_env_location(yamop *cp, choiceptr b_ptr, CELL *env, Int ignore_first) {
}
}
/*
Term Yap_env_location(yamop *cp, choiceptr b_ptr, CELL *env, Int ignore_first)
{ while (true) { if (b_ptr == NULL || env == NULL) return TermNil; PredEntry
*pe = EnvPreg(cp); if (pe == PredTrue) return TermNil; if (ignore_first <= 0
&& pe
// pe->ModuleOfPred != PROLOG_MODULE &&s
&& !(pe->PredFlags & HiddenPredFlag)) {
return add_bug_location(cp, pe);
} else {
if (NULL && b_ptr && b_ptr->cp_env < env) {
cp = b_ptr->cp_cp;
env = b_ptr->cp_env;
b_ptr = b_ptr->cp_b;
} else {
cp = (yamop *)env[E_CP];
env = ENV_Parent(env);
}
ignore_first--;
}
}
}
*/
static Term mkloc(yap_error_descriptor_t *t) { return TermNil; }
static Int clause_location(USES_REGS1) {
return Yap_unify(Yap_pc_location(P, B, ENV), ARG1) &&
Yap_unify(Yap_env_location(CP, B, ENV, 1), ARG2);
yap_error_descriptor_t t;
memset(&t, 0, sizeof(yap_error_descriptor_t));
return Yap_unify(mkloc(Yap_pc_add_location(&t, P, B, ENV)), ARG1) &&
Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 1)), ARG2);
}
static Int ancestor_location(USES_REGS1) {
return Yap_unify(Yap_env_location(CP, B, ENV, 2), ARG1) &&
Yap_unify(Yap_env_location(CP, B, ENV, 3), ARG2);
yap_error_descriptor_t t;
memset(&t, 0, sizeof(yap_error_descriptor_t));
return Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 2)), ARG2) &&
Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 3)), ARG2);
}
void Yap_InitStInfo(void) {

2
C/stackinfo.c
View File

@@ -26,7 +26,7 @@
* @brief Get to know what is in your stack.
*
*
*/
` */
#include "Yap.h"
#include "clause.h"

211
C/text.c
View File

@@ -32,7 +32,9 @@ inline static size_t min_size(size_t i, size_t j) { return (i < j ? i : j); }
#endif
#if !defined(HAVE_STPCPY) && !defined(__APPLE__)
inline static void* __stpcpy(void * i, const void * j) { return strcpy(i,j)+strlen(j);}
inline static void *__stpcpy(void *i, const void *j) {
return strcpy(i, j) + strlen(j);
}
#define stpcpy __stpcpy
#endif
@@ -89,7 +91,7 @@ void *pop_output_text_stack__(int i, const void *export) {
while (p) {
struct mblock *np = p->next;
if (p + 1 == export) {
size_t sz = p->sz-sizeof(struct mblock) ;
size_t sz = p->sz - sizeof(struct mblock);
memcpy(p, p + 1, sz);
export = p;
} else {
@@ -185,19 +187,19 @@ void *Realloc(void *pt, size_t sz USES_REGS) {
return o + 1;
}
/**
* Export a local memory object as a RO object to the outside world, that is, recovering as much storage as one can.
* Export a local memory object as a RO object to the outside world, that is,
* recovering as much storage as one can.
* @param pt pointer to object
* @return new object
*/
const void *MallocExportAsRO(const void *pt USES_REGS) {
struct mblock *old = (void *)pt, *o = old-1;
if (old == NULL)
return NULL;
struct mblock *old = (void *)pt, *o = old - 1;
if (old == NULL)
return NULL;
size_t sz = o->sz;
release_block(o);
memcpy((void*)o, pt,sz);
memcpy((void *)o, pt, sz);
return realloc((void *)o, sz);
}
@@ -249,42 +251,61 @@ static void *codes2buf(Term t0, void *b0, bool *get_codes USES_REGS) {
while (IsPairTerm(t)) {
Term hd = HeadOfTerm(t);
if (IsVarTerm(hd)) {
Yap_Error(INSTANTIATION_ERROR, t0, "scanning list of codes");
Yap_ThrowError(INSTANTIATION_ERROR, hd, "scanning list of codes");
return NULL;
}
if (!IsIntegerTerm(hd)) {
Yap_Error(TYPE_ERROR_INTEGER, t0, "scanning list of codes");
Yap_ThrowError(TYPE_ERROR_CHARACTER_CODE, hd, "scanning list of codes");
return NULL;
}
Int code = IntegerOfTerm(hd);
if (code < 0) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE, t0,
"scanning list of codes");
Yap_ThrowError(TYPE_ERROR_CHARACTER_CODE, hd, "scanning list of codes");
return NULL;
}
length += put_utf8(ar, code);
t = TailOfTerm(t);
if (IsVarTerm(t)) {
Yap_ThrowError(INSTANTIATION_ERROR, t, "scanning list of codes");
return NULL;
}
if (!IsPairTerm(t) && t != TermNil) {
Yap_ThrowError(TYPE_ERROR_LIST, t, "scanning list of codes");
return NULL;
}
}
} else {
while (IsPairTerm(t)) {
Term hd = HeadOfTerm(t);
if (IsVarTerm(hd)) {
Yap_ThrowError(INSTANTIATION_ERROR, hd, "scanning list of codes");
return NULL;
}
if (!IsAtomTerm(hd)) {
Yap_Error(TYPE_ERROR_ATOM, t0, "scanning list of atoms");
Yap_ThrowError(TYPE_ERROR_CHARACTER, hd, "scanning list of atoms");
return NULL;
}
const char *code = RepAtom(AtomOfTerm(hd))->StrOfAE;
if (code < 0) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER, t0, "scanning list of atoms");
Yap_ThrowError(TYPE_ERROR_CHARACTER, hd, "scanning list of atoms");
return NULL;
}
length += strlen(code);
t = TailOfTerm(t);
if (IsVarTerm(t)) {
Yap_ThrowError(INSTANTIATION_ERROR, t, "scanning list of codes");
return NULL;
}
if (!IsPairTerm(t) && t != TermNil) {
Yap_ThrowError(TYPE_ERROR_LIST, t, "scanning list of codes");
return NULL;
}
}
}
if (!IsVarTerm(t)) {
if (t != TermNil) {
Yap_Error(TYPE_ERROR_INTEGER, t0, "scanning list of codes");
Yap_ThrowError(TYPE_ERROR_LIST, t0, "scanning list of codes");
return NULL;
}
}
@@ -294,7 +315,6 @@ static void *codes2buf(Term t0, void *b0, bool *get_codes USES_REGS) {
if (codes) {
while (IsPairTerm(t)) {
Term hd = HeadOfTerm(t);
Int code = IntegerOfTerm(hd);
st = st + put_utf8(st, code);
@@ -400,6 +420,7 @@ static yap_error_number gen_type_error(int flags) {
unsigned char *Yap_readText(seq_tv_t *inp USES_REGS) {
int lvl = push_text_stack();
/* we know what the term is */
if (!(inp->type & (YAP_STRING_CHARS | YAP_STRING_WCHARS))) {
if (!(inp->type & YAP_STRING_TERM)) {
@@ -417,9 +438,12 @@ unsigned char *Yap_readText(seq_tv_t *inp USES_REGS) {
LOCAL_Error_TYPE = TYPE_ERROR_TEXT;
}
}
LOCAL_ActiveError->errorRawTerm = inp->val.t;
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR)
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
pop_text_stack(lvl);
return NULL;
}
if (IsAtomTerm(inp->val.t) && inp->type & YAP_STRING_ATOM) {
// this is a term, extract to a buffer, and representation is wide
@@ -428,85 +452,93 @@ unsigned char *Yap_readText(seq_tv_t *inp USES_REGS) {
if (RepAtom(at)->UStrOfAE[0] == 0) {
unsigned char *o = Malloc(4);
memset(o, 0, 4);
return o;
return pop_output_text_stack(lvl, o);
}
if (inp->type & YAP_STRING_WITH_BUFFER)
if (inp->type & YAP_STRING_WITH_BUFFER) {
pop_text_stack(lvl);
return at->UStrOfAE;
}
size_t sz = strlen(at->StrOfAE);
inp->type |= YAP_STRING_IN_TMP;
char *o = BaseMalloc(sz + 1);
void *o = Malloc(sz + 1);
strcpy(o, at->StrOfAE);
return (unsigned char *)o;
return pop_output_text_stack(lvl, o);
}
if (IsStringTerm(inp->val.t) && inp->type & YAP_STRING_STRING) {
// this is a term, extract to a buffer, and representation is wide
// Yap_DebugPlWriteln(inp->val.t);
const char *s = StringOfTerm(inp->val.t);
if (s[0] == 0) {
char *o = BaseMalloc(4);
char *o = Malloc(4);
memset(o, 0, 4);
return pop_output_text_stack(lvl, o);
}
if (inp->type & YAP_STRING_WITH_BUFFER)
return (unsigned char *)UStringOfTerm(inp->val.t);
inp->type |= YAP_STRING_IN_TMP;
size_t sz = strlen(s);
char *o = BaseMalloc(sz + 1);
char *o = Malloc(sz + 1);
strcpy(o, s);
return (unsigned char *)o;
return pop_output_text_stack(lvl, o);
}
if (((inp->type & (YAP_STRING_CODES | YAP_STRING_ATOMS)) ==
(YAP_STRING_CODES | YAP_STRING_ATOMS)) &&
IsPairOrNilTerm(inp->val.t)) {
// Yap_DebugPlWriteln(inp->val.t);
return Yap_ListToBuffer(NULL, inp->val.t, inp PASS_REGS);
return pop_output_text_stack(
lvl, Yap_ListToBuffer(NULL, inp->val.t, inp PASS_REGS));
// this is a term, extract to a sfer, and representation is wide
}
if (inp->type & YAP_STRING_CODES && IsPairOrNilTerm(inp->val.t)) {
// Yap_DebugPlWriteln(inp->val.t);
return Yap_ListOfCodesToBuffer(NULL, inp->val.t, inp PASS_REGS);
return pop_output_text_stack(
lvl, Yap_ListOfCodesToBuffer(NULL, inp->val.t, inp PASS_REGS));
// this is a term, extract to a sfer, and representation is wide
}
if (inp->type & YAP_STRING_ATOMS && IsPairOrNilTerm(inp->val.t)) {
// Yap_DebugPlWriteln(inp->val.t);
return Yap_ListOfAtomsToBuffer(NULL, inp->val.t, inp PASS_REGS);
return pop_output_text_stack(
lvl, Yap_ListOfAtomsToBuffer(NULL, inp->val.t, inp PASS_REGS));
// this is a term, extract to a buffer, and representation is wide
}
if (inp->type & YAP_STRING_INT && IsIntegerTerm(inp->val.t)) {
// ASCII, so both LATIN1 and UTF-8
// Yap_DebugPlWriteln(inp->val.t);
char *s;
s = BaseMalloc(2 * MaxTmp(PASS_REGS1));
s = Malloc(2 * MaxTmp(PASS_REGS1));
if (snprintf(s, MaxTmp(PASS_REGS1) - 1, Int_FORMAT,
IntegerOfTerm(inp->val.t)) < 0) {
AUX_ERROR(inp->val.t, 2 * MaxTmp(PASS_REGS1), s, char);
}
return (unsigned char *)s;
return pop_output_text_stack(lvl, s);
}
if (inp->type & YAP_STRING_FLOAT && IsFloatTerm(inp->val.t)) {
char *s;
// Yap_DebugPlWriteln(inp->val.t);
if (!Yap_FormatFloat(FloatOfTerm(inp->val.t), &s, 1024)) {
pop_text_stack(lvl);
return NULL;
}
return (unsigned char *)s;
return pop_output_text_stack(lvl, s);
}
#if USE_GMP
if (inp->type & YAP_STRING_BIG && IsBigIntTerm(inp->val.t)) {
// Yap_DebugPlWriteln(inp->val.t);
char *s;
s = BaseMalloc(MaxTmp());
s = Malloc(MaxTmp());
if (!Yap_mpz_to_string(Yap_BigIntOfTerm(inp->val.t), s, MaxTmp() - 1, 10)) {
AUX_ERROR(inp->val.t, MaxTmp(PASS_REGS1), s, char);
}
return inp->val.uc = (unsigned char *)s;
return inp->val.uc = pop_output_text_stack(lvl, s);
}
#endif
if (inp->type & YAP_STRING_TERM) {
// Yap_DebugPlWriteln(inp->val.t);
char *s = (char *) Yap_TermToBuffer(inp->val.t, ENC_ISO_UTF8, 0);
return inp->val.uc = (unsigned char *)s;
char *s = (char *)Yap_TermToBuffer(inp->val.t, ENC_ISO_UTF8, 0);
return inp->val.uc = pop_output_text_stack(lvl, s);
}
if (inp->type & YAP_STRING_CHARS) {
pop_text_stack(lvl);
if (inp->enc == ENC_ISO_LATIN1) {
return latin2utf8(inp);
} else if (inp->enc == ENC_ISO_ASCII) {
@@ -515,6 +547,7 @@ unsigned char *Yap_readText(seq_tv_t *inp USES_REGS) {
return inp->val.uc;
}
}
pop_text_stack(lvl);
if (inp->type & YAP_STRING_WCHARS) {
// printf("%S\n",inp->val.w);
return wchar2utf8(inp);
@@ -538,7 +571,7 @@ static Term write_strings(unsigned char *s0, seq_tv_t *out USES_REGS) {
Term t = init_tstring(PASS_REGS1);
LOCAL_TERM_ERROR(t, 2 * max);
unsigned char *buf = buf_from_tstring(HR);
if (max==0)
if (max == 0)
buf[0] = '\0';
else
strcpy((char *)buf, s);
@@ -662,14 +695,15 @@ static Atom write_atom(void *s0, seq_tv_t *out USES_REGS) {
}
void *write_buffer(unsigned char *s0, seq_tv_t *out USES_REGS) {
int l = push_text_stack();
size_t leng = strlen((char *)s0);
size_t min = 0, max = leng;
if (out->enc == ENC_ISO_UTF8) {
if ( out->val.uc == NULL) { // this should always be the case
out->val.uc = BaseMalloc(leng + 1);
if (out->val.uc == NULL) { // this should always be the case
out->val.uc = Malloc(leng + 1);
strcpy(out->val.c, (char *)s0);
} else if (out->val.uc != s0) {
out->val.c = BaseMalloc(leng + 1);
out->val.c = Malloc(leng + 1);
strcpy(out->val.c, (char *)s0);
}
} else if (out->enc == ENC_ISO_LATIN1) {
@@ -677,13 +711,17 @@ void *write_buffer(unsigned char *s0, seq_tv_t *out USES_REGS) {
unsigned char *s = s0;
unsigned char *cp = s;
unsigned char *buf = out->val.uc;
if (!buf)
if (!buf) {
pop_text_stack(l);
return NULL;
}
while (*cp) {
utf8proc_int32_t chr;
int off = get_utf8(cp, -1, &chr);
if (off <= 0 || chr > 255)
if (off <= 0 || chr > 255) {
pop_text_stack(l);
return NULL;
}
if (off == max)
break;
cp += off;
@@ -704,8 +742,10 @@ void *write_buffer(unsigned char *s0, seq_tv_t *out USES_REGS) {
wchar_t *buf0, *buf;
buf = buf0 = out->val.w;
if (!buf)
if (!buf) {
pop_text_stack(l);
return NULL;
}
while (*cp && cp < lim) {
utf8proc_int32_t chr;
cp += get_utf8(cp, -1, &chr);
@@ -723,8 +763,10 @@ void *write_buffer(unsigned char *s0, seq_tv_t *out USES_REGS) {
*buf = '\0';
} else {
// no other encodings are supported.
pop_text_stack(l);
return NULL;
}
out->val.c = pop_output_text_stack__(l, out->val.c);
return out->val.c;
}
@@ -735,23 +777,20 @@ static size_t write_length(const unsigned char *s0, seq_tv_t *out USES_REGS) {
static Term write_number(unsigned char *s, seq_tv_t *out,
bool error_on USES_REGS) {
Term t;
yap_error_descriptor_t new_error;
int i = push_text_stack();
Yap_pushErrorContext(&new_error);
t = Yap_StringToNumberTerm((char *)s, &out->enc,true);
pop_text_stack(i);
Yap_popErrorContext(error_on);
LOCAL_delay = !error_on;
t = Yap_StringToNumberTerm((char *)s, &out->enc, error_on);
LOCAL_delay = false;
return t;
}
static Term string_to_term(void *s, seq_tv_t *out USES_REGS) {
Term o;
yap_error_descriptor_t new_error;
Yap_pushErrorContext(&new_error);
o = out->val.t = Yap_BufferToTerm(s, TermNil);
Yap_popErrorContext(true);
yap_error_descriptor_t *new_error = malloc(sizeof(yap_error_descriptor_t));
bool mdnew = Yap_pushErrorContext(true, new_error);
o = out->val.t = Yap_BufferToTerm(s, TermNil);
Yap_popErrorContext(mdnew, true);
return o;
return o;
}
bool write_Text(unsigned char *inp, seq_tv_t *out USES_REGS) {
@@ -759,6 +798,9 @@ bool write_Text(unsigned char *inp, seq_tv_t *out USES_REGS) {
if (out->type == 0) {
return true;
}
if (LOCAL_Error_TYPE) {
return false;
}
if (out->type & (YAP_STRING_INT | YAP_STRING_FLOAT | YAP_STRING_BIG)) {
if ((out->val.t = write_number(
@@ -854,6 +896,7 @@ static size_t downcase(void *s0, seq_tv_t *out USES_REGS) {
bool Yap_CVT_Text(seq_tv_t *inp, seq_tv_t *out USES_REGS) {
unsigned char *buf;
bool rc;
/*
//printf(stderr, "[ %d ", n++) ;
if (inp->type & (YAP_STRING_TERM|YAP_STRING_ATOM|YAP_STRING_ATOMS_CODES
@@ -871,34 +914,34 @@ bool Yap_CVT_Text(seq_tv_t *inp, seq_tv_t *out USES_REGS) {
return 0L;
}
if (buf[0]) {
size_t leng = strlen_utf8(buf);
if (out->type & (YAP_STRING_NCHARS | YAP_STRING_TRUNC)) {
if (out->max < leng) {
const unsigned char *ptr = skip_utf8(buf, out->max);
size_t diff = (ptr - buf);
char *nbuf = Malloc(diff + 1);
memcpy(nbuf, buf, diff);
nbuf[diff] = '\0';
leng = diff;
size_t leng = strlen_utf8(buf);
if (out->type & (YAP_STRING_NCHARS | YAP_STRING_TRUNC)) {
if (out->max < leng) {
const unsigned char *ptr = skip_utf8(buf, out->max);
size_t diff = (ptr - buf);
char *nbuf = Malloc(diff + 1);
memcpy(nbuf, buf, diff);
nbuf[diff] = '\0';
leng = diff;
}
// else if (out->type & YAP_STRING_NCHARS &&
// const unsigned char *ptr = skip_utf8(buf)
}
// else if (out->type & YAP_STRING_NCHARS &&
// const unsigned char *ptr = skip_utf8(buf)
}
if (out->type & (YAP_STRING_UPCASE | YAP_STRING_DOWNCASE)) {
if (out->type & YAP_STRING_UPCASE) {
if (!upcase(buf, out)) {
pop_text_stack(l);
return false;
if (out->type & (YAP_STRING_UPCASE | YAP_STRING_DOWNCASE)) {
if (out->type & YAP_STRING_UPCASE) {
if (!upcase(buf, out)) {
pop_text_stack(l);
return false;
}
}
if (out->type & YAP_STRING_DOWNCASE) {
if (!downcase(buf, out)) {
pop_text_stack(l);
return false;
}
}
}
if (out->type & YAP_STRING_DOWNCASE) {
if (!downcase(buf, out)) {
pop_text_stack(l);
return false;
}
}
}
}
rc = write_Text(buf, out PASS_REGS);
/* fprintf(stderr, " -> ");
@@ -964,9 +1007,10 @@ bool Yap_Concat_Text(int tot, seq_tv_t inp[], seq_tv_t *out USES_REGS) {
void **bufv;
unsigned char *buf;
int i, j;
// int lvl = push_text_stack();
bufv = Malloc(tot * sizeof(unsigned char *));
if (!bufv) {
// pop_text_stack(lvl);
return NULL;
}
for (i = 0, j = 0; i < tot; i++) {
@@ -974,6 +1018,7 @@ bool Yap_Concat_Text(int tot, seq_tv_t inp[], seq_tv_t *out USES_REGS) {
unsigned char *nbuf = Yap_readText(inp + i PASS_REGS);
if (!nbuf) {
// pop_text_stack(lvl);
return NULL;
}
// if (!nbuf[0])
@@ -989,6 +1034,7 @@ bool Yap_Concat_Text(int tot, seq_tv_t inp[], seq_tv_t *out USES_REGS) {
buf = concat(tot, bufv PASS_REGS);
}
bool rc = write_Text(buf, out PASS_REGS);
// pop_text_stack( lvl );
return rc;
}
@@ -996,16 +1042,19 @@ bool Yap_Concat_Text(int tot, seq_tv_t inp[], seq_tv_t *out USES_REGS) {
//
bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
seq_tv_t outv[] USES_REGS) {
int lvl = push_text_stack();
const unsigned char *buf;
size_t b_l, u_l;
inp->type |= YAP_STRING_IN_TMP;
buf = Yap_readText(inp PASS_REGS);
if (!buf) {
pop_text_stack(lvl);
return false;
}
b_l = strlen((char *)buf);
if (b_l == 0) {
pop_text_stack(lvl);
return false;
}
u_l = strlen_utf8(buf);
@@ -1021,6 +1070,7 @@ bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
}
b_l0 = strlen((const char *)buf0);
if (memcmp(buf, buf0, b_l0) != 0) {
pop_text_stack(lvl);
return false;
}
u_l0 = strlen_utf8(buf0);
@@ -1030,6 +1080,7 @@ bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
buf1 = slice(u_l0, u_l, buf PASS_REGS);
b_l1 = strlen((const char *)buf1);
bool rc = write_Text(buf1, outv + 1 PASS_REGS);
pop_text_stack(lvl);
if (!rc) {
return false;
}
@@ -1037,6 +1088,7 @@ bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
} else /* if (outv[1].val.t) */ {
buf1 = Yap_readText(outv + 1 PASS_REGS);
if (!buf1) {
pop_text_stack(lvl);
return false;
}
b_l1 = strlen((char *)buf1);
@@ -1045,9 +1097,11 @@ bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
u_l0 = u_l - u_l1;
if (memcmp(skip_utf8((const unsigned char *)buf, b_l0), buf1, b_l1) !=
0) {
pop_text_stack(lvl);
return false;
}
buf0 = slice(0, u_l0, buf PASS_REGS);
buf0 = pop_output_text_stack(lvl, buf0);
bool rc = write_Text(buf0, outv PASS_REGS);
return rc;
}
@@ -1062,15 +1116,16 @@ bool Yap_Splice_Text(int n, size_t cuts[], seq_tv_t *inp,
if (i > 0 && cuts[i] == 0)
break;
void *bufi = slice(next, cuts[i], buf PASS_REGS);
bufi = pop_output_text_stack(lvl, bufi);
if (!write_Text(bufi, outv + i PASS_REGS)) {
return false;
}
}
pop_text_stack(lvl);
return true;
}
/**
* Convert from a predicate structure to an UTF-8 string of the form
*

13
C/threads.c
View File

@@ -1174,9 +1174,9 @@ p_with_mutex( USES_REGS1 )
rc = TRUE;
}
end:
excep = Yap_GetException();
excep = Yap_GetException(LOCAL_ComiittedError);
if ( !UnLockMutex(mut PASS_REGS) ) {
return FALSE;
return FALSE;c
}
if (creeping) {
Yap_signal( YAP_CREEP_SIGNAL );
@@ -1756,7 +1756,7 @@ p_new_mutex(void)
p_with_mutex( USES_REGS1 )
{
Int mut;
Term t1 = Deref(ARG1), excep;
Term t1 = Deref(ARG1);
Int rc = FALSE;
Int creeping = Yap_get_signal(YAP_CREEP_SIGNAL);
PredEntry *pe;
@@ -1813,11 +1813,12 @@ p_new_mutex(void)
}
end:
ARG1 = MkIntegerTerm(mut);
excep = Yap_GetException();
yap_error_descriptor_t *err = Yap_GetException();
if (creeping) {
Yap_signal( YAP_CREEP_SIGNAL );
} else if ( excep != 0) {
return Yap_JumpToEnv(excep);
} else if ( err ) {
LOCAL_ActiveError->errorNo = err->errorNo;
return Yap_JumpToEnv();
}
return rc;
}

3
C/tracer.c
View File

@@ -114,7 +114,7 @@ static char *send_tracer_message(char *start, char *name, arity_t arity,
return s;
}
#if defined(__GNUC__)
#if defined(__GNUC__) || defined(__clang__)
unsigned long long vsc_count;
#else
unsigned long vsc_count;
@@ -202,6 +202,7 @@ bool low_level_trace__(yap_low_level_port port, PredEntry *pred, CELL *args) {
int l = push_text_stack();
/* extern int gc_calls; */
vsc_count++;
//fprintf(stderr,"%p-%p\n",B->cp_tr,TR);
// if (HR < ASP ) return;
// fif (vsc_count == 12534) jmp_deb( 2 );
char *buf = Malloc(512), *top = buf + 511, *b = buf;

2
C/unify_absmi_insts.h
View File

@@ -2,6 +2,8 @@
* Get Instructions *
\************************************************************************/
#include <amiops.h>
#ifdef INDENT_CODE
{
{

210
C/utilpreds.c
View File

@@ -1617,8 +1617,9 @@ p_term_variables( USES_REGS1 ) /* variables in term t */
/**
* Exports a nil-terminated list with all the variables in a term.
* @param[in] the term
* @param[in] the arity of the calling predicate (required for exact garbage collection).
* @param[t] the term
* @param[arity] the arity of the calling predicate (required for exact garbage collection).
* @param[USES_REGS] threading
*/
Term
Yap_TermVariables( Term t, UInt arity USES_REGS ) /* variables in term t */
@@ -1649,16 +1650,24 @@ Yap_TermVariables( Term t, UInt arity USES_REGS ) /* variables in term t */
return out;
}
typedef struct att_rec {
CELL *beg, *end;
CELL oval;
} att_rec_t;
static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Term inp USES_REGS)
{
register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
int lvl = push_text_stack();
att_rec_t *to_visit0, *to_visit = Malloc(1024*sizeof(att_rec_t));
att_rec_t *to_visit_max;
register tr_fr_ptr TR0 = TR;
CELL *InitialH = HR;
CELL output = AbsPair(HR);
to_visit0 = to_visit;
loop:
to_visit_max = to_visit0+1024;
restart:
do {
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
@@ -1669,7 +1678,7 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
attvars_in_term_nvar:
{
if (IsPairTerm(d0)) {
if (to_visit + 1024 >= (CELL **)AuxSp) {
if (to_visit + 32 >= to_visit_max) {
goto aux_overflow;
}
{
@@ -1681,10 +1690,10 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
}
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
to_visit->beg = pt0;
to_visit->end = pt0_end;
to_visit->oval = *pt0;
to_visit ++;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
@@ -1696,8 +1705,8 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
pt0 = RepPair(d0) - 1;
pt0_end = pt0+2;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
Functor f;
CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
@@ -1705,14 +1714,14 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
continue;
}
/* store the terms to visit */
if (to_visit + 1024 >= (CELL **)AuxSp) {
if (to_visit + 32 >= to_visit_max) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
to_visit->beg = pt0;
to_visit->end = pt0_end;
to_visit->oval = *pt0;
to_visit ++;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
@@ -1721,9 +1730,9 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
arity_t a = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt0_end = ap2 + a;
}
continue;
}
@@ -1749,15 +1758,16 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
HR += 2;
HR[-2] = (CELL)ptd0;
/* store the terms to visit */
if (to_visit + 1024 >= (CELL **)AuxSp) {
if (to_visit + 32 >= to_visit_max) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
to_visit->beg = pt0;
to_visit->end = pt0_end;
to_visit->oval = *pt0;
to_visit ++;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
@@ -1768,24 +1778,25 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
pt0 = &RepAttVar(ptd0)->Value;
pt0_end = &RepAttVar(ptd0)->Atts;
}
continue;
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
if (to_visit == to_visit0)
break;
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
pt0_end = to_visit->end;
*pt0 = to_visit->oval;
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
} while(true);
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
pop_text_stack(lvl);
if (HR != InitialH) {
/* close the list */
Term t2 = Deref(inp);
@@ -1803,43 +1814,39 @@ static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end,
trail_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
*pt0 = to_visit->oval;
}
#endif
LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
LOCAL_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
pop_text_stack(lvl);
HR = InitialH;
return 0L;
aux_overflow:
LOCAL_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
HR = InitialH;
return 0L;
{
size_t d1 = to_visit-to_visit0;
size_t d2 = to_visit_max-to_visit0;
to_visit0 = Realloc(to_visit0,d2*sizeof(CELL*)+64*1024);
to_visit = to_visit0+d1;
to_visit_max = to_visit0+(d2+(64*1024))/sizeof(CELL **);
}
pt0--;
goto restart;
global_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
*pt0 = to_visit->oval;
}
#endif
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
pop_text_stack(lvl);
HR = InitialH;
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
LOCAL_Error_Size = (ASP-HR)*sizeof(CELL);
@@ -1865,6 +1872,8 @@ p_term_attvars( USES_REGS1 ) /* variables in term t */
}
else {
Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f))
return Yap_unify(TermNil, ARG2);
out = attvars_in_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(f), TermNil PASS_REGS);
@@ -4592,12 +4601,15 @@ int vsc;
static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Int numbv, int singles USES_REGS)
{
register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
int lvl = push_text_stack();
att_rec_t *to_visit0, *to_visit = Malloc(1024*sizeof(att_rec_t));
att_rec_t *to_visit_max;
register tr_fr_ptr TR0 = TR;
CELL *InitialH = HR;
to_visit0 = to_visit;
loop:
to_visit_max = to_visit0+1024;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
@@ -4607,16 +4619,15 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
deref_head(d0, vars_in_term_unk);
vars_in_term_nvar:
{
vsc++;
if (IsPairTerm(d0)) {
if (to_visit + 1024 >= (CELL **)AuxSp) {
if (to_visit + 32 >= to_visit_max) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
to_visit->beg = pt0;
to_visit->end = pt0_end;
to_visit->oval = *pt0;
to_visit ++;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
@@ -4628,8 +4639,8 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
Functor f;
CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
@@ -4641,21 +4652,16 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
continue;
}
/* store the terms to visit */
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
if (to_visit + 32 >= to_visit_max) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
to_visit->beg = pt0;
to_visit->end = pt0_end;
to_visit->oval = *pt0;
to_visit ++;
*pt0 = TermNil;
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
@@ -4691,10 +4697,10 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
pt0_end = to_visit->end;
*pt0 = to_visit->oval;
#else
to_visit -= 2;
pt0 = to_visit[0];
@@ -4704,52 +4710,50 @@ static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end
}
prune(B PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
pop_text_stack(lvl);
return numbv;
trail_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
pt0_end = to_visit->end;
*pt0 = to_visit->oval;
}
#endif
LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
LOCAL_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
HR = InitialH;
pop_text_stack(lvl);
return numbv-1;
aux_overflow:
LOCAL_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
HR = InitialH;
return numbv-1;
{
size_t d1 = to_visit-to_visit0;
size_t d2 = to_visit_max-to_visit0;
to_visit0 = Realloc(to_visit0,d2*sizeof(CELL*)+64*1024);
to_visit = to_visit0+d1;
to_visit_max = to_visit0+(d2+(64*1024))/sizeof(CELL **);
}
pt0--;
goto loop;
global_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
to_visit --;
pt0 = to_visit->beg;
pt0_end = to_visit->end;
*pt0 = to_visit->oval;
}
#endif
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
HR = InitialH;
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
LOCAL_Error_Size = (ASP-HR)*sizeof(CELL);
pop_text_stack(lvl);
return numbv-1;
}

21
C/write.c
View File

@@ -349,7 +349,7 @@ static void wrputf(Float f, struct write_globs *wglb) /* writes a float */
found_dot = TRUE;
wrputs(".0", stream);
}
found_dot = TRUE;
found_dot = true;
}
wrputc(ch, stream);
pt++;
@@ -748,6 +748,7 @@ static void write_var(CELL *t, struct write_globs *wglb,
wglb->Portray_delays = FALSE;
if (ext == attvars_ext) {
yhandle_t h = Yap_InitHandle((CELL)t);
attvar_record *attv = RepAttVar(t);
CELL *l = &attv->Value; /* dirty low-level hack, check atts.h */
@@ -757,6 +758,10 @@ static void write_var(CELL *t, struct write_globs *wglb,
writeTerm(from_pointer(l, &nrwt, wglb), 999, 1, FALSE, wglb, &nrwt);
l = restore_from_write(&nrwt, wglb);
wrputc(',', wglb->stream);
attv = RepAttVar((CELL *)Yap_GetFromHandle(h));
l = &attv->Value;
;
l++;
writeTerm(from_pointer(l, &nrwt, wglb), 999, 1, FALSE, wglb, &nrwt);
restore_from_write(&nrwt, wglb);
@@ -1206,6 +1211,7 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
struct write_globs wglb;
struct rewind_term rwt;
yhandle_t sls = Yap_CurrentSlot();
int lvl = push_text_stack();
if (t == 0)
return;
@@ -1230,10 +1236,7 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
wglb.Ignore_ops = flags & Ignore_ops_f;
wglb.Write_strings = flags & BackQuote_String_f;
/* protect slots for portray */
yap_error_descriptor_t ne;
Yap_pushErrorContext(&ne);
writeTerm(from_pointer(&t, &rwt, &wglb), priority, 1, FALSE, &wglb, &rwt);
Yap_popErrorContext(true);
if (flags & New_Line_f) {
if (flags & Fullstop_f) {
wrputc('.', wglb.stream);
@@ -1249,21 +1252,25 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
}
restore_from_write(&rwt, &wglb);
Yap_CloseSlots(sls);
pop_text_stack(lvl);
}
char *Yap_TermToBuffer(Term t, encoding_t enc, int flags) {
CACHE_REGS
int sno = Yap_open_buf_write_stream(enc, flags);
const char *sf;
DBTerm *e = LOCAL_BallTerm;
if (sno < 0)
return NULL;
LOCAL_c_output_stream = sno;
if (t == 0)
return NULL;
else
t = Deref(t);
if (enc)
GLOBAL_Stream[sno].encoding = enc;
else
GLOBAL_Stream[sno].encoding = LOCAL_encoding;
GLOBAL_Stream[sno].status |= CloseOnException_Stream_f;
Yap_plwrite(t, GLOBAL_Stream + sno, 0, flags, GLOBAL_MaxPriority);
sf = Yap_MemExportStreamPtr(sno);
@@ -1271,7 +1278,5 @@ char *Yap_TermToBuffer(Term t, encoding_t enc, int flags) {
char *new = malloc(len + 1);
strcpy(new, sf);
Yap_CloseStream(sno);
if (e)
LOCAL_BallTerm = e;
return new;
}

85
C/yap-args.c
View File

@@ -125,7 +125,7 @@ static void init_globals(YAP_init_args *yap_init) {
has been overwritten ....
*/
setBooleanGlobalPrologFlag(HALT_AFTER_CONSULT_FLAG,
yap_init->HaltAfterConsult);
yap_init->HaltAfterBoot);
}
if (yap_init->PrologTopLevelGoal) {
Yap_PutValue(AtomTopLevelGoal,
@@ -149,22 +149,24 @@ const char *Yap_BINDIR, *Yap_ROOTDIR, *Yap_SHAREDIR, *Yap_LIBDIR, *Yap_DLLDIR,
*Yap_PLDIR, *Yap_BOOTSTRAP, *Yap_COMMONSDIR,
*Yap_INPUT_STARTUP, *Yap_OUTPUT_STARTUP, *Yap_BOOTFILE, *Yap_INCLUDEDIR;
/* do initial boot by consulting the file boot.yap */
/**
* consult loop in C: used to boot the system, butt supports goal execution and recursive consulting.
*
* */
static void consult(const char *b_file USES_REGS) {
Term t;
int c_stream, osno, oactive;
Functor functor_query = Yap_MkFunctor(Yap_LookupAtom("?-"), 1);
Functor functor_command1 = Yap_MkFunctor(Yap_LookupAtom(":-"), 1);
Functor functor_compile2 = Yap_MkFunctor(Yap_LookupAtom("c_compile"), 1);
char *full;
/* consult boot.pl */
/* consult in C */
int lvl = push_text_stack();
char *full = Malloc(YAP_FILENAME_MAX + 1);
full[0] = '\0';
/* the consult mode does not matter here, really */
if ((osno = Yap_CheckAlias(AtomLoopStream)) < 0)
osno = 0;
c_stream = YAP_InitConsult(YAP_BOOT_MODE, b_file, full, &oactive);
c_stream = YAP_InitConsult(YAP_BOOT_MODE, b_file, &full, &oactive);
if (c_stream < 0) {
fprintf(stderr, "[ FATAL ERROR: could not open file %s ]\n", b_file);
pop_text_stack(lvl);
@@ -199,11 +201,13 @@ static void consult(const char *b_file USES_REGS) {
YAP_RunGoalOnce(t);
}
} else {
char *ErrorMessage;
ErrorMessage = YAP_CompileClause(t);
if (ErrorMessage) {
fprintf(stderr, "%s", ErrorMessage);
}
YAP_CompileClause(t);
}
yap_error_descriptor_t *errd;
if ((errd =
Yap_GetException(LOCAL_ActiveError))) {
fprintf(stderr, "%s:%ld:0: Error %s %s Found\n", errd->errorFile, (long int) errd->errorLine, errd->classAsText,
errd->errorAsText);
}
} while (t != TermEof);
BACKUP_MACHINE_REGS();
@@ -699,7 +703,7 @@ X_API YAP_file_type_t YAP_parse_yap_arguments(int argc, char *argv[],
goto GetSize;
}
iap->QuietMode = TRUE;
iap->HaltAfterConsult = TRUE;
iap->HaltAfterBoot = true;
case 'l':
p++;
if (!*++argv) {
@@ -759,6 +763,7 @@ X_API YAP_file_type_t YAP_parse_yap_arguments(int argc, char *argv[],
argv++;
iap->PrologTopLevelGoal = add_end_dot(*argv);
}
iap->HaltAfterBoot = true;
break;
case 'n':
if (!strcmp("nosignals", p)) {
@@ -967,11 +972,11 @@ static void init_hw(YAP_init_args *yap_init, struct ssz_t *spt) {
#endif
}
static YAP_file_type_t end_init(YAP_init_args *yap_init, YAP_file_type_t rc) {
static void end_init(YAP_init_args *iap) {
YAP_initialized = true;
if (iap->HaltAfterBoot) Yap_exit(0);
LOCAL_PrologMode &= ~BootMode;
CurrentModule = USER_MODULE;
return rc;
}
static void start_modules(void) {
@@ -987,14 +992,14 @@ static void start_modules(void) {
/* this routine is supposed to be called from an external program
that wants to control Yap */
X_API YAP_file_type_t YAP_Init(YAP_init_args *yap_init) {
YAP_file_type_t restore_result = yap_init->boot_file_type;
bool do_bootstrap = (restore_result & YAP_CONSULT_MODE);
X_API void YAP_Init(YAP_init_args *yap_init) {
bool try_restore = yap_init->boot_file_type == YAP_QLY;
bool do_bootstrap = yap_init->boot_file_type == YAP_BOOT_PL;
struct ssz_t minfo;
if (YAP_initialized)
/* ignore repeated calls to YAP_Init */
return YAP_FOUND_BOOT_ERROR;
return;
if (!LOCAL_TextBuffer)
LOCAL_TextBuffer = Yap_InitTextAllocator();
@@ -1008,7 +1013,7 @@ X_API YAP_file_type_t YAP_Init(YAP_init_args *yap_init) {
//
CACHE_REGS
if (Yap_embedded)
if (yap_init->QuietMode) {
setVerbosity(TermSilent);
}
@@ -1018,41 +1023,42 @@ X_API YAP_file_type_t YAP_Init(YAP_init_args *yap_init) {
restore will print out messages ....
*/
setBooleanGlobalPrologFlag(HALT_AFTER_CONSULT_FLAG,
yap_init->HaltAfterConsult);
yap_init->HaltAfterBoot);
}
/* tell the system who should cope with interrupts */
Yap_ExecutionMode = yap_init->ExecutionMode;
Yap_set_locations(yap_init);
if (!do_bootstrap && Yap_INPUT_STARTUP &&
yap_init->boot_file_type != YAP_BOOT_PL &&
Yap_SavedInfo(Yap_INPUT_STARTUP, &minfo.Trail, &minfo.Stack,
&minfo.Heap) &&
Yap_Restore(Yap_INPUT_STARTUP)) {
setBooleanGlobalPrologFlag(SAVED_PROGRAM_FLAG, true);
CurrentModule = LOCAL_SourceModule = USER_MODULE;
if (do_bootstrap ||
!try_restore ||
!Yap_SavedInfo(Yap_INPUT_STARTUP, &minfo.Trail, &minfo.Stack,
&minfo.Heap) ) {
init_globals(yap_init);
YAP_RunGoalOnce(TermInitProlog);
start_modules();
return end_init(yap_init, YAP_QLY);
consult(Yap_BOOTSTRAP PASS_REGS);
setAtomicGlobalPrologFlag(RESOURCE_DATABASE_FLAG,
MkAtomTerm(Yap_LookupAtom(Yap_BOOTFILE)));
setBooleanGlobalPrologFlag(SAVED_PROGRAM_FLAG, false);
} else {
Yap_Restore(Yap_INPUT_STARTUP);
init_globals(yap_init);
start_modules();
consult(Yap_BOOTFILE PASS_REGS);
if (yap_init->install && Yap_OUTPUT_STARTUP) {
setAtomicGlobalPrologFlag(RESOURCE_DATABASE_FLAG,
MkAtomTerm(Yap_LookupAtom(Yap_INPUT_STARTUP)));
setBooleanGlobalPrologFlag(SAVED_PROGRAM_FLAG, true);
}
YAP_RunGoalOnce(TermInitProlog);
if (yap_init->install && Yap_OUTPUT_STARTUP) {
Term t = MkAtomTerm(Yap_LookupAtom(Yap_OUTPUT_STARTUP));
Term g = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("qsave_program"), 1),
1, &t);
YAP_RunGoalOnce(g);
}
setAtomicGlobalPrologFlag(RESOURCE_DATABASE_FLAG,
MkAtomTerm(Yap_LookupAtom(Yap_BOOTFILE)));
setBooleanGlobalPrologFlag(SAVED_PROGRAM_FLAG, false);
return end_init(yap_init, YAP_BOOT_PL);
}
}
end_init(yap_init);
}
#if (DefTrailSpace < MinTrailSpace)
@@ -1074,15 +1080,14 @@ X_API YAP_file_type_t YAP_Init(YAP_init_args *yap_init) {
#define DEFAULT_SCHEDULERLOOP 10
#define DEFAULT_DELAYEDRELEASELOAD 3
X_API YAP_file_type_t YAP_FastInit(char *saved_state, int argc, char *argv[]) {
X_API void YAP_FastInit(char *saved_state, int argc, char *argv[]) {
YAP_init_args init_args;
YAP_file_type_t out;
if ((out = Yap_InitDefaults(&init_args, saved_state, argc, argv)) !=
YAP_FOUND_BOOT_ERROR)
out = YAP_Init(&init_args);
YAP_Init(&init_args);
if (out == YAP_FOUND_BOOT_ERROR) {
Yap_Error(init_args.ErrorNo, TermNil, init_args.ErrorCause);
}
return out;
}