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

a new and hopefully much better implementation of atts.

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1392 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2005-09-09 17:24:39 +00:00
parent 2444b775b7
commit 03ba05f24a
14 changed files with 624 additions and 495 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
C/absmi.c
View File

@ -10,8 +10,11 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2005-09-08 22:06:44 $,$Author: rslopes $ *
* Last rev: $Date: 2005-09-09 17:24:37 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.176 2005/09/08 22:06:44 rslopes
* BEAM for YAP update...
*
* Revision 1.175 2005/08/12 17:00:00 ricroc
* TABLING FIX: support for incomplete tables
*
@ -1754,12 +1757,17 @@ Yap_absmi(int inp)
}
pt1--;
} else if (IsApplTerm(d1)) {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0-1) = TrailTerm(pt1-1);
TrailVal(pt0-1) = TrailVal(pt1-1);
pt0 -= 2;
pt1 -= 2;
if (IN_BETWEEN(HBREG,RepAppl(d1),B->cp_b)) {
/* deterministic binding to multi-assignment variable */
pt1 -= 2;
} else {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0-1) = TrailTerm(pt1-1);
TrailVal(pt0-1) = TrailVal(pt1-1);
pt0 -= 2;
pt1 -= 2;
}
} else {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
@ -1793,19 +1801,27 @@ Yap_absmi(int inp)
}
pt1++;
} else if (IsApplTerm(d1)) {
if (IN_BETWEEN(HBREG,RepAppl(d1),B->cp_b)) {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = TrailTerm(pt0+2) = d1;
TrailVal(pt0+1) = TrailVal(pt1+1);
TrailTerm(pt0+1) = TrailTerm(pt1+1);
pt0 += 2;
pt1 += 2;
pt1 += 2;
#else
TrailTerm(pt0+1) = TrailTerm(pt1+1);
TrailTerm(pt0) = TrailTerm(pt0+2) = d1;
pt0 += 3;
pt1 += 3;
pt1 += 3;
#endif
} else {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = TrailTerm(pt0+2) = d1;
TrailVal(pt0+1) = TrailVal(pt1+1);
TrailTerm(pt0+1) = TrailTerm(pt1+1);
pt0 += 2;
pt1 += 2;
#else
TrailTerm(pt0+1) = TrailTerm(pt1+1);
TrailTerm(pt0) = TrailTerm(pt0+2) = d1;
pt0 += 3;
pt1 += 3;
#endif /* FROZEN_STACKS */
}
} else if (IsPairTerm(d1)) {
CELL *pt = RepPair(d1);
if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {

741
C/attvar.c
View File

@ -30,10 +30,6 @@ static char SccsId[]="%W% %G%";
#ifdef COROUTINING
STATIC_PROTO(Term InitVarTime, (void));
STATIC_PROTO(void PutAtt, (attvar_record *,Int,Term));
STATIC_PROTO(Int BuildNewAttVar, (Term,Int,Term));
static CELL *
AddToQueue(attvar_record *attv)
{
@ -75,68 +71,55 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res)
register attvar_record *attv = (attvar_record *)orig;
register attvar_record *newv;
CELL **to_visit = *to_visit_ptr;
Term time = InitVarTime();
Int j;
CELL *vt;
/* add a new attributed variable */
newv = DelayTop();
if (H0 - (CELL *)newv < 1024+(2*NUM_OF_ATTS))
if (H0 - (CELL *)newv < 1024)
return FALSE;
RESET_VARIABLE(&(newv->Done));
newv->sus_id = attvars_ext;
RESET_VARIABLE(&(newv->Value));
newv->NS = Yap_UpdateTimedVar(AttsMutableList, (CELL)&(newv->Done));
for (j = 0; j < NUM_OF_ATTS; j++) {
Term t = Deref(attv->Atts[2*j+1]);
newv->Atts[2*j] = time;
if (IsVarTerm(t)) {
CELL *vt = VarOfTerm(t);
if (vt == attv->Atts+(2*j+1)) {
RESET_VARIABLE(newv->Atts+(2*j+1));
} else {
to_visit[0] = vt-1;
to_visit[1] = vt;
to_visit[2] = newv->Atts+2*j+1;
to_visit[3] = (CELL *)vt[-1];
to_visit += 4;
}
} else if (IsVarTerm(t) && IsAtomicTerm(t)) {
newv->Atts[2*j+1] = t;
} else {
to_visit[0] = attv->Atts+2*j;
to_visit[1] = attv->Atts+2*j+1;
to_visit[2] = newv->Atts+2*j+1;
to_visit[3] = (CELL *)(attv->Atts[2*j]);
to_visit += 4;
}
}
*to_visit_ptr = to_visit;
RESET_VARIABLE(&(newv->Done));
vt = &(attv->Atts);
to_visit[0] = vt-1;
to_visit[1] = vt;
to_visit[2] = &(newv->Atts);
to_visit[3] = (CELL *)vt[-1];
*to_visit_ptr = to_visit+4;
*res = (CELL)&(newv->Done);
SetDelayTop(attv->Atts+2*j);
return(TRUE);
SetDelayTop(newv+1);
return TRUE;
}
static Term
AttVarToTerm(CELL *orig)
{
register attvar_record *attv = (attvar_record *)orig;
Term list = TermNil;
int j;
for (j = 0; j < NUM_OF_ATTS; j++) {
Term t = attv->Atts[2*(NUM_OF_ATTS-j-1)+1];
if (IsVarTerm(t))
list = MkPairTerm(MkVarTerm(),list);
else
list = MkPairTerm(t,list);
attvar_record *attv = (attvar_record *)orig;
return attv->Atts;
}
static attvar_record *
BuildNewAttVar(void)
{
attvar_record *attv = DelayTop();
if (H0 - (CELL *)(attv+1) < 1024) {
return NULL;
}
return(list);
RESET_VARIABLE(&(attv->Done));
RESET_VARIABLE(&(attv->Value));
RESET_VARIABLE(&(attv->Atts));
SetDelayTop(attv+1);
return attv;
}
static int
TermToAttVar(Term attvar, Term to)
{
return(BuildNewAttVar(to, -1, attvar));
attvar_record *attv = BuildNewAttVar();
if (!attv)
return FALSE;
attv->Atts = attvar;
return TRUE;
}
static void
@ -155,11 +138,6 @@ WakeAttVar(CELL* pt1, CELL reg2)
attvar_record *susp2 = (attvar_record *)VarOfTerm(reg2);
/* binding two suspended variables, be careful */
if (susp2->sus_id != attvars_ext) {
/* joining two different kinds of suspensions */
Yap_Error(SYSTEM_ERROR, TermNil, "joining two different suspensions not implemented");
return;
}
if (susp2 >= attv) {
if (!IsVarTerm(susp2->Value) || !IsUnboundVar(&susp2->Value)) {
/* oops, our goal is on the queue to be woken */
@ -207,13 +185,10 @@ static void
mark_attvar(CELL *orig)
{
register attvar_record *attv = (attvar_record *)orig;
Int i;
Yap_mark_external_reference(&(attv->Value));
Yap_mark_external_reference(&(attv->Done));
for (i = 0; i < NUM_OF_ATTS; i++) {
Yap_mark_external_reference(attv->Atts+2*i+1);
}
Yap_mark_external_reference(&(attv->Atts));
}
#if FROZEN_STACKS
@ -224,173 +199,113 @@ CurrentTime(void) {
#endif
static Term
InitVarTime(void) {
#if FROZEN_STACKS
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
return(MkIntegerTerm(B->cp_tr-(tr_fr_ptr)Yap_TrailBase));
#else
Term t = (CELL)H;
*H++ = TermFoundVar;
return(t);
#endif
}
static void
PutAtt(attvar_record *attv, Int i, Term tatt) {
Int pos = i*2;
#if FROZEN_STACKS
tr_fr_ptr timestmp = (tr_fr_ptr)Yap_TrailBase+IntegerOfTerm(attv->Atts[pos]);
if (B->cp_tr <= timestmp
&& timestmp <= TR) {
#if defined(SBA)
if (Unsigned((Int)(attv)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
CELL *ptr = STACK_TO_SBA(attv->Atts+pos+1);
*ptr = tatt;
} else
#endif
attv->Atts[pos+1] = tatt;
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
Unsigned(BBREG)-(Int)(HBREG))
TrailVal(timestmp-1) = tatt;
} else {
Term tnewt;
MaBind(attv->Atts+pos+1, tatt);
tnewt = CurrentTime();
MaBind(attv->Atts+pos, tnewt);
}
#else
CELL *timestmp = (CELL *)(attv->Atts[pos]);
if (B->cp_h <= timestmp) {
attv->Atts[pos+1] = tatt;
} else {
Term tnewt;
MaBind(attv->Atts+pos+1, tatt);
tnewt = (Term)H;
*H++ = TermFoundVar;
MaBind(attv->Atts+pos, tnewt);
}
#endif
}
static Int
UpdateAtt(attvar_record *attv, Int i, Term tatt) {
Int pos = i*2;
Term tv = attv->Atts[pos+1];
if (!IsVarTerm(tv) || !IsUnboundVar(attv->Atts+pos+1)) {
tatt = MkPairTerm(tatt, attv->Atts[pos+1]);
} else {
tatt = MkPairTerm(tatt, TermNil);
}
PutAtt(attv, i, tatt);
return TRUE;
}
static Int
RmAtt(attvar_record *attv, Int i) {
Int pos = i *2;
if (!IsVarTerm(attv->Atts[pos+1])) {
#if FROZEN_STACKS
tr_fr_ptr timestmp = (tr_fr_ptr)Yap_TrailBase+IntegerOfTerm(attv->Atts[pos]);
if (B->cp_tr <= timestmp
&& timestmp <= TR) {
RESET_VARIABLE(attv->Atts+(pos+1));
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
Unsigned(BBREG)-(Int)(HBREG))
TrailVal(timestmp-1) = attv->Atts[pos+1];
} else {
/* reset the variable */
Term tnewt;
#ifdef SBA
MaBind(attv->Atts+(pos+1), 0L);
#else
MaBind(attv->Atts+(pos+1), (CELL)(attv->Atts+(pos+1)));
#endif
tnewt = CurrentTime();
MaBind(attv->Atts+pos, tnewt);
}
#else
CELL *timestmp = (CELL *)(attv->Atts[pos]);
if (B->cp_h <= timestmp) {
RESET_VARIABLE(attv->Atts+(pos+1));
} else {
/* reset the variable */
Term tnewt;
#ifdef SBA
MaBind(attv->Atts+(pos+1), 0L);
#else
MaBind(attv->Atts+(pos+1), (CELL)(attv->Atts+(pos+1)));
#endif
tnewt = (Term)H;
*H++ = TermFoundVar;
MaBind(attv->Atts+pos, tnewt);
}
#endif
}
return(TRUE);
}
static Int
BuildNewAttVar(Term t, Int i, Term tatt)
BuildAttTerm(Functor mfun, UInt ar)
{
/* allocate space in Heap */
Term time;
int j;
CELL *h0 = H;
UInt i;
attvar_record *attv = DelayTop();
if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
return FALSE;
if (H+(1024+ar) > ASP) {
return 0L;
}
time = InitVarTime();
RESET_VARIABLE(&(attv->Value));
RESET_VARIABLE(&(attv->Done));
attv->sus_id = attvars_ext;
for (j = 0; j < NUM_OF_ATTS; j++) {
attv->Atts[2*j] = time;
RESET_VARIABLE(attv->Atts+(2*j+1));
H[0] = (CELL)mfun;
RESET_VARIABLE(H+1);
H += 2;
for (i = 1; i< ar; i++) {
*H = TermFoundVar;
H++;
}
attv->NS = Yap_UpdateTimedVar(AttsMutableList, (CELL)&(attv->Done));
Bind((CELL *)t,(CELL)attv);
SetDelayTop(attv->Atts+2*j);
/* avoid trouble in gc */
/* if i < 0 then we have the list of arguments */
if (i < 0) {
Int j = 0;
while (IsPairTerm(tatt)) {
Term t = HeadOfTerm(tatt);
/* I need to do this because BuildNewAttVar may shift the stacks */
if (!IsVarTerm(t)) {
attv->Atts[2*j+1] = t;
}
j++;
tatt = TailOfTerm(tatt);
return AbsAppl(h0);
}
static Term
SearchAttsForModule(Term start, Functor mfun)
{
do {
if (IsVarTerm(start) ||
FunctorOfTerm(start) == mfun)
return start;
start = ArgOfTerm(1,start);
} while (TRUE);
}
static Term
SearchAttsForModuleName(Term start, Atom mname)
{
do {
if (IsVarTerm(start) ||
NameOfFunctor(FunctorOfTerm(start)) == mname)
return start;
start = ArgOfTerm(1,start);
} while (TRUE);
}
static void
AddNewModule(attvar_record *attv, Term t, int new)
{
if (IsVarTerm(attv->Atts)) {
if (new) {
attv->Atts = t;
} else {
Bind(&(attv->Atts),t);
}
return TRUE;
} else {
PutAtt(attv, i, tatt);
return TRUE;
Term *wherep = &attv->Atts;
do {
if (IsVarTerm(*wherep)) {
Bind_Global(wherep,t);
return;
} else {
wherep = RepAppl(Deref(*wherep))+1;
}
} while (TRUE);
}
}
static Int
GetAtt(attvar_record *attv, int i) {
Int pos = i *2;
#if SBA
if (IsVarTerm(attv->Atts[pos+1]) && IsUnboundVar(attv->Atts+pos+1))
return((CELL)&(attv->Atts[pos+1]));
#endif
return(attv->Atts[pos+1]);
static void
ReplaceAtts(attvar_record *attv, Term oatt, Term att)
{
UInt ar = ArityOfFunctor(FunctorOfTerm(oatt)), i;
CELL *oldp = RepAppl(oatt)+1;
CELL *newp = RepAppl(att)+1;
*newp++ = *oldp++;
for (i=1; i< ar; i++) {
if (*newp == TermFoundVar) {
*newp = *oldp;
}
oldp++;
newp++;
}
if (attv->Atts == oatt) {
if (RepAppl(attv->Atts) >= HB)
attv->Atts = att;
else
MaBind(&(attv->Atts), att);
} else {
Term *wherep = &attv->Atts;
do {
if (*wherep == oatt) {
MaBind(wherep, att);
return;
} else {
wherep = RepAppl(Deref(*wherep))+1;
}
} while (TRUE);
}
}
static Int
FreeAtt(attvar_record *attv, int i) {
Int pos = i *2;
return(IsVarTerm(attv->Atts[pos+1]));
static void
PutAtt(Int pos, Term atts, Term att)
{
if (IsVarTerm(att) && (CELL *)att > H && (CELL *)att < LCL0) {
/* globalise locals */
Term tnew = MkVarTerm();
Bind((CELL *)att, tnew);
att = tnew;
}
MaBind(RepAppl(atts)+pos, att);
}
static Int
@ -426,35 +341,35 @@ BindAttVar(attvar_record *attv) {
static Term
GetAllAtts(attvar_record *attv) {
Int i;
Term t = TermNil;
for (i = NUM_OF_ATTS-1; i >= 0; i --) {
if (!IsVarTerm(attv->Atts[2*i+1]))
t = MkPairTerm(MkPairTerm(MkIntegerTerm(i),attv->Atts[2*i+1]), t);
}
return(t);
/* check if we are already there */
return attv->Atts;
}
static Term
AllAttVars(Term t) {
AllAttVars(attvar_record *attv) {
CELL *h0 = H;
attvar_record *max = DelayTop();
while (t != TermNil) {
attvar_record *attv;
while (attv != max) {
if (ASP - H < 1024) {
H = h0;
return 0L;
}
attv = (attvar_record *)VarOfTerm(t);
if (IsVarTerm(attv->Done) && IsUnboundVar(&attv->Done)) {
if (H != h0) {
H[-1] = AbsPair(H);
if (IsIntegerTerm(attv->Atts)) {
/* skip call residue(s) */
UInt n = IntegerOfTerm(attv->Atts)-1;
attv += n;
} else {
if (H != h0) {
H[-1] = AbsPair(H);
}
H[0] = (CELL)attv;
H += 2;
}
H[0] = t;
H += 2;
}
t = attv->NS;
attv++;
}
if (H != h0) {
H[-1] = TermNil;
@ -470,54 +385,37 @@ p_put_att(void) {
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
attvar_record *attv;
Atom modname = AtomOfTerm(Deref(ARG2));
UInt ar = IntegerOfTerm(Deref(ARG3));
Functor mfun;
Term tatts;
int new = FALSE;
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
attv = (attvar_record *)VarOfTerm(inp);
} else {
while (!(attv = BuildNewAttVar())) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
inp = Deref(ARG1);
}
PutAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3));
return TRUE;
new = TRUE;
}
while (!BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), Deref(ARG3))) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
mfun= Yap_MkFunctor(modname,ar);
if (IsVarTerm(tatts = SearchAttsForModule(attv->Atts,mfun))) {
while (!(tatts = BuildAttTerm(mfun,ar))) {
if (!Yap_gc(5, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
inp = Deref(ARG1);
}
return TRUE;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_update_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
return(UpdateAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
}
while (!BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), MkPairTerm(Deref(ARG3),TermNil))) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
inp = Deref(ARG1);
Yap_unify(ARG1, (Term)attv);
AddNewModule(attv,tatts,new);
}
PutAtt(IntegerOfTerm(Deref(ARG4)), tatts, Deref(ARG5));
return TRUE;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
@ -531,68 +429,197 @@ p_rm_att(void) {
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
attvar_record *attv;
Atom modname = AtomOfTerm(Deref(ARG2));
UInt ar = IntegerOfTerm(Deref(ARG3));
Functor mfun;
Term tatts;
int new = FALSE;
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
return(FALSE);
if (IsAttachedTerm(inp)) {
attv = (attvar_record *)VarOfTerm(inp);
} else {
while (!(attv = BuildNewAttVar())) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
inp = Deref(ARG1);
}
return(RmAtt(attv, IntegerOfTerm(Deref(ARG2))));
new = TRUE;
Yap_unify(ARG1, (Term)attv);
}
return(TRUE);
mfun= Yap_MkFunctor(modname,ar);
if (IsVarTerm(tatts = SearchAttsForModule(attv->Atts,mfun))) {
while (!(tatts = BuildAttTerm(mfun,ar))) {
if (!Yap_gc(4, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
AddNewModule(attv,tatts,new);
} else {
PutAtt(IntegerOfTerm(Deref(ARG4)), tatts, TermFoundVar);
}
return TRUE;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_put_atts(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
Term otatts;
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
attvar_record *attv;
Term tatts = Deref(ARG2);
Functor mfun = FunctorOfTerm(tatts);
int new = FALSE;
if (IsAttachedTerm(inp)) {
attv = (attvar_record *)VarOfTerm(inp);
} else {
while (!(attv = BuildNewAttVar())) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
tatts = Deref(ARG2);
}
new = TRUE;
Yap_unify(ARG1, (Term)attv);
}
if (IsVarTerm(otatts = SearchAttsForModule(attv->Atts,mfun))) {
AddNewModule(attv,tatts,new);
} else {
ReplaceAtts(attv, otatts, tatts);
}
return TRUE;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return FALSE;
}
}
static Int
p_get_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
Term out;
exts id = (exts)attv->sus_id;
Atom modname = AtomOfTerm(Deref(ARG2));
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
if (IsAttachedTerm(inp)) {
attvar_record *attv;
Term tout, tatts;
attv = (attvar_record *)VarOfTerm(inp);
if (IsVarTerm(tatts = SearchAttsForModuleName(attv->Atts,modname)))
return FALSE;
}
out = GetAtt(attv,IntegerOfTerm(Deref(ARG2)));
return !IsVarTerm(out) && Yap_unify(ARG3,out);
tout = ArgOfTerm(IntegerOfTerm(Deref(ARG3)),tatts);
if (tout == TermFoundVar) return FALSE;
return Yap_unify(tout, ARG4);
} else {
/* Yap_Error(INSTANTIATION_ERROR,inp,"get_att/2"); */
return FALSE;
}
/* Yap_Error(INSTANTIATION_ERROR,inp,"get_att/2");*/
return FALSE;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return FALSE;
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_free_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
Atom modname = AtomOfTerm(Deref(ARG2));
if (IsAttachedTerm(inp)) {
attvar_record *attv;
Term tout, tatts;
attv = (attvar_record *)VarOfTerm(inp);
if (IsVarTerm(tatts = SearchAttsForModuleName(attv->Atts,modname)))
return TRUE;
tout = ArgOfTerm(IntegerOfTerm(Deref(ARG3)),tatts);
return (tout == TermFoundVar);
} else {
/* Yap_Error(INSTANTIATION_ERROR,inp,"get_att/2"); */
return TRUE;
}
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_get_atts(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
attvar_record *attv;
Term tatts;
Term access = Deref(ARG2);
Functor mfun = FunctorOfTerm(access);
UInt ar, i;
CELL *old, *new;
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
attv = (attvar_record *)VarOfTerm(inp);
if (IsVarTerm(tatts = SearchAttsForModule(attv->Atts,mfun)))
return FALSE;
ar = ArityOfFunctor(mfun);
new = RepAppl(access)+2;
old = RepAppl(tatts)+2;
for (i = 1; i < ar; i++,new++,old++) {
if (*new != TermFreeTerm) {
if (*old == TermFoundVar && *new != TermFoundVar)
return FALSE;
if (!Yap_unify(*new,*old)) return FALSE;
}
}
return(FreeAtt(attv,IntegerOfTerm(Deref(ARG2))));
return TRUE;
} else {
/* Yap_Error(INSTANTIATION_ERROR,inp,"get_att/2"); */
return FALSE;
}
return(TRUE);
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"free_att/2");
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_has_atts(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv;
Term tatts;
Term access = Deref(ARG2);
Functor mfun = FunctorOfTerm(access);
attv = (attvar_record *)VarOfTerm(inp);
return !IsVarTerm(tatts = SearchAttsForModule(attv->Atts,mfun));
} else {
/* Yap_Error(INSTANTIATION_ERROR,inp,"get_att/2"); */
return FALSE;
}
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
@ -605,12 +632,6 @@ p_bind_attvar(void) {
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
return(BindAttVar(attv));
}
return(TRUE);
@ -628,12 +649,6 @@ p_get_all_atts(void) {
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)(attv->sus_id);
if (id != attvars_ext) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
return Yap_unify(ARG2,GetAllAtts(attv));
}
return TRUE;
@ -644,31 +659,52 @@ p_get_all_atts(void) {
}
static Int
p_inc_atts(void)
{
Term t = MkIntegerTerm(NUM_OF_ATTS);
NUM_OF_ATTS++;
return(Yap_unify(ARG1,t));
}
p_modules_with_atts(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
CELL *h0 = H;
Term tatt;
static Int
p_n_atts(void)
{
Term t = MkIntegerTerm(NUM_OF_ATTS);
return Yap_unify(ARG1,t);
if (IsVarTerm(tatt = attv->Atts))
return Yap_unify(ARG2,TermNil);
while (!IsVarTerm(tatt)) {
if (H != H0)
H[-1] = AbsPair(H);
*H = MkAtomTerm(NameOfFunctor(FunctorOfTerm(tatt)));
H+=2;
tatt = ArgOfTerm(1,tatt);
}
H[-1] = TermNil;
return Yap_unify(ARG2,AbsPair(h0));
}
return TermNil;
} else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return FALSE;
}
}
static Int
p_all_attvars(void)
{
Term out;
while ((out = AllAttVars(Yap_ReadTimedVar(AttsMutableList))) == 0L) {
if (!Yap_gc(1, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
return Yap_unify(ARG1,out);
do {
Term out;
attvar_record *base;
base = (attvar_record *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(AttsMutableList));
if (!(out = AllAttVars(base))) {
if (!Yap_gc(1, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
} else {
return Yap_unify(ARG1,out);
}
} while (TRUE);
}
static Int
@ -676,8 +712,7 @@ p_is_attvar(void)
{
Term t = Deref(ARG1);
return(IsVarTerm(t) &&
IsAttachedTerm(t) &&
((attvar_record *)VarOfTerm(t))->sus_id == attvars_ext);
IsAttachedTerm(t));
}
/* check if we are not redoing effort */
@ -687,7 +722,6 @@ p_attvar_bound(void)
Term t = Deref(ARG1);
return(IsVarTerm(t) &&
IsAttachedTerm(t) &&
((attvar_record *)VarOfTerm(t))->sus_id == attvars_ext &&
!IsUnboundVar(&((attvar_record *)VarOfTerm(t))->Done));
}
@ -713,6 +747,18 @@ p_attvar_bound(void)
#endif /* COROUTINING */
static Int
p_void_term(void)
{
return Yap_unify(ARG1,TermFoundVar);
}
static Int
p_free_term(void)
{
return Yap_unify(ARG1,TermFreeTerm);
}
void Yap_InitAttVarPreds(void)
{
Term OldCurrentModule = CurrentModule;
@ -723,15 +769,18 @@ void Yap_InitAttVarPreds(void)
attas[attvars_ext].to_term_op = AttVarToTerm;
attas[attvars_ext].term_to_op = TermToAttVar;
attas[attvars_ext].mark_op = mark_attvar;
Yap_InitCPred("get_att", 3, p_get_att, SafePredFlag);
Yap_InitCPred("get_att", 4, p_get_att, SafePredFlag);
Yap_InitCPred("get_module_atts", 2, p_get_atts, SafePredFlag);
Yap_InitCPred("has_module_atts", 2, p_has_atts, SafePredFlag);
Yap_InitCPred("get_all_atts", 2, p_get_all_atts, SafePredFlag);
Yap_InitCPred("free_att", 2, p_free_att, SafePredFlag);
Yap_InitCPred("put_att", 3, p_put_att, 0);
Yap_InitCPred("update_att", 3, p_update_att, 0);
Yap_InitCPred("rm_att", 2, p_rm_att, SafePredFlag);
Yap_InitCPred("inc_n_of_atts", 1, p_inc_atts, SafePredFlag);
Yap_InitCPred("n_of_atts", 1, p_n_atts, SafePredFlag);
Yap_InitCPred("free_att", 3, p_free_att, SafePredFlag);
Yap_InitCPred("put_att", 5, p_put_att, 0);
Yap_InitCPred("put_module_atts", 2, p_put_atts, 0);
Yap_InitCPred("rm_att", 4, p_rm_att, 0);
Yap_InitCPred("bind_attvar", 1, p_bind_attvar, SafePredFlag);
Yap_InitCPred("void_term", 1, p_void_term, SafePredFlag);
Yap_InitCPred("free_term", 1, p_free_term, SafePredFlag);
Yap_InitCPred("modules_with_attributes", 2, p_modules_with_atts, SafePredFlag);
#endif /* COROUTINING */
Yap_InitCPred("all_attvars", 1, p_all_attvars, 0);
CurrentModule = OldCurrentModule;

36
C/corout.c
View File

@ -22,6 +22,7 @@ static char SccsId[]="%W% %G%";
#include "Yatom.h"
#include "Heap.h"
#include "heapgc.h"
#include "attvar.h"
#ifndef NULL
#define NULL (void *)0
#endif
@ -31,7 +32,7 @@ p_read_svar_list(void)
{
#ifdef COROUTINING
#ifdef MULTI_ASSIGNMENT_VARIABLES
return(Yap_unify(ARG1, AttsMutableList));
return Yap_unify(ARG1,Yap_ReadTimedVar(AttsMutableList));
#else
return(TRUE);
#endif
@ -45,10 +46,39 @@ p_set_svar_list(void)
{
#ifdef COROUTINING
#ifdef MULTI_ASSIGNMENT_VARIABLES
AttsMutableList = Deref(ARG1);
Term newl = Deref(ARG1);
attvar_record *max = DelayTop();
if (IsVarTerm(newl)) {
/* set to current top */
UInt diff;
Term tdiff;
RESET_VARIABLE(&max->Done);
RESET_VARIABLE(&max->Value);
max->Atts = MkIntTerm(1);
max++;
SetDelayTop(max);
diff = max-(attvar_record *)Yap_GlobalBase;
tdiff = MkIntegerTerm(diff);
Yap_UpdateTimedVar(AttsMutableList,tdiff);
return Yap_unify(ARG1,tdiff);
} else {
UInt old = IntegerOfTerm(Yap_UpdateTimedVar(AttsMutableList,newl));
attvar_record *aold = (attvar_record *)Yap_GlobalBase + (old-1);
if (max > aold+1) {
/* we are moving forward */
/* these items are protected by call-residue, should not
be visible to AllAtts
*/
MaBind(&(aold->Atts),MkIntegerTerm(max-aold));
}
}
#endif
#endif
return(TRUE);
return TRUE;
}
#ifdef COROUTINING

2
C/exec.c
View File

@ -1605,7 +1605,7 @@ Yap_InitYaamRegs(void)
DelayedVars = Yap_NewTimedVar(MkIntTerm(0));
WokenGoals = Yap_NewTimedVar(TermNil);
MutableList = Yap_NewTimedVar(TermNil);
AttsMutableList = Yap_NewTimedVar(TermNil);
AttsMutableList = Yap_NewTimedVar(MkIntTerm(0));
#endif
#if defined(YAPOR) || defined(THREADS)
PP = NULL;

7
C/init.c
View File

@ -937,6 +937,9 @@ InitCodes(void)
Yap_heap_regs->atom_sig_pending = Yap_FullLookupAtom("$sig_pending");
#endif
AtomBraces = Yap_LookupAtom("{}");
#ifdef COROUTINING
Yap_heap_regs->atom_att = Yap_FullLookupAtom("$att");
#endif
Yap_heap_regs->atom_b = Yap_FullLookupAtom("$last_choice_pt");
Yap_heap_regs->atom_break = Yap_FullLookupAtom("$break");
Yap_heap_regs->atom_call = Yap_LookupAtom("call");
@ -1182,8 +1185,10 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size,
INIT_RWLOCK(HashChain[i].AERWLock);
HashChain[i].Entry = NIL;
}
Yap_LookupAtomWithAddress("FoundVar",&(SF_STORE->AtFoundVar));
Yap_LookupAtomWithAddress(".",&(SF_STORE->AtFoundVar));
Yap_ReleaseAtom(AtomFoundVar);
Yap_LookupAtomWithAddress("?",&(SF_STORE->AtFreeTerm));
Yap_ReleaseAtom(AtomFreeTerm);
Yap_LookupAtomWithAddress("[]",&(SF_STORE->AtNil));
Yap_LookupAtomWithAddress(".",&(SF_STORE->AtDot));
/* InitAbsmi must be done before InitCodes */

2
C/tracer.c
View File

@ -120,6 +120,8 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
/* extern int gc_calls; */
vsc_count++;
if (vsc_count < 487000)
return;
#ifdef COMMENTED
// if (vsc_count == 218280)
// vsc_xstop = 1;

20
C/write.c
View File

@ -313,8 +313,8 @@ write_var(CELL *t, struct write_globs *wglb)
Yap_Portray_delays = FALSE;
if (ext == attvars_ext) {
attvar_record *attv = (attvar_record *)t;
int i;
long sl = 0;
Term l = attv->Atts;
wrputs("$AT(",wglb->writech);
write_var(t, wglb);
@ -324,26 +324,12 @@ write_var(CELL *t, struct write_globs *wglb)
sl = Yap_InitSlot((CELL)attv);
}
writeTerm((Term)&(attv->Value), 999, 1, FALSE, wglb);
wrputc(',', wglb->writech);
writeTerm(l, 999, 1, FALSE, wglb);
if (wglb->keep_terms) {
attv = (attvar_record *)Yap_GetFromSlot(sl);
Yap_RecoverSlots(1);
}
for (i = 0; i < NUM_OF_ATTS; i ++) {
if (!IsVarTerm(attv->Atts[2*i+1])) {
long sl = 0;
wrputc(',', wglb->writech);
if (wglb->keep_terms) {
/* garbage collection may be called */
sl = Yap_InitSlot((CELL)attv);
}
writeTerm((Term)&(attv->Atts[2*i+1]), 999, 1, FALSE, wglb);
if (wglb->keep_terms) {
attv = (attvar_record *)Yap_GetFromSlot(sl);
Yap_RecoverSlots(1);
}
}
}
wrputc(')', wglb->writech);
}
Yap_Portray_delays = TRUE;

4
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.82 2005-08-01 15:40:38 ricroc Exp $ *
* version: $Id: Heap.h,v 1.83 2005-09-09 17:24:39 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -264,6 +264,7 @@ typedef struct various_codes {
atom_append,
atom_array,
atom_assert,
atom_att,
atom_b,
atom_break,
atom_call,
@ -534,6 +535,7 @@ struct various_codes *Yap_heap_regs;
#define AtomAppend Yap_heap_regs->atom_append
#define AtomArray Yap_heap_regs->atom_array
#define AtomAssert Yap_heap_regs->atom_assert
#define AtomAtt Yap_heap_regs->atom_att
#define AtomB Yap_heap_regs->atom_b
#define AtomBreak Yap_heap_regs->atom_break
#define AtomCall Yap_heap_regs->atom_call

16
H/TermExt.h
View File

@ -1,10 +1,3 @@
/*************************************************************************
* *
* YAP Prolog %W% %G% *
@ -17,7 +10,7 @@
* File: TermExt.h *
* mods: *
* comments: Extensions to standard terms for YAP *
* version: $Id: TermExt.h,v 1.1 2005-05-27 22:27:06 rslopes Exp $ *
* version: $Id: TermExt.h,v 1.2 2005-09-09 17:24:39 vsc Exp $ *
*************************************************************************/
#ifdef USE_SYSTEM_MALLOC
@ -28,15 +21,18 @@
#if USE_OFFSETS
#define AtomFoundVar ((Atom)(&(((special_functors *)(NULL))->AtFoundVar)))
#define AtomFreeTerm ((Atom)(&(((special_functors *)(NULL))->AtFreeTerm)))
#define AtomNil ((Atom)(&(((special_functors *)(NULL))->AtNil)))
#define AtomDot ((Atom)(&(((special_functors *)(NULL))->AtDot)))
#else
#define AtomFoundVar AbsAtom(&(SF_STORE->AtFoundVar))
#define AtomFreeTerm AbsAtom(&(SF_STORE->AtFreeTerm))
#define AtomNil AbsAtom(&(SF_STORE->AtNil))
#define AtomDot AbsAtom(&(SF_STORE->AtDot))
#endif
#define TermFoundVar MkAtomTerm(AtomFoundVar)
#define TermFreeTerm MkAtomTerm(AtomFreeTerm)
#define TermNil MkAtomTerm(AtomNil)
#define TermDot MkAtomTerm(AtomDot)
@ -125,6 +121,8 @@ typedef struct special_functors_struct
{
AtomEntry AtFoundVar;
char AtFoundVarChars[8];
AtomEntry AtFreeTerm;
char AtFreeTermChars[8];
AtomEntry AtNil;
char AtNilChars[8];
AtomEntry AtDot;
@ -495,7 +493,7 @@ inline EXTERN exts ExtFromCell (CELL *);
inline EXTERN exts
ExtFromCell (CELL * pt)
{
return (exts) (pt[1]);
return attvars_ext;
}

24
H/attvar.h
View File

@ -36,17 +36,15 @@ Each attribute contains;
*/
/*
attvar_entry is just a Prolog structure such that the first argument is
a pointer to the next args
*/
typedef struct attvar_struct {
Term Done; /* if unbound suspension active, if bound terminated */
CELL sus_id;
Term NS; /* other attributed variables */
Term Value; /* value the variable will take */
#ifdef __GNUC__
/* GNUCC understands empty arrays */
Term Atts[0];
#else
Term Atts[2]; /* size of an entry */
#endif
Term Done; /* if unbound suspension active, if bound terminated */
Term Value; /* value the variable will take */
Term Atts; /* actual data */
} attvar_record;
/*********** tags for suspension variables */
@ -56,12 +54,12 @@ typedef struct attvar_struct {
static inline attvar_record *
DelayTop(void) {
return (attvar_record *)((CELL *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(DelayedVars)));
return (attvar_record *)((attvar_record *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(DelayedVars)));
}
static inline void
SetDelayTop(CELL *new_top) {
Yap_UpdateTimedVar(DelayedVars, MkIntegerTerm((CELL)(new_top-(CELL *)Yap_GlobalBase)));
SetDelayTop(attvar_record *new_top) {
Yap_UpdateTimedVar(DelayedVars, MkIntegerTerm((CELL)(new_top-(attvar_record *)Yap_GlobalBase)));
}
#endif

5
H/heapgc.h
View File

@ -67,7 +67,7 @@
/* is val pointing to something bound to the heap? */
#define GCIsPrimitiveTerm(X) (!IsVarTerm(X) && IsAtomOrIntTerm(X))
#define GCIsPrimitiveTerm(X) (/* not really needed !IsVarTerm(X) && */ IsAtomOrIntTerm(X))
/* Does X point to an object in the heap */
#define HEAP_PTR(val) (!GCIsPrimitiveTerm(val) && ONHEAP(GET_NEXT(val)))
@ -131,8 +131,7 @@ UNRMARK(CELL* ptr)
static inline int
RMARKED(CELL* ptr)
{
CELL val = *ptr;
return !GCIsPrimitiveTerm(val) && (mcell(ptr) & RMARK_BIT);
return mcell(ptr) & RMARK_BIT;
}
#else

8
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2005-08-01 15:40:38 $,$Author: ricroc $ *
* Last rev: $Date: 2005-09-09 17:24:39 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.53 2005/08/01 15:40:38 ricroc
* TABLING NEW: better support for incomplete tabling
*
* Revision 1.52 2005/07/06 19:34:11 ricroc
* TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
*
@ -282,6 +285,9 @@ restore_codes(void)
Yap_heap_regs->atom_array = AtomAdjust(Yap_heap_regs->atom_array);
Yap_heap_regs->atom_assert = AtomAdjust(Yap_heap_regs->atom_assert);
Yap_heap_regs->atom_alarm = AtomAdjust(Yap_heap_regs->atom_alarm);
#ifdef COROUTINING
Yap_heap_regs->atom_att = AtomAdjust(Yap_heap_regs->atom_att);
#endif
Yap_heap_regs->atom_b = AtomAdjust(Yap_heap_regs->atom_b);
Yap_heap_regs->atom_break = AtomAdjust(Yap_heap_regs->atom_break);
Yap_heap_regs->atom_call = AtomAdjust(Yap_heap_regs->atom_call);

191
library/atts.yap
View File

@ -24,20 +24,10 @@
:- multifile
user:term_expansion/2.
:- dynamic_predicate(existing_attribute/3,logical).
:- dynamic_predicate(modules_with_attributes/1,logical).
modules_with_attributes([]).
:- user_defined_directive(attribute(G), attributes:new_attribute(G)).
user:goal_expansion(get_atts(Var,AccessSpec), Mod, Gs) :- !,
expand_get_attributes(AccessSpec,Mod,Var,[],GL),
convert_to_goals(GL,Gs).
user:goal_expansion(put_atts(Var,AccessSpec), Mod, Gs) :- !,
expand_put_attributes(AccessSpec,Mod,Var,[],GL),
convert_to_goals(GL,Gs).
:- dynamic existing_attribute/4.
:- dynamic modules_with_attributes/1.
modules_with_attributes([prolog]).
%
% defining a new attribute is just a question of establishing a
@ -51,90 +41,135 @@ new_attribute((At1,At2)) :-
new_attribute(Na/Ar) :-
source_module(Mod),
functor(S,Na,Ar),
existing_attribute(S,Mod,_) , !.
existing_attribute(S,Mod,_,_) , !.
new_attribute(Na/Ar) :-
source_module(Mod),
inc_n_of_atts(Key),
functor(S,Na,Ar),
store_new_module(Mod),
assertz(existing_attribute(S,Mod,Key)).
store_new_module(Mod,Ar,Position),
assertz(existing_attribute(S,Mod,Ar,Position)).
store_new_module(Mod) :-
existing_attribute(_,Mod,_), !.
existing_attribute(delay(_),prolog,1,2).
store_new_module(Mod,Ar,ArgPosition) :-
(
retract(attributed_module(Mod,Position,_))
->
true
;
store_new_module(Mod), Position = 1
),
ArgPosition is Position+1,
( Ar == 0 -> NOfAtts is Position+1 ; NOfAtts is Position+Ar),
functor(AccessTerm,Mod,NOfAtts),
assertz(attributed_module(Mod,NOfAtts,AccessTerm)).
store_new_module(Mod) :-
retract(modules_with_attributes(Mods)),
assertz(modules_with_attributes([Mod|Mods])).
expand_get_attributes(V,Mod,Var,GL0,GL) :- var(V), !,
GL = [attributes:get_atts_at_run_time(Var,V,Mod)|GL0].
expand_get_attributes([],_,_,LG,LG) :- !.
expand_get_attributes([Att|Atts],Mod,Var,L0,LF) :- !,
expand_get_attributes(Att,Mod,Var,L0,L1),
expand_get_attributes(Atts,Mod,Var,L1,LF).
expand_get_attributes(+Att,Mod,Var,L0,LF) :- !,
expand_get_attributes(Att,Mod,Var,L0,LF).
expand_get_attributes(-Att,Mod,Var,L0,[attributes:free_att(Var,Key)|L0]) :- !,
existing_attribute(Att,Mod,Key).
expand_get_attributes(Att,Mod,Var,L0,[attributes:get_att(Var,Key,Att)|L0]) :-
% searching for an attribute
existing_attribute(Att,Mod,Key).
:- user_defined_directive(attribute(G), attributes:new_attribute(G)).
get_atts_at_run_time(Var,Atts,Module) :-
var(Atts), !,
get_all_atts(Var,LAtts),
fetch_interesting_attributes(LAtts, Module, Atts).
get_atts_at_run_time(Var,Atts,Module) :-
expand_get_attributes(Atts,Module,Var,[],GL),
convert_to_goals(GL,Gs),
call(Gs).
user:goal_expansion(get_atts(Var,AccessSpec), Mod, Goal) :-
expand_get_attributes(AccessSpec,Mod,Var,Goal).
user:goal_expansion(put_atts(Var,AccessSpec), Mod, Goal) :-
expand_put_attributes(AccessSpec, Mod, Var, Goal).
fetch_interesting_attributes([], _, []).
fetch_interesting_attributes([[I|Att]|LAtts], Module, Atts) :-
fetch_interesting_attribute(Att, Module, I, Atts, AttsI),
fetch_interesting_attributes(LAtts, Module, AttsI).
%
% only output attributes if they are for the current module.
%
fetch_interesting_attribute(Att, Module, Key, [Att|Atts], Atts) :-
existing_attribute(Att, Module, Key), !.
fetch_interesting_attribute(_, _, _, Atts, Atts).
expand_get_attributes(V,_,_,_) :- var(V), !, fail.
expand_get_attributes([],_,_,true) :- !.
expand_get_attributes([-G1],Mod,V,attributes:free_att(V,Mod,Pos)) :-
existing_attribute(G1,Mod,_,Pos), !.
expand_get_attributes([+G1],Mod,V,attributes:get_att(V,Mod,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
arg(1,G1,A).
expand_get_attributes([G1],Mod,V,attributes:get_att(V,Mod,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
arg(1,G1,A).
expand_get_attributes(Atts,Mod,Var,attributes:get_module_atts(Var,AccessTerm)) :- Atts = [_|_], !,
attributed_module(Mod,NOfAtts,AccessTerm),
cvt_atts(Atts,Mod,LAtts),
sort(LAtts,SortedLAtts),
free_term(Void),
build_att_term(1,NOfAtts,SortedLAtts,Void,AccessTerm).
expand_get_attributes(Att,Mod,Var,Goal) :-
expand_get_attributes([Att],Mod,Var,Goal).
expand_put_attributes(V,Mod,Var,G0,GF) :- var(V), !,
GF = [attributes:put_atts_at_run_time(Var,V,Mod)|G0].
expand_put_attributes([],_,_,G,G) :- !.
expand_put_attributes([Att|Atts],Mod,Var,G0,GF) :- !,
expand_put_attributes(Att,Mod,Var,G0,GI),
expand_put_attributes(Atts,Mod,Var,GI,GF).
expand_put_attributes(+Att,Mod,Var,G0,GF) :- !,
expand_put_attributes(Att,Mod,Var,G0,GF).
expand_put_attributes(-Att,Mod,Var,G0,[attributes:rm_att(Var,Key)|G0]) :- !,
existing_attribute(Att,Mod,Key).
expand_put_attributes(Att,Mod,Var,G0,[attributes:put_att(Var,Key,Att)|G0]) :-
% searching for an attribute
existing_attribute(Att,Mod,Key).
build_att_term(NOfAtts,NOfAtts,[],_,_) :- !.
build_att_term(I0,NOfAtts,[I-Info|SortedLAtts],Void,AccessTerm) :-
I is I0+1, !,
copy_att_args(Info,I0,NI,AccessTerm),
build_att_term(NI,NOfAtts,SortedLAtts,Void,AccessTerm).
build_att_term(I0,NOfAtts,SortedLAtts,Void,AccessTerm) :-
I is I0+1,
arg(I,AccessTerm,Void),
build_att_term(I,NOfAtts,SortedLAtts,Void,AccessTerm).
put_atts_at_run_time(Var,Atts,_) :-
var(Atts), !,
throw(error(instantiation_error,put_atts(Var,Atts))).
put_atts_at_run_time(Var,Atts,Module) :-
expand_put_attributes(Atts,Module,Var,[],GL),
convert_to_goals(GL,Gs),
call(Gs).
cvt_atts(V,_,_) :- var(V), !, fail.
cvt_atts([],_,[]).
cvt_atts([V|_],_,_) :- var(V), !, fail.
cvt_atts([+Att|Atts],Mod,[Pos-LAtts|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
(atom(Att) -> LAtts = [_] ; Att=..[_|LAtts]),
cvt_atts(Atts,Mod,Read).
cvt_atts([-Att|Atts],Mod,[Pos-LVoids|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
void_term(Void),
(
atom(Att)
->
LVoids = [Void]
;
Att =..[_|LAtts],
void_vars(LAtts,Void,LVoids)
),
cvt_atts(Atts,Mod,Read).
cvt_atts([Att|Atts],Mod,[Pos-LAtts|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
(atom(Att) -> LAtts = [_] ; Att=..[_|LAtts]),
cvt_atts(Atts,Mod,Read).
copy_att_args([],I,I,_).
copy_att_args([V|Info],I,NI,AccessTerm) :-
I1 is I+1,
arg(I1,AccessTerm,V),
copy_att_args(Info,I1,NI,AccessTerm).
void_vars([],_,[]).
void_vars([_|LAtts],Void,[Void|LVoids]) :-
void_vars(LAtts,Void,LVoids).
expand_put_attributes(V,_,_,_) :- var(V), !, fail.
expand_put_attributes([-G1],Mod,V,attributes:rm_att(V,Mod,NOfAtts,Pos)) :-
existing_attribute(G1,Mod,_,Pos), !,
attributed_module(Mod,NOfAtts,_).
expand_put_attributes([+G1],Mod,V,attributes:put_att(V,Mod,NOfAtts,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
attributed_module(Mod,NOfAtts,_),
arg(1,G1,A).
expand_put_attributes([G1],Mod,V,attributes:put_att(V,Mod,NOfAtts,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
attributed_module(Mod,NOfAtts,_),
arg(1,G1,A).
expand_put_attributes(Atts,Mod,Var,attributes:put_module_atts(Var,AccessTerm)) :- Atts = [_|_], !,
attributed_module(Mod,NOfAtts,AccessTerm),
cvt_atts(Atts,Mod,LAtts),
sort(LAtts,SortedLAtts),
void_term(Void),
build_att_term(1,NOfAtts,SortedLAtts,Void,AccessTerm).
expand_put_attributes(Att,Mod,Var,Goal) :-
expand_put_attributes([Att],Mod,Var,Goal).
woken_att_do(AttVar, Binding) :-
modules_with_attributes(Mods),
modules_with_attributes(AttVar,Mods),
do_verify_attributes(Mods, AttVar, Binding, Goals),
bind_attvar(AttVar),
lcall(Goals).
do_verify_attributes([], _, _, []).
do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :-
existing_attribute(_,Mod,Key),
get_att(AttVar,Key,_),
current_predicate(verify_attributes, Mod:verify_attributes(_,_,_)), !,
do_verify_attributes(Mods, AttVar, Binding, Goals),
Mod:verify_attributes(AttVar, Binding, Goal).
current_predicate(verify_attributes,Mod:verify_attributes(_,_,_)), !,
Mod:verify_attributes(AttVar, Binding, Goal),
do_verify_attributes(Mods, AttVar, Binding, Goals).
do_verify_attributes([_|Mods], AttVar, Binding, Goals) :-
do_verify_attributes(Mods, AttVar, Binding, Goals).
@ -149,7 +184,7 @@ lcall2([Goal|Goals], Mod) :-
lcall2(Goals, Mod).
convert_att_var(V, Gs) :-
modules_with_attributes(LMods),
modules_with_attributes(V,LMods),
fetch_att_goals(LMods,V,Gs0), !,
simplify_trues(Gs0, Gs).
convert_att_var(_, true).
@ -167,8 +202,6 @@ fetch_att_goals([_|LMods], Att, LGoal) :-
% if there is an active attribute for this module call attribute_goal.
%
call_module_attributes(Mod, AttV, G1) :-
existing_attribute(_,Mod,Key),
get_att(AttV,Key,_), !,
current_predicate(attribute_goal, Mod:attribute_goal(AttV,G1)),
Mod:attribute_goal(AttV, G1).

13
pl/corout.yap
View File

@ -558,8 +558,7 @@ call_residue(Goal,Residue) :-
'$call_residue'(Goal,Module,Residue) :-
'$read_svar_list'(OldAttsList),
'$copy_term_but_not_constraints'(Goal, NGoal),
( create_mutable([], CurrentAttsList),
'$set_svar_list'(CurrentAttsList),
( '$set_svar_list'(CurrentAttsList),
'$system_catch'(NGoal,Module,Error,'$residue_catch_trap'(Error,OldAttsList)),
'$call_residue_continuation'(NGoal,NResidue),
@ -729,14 +728,20 @@ call_residue(Goal,Residue) :-
%'$freeze'(V,G) :-
% attributes:get_att(V, 0, Gs), write(G+Gs),nl,fail.
'$freeze'(V,G) :-
attributes:update_att(V, 0, G).
'$update_att'(V, G).
'$update_att'(V, G) :-
attributes:get_module_atts(V, prolog(_,Gs)), !,
attributes:put_module_atts(V, prolog(_,[G|Gs])).
'$update_att'(V, G) :-
attributes:put_module_atts(V, prolog(_,[G])).
'$goal_in'(G,[G1|_]) :- G == G1, !.
'$goal_in'(G,[_|Gs]) :-
'$goal_in'(G,Gs).
'$frozen_goals'(V,Gs) :-
var(V),
attributes:get_att(V, 0, Gs), nonvar(Gs).
attributes:get_att(V, prolog, 2, Gs), nonvar(Gs).