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

continue big commit

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@863 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2003-08-27 13:37:10 +00:00
parent 402d26796f
commit 17ecf0dc14
45 changed files with 2945 additions and 2483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
C/absmi.c
View File

@ -204,8 +204,6 @@ Yap_absmi(int inp)
} }
#endif /* USE_THREADED_CODE */ #endif /* USE_THREADED_CODE */
reset_absmi:
#if PUSH_REGS #if PUSH_REGS
old_regs = &Yap_REGS; old_regs = &Yap_REGS;
@ -233,6 +231,8 @@ Yap_absmi(int inp)
setregs(); setregs();
reset_absmi:
#if !S_IN_MEM #if !S_IN_MEM
CACHE_A1(); CACHE_A1();
#endif #endif
@ -287,19 +287,16 @@ Yap_absmi(int inp)
noheapleft: noheapleft:
CFREG = CalculateStackGap(); CFREG = CalculateStackGap();
saveregs(); saveregs();
#if PUSH_REGS
restore_absmi_regs(old_regs);
#endif
if (!Yap_growheap(FALSE, 0)) { if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, "YAP failed to grow heap: %s", Yap_ErrorMessage); Yap_Error(FATAL_ERROR, TermNil, "YAP failed to grow heap: %s", Yap_ErrorMessage);
setregs(); setregs();
FAIL(); FAIL();
} }
setregs();
goto reset_absmi; goto reset_absmi;
#if !OS_HANDLES_TR_OVERFLOW #if !OS_HANDLES_TR_OVERFLOW
notrailleft: notrailleft:
saveregs();
/* if we are within indexing code, the system may have to /* if we are within indexing code, the system may have to
* update a S */ * update a S */
#if SHADOW_S #if SHADOW_S
@ -314,15 +311,13 @@ Yap_absmi(int inp)
else { else {
ASP = YREG+E_CB; ASP = YREG+E_CB;
} }
#if PUSH_REGS
restore_absmi_regs(old_regs);
#endif
if(!Yap_growtrail (sizeof(CELL) * 16 * 1024L)) {
saveregs(); saveregs();
if(!Yap_growtrail (sizeof(CELL) * 16 * 1024L)) {
Yap_Error(SYSTEM_ERROR,TermNil,"YAP failed to reserve %ld bytes in growtrail",sizeof(CELL) * 16 * 1024L); Yap_Error(SYSTEM_ERROR,TermNil,"YAP failed to reserve %ld bytes in growtrail",sizeof(CELL) * 16 * 1024L);
setregs(); setregs();
FAIL(); FAIL();
} }
setregs();
goto reset_absmi; goto reset_absmi;
#endif /* OS_HANDLES_TR_OVERFLOW */ #endif /* OS_HANDLES_TR_OVERFLOW */

6
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: * * Last rev: *
* mods: * * mods: *
* comments: allocating space * * comments: allocating space *
* version:$Id: alloc.c,v 1.32 2003-03-20 15:10:13 vsc Exp $ * * version:$Id: alloc.c,v 1.33 2003-08-27 13:37:08 vsc Exp $ *
*************************************************************************/ *************************************************************************/
#ifdef SCCS #ifdef SCCS
static char SccsId[] = "%W% %G%"; static char SccsId[] = "%W% %G%";
@ -153,10 +153,10 @@ FreeBlock(BlockHeader *b)
sp = &(b->b_size) + (b->b_size & ~InUseFlag); sp = &(b->b_size) + (b->b_size & ~InUseFlag);
if (*sp != b->b_size) { if (*sp != b->b_size) {
#if !SHORT_INTS #if !SHORT_INTS
fprintf(Yap_stderr, "** sanity check failed in FreeBlock %p %x %x\n", fprintf(stderr, "** sanity check failed in FreeBlock %p %x %x\n",
b, b->b_size, Unsigned(*sp)); b, b->b_size, Unsigned(*sp));
#else #else
fprintf(Yap_stderr, "** sanity check failed in FreeBlock %p %lx %lx\n", fprintf(stderr, "**sanity check failed in FreeBlock %p %lx %lx\n",
b, b->b_size, *sp); b, b->b_size, *sp);
#endif #endif
return; return;

178
C/amasm.c
View File

@ -65,9 +65,8 @@ STATIC_PROTO(void a_r, (op_numbers));
STATIC_PROTO(void a_p, (op_numbers)); STATIC_PROTO(void a_p, (op_numbers));
STATIC_PROTO(void a_pl, (op_numbers,PredEntry *)); STATIC_PROTO(void a_pl, (op_numbers,PredEntry *));
STATIC_PROTO(void a_l, (op_numbers)); STATIC_PROTO(void a_l, (op_numbers));
STATIC_PROTO(void a_hx, (op_numbers)); STATIC_PROTO(void a_hx, (op_numbers, union clause_obj *, int));
STATIC_PROTO(void a_if, (op_numbers)); STATIC_PROTO(void a_if, (op_numbers, union clause_obj *, int));
STATIC_PROTO(void a_go, (op_numbers));
STATIC_PROTO(void a_cut, (void)); STATIC_PROTO(void a_cut, (void));
#ifdef YAPOR #ifdef YAPOR
STATIC_PROTO(void a_try, (op_numbers, CELL, CELL, int, int)); STATIC_PROTO(void a_try, (op_numbers, CELL, CELL, int, int));
@ -137,20 +136,6 @@ static int c_type;
static int clause_has_blobs; static int clause_has_blobs;
wamreg
Yap_regnotoreg(UInt regnbr)
{
#if PRECOMPUTE_REGADDRESS
return (wamreg)(XREGS + regnbr);
#else
#if MSHIFTOFFS
return regnbr;
#else
return CELLSIZE*regnbr;
#endif
#endif /* ALIGN_LONGS */
}
inline static yslot inline static yslot
emit_y(Ventry *ve) emit_y(Ventry *ve)
{ {
@ -339,14 +324,21 @@ Yap_opcode(op_numbers op)
return (opcode(op)); return (opcode(op));
} }
static void
add_clref(CELL clause_code)
{
if (pass_no) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(clause_code);
cl->ClRefCount++;
}
}
static void static void
a_cl(op_numbers opcode) a_cl(op_numbers opcode)
{ {
if (pass_no) { if (pass_no) {
LogUpdClause *cl = (LogUpdClause *)code_addr;
code_p->opc = emit_op(opcode); code_p->opc = emit_op(opcode);
code_p->u.l.l = code_addr; code_p->u.l.l = code_addr;
cl->u.ClVarChain = (yamop *)(Unsigned(code_addr) + label_offset[1]);
} }
GONEXT(l); GONEXT(l);
} }
@ -362,7 +354,7 @@ a_cle(op_numbers opcode)
code_p->u.EC.ClENV = 0; code_p->u.EC.ClENV = 0;
code_p->u.EC.ClRefs = 0; code_p->u.EC.ClRefs = 0;
code_p->u.EC.ClBase = code_addr; code_p->u.EC.ClBase = code_addr;
cl->u2.ClExt = code_p; cl->ClExt = code_p;
cl->ClFlags |= LogUpdRuleMask; cl->ClFlags |= LogUpdRuleMask;
} }
GONEXT(EC); GONEXT(EC);
@ -450,6 +442,19 @@ a_vv(op_numbers opcode, op_numbers opcodew)
GONEXT(oxx); GONEXT(oxx);
} }
inline static void
a_xxp(op_numbers opcode)
{
if (pass_no) {
PredEntry *ap = (PredEntry *)(cpc->rnd2);
code_p->opc = emit_op(opcode);
code_p->u.xxp.x = cpc->rnd1;
code_p->u.xxp.x1 = ap->ArityOfPE;
code_p->u.xxp.p = ap;
}
GONEXT(xxp);
}
inline static void inline static void
a_vr(op_numbers opcode) a_vr(op_numbers opcode)
{ {
@ -545,12 +550,9 @@ a_asf(opcode)
inline static void inline static void
a_pair(CELL *seq_ptr) a_pair(CELL *seq_ptr)
{ {
CELL *ptr = ((CELL *) (code_p));
code_p = (yamop *) (ptr + 2);
if (pass_no) { if (pass_no) {
ptr[0] = (CELL) emit_a(*seq_ptr); seq_ptr[0] = (CELL) emit_a(seq_ptr[0]);
ptr[1] = (CELL) emit_ilabel(seq_ptr[1]); seq_ptr[1] = (CELL) emit_ilabel(seq_ptr[1]);
} }
} }
@ -1098,52 +1100,78 @@ a_4sw_s(op_numbers opcode)
} }
static void static void
a_hx(op_numbers opcode) init_log_upd_table(LogUpdIndex *ic, union clause_obj *cl_u)
{
/* insert myself in the indexing code chain */
ic->SiblingIndex = cl_u->lui.ChildIndex;
ic->ChildIndex = NULL;
ic->ClRefCount = 0;
ic->ClUse = 0L;
ic->u.ParentIndex = (LogUpdIndex *)cl_u;
cl_u->lui.ChildIndex = ic;
cl_u->lui.ClRefCount++;
}
static void
init_static_table(StaticIndex *ic, union clause_obj *cl_u)
{
/* insert myself in the indexing code chain */
ic->SiblingIndex = cl_u->si.ChildIndex;
ic->ChildIndex = NULL;
cl_u->si.ChildIndex = ic;
}
static void
a_hx(op_numbers opcode, union clause_obj *cl_u, int log_update)
{ {
register CELL i, imax; register CELL i, imax;
register CELL *seq_ptr = cpc->arnds; register CELL *seq_ptr = (CELL *)cpc->rnd2;
imax = cpc->rnd1; imax = cpc->rnd1;
if (pass_no) { if (pass_no) {
code_p->opc = emit_op(opcode); code_p->opc = emit_op(opcode);
code_p->u.c.c = emit_c(imax); code_p->u.sl.s = emit_c(imax);
code_p->u.sl.l = emit_a(cpc->rnd2);
if (log_update) {
init_log_upd_table(ClauseCodeToLogUpdIndex(cpc->rnd2), cl_u);
} else {
init_static_table(ClauseCodeToStaticIndex(cpc->rnd2), cl_u);
} }
GONEXT(c); }
GONEXT(sl);
if (pass_no) {
for (i = 0; i < imax; i++) { for (i = 0; i < imax; i++) {
a_pair(seq_ptr); a_pair(seq_ptr);
seq_ptr += 2; seq_ptr += 2;
} }
}
} }
static void static void
a_if(op_numbers opcode) a_if(op_numbers opcode, union clause_obj *cl_u, int log_update)
{ {
register CELL i, imax; register CELL i, imax;
register CELL *seq_ptr = cpc->arnds + 1; register CELL *seq_ptr = (CELL *)cpc->rnd2;
imax = cpc->rnd1; imax = cpc->rnd1;
if (pass_no) { if (pass_no) {
code_p->opc = emit_op(opcode); code_p->opc = emit_op(opcode);
code_p->u.sl.s = emit_count(imax); code_p->u.sl.s = emit_count(imax);
code_p->u.sl.l = emit_ilabel(cpc->arnds[0]); code_p->u.sl.l = emit_a(cpc->rnd2);
if (log_update) {
init_log_upd_table(ClauseCodeToLogUpdIndex(cpc->rnd2), cl_u);
} else {
init_static_table(ClauseCodeToStaticIndex(cpc->rnd2), cl_u);
}
} }
GONEXT(sl); GONEXT(sl);
if (pass_no) {
for (i = 0; i < imax; i++) { for (i = 0; i < imax; i++) {
a_pair(seq_ptr); a_pair(seq_ptr);
seq_ptr += 2; seq_ptr += 2;
} }
} seq_ptr[1] = (CELL) emit_ilabel(seq_ptr[1]);
static void
a_go(op_numbers opcode)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.cll.c = emit_count(cpc->arnds[1]); /* tag */
code_p->u.cll.l1 = emit_ilabel(cpc->arnds[2]); /* success point */
code_p->u.cll.l2 = emit_ilabel(cpc->arnds[0]); /* fail point */
} }
GONEXT(cll);
} }
static void static void
@ -1983,12 +2011,16 @@ do_pass(void)
if (assembling != ASSEMBLING_INDEX) { if (assembling != ASSEMBLING_INDEX) {
if (log_update) { if (log_update) {
if (pass_no) { if (pass_no) {
cl_u->luc.Id = FunctorDBRef;
cl_u->luc.ClFlags = LogUpdMask; cl_u->luc.ClFlags = LogUpdMask;
cl_u->luc.Owner = Yap_ConsultingFile(); cl_u->luc.Owner = Yap_ConsultingFile();
cl_u->luc.ClRefCount = 0;
cl_u->luc.ClPred = CurrentPred;
if (clause_has_blobs) { if (clause_has_blobs) {
cl_u->luc.ClFlags |= HasBlobsMask; cl_u->luc.ClFlags |= HasBlobsMask;
} }
cl_u->luc.u2.ClExt = NULL; cl_u->luc.ClExt = NULL;
cl_u->luc.ClPrev = cl_u->luc.ClNext = NULL;
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
INIT_LOCK(cl_u.luc->ClLock); INIT_LOCK(cl_u.luc->ClLock);
INIT_CLREF_COUNT(cl_u.luc); INIT_CLREF_COUNT(cl_u.luc);
@ -1997,10 +2029,12 @@ do_pass(void)
code_p = cl_u->luc.ClCode; code_p = cl_u->luc.ClCode;
} else if (dynamic) { } else if (dynamic) {
if (pass_no) { if (pass_no) {
cl_u->ic.ClFlags = DynamicMask;
cl_u->ic.Owner = Yap_ConsultingFile(); cl_u->ic.Owner = Yap_ConsultingFile();
if (clause_has_blobs) { if (clause_has_blobs) {
cl_u->ic.ClFlags |= HasBlobsMask; cl_u->ic.ClFlags |= HasBlobsMask;
} }
cl_u->ic.ClRefCount = 0;
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
INIT_LOCK(cl_u.ic->ClLock); INIT_LOCK(cl_u.ic->ClLock);
INIT_CLREF_COUNT(cl_u.ic); INIT_CLREF_COUNT(cl_u.ic);
@ -2020,23 +2054,32 @@ do_pass(void)
} }
IPredArity = cpc->rnd2; /* number of args */ IPredArity = cpc->rnd2; /* number of args */
entry_code = code_p; entry_code = code_p;
if (!log_update) {
#ifdef YAPOR #ifdef YAPOR
a_try(TRYOP(_try_me, _try_me0), 0, IPredArity, 1, 0); a_try(TRYOP(_try_me, _try_me0), 0, IPredArity, 1, 0);
#else #else
a_try(TRYOP(_try_me, _try_me0), 0, IPredArity); a_try(TRYOP(_try_me, _try_me0), 0, IPredArity);
#endif /* YAPOR */ #endif /* YAPOR */
}
} else { } else {
/* index code */
if (log_update) { if (log_update) {
if (pass_no) { if (pass_no) {
cl_u->luc.ClFlags = LogUpdatePredFlag|IndexedPredFlag|IndexMask; cl_u->lui.ClFlags = LogUpdMask|IndexedPredFlag|IndexMask;
cl_u->luc.u2.ClUse = 0; cl_u->lui.ChildIndex = NULL;
cl_u->lui.SiblingIndex = NULL;
cl_u->lui.u.pred = CurrentPred;
cl_u->lui.ClUse = 0;
cl_u->lui.ClRefCount = 0;
} }
code_p = cl_u->luc.ClCode; code_p = cl_u->lui.ClCode;
} else { } else {
if (pass_no) { if (pass_no) {
cl_u->sc.ClFlags = IndexMask; cl_u->si.ClFlags = IndexMask;
cl_u->si.ChildIndex = NULL;
cl_u->si.SiblingIndex = NULL;
} }
code_p = cl_u->sc.ClCode; code_p = cl_u->si.ClCode;
} }
entry_code = code_p; entry_code = code_p;
} }
@ -2274,25 +2317,37 @@ do_pass(void)
a_deallocate(); a_deallocate();
break; break;
case tryme_op: case tryme_op:
if (log_update && assembling == ASSEMBLING_INDEX) {
a_cl(_try_logical_pred);
}
TRYCODE(_try_me, _try_me0); TRYCODE(_try_me, _try_me0);
break; break;
case retryme_op: case retryme_op:
TRYCODE(_retry_me, _retry_me0); TRYCODE(_retry_me, _retry_me0);
break; break;
case trustme_op: case trustme_op:
if (log_update && assembling == ASSEMBLING_INDEX) {
a_cl(_trust_logical_pred);
}
TRYCODE(_trust_me, _trust_me0); TRYCODE(_trust_me, _trust_me0);
break; break;
case try_op: case try_op:
if (log_update) if (log_update) {
a_cl(_try_logical_pred); a_cl(_try_logical_pred);
}
a_gl(_try_clause); a_gl(_try_clause);
break; break;
case retry_op: case retry_op:
if (log_update) {
add_clref(cpc->rnd1);
}
a_gl(_retry); a_gl(_retry);
break; break;
case trust_op: case trust_op:
if (log_update) if (log_update) {
add_clref(cpc->rnd1);
a_cl(_trust_logical_pred); a_cl(_trust_logical_pred);
}
a_gl(_trust); a_gl(_trust);
break; break;
case try_in_op: case try_in_op:
@ -2414,28 +2469,37 @@ do_pass(void)
a_4sw(_switch_on_type); a_4sw(_switch_on_type);
break; break;
case switch_c_op: case switch_c_op:
a_hx(_switch_on_cons); a_hx(_switch_on_cons, cl_u, log_update);
break; break;
case switch_f_op: case switch_f_op:
a_hx(_switch_on_func); a_hx(_switch_on_func, cl_u, log_update);
break; break;
case if_c_op: case if_c_op:
if (cpc->rnd1 == 1) { if (cpc->rnd1 == 1) {
a_go(_go_on_cons); a_if(_go_on_cons, cl_u, log_update);
} else { } else {
a_if(_if_cons); a_if(_if_cons, cl_u, log_update);
} }
break; break;
case if_f_op: case if_f_op:
if (cpc->rnd1 == 1) { if (cpc->rnd1 == 1) {
a_go(_go_on_func); a_if(_go_on_func, cl_u, log_update);
} else { } else {
a_if(_if_func); a_if(_if_func, cl_u, log_update);
} }
break; break;
case if_not_op: case if_not_op:
a_ifnot(_if_not_then); a_ifnot(_if_not_then);
break; break;
case index_dbref_op:
a_e(_index_dbref);
break;
case index_blob_op:
a_e(_index_blob);
break;
case check_var_op:
a_xxp(_check_var_for_index);
break;
case mark_initialised_pvars_op: case mark_initialised_pvars_op:
a_bmap(); a_bmap();
break; break;

8
C/arrays.c
View File

@ -254,7 +254,7 @@ AccessNamedArray(Atom a, Int indx)
case array_of_terms: case array_of_terms:
{ {
/* The object is now in use */ /* The object is now in use */
DBRef ref = ptr->ValueOfVE.terms[indx]; DBTerm *ref = ptr->ValueOfVE.terms[indx];
Term TRef; Term TRef;
READ_UNLOCK(ptr->ArRWLock); READ_UNLOCK(ptr->ArRWLock);
@ -1553,12 +1553,12 @@ p_assign_static(void)
case array_of_terms: case array_of_terms:
{ {
DBRef ref = ptr->ValueOfVE.terms[indx]; DBTerm *ref = ptr->ValueOfVE.terms[indx];
if (ref != NULL) { if (ref != NULL) {
Yap_ReleaseTermFromDB(ref); Yap_ReleaseTermFromDB(ref);
} }
ptr->ValueOfVE.terms[indx] = Yap_StoreTermInDB(3,3); ptr->ValueOfVE.terms[indx] = Yap_StoreTermInDB(Deref(ARG3),3);
if (ptr->ValueOfVE.terms[indx] == NULL){ if (ptr->ValueOfVE.terms[indx] == NULL){
WRITE_UNLOCK(ptr->ArRWLock); WRITE_UNLOCK(ptr->ArRWLock);
return(FALSE); return(FALSE);
@ -1913,7 +1913,7 @@ p_static_array_to_term(void)
H += dim; H += dim;
for (indx=0; indx < dim; indx++) { for (indx=0; indx < dim; indx++) {
/* The object is now in use */ /* The object is now in use */
DBRef ref = pp->ValueOfVE.terms[indx]; DBTerm *ref = pp->ValueOfVE.terms[indx];
Term TRef; Term TRef;
if (ref != NULL) { if (ref != NULL) {

4
C/bb.c
View File

@ -257,7 +257,7 @@ p_bb_put(void)
if (p->Element != NULL) { if (p->Element != NULL) {
Yap_ReleaseTermFromDB(p->Element); Yap_ReleaseTermFromDB(p->Element);
} }
p->Element = Yap_StoreTermInDB(2,2); p->Element = Yap_StoreTermInDB(Deref(ARG2),2);
WRITE_UNLOCK(p->BBRWLock); WRITE_UNLOCK(p->BBRWLock);
return(p->Element != NULL); return(p->Element != NULL);
} }
@ -312,7 +312,7 @@ p_bb_update(void)
} }
Yap_ReleaseTermFromDB(p->Element); Yap_ReleaseTermFromDB(p->Element);
p->Element = Yap_StoreTermInDB(3,3); p->Element = Yap_StoreTermInDB(Deref(ARG3),3);
WRITE_UNLOCK(p->BBRWLock); WRITE_UNLOCK(p->BBRWLock);
return(p->Element != NULL); return(p->Element != NULL);
} }

951
C/cdmgr.c
View File

File diff suppressed because it is too large Load Diff

24
C/computils.c
View File

@ -455,17 +455,18 @@ ShowOp (char *f)
case 'c': case 'c':
{ {
int i; int i;
CELL *ptr = (CELL *)cptr[0];
for (i = 0; i < arg; ++i) { for (i = 0; i < arg; ++i) {
CELL my_arg; CELL my_arg;
Yap_DebugPutc(Yap_c_error_stream,'\t'); Yap_DebugPutc(Yap_c_error_stream,'\t');
if (*cptr) { if (*ptr) {
Yap_plwrite ((Term) * cptr++, Yap_DebugPutc, 0); Yap_plwrite ((Term) *ptr++, Yap_DebugPutc, 0);
} else { } else {
Yap_plwrite (MkIntTerm (0), Yap_DebugPutc, 0); Yap_plwrite (MkIntTerm (0), Yap_DebugPutc, 0);
cptr++; ptr++;
} }
Yap_DebugPutc (Yap_c_error_stream,'\t'); Yap_DebugPutc (Yap_c_error_stream,'\t');
my_arg = *cptr++; my_arg = *ptr++;
write_address (my_arg); write_address (my_arg);
if (i+1 < arg) if (i+1 < arg)
Yap_DebugPutc (Yap_c_error_stream,'\n'); Yap_DebugPutc (Yap_c_error_stream,'\n');
@ -475,8 +476,9 @@ ShowOp (char *f)
case 'e': case 'e':
{ {
int i; int i;
CELL *ptr = (CELL *)cptr[0];
for (i = 0; i < arg; ++i) { for (i = 0; i < arg; ++i) {
CELL my_arg = cptr[0], lbl = cptr[1]; CELL my_arg = ptr[0], lbl = ptr[1];
Yap_DebugPutc(Yap_c_error_stream,'\t'); Yap_DebugPutc(Yap_c_error_stream,'\t');
if (my_arg) { if (my_arg) {
write_functor((Functor)my_arg); write_functor((Functor)my_arg);
@ -485,7 +487,7 @@ ShowOp (char *f)
} }
Yap_DebugPutc(Yap_c_error_stream,'\t'); Yap_DebugPutc(Yap_c_error_stream,'\t');
write_address(lbl); write_address(lbl);
cptr += 2; ptr += 2;
if (i+1 < arg) if (i+1 < arg)
Yap_DebugPutc(Yap_c_error_stream,'\n'); Yap_DebugPutc(Yap_c_error_stream,'\n');
} }
@ -577,10 +579,13 @@ static char *opformat[] =
"cache_sub_arg\t%d", "cache_sub_arg\t%d",
"switch_on_type\t%h\t%h\t%h\t%h", "switch_on_type\t%h\t%h\t%h\t%h",
"switch_on_constant\t%i\n%c", "switch_on_constant\t%i\n%c",
"if_constant\t%i\t%h\n%c", "if_constant\t%i\n%c",
"switch_on_functor\t%i\n%e", "switch_on_functor\t%i\n%e",
"if_functor\t%i\t%h\n%e", "if_functor\t%i\n%e",
"if_not_then\t%i\t%h\t%h\t%h", "if_not_then\t%i\t%h\t%h\t%h",
"index_on_dbref",
"index_on_blob",
"check_var\t %r",
"save_pair\t%v", "save_pair\t%v",
"save_appl\t%v", "save_appl\t%v",
"fail_label\t%l", "fail_label\t%l",
@ -655,8 +660,9 @@ Yap_ShowCode ()
arg = cpc->rnd1; arg = cpc->rnd1;
rn = cpc->rnd2; rn = cpc->rnd2;
cptr = cpc->arnds; cptr = cpc->arnds;
if (ic != nop_op) if (ic != nop_op) {
ShowOp (opformat[ic]); ShowOp (opformat[ic]);
}
cpc = cpc->nextInst; cpc = cpc->nextInst;
} }
Yap_DebugPutc (Yap_c_error_stream,'\n'); Yap_DebugPutc (Yap_c_error_stream,'\n');

1675
C/dbase.c
View File

File diff suppressed because it is too large Load Diff

14
C/exec.c
View File

@ -58,7 +58,7 @@ CallPredicate(PredEntry *pen, choiceptr cut_pt) {
low_level_trace(enter_pred,pen,XREGS+1); low_level_trace(enter_pred,pen,XREGS+1);
#endif /* LOW_LEVEL_TRACE */ #endif /* LOW_LEVEL_TRACE */
CP = P; CP = P;
P = (yamop *)(pen->CodeOfPred); P = pen->CodeOfPred;
/* vsc: increment reduction counter at meta-call entry */ /* vsc: increment reduction counter at meta-call entry */
WRITE_UNLOCK(pen->PRWLock); WRITE_UNLOCK(pen->PRWLock);
if (pen->PredFlags & ProfiledPredFlag) { if (pen->PredFlags & ProfiledPredFlag) {
@ -170,6 +170,13 @@ CallClause(PredEntry *pen, Int position)
P = CLAUSECODE->clause; P = CLAUSECODE->clause;
WRITE_UNLOCK(pen->PRWLock); WRITE_UNLOCK(pen->PRWLock);
return((CELL)(&(CLAUSECODE->clause))); return((CELL)(&(CLAUSECODE->clause)));
} else if (flags & LogUpdatePredFlag) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(q);
for (; position > 1; position--)
cl = cl->ClNext;
P = cl->ClCode;
WRITE_UNLOCK(pen->PRWLock);
return (Unsigned(pen));
} else { } else {
for (; position > 1; position--) for (; position > 1; position--)
q = NextClause(q); q = NextClause(q);
@ -205,8 +212,7 @@ p_save_cp(void)
static Int static Int
EnterCreepMode(SMALLUNSGN mod) { EnterCreepMode(SMALLUNSGN mod) {
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,1)); PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,1));
Term tn = Yap_MkApplTerm(Yap_MkFunctor(AtomMetaCall,1),1,&ARG1); ARG1 = MkPairTerm(ModuleName[mod],ARG1);
ARG1 = MkPairTerm(ModuleName[mod],tn);
CreepFlag = CalculateStackGap(); CreepFlag = CalculateStackGap();
P_before_spy = P; P_before_spy = P;
return (CallPredicate(PredSpy, B)); return (CallPredicate(PredSpy, B));
@ -215,7 +221,7 @@ EnterCreepMode(SMALLUNSGN mod) {
inline static Int inline static Int
do_execute(Term t, SMALLUNSGN mod) do_execute(Term t, SMALLUNSGN mod)
{ {
if (yap_flags[SPY_CREEP_FLAG]) { if (CreepFlag == (CELL)(LCL0+2)) {
return(EnterCreepMode(mod)); return(EnterCreepMode(mod));
} else if (PRED_GOAL_EXPANSION_ON) { } else if (PRED_GOAL_EXPANSION_ON) {
return(CallMetaCall(mod)); return(CallMetaCall(mod));

4
C/heapgc.c
View File

@ -1560,9 +1560,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
} }
case _retry_c: case _retry_c:
case _retry_userc: case _retry_userc:
if (gc_B->cp_ap == RETRY_C_RECORDED_CODE if (gc_B->cp_ap == RETRY_C_RECORDED_K_CODE
|| gc_B->cp_ap == RETRY_C_RECORDED_K_CODE
|| gc_B->cp_ap == RETRY_C_DRECORDED_CODE
|| gc_B->cp_ap == RETRY_C_RECORDEDP_CODE) { || gc_B->cp_ap == RETRY_C_RECORDEDP_CODE) {
/* we have a reference from the choice-point stack to a term */ /* we have a reference from the choice-point stack to a term */
choiceptr old_b = B; choiceptr old_b = B;

9
C/init.c
View File

@ -709,6 +709,7 @@ InitCodes(void)
INIT_YAMOP_LTT(&(heap_regs->tableanswerresolutioncode), 0); INIT_YAMOP_LTT(&(heap_regs->tableanswerresolutioncode), 0);
#endif /* YAPOR */ #endif /* YAPOR */
#endif /* TABLING */ #endif /* TABLING */
heap_regs->expand_op_code = Yap_opcode(_expand_index);
heap_regs->failcode->opc = Yap_opcode(_op_fail); heap_regs->failcode->opc = Yap_opcode(_op_fail);
heap_regs->failcode_1 = Yap_opcode(_op_fail); heap_regs->failcode_1 = Yap_opcode(_op_fail);
heap_regs->failcode_2 = Yap_opcode(_op_fail); heap_regs->failcode_2 = Yap_opcode(_op_fail);
@ -763,7 +764,7 @@ InitCodes(void)
heap_regs->system_profiling = FALSE; heap_regs->system_profiling = FALSE;
heap_regs->system_call_counting = FALSE; heap_regs->system_call_counting = FALSE;
heap_regs->system_pred_goal_expansion_on = FALSE; heap_regs->system_pred_goal_expansion_on = FALSE;
heap_regs->update_mode = 0; heap_regs->update_mode = UPDATE_MODE_LOGICAL;
heap_regs->consultbase = heap_regs->consultsp = heap_regs->consultbase = heap_regs->consultsp =
heap_regs->consultlow + heap_regs->consultcapacity; heap_regs->consultlow + heap_regs->consultcapacity;
heap_regs->compiler_compile_mode = 1; heap_regs->compiler_compile_mode = 1;
@ -961,6 +962,10 @@ InitCodes(void)
RepPredProp(PredPropByAtom(heap_regs->atom_true,0)); RepPredProp(PredPropByAtom(heap_regs->atom_true,0));
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(Yap_MkFunctor(heap_regs->atom_meta_call,4),0)); heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(Yap_MkFunctor(heap_regs->atom_meta_call,4),0));
heap_regs->pred_dollar_catch = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$catch"),3),0)); heap_regs->pred_dollar_catch = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$catch"),3),0));
heap_regs->pred_recorded_with_key = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$recorded_with_key"),3),0));
heap_regs->pred_log_upd_clause = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$do_log_upd_clause"),5),0));
heap_regs->pred_log_upd_clause0 = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$do_log_upd_clause"),4),0));
heap_regs->pred_log_upd_retract = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$do_log_upd_retract"),4),0));
heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,0)); heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,0));
heap_regs->pred_handle_throw = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$handle_throw"),3),0)); heap_regs->pred_handle_throw = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("$handle_throw"),3),0));
heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("goal_expansion"),3),1)); heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_LookupAtom("goal_expansion"),3),1));
@ -981,7 +986,7 @@ InitCodes(void)
heap_regs->db_erased_marker->id = FunctorDBRef; heap_regs->db_erased_marker->id = FunctorDBRef;
heap_regs->db_erased_marker->Flags = ErasedMask; heap_regs->db_erased_marker->Flags = ErasedMask;
heap_regs->db_erased_marker->Code = NULL; heap_regs->db_erased_marker->Code = NULL;
heap_regs->db_erased_marker->DBRefs = NULL; heap_regs->db_erased_marker->DBT.DBRefs = NULL;
heap_regs->db_erased_marker->Parent = NULL; heap_regs->db_erased_marker->Parent = NULL;
INIT_LOCK(heap_regs->db_erased_marker->lock); INIT_LOCK(heap_regs->db_erased_marker->lock);
INIT_DBREF_COUNT(heap_regs->db_erased_marker); INIT_DBREF_COUNT(heap_regs->db_erased_marker);

2
C/mavar.c
View File

@ -71,7 +71,7 @@ p_setarg(void)
MaBind(pt, Deref(ARG3)); MaBind(pt, Deref(ARG3));
} else if(IsPairTerm(ts)) { } else if(IsPairTerm(ts)) {
CELL *pt; CELL *pt;
if (i != 1 || i != 2) { if (i < 1 || i > 2) {
if (i<0) if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3"); Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return(FALSE); return(FALSE);

4
C/modules.c
View File

@ -140,7 +140,9 @@ Yap_InitModules(void)
MkAtomTerm(Yap_LookupAtom("prolog")); MkAtomTerm(Yap_LookupAtom("prolog"));
ModuleName[1] = ModuleName[1] =
MkAtomTerm(Yap_LookupAtom("user")); MkAtomTerm(Yap_LookupAtom("user"));
NoOfModules = 2; ModuleName[2] =
MkAtomTerm(Yap_LookupAtom("idb"));
NoOfModules = 3;
CurrentModule = 0; CurrentModule = 0;
Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag); Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag); Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);

12
C/save.c
View File

@ -906,7 +906,7 @@ static void
recompute_mask(DBRef dbr) recompute_mask(DBRef dbr)
{ {
if (dbr->Flags & DBNoVars) { if (dbr->Flags & DBNoVars) {
dbr->Mask = Yap_EvalMasks((Term) dbr->Entry, &(dbr->Key)); dbr->Mask = Yap_EvalMasks((Term) dbr->DBT.Entry, &(dbr->Key));
} else if (dbr->Flags & DBComplex) { } else if (dbr->Flags & DBComplex) {
/* This is quite nasty, we want to recalculate the mask but /* This is quite nasty, we want to recalculate the mask but
we don't want to rebuild the whole term. We'll just build whatever we we don't want to rebuild the whole term. We'll just build whatever we
@ -915,17 +915,17 @@ recompute_mask(DBRef dbr)
CELL *x = (CELL *)HeapTop, *tp; CELL *x = (CELL *)HeapTop, *tp;
unsigned int Arity, i; unsigned int Arity, i;
Term out; Term out;
char *tbase = CharP(dbr->Contents-1); char *tbase = CharP(dbr->DBT.Contents-1);
if (IsPairTerm(dbr->Entry)) { if (IsPairTerm(dbr->DBT.Entry)) {
out = AbsPair(x); out = AbsPair(x);
Arity = 2; Arity = 2;
tp = (CELL *)(tbase + (CELL) RepPair(dbr->Entry)); tp = (CELL *)(tbase + (CELL) RepPair(dbr->DBT.Entry));
} else { } else {
Functor f; Functor f;
tp = (CELL *)(tbase + (CELL) RepAppl(dbr->Entry)); tp = (CELL *)(tbase + (CELL) RepAppl(dbr->DBT.Entry));
f = (Functor)(*tp++); f = (Functor)(*tp++);
out = AbsAppl(x); out = AbsAppl(x);
Arity = ArityOfFunctor(f); Arity = ArityOfFunctor(f);
@ -940,7 +940,7 @@ recompute_mask(DBRef dbr)
/* just fetch the functor from where it is in the data-base. /* just fetch the functor from where it is in the data-base.
This guarantees we have access to references and friends. */ This guarantees we have access to references and friends. */
CELL offset = (CELL)RepAppl(tw); CELL offset = (CELL)RepAppl(tw);
if (offset > dbr->NOfCells*sizeof(CELL)) if (offset > dbr->DBT.NOfCells*sizeof(CELL))
*x = tw; *x = tw;
else else
*x = AbsAppl((CELL *)(tbase + offset)); *x = AbsAppl((CELL *)(tbase + offset));

18
C/stdpreds.c
View File

@ -411,11 +411,20 @@ p_creep(void)
Atom at; Atom at;
PredEntry *pred; PredEntry *pred;
yap_flags[SPY_CREEP_FLAG] = TRUE;
at = Yap_FullLookupAtom("$creep"); at = Yap_FullLookupAtom("$creep");
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0)); pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
CreepCode = pred; CreepCode = pred;
CreepFlag = Unsigned(LCL0)-Unsigned(H0); CreepFlag = Unsigned(LCL0+2);
return (TRUE); FlipFlop = 0;
return TRUE;
}
static Int
p_stop_creep(void)
{
CreepFlag = CalculateStackGap();
return TRUE;
} }
Int Int
@ -2507,8 +2516,8 @@ void
Yap_InitCPreds(void) Yap_InitCPreds(void)
{ {
/* numerical comparison */ /* numerical comparison */
Yap_InitCPred("$set_value", 2, p_setval, SafePredFlag|SyncPredFlag); Yap_InitCPred("set_value", 2, p_setval, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$get_value", 2, p_value, TestPredFlag|SafePredFlag|SyncPredFlag); Yap_InitCPred("get_value", 2, p_value, TestPredFlag|SafePredFlag|SyncPredFlag);
Yap_InitCPred("$values", 3, p_values, SafePredFlag|SyncPredFlag); Yap_InitCPred("$values", 3, p_values, SafePredFlag|SyncPredFlag);
/* The flip-flop */ /* The flip-flop */
Yap_InitCPred("$flipflop", 0, p_flipflop, SafePredFlag|SyncPredFlag); Yap_InitCPred("$flipflop", 0, p_flipflop, SafePredFlag|SyncPredFlag);
@ -2547,6 +2556,7 @@ Yap_InitCPreds(void)
/* they are defined in analyst.c */ /* they are defined in analyst.c */
/* Basic predicates for the debugger */ /* Basic predicates for the debugger */
Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag); Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$stop_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag);
#ifdef DEBUG #ifdef DEBUG
Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag); Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag);
#endif #endif

32
C/tracer.c
View File

@ -102,6 +102,8 @@ check_trail_consistency(void) {
*/ */
static int vsc_xstop = FALSE;
void void
low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
{ {
@ -112,12 +114,24 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
vsc_count++; vsc_count++;
#ifdef COMMENTED #ifdef COMMENTED
if (vsc_count < 130000) return; if (vsc_count < 5530257LL) {
return; return;
if (vsc_count == 133000LL) { }
if (vsc_count == 41597LL) {
vsc_xstop = TRUE;
}
if (vsc_count < 3399741LL) {
return;
}
if (vsc_count == 51021) {
printf("Here I go\n");
}
if (vsc_count < 52000) return;
if (vsc_count > 52000) exit(0);
return;
if (vsc_count == 837074) {
printf("Here I go\n"); printf("Here I go\n");
} }
if (vsc_count > 500000) exit(0);
if (gc_calls < 1) return; if (gc_calls < 1) return;
#endif #endif
#if defined(__GNUC__) #if defined(__GNUC__)
@ -184,15 +198,17 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
} }
break; break;
case retry_pred: case retry_pred:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
mname = RepAtom(AtomOfTerm(Yap_Module_Name((CODEADDR)pred)))->StrOfAE; mname = RepAtom(AtomOfTerm(Yap_Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE; arity = pred->ArityOfPE;
if (arity == 0) if (pred->ModuleOfPred == 2) {
s = "recorded";
arity = 3;
} else if (arity == 0) {
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE; s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else } else {
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE; s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$')) }
return; */
send_tracer_message("FAIL ", NULL, 0, NULL, args);
send_tracer_message("RETRY: ", s, arity, mname, args); send_tracer_message("RETRY: ", s, arity, mname, args);
break; break;
} }

23
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h * * File: Heap.h *
* mods: * * mods: *
* comments: Heap Init Structure * * comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.43 2003-06-06 11:54:01 vsc Exp $ * * version: $Id: Heap.h,v 1.44 2003-08-27 13:37:09 vsc Exp $ *
*************************************************************************/ *************************************************************************/
/* information that can be stored in Code Space */ /* information that can be stored in Code Space */
@ -57,6 +57,7 @@ typedef struct various_codes {
yamop tablecompletioncode; yamop tablecompletioncode;
yamop tableanswerresolutioncode; yamop tableanswerresolutioncode;
#endif /* TABLING */ #endif /* TABLING */
OPCODE expand_op_code;
yamop comma_code[5]; yamop comma_code[5];
yamop failcode[1]; yamop failcode[1];
OPCODE failcode_1; OPCODE failcode_1;
@ -135,14 +136,15 @@ typedef struct various_codes {
OPCODE undef_op; OPCODE undef_op;
OPCODE index_op; OPCODE index_op;
OPCODE fail_op; OPCODE fail_op;
yamop *retry_recorded_code, yamop *retry_recorded_k_code,
*retry_recorded_k_code,
*retry_drecorded_code,
*retry_c_recordedp_code; *retry_c_recordedp_code;
Int static_predicates_marked; Int static_predicates_marked;
UInt int_keys_size; UInt int_keys_size;
UInt int_keys_timestamp; UInt int_keys_timestamp;
Prop *IntKeys; Prop *IntKeys;
UInt int_lu_keys_size;
UInt int_lu_keys_timestamp;
Prop *IntLUKeys;
UInt int_bb_keys_size; UInt int_bb_keys_size;
Prop *IntBBKeys; Prop *IntBBKeys;
Int yap_flags_field[NUMBER_OF_YAP_FLAGS]; Int yap_flags_field[NUMBER_OF_YAP_FLAGS];
@ -288,6 +290,10 @@ typedef struct various_codes {
struct pred_entry *pred_goal_expansion; struct pred_entry *pred_goal_expansion;
struct pred_entry *pred_meta_call; struct pred_entry *pred_meta_call;
struct pred_entry *pred_dollar_catch; struct pred_entry *pred_dollar_catch;
struct pred_entry *pred_recorded_with_key;
struct pred_entry *pred_log_upd_clause;
struct pred_entry *pred_log_upd_clause0;
struct pred_entry *pred_log_upd_retract;
struct pred_entry *pred_throw; struct pred_entry *pred_throw;
struct pred_entry *pred_handle_throw; struct pred_entry *pred_handle_throw;
struct array_entry *dyn_array_list; struct array_entry *dyn_array_list;
@ -353,6 +359,7 @@ typedef struct various_codes {
#define COMPLETION ((yamop *)&(heap_regs->tablecompletioncode )) #define COMPLETION ((yamop *)&(heap_regs->tablecompletioncode ))
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode )) #define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */ #endif /* TABLING */
#define EXPAND_OP_CODE heap_regs->expand_op_code
#define COMMA_CODE heap_regs->comma_code #define COMMA_CODE heap_regs->comma_code
#define FAILCODE heap_regs->failcode #define FAILCODE heap_regs->failcode
#define TRUSTFAILCODE heap_regs->trustfailcode #define TRUSTFAILCODE heap_regs->trustfailcode
@ -375,7 +382,6 @@ typedef struct various_codes {
#define UPDATE_MODE heap_regs->update_mode #define UPDATE_MODE heap_regs->update_mode
#define RETRY_C_RECORDED_CODE heap_regs->retry_recorded_code #define RETRY_C_RECORDED_CODE heap_regs->retry_recorded_code
#define RETRY_C_RECORDED_K_CODE heap_regs->retry_recorded_k_code #define RETRY_C_RECORDED_K_CODE heap_regs->retry_recorded_k_code
#define RETRY_C_DRECORDED_CODE heap_regs->retry_drecorded_code
#define RETRY_C_RECORDEDP_CODE heap_regs->retry_c_recordedp_code #define RETRY_C_RECORDEDP_CODE heap_regs->retry_c_recordedp_code
#define STATIC_PREDICATES_MARKED heap_regs->static_predicates_marked #define STATIC_PREDICATES_MARKED heap_regs->static_predicates_marked
#define yap_flags heap_regs->yap_flags_field #define yap_flags heap_regs->yap_flags_field
@ -386,6 +392,9 @@ typedef struct various_codes {
#define INT_KEYS_SIZE heap_regs->int_keys_size #define INT_KEYS_SIZE heap_regs->int_keys_size
#define INT_KEYS_TIMESTAMP heap_regs->int_keys_timestamp #define INT_KEYS_TIMESTAMP heap_regs->int_keys_timestamp
#define INT_KEYS heap_regs->IntKeys #define INT_KEYS heap_regs->IntKeys
#define INT_LU_KEYS_SIZE heap_regs->int_lu_keys_size
#define INT_LU_KEYS_TIMESTAMP heap_regs->int_lu_keys_timestamp
#define INT_LU_KEYS heap_regs->IntLUKeys
#define INT_BB_KEYS_SIZE heap_regs->int_bb_keys_size #define INT_BB_KEYS_SIZE heap_regs->int_bb_keys_size
#define INT_BB_KEYS heap_regs->IntBBKeys #define INT_BB_KEYS heap_regs->IntBBKeys
#define CharConversionTable heap_regs->char_conversion_table #define CharConversionTable heap_regs->char_conversion_table
@ -513,6 +522,10 @@ typedef struct various_codes {
#define PredGoalExpansion heap_regs->pred_goal_expansion #define PredGoalExpansion heap_regs->pred_goal_expansion
#define PredMetaCall heap_regs->pred_meta_call #define PredMetaCall heap_regs->pred_meta_call
#define PredDollarCatch heap_regs->pred_dollar_catch #define PredDollarCatch heap_regs->pred_dollar_catch
#define PredRecordedWithKey heap_regs->pred_recorded_with_key
#define PredLogUpdClause heap_regs->pred_log_upd_clause
#define PredLogUpdClause0 heap_regs->pred_log_upd_clause0
#define PredLogUpdRetract heap_regs->pred_log_upd_retract
#define PredThrow heap_regs->pred_throw #define PredThrow heap_regs->pred_throw
#define PredHandleThrow heap_regs->pred_handle_throw #define PredHandleThrow heap_regs->pred_handle_throw
#define DynArrayList heap_regs->dyn_array_list #define DynArrayList heap_regs->dyn_array_list

6
H/YapOpcodes.h
View File

@ -155,8 +155,12 @@
OPCODE(go_on_func ,fll), OPCODE(go_on_func ,fll),
OPCODE(if_func ,sl), OPCODE(if_func ,sl),
OPCODE(if_not_then ,cll), OPCODE(if_not_then ,cll),
OPCODE(index_dbref ,e),
OPCODE(index_blob ,e),
OPCODE(check_var_for_index ,xxp),
OPCODE(trust_fail ,e), OPCODE(trust_fail ,e),
OPCODE(index_pred ,e), OPCODE(index_pred ,e),
OPCODE(expand_index ,e),
OPCODE(save_b_x ,x), OPCODE(save_b_x ,x),
OPCODE(save_b_y ,y), OPCODE(save_b_y ,y),
OPCODE(comit_b_x ,x), OPCODE(comit_b_x ,x),
@ -248,6 +252,8 @@
OPCODE(try_logical_pred ,l), OPCODE(try_logical_pred ,l),
OPCODE(trust_logical_pred ,l), OPCODE(trust_logical_pred ,l),
OPCODE(alloc_for_logical_pred ,EC), OPCODE(alloc_for_logical_pred ,EC),
OPCODE(unify_idb_term ,e),
OPCODE(copy_idb_term ,e),
#ifdef SFUNC #ifdef SFUNC
OPCODE(get_s_f ,), OPCODE(get_s_f ,),
OPCODE(put_s_f ,), OPCODE(put_s_f ,),

4
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto * * File: Yap.proto *
* mods: * * mods: *
* comments: Function declarations for YAP * * comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.37 2003-06-06 11:54:02 vsc Exp $ * * version: $Id: Yapproto.h,v 1.38 2003-08-27 13:37:09 vsc Exp $ *
*************************************************************************/ *************************************************************************/
/* prototype file for Yap */ /* prototype file for Yap */
@ -55,6 +55,8 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term));
Prop STD_PROTO(Yap_GetPredPropByAtom,(Atom, SMALLUNSGN)); Prop STD_PROTO(Yap_GetPredPropByAtom,(Atom, SMALLUNSGN));
Prop STD_PROTO(Yap_GetPredPropByFunc,(Functor, SMALLUNSGN)); Prop STD_PROTO(Yap_GetPredPropByFunc,(Functor, SMALLUNSGN));
Prop STD_PROTO(Yap_GetPredPropByAtomInThisModule,(Atom, SMALLUNSGN));
Prop STD_PROTO(Yap_GetPredPropByFuncInThisModule,(Functor, SMALLUNSGN));
Prop STD_PROTO(Yap_GetPredPropHavingLock,(Atom,unsigned int,SMALLUNSGN)); Prop STD_PROTO(Yap_GetPredPropHavingLock,(Atom,unsigned int,SMALLUNSGN));
Prop STD_PROTO(Yap_GetExpProp,(Atom,unsigned int)); Prop STD_PROTO(Yap_GetExpProp,(Atom,unsigned int));
Prop STD_PROTO(Yap_GetExpPropHavingLock,(AtomEntry *,unsigned int)); Prop STD_PROTO(Yap_GetExpPropHavingLock,(AtomEntry *,unsigned int));

51
H/absmi.h
View File

@ -533,6 +533,7 @@ typedef CELL label;
#define pred_entry(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->StateOfPred)))) #define pred_entry(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->StateOfPred))))
#define pred_entry_from_code(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->CodeOfPred)))) #define pred_entry_from_code(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->CodeOfPred))))
#define PredFromDefCode(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->OpcodeOfPred)))) #define PredFromDefCode(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->OpcodeOfPred))))
#define PredFromExpandCode(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->cs.p_code.ExpandCode))))
#define PredCode(X) pred_entry(X)->CodeOfPred #define PredCode(X) pred_entry(X)->CodeOfPred
#define PredOpCode(X) pred_entry(X)->OpcodeOfPred #define PredOpCode(X) pred_entry(X)->OpcodeOfPred
#define TruePredCode(X) pred_entry(X)->TrueCodeOfPred #define TruePredCode(X) pred_entry(X)->TrueCodeOfPred
@ -676,11 +677,11 @@ Macros to check the limits of stacks
#if OS_HANDLES_TR_OVERFLOW #if OS_HANDLES_TR_OVERFLOW
#define check_trail() #define check_trail(x)
#else #else
#define check_trail() if (Unsigned(Yap_TrailTop) - Unsigned(TR) < MinTrailGap) \ #define check_trail(x) if (Unsigned(Yap_TrailTop) - Unsigned(x) < MinTrailGap) \
goto notrailleft goto notrailleft
#endif #endif
@ -1138,10 +1139,10 @@ trim_trail(choiceptr b, tr_fr_ptr tr, CELL *hbreg)
DO_TRAIL(d1, TrailVal(pt0)); DO_TRAIL(d1, TrailVal(pt0));
} }
pt0++; pt0++;
}
ENDD(d1); ENDD(d1);
}
ENDD(d0); ENDD(d0);
}
}
return(TR); return(TR);
} }
#endif /* FROZEN_STACKS */ #endif /* FROZEN_STACKS */
@ -1496,3 +1497,45 @@ loop:
} }
#endif #endif
static inline wamreg
Yap_regnotoreg(UInt regnbr)
{
#if PRECOMPUTE_REGADDRESS
return (wamreg)(XREGS + regnbr);
#else
#if MSHIFTOFFS
return regnbr;
#else
return CELLSIZE*regnbr;
#endif
#endif /* ALIGN_LONGS */
}
static inline UInt
Yap_regtoregno(wamreg reg)
{
#if PRECOMPUTE_REGADDRESS
return ((CELL *)reg)-XREGS;
#else
#if MSHIFTOFFS
return reg;
#else
return reg/CELLSIZE;
#endif
#endif /* ALIGN_LONGS */
}
#ifdef DEPTH_LIMIT
#define check_depth(DEPTH, ap) \
if ((DEPTH) <= MkIntTerm(1)) {/* I assume Module==0 is prolog */ \
if ((ap)->ModuleOfPred) {\
if ((DEPTH) == MkIntTerm(0))\
FAIL(); \
else (DEPTH) = RESET_DEPTH();\
} \
} else if ((ap)->ModuleOfPred)\
(DEPTH) -= MkIntConstant(2);
#else
#define check_depth(DEPTH)
#endif

6
H/amidefs.h
View File

@ -390,6 +390,12 @@ typedef struct yami {
wamreg xr; wamreg xr;
CELL next; CELL next;
} xx; } xx;
struct {
CELL x;
CELL x1;
struct pred_entry *p;
CELL next;
} xxp;
struct { struct {
wamreg x; wamreg x;
wamreg x1; wamreg x1;

79
H/clause.h
View File

@ -38,27 +38,48 @@ typedef union CONSULT_OBJ {
#define PredMiddleClause 1 #define PredMiddleClause 1
#define PredLastClause 2 #define PredLastClause 2
typedef struct logic_upd_index {
CELL ClFlags;
UInt ClRefCount;
#if defined(YAPOR) || defined(THREADS)
/* A lock for manipulating the clause */
lockvar ClLock;
#endif
UInt ClUse;
union {
PredEntry *pred;
struct logic_upd_index *ParentIndex;
} u;
struct logic_upd_index *SiblingIndex;
struct logic_upd_index *ChildIndex;
/* The instructions, at least one of the form sl */
yamop ClCode[MIN_ARRAY];
} LogUpdIndex;
typedef struct logic_upd_clause { typedef struct logic_upd_clause {
Functor Id; /* allow pointers to this struct to id */
/* as dbref */
/* A set of flags describing info on the clause */
/* A set of flags describing info on the clause */ /* A set of flags describing info on the clause */
CELL ClFlags; CELL ClFlags;
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
/* A lock for manipulating the clause */ /* A lock for manipulating the clause */
lockvar ClLock; lockvar ClLock;
UInt ref_count;
#endif #endif
union {
yamop *ClVarChain; /* indexing code for log. sem. */
} u;
/* extra clause information for logical update indices and facts */ /* extra clause information for logical update indices and facts */
union { /* indices that may still backtrack to this clause */
/* extra clause information for logical update semantics, rules with envs */ UInt ClRefCount;
/* data for clauses with environments */
yamop *ClExt; yamop *ClExt;
/* extra clause information for logical update indices and facts */ DBTerm *ClSource;
Int ClUse; /* doubly linked list of clauses */
} u2; struct logic_upd_clause *ClPrev, *ClNext;
/* parent pointer */
PredEntry *ClPred;
/* file which defined the clause */
Atom Owner;
/* The instructions, at least one of the form sl */ /* The instructions, at least one of the form sl */
yamop ClCode[MIN_ARRAY]; yamop ClCode[MIN_ARRAY];
Atom Owner;
} LogUpdClause; } LogUpdClause;
typedef struct dynamic_clause { typedef struct dynamic_clause {
@ -67,14 +88,23 @@ typedef struct dynamic_clause {
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
/* A lock for manipulating the clause */ /* A lock for manipulating the clause */
lockvar ClLock; lockvar ClLock;
UInt ref_count;
#endif #endif
UInt ClRefCount;
Atom Owner; Atom Owner;
yamop *ClPrevious; /* immediate update clause */ yamop *ClPrevious; /* immediate update clause */
/* The instructions, at least one of the form sl */ /* The instructions, at least one of the form sl */
yamop ClCode[MIN_ARRAY]; yamop ClCode[MIN_ARRAY];
} DynamicClause; } DynamicClause;
typedef struct static_index {
/* A set of flags describing info on the clause */
CELL ClFlags;
struct static_index *SiblingIndex;
struct static_index *ChildIndex;
/* The instructions, at least one of the form sl */
yamop ClCode[MIN_ARRAY];
} StaticIndex;
typedef struct static_clause { typedef struct static_clause {
/* A set of flags describing info on the clause */ /* A set of flags describing info on the clause */
CELL ClFlags; CELL ClFlags;
@ -95,16 +125,20 @@ typedef struct dead_clause {
typedef union clause_obj { typedef union clause_obj {
struct logic_upd_clause luc; struct logic_upd_clause luc;
struct logic_upd_index lui;
struct dynamic_clause ic; struct dynamic_clause ic;
struct static_clause sc; struct static_clause sc;
struct static_index si;
} ClauseUnion; } ClauseUnion;
#define ClauseCodeToDynamicClause(p) ((DynamicClause *)((CODEADDR)(p)-(CELL)(((DynamicClause *)NULL)->ClCode))) #define ClauseCodeToDynamicClause(p) ((DynamicClause *)((CODEADDR)(p)-(CELL)(((DynamicClause *)NULL)->ClCode)))
#define ClauseCodeToStaticClause(p) ((StaticClause *)((CODEADDR)(p)-(CELL)(((StaticClause *)NULL)->ClCode))) #define ClauseCodeToStaticClause(p) ((StaticClause *)((CODEADDR)(p)-(CELL)(((StaticClause *)NULL)->ClCode)))
#define ClauseCodeToLogUpdClause(p) ((LogUpdClause *)((CODEADDR)(p)-(CELL)(((LogUpdClause *)NULL)->ClCode))) #define ClauseCodeToLogUpdClause(p) ((LogUpdClause *)((CODEADDR)(p)-(CELL)(((LogUpdClause *)NULL)->ClCode)))
#define ClauseCodeToLogUpdIndex(p) ((LogUpdIndex *)((CODEADDR)(p)-(CELL)(((LogUpdIndex *)NULL)->ClCode)))
#define ClauseCodeToStaticIndex(p) ((StaticIndex *)((CODEADDR)(p)-(CELL)(((StaticIndex *)NULL)->ClCode)))
#define ClauseFlagsToDynamicClause(p) ((DynamicClause *)(p)) #define ClauseFlagsToDynamicClause(p) ((DynamicClause *)(p))
#define ClauseFlagsToLogUpdClause(p) ((LogUpdClause *)(p)) #define ClauseFlagsToLogUpdClause(p) ((LogUpdClause *)((CODEADDR)(p)-(CELL)(&(((LogUpdClause *)NULL)->ClFlags))))
#define ClauseFlagsToStaticClause(p) ((StaticClause *)(p)) #define ClauseFlagsToStaticClause(p) ((StaticClause *)(p))
#define DynamicFlags(X) (ClauseCodeToDynamicClause(X)->ClFlags) #define DynamicFlags(X) (ClauseCodeToDynamicClause(X)->ClFlags)
@ -112,27 +146,29 @@ typedef union clause_obj {
#define DynamicLock(X) (ClauseCodeToDynamicClause(X)->ClLock) #define DynamicLock(X) (ClauseCodeToDynamicClause(X)->ClLock)
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
#define INIT_CLREF_COUNT(X) (X)->ref_count = 0 #define INIT_CLREF_COUNT(X) (X)->ClRefCount = 0
#define INC_CLREF_COUNT(X) (X)->ref_count++ #define INC_CLREF_COUNT(X) (X)->ClRefCount++
#define DEC_CLREF_COUNT(X) (X)->ref_count-- #define DEC_CLREF_COUNT(X) (X)->ClRefCount--
#define CL_IN_USE(X) ((X)->ref_count != 0) #define CL_IN_USE(X) ((X)->ClRefCount != 0)
#else #else
#define INIT_CLREF_COUNT(X) #define INIT_CLREF_COUNT(X)
#define INC_CLREF_COUNT(X) #define INC_CLREF_COUNT(X)
#define DEC_CLREF_COUNT(X) #define DEC_CLREF_COUNT(X)
#define CL_IN_USE(X) ((X)->ClFlags & InUseMask) #define CL_IN_USE(X) ((X)->ClFlags & InUseMask || (X)->ClRefCount)
#endif #endif
/* amasm.c */ /* amasm.c */
wamreg STD_PROTO(Yap_emit_x,(CELL)); wamreg STD_PROTO(Yap_emit_x,(CELL));
wamreg STD_PROTO(Yap_compile_cmp_flags,(PredEntry *)); wamreg STD_PROTO(Yap_compile_cmp_flags,(PredEntry *));
void STD_PROTO(Yap_InitComma,(void)); void STD_PROTO(Yap_InitComma,(void));
wamreg STD_PROTO(Yap_regnotoreg,(UInt));
/* cdmgr.c */ /* cdmgr.c */
void STD_PROTO(Yap_RemoveLogUpdIndex,(LogUpdClause *)); void STD_PROTO(Yap_RemoveLogUpdIndex,(LogUpdIndex *));
void STD_PROTO(Yap_IPred,(PredEntry *)); void STD_PROTO(Yap_IPred,(PredEntry *));
void STD_PROTO(Yap_addclause,(Term,yamop *,int,int)); void STD_PROTO(Yap_addclause,(Term,yamop *,int,int));
void STD_PROTO(Yap_add_logupd_clause,(PredEntry *,LogUpdClause *,int));
void STD_PROTO(Yap_kill_iblock,(ClauseUnion *,ClauseUnion *,PredEntry *));
ClauseUnion *STD_PROTO(Yap_find_owner_index,(yamop *, PredEntry *));
/* dbase.c */ /* dbase.c */
void STD_PROTO(Yap_ErCl,(DynamicClause *)); void STD_PROTO(Yap_ErCl,(DynamicClause *));
@ -143,6 +179,10 @@ Term STD_PROTO(Yap_cp_as_integer,(choiceptr));
/* index.c */ /* index.c */
yamop *STD_PROTO(Yap_PredIsIndexable,(PredEntry *)); yamop *STD_PROTO(Yap_PredIsIndexable,(PredEntry *));
yamop *STD_PROTO(Yap_ExpandIndex,(PredEntry *));
void STD_PROTO(Yap_AddClauseToIndex,(PredEntry *,yamop *,int));
void STD_PROTO(Yap_RemoveClauseFromIndex,(PredEntry *,yamop *));
LogUpdClause *STD_PROTO(Yap_follow_lu_indexing_code,(PredEntry *,yamop *,Term,Term,Term, yamop *,yamop *));
#if LOW_PROF #if LOW_PROF
/* profiling */ /* profiling */
@ -181,3 +221,4 @@ Yap_op_from_opcode(OPCODE opc)
return((op_numbers)opc); return((op_numbers)opc);
} }
#endif /* USE_THREADED_CODE */ #endif /* USE_THREADED_CODE */

3
H/compile.h
View File

@ -97,6 +97,9 @@ typedef enum compiler_op {
switch_f_op, switch_f_op,
if_f_op, if_f_op,
if_not_op, if_not_op,
index_dbref_op,
index_blob_op,
check_var_op,
save_pair_op, save_pair_op,
save_appl_op, save_appl_op,
comit_opt_op, comit_opt_op,

32
H/index.h
View File

@ -43,7 +43,11 @@ typedef struct StructClauseDef {
Term Tag; /* if nonvar or nonlist, first argument */ Term Tag; /* if nonvar or nonlist, first argument */
yamop *Code; /* start of code for clause */ yamop *Code; /* start of code for clause */
yamop *CurrentCode; /* start of code for clause */ yamop *CurrentCode; /* start of code for clause */
union {
yamop *WorkPC; /* start of code for clause */ yamop *WorkPC; /* start of code for clause */
CELL *c_sreg;
Term t_ptr;
} u;
} ClauseDef; } ClauseDef;
@ -82,3 +86,31 @@ typedef struct {
#define MAX_REG_COPIES 32 #define MAX_REG_COPIES 32
typedef struct {
Int pos;
Term val;
} istack_entry;
typedef enum {
pc_entry,
block_entry
} add2index_entries;
typedef struct {
add2index_entries flag;
union {
struct {
yamop**pi_pc;
yamop *code, *current_code, *work_pc;
Term tag;
} pce;
struct {
ClauseUnion *block;
yamop **entry_code;
} cle;
} u;
} path_stack_entry;
#define MAX_ISTACK_DEPTH 32

193
H/rheap.h
View File

@ -53,6 +53,7 @@ restore_codes(void)
INIT_YAMOP_LTT(&(heap_regs->tableanswerresolutioncode), 0); INIT_YAMOP_LTT(&(heap_regs->tableanswerresolutioncode), 0);
#endif /* YAPOR */ #endif /* YAPOR */
#endif /* TABLING */ #endif /* TABLING */
heap_regs->expand_op_code = Yap_opcode(_expand_index);
heap_regs->failcode->opc = Yap_opcode(_op_fail); heap_regs->failcode->opc = Yap_opcode(_op_fail);
heap_regs->failcode_1 = Yap_opcode(_op_fail); heap_regs->failcode_1 = Yap_opcode(_op_fail);
heap_regs->failcode_2 = Yap_opcode(_op_fail); heap_regs->failcode_2 = Yap_opcode(_op_fail);
@ -131,12 +132,8 @@ restore_codes(void)
heap_regs->dead_clauses = (DeadClause *) heap_regs->dead_clauses = (DeadClause *)
AddrAdjust((ADDR)(heap_regs->dead_clauses)); AddrAdjust((ADDR)(heap_regs->dead_clauses));
} }
heap_regs->retry_recorded_code =
PtoOpAdjust(heap_regs->retry_recorded_code);
heap_regs->retry_recorded_k_code = heap_regs->retry_recorded_k_code =
PtoOpAdjust(heap_regs->retry_recorded_k_code); PtoOpAdjust(heap_regs->retry_recorded_k_code);
heap_regs->retry_drecorded_code =
PtoOpAdjust(heap_regs->retry_drecorded_code);
heap_regs->retry_c_recordedp_code = heap_regs->retry_c_recordedp_code =
PtoOpAdjust(heap_regs->retry_c_recordedp_code); PtoOpAdjust(heap_regs->retry_c_recordedp_code);
if (heap_regs->IntKeys != NULL) { if (heap_regs->IntKeys != NULL) {
@ -308,6 +305,10 @@ restore_codes(void)
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_meta_call); (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_meta_call);
heap_regs->pred_dollar_catch = heap_regs->pred_dollar_catch =
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_dollar_catch); (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_dollar_catch);
heap_regs->pred_recorded_with_key =
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_recorded_with_key);
heap_regs->pred_log_upd_clause =
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_log_upd_clause);
heap_regs->pred_throw = heap_regs->pred_throw =
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_throw); (PredEntry *)AddrAdjust((ADDR)heap_regs->pred_throw);
heap_regs->pred_handle_throw = heap_regs->pred_handle_throw =
@ -440,6 +441,26 @@ AdjustDBTerm(Term trm)
return (trm); return (trm);
} }
static void
RestoreDBTerm(DBTerm *dbr)
{
#ifdef COROUTINING
if (dbr->attachments)
dbr->attachments = AdjustDBTerm(dbr->attachments);
#endif
if (dbr->DBRefs != NULL)
dbr->DBRefs = DBRefPAdjust(dbr->DBRefs);
if (IsAtomTerm(dbr->Entry)) {
dbr->Entry = AtomTermAdjust(dbr->Entry);
return;
}
if (IsApplTerm(dbr->Entry)) {
ConvDBStruct(dbr->Entry, CharP(dbr->Contents-1), dbr->NOfCells*sizeof(CELL));
} else if (IsPairTerm(dbr->Entry)) {
ConvDBList(dbr->Entry, CharP(dbr->Contents-1), dbr->NOfCells*sizeof(CELL));
}
}
static void static void
RestoreDBEntry(DBRef dbr) RestoreDBEntry(DBRef dbr)
{ {
@ -457,27 +478,31 @@ RestoreDBEntry(DBRef dbr)
YP_fprintf(errout, " a var\n"); YP_fprintf(errout, " a var\n");
#endif #endif
dbr->Parent = (DBProp)AddrAdjust((ADDR)(dbr->Parent)); dbr->Parent = (DBProp)AddrAdjust((ADDR)(dbr->Parent));
#ifdef COROUTINING
if (dbr->DBT.attachments)
dbr->DBT.attachments = AdjustDBTerm(dbr->DBT.attachments);
#endif
if (dbr->Code != NULL) if (dbr->Code != NULL)
dbr->Code = PtoOpAdjust(dbr->Code); dbr->Code = PtoOpAdjust(dbr->Code);
if (dbr->Flags & DBWithRefs) { if (dbr->Flags & DBWithRefs) {
DBRef *cp; DBRef *cp;
DBRef tm; DBRef tm;
dbr->DBRefs = DBRefPAdjust(dbr->DBRefs); dbr->DBT.DBRefs = DBRefPAdjust(dbr->DBT.DBRefs);
cp = dbr->DBRefs; cp = dbr->DBT.DBRefs;
while ((tm = *--cp) != 0) while ((tm = *--cp) != 0)
*cp = DBRefAdjust(tm); *cp = DBRefAdjust(tm);
} }
if (dbr->Flags & DBAtomic) { if (dbr->Flags & DBAtomic) {
if (IsAtomTerm(dbr->Entry)) if (IsAtomTerm(dbr->DBT.Entry))
dbr->Entry = AtomTermAdjust(dbr->Entry); dbr->DBT.Entry = AtomTermAdjust(dbr->DBT.Entry);
} else if (dbr->Flags & DBNoVars) } else if (dbr->Flags & DBNoVars)
dbr->Entry = (CELL) AdjustDBTerm((Term) dbr->Entry); dbr->DBT.Entry = (CELL) AdjustDBTerm((Term) dbr->DBT.Entry);
else if (dbr->Flags & DBComplex) { else if (dbr->Flags & DBComplex) {
if (IsApplTerm((Term) dbr->Entry)) if (IsApplTerm(dbr->DBT.Entry))
ConvDBStruct((Term) dbr->Entry, CharP(dbr->Contents-1), dbr->NOfCells*sizeof(CELL)); ConvDBStruct(dbr->DBT.Entry, CharP(dbr->DBT.Contents-1), dbr->DBT.NOfCells*sizeof(CELL));
else else
ConvDBList((Term) dbr->Entry, CharP(dbr->Contents-1), dbr->NOfCells*sizeof(CELL)); ConvDBList(dbr->DBT.Entry, CharP(dbr->DBT.Contents-1), dbr->DBT.NOfCells*sizeof(CELL));
} }
if (dbr->Prev != NULL) if (dbr->Prev != NULL)
dbr->Prev = DBRefAdjust(dbr->Prev); dbr->Prev = DBRefAdjust(dbr->Prev);
@ -534,24 +559,11 @@ static void
RestoreBB(BlackBoardEntry *pp) RestoreBB(BlackBoardEntry *pp)
{ {
if (pp->Element) { if (pp->Element) {
register DBRef dbr; register DBTerm *dbr;
pp->Element = DBRefAdjust(pp->Element); pp->Element = (DBTerm *)AdjustDBTerm((Term)pp->Element);
#ifdef DEBUG_RESTORE
YP_fprintf(errout, "Restoring at %x", dbr);
if (dbr->Flags & DBAtomic)
YP_fprintf(errout, " an atomic term\n");
else if (dbr->Flags & DBNoVars)
YP_fprintf(errout, " with no vars\n");
else if (dbr->Flags & DBComplex)
YP_fprintf(errout, " complex term\n");
else if (dbr->Flags & DBIsRef)
YP_fprintf(errout, " a ref\n");
else
YP_fprintf(errout, " a var\n");
#endif
dbr = pp->Element; dbr = pp->Element;
RestoreDBEntry(dbr); RestoreDBTerm(dbr);
} }
pp->KeyOfBB = AtomAdjust(pp->KeyOfBB); pp->KeyOfBB = AtomAdjust(pp->KeyOfBB);
} }
@ -575,7 +587,7 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
LogUpdClause *cl = ClauseCodeToLogUpdClause(pc); LogUpdClause *cl = ClauseCodeToLogUpdClause(pc);
if (cl->ClFlags & LogUpdRuleMask) { if (cl->ClFlags & LogUpdRuleMask) {
cl->u2.ClExt = PtoOpAdjust(cl->u2.ClExt); cl->ClExt = PtoOpAdjust(cl->ClExt);
} }
cl->Owner = AtomAdjust(cl->Owner); cl->Owner = AtomAdjust(cl->Owner);
} else { } else {
@ -668,6 +680,8 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
pc = NEXTOP(pc,EC); pc = NEXTOP(pc,EC);
break; break;
/* instructions type e */ /* instructions type e */
case _unify_idb_term:
case _copy_idb_term:
case _trust_fail: case _trust_fail:
case _op_fail: case _op_fail:
case _cut: case _cut:
@ -684,6 +698,7 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
#endif #endif
case _pop: case _pop:
case _index_pred: case _index_pred:
case _expand_index:
case _undef_p: case _undef_p:
case _spy_pred: case _spy_pred:
case _p_equal: case _p_equal:
@ -693,6 +708,8 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
case _p_execute_tail: case _p_execute_tail:
case _enter_a_profiling: case _enter_a_profiling:
case _count_a_call: case _count_a_call:
case _index_dbref:
case _index_blob:
#ifdef YAPOR #ifdef YAPOR
case _getwork_first_time: case _getwork_first_time:
#endif #endif
@ -762,6 +779,10 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
pc->u.y.y = YAdjust(pc->u.y.y); pc->u.y.y = YAdjust(pc->u.y.y);
pc = NEXTOP(pc,y); pc = NEXTOP(pc,y);
break; break;
case _check_var_for_index:
pc->u.xxp.p = PtoPredAdjust(pc->u.xxp.p);
pc = NEXTOP(pc,xxp);
break;
/* instructions type sla */ /* instructions type sla */
case _p_execute: case _p_execute:
goto sla_full; goto sla_full;
@ -1070,8 +1091,8 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
int i, j; int i, j;
CELL *oldcode, *startcode; CELL *oldcode, *startcode;
i = pc->u.s.s; i = pc->u.sl.s;
startcode = oldcode = (CELL *)NEXTOP(pc,s); startcode = oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
for (j = 0; j < i; j++) { for (j = 0; j < i; j++) {
Functor oldfunc = (Functor)(oldcode[0]); Functor oldfunc = (Functor)(oldcode[0]);
CODEADDR oldjmp = (CODEADDR)(oldcode[1]); CODEADDR oldjmp = (CODEADDR)(oldcode[1]);
@ -1094,21 +1115,17 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
CELL *startcode; CELL *startcode;
#endif #endif
i = pc->u.s.s; i = pc->u.sl.s;
#if !USE_OFFSETS #if !USE_OFFSETS
startcode = startcode =
#endif #endif
oldcode = (CELL *)NEXTOP(pc,s); oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
for (j = 0; j < i; j++) { for (j = 0; j < i; j++) {
#if !USE_OFFSETS Term oldcons = oldcode[0];
Term oldatom = oldcode[0];
#endif
CODEADDR oldjmp = (CODEADDR)(oldcode[1]); CODEADDR oldjmp = (CODEADDR)(oldcode[1]);
#if !USE_OFFSETS if (oldcons != 0x0 && IsAtomTerm(oldcons)) {
if (oldatom != 0x0) { oldcode[0] = AtomTermAdjust(oldcons);
oldcode[0] = AtomTermAdjust(oldatom);
} }
#endif
oldcode[1] = (CELL)CodeAddrAdjust(oldjmp); oldcode[1] = (CELL)CodeAddrAdjust(oldjmp);
oldcode += 2; oldcode += 2;
} }
@ -1118,65 +1135,66 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
pc = (yamop *)oldcode; pc = (yamop *)oldcode;
} }
break; break;
/* instructions type fll */
case _go_on_func: case _go_on_func:
pc->u.fll.f = FuncAdjust(pc->u.fll.f); {
pc->u.fll.l1 = CodeAddrAdjust(pc->u.fll.l1); CELL *oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
pc->u.fll.l2 = CodeAddrAdjust(pc->u.fll.l2); Functor oldfunc = (Functor)(oldcode[0]);
pc = NEXTOP(pc,fll);
oldcode[0] = (CELL)FuncAdjust(oldfunc);
oldcode[1] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[1]);
oldcode[3] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[3]);
}
pc = NEXTOP(pc,sl);
break; break;
/* instructions type cll */
case _go_on_cons: case _go_on_cons:
if (IsAtomTerm(pc->u.cll.c)) {
pc->u.cll.c = AtomTermAdjust(pc->u.cll.c); CELL *oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
pc->u.cll.l1 = PtoOpAdjust(pc->u.cll.l1); Term oldcons = oldcode[0];
pc->u.cll.l2 = PtoOpAdjust(pc->u.cll.l2);
pc = NEXTOP(pc,cll); if (IsAtomTerm(oldcons)) {
oldcode[0] = AtomTermAdjust(oldcons);
}
oldcode[1] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[1]);
oldcode[3] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[3]);
}
pc = NEXTOP(pc,sl);
break; break;
/* instructions type sl */
case _if_func: case _if_func:
{ {
int i, j; CELL *oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
CELL *oldcode; Int j;
i = pc->u.s.s; for (j = 0; j < pc->u.sl.s; j++) {
pc->u.sl.l = PtoOpAdjust(pc->u.sl.l);
oldcode = (CELL *)NEXTOP(pc,sl);
for (j = 0; j < i; ++j) {
Functor oldfunc = (Functor)(oldcode[0]); Functor oldfunc = (Functor)(oldcode[0]);
CODEADDR oldjmp = (CODEADDR)(oldcode[1]); CODEADDR oldjmp = (CODEADDR)(oldcode[1]);
if (oldfunc != NULL) {
oldcode[0] = (CELL)FuncAdjust(oldfunc); oldcode[0] = (CELL)FuncAdjust(oldfunc);
}
oldcode[1] = (CELL)CodeAddrAdjust(oldjmp); oldcode[1] = (CELL)CodeAddrAdjust(oldjmp);
oldcode += 2; oldcode += 2;
pc = (yamop *)oldcode;
} }
/* adjust fail code */
oldcode[1] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[1]);
} }
pc = NEXTOP(pc,sl);
break; break;
/* instructions type cll */
case _if_cons: case _if_cons:
{ {
int i, j; CELL *oldcode = (CELL *)(pc->u.sl.l = PtoOpAdjust(pc->u.sl.l));
CELL *oldcode; Int j;
i = pc->u.sl.s; for (j = 0; j < pc->u.sl.s; j++) {
pc->u.sl.l = PtoOpAdjust(pc->u.sl.l); Term oldcons = oldcode[0];
oldcode = (CELL *)NEXTOP(pc,sl);
for (j = 0; j < i; ++j) {
#if !USE_OFFSETS
Term oldatom = oldcode[0];
#endif
CODEADDR oldjmp = (CODEADDR)(oldcode[1]); CODEADDR oldjmp = (CODEADDR)(oldcode[1]);
#if !USE_OFFSETS if (IsAtomTerm(oldcons)) {
if (oldatom != 0x0) { oldcode[0] = (CELL)AtomTermAdjust(oldcons);
oldcode[0] = AtomTermAdjust(oldatom);
} }
#endif
oldcode[1] = (CELL)CodeAddrAdjust(oldjmp); oldcode[1] = (CELL)CodeAddrAdjust(oldjmp);
oldcode += 2; oldcode += 2;
} }
pc = (yamop *)oldcode; /* adjust fail code */
oldcode[1] = (CELL)CodeAddrAdjust((CODEADDR)oldcode[1]);
} }
pc = NEXTOP(pc,sl);
break; break;
/* instructions type xxx */ /* instructions type xxx */
case _p_plus_vv: case _p_plus_vv:
@ -1318,12 +1336,22 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode)
static void static void
CleanClauses(yamop *First, yamop *Last, PredEntry *pp) CleanClauses(yamop *First, yamop *Last, PredEntry *pp)
{ {
if (pp->PredFlags & LogUpdatePredFlag) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(First);
while (cl != NULL) {
RestoreClause(cl->ClCode, pp, ASSEMBLING_CLAUSE);
cl = cl->ClNext;
}
} else {
yamop *cl = First; yamop *cl = First;
do { do {
RestoreClause(cl, pp, ASSEMBLING_CLAUSE); RestoreClause(cl, pp, ASSEMBLING_CLAUSE);
if (cl == Last) return; if (cl == Last) return;
cl = NextClause(cl); cl = NextClause(cl);
} while (TRUE); } while (TRUE);
}
} }
@ -1402,18 +1430,18 @@ restore_static_array(StaticArrayEntry *ae)
return; return;
case array_of_terms: case array_of_terms:
{ {
DBRef *base = (DBRef *)AddrAdjust((ADDR)(ae->ValueOfVE.terms)); DBTerm **base = (DBTerm **)AddrAdjust((ADDR)(ae->ValueOfVE.terms));
Int i; Int i;
ae->ValueOfVE.terms = base; ae->ValueOfVE.terms = base;
if (ae != 0L) { if (ae != 0L) {
for (i=0; i<sz; i++) { for (i=0; i<sz; i++) {
DBRef reg = *base; DBTerm *reg = *base;
if (reg == NULL) { if (reg == NULL) {
base++; base++;
} else { } else {
*base++ = reg = DBRefAdjust(reg); *base++ = reg = (DBTerm *)AdjustDBTerm((Term)reg);
RestoreDBEntry(reg); RestoreDBTerm(reg);
} }
} }
} }
@ -1437,8 +1465,10 @@ CleanCode(PredEntry *pp)
pp->FunctorOfPred = FuncAdjust(pp->FunctorOfPred); pp->FunctorOfPred = FuncAdjust(pp->FunctorOfPred);
else else
pp->FunctorOfPred = (Functor)AtomAdjust((Atom)(pp->FunctorOfPred)); pp->FunctorOfPred = (Functor)AtomAdjust((Atom)(pp->FunctorOfPred));
if (pp->OwnerFile) if (pp->ModuleOfPred != 2) {
pp->OwnerFile = AtomAdjust(pp->OwnerFile); if (pp->src.OwnerFile && pp->ModuleOfPred != 2)
pp->src.OwnerFile = AtomAdjust(pp->src.OwnerFile);
}
pp->OpcodeOfPred = Yap_opcode(Yap_op_from_opcode(pp->OpcodeOfPred)); pp->OpcodeOfPred = Yap_opcode(Yap_op_from_opcode(pp->OpcodeOfPred));
if (pp->PredFlags & (AsmPredFlag|CPredFlag)) { if (pp->PredFlags & (AsmPredFlag|CPredFlag)) {
/* assembly */ /* assembly */
@ -1455,6 +1485,7 @@ CleanCode(PredEntry *pp)
pp->cs.p_code.LastClause = PtoOpAdjust(pp->cs.p_code.LastClause); pp->cs.p_code.LastClause = PtoOpAdjust(pp->cs.p_code.LastClause);
pp->CodeOfPred =PtoOpAdjust(pp->CodeOfPred); pp->CodeOfPred =PtoOpAdjust(pp->CodeOfPred);
pp->cs.p_code.TrueCodeOfPred = PtoOpAdjust(pp->cs.p_code.TrueCodeOfPred); pp->cs.p_code.TrueCodeOfPred = PtoOpAdjust(pp->cs.p_code.TrueCodeOfPred);
pp->cs.p_code.ExpandCode = Yap_opcode(_expand_index);
if (pp->NextPredOfModule) if (pp->NextPredOfModule)
pp->NextPredOfModule = PtoPredAdjust(pp->NextPredOfModule); pp->NextPredOfModule = PtoPredAdjust(pp->NextPredOfModule);
flag = pp->PredFlags; flag = pp->PredFlags;

22
docs/yap.tex
View File

@ -7703,8 +7703,8 @@ mailing-list.
@findex splay_access/5 @findex splay_access/5
@snindex splay_access/5 @snindex splay_access/5
@cnindex splay_access/5 @cnindex splay_access/5
If item @var{Key} is in tree @var{Tree}, return its @value{Val} and unify If item @var{Key} is in tree @var{Tree}, return its @value{Val} and
@var{Return} with @code{true}. Otherwise unify @var{Return} with unify @var{Return} with @code{true}. Otherwise unify @var{Return} with
@code{null}. The variable @var{NewTree} unifies with the new tree. @code{null}. The variable @var{NewTree} unifies with the new tree.
@item splay_delete(+@var{Key},?@var{Val},+@var{Tree},-@var{NewTree}) @item splay_delete(+@var{Key},?@var{Val},+@var{Tree},-@var{NewTree})
@ -7726,11 +7726,11 @@ Initialize a new splay tree.
@findex splay_insert/4 @findex splay_insert/4
@snindex splay_insert/4 @snindex splay_insert/4
@cnindex splay_insert/4 @cnindex splay_insert/4
Insert item @var{Key} in tree @var{Tree}, assuming that it is not there Insert item @var{Key} in tree @var{Tree}, assuming that it is not
already. The variable @var{Val} unifies with a value for key @var{Key}, there already. The variable @var{Val} unifies with a value for key
and the variable @var{NewTree} unifies with the new tree. In our @var{Key}, and the variable @var{NewTree} unifies with the new
implementation, @var{Key} is not inserted if it is already there: tree. In our implementation, @var{Key} is not inserted if it is
rather it is unified with the item already in the tree. already there: rather it is unified with the item already in the tree.
@item splay_join(+@var{LeftTree},+@var{RighTree},-@var{NewTree}) @item splay_join(+@var{LeftTree},+@var{RighTree},-@var{NewTree})
@findex splay_join/3 @findex splay_join/3
@ -7745,10 +7745,10 @@ assumes that all items in @var{LeftTree} are less than all those in
@findex splay_split/5 @findex splay_split/5
@snindex splay_split/5 @snindex splay_split/5
@cnindex splay_split/5 @cnindex splay_split/5
Construct and return two trees @var{LeftTree} and @var{RightTree}, where Construct and return two trees @var{LeftTree} and @var{RightTree},
@var{LeftTree} contains all items in @var{Tree} less than @var{Key}, and where @var{LeftTree} contains all items in @var{Tree} less than
@var{RightTree} contains all items in @var{Tree} greater than @var{Key}, and @var{RightTree} contains all items in @var{Tree}
@var{Key}. This operations destroys @var{Tree}. greater than @var{Key}. This operations destroys @var{Tree}.
@end table @end table

1
library/Makefile.in
View File

@ -37,6 +37,7 @@ PROGRAMS= $(srcdir)/apply_macros.yap \
$(srcdir)/queues.yap \ $(srcdir)/queues.yap \
$(srcdir)/random.yap \ $(srcdir)/random.yap \
$(srcdir)/regexp.yap \ $(srcdir)/regexp.yap \
$(srcdir)/splay.yap \
$(srcdir)/system.yap \ $(srcdir)/system.yap \
$(srcdir)/terms.yap \ $(srcdir)/terms.yap \
$(srcdir)/tries.yap \ $(srcdir)/tries.yap \

4
m4/TermExt.h.m4
View File

@ -10,7 +10,7 @@
* File: TermExt.h * * File: TermExt.h *
* mods: * * mods: *
* comments: Extensions to standard terms for YAP * * comments: Extensions to standard terms for YAP *
* version: $Id: TermExt.h.m4,v 1.9 2002-12-06 20:03:26 vsc Exp $ * * version: $Id: TermExt.h.m4,v 1.10 2003-08-27 13:37:10 vsc Exp $ *
*************************************************************************/ *************************************************************************/
#if USE_OFFSETS #if USE_OFFSETS
@ -197,6 +197,8 @@ Inline(IsAttachFunc, Int, Functor, f, FALSE)
Inline(IsAttachedTerm, Int, Term, t, (IsVarTerm(t) && VarOfTerm(t) < H0) ) Inline(IsAttachedTerm, Int, Term, t, (IsVarTerm(t) && VarOfTerm(t) < H0) )
Inline(SafeIsAttachedTerm, Int, Term, t, (IsVarTerm(t) && VarOfTerm(t) < H0 && VarOfTerm(t) >= (CELL *)Yap_GlobalBase) )
Inline(ExtFromCell, exts, CELL *, pt, pt[1]) Inline(ExtFromCell, exts, CELL *, pt, pt[1])
#else #else

49
m4/Yatom.h.m4
View File

@ -170,6 +170,8 @@ typedef enum {
MetaPredFlag = 0x200000L, /* predicate subject to a meta declaration */ MetaPredFlag = 0x200000L, /* predicate subject to a meta declaration */
SyncPredFlag = 0x100000L, /* has to synch before it can execute*/ SyncPredFlag = 0x100000L, /* has to synch before it can execute*/
UserCPredFlag = 0x080000L, /* CPred defined by the user */ UserCPredFlag = 0x080000L, /* CPred defined by the user */
NumberDBPredFlag = 0x080000L, /* entry for a number key */
AtomDBPredFlag = 0x040000L, /* entry for an atom key */
MultiFileFlag = 0x040000L, /* is multi-file */ MultiFileFlag = 0x040000L, /* is multi-file */
FastPredFlag = 0x020000L, /* is "compiled" */ FastPredFlag = 0x020000L, /* is "compiled" */
TestPredFlag = 0x010000L, /* is a test (optim. comit) */ TestPredFlag = 0x010000L, /* is a test (optim. comit) */
@ -216,12 +218,17 @@ typedef struct pred_entry {
struct yami *FirstClause; struct yami *FirstClause;
struct yami *LastClause; struct yami *LastClause;
UInt NOfClauses; UInt NOfClauses;
OPCODE ExpandCode;
} p_code; } p_code;
CPredicate f_code; CPredicate f_code;
CmpPredicate d_code; CmpPredicate d_code;
} cs; /* if needing to spy or to lock */ } cs; /* if needing to spy or to lock */
Functor FunctorOfPred; /* functor for Predicate */ Functor FunctorOfPred; /* functor for Predicate */
union {
Atom OwnerFile; /* File where the predicate was defined */ Atom OwnerFile; /* File where the predicate was defined */
Int IndxId; /* Index for a certain key */
struct mfile *file_srcs; /* for multifile predicates */
} src;
struct pred_entry *NextPredOfModule; /* next pred for same module */ struct pred_entry *NextPredOfModule; /* next pred for same module */
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
rwlock_t PRWLock; /* a simple lock to protect this entry */ rwlock_t PRWLock; /* a simple lock to protect this entry */
@ -247,7 +254,9 @@ Inline(IsPredProperty, PropFlags, int, flags, (flags == PEProp) )
/* Flags for code or dbase entry */ /* Flags for code or dbase entry */
/* There are several flags for code and data base entries */ /* There are several flags for code and data base entries */
typedef enum { typedef enum {
HasBlobsMask = 0x20000, /* informs this has blobs whihc may be in use */ SwitchRootMask= 0x80000, /* informs this is the root for the index tree */
SwitchTableMask=0x40000, /* informs this is a switch table */
HasBlobsMask = 0x20000, /* informs this has blobs which may be in use */
GcFoundMask = 0x10000, /* informs this is a dynamic predicate */ GcFoundMask = 0x10000, /* informs this is a dynamic predicate */
DynamicMask = 0x8000, /* informs this is a dynamic predicate */ DynamicMask = 0x8000, /* informs this is a dynamic predicate */
InUseMask = 0x4000, /* informs this block is being used */ InUseMask = 0x4000, /* informs this block is being used */
@ -262,6 +271,16 @@ typedef enum {
/* *********************** DBrefs **************************************/ /* *********************** DBrefs **************************************/
typedef struct DB_TERM {
#ifdef COROUTINING
CELL attachments; /* attached terms */
#endif
struct DB_STRUCT **DBRefs; /* pointer to other references */
CELL NOfCells; /* Size of Term */
CELL Entry; /* entry point */
Term Contents[MIN_ARRAY]; /* stored term */
} DBTerm;
typedef struct DB_STRUCT { typedef struct DB_STRUCT {
Functor id; /* allow pointers to this struct to id */ Functor id; /* allow pointers to this struct to id */
/* as dbref */ /* as dbref */
@ -269,7 +288,6 @@ typedef struct DB_STRUCT {
CELL NOfRefsTo; /* Number of references pointing here */ CELL NOfRefsTo; /* Number of references pointing here */
struct struct_dbentry *Parent; /* key of DBase reference */ struct struct_dbentry *Parent; /* key of DBase reference */
struct yami *Code; /* pointer to code if this is a clause */ struct yami *Code; /* pointer to code if this is a clause */
struct DB_STRUCT **DBRefs; /* pointer to other references */
struct DB_STRUCT *Prev; /* Previous element in chain */ struct DB_STRUCT *Prev; /* Previous element in chain */
struct DB_STRUCT *Next; /* Next element in chain */ struct DB_STRUCT *Next; /* Next element in chain */
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
@ -278,18 +296,13 @@ typedef struct DB_STRUCT {
#endif #endif
struct DB_STRUCT *p, *n; /* entry's age, negative if from recorda, struct DB_STRUCT *p, *n; /* entry's age, negative if from recorda,
positive if it was recordz */ positive if it was recordz */
#ifdef COROUTINING
CELL attachments; /* attached terms */
#endif
CELL Mask; /* parts that should be cleared */ CELL Mask; /* parts that should be cleared */
CELL Key; /* A mask that can be used to check before CELL Key; /* A mask that can be used to check before
you unify */ you unify */
CELL NOfCells; /* Size of Term */ DBTerm DBT;
CELL Entry; /* entry point */
Term Contents[MIN_ARRAY]; /* stored term */
} DBStruct; } DBStruct;
#define DBStructFlagsToDBStruct(X) ((DBRef)((char *)(X) - (CELL) &(((DBRef) NIL)->Flags))) #define DBStructFlagsToDBStruct(X) ((DBRef)((char *)(X) - (CELL) &(((DBRef) NULL)->Flags)))
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
#define INIT_DBREF_COUNT(X) (X)->ref_count = 0 #define INIT_DBREF_COUNT(X) (X)->ref_count = 0
@ -377,7 +390,7 @@ typedef struct {
Prop NextOfPE; /* used to chain properties */ Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */ PropFlags KindOfPE; /* kind of property */
Atom KeyOfBB; /* functor for this property */ Atom KeyOfBB; /* functor for this property */
DBRef Element; /* blackboard element */ DBTerm *Element; /* blackboard element */
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
rwlock_t BBRWLock; /* a read-write lock to protect the entry */ rwlock_t BBRWLock; /* a read-write lock to protect the entry */
#endif #endif
@ -433,7 +446,7 @@ typedef union {
AtomEntry **ptrs; AtomEntry **ptrs;
Term *atoms; Term *atoms;
Term *dbrefs; Term *dbrefs;
DBRef *terms; DBTerm **terms;
} statarray_elements; } statarray_elements;
/* next, the actual data structure */ /* next, the actual data structure */
@ -473,9 +486,9 @@ int STD_PROTO(Yap_RemoveIndexation,(PredEntry *));
/* dbase.c */ /* dbase.c */
void STD_PROTO(Yap_ErDBE,(DBRef)); void STD_PROTO(Yap_ErDBE,(DBRef));
DBRef STD_PROTO(Yap_StoreTermInDB,(int,int)); DBTerm *STD_PROTO(Yap_StoreTermInDB,(Term,int));
Term STD_PROTO(Yap_FetchTermFromDB,(DBRef,int)); Term STD_PROTO(Yap_FetchTermFromDB,(DBTerm *,int));
void STD_PROTO(Yap_ReleaseTermFromDB,(DBRef)); void STD_PROTO(Yap_ReleaseTermFromDB,(DBTerm *));
/* init.c */ /* init.c */
Atom STD_PROTO(Yap_GetOp,(OpEntry *,int *,int)); Atom STD_PROTO(Yap_GetOp,(OpEntry *,int *,int));
@ -532,3 +545,11 @@ void STD_PROTO(Yap_ReleasePreAllocCodeSpace, (ADDR));
#else #else
#define Yap_ReleasePreAllocCodeSpace(x) #define Yap_ReleasePreAllocCodeSpace(x)
#endif #endif
typedef enum {
PROLOG_MODULE = 0,
USER_MODULE = 1,
IDB_MODULE = 2
} default_modules;

20
pl/arith.yap
View File

@ -18,20 +18,20 @@
% the default mode is on % the default mode is on
expand_exprs(Old,New) :- expand_exprs(Old,New) :-
('$get_value'('$c_arith',true) -> (get_value('$c_arith',true) ->
Old = on ; Old = on ;
Old = off ), Old = off ),
'$set_arith_expan'(New). '$set_arith_expan'(New).
'$set_arith_expan'(on) :- '$set_value'('$c_arith',true). '$set_arith_expan'(on) :- set_value('$c_arith',true).
'$set_arith_expan'(off) :- '$set_value'('$c_arith',[]). '$set_arith_expan'(off) :- set_value('$c_arith',[]).
compile_expressions :- '$set_value'('$c_arith',true). compile_expressions :- set_value('$c_arith',true).
do_not_compile_expressions :- '$set_value'('$c_arith',[]). do_not_compile_expressions :- set_value('$c_arith',[]).
'$c_built_in'(IN, M, OUT) :- '$c_built_in'(IN, M, OUT) :-
'$get_value'('$c_arith',true), !, get_value('$c_arith',true), !,
'$do_c_built_in'(IN, M, OUT). '$do_c_built_in'(IN, M, OUT).
'$c_built_in'(IN, _, IN). '$c_built_in'(IN, _, IN).
@ -63,14 +63,6 @@ do_not_compile_expressions :- '$set_value'('$c_arith',[]).
). ).
'$do_c_built_in'(once(G), M, ('$save_current_choice_point'(CP),NG,'$$cut_by'(CP))) :- !, '$do_c_built_in'(once(G), M, ('$save_current_choice_point'(CP),NG,'$$cut_by'(CP))) :- !,
'$do_c_built_in'(G,M,NG). '$do_c_built_in'(G,M,NG).
'$do_c_built_in'(recorded(K,T,R), _, OUT) :-
nonvar(K),
!,
( '$db_key'(K,I) ->
OUT = '$recorded_with_key'(I,T,R)
;
OUT = recorded(K,T,R)
).
'$do_c_built_in'(X is Y, _, P) :- '$do_c_built_in'(X is Y, _, P) :-
nonvar(Y), % Don't rewrite variables nonvar(Y), % Don't rewrite variables
!, !,

201
pl/boot.yap
View File

@ -56,35 +56,35 @@ read_sig.
eraseall('$sig_handler'), eraseall('$sig_handler'),
% The default interrupt handlers are kept, so that it's % The default interrupt handlers are kept, so that it's
% possible to revert to them with on_signal(S,_,default) % possible to revert to them with on_signal(S,_,default)
'$recordz'('$sig_handler',default(sig_hup, recordz('$sig_handler',default(sig_hup,
(( exists('~/.yaprc') -> [-'~/.yaprc'] ; true ), (( exists('~/.yaprc') -> [-'~/.yaprc'] ; true ),
( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ), ( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ),
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true ))), _), ( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true ))), _),
'$recordz'('$sig_handler',default(sig_usr1, recordz('$sig_handler',default(sig_usr1,
(nl,writeq('[ Received user signal 1 ]'),nl,halt)), _), (nl,writeq('[ Received user signal 1 ]'),nl,halt)), _),
'$recordz'('$sig_handler',default(sig_usr2, recordz('$sig_handler',default(sig_usr2,
(nl,writeq('[ Received user signal 2 ]'),nl,halt)), _), (nl,writeq('[ Received user signal 2 ]'),nl,halt)), _),
% The current interrupt handlers are also set the default values % The current interrupt handlers are also set the default values
'$recordz'('$sig_handler',action(sig_hup, recordz('$sig_handler',action(sig_hup,
(( exists('~/.yaprc') -> [-'~/.yaprc'] ; true ), (( exists('~/.yaprc') -> [-'~/.yaprc'] ; true ),
( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ), ( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ),
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true ))), _), ( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true ))), _),
'$recordz'('$sig_handler',action(sig_usr1, recordz('$sig_handler',action(sig_usr1,
(nl,writeq('[ Received user signal 1 ]'),nl,halt)), _), (nl,writeq('[ Received user signal 1 ]'),nl,halt)), _),
'$recordz'('$sig_handler',action(sig_usr2, recordz('$sig_handler',action(sig_usr2,
(nl,writeq('[ Received user signal 2 ]'),nl,halt)), _), (nl,writeq('[ Received user signal 2 ]'),nl,halt)), _),
'$set_yap_flags'(10,0), '$set_yap_flags'(10,0),
'$set_value'('$gc',on), set_value('$gc',on),
'$set_value'('$verbose',on), set_value('$verbose',on),
prompt(' ?- '), prompt(' ?- '),
( (
'$get_value'('$break',0) get_value('$break',0)
-> ->
% '$set_read_error_handler'(error), let the user do that % '$set_read_error_handler'(error), let the user do that
% after an abort, make sure all spy points are gone. % after an abort, make sure all spy points are gone.
'$clean_debugging_info', '$clean_debugging_info',
% simple trick to find out if this is we are booting from Prolog. % simple trick to find out if this is we are booting from Prolog.
'$get_value'('$user_module',V), get_value('$user_module',V),
( V = [] -> ( V = [] ->
'$current_module'(_,prolog) '$current_module'(_,prolog)
; ;
@ -138,17 +138,16 @@ read_sig.
'$clean_up_dead_clauses', '$clean_up_dead_clauses',
fail. fail.
'$enter_top_level' :- '$enter_top_level' :-
'$recorded'('$restore_goal',G,R), recorded('$restore_goal',G,R),
erase(R), erase(R),
prompt(_,' | '), prompt(_,' | '),
'$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)), '$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)),
fail. fail.
'$enter_top_level' :- '$enter_top_level' :-
( '$get_value'('$trace', 1) -> ( get_value('$trace', 1) ->
'$set_value'(spy_sl,0),
'$format'(user_error, "[trace]~n", []) '$format'(user_error, "[trace]~n", [])
; ;
'$get_value'(debug, 1) -> get_value(debug, 1) ->
'$format'(user_error, "[debug]~n", []) '$format'(user_error, "[debug]~n", [])
), ),
fail. fail.
@ -156,33 +155,26 @@ read_sig.
prompt(_,' ?- '), prompt(_,' ?- '),
prompt(' | '), prompt(' | '),
'$read_vars'(user_input,Command,_,Varnames), '$read_vars'(user_input,Command,_,Varnames),
'$set_value'(spy_sl,0), set_value(spy_fs,0),
'$set_value'(spy_fs,0), set_value(spy_sp,0),
'$set_value'(spy_sp,0), set_value(spy_gn,1),
'$set_value'(spy_gn,1), set_value(spy_skip,off),
( '$get_value'('$trace', 1) -> set_value(spy_stop,on),
'$set_yap_flags'(10,1)
;
'$set_yap_flags'(10,0)
),
'$set_value'(spy_cl,1),
'$set_value'(spy_leap,0),
'$setflop'(0),
prompt(_,' |: '), prompt(_,' |: '),
'$run_toplevel_hooks', '$run_toplevel_hooks',
'$command'((?-Command),Varnames,top), '$command'((?-Command),Varnames,top),
'$sync_mmapped_arrays', '$sync_mmapped_arrays',
'$set_value'('$live','$false'). set_value('$live','$false').
'$startup_goals' :- '$startup_goals' :-
'$recorded'('$startup_goal',G,_), recorded('$startup_goal',G,_),
'$current_module'(Module), '$current_module'(Module),
'$system_catch'('$query'((G->true), []),Module,Error,user:'$Error'(Error)), '$system_catch'('$query'((G->true), []),Module,Error,user:'$Error'(Error)),
fail. fail.
'$startup_goals'. '$startup_goals'.
'$startup_reconsult' :- '$startup_reconsult' :-
'$get_value'('$consult_on_boot',X), X \= [], !, get_value('$consult_on_boot',X), X \= [], !,
'$do_startup_reconsult'(X). '$do_startup_reconsult'(X).
'$startup_reconsult'. '$startup_reconsult'.
@ -190,7 +182,7 @@ read_sig.
% remove any debugging info after an abort. % remove any debugging info after an abort.
% %
'$clean_debugging_info' :- '$clean_debugging_info' :-
'$recorded'('$spy',_,R), recorded('$spy',_,R),
erase(R), erase(R),
fail. fail.
'$clean_debugging_info'. '$clean_debugging_info'.
@ -200,14 +192,14 @@ read_sig.
eraseall('$$set'), eraseall('$$set'),
eraseall('$$one'), eraseall('$$one'),
eraseall('$reconsulted'), fail. eraseall('$reconsulted'), fail.
'$erase_sets' :- \+ '$recorded'('$path',_,_), '$recorda'('$path',"",_). '$erase_sets' :- \+ recorded('$path',_,_), recorda('$path',"",_).
'$erase_sets'. '$erase_sets'.
'$version' :- '$version' :-
'$get_value'('$version_name',VersionName), get_value('$version_name',VersionName),
'$format'(user_error, "[ YAP version ~w ]~n", [VersionName]), '$format'(user_error, "[ YAP version ~w ]~n", [VersionName]),
fail. fail.
'$version' :- '$recorded'('$version',VersionName,_), '$version' :- recorded('$version',VersionName,_),
'$format'(user_error, "~w~n", [VersionName]), '$format'(user_error, "~w~n", [VersionName]),
fail. fail.
'$version'. '$version'.
@ -225,16 +217,16 @@ repeat :- '$repeat'.
'$repeat'. '$repeat'.
'$repeat' :- '$repeat'. '$repeat' :- '$repeat'.
'$start_corouts' :- '$recorded'('$corout','$corout'(Name,_,_),R), Name \= main, finish_corout(R), '$start_corouts' :- recorded('$corout','$corout'(Name,_,_),R), Name \= main, finish_corout(R),
fail. fail.
'$start_corouts' :- '$start_corouts' :-
eraseall('$corout'), eraseall('$corout'),
eraseall('$result'), eraseall('$result'),
eraseall('$actual'), eraseall('$actual'),
fail. fail.
'$start_corouts' :- '$recorda'('$actual',main,_), '$start_corouts' :- recorda('$actual',main,_),
'$recordz'('$corout','$corout'(main,main,'$corout'([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])),_Ref), recordz('$corout','$corout'(main,main,'$corout'([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])),_Ref),
'$recorda'('$result',going,_). recorda('$result',going,_).
'$command'(C,VL,Con) :- '$command'(C,VL,Con) :-
'$access_yap_flags'(9,1), !, '$access_yap_flags'(9,1), !,
@ -361,7 +353,7 @@ repeat :- '$repeat'.
'$$compile'(G1, G0, N, Mod). '$$compile'(G1, G0, N, Mod).
'$prepare_term'(G,V,G0,G1, Mod) :- '$prepare_term'(G,V,G0,G1, Mod) :-
( '$get_value'('$syntaxcheckflag',on) -> ( get_value('$syntaxcheckflag',on) ->
'$check_term'(G,V,Mod) ; true ), '$check_term'(G,V,Mod) ; true ),
'$precompile_term'(G, G0, G1, Mod). '$precompile_term'(G, G0, G1, Mod).
@ -370,17 +362,19 @@ repeat :- '$repeat'.
'$head_and_body'(G,H,_), '$head_and_body'(G,H,_),
'$inform_of_clause'(H,L), '$inform_of_clause'(H,L),
'$flags'(H, Mod, Fl, Fl), '$flags'(H, Mod, Fl, Fl),
( Fl /\ 16'002008 =\= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ; ( Fl /\ 16'000008 =\= 0 -> '$compile'(G,L,G0,Mod)
;
Fl /\ 16'002000 =\= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ;
'$$compile_stat'(G,G0,L,H, Mod) ). '$$compile_stat'(G,G0,L,H, Mod) ).
% process a clause for a static predicate % process a clause for a static predicate
'$$compile_stat'(G,G0,L,H, Mod) :- '$$compile_stat'(G,G0,L,H, Mod) :-
'$compile'(G,L,Mod), '$compile'(G,L,G0,Mod),
% first occurrence of this predicate in this file, % first occurrence of this predicate in this file,
% check if we need to erase the source and if % check if we need to erase the source and if
% it is a multifile procedure. % it is a multifile procedure.
'$flags'(H,Mod,Fl,Fl), '$flags'(H,Mod,Fl,Fl),
( '$get_value'('$abol',true) ( get_value('$abol',true)
-> ->
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H, Mod) ; true ), ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H, Mod) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true ) ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
@ -399,9 +393,9 @@ repeat :- '$repeat'.
'$head_and_body'(G0,H0,B0), '$head_and_body'(G0,H0,B0),
'$record_stat_source'(M:H,(H0:-B0),L,R), '$record_stat_source'(M:H,(H0:-B0),L,R),
( '$is_multifile'(H,M) -> ( '$is_multifile'(H,M) ->
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
functor(H, Na, Ar), functor(H, Na, Ar),
'$recordz'('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), _) recordz('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), _)
; ;
true true
). ).
@ -414,34 +408,34 @@ repeat :- '$repeat'.
'$erase_source'(_, _). '$erase_source'(_, _).
'$erase_mf_source'(Na, Ar, M) :- '$erase_mf_source'(Na, Ar, M) :-
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
'$recorded'('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), R1), recorded('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), R1),
erase(R1), erase(R1),
erase(R), erase(R),
fail. fail.
'$erase_mf_source'(Na, Ar, M) :- '$erase_mf_source'(Na, Ar, M) :-
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
'$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), R1), recorded('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), R1),
erase(R1), erase(R1),
erase(R), erase(R),
fail. fail.
'$erase_mf_source'(_,_,_). '$erase_mf_source'(_,_,_).
'$check_if_reconsulted'(N,A) :- '$check_if_reconsulted'(N,A) :-
'$recorded'('$reconsulted',X,_), recorded('$reconsulted',X,_),
( X = N/A , !; ( X = N/A , !;
X = '$', !, fail; X = '$', !, fail;
fail fail
). ).
'$inform_as_reconsulted'(N,A) :- '$inform_as_reconsulted'(N,A) :-
'$recorda'('$reconsulted',N/A,_). recorda('$reconsulted',N/A,_).
'$clear_reconsulting' :- '$clear_reconsulting' :-
'$recorded'('$reconsulted',X,Ref), recorded('$reconsulted',X,Ref),
erase(Ref), erase(Ref),
X == '$', !, X == '$', !,
( '$recorded'('$reconsulting',_,R) -> erase(R) ). ( recorded('$reconsulting',_,R) -> erase(R) ).
/* Executing a query */ /* Executing a query */
@ -464,13 +458,17 @@ repeat :- '$repeat'.
'$query'(G,[]) :- !, '$query'(G,[]) :- !,
'$yes_no'(G,(?-)). '$yes_no'(G,(?-)).
'$query'(G,V) :- '$query'(G,V) :-
( '$execute'(G), (
'$start_creep',
'$execute'(G),
'$stop_creep',
'$extract_goal_vars_for_dump'(V,LIV), '$extract_goal_vars_for_dump'(V,LIV),
'$show_frozen'(G,LIV,LGs), '$show_frozen'(G,LIV,LGs),
'$write_answer'(V, LGs, Written), '$write_answer'(V, LGs, Written),
'$write_query_answer_true'(Written), '$write_query_answer_true'(Written),
'$another', '$another',
!, fail ; !, fail ;
'$stop_creep',
'$present_answer'(_, no), '$present_answer'(_, no),
fail fail
). ).
@ -478,6 +476,7 @@ repeat :- '$repeat'.
'$yes_no'(G,C) :- '$yes_no'(G,C) :-
'$current_module'(M), '$current_module'(M),
'$do_yes_no'(G,M), '$do_yes_no'(G,M),
'$stop_creep',
'$show_frozen'(G, [], LGs), '$show_frozen'(G, [], LGs),
'$write_answer'([], LGs, Written), '$write_answer'([], LGs, Written),
( Written = [] -> ( Written = [] ->
@ -486,12 +485,20 @@ repeat :- '$repeat'.
), ),
fail. fail.
'$yes_no'(_,_) :- '$yes_no'(_,_) :-
'$stop_creep',
'$present_answer'(_, no), '$present_answer'(_, no),
fail. fail.
'$start_creep' :-
( get_value('$trace', 1) ->
'$creep'
;
'$setflop'(1)
).
'$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M). '$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M).
'$do_yes_no'(G, M) :- '$execute'(M:G). '$do_yes_no'(G, M) :- '$start_creep', '$execute'(M:G).
'$extract_goal_vars_for_dump'([],[]). '$extract_goal_vars_for_dump'([],[]).
'$extract_goal_vars_for_dump'([[_|V]|VL],[V|LIV]) :- '$extract_goal_vars_for_dump'([[_|V]|VL],[V|LIV]) :-
@ -516,10 +523,10 @@ repeat :- '$repeat'.
'$flush_all_streams', '$flush_all_streams',
fail. fail.
'$present_answer'((?-), Answ) :- '$present_answer'((?-), Answ) :-
'$get_value'('$break',BL), get_value('$break',BL),
( BL \= 0 -> '$format'(user_error, "[~p] ",[BL]) ; ( BL \= 0 -> '$format'(user_error, "[~p] ",[BL]) ;
true ), true ),
( '$recorded'('$print_options','$toplevel'(Opts),_) -> ( recorded('$print_options','$toplevel'(Opts),_) ->
write_term(user_error,Answ,Opts) ; write_term(user_error,Answ,Opts) ;
'$format'(user_error,"~w",[Answ]) '$format'(user_error,"~w",[Answ])
), ),
@ -616,12 +623,12 @@ repeat :- '$repeat'.
'$format'(user_error,"~s",[V]), '$format'(user_error,"~s",[V]),
'$write_output_vars'(VL), '$write_output_vars'(VL),
'$format'(user_error," = ", []), '$format'(user_error," = ", []),
( '$recorded'('$print_options','$toplevel'(Opts),_) -> ( recorded('$print_options','$toplevel'(Opts),_) ->
write_term(user_error,B,Opts) ; write_term(user_error,B,Opts) ;
'$format'(user_error,"~w",[B]) '$format'(user_error,"~w",[B])
). ).
'$write_goal_output'(_-G) :- '$write_goal_output'(_-G) :-
( '$recorded'('$print_options','$toplevel'(Opts),_) -> ( recorded('$print_options','$toplevel'(Opts),_) ->
write_term(user_error,G,Opts) ; write_term(user_error,G,Opts) ;
'$format'(user_error,"~w",[G]) '$format'(user_error,"~w",[G])
). ).
@ -813,7 +820,7 @@ incore(G) :- '$execute'(G).
'$std_spied_call'(A, CP, G0, M) :- '$std_spied_call'(A, CP, G0, M) :-
( '$undefined'(A, M) -> ( '$undefined'(A, M) ->
functor(A,F,N), functor(A,F,N),
( '$recorded'('$import','$import'(S,M,F,N),_) -> ( recorded('$import','$import'(S,M,F,N),_) ->
'$spied_call'(S:A,CP,G0,M) ; '$spied_call'(S:A,CP,G0,M) ;
'$spy'(A) '$spy'(A)
) )
@ -835,7 +842,7 @@ incore(G) :- '$execute'(G).
% Called by the abstract machine, if no clauses exist for a predicate % Called by the abstract machine, if no clauses exist for a predicate
'$undefp'([M|G]) :- '$undefp'([M|G]) :-
functor(G,F,N), functor(G,F,N),
'$recorded'('$import','$import'(S,M,F,N),_), recorded('$import','$import'(S,M,F,N),_),
S \= M, % can't try importing from the module itself. S \= M, % can't try importing from the module itself.
!, !,
'$expand_goal'(G, S, M, NG, NMod), '$expand_goal'(G, S, M, NG, NMod),
@ -845,7 +852,7 @@ incore(G) :- '$execute'(G).
user:unknown_predicate_handler(G,M,NG), !, user:unknown_predicate_handler(G,M,NG), !,
'$execute'(M:NG). '$execute'(M:NG).
'$undefp'([M|G]) :- '$undefp'([M|G]) :-
'$recorded'('$unknown','$unknown'(M:G,US),_), !, recorded('$unknown','$unknown'(M:G,US),_), !,
'$execute'(user:US). '$execute'(user:US).
@ -853,29 +860,27 @@ incore(G) :- '$execute'(G).
it saves the importante data about current streams and it saves the importante data about current streams and
debugger state */ debugger state */
break :- '$get_value'('$break',BL), NBL is BL+1, break :- get_value('$break',BL), NBL is BL+1,
'$get_value'(spy_sl,SPY_SL), get_value(spy_fs,SPY_FS),
'$get_value'(spy_fs,SPY_FS), get_value(spy_sp,SPY_SP),
'$get_value'(spy_sp,SPY_SP), get_value(spy_gn,SPY_GN),
'$get_value'(spy_gn,SPY_GN),
'$access_yap_flags'(10,SPY_CREEP), '$access_yap_flags'(10,SPY_CREEP),
'$get_value'(spy_cl,SPY_CL), get_value(spy_cl,SPY_CL),
'$get_value'(spy_leap,_Leap), get_value(spy_leap,_Leap),
'$set_value'('$break',NBL), set_value('$break',NBL),
current_output(OutStream), current_input(InpStream), current_output(OutStream), current_input(InpStream),
'$format'(user_error, "[ Break (level ~w) ]~n", [NBL]), '$format'(user_error, "[ Break (level ~w) ]~n", [NBL]),
'$do_live', '$do_live',
!, !,
'$set_value'('$live','$true'), set_value('$live','$true'),
'$set_value'(spy_sl,SPY_SL), get_value(spy_fs,SPY_FS),
'$get_value'(spy_fs,SPY_FS), set_value(spy_sp,SPY_SP),
'$set_value'(spy_sp,SPY_SP), set_value(spy_gn,SPY_GN),
'$set_value'(spy_gn,SPY_GN),
'$set_yap_flags'(10,SPY_CREEP), '$set_yap_flags'(10,SPY_CREEP),
'$set_value'(spy_cl,SPY_CL), set_value(spy_cl,SPY_CL),
'$set_value'(spy_leap,_Leap), set_value(spy_leap,_Leap),
'$set_input'(InpStream), '$set_output'(OutStream), '$set_input'(InpStream), '$set_output'(OutStream),
'$set_value'('$break',BL). set_value('$break',BL).
'$csult'(V, _) :- var(V), !, '$csult'(V, _) :- var(V), !,
@ -913,17 +918,17 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
'$reconsult'(F,Stream). '$reconsult'(F,Stream).
'$consult'(F,Stream) :- '$consult'(F,Stream) :-
'$getcwd'(OldD), '$getcwd'(OldD),
'$get_value'('$consulting_file',OldF), get_value('$consulting_file',OldF),
'$set_consulting_file'(Stream), '$set_consulting_file'(Stream),
H0 is heapused, '$cputime'(T0,_), H0 is heapused, '$cputime'(T0,_),
'$current_stream'(File,_,Stream), '$current_stream'(File,_,Stream),
'$current_module'(OldModule), '$current_module'(OldModule),
'$start_consult'(consult,File,LC), '$start_consult'(consult,File,LC),
'$get_value'('$consulting',Old), get_value('$consulting',Old),
'$set_value'('$consulting',true), set_value('$consulting',true),
'$recorda'('$initialisation','$',_), recorda('$initialisation','$',_),
( '$undefined'('$print_message'(_,_),prolog) -> ( '$undefined'('$print_message'(_,_),prolog) ->
( '$get_value'('$verbose',on) -> ( get_value('$verbose',on) ->
'$format'(user_error, "~*|[ consulting ~w... ]~n", [LC,F]) '$format'(user_error, "~*|[ consulting ~w... ]~n", [LC,F])
; true ) ; true )
; ;
@ -932,14 +937,14 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
'$loop'(Stream,consult), '$loop'(Stream,consult),
'$end_consult', '$end_consult',
'$cd'(OldD), '$cd'(OldD),
'$set_value'('$consulting',Old), set_value('$consulting',Old),
'$set_value'('$consulting_file',OldF), set_value('$consulting_file',OldF),
( LC == 0 -> prompt(_,' |: ') ; true), ( LC == 0 -> prompt(_,' |: ') ; true),
'$exec_initialisation_goals', '$exec_initialisation_goals',
'$current_module'(Mod,OldModule), '$current_module'(Mod,OldModule),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0, H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
( '$undefined'('$print_message'(_,_),prolog) -> ( '$undefined'('$print_message'(_,_),prolog) ->
( '$get_value'('$verbose',on) -> ( get_value('$verbose',on) ->
'$format'(user_error, "~*|[ ~w consulted ~w bytes in ~d msecs ]~n", [LC,F,H,T]) '$format'(user_error, "~*|[ ~w consulted ~w bytes in ~d msecs ]~n", [LC,F,H,T])
; ;
true true
@ -957,15 +962,15 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
'$record_loaded'(Stream) :- '$record_loaded'(Stream) :-
'$file_name'(Stream,F), '$file_name'(Stream,F),
'$file_age'(F,Age), '$file_age'(F,Age),
'$recorda'('$loaded','$loaded'(F,Age),_). recorda('$loaded','$loaded'(F,Age),_).
'$set_consulting_file'(user) :- !, '$set_consulting_file'(user) :- !,
'$set_value'('$consulting_file',user_input). set_value('$consulting_file',user_input).
'$set_consulting_file'(user_input) :- !, '$set_consulting_file'(user_input) :- !,
'$set_value'('$consulting_file',user_input). set_value('$consulting_file',user_input).
'$set_consulting_file'(Stream) :- '$set_consulting_file'(Stream) :-
'$file_name'(Stream,F), '$file_name'(Stream,F),
'$set_value'('$consulting_file',F), set_value('$consulting_file',F),
'$set_consulting_dir'(F). '$set_consulting_dir'(F).
% %
@ -1030,9 +1035,9 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
% Path predicates % Path predicates
'$exists'(F,Mode) :- '$get_value'(fileerrors,V), '$set_value'(fileerrors,0), '$exists'(F,Mode) :- get_value(fileerrors,V), set_value(fileerrors,0),
( '$open'(F,Mode,S,0), !, '$close'(S), '$set_value'(fileerrors,V); ( '$open'(F,Mode,S,0), !, '$close'(S), set_value(fileerrors,V);
'$set_value'(fileerrors,V), fail). set_value(fileerrors,V), fail).
'$find_in_path'(user,user_input, _) :- !. '$find_in_path'(user,user_input, _) :- !.
@ -1052,7 +1057,7 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
'$search_in_path'(New,New) :- '$search_in_path'(New,New) :-
'$exists'(New,'$csult'), !. '$exists'(New,'$csult'), !.
'$search_in_path'(File,New) :- '$search_in_path'(File,New) :-
'$recorded'('$path',Path,_), recorded('$path',Path,_),
atom_concat([Path,File],New), atom_concat([Path,File],New),
'$exists'(New,'$csult'). '$exists'(New,'$csult').
@ -1092,7 +1097,7 @@ expand_term(Term,Expanded) :-
% Arithmetic expansion % Arithmetic expansion
% %
'$expand_term_arith'(G1, G2) :- '$expand_term_arith'(G1, G2) :-
'$get_value'('$c_arith',true), get_value('$c_arith',true),
'$c_arith'(G1, G2), !. '$c_arith'(G1, G2), !.
'$expand_term_arith'(G,G). '$expand_term_arith'(G,G).
@ -1158,18 +1163,18 @@ throw(Ball) :-
). ).
'$exec_initialisation_goals' :- '$exec_initialisation_goals' :-
'$recorded'('$blocking_code',_,R), recorded('$blocking_code',_,R),
erase(R), erase(R),
fail. fail.
% system goals must be performed first % system goals must be performed first
'$exec_initialisation_goals' :- '$exec_initialisation_goals' :-
'$recorded'('$system_initialisation',G,R), recorded('$system_initialisation',G,R),
erase(R), erase(R),
G \= '$', G \= '$',
call(G), call(G),
fail. fail.
'$exec_initialisation_goals' :- '$exec_initialisation_goals' :-
'$recorded'('$initialisation',G,R), recorded('$initialisation',G,R),
erase(R), erase(R),
G \= '$', G \= '$',
'$current_module'(M), '$current_module'(M),
@ -1179,8 +1184,8 @@ throw(Ball) :-
'$run_toplevel_hooks' :- '$run_toplevel_hooks' :-
'$get_value'('$break',0), get_value('$break',0),
'$recorded'('$toplevel_hooks',H,_), !, recorded('$toplevel_hooks',H,_), !,
( '$execute'(H) -> true ; true). ( '$execute'(H) -> true ; true).
'$run_toplevel_hooks'. '$run_toplevel_hooks'.

36
pl/checker.yap
View File

@ -64,15 +64,15 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$check_term'(T,_,M) :- '$check_term'(T,_,M) :-
'$get_value'('$syntaxcheckdiscontiguous',on), get_value('$syntaxcheckdiscontiguous',on),
'$xtract_head'(T,M,NM,_,F,A), '$xtract_head'(T,M,NM,_,F,A),
'$handle_discontiguous'(F,A,NM), fail. '$handle_discontiguous'(F,A,NM), fail.
'$check_term'(T,_,M) :- '$check_term'(T,_,M) :-
'$get_value'('$syntaxcheckmultiple',on), get_value('$syntaxcheckmultiple',on),
'$xtract_head'(T,M,NM,_,F,A), '$xtract_head'(T,M,NM,_,F,A),
'$handle_multiple'(F,A,NM), fail. '$handle_multiple'(F,A,NM), fail.
'$check_term'(T,VL,_) :- '$check_term'(T,VL,_) :-
'$get_value'('$syntaxchecksinglevar',on), get_value('$syntaxchecksinglevar',on),
( '$chk_binding_vars'(T), ( '$chk_binding_vars'(T),
'$sv_list'(VL,Sv) -> '$sv_list'(VL,Sv) ->
'$sv_warning'(Sv,T) ), fail. '$sv_warning'(Sv,T) ), fail.
@ -109,7 +109,7 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
write(user_error,' (line '), write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN), '$start_line'(LN), write(user_error,LN),
write(user_error,', clause '), write(user_error,', clause '),
( '$get_value'('$consulting',false), ( get_value('$consulting',false),
'$first_clause_in_file'(Name,Arity, OM) -> '$first_clause_in_file'(Name,Arity, OM) ->
ClN = 1 ; ClN = 1 ;
'$number_of_clauses'(H,M,ClN0), '$number_of_clauses'(H,M,ClN0),
@ -150,7 +150,7 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$handle_discontiguous'(F,A,M) :- '$handle_discontiguous'(F,A,M) :-
'$recorded'('$discontiguous_defs','$df'(F,A,M),_), !. recorded('$discontiguous_defs','$df'(F,A,M),_), !.
'$handle_discontiguous'(F,A,M) :- '$handle_discontiguous'(F,A,M) :-
'$in_this_file_before'(F,A,M), '$in_this_file_before'(F,A,M),
write(user_error,'[ Warning: discontiguous definition of '), write(user_error,'[ Warning: discontiguous definition of '),
@ -162,19 +162,19 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$handle_multiple'(F,A,M) :- '$handle_multiple'(F,A,M) :-
\+ '$first_clause_in_file'(F,A,M), !. \+ '$first_clause_in_file'(F,A,M), !.
'$handle_multiple'(_,_,_) :- '$handle_multiple'(_,_,_) :-
'$get_value'('$consulting',true), !. get_value('$consulting',true), !.
'$handle_multiple'(F,A,M) :- '$handle_multiple'(F,A,M) :-
'$recorded'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !, recorded('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !,
'$multiple_has_been_defined'(Fil, F/A, M), !. '$multiple_has_been_defined'(Fil, F/A, M), !.
'$handle_multiple'(F,A,M) :- '$handle_multiple'(F,A,M) :-
( '$recorded'('$reconsulting',Fil,_) -> true ), ( recorded('$reconsulting',Fil,_) -> true ),
'$recorda'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_). recorda('$predicate_defs','$predicate_defs'(F,A,M,Fil),_).
'$multiple_has_been_defined'(_, F/A, M) :- '$multiple_has_been_defined'(_, F/A, M) :-
functor(S, F, A), functor(S, F, A),
'$is_multifile'(S, M), !. '$is_multifile'(S, M), !.
'$multiple_has_been_defined'(Fil,P,_) :- '$multiple_has_been_defined'(Fil,P,_) :-
'$recorded'('$reconsulting',F,_), !, recorded('$reconsulting',F,_), !,
'$test_if_well_reconsulting'(F,Fil,P). '$test_if_well_reconsulting'(F,Fil,P).
'$test_if_well_reconsulting'(F,F,_) :- !. '$test_if_well_reconsulting'(F,F,_) :- !.
@ -192,8 +192,8 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$multifile'(Mod:PredSpec, _) :- !, '$multifile'(Mod:PredSpec, _) :- !,
'$multifile'(PredSpec, Mod). '$multifile'(PredSpec, Mod).
'$multifile'(N/A, M) :- '$multifile'(N/A, M) :-
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
'$recordzifnot'('$multifile_defs','$defined'(F,N,A,M),_), recordzifnot('$multifile_defs','$defined'(F,N,A,M),_),
fail. fail.
'$multifile'(N/A, M) :- '$multifile'(N/A, M) :-
functor(S,N,A), functor(S,N,A),
@ -214,7 +214,7 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$discontiguous'(M:A,_) :- !, '$discontiguous'(M:A,_) :- !,
'$discontiguous'(A,M). '$discontiguous'(A,M).
'$discontiguous'(N/A, M) :- !, '$discontiguous'(N/A, M) :- !,
( '$recordzifnot'('$discontiguous_defs','$df'(N,A,M),_) -> ( recordzifnot('$discontiguous_defs','$df'(N,A,M),_) ->
true true
; ;
true true
@ -227,8 +227,8 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
% %
'$check_multifile_pred'(Hd, M, _) :- '$check_multifile_pred'(Hd, M, _) :-
functor(Hd,Na,Ar), functor(Hd,Na,Ar),
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
'$recorded'('$multifile_defs','$defined'(F,Na,Ar,M),_), !. recorded('$multifile_defs','$defined'(F,Na,Ar,M),_), !.
% oops, we did not. % oops, we did not.
'$check_multifile_pred'(Hd, M, Fl) :- '$check_multifile_pred'(Hd, M, Fl) :-
% so this is not a multi-file predicate any longer. % so this is not a multi-file predicate any longer.
@ -247,15 +247,15 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
nl(user_error). nl(user_error).
'$clear_multifile_pred'(Na,Ar,M) :- '$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile_defs','$defined'(_,Na,Ar,M),R), recorded('$multifile_defs','$defined'(_,Na,Ar,M),R),
erase(R), erase(R),
fail. fail.
'$clear_multifile_pred'(Na,Ar,M) :- '$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile'(_,_,_),'$mf'(Na,Ar,M,_,_),R), recorded('$multifile'(_,_,_),'$mf'(Na,Ar,M,_,_),R),
erase(R), erase(R),
fail. fail.
'$clear_multifile_pred'(Na,Ar,M) :- '$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile_dynamic'(_,_,_),'$mf'(Na,Ar,M,_,_),R), recorded('$multifile_dynamic'(_,_,_),'$mf'(Na,Ar,M,_,_),R),
erase(R), erase(R),
fail. fail.
'$clear_multifile_pred'(_,_,_). '$clear_multifile_pred'(_,_,_).

56
pl/consult.yap
View File

@ -33,7 +33,7 @@ ensure_loaded(V) :-
'$find_in_path'(X,Y,ensure_loaded(X)), '$find_in_path'(X,Y,ensure_loaded(X)),
'$open'(Y, '$csult', Stream, 0), !, '$open'(Y, '$csult', Stream, 0), !,
( '$loaded'(Stream,TFN) -> ( '$loaded'(Stream,TFN) ->
( '$recorded'('$module','$module'(TFN,M,P),_) -> ( recorded('$module','$module'(TFN,M,P),_) ->
'$current_module'(T), '$import'(P,M,T) '$current_module'(T), '$import'(P,M,T)
; ;
true true
@ -99,22 +99,22 @@ reconsult(Fs) :-
fail. fail.
'$reconsult'(F,Stream) :- '$reconsult'(F,Stream) :-
'$getcwd'(OldD), '$getcwd'(OldD),
'$get_value'('$consulting_file',OldF), get_value('$consulting_file',OldF),
'$set_consulting_file'(Stream), '$set_consulting_file'(Stream),
H0 is heapused, '$cputime'(T0,_), H0 is heapused, '$cputime'(T0,_),
current_stream(File,_,Stream), current_stream(File,_,Stream),
'$get_value'('$consulting',Old), get_value('$consulting',Old),
'$set_value'('$consulting',false), set_value('$consulting',false),
'$current_module'(OldModule), '$current_module'(OldModule),
'$start_reconsulting'(F), '$start_reconsulting'(F),
'$start_consult'(reconsult,File,LC), '$start_consult'(reconsult,File,LC),
'$recorda'('$initialisation','$',_), recorda('$initialisation','$',_),
'$print_message'(informational, loading(reconsulting, File)), '$print_message'(informational, loading(reconsulting, File)),
'$loop'(Stream,reconsult), '$loop'(Stream,reconsult),
'$end_consult', '$end_consult',
'$clear_reconsulting', '$clear_reconsulting',
'$set_value'('$consulting',Old), set_value('$consulting',Old),
'$set_value'('$consulting_file',OldF), set_value('$consulting_file',OldF),
'$cd'(OldD), '$cd'(OldD),
'$exec_initialisation_goals', '$exec_initialisation_goals',
'$current_module'(Mod,OldModule), '$current_module'(Mod,OldModule),
@ -124,8 +124,8 @@ reconsult(Fs) :-
!. !.
'$start_reconsulting'(F) :- '$start_reconsulting'(F) :-
'$recorda'('$reconsulted','$',_), recorda('$reconsulted','$',_),
'$recorda'('$reconsulting',F,_). recorda('$reconsulting',F,_).
'EMACS_FILE'(F,File0) :- 'EMACS_FILE'(F,File0) :-
'$format'('''EMACS_RECONSULT''(~w).~n',[File0]), '$format'('''EMACS_RECONSULT''(~w).~n',[File0]),
@ -133,21 +133,21 @@ reconsult(Fs) :-
'$open'(F,'$csult',Stream,0), '$open'(F,'$csult',Stream,0),
'$find_in_path'(File0,File,emacs(F)), '$find_in_path'(File0,File,emacs(F)),
'$open'(File,'$csult',Stream0,0), '$open'(File,'$csult',Stream0,0),
'$get_value'('$consulting_file',OldF), get_value('$consulting_file',OldF),
'$set_consulting_file'(Stream0), '$set_consulting_file'(Stream0),
H0 is heapused, '$cputime'(T0,_), H0 is heapused, '$cputime'(T0,_),
'$get_value'('$consulting',Old), get_value('$consulting',Old),
'$set_value'('$consulting',false), set_value('$consulting',false),
'$start_reconsulting'(File), '$start_reconsulting'(File),
'$start_consult'(reconsult,File,LC), '$start_consult'(reconsult,File,LC),
'$current_module'(OldModule), '$current_module'(OldModule),
'$recorda'('$initialisation','$',_), recorda('$initialisation','$',_),
'$print_message'(informational, loading(reconsulting, File)), '$print_message'(informational, loading(reconsulting, File)),
'$loop'(Stream,reconsult), '$loop'(Stream,reconsult),
'$end_consult', '$end_consult',
'$clear_reconsulting', '$clear_reconsulting',
'$set_value'('$consulting',Old), set_value('$consulting',Old),
'$set_value'('$consulting_file',OldF), set_value('$consulting_file',OldF),
'$cd'(OldD), '$cd'(OldD),
'$exec_initialisation_goals', '$exec_initialisation_goals',
'$current_module'(Mod,OldModule), '$current_module'(Mod,OldModule),
@ -165,7 +165,7 @@ reconsult(Fs) :-
'$initialization'(C) :- db_reference(C), !, '$initialization'(C) :- db_reference(C), !,
'$do_error'(type_error(callable,C),initialization(C)). '$do_error'(type_error(callable,C),initialization(C)).
'$initialization'(G) :- '$initialization'(G) :-
'$recorda'('$initialisation',G,_), recorda('$initialisation',G,_),
fail. fail.
'$initialization'(_). '$initialization'(_).
@ -184,13 +184,13 @@ reconsult(Fs) :-
; ;
'$do_error'(permission_error(input,stream,Y),include(X)) '$do_error'(permission_error(input,stream,Y),include(X))
), ),
'$set_value'('$included_file',OY). set_value('$included_file',OY).
'$do_startup_reconsult'(X) :- '$do_startup_reconsult'(X) :-
( '$access_yap_flags'(15, 0) -> ( '$access_yap_flags'(15, 0) ->
true true
; ;
'$set_value'('$verbose',off) set_value('$verbose',off)
), ),
( '$find_in_path'(X,Y,reconsult(X)), ( '$find_in_path'(X,Y,reconsult(X)),
'$open'(Y,'$csult',Stream,0) -> '$open'(Y,'$csult',Stream,0) ->
@ -209,9 +209,9 @@ reconsult(Fs) :-
prolog_load_context(_, _) :- prolog_load_context(_, _) :-
'$get_value'('$consulting_file',[]), !, fail. get_value('$consulting_file',[]), !, fail.
prolog_load_context(directory, DirName) :- prolog_load_context(directory, DirName) :-
'$get_value'('$consulting_file',FileName), get_value('$consulting_file',FileName),
(FileName = user_input -> (FileName = user_input ->
'$getcwd'(S), '$getcwd'(S),
atom_codes(DirName,S) atom_codes(DirName,S)
@ -221,16 +221,16 @@ prolog_load_context(directory, DirName) :-
atom_codes(DirName,Dir) atom_codes(DirName,Dir)
). ).
prolog_load_context(file, FileName) :- prolog_load_context(file, FileName) :-
'$get_value'('$included_file',IncFileName), get_value('$included_file',IncFileName),
( IncFileName = [] -> ( IncFileName = [] ->
'$get_value'('$consulting_file',FileName) get_value('$consulting_file',FileName)
; ;
FileName = IncFileName FileName = IncFileName
). ).
prolog_load_context(module, X) :- prolog_load_context(module, X) :-
'$current_module'(X). '$current_module'(X).
prolog_load_context(source, FileName) :- prolog_load_context(source, FileName) :-
'$get_value'('$consulting_file',FileName). get_value('$consulting_file',FileName).
prolog_load_context(stream, Stream) :- prolog_load_context(stream, Stream) :-
'$fetch_stream_alias'('$loop_stream', Stream). '$fetch_stream_alias'('$loop_stream', Stream).
prolog_load_context(term_position, Position) :- prolog_load_context(term_position, Position) :-
@ -240,7 +240,7 @@ prolog_load_context(term_position, Position) :-
'$loaded'(Stream,F1) :- '$loaded'(Stream,F1) :-
'$file_name'(Stream,F), % '$file_name'(Stream,F), %
'$recorded'('$loaded','$loaded'(F1,Age),R), recorded('$loaded','$loaded'(F1,Age),R),
'$same_file'(F1,F), !, '$same_file'(F1,F), !,
'$file_age'(F,CurrentAge), '$file_age'(F,CurrentAge),
((CurrentAge = Age ; Age = -1) -> true; erase(R), fail). ((CurrentAge = Age ; Age = -1) -> true; erase(R), fail).
@ -250,7 +250,7 @@ prolog_load_context(term_position, Position) :-
path(Path) :- findall(X,'$in_path'(X),Path). path(Path) :- findall(X,'$in_path'(X),Path).
'$in_path'(X) :- '$recorded'('$path',Path,_), '$in_path'(X) :- recorded('$path',Path,_),
atom_codes(Path,S), atom_codes(Path,S),
( S = "" -> X = '.' ; ( S = "" -> X = '.' ;
atom_codes(X,S) ). atom_codes(X,S) ).
@ -263,12 +263,12 @@ add_to_path(New,Pos) :-
atom_codes(Path,Str), atom_codes(Path,Str),
'$add_to_path'(Path,Pos). '$add_to_path'(Path,Pos).
'$add_to_path'(New,_) :- '$recorded'('$path',New,R), erase(R), fail. '$add_to_path'(New,_) :- recorded('$path',New,R), erase(R), fail.
'$add_to_path'(New,last) :- !, '$recordz'('$path',New,_). '$add_to_path'(New,last) :- !, '$recordz'('$path',New,_).
'$add_to_path'(New,first) :- '$recorda'('$path',New,_). '$add_to_path'(New,first) :- recorda('$path',New,_).
remove_from_path(New) :- '$check_path'(New,Path), remove_from_path(New) :- '$check_path'(New,Path),
'$recorded'('$path',Path,R), erase(R). recorded('$path',Path,R), erase(R).
'$check_path'(At,SAt) :- atom(At), !, atom_codes(At,S), '$check_path'(S,SAt). '$check_path'(At,SAt) :- atom(At), !, atom_codes(At,S), '$check_path'(S,SAt).
'$check_path'([],[]). '$check_path'([],[]).

2
pl/corout.yap
View File

@ -396,7 +396,7 @@ when(_,Goal) :-
'$generate_blocking_code'((Conds,OldConds), G, Code). '$generate_blocking_code'((Conds,OldConds), G, Code).
'$generate_blocking_code'(Conds, G, (G :- (If, !, when(When, G)))) :- '$generate_blocking_code'(Conds, G, (G :- (If, !, when(When, G)))) :-
'$extract_head_for_block'(Conds, G), '$extract_head_for_block'(Conds, G),
'$recorda'('$blocking_code','$code'(G,Conds),_), recorda('$blocking_code','$code'(G,Conds),_),
'$generate_body_for_block'(Conds, G, If, When). '$generate_body_for_block'(Conds, G, If, When).
% %

973
pl/debug.yap
View File

File diff suppressed because it is too large Load Diff

78
pl/directives.yap
View File

@ -115,8 +115,8 @@ yap_flag(V,Out) :-
'$show_yap_flag_opts'(V,Out). '$show_yap_flag_opts'(V,Out).
% do or do not machine code % do or do not machine code
yap_flag(fast,on) :- '$set_value'('$fast',true). yap_flag(fast,on) :- set_value('$fast',true).
yap_flag(fast,off) :- !, '$set_value'('$fast',[]). yap_flag(fast,off) :- !, set_value('$fast',[]).
% do or do not machine code % do or do not machine code
yap_flag(argv,L) :- '$argv'(L). yap_flag(argv,L) :- '$argv'(L).
@ -128,48 +128,48 @@ yap_flag(unhide,Atom) :- !, unhide(Atom).
% control garbage collection % control garbage collection
yap_flag(gc,V) :- yap_flag(gc,V) :-
var(V), !, var(V), !,
( '$get_value'('$gc',[]) -> V = off ; V = on). ( get_value('$gc',[]) -> V = off ; V = on).
yap_flag(gc,on) :- !, '$set_value'('$gc',true). yap_flag(gc,on) :- !, set_value('$gc',true).
yap_flag(gc,off) :- !, '$set_value'('$gc',[]). yap_flag(gc,off) :- !, set_value('$gc',[]).
yap_flag(gc_margin,N) :- yap_flag(gc_margin,N) :-
( var(N) -> ( var(N) ->
'$get_value'('$gc_margin',N) get_value('$gc_margin',N)
; ;
integer(N), N >0 -> integer(N), N >0 ->
'$set_value'('$gc_margin',N) set_value('$gc_margin',N)
; ;
'$do_error'(domain_error(flag_value,gc_margin+X),yap_flag(gc_margin,X)) '$do_error'(domain_error(flag_value,gc_margin+X),yap_flag(gc_margin,X))
). ).
yap_flag(gc_trace,V) :- yap_flag(gc_trace,V) :-
var(V), !, var(V), !,
'$get_value'('$gc_trace',N1), get_value('$gc_trace',N1),
'$get_value'('$gc_verbose',N2), get_value('$gc_verbose',N2),
'$get_value'('$gc_very_verbose',N3), get_value('$gc_very_verbose',N3),
'$yap_flag_show_gc_tracing'(N1, N2, N3, V). '$yap_flag_show_gc_tracing'(N1, N2, N3, V).
yap_flag(gc_trace,on) :- !, yap_flag(gc_trace,on) :- !,
'$set_value'('$gc_trace',true), set_value('$gc_trace',true),
'$set_value'('$gc_verbose',[]), set_value('$gc_verbose',[]),
'$set_value'('$gc_very_verbose',[]). set_value('$gc_very_verbose',[]).
yap_flag(gc_trace,verbose) :- !, yap_flag(gc_trace,verbose) :- !,
'$set_value'('$gc_trace',[]), set_value('$gc_trace',[]),
'$set_value'('$gc_verbose',true), set_value('$gc_verbose',true),
'$set_value'('$gc_very_verbose',[]). set_value('$gc_very_verbose',[]).
yap_flag(gc_trace,very_verbose) :- !, yap_flag(gc_trace,very_verbose) :- !,
'$set_value'('$gc_trace',[]), set_value('$gc_trace',[]),
'$set_value'('$gc_verbose',true), set_value('$gc_verbose',true),
'$set_value'('$gc_very_verbose',true). set_value('$gc_very_verbose',true).
yap_flag(gc_trace,off) :- yap_flag(gc_trace,off) :-
'$set_value'('$gc_trace',[]), set_value('$gc_trace',[]),
'$set_value'('$gc_verbose',[]), set_value('$gc_verbose',[]),
'$set_value'('$gc_very_verbose',[]). set_value('$gc_very_verbose',[]).
yap_flag(syntax_errors, V) :- var(V), !, yap_flag(syntax_errors, V) :- var(V), !,
'$get_read_error_handler'(V). '$get_read_error_handler'(V).
yap_flag(syntax_errors, Option) :- yap_flag(syntax_errors, Option) :-
'$set_read_error_handler'(Option). '$set_read_error_handler'(Option).
% compatibility flag % compatibility flag
yap_flag(enhanced,on) :- !, '$set_value'('$enhanced',true). yap_flag(enhanced,on) :- !, set_value('$enhanced',true).
yap_flag(enhanced,off) :- '$set_value'('$enhanced',[]). yap_flag(enhanced,off) :- set_value('$enhanced',[]).
% %
% show state of $ % show state of $
% %
@ -224,9 +224,9 @@ yap_flag(index,X) :-
yap_flag(informational_messages,X) :- var(X), !, yap_flag(informational_messages,X) :- var(X), !,
'$get_value'('$verbose',X). get_value('$verbose',X).
yap_flag(informational_messages,on) :- !, '$set_value'('$verbose',on). yap_flag(informational_messages,on) :- !, set_value('$verbose',on).
yap_flag(informational_messages,off) :- !, '$set_value'('$verbose',off). yap_flag(informational_messages,off) :- !, set_value('$verbose',off).
yap_flag(informational_messages,X) :- yap_flag(informational_messages,X) :-
'$do_error'(domain_error(flag_value,informational_messages+X),yap_flag(informational_messages,X)). '$do_error'(domain_error(flag_value,informational_messages+X),yap_flag(informational_messages,X)).
@ -252,7 +252,7 @@ yap_flag(max_arity,X) :-
yap_flag(version,X) :- yap_flag(version,X) :-
var(X), !, var(X), !,
'$get_value'('$version_name',X). get_value('$version_name',X).
yap_flag(version,X) :- yap_flag(version,X) :-
'$do_error'(permission_error(modify,flag,version),yap_flag(version,X)). '$do_error'(permission_error(modify,flag,version),yap_flag(version,X)).
@ -344,7 +344,7 @@ yap_flag(language,X) :-
yap_flag(debug,X) :- yap_flag(debug,X) :-
var(X), !, var(X), !,
('$get_value'(debug,1) -> (get_value(debug,1) ->
X = on X = on
; ;
X = off X = off
@ -446,7 +446,7 @@ yap_flag(update_semantics,X) :-
yap_flag(toplevel_hook,X) :- yap_flag(toplevel_hook,X) :-
var(X), !, var(X), !,
( '$recorded'('$toplevel_hooks',G,_) -> G ; true ). ( recorded('$toplevel_hooks',G,_) -> G ; true ).
yap_flag(toplevel_hook,G) :- !, yap_flag(toplevel_hook,G) :- !,
'$set_toplevel_hook'(G). '$set_toplevel_hook'(G).
@ -504,33 +504,33 @@ yap_flag(user_error,Stream) :-
yap_flag(debugger_print_options,OUT) :- yap_flag(debugger_print_options,OUT) :-
var(OUT), var(OUT),
'$recorded'('$print_options','$debugger'(OUT),_), !. recorded('$print_options','$debugger'(OUT),_), !.
yap_flag(debugger_print_options,Opts) :- !, yap_flag(debugger_print_options,Opts) :- !,
'$check_io_opts'(Opts, yap_flag(debugger_print_options,Opts)), '$check_io_opts'(Opts, yap_flag(debugger_print_options,Opts)),
'$recorda'('$print_options','$debugger'(Opts),_). recorda('$print_options','$debugger'(Opts),_).
:- '$recorda'('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(10)]),_). :- recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(10)]),_).
yap_flag(toplevel_print_options,OUT) :- yap_flag(toplevel_print_options,OUT) :-
var(OUT), var(OUT),
'$recorded'('$print_options','$toplevel'(OUT),_), !. recorded('$print_options','$toplevel'(OUT),_), !.
yap_flag(toplevel_print_options,Opts) :- !, yap_flag(toplevel_print_options,Opts) :- !,
'$check_io_opts'(Opts, yap_flag(toplevel_print_options,Opts)), '$check_io_opts'(Opts, yap_flag(toplevel_print_options,Opts)),
'$recorda'('$print_options','$toplevel'(Opts),_). recorda('$print_options','$toplevel'(Opts),_).
yap_flag(fileerrors,OUT) :- yap_flag(fileerrors,OUT) :-
var(OUT), !, var(OUT), !,
'$get_value'(fileerrors,X0), get_value(fileerrors,X0),
(X0 = [] -> X= 0 ; X = X0), (X0 = [] -> X= 0 ; X = X0),
'$transl_to_on_off'(X,OUT). '$transl_to_on_off'(X,OUT).
yap_flag(fileerrors,on) :- !, yap_flag(fileerrors,on) :- !,
'$set_value'(fileerrors,1). set_value(fileerrors,1).
yap_flag(fileerrors,off) :- !, yap_flag(fileerrors,off) :- !,
'$set_value'(fileerrors,0). set_value(fileerrors,0).
yap_flag(fileerrors,X) :- yap_flag(fileerrors,X) :-
'$do_error'(domain_error(flag_value,fileerrors+X),yap_flag(fileerrors,X)). '$do_error'(domain_error(flag_value,fileerrors+X),yap_flag(fileerrors,X)).
:- '$recorda'('$print_options','$toplevel'([quoted(true),numbervars(true),portrayed(true)]),_). :- recorda('$print_options','$toplevel'([quoted(true),numbervars(true),portrayed(true)]),_).
yap_flag(host_type,X) :- yap_flag(host_type,X) :-
'$host_type'(X). '$host_type'(X).

2
pl/errors.yap
View File

@ -66,7 +66,7 @@ print_message(Level, Mss) :-
'$print_message'(error,Throw) :- '$print_message'(error,Throw) :-
'$format'(user_error,"[ No handler for error ~w ]~n", [Throw]). '$format'(user_error,"[ No handler for error ~w ]~n", [Throw]).
'$print_message'(informational,M) :- '$print_message'(informational,M) :-
( '$get_value'('$verbose',on) -> ( get_value('$verbose',on) ->
'$do_informational_message'(M) ; '$do_informational_message'(M) ;
true true
). ).

8
pl/init.yap
View File

@ -35,7 +35,7 @@ false :- fail.
not(G) :- '$current_module'(Module), '$meta_call'(not(G),Module). not(G) :- '$current_module'(Module), '$meta_call'(not(G),Module).
:- '$set_value'('$doindex',true). :- set_value('$doindex',true).
:- ['errors.yap', :- ['errors.yap',
'utils.yap', 'utils.yap',
@ -70,8 +70,8 @@ not(G) :- '$current_module'(Module), '$meta_call'(not(G),Module).
version(yap,[4,1]). version(yap,[4,1]).
system_mode(verbose,on) :- '$set_value'('$verbose',on). system_mode(verbose,on) :- set_value('$verbose',on).
system_mode(verbose,off) :- '$set_value'('$verbose',off). system_mode(verbose,off) :- set_value('$verbose',off).
:- op(1150,fx,(mode)). :- op(1150,fx,(mode)).
@ -113,7 +113,7 @@ system_mode(verbose,off) :- '$set_value'('$verbose',off).
% %
:- ( recorded('$loaded','$loaded'(_,_),R), erase(R), fail ; true ). :- ( recorded('$loaded','$loaded'(_,_),R), erase(R), fail ; true ).
:- '$set_value'('$user_module',user), '$protect'. :- set_value('$user_module',user), '$protect'.
:- style_check([]). :- style_check([]).

5
pl/listing.yap
View File

@ -55,6 +55,11 @@ listing(V) :-
'$funcspec'(Name,_,_) :- '$funcspec'(Name,_,_) :-
'$do_error'(domain_error(predicate_spec,Name),listing(Name)). '$do_error'(domain_error(predicate_spec,Name),listing(Name)).
'$list_clauses'(Stream, Mod, Pred) :-
'$is_log_updatable'(Pred, Mod), !,
'$log_update_clause'(Pred,Mod,Body),
'$portray_clause'(Stream,(Pred:-Body)),
fail.
'$list_clauses'(Stream, M, Pred) :- '$list_clauses'(Stream, M, Pred) :-
( '$recordedp'(M:Pred,_,_) -> nl(Stream) ), ( '$recordedp'(M:Pred,_,_) -> nl(Stream) ),
fail. fail.

36
pl/modules.yap
View File

@ -17,8 +17,6 @@
% module handling % module handling
:- '$switch_log_upd'(1).
use_module(M) :- use_module(M) :-
'$use_module'(M). '$use_module'(M).
@ -35,7 +33,7 @@ use_module(M) :-
'$change_module'(M0). '$change_module'(M0).
'$use_module'(File) :- '$use_module'(File) :-
'$find_in_path'(File,X,use_module(File)), !, '$find_in_path'(File,X,use_module(File)), !,
( '$recorded'('$module','$module'(_,X,Publics),_) -> ( recorded('$module','$module'(_,X,Publics),_) ->
'$use_module'(File,Publics) '$use_module'(File,Publics)
; ;
'$ensure_loaded'(File) '$ensure_loaded'(File)
@ -64,12 +62,12 @@ use_module(M,I) :-
; ;
% the following avoids import of all public predicates % the following avoids import of all public predicates
'$consulting_file_name'(Stream,TrueFileName), '$consulting_file_name'(Stream,TrueFileName),
'$recorda'('$importing','$importing'(TrueFileName),R), recorda('$importing','$importing'(TrueFileName),R),
'$reconsult'(File,Stream) '$reconsult'(File,Stream)
), ),
'$close'(Stream), '$close'(Stream),
( var(R) -> true; erased(R) -> true; erase(R)), ( var(R) -> true; erased(R) -> true; erase(R)),
( '$recorded'('$module','$module'(TrueFileName,Mod,Publics),_) -> ( recorded('$module','$module'(TrueFileName,Mod,Publics),_) ->
'$use_preds'(Imports,Publics,Mod,M) '$use_preds'(Imports,Publics,Mod,M)
; ;
'$format'(user_error,"[ use_module/2 can not find a module in file ~w]~n",File), '$format'(user_error,"[ use_module/2 can not find a module in file ~w]~n",File),
@ -99,13 +97,13 @@ use_module(Mod,F,I) :-
; ;
'$consulting_file_name'(Stream,TrueFileName), '$consulting_file_name'(Stream,TrueFileName),
% the following avoids import of all public predicates % the following avoids import of all public predicates
'$recorda'('$importing','$importing'(TrueFileName),R), recorda('$importing','$importing'(TrueFileName),R),
'$reconsult'(File,Stream) '$reconsult'(File,Stream)
), ),
'$close'(Stream), '$close'(Stream),
( var(R) -> true; erased(R) -> true; erase(R)), ( var(R) -> true; erased(R) -> true; erase(R)),
( (
'$recorded'('$module','$module'(TrueFileName,Module,Publics),_) recorded('$module','$module'(TrueFileName,Module,Publics),_)
-> ->
'$use_preds'(Imports,Publics,Module,M) '$use_preds'(Imports,Publics,Module,M)
; ;
@ -123,7 +121,7 @@ use_module(Mod,F,I) :-
'$abolish_module_data'(N), '$abolish_module_data'(N),
'$module_dec'(N,P). '$module_dec'(N,P).
'$module'(consult,N,P) :- '$module'(consult,N,P) :-
( '$recorded'('$module','$module'(F,N,_),_), ( recorded('$module','$module'(F,N,_),_),
'$format'(user_error,"[ Module ~w was already defined in file ~w]~n",[N,F]), '$format'(user_error,"[ Module ~w was already defined in file ~w]~n",[N,F]),
'$abolish_module_data'(N), '$abolish_module_data'(N),
fail fail
@ -172,7 +170,7 @@ use_module(Mod,F,I) :-
'$prepare_restore_hidden'(Old,Old) :- !. '$prepare_restore_hidden'(Old,Old) :- !.
'$prepare_restore_hidden'(Old,New) :- '$prepare_restore_hidden'(Old,New) :-
'$recorda'('$system_initialisation', source_mode(New,Old), _). recorda('$system_initialisation', source_mode(New,Old), _).
module(N) :- module(N) :-
var(N), var(N),
@ -180,7 +178,7 @@ module(N) :-
module(N) :- module(N) :-
atom(N), !, atom(N), !,
'$current_module'(_,N), '$current_module'(_,N),
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true), ( recordzifnot('$module','$module'(N),_) -> true; true),
( recorded('$module','$module'(F,N,[]),_) -> ( recorded('$module','$module'(F,N,[]),_) ->
true ; true ;
@ -191,10 +189,10 @@ module(N) :-
'$module_dec'(N,P) :- '$module_dec'(N,P) :-
'$current_module'(Old,N), '$current_module'(Old,N),
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true), ( recordzifnot('$module','$module'(N),_) -> true; true),
recorda('$module','$module'(F,N,P),_), recorda('$module','$module'(F,N,P),_),
( '$recorded'('$importing','$importing'(F),_) -> ( recorded('$importing','$importing'(F),_) ->
true true
; ;
'$import'(P,N,Old) '$import'(P,N,Old)
@ -219,7 +217,7 @@ module(N) :-
'$import'(L,M,T). '$import'(L,M,T).
'$check_import'(M,T,N,K) :- '$check_import'(M,T,N,K) :-
'$recorded'('$import','$import'(M1,T0,N,K),R), T0 == T, M1 \= M, /* ZP */ !, recorded('$import','$import'(M1,T0,N,K),R), T0 == T, M1 \= M, /* ZP */ !,
'$format'(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[M1:N/K,T]), '$format'(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[M1:N/K,T]),
'$format'(user_error," Do you want to import it from ~w ? [y or n] ",M), '$format'(user_error," Do you want to import it from ~w ? [y or n] ",M),
repeat, repeat,
@ -256,8 +254,8 @@ module(N) :-
'$abolish_module_data'(M) :- '$abolish_module_data'(M) :-
'$current_module'(T), '$current_module'(T),
( '$recorded'('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true), ( recorded('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true),
'$recorded'('$module','$module'(_,M,_),R), recorded('$module','$module'(_,M,_),R),
erase(R), erase(R),
fail. fail.
'$abolish_module_data'(_). '$abolish_module_data'(_).
@ -325,7 +323,7 @@ module(N) :-
'$expand_goal2'(G, M, NG, NM) :- '$expand_goal2'(G, M, NG, NM) :-
'$undefined'(G,M), '$undefined'(G,M),
functor(G,F,N), functor(G,F,N),
'$recorded'('$import','$import'(ExportingMod,M,F,N),_), recorded('$import','$import'(ExportingMod,M,F,N),_),
ExportingMod \= M, ExportingMod \= M,
!, !,
'$expand_goal2'(G, ExportingMod, NG, NM). '$expand_goal2'(G, ExportingMod, NG, NM).
@ -405,7 +403,7 @@ module(N) :-
'$imported_pred'(G, ImportingMod, ExportingMod) :- '$imported_pred'(G, ImportingMod, ExportingMod) :-
'$undefined'(G, ImportingMod), '$undefined'(G, ImportingMod),
functor(G,F,N), functor(G,F,N),
'$recorded'('$import','$import'(ExportingMod,ImportingMod,F,N),_), recorded('$import','$import'(ExportingMod,ImportingMod,F,N),_),
ExportingMod \= ImportingMod. ExportingMod \= ImportingMod.
% args are: % args are:
@ -534,7 +532,7 @@ current_module(Mod) :-
current_module(Mod,TFN) :- current_module(Mod,TFN) :-
'$all_current_modules'(Mod), '$all_current_modules'(Mod),
( '$recorded'('$module','$module'(TFN,Mod,_Publics),_) -> true ; TFN = user ). ( recorded('$module','$module'(TFN,Mod,_Publics),_) -> true ; TFN = user ).
source_module(Mod) :- source_module(Mod) :-
'$current_module'(Mod). '$current_module'(Mod).
@ -542,6 +540,7 @@ source_module(Mod) :-
'$member'(X,[X|_]) :- !. '$member'(X,[X|_]) :- !.
'$member'(X,[_|L]) :- '$member'(X,L). '$member'(X,[_|L]) :- '$member'(X,L).
:- meta_predicate :- meta_predicate
% [:,:], % [:,:],
abolish(:), abolish(:),
@ -643,5 +642,4 @@ source_module(Mod) :-
'$system_predicate'(G,M), !. '$system_predicate'(G,M), !.
'$preprocess_body_before_mod_change'(G,M,_,M:G). '$preprocess_body_before_mod_change'(G,M,_,M:G).
:- '$switch_log_upd'(0).

176
pl/preds.yap
View File

@ -40,24 +40,60 @@ assert(C) :-
'$do_error'(instantiation_error,assert(Mod:V)). '$do_error'(instantiation_error,assert(Mod:V)).
'$assert'(M:C,_,Where,R,P) :- !, '$assert'(M:C,_,Where,R,P) :- !,
'$assert'(C,M,Where,R,P). '$assert'(C,M,Where,R,P).
'$assert'((H:-G),M1,Where,R,P) :- '$assert'((H:-G),M1,Where,R,P) :- !,
(var(H) -> '$do_error'(instantiation_error,P) ; H=M:C), !, '$assert_clause'(H, G, M1, Where, R, P).
( M1 = M -> '$assert'(H,M1,Where,R,_) :-
'$assert'((C:-G),M1,Where,R,P) '$assert_fact'(H, M1, Where, R).
;
'$assert_clause'(H, G, M1, Where, R, P) :-
var(H), !, '$do_error'(instantiation_error,P).
'$assert_clause'(M1:C, G, M1, Where, R, P) :- !,
'$assert_clause2'(C, G, M1, Where, R, P).
'$assert_clause'(M:C, G, M1, Where, R, P) :- !,
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1), '$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
'$assert'(C1,M,Where,R,P) C1 = (MH :- NG),
). '$assert_clause2'(NH, NG, M, Where, R, P).
'$assert'(CI,Mod,Where,R,P) :- '$assert_clause'(H, G, M1, Where, R, P) :- !,
'$expand_clause'(CI,C0,C,Mod), '$assert_clause2'(H, G, M1, Where, R, P).
'$check_head_and_body'(C,H,B,P),
'$assert_fact'(H,Mod,Where,R) :-
'$is_log_updatable'(H, Mod), !,
(Where = first -> Pos = 2 ; Pos = 0),
'$compile_dynamic'(H, Pos, H, Mod, R).
'$assert_fact'(H,Mod,Where,R) :-
( '$is_dynamic'(H, Mod) -> ( '$is_dynamic'(H, Mod) ->
'$assertat_d'(Where, H, true, H, Mod, R)
;
'$undefined'(H,Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod),
'$assert_fact'(H,Mod,Where,R)
;
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
'$assert1'(Where,H,H,Mod,H)
;
functor(H, Na, Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
).
'$assert_clause2'(HI,BI,Mod,Where,R,P) :-
'$expand_clause'((HI :- BI),C0,C,Mod),
'$assert_clause3'(C0,C,Mod,Where,R,P).
'$assert_clause3'(C0,C,Mod,Where,R,P) :-
'$check_head_and_body'(C,H,B,P),
( '$is_log_updatable'(H, Mod) ->
(Where = first -> Pos = 2 ; Pos = 0),
'$compile_dynamic'((H :- B), Pos, C0, Mod, R)
;
'$is_dynamic'(H, Mod) ->
'$assertat_d'(Where, H, B, C0, Mod, R) '$assertat_d'(Where, H, B, C0, Mod, R)
; ;
'$undefined'(H,Mod) -> '$undefined'(H,Mod) ->
functor(H, Na, Ar), functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod), '$dynamic'(Na/Ar, Mod),
'$assertat_d'(Where,H,B,C0,Mod,R) '$assert_clause3'(C0,C,Mod,Where,R,P)
; ;
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode '$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
'$assert1'(Where,C,C0,Mod,H) '$assert1'(Where,C,C0,Mod,H)
@ -81,14 +117,21 @@ assert(C) :-
). ).
'$assert_dynamic'(CI,Mod,Where,R,P) :- '$assert_dynamic'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod), '$expand_clause'(CI,C0,C,Mod),
'$assert_dynamic2'(C0,C,Mod,Where,R,P).
'$assert_dynamic2'(C0,C,Mod,Where,R,P) :-
'$check_head_and_body'(C,H,B,P), '$check_head_and_body'(C,H,B,P),
( '$is_dynamic'(H, Mod) -> ( '$is_log_updatable'(H, Mod) ->
(Where = first -> Pos = 2 ; Pos = 0),
'$compile_dynamic'(C, Pos, C0, Mod, R)
;
'$is_dynamic'(H, Mod) ->
'$assertat_d'(Where,H,B,C0,Mod,R) '$assertat_d'(Where,H,B,C0,Mod,R)
; ;
'$undefined'(H, Mod) -> '$undefined'(H, Mod) ->
functor(H, Na, Ar), functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod), '$dynamic'(Na/Ar, Mod),
'$assertat_d'(Where,H,B,C0,Mod,R) '$assert_dynamic2'(C0,C,Mod,Where,R,P)
; ;
functor(H,Na,Ar), functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P) '$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
@ -130,7 +173,7 @@ assertz_static(C) :-
( '$is_dynamic'(H, Mod) -> ( '$is_dynamic'(H, Mod) ->
'$do_error'(permission_error(modify,dynamic_procedure,Na/Ar),P) '$do_error'(permission_error(modify,dynamic_procedure,Na/Ar),P)
; ;
'$undefined'(H,Mod), '$get_value'('$full_iso',true) -> '$undefined'(H,Mod), get_value('$full_iso',true) ->
functor(H,Na,Ar), '$dynamic'(Na/Ar, Mod), '$assertat_d'(Where,H,B,C0,Mod,R) functor(H,Na,Ar), '$dynamic'(Na/Ar, Mod), '$assertat_d'(Where,H,B,C0,Mod,R)
; ;
'$assert1'(Where,C,C0,Mod,H) '$assert1'(Where,C,C0,Mod,H)
@ -138,8 +181,8 @@ assertz_static(C) :-
'$assertat_d'(first,Head,Body,C0,Mod,R) :- !, '$assertat_d'(first,Head,Body,C0,Mod,R) :- !,
'$compile_dynamic'((Head:-Body), 2, Mod, CR), '$compile_dynamic'((Head:-Body), 2, C0, Mod, CR),
( '$get_value'('$abol',true) ( get_value('$abol',true)
-> ->
'$flags'(Head,Mod,Fl,Fl), '$flags'(Head,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ), ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ),
@ -150,15 +193,15 @@ assertz_static(C) :-
'$head_and_body'(C0, H0, B0), '$head_and_body'(C0, H0, B0),
'$recordap'(Mod:Head,(H0 :- B0),R,CR), '$recordap'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(Head, Mod) -> ( '$is_multifile'(Head, Mod) ->
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
functor(H0, Na, Ar), functor(H0, Na, Ar),
'$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _) recorda('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
; ;
true true
). ).
'$assertat_d'(last,Head,Body,C0,Mod,R) :- '$assertat_d'(last,Head,Body,C0,Mod,R) :-
'$compile_dynamic'((Head:-Body), 0, Mod, CR), '$compile_dynamic'((Head:-Body), 0, C0, Mod, CR),
( '$get_value'('$abol',true) ( get_value('$abol',true)
-> ->
'$flags'(Head,Mod,Fl,Fl), '$flags'(Head,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ), ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ),
@ -169,9 +212,9 @@ assertz_static(C) :-
'$head_and_body'(C0, H0, B0), '$head_and_body'(C0, H0, B0),
'$recordzp'(Mod:Head,(H0 :- B0),R,CR), '$recordzp'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(H0, Mod) -> ( '$is_multifile'(H0, Mod) ->
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
functor(H0, Na, Ar), functor(H0, Na, Ar),
'$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _) recordz('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
; ;
true true
). ).
@ -204,7 +247,7 @@ assertz_static(C) :-
'$remove_all_d_clauses'(_,_). '$remove_all_d_clauses'(_,_).
'$erase_all_mf_dynamic'(Na,A,M) :- '$erase_all_mf_dynamic'(Na,A,M) :-
'$get_value'('$consulting_file',F), get_value('$consulting_file',F),
'$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1), '$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1), erase(R1),
erase(R), erase(R),
@ -235,6 +278,20 @@ clause(V,Q) :-
'$current_module'(M), '$current_module'(M),
'$clause'(V,M,Q,R). '$clause'(V,M,Q,R).
'$clause'(V,M,Q) :- var(V), !,
'$do_error'(instantiation_error,M:clause(V,Q)).
'$clause'(C,M,Q) :- number(C), !,
'$do_error'(type_error(callable,C),M:clause(C,Q)).
'$clause'(R,M,Q) :- db_reference(R), !,
'$do_error'(type_error(callable,R),M:clause(R,Q)).
'$clause'(M:P,_,Q) :- !,
'$clause'(P,M,Q).
'$clause'(P,M,Q) :-
'$is_log_updatable'(P, M), !,
'$log_update_clause'(P,M,Q).
'$clause'(P,M,Q) :-
'$clause'(P,M,Q,_).
clause(M:P,Q,R) :- !, clause(M:P,Q,R) :- !,
'$clause'(P,M,Q,R). '$clause'(P,M,Q,R).
clause(V,Q,R) :- clause(V,Q,R) :-
@ -249,6 +306,9 @@ clause(V,Q,R) :-
'$do_error'(type_error(callable,R),M:clause(R,Q)). '$do_error'(type_error(callable,R),M:clause(R,Q)).
'$clause'(M:P,_,Q,R) :- !, '$clause'(M:P,_,Q,R) :- !,
'$clause'(P,M,Q,R). '$clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$is_log_updatable'(P, M), !,
'$log_update_clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :- '$clause'(P,M,Q,R) :-
'$some_recordedp'(M:P), !, '$some_recordedp'(M:P), !,
'$recordedp'(M:P,(P:-Q),R). '$recordedp'(M:P,(P:-Q),R).
@ -260,6 +320,22 @@ clause(V,Q,R) :-
'$do_error'(permission_error(access,private_procedure,Name/Arity), '$do_error'(permission_error(access,private_procedure,Name/Arity),
clause(M:P,Q)). clause(M:P,Q)).
% just create a choice-point
'$do_log_upd_clause'(_,_,_,_,_).
'$do_log_upd_clause'(A,B,C,D,E) :-
'$continue_log_update_clause'(A,B,C,D,E).
'$do_log_upd_clause'(A,B,C,D,E).
'$do_log_upd_clause'(_,_,_,_).
'$do_log_upd_clause'(A,B,C,D) :-
'$continue_log_update_clause'(A,B,C,D).
'$do_log_upd_clause'(A,B,C,D).
'$do_log_upd_retract'(_,_,_,_).
'$do_log_upd_retract'(A,B,C,D) :-
'$continue_log_update_retract'(A,B,C,D).
'$do_log_upd_retract'(A,B,C,D).
nth_clause(P,I,R) :- nonvar(R), !, nth_clause(P,I,R) :- nonvar(R), !,
'$nth_instancep'(P,I,R). '$nth_instancep'(P,I,R).
nth_clause(M:V,I,R) :- !, nth_clause(M:V,I,R) :- !,
@ -299,18 +375,23 @@ retract(C) :-
'$retract'(M:C,_) :- !, '$retract'(M:C,_) :- !,
'$retract'(C,M). '$retract'(C,M).
'$retract'(C,M) :- '$retract'(C,M) :-
'$check_head_and_body'(C,H,B,retract(M:C)), '$check_head_and_body'(C,H,B,retract(M:C)), !,
'$retract2'(H,M,B).
'$retract2'(H,M,B) :-
'$is_log_updatable'(H, M), !,
'$log_update_retract'(H,M,B).
'$retract2'(H,M,B) :-
'$is_dynamic'(H,M), !, '$is_dynamic'(H,M), !,
'$recordedp'(M:H,(H:-B),R), erase(R). '$recordedp'(M:H,(H:-B),R), erase(R).
'$retract'(C,M) :- '$retract2'(H,M,B) :-
'$check_head_and_body'(C,H,B,retract(M:C)),
'$undefined'(H,M), !, '$undefined'(H,M), !,
functor(H,Na,Ar), functor(H,Na,Ar),
'$dynamic'(Na/Ar,M), '$dynamic'(Na/Ar,M),
fail. fail.
'$retract'(C,M) :- '$retract2'(H,M,B) :-
'$fetch_predicate_indicator_from_clause'(C, PI), functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)). '$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
retract(M:C,R) :- !, retract(M:C,R) :- !,
'$retract'(C,M,R). '$retract'(C,M,R).
@ -359,15 +440,26 @@ retractall(V) :-
'$retractall'(M:V,_) :- !, '$retractall'(M:V,_) :- !,
'$retractall'(V,M). '$retractall'(V,M).
'$retractall'(T,M) :- '$retractall'(T,M) :-
'$undefined'(T,M), (
'$is_log_updatable'(T, M) ->
'$retractall_lu'(T,M)
;
'$undefined'(T,M) ->
functor(T,Na,Ar), functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !. '$dynamic'(Na/Ar,M), !
'$retractall'(T,M) :- ;
\+ '$is_dynamic'(T,M), !, '$is_dynamic'(T,M) ->
'$erase_all_clauses_for_dynamic'(T, M)
;
functor(T,Na,Ar), functor(T,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T)). '$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
'$retractall'(T,M) :- ).
'$erase_all_clauses_for_dynamic'(T, M).
'$retractall_lu'(T,M) :-
'$log_update_retract'(T,M,_),
fail.
'$retractall_lu'(_,_).
'$erase_all_clauses_for_dynamic'(T, M) :- '$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail. '$recordedp'(M:T,(T :- _),R), erase(R), fail.
@ -386,7 +478,7 @@ abolish(N,A) :-
'$abolish'(N,A,M) :- var(A), !, '$abolish'(N,A,M) :- var(A), !,
'$do_error'(instantiation_error,abolish(M:N,A)). '$do_error'(instantiation_error,abolish(M:N,A)).
'$abolish'(N,A,M) :- '$abolish'(N,A,M) :-
( '$recorded'('$predicate_defs','$predicate_defs'(N,A,M,_),R) -> erase(R) ), ( recorded('$predicate_defs','$predicate_defs'(N,A,M,_),R) -> erase(R) ),
fail. fail.
'$abolish'(N,A,M) :- functor(T,N,A), '$abolish'(N,A,M) :- functor(T,N,A),
( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ; ( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ;
@ -591,7 +683,7 @@ dynamic_predicate(P,Sem) :-
'$expand_clause'(C0,C1,C2,Mod) :- '$expand_clause'(C0,C1,C2,Mod) :-
'$expand_term_modules'(C0, C1, C2, Mod), '$expand_term_modules'(C0, C1, C2, Mod),
( '$get_value'('$strict_iso',on) -> ( get_value('$strict_iso',on) ->
'$check_iso_strict_clause'(C1) '$check_iso_strict_clause'(C1)
; ;
true true
@ -660,14 +752,14 @@ predicate_property(Pred,Prop) :-
'$predicate_property'(Pred,Mod,Mod,Prop). '$predicate_property'(Pred,Mod,Mod,Prop).
'$predicate_property2'(Pred,Prop,Mod) :- '$predicate_property2'(Pred,Prop,Mod) :-
functor(Pred, N, K), functor(Pred, N, K),
'$recorded'('$import','$import'(M,Mod,N,K),_), recorded('$import','$import'(M,Mod,N,K),_),
'$predicate_property'(Pred,M,Mod,Prop). '$predicate_property'(Pred,M,Mod,Prop).
'$generate_all_preds_from_mod'(Pred, M, M) :- '$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(M,Na,Ar), '$current_predicate'(M,Na,Ar),
functor(Pred, Na, Ar). functor(Pred, Na, Ar).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :- '$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
'$recorded'('$import','$import'(SourceMod,Mod,N,K),_), recorded('$import','$import'(SourceMod,Mod,N,K),_),
functor(Pred, N, K). functor(Pred, N, K).
@ -687,12 +779,12 @@ predicate_property(Pred,Prop) :-
'$is_multifile'(P,M). '$is_multifile'(P,M).
'$predicate_property'(P,Mod,M,imported_from(Mod)) :- '$predicate_property'(P,Mod,M,imported_from(Mod)) :-
functor(P,N,K), functor(P,N,K),
'$recorded'('$import','$import'(Mod,M,N,K),_). recorded('$import','$import'(Mod,M,N,K),_).
'$predicate_property'(P,M,_,public) :- '$predicate_property'(P,M,_,public) :-
'$is_public'(P,M). '$is_public'(P,M).
'$predicate_property'(P,M,M,exported) :- '$predicate_property'(P,M,M,exported) :-
functor(P,N,A), functor(P,N,A),
'$recorded'('$module','$module'(_TFN,M,Publics),_), recorded('$module','$module'(_TFN,M,Publics),_),
'$member'(N/A,Publics), !. /* defined in modules.yap */ '$member'(N/A,Publics), !. /* defined in modules.yap */
'$predicate_property'(P,Mod,_,number_of_clauses(NCl)) :- '$predicate_property'(P,Mod,_,number_of_clauses(NCl)) :-
'$number_of_clauses'(P,Mod,NCl). '$number_of_clauses'(P,Mod,NCl).

10
pl/setof.yap
View File

@ -199,17 +199,17 @@ bagof(Template, Generator, Bag) :-
% if you want them use findall % if you want them use findall
all(T,G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X). all(T,G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X).
all(T,G,S) :- '$recorda'('$$one','$',R), ( all(T,G,S) :- recorda('$$one','$',R), (
'$execute'(G), '$recorda'('$$one',T,_), fail ; '$execute'(G), recorda('$$one',T,_), fail ;
'$$set'(S,R) ). '$$set'(S,R) ).
% $$set does its best to preserve space % $$set does its best to preserve space
'$$set'(S,R) :- '$$build'(S,[],R), '$$set'(S,R) :- '$$build'(S,[],R),
( S=[], !, fail; ( S=[], !, fail;
'$recorda'('$$set',S,_), fail ). recorda('$$set',S,_), fail ).
'$$set'(S,_) :- '$recorded'('$$set',S,R), erase(R). '$$set'(S,_) :- recorded('$$set',S,R), erase(R).
'$$build'(Ns,S,Start) :- '$recorded'('$$one',X,R), erase(R), '$$build'(Ns,S,Start) :- recorded('$$one',X,R), erase(R),
( Start==R, Ns=S; ( Start==R, Ns=S;
'$$join'(S,X,Xs), '$$build'(Ns,Xs,Start) ), !. '$$join'(S,X,Xs), '$$build'(Ns,Xs,Start) ), !.

40
pl/utils.yap
View File

@ -254,7 +254,7 @@ alarm(_, _, _) :-
recorded('$alarm_handler',_, Ref), erase(Ref), fail. recorded('$alarm_handler',_, Ref), erase(Ref), fail.
alarm(Interval, Goal, Left) :- alarm(Interval, Goal, Left) :-
'$current_module'(M), '$current_module'(M),
'$recordz'('$alarm_handler',M:Goal,_), recordz('$alarm_handler',M:Goal,_),
'$alarm'(Interval, Left). '$alarm'(Interval, Left).
on_signal(Signal,OldAction,default) :- on_signal(Signal,OldAction,default) :-
@ -264,7 +264,7 @@ on_signal(Signal,OldAction,Action) :-
recorded('$sig_handler', action(Signal,OldAction), Ref), recorded('$sig_handler', action(Signal,OldAction), Ref),
erase(Ref), erase(Ref),
'$current_module'(M), '$current_module'(M),
'$recordz'('$sig_handler', action(Signal,M:Action), _). recordz('$sig_handler', action(Signal,M:Action), _).
%%% Saving and restoring a computation %%% Saving and restoring a computation
@ -292,7 +292,7 @@ save_program(A, G) :- \+ callable(G), !,
'$do_error'(type_error(callable,G),save_program(A,G)). '$do_error'(type_error(callable,G),save_program(A,G)).
save_program(A, G) :- save_program(A, G) :-
( atom(A) -> name(A,S) ; A = S), ( atom(A) -> name(A,S) ; A = S),
'$recorda'('$restore_goal',G,R), recorda('$restore_goal',G,R),
'$save_program'(S), '$save_program'(S),
erase(R), erase(R),
fail. fail.
@ -303,18 +303,10 @@ restore(A) :- var(A), !,
restore(A) :- atom(A), !, name(A,S), '$restore'(S). restore(A) :- atom(A), !, name(A,S), '$restore'(S).
restore(S) :- '$restore'(S). restore(S) :- '$restore'(S).
%%% Data base predicates -> the interface to the external world recordaifnot(K,T,R) :-
( recorded(K,T,R) -> fail ; recorda(K,T,R)).
recorda(Key,Term,Ref) :- '$recorda'(Key,Term,Ref). recordzifnot(K,T,R) :-
recordz(Key,Term,Ref) :- '$recordz'(Key,Term,Ref). ( recorded(K,T,R) -> fail ; recordz(K,T,R)).
recordaifnot(Key,Term,Ref) :- '$recordaifnot'(Key,Term,Ref).
recordzifnot(Key,Term,Ref) :- '$recordzifnot'(Key,Term,Ref).
%%% Atoms with value
get_value(X,Y) :- '$get_value'(X,Y).
set_value(X,Y) :- '$set_value'(X,Y).
%%% current .... %%% current ....
@ -489,7 +481,7 @@ unknown(V0,V) :-
'$valid_unknown_handler'(New,Mod), fail. '$valid_unknown_handler'(New,Mod), fail.
% clean up previous unknown predicate handlers % clean up previous unknown predicate handlers
'$unknown'(Old,New,Mod) :- '$unknown'(Old,New,Mod) :-
'$recorded'('$unknown','$unknown'(_,MyOld),Ref), !, recorded('$unknown','$unknown'(_,MyOld),Ref), !,
erase(Ref), erase(Ref),
'$cleanup_unknown_handler'(MyOld,Old), '$cleanup_unknown_handler'(MyOld,Old),
'$new_unknown'(New, Mod). '$new_unknown'(New, Mod).
@ -513,7 +505,7 @@ unknown(V0,V) :-
'$do_error'(domain_error(flag_value,unknown+S),yap_flag(unknown,S)). '$do_error'(domain_error(flag_value,unknown+S),yap_flag(unknown,S)).
'$ask_unknown_flag'(Old) :- '$ask_unknown_flag'(Old) :-
'$recorded'('$unknown','$unkonwn'(_,MyOld),_), !, recorded('$unknown','$unkonwn'(_,MyOld),_), !,
'$cleanup_unknwon_handler'(MyOld,Old). '$cleanup_unknwon_handler'(MyOld,Old).
'$ask_unknown_flag'(fail). '$ask_unknown_flag'(fail).
@ -523,12 +515,12 @@ unknown(V0,V) :-
'$new_unknown'(fail,_) :- !. '$new_unknown'(fail,_) :- !.
'$new_unknown'(error,_) :- !, '$new_unknown'(error,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_error'(P)),_). recorda('$unknown','$unknown'(P,'$unknown_error'(P)),_).
'$new_unknown'(warning,_) :- !, '$new_unknown'(warning,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_warning'(P)),_). recorda('$unknown','$unknown'(P,'$unknown_warning'(P)),_).
'$new_unknown'(X,M) :- '$new_unknown'(X,M) :-
arg(1,X,A), arg(1,X,A),
'$recorda'('$unknown','$unknown'(A,M:X),_). recorda('$unknown','$unknown'(A,M:X),_).
'$unknown_error'(P) :- '$unknown_error'(P) :-
'$do_error'(unknown,P). '$do_error'(unknown,P).
@ -693,7 +685,7 @@ prolog_initialization(T) :- callable(T), !,
prolog_initialization(T) :- prolog_initialization(T) :-
'$do_error'(type_error(callable,T),initialization(T)). '$do_error'(type_error(callable,T),initialization(T)).
'$assert_init'(T) :- '$recordz'('$startup_goal',T,_), fail. '$assert_init'(T) :- recordz('$startup_goal',T,_), fail.
'$assert_init'(_). '$assert_init'(_).
version :- '$version'. version :- '$version'.
@ -704,7 +696,7 @@ version(T) :- atom(T), !, '$assert_version'(T).
version(T) :- version(T) :-
'$do_error'(type_error(atom,T),version(T)). '$do_error'(type_error(atom,T),version(T)).
'$assert_version'(T) :- '$recordz'('$version',T,_), fail. '$assert_version'(T) :- recordz('$version',T,_), fail.
'$assert_version'(_). '$assert_version'(_).
term_variables(Term, L) :- term_variables(Term, L) :-
@ -729,11 +721,11 @@ user_defined_directive(Dir,Action) :-
'$current_module'(_, M). '$current_module'(_, M).
'$set_toplevel_hook'(_) :- '$set_toplevel_hook'(_) :-
'$recorded'('$toplevel_hooks',_,R), recorded('$toplevel_hooks',_,R),
erase(R), erase(R),
fail. fail.
'$set_toplevel_hook'(H) :- '$set_toplevel_hook'(H) :-
'$recorda'('$toplevel_hooks',H,_), recorda('$toplevel_hooks',H,_),
fail. fail.
'$set_toplevel_hook'(_). '$set_toplevel_hook'(_).

2
pl/yapor.yap
View File

@ -104,7 +104,7 @@ default_sequential(_).
% do not try to run consult in the parallel system. % do not try to run consult in the parallel system.
% %
'$parallelizable'(_) :- '$parallelizable'(_) :-
'$get_value'('$consulting_file',S), S\=[], !, fail. get_value('$consulting_file',S), S\=[], !, fail.
'$parallelizable'((G1,G2)) :- !, '$parallelizable'((G1,G2)) :- !,
'$parallelizable'(G1), '$parallelizable'(G1),
'$parallelizable'(G2). '$parallelizable'(G2).

20
pl/yio.yap
View File

@ -273,8 +273,8 @@ open_null_stream(S) :- '$open_null_stream'(S).
open_pipe_streams(P1,P2) :- '$open_pipe_stream'(P1, P2). open_pipe_streams(P1,P2) :- '$open_pipe_stream'(P1, P2).
fileerrors :- '$set_value'(fileerrors,1). fileerrors :- set_value(fileerrors,1).
nofileerrors :- '$set_value'(fileerrors,0). nofileerrors :- set_value(fileerrors,0).
exists(F) :- '$exists'(F,read). exists(F) :- '$exists'(F,read).
@ -350,7 +350,7 @@ read_term(Stream, T, Options) :-
'$preprocess_read_terms_options'([]). '$preprocess_read_terms_options'([]).
'$preprocess_read_terms_options'([syntax_errors(NewVal)|L]) :- !, '$preprocess_read_terms_options'([syntax_errors(NewVal)|L]) :- !,
'$get_read_error_handler'(OldVal), '$get_read_error_handler'(OldVal),
'$set_value'('$read_term_error_handler', OldVal), set_value('$read_term_error_handler', OldVal),
'$set_read_error_handler'(NewVal), '$set_read_error_handler'(NewVal),
'$preprocess_read_terms_options'(L). '$preprocess_read_terms_options'(L).
'$preprocess_read_terms_options'([_|L]) :- '$preprocess_read_terms_options'([_|L]) :-
@ -367,7 +367,7 @@ read_term(Stream, T, Options) :-
'$postprocess_read_terms_options_list'(Tail, T, VL, Pos). '$postprocess_read_terms_options_list'(Tail, T, VL, Pos).
'$postprocess_read_terms_option'(syntax_errors(_), _, _, _) :- '$postprocess_read_terms_option'(syntax_errors(_), _, _, _) :-
'$get_value'('$read_term_error_handler', OldVal), get_value('$read_term_error_handler', OldVal),
'$set_read_error_handler'(OldVal). '$set_read_error_handler'(OldVal).
'$postprocess_read_terms_option'(variable_names(Vars), _, VL, _) :- '$postprocess_read_terms_option'(variable_names(Vars), _, VL, _) :-
'$read_term_non_anonymous'(VL, Vars). '$read_term_non_anonymous'(VL, Vars).
@ -515,8 +515,8 @@ format(Stream, S, A) :- '$format'(Stream, S, A).
'$portray'(T) :- '$portray'(T) :-
\+ '$undefined'(portray(_),user), \+ '$undefined'(portray(_),user),
user:portray(T), !, user:portray(T), !,
'$set_value'('$portray',true), fail. set_value('$portray',true), fail.
'$portray'(_) :- '$set_value'('$portray',false), fail. '$portray'(_) :- set_value('$portray',false), fail.
/* character I/O */ /* character I/O */
@ -891,12 +891,12 @@ absolute_file_name(RelFile, AbsFile) :-
'$file_expansion'(RelFile, AbsFile). '$file_expansion'(RelFile, AbsFile).
'$exists'(F,Mode,AbsFile) :- '$exists'(F,Mode,AbsFile) :-
'$get_value'(fileerrors,V), get_value(fileerrors,V),
'$set_value'(fileerrors,0), set_value(fileerrors,0),
( '$open'(F,Mode,S,0), !, ( '$open'(F,Mode,S,0), !,
'$file_name'(S, AbsFile), '$file_name'(S, AbsFile),
'$close'(S), '$set_value'(fileerrors,V); '$close'(S), set_value(fileerrors,V);
'$set_value'(fileerrors,V), fail). set_value(fileerrors,V), fail).
current_char_conversion(X,Y) :- current_char_conversion(X,Y) :-