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

ugh

Browse Source
This commit is contained in:
Vitor Santos Costa 2019-01-28 15:02:55 +00:00
parent 36fedfa321
commit 09d8d07b7e
6 changed files with 2186 additions and 1187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

439
C/globals.c
View File

@ -145,13 +145,13 @@ static char SccsId[] = "%W% %G%";
#define Global_MkIntegerTerm(I) MkIntegerTerm(I) #define Global_MkIntegerTerm(I) MkIntegerTerm(I)
static size_t big2arena_sz(CELL *arena_base) { static UInt big2arena_sz(CELL *arena_base) {
return (((MP_INT *)(arena_base + 2))->_mp_alloc * sizeof(mp_limb_t) + return (((MP_INT *)(arena_base + 2))->_mp_alloc * sizeof(mp_limb_t) +
sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) /
sizeof(CELL); sizeof(CELL);
} }
static size_t arena2big_sz(size_t sz) { static UInt arena2big_sz(UInt sz) {
return sz - return sz -
(sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(CELL); (sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(CELL);
} }
@ -159,7 +159,7 @@ static size_t arena2big_sz(size_t sz) {
/* pointer to top of an arena */ /* pointer to top of an arena */
static inline CELL *ArenaLimit(Term arena) { static inline CELL *ArenaLimit(Term arena) {
CELL *arena_base = RepAppl(arena); CELL *arena_base = RepAppl(arena);
size_t sz = big2arena_sz(arena_base); UInt sz = big2arena_sz(arena_base);
return arena_base + sz; return arena_base + sz;
} }
@ -171,9 +171,9 @@ CELL *Yap_ArenaLimit(Term arena) {
/* pointer to top of an arena */ /* pointer to top of an arena */
static inline CELL *ArenaPt(Term arena) { return (CELL *)RepAppl(arena); } static inline CELL *ArenaPt(Term arena) { return (CELL *)RepAppl(arena); }
static inline size_t ArenaSz(Term arena) { return big2arena_sz(RepAppl(arena)); } static inline UInt ArenaSz(Term arena) { return big2arena_sz(RepAppl(arena)); }
static Term CreateNewArena(CELL *ptr, size_t size) { static Term CreateNewArena(CELL *ptr, UInt size) {
Term t = AbsAppl(ptr); Term t = AbsAppl(ptr);
MP_INT *dst; MP_INT *dst;
@ -186,9 +186,9 @@ static Term CreateNewArena(CELL *ptr, size_t size) {
return t; return t;
} }
static Term NewArena(size_t size, int wid, UInt arity, CELL *where) { static Term NewArena(UInt size, int wid, UInt arity, CELL *where) {
Term t; Term t;
size_t new_size; UInt new_size;
WORKER_REGS(wid) WORKER_REGS(wid)
if (where == NULL || where == HR) { if (where == NULL || where == HR) {
@ -232,7 +232,7 @@ void Yap_AllocateDefaultArena(size_t gsize, int wid) {
REMOTE_GlobalArena(wid) = NewArena(gsize, wid, 2, NULL); REMOTE_GlobalArena(wid) = NewArena(gsize, wid, 2, NULL);
} }
static void adjust_cps(size_t size USES_REGS) { static void adjust_cps(UInt size USES_REGS) {
/* adjust possible back pointers in choice-point stack */ /* adjust possible back pointers in choice-point stack */
choiceptr b_ptr = B; choiceptr b_ptr = B;
while (b_ptr->cp_h == HR) { while (b_ptr->cp_h == HR) {
@ -290,14 +290,14 @@ static int GrowArena(Term arena, CELL *pt, size_t old_size, size_t size,
return TRUE; return TRUE;
} }
CELL *Yap_GetFromArena(Term *arenap, size_t cells, UInt arity) { CELL *Yap_GetFromArena(Term *arenap, UInt cells, UInt arity) {
CACHE_REGS CACHE_REGS
restart : { restart : {
Term arena = *arenap; Term arena = *arenap;
CELL *max = ArenaLimit(arena); CELL *max = ArenaLimit(arena);
CELL *base = ArenaPt(arena); CELL *base = ArenaPt(arena);
CELL *newH; CELL *newH;
size_t old_sz = ArenaSz(arena), new_size; UInt old_sz = ArenaSz(arena), new_size;
if (IN_BETWEEN(base, HR, max)) { if (IN_BETWEEN(base, HR, max)) {
base = HR; base = HR;
@ -319,8 +319,8 @@ CELL *Yap_GetFromArena(Term *arenap, size_t cells, UInt arity) {
} }
static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP, static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP,
size_t old_size USES_REGS) { UInt old_size USES_REGS) {
size_t new_size; UInt new_size;
if (HR == oldH) if (HR == oldH)
return; return;
@ -331,6 +331,319 @@ static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP,
ASP = oldASP; ASP = oldASP;
} }
static inline void clean_dirty_tr(tr_fr_ptr TR0 USES_REGS) {
if (TR != TR0) {
tr_fr_ptr pt = TR0;
do {
Term p = TrailTerm(pt++);
if (IsVarTerm(p)) {
RESET_VARIABLE(p);
} else {
/* copy downwards */
TrailTerm(TR0 + 1) = TrailTerm(pt);
TrailTerm(TR0) = TrailTerm(TR0 + 2) = p;
pt += 2;
TR0 += 3;
}
} while (pt != TR);
TR = TR0;
}
}
#define expand_stack(S0,SP,SF,TYPE) \
{ size_t sz = SF-S0, used = SP-S0; \
S0 = Realloc(S0, (1024+sz)*sizeof(TYPE) PASS_REGS); \
SP = S0+used; SF = S0+sz; }
static int copy_complex_term(register CELL *pt0, register CELL *pt0_end,
int share, int copy_att_vars, CELL *ptf,
CELL *HLow USES_REGS) {
int lvl = push_text_stack();
struct cp_frame *to_visit0, *to_visit = Malloc(1024*sizeof(struct cp_frame));
struct cp_frame *to_visit_max;
CELL *HB0 = HB;
tr_fr_ptr TR0 = TR;
int ground = TRUE;
HB = HLow;
to_visit0 = to_visit;
to_visit_max = to_visit+1024;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, copy_term_unk);
copy_term_nvar : {
if (IsPairTerm(d0)) {
CELL *ap2 = RepPair(d0);
if ((share && ap2 < HB) || (ap2 >= HB && ap2 < HR)) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
*ptf = AbsPair(HR);
ptf++;
#ifdef RATIONAL_TREES
if (to_visit >= to_visit_max-32) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsPair(HR);
to_visit++;
#else
if (pt0 < pt0_end) {
if (to_visit + 32 >= to_visit_max - 32) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit++;
}
#endif
ground = TRUE;
pt0 = ap2 - 1;
pt0_end = ap2 + 1;
ptf = HR;
HR += 2;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
if ((share && ap2 < HB) || (ap2 >= HB && ap2 < HR)) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
case (CELL) FunctorAttVar:
*ptf++ = d0;
break;
case (CELL) FunctorLongInt:
if (HR > ASP - (MIN_ARENA_SIZE + 3)) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
HR[1] = ap2[1];
HR[2] = EndSpecials;
HR += 3;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
break;
case (CELL) FunctorDouble:
if (HR >
ASP - (MIN_ARENA_SIZE + (2 + SIZEOF_DOUBLE / sizeof(CELL)))) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
HR[1] = ap2[1];
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
HR[2] = ap2[2];
HR[3] = EndSpecials;
HR += 4;
#else
HR[2] = EndSpecials;
HR += 3;
#endif
break;
case (CELL) FunctorString:
if (ASP - HR < MIN_ARENA_SIZE + 3 + ap2[1]) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
memmove(HR, ap2, sizeof(CELL) * (3 + ap2[1]));
HR += ap2[1] + 3;
break;
default: {
/* big int */
UInt sz = (sizeof(MP_INT) + 3 * CellSize +
((MP_INT *)(ap2 + 2))->_mp_alloc * sizeof(mp_limb_t)) /
CellSize,
i;
if (HR > ASP - (MIN_ARENA_SIZE + sz)) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
for (i = 1; i < sz; i++) {
HR[i] = ap2[i];
}
HR += sz;
}
}
continue;
}
*ptf = AbsAppl(HR);
ptf++;
/* store the terms to visit */
#ifdef RATIONAL_TREES
if (to_visit + 32 >= to_visit_max) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsAppl(HR);
to_visit++;
#else
if (pt0 < pt0_end) {
if (to_visit++ >= (CELL **)AuxSp) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit++;
}
#endif
ground = (f != FunctorMutable);
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
/* store the functor for the new term */
HR[0] = (CELL)f;
ptf = HR + 1;
HR += 1 + d0;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
} else {
/* just copy atoms or integers */
*ptf++ = d0;
}
continue;
}
derefa_body(d0, ptd0, copy_term_unk, copy_term_nvar);
ground = FALSE;
/* don't need to copy variables if we want to share the global term */
if ((share && ptd0 < HB && ptd0 > H0) || (ptd0 >= HLow && ptd0 < HR)) {
/* we have already found this cell */
*ptf++ = (CELL)ptd0;
} else {
#if COROUTINING
if (copy_att_vars && GlobalIsAttachedTerm((CELL)ptd0)) {
/* if unbound, call the standard copy term routine */
struct cp_frame *bp;
CELL new;
bp = to_visit;
if (!GLOBAL_attas[ExtFromCell(ptd0)].copy_term_op(ptd0, &bp,
ptf PASS_REGS)) {
goto overflow;
}
to_visit = bp;
new = *ptf;
if (TR > (tr_fr_ptr)LOCAL_TrailTop - 256) {
/* Trail overflow */
if (!Yap_growtrail((TR - TR0) * sizeof(tr_fr_ptr *), TRUE)) {
goto trail_overflow;
}
}
Bind_and_Trail(ptd0, new);
ptf++;
} else {
#endif
/* first time we met this term */
RESET_VARIABLE(ptf);
if ((ADDR)TR > LOCAL_TrailTop - MIN_ARENA_SIZE)
goto trail_overflow;
Bind_and_Trail(ptd0, (CELL)ptf);
ptf++;
#ifdef COROUTINING
}
#endif
}
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
#ifdef RATIONAL_TREES
*pt0 = to_visit->oldv;
#endif
ground = (ground && to_visit->ground);
goto loop;
}
/* restore our nice, friendly, term to its original state */
HB = HB0;
clean_dirty_tr(TR0 PASS_REGS);
/* follow chain of multi-assigned variables */
pop_text_stack(lvl);
return 0;
overflow:
/* oops, we're in trouble */
HR = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
pop_text_stack(lvl);
return -1;
trail_overflow:
/* oops, we're in trouble */
HR = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
pop_text_stack(lvl);
return -4;
}
static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars, static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
UInt arity, Term *newarena, UInt arity, Term *newarena,
size_t min_grow USES_REGS) { size_t min_grow USES_REGS) {
@ -353,7 +666,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
*HR = t; *HR = t;
Hi = HR + 1; Hi = HR + 1;
HR += 2; HR += 2;
if ((res = Yap_copy_complex_term(Hi - 2, Hi - 1, share, NULL, copy_att_vars, Hi, if ((res = copy_complex_term(Hi - 2, Hi - 1, share, copy_att_vars, Hi,
Hi PASS_REGS)) < 0) Hi PASS_REGS)) < 0)
goto error_handler; goto error_handler;
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS); CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
@ -373,20 +686,106 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
return tn; return tn;
} else if (IsAtomOrIntTerm(t)) { } else if (IsAtomOrIntTerm(t)) {
return t; return t;
} else { } else if (IsPairTerm(t)) {
Term tf;
CELL *ap;
CELL *Hi; CELL *Hi;
Hi = HR; if (share && ArenaPt(arena) > RepPair(t)) {
HR++; return t;
oldH = HR; }
HR = HB = ArenaPt(arena); HR = HB = ArenaPt(arena);
ASP = ArenaLimit(arena); ASP = ArenaLimit(arena);
if ((res = Yap_copy_complex_term(&t - 1, &t, share, NULL, copy_att_vars, Hi, ap = RepPair(t);
HR PASS_REGS)) < 0) { Hi = HR;
tf = AbsPair(HR);
HR += 2;
if ((res = copy_complex_term(ap - 1, ap + 1, share, copy_att_vars, Hi,
Hi PASS_REGS)) < 0) {
goto error_handler; goto error_handler;
} }
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS); CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return Hi[0]; return tf;
} else {
Functor f;
Term tf;
CELL *HB0;
CELL *ap;
if (share && ArenaPt(arena) > RepAppl(t)) {
return t;
}
HR = HB = ArenaPt(arena);
ASP = ArenaLimit(arena);
f = FunctorOfTerm(t);
HB0 = HR;
ap = RepAppl(t);
tf = AbsAppl(HR);
HR[0] = (CELL)f;
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return t;
case (CELL) FunctorLongInt:
if (HR > ASP - (MIN_ARENA_SIZE + 3)) {
res = -1;
goto error_handler;
}
HR[1] = ap[1];
HR[2] = EndSpecials;
HR += 3;
break;
case (CELL) FunctorDouble:
if (HR > ASP - (MIN_ARENA_SIZE + (2 + SIZEOF_DOUBLE / sizeof(CELL)))) {
res = -1;
goto error_handler;
}
HR[1] = ap[1];
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
HR[2] = ap[2];
HR[3] = EndSpecials;
HR += 4;
#else
HR[2] = EndSpecials;
HR += 3;
#endif
break;
case (CELL) FunctorString:
if (HR > ASP - (MIN_ARENA_SIZE + 3 + ap[1])) {
res = -1;
goto error_handler;
}
memmove(HR, ap, sizeof(CELL) * (3 + ap[1]));
HR += ap[1] + 3;
break;
default: {
UInt sz = ArenaSz(t), i;
if (HR > ASP - (MIN_ARENA_SIZE + sz)) {
res = -1;
goto error_handler;
}
for (i = 1; i < sz; i++) {
HR[i] = ap[i];
}
HR += sz;
}
}
} else {
HR += 1 + ArityOfFunctor(f);
if (HR > ASP - MIN_ARENA_SIZE) {
res = -1;
goto error_handler;
}
if ((res = copy_complex_term(ap, ap + ArityOfFunctor(f), share,
copy_att_vars, HB0 + 1, HB0 PASS_REGS)) <
0) {
goto error_handler;
}
}
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return tf;
} }
error_handler: error_handler:
HR = HB; HR = HB;

7
C/qlyr.c
View File

@ -863,6 +863,9 @@ static void read_clauses(FILE *stream, PredEntry *pp, UInt nclauses,
} while (cl != NULL); } while (cl != NULL);
} }
if (!nclauses) { if (!nclauses) {
pp->CodeOfPred = pp->cs.p_code.TrueCodeOfPred = FAILCODE;
pp->OpcodeOfPred = FAIL_OPCODE;
return; return;
} }
while ((read_tag(stream) == QLY_START_LU_CLAUSE)) { while ((read_tag(stream) == QLY_START_LU_CLAUSE)) {
@ -947,6 +950,10 @@ static void read_clauses(FILE *stream, PredEntry *pp, UInt nclauses,
Yap_EraseStaticClause(cl, pp, CurrentModule); Yap_EraseStaticClause(cl, pp, CurrentModule);
cl = ncl; cl = ncl;
} while (cl != NULL); } while (cl != NULL);
} else if (flags & MultiFileFlag) {
pp->CodeOfPred = pp->cs.p_code.TrueCodeOfPred = FAILCODE;
pp->OpcodeOfPred = FAIL_OPCODE;
} }
for (i = 0; i < nclauses; i++) { for (i = 0; i < nclauses; i++) {
char *base = (void *)read_UInt(stream); char *base = (void *)read_UInt(stream);

1871
C/utilpreds.c
View File

File diff suppressed because it is too large Load Diff

81
C/write.c
View File

@ -77,8 +77,6 @@ typedef struct write_globs {
int last_atom_minus; int last_atom_minus;
UInt MaxDepth, MaxArgs; UInt MaxDepth, MaxArgs;
wtype lw; wtype lw;
yhandle_t sl0, sl;
bool protectedEntry;
} wglbs; } wglbs;
#define lastw wglb->lw #define lastw wglb->lw
@ -104,8 +102,9 @@ static bool callPortray(Term t, int sno USES_REGS) {
#define PROTECT(t, F) \ #define PROTECT(t, F) \
{ \ { \
yhandle_t yt = Yap_InitHandle(t); \
F; \ F; \
t = Yap_GetFromSlot(wglb->sl); \ t = Yap_PopHandle(yt); \
} }
static void wrputn(Int, struct write_globs *); static void wrputn(Int, struct write_globs *);
static void wrputf(Float, struct write_globs *); static void wrputf(Float, struct write_globs *);
@ -117,11 +116,6 @@ static wtype AtomIsSymbols(unsigned char *);
static void putAtom(Atom, int, struct write_globs *); static void putAtom(Atom, int, struct write_globs *);
static void writeTerm(Term, int, int, int, struct write_globs *, static void writeTerm(Term, int, int, int, struct write_globs *,
struct rewind_term *); struct rewind_term *);
static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt);
static void write_list(Term t, int direction, int depth,
struct write_globs *wglb, struct rewind_term *rwt);
#define wrputc(WF, X) \ #define wrputc(WF, X) \
(X)->stream_wputc(X - GLOBAL_Stream, WF) /* writes a character */ (X)->stream_wputc(X - GLOBAL_Stream, WF) /* writes a character */
@ -273,7 +267,7 @@ static void writebig(Term t, int p, int depth, int rinfixarg,
return; return;
} else if (big_tag == BIG_RATIONAL) { } else if (big_tag == BIG_RATIONAL) {
Term trat = Yap_RatTermToApplTerm(t); Term trat = Yap_RatTermToApplTerm(t);
writeTerm__(trat,wglb->sl, p, depth, rinfixarg, wglb, rwt); writeTerm(trat, p, depth, rinfixarg, wglb, rwt);
return; return;
#endif #endif
} else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) { } else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
@ -387,7 +381,8 @@ int Yap_FormatFloat(Float f, char **s, size_t sz) {
struct write_globs wglb; struct write_globs wglb;
int sno; int sno;
sno = Yap_open_buf_write_stream(GLOBAL_Stream[LOCAL_c_output_stream].encoding, 0); sno = Yap_open_buf_write_stream(GLOBAL_Stream[LOCAL_c_output_stream].encoding,
0);
if (sno < 0) if (sno < 0)
return false; return false;
wglb.lw = separator; wglb.lw = separator;
@ -706,9 +701,7 @@ static void write_var(CELL *t, struct write_globs *wglb,
wrputs("$AT(", wglb->stream); wrputs("$AT(", wglb->stream);
write_var(t, wglb, rwt); write_var(t, wglb, rwt);
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
CELL tt = (CELL)t; PROTECT(*t, writeTerm(*l, 999, 1, FALSE, wglb, &nrwt));
PROTECT(tt, writeTerm(*l, 999, 1, FALSE, wglb, &nrwt));
t = (CELL *)tt;
attv = RepAttVar(t); attv = RepAttVar(t);
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
l++; l++;
@ -725,32 +718,13 @@ static void write_var(CELL *t, struct write_globs *wglb,
} }
} }
static bool check_for_loops(Term t, struct write_globs *wglb) static void write_list(Term t, int direction, int depth,
{
yhandle_t i, sl = wglb->sl;
if ((wglb->Write_Loops)) {
return false;
}
for (i=sl-1; i>wglb->sl0;i--) {
if (Yap_GetFromHandle(i) == t) {
char buf[64];
snprintf(buf,63," @{ ^^%ld } " ,sl-i);
wrputs(buf, wglb->stream);
return true;
}
}
return false;
}
static void write_list__(Term t, yhandle_t sl, int direction, int depth,
struct write_globs *wglb, struct rewind_term *rwt) { struct write_globs *wglb, struct rewind_term *rwt) {
Term ti; Term ti;
struct rewind_term nrwt; struct rewind_term nrwt;
nrwt.parent = rwt; nrwt.parent = rwt;
nrwt.u_sd.s.ptr = 0; nrwt.u_sd.s.ptr = 0;
while (1) { while (1) {
int ndirection; int ndirection;
int do_jump; int do_jump;
@ -761,18 +735,16 @@ static void write_list__(Term t, yhandle_t sl, int direction, int depth,
break; break;
if (!IsPairTerm(ti)) if (!IsPairTerm(ti))
break; break;
if (check_for_loops(ti,wglb)) return;
wglb->sl = Yap_InitHandle(ti);
ndirection = RepPair(ti) - RepPair(t); ndirection = RepPair(ti) - RepPair(t);
/* make sure we're not trapped in loops */ /* make sure we're not trapped in loops */
if (ndirection > 0) { if (ndirection > 0) {
do_jump = (direction <= 0); do_jump = (direction <= 0);
} /*else if (ndirection == 0) { } else if (ndirection == 0) {
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
putAtom(AtomFoundVar, wglb->Quote_illegal, wglb); putAtom(AtomFoundVar, wglb->Quote_illegal, wglb);
lastw = separator; lastw = separator;
return; return;
} */ else { } else {
do_jump = (direction >= 0); do_jump = (direction >= 0);
} }
if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) {
@ -806,24 +778,16 @@ static void write_list__(Term t, yhandle_t sl, int direction, int depth,
} }
} }
static void write_list(Term t, int direction, int depth, static void writeTerm(Term t, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt) {
if (check_for_loops(t,wglb)) return;
yhandle_t sl = wglb->sl = Yap_InitHandle(t);
write_list__(t, sl, direction, depth,
wglb, rwt);
Yap_PopHandle(sl);
wglb->sl = sl-1;
}
static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt) struct write_globs *wglb, struct rewind_term *rwt)
/* term to write */ /* term to write */
/* context priority */ /* context priority */
{ {
CACHE_REGS CACHE_REGS
struct rewind_term nrwt; struct rewind_term nrwt;
nrwt.parent = rwt;
nrwt.u_sd.s.ptr = 0;
if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) {
putAtom(Atom3Dots, wglb->Quote_illegal, wglb); putAtom(Atom3Dots, wglb->Quote_illegal, wglb);
return; return;
@ -857,7 +821,7 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
wrputc('[', wglb->stream); wrputc('[', wglb->stream);
lastw = separator; lastw = separator;
/* we assume t was already saved in the stack */ /* we assume t was already saved in the stack */
write_list__(t, wglb->sl, 0, depth, wglb, rwt); write_list(t, 0, depth, wglb, rwt);
wrputc(']', wglb->stream); wrputc(']', wglb->stream);
lastw = separator; lastw = separator;
} }
@ -909,7 +873,7 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
*p++; *p++;
lastw = separator; lastw = separator;
/* cannot use the term directly with the SBA */ /* cannot use the term directly with the SBA */
writeTerm(*p, 999, depth + 1, FALSE, wglb, &nrwt); PROTECT(t, writeTerm(*p, 999, depth + 1, FALSE, wglb, &nrwt));
if (*p) if (*p)
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
argno++; argno++;
@ -1126,17 +1090,6 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
} }
} }
static void writeTerm(Term t, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt)
{
if (check_for_loops(t,wglb)) return;
yhandle_t sl = wglb->sl = Yap_InitHandle(t);
writeTerm__(t, sl, p, depth, rinfixarg,
wglb, rwt);
Yap_PopHandle(sl);
wglb->sl = sl-1;
}
void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags, void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
int priority) int priority)
/* term to be written */ /* term to be written */
@ -1171,7 +1124,6 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
rwt.parent = NULL; rwt.parent = NULL;
wglb.Ignore_ops = flags & Ignore_ops_f; wglb.Ignore_ops = flags & Ignore_ops_f;
wglb.Write_strings = flags & BackQuote_String_f; wglb.Write_strings = flags & BackQuote_String_f;
wglb.Write_Loops = flags & YAP_WRITE_HANDLE_CYCLES;
if (!(flags & Ignore_cyclics_f) && false) { if (!(flags & Ignore_cyclics_f) && false) {
Term ts[2]; Term ts[2];
ts[0] = Yap_BreakRational(t, 0, ts + 1, TermNil PASS_REGS); ts[0] = Yap_BreakRational(t, 0, ts + 1, TermNil PASS_REGS);
@ -1183,8 +1135,7 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
} }
} }
/* protect slots for portray */ /* protect slots for portray */
wglb.sl0 = (wglb.sl = Yap_InitHandle(t))-1; writeTerm(t, priority, 1, FALSE, &wglb, &rwt);
writeTerm__(t,wglb.sl, priority, 1, FALSE, &wglb, &rwt);
if (flags & New_Line_f) { if (flags & New_Line_f) {
if (flags & Fullstop_f) { if (flags & Fullstop_f) {
wrputc('.', wglb.stream); wrputc('.', wglb.stream);

6
pl/messages.yap
View File

@ -108,7 +108,8 @@ In YAP, the info field describes:
:- use_system_module( user, [message_hook/3]). :- use_system_module( user, [message_hook/3]).
%:- start_low_level_trace. %:- start_low_level_trace.
:- multifile prolog:message/3. :- dynamic prolog:message//1.
:- multifile prolog:message//1.
%:- stop_low_level_trace. %:- stop_low_level_trace.
:- multifile user:message_hook/3. :- multifile user:message_hook/3.
@ -374,7 +375,8 @@ display_consulting( F, Level, Info, LC) -->
'$error_descriptor'(Info, Desc), '$error_descriptor'(Info, Desc),
query_exception(prologParserFile, Desc, F0), query_exception(prologParserFile, Desc, F0),
query_exception(prologParserLine, Desc, L), query_exception(prologParserLine, Desc, L),
F \= F0 integer(L)
, F \= F0
}, !, }, !,
[ '~a:~d:0: ~a raised at:'-[F0,L,Level], nl ]. [ '~a:~d:0: ~a raised at:'-[F0,L,Level], nl ].
display_consulting( F, Level, _, LC) --> display_consulting( F, Level, _, LC) -->

7
pl/undefined.yap
View File

@ -97,7 +97,7 @@ undefined_query(G0, M0, Cut) :-
'$undefp'([M0|G0],MG) :- '$undefp'([M0|G0],MG) :-
% make sure we do not loop on undefined predicates % make sure we do not loop on undefined predicates
'$undef_setup'(M0:G0, Action,Debug,Current, MGI), '$undef_setup'(M0:G0, Action,Debug,Current, MGI),
('$get_undefined_predicates'(Current, MGI, MG ) , MG) ('$get_undefined_predicates'( MGI, MG ) , MG)
-> ->
true true
; ;
@ -119,10 +119,11 @@ undefined_query(G0, M0, Cut) :-
'$handle_error'(fail,_Goal,_Mod) :- '$handle_error'(fail,_Goal,_Mod) :-
fail. fail.
'$undef_setup'(Action,Debug,Current) :- '$undef_setup'(G0,Action,Debug,Current,GI) :-
yap_flag( unknown, Action, fail), yap_flag( unknown, Action, fail),
yap_flag( debug, Debug, false), yap_flag( debug, Debug, false),
'$stop_creeping'(Current). '$stop_creeping'(Current),
'$g2i'(G0,GI).
'$g2i'(user:G, Na/Ar ) :- '$g2i'(user:G, Na/Ar ) :-
!, !,