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

6
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: *
* mods: *
* 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
static char SccsId[] = "%W% %G%";
@ -153,10 +153,10 @@ FreeBlock(BlockHeader *b)
sp = &(b->b_size) + (b->b_size & ~InUseFlag);
if (*sp != b->b_size) {
#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));
#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);
#endif
return;

194
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_pl, (op_numbers,PredEntry *));
STATIC_PROTO(void a_l, (op_numbers));
STATIC_PROTO(void a_hx, (op_numbers));
STATIC_PROTO(void a_if, (op_numbers));
STATIC_PROTO(void a_go, (op_numbers));
STATIC_PROTO(void a_hx, (op_numbers, union clause_obj *, int));
STATIC_PROTO(void a_if, (op_numbers, union clause_obj *, int));
STATIC_PROTO(void a_cut, (void));
#ifdef YAPOR
STATIC_PROTO(void a_try, (op_numbers, CELL, CELL, int, int));
@ -137,20 +136,6 @@ static int c_type;
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
emit_y(Ventry *ve)
{
@ -339,14 +324,21 @@ Yap_opcode(op_numbers op)
return (opcode(op));
}
static void
add_clref(CELL clause_code)
{
if (pass_no) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(clause_code);
cl->ClRefCount++;
}
}
static void
a_cl(op_numbers opcode)
{
if (pass_no) {
LogUpdClause *cl = (LogUpdClause *)code_addr;
code_p->opc = emit_op(opcode);
code_p->u.l.l = code_addr;
cl->u.ClVarChain = (yamop *)(Unsigned(code_addr) + label_offset[1]);
}
GONEXT(l);
}
@ -362,7 +354,7 @@ a_cle(op_numbers opcode)
code_p->u.EC.ClENV = 0;
code_p->u.EC.ClRefs = 0;
code_p->u.EC.ClBase = code_addr;
cl->u2.ClExt = code_p;
cl->ClExt = code_p;
cl->ClFlags |= LogUpdRuleMask;
}
GONEXT(EC);
@ -450,6 +442,19 @@ a_vv(op_numbers opcode, op_numbers opcodew)
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
a_vr(op_numbers opcode)
{
@ -545,12 +550,9 @@ a_asf(opcode)
inline static void
a_pair(CELL *seq_ptr)
{
CELL *ptr = ((CELL *) (code_p));
code_p = (yamop *) (ptr + 2);
if (pass_no) {
ptr[0] = (CELL) emit_a(*seq_ptr);
ptr[1] = (CELL) emit_ilabel(seq_ptr[1]);
seq_ptr[0] = (CELL) emit_a(seq_ptr[0]);
seq_ptr[1] = (CELL) emit_ilabel(seq_ptr[1]);
}
}
@ -1098,52 +1100,78 @@ a_4sw_s(op_numbers opcode)
}
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 *seq_ptr = cpc->arnds;
register CELL *seq_ptr = (CELL *)cpc->rnd2;
imax = cpc->rnd1;
if (pass_no) {
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);
for (i = 0; i < imax; i++) {
a_pair(seq_ptr);
seq_ptr += 2;
GONEXT(sl);
if (pass_no) {
for (i = 0; i < imax; i++) {
a_pair(seq_ptr);
seq_ptr += 2;
}
}
}
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 *seq_ptr = cpc->arnds + 1;
register CELL *seq_ptr = (CELL *)cpc->rnd2;
imax = cpc->rnd1;
if (pass_no) {
code_p->opc = emit_op(opcode);
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);
for (i = 0; i < imax; i++) {
a_pair(seq_ptr);
seq_ptr += 2;
}
}
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 */
for (i = 0; i < imax; i++) {
a_pair(seq_ptr);
seq_ptr += 2;
}
seq_ptr[1] = (CELL) emit_ilabel(seq_ptr[1]);
}
GONEXT(cll);
}
static void
@ -1983,12 +2011,16 @@ do_pass(void)
if (assembling != ASSEMBLING_INDEX) {
if (log_update) {
if (pass_no) {
cl_u->luc.Id = FunctorDBRef;
cl_u->luc.ClFlags = LogUpdMask;
cl_u->luc.Owner = Yap_ConsultingFile();
cl_u->luc.ClRefCount = 0;
cl_u->luc.ClPred = CurrentPred;
if (clause_has_blobs) {
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)
INIT_LOCK(cl_u.luc->ClLock);
INIT_CLREF_COUNT(cl_u.luc);
@ -1997,10 +2029,12 @@ do_pass(void)
code_p = cl_u->luc.ClCode;
} else if (dynamic) {
if (pass_no) {
cl_u->ic.ClFlags = DynamicMask;
cl_u->ic.Owner = Yap_ConsultingFile();
if (clause_has_blobs) {
cl_u->ic.ClFlags |= HasBlobsMask;
}
cl_u->ic.ClRefCount = 0;
#if defined(YAPOR) || defined(THREADS)
INIT_LOCK(cl_u.ic->ClLock);
INIT_CLREF_COUNT(cl_u.ic);
@ -2020,23 +2054,32 @@ do_pass(void)
}
IPredArity = cpc->rnd2; /* number of args */
entry_code = code_p;
if (!log_update) {
#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
a_try(TRYOP(_try_me, _try_me0), 0, IPredArity);
a_try(TRYOP(_try_me, _try_me0), 0, IPredArity);
#endif /* YAPOR */
}
} else {
/* index code */
if (log_update) {
if (pass_no) {
cl_u->luc.ClFlags = LogUpdatePredFlag|IndexedPredFlag|IndexMask;
cl_u->luc.u2.ClUse = 0;
cl_u->lui.ClFlags = LogUpdMask|IndexedPredFlag|IndexMask;
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 {
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;
}
@ -2274,25 +2317,37 @@ do_pass(void)
a_deallocate();
break;
case tryme_op:
if (log_update && assembling == ASSEMBLING_INDEX) {
a_cl(_try_logical_pred);
}
TRYCODE(_try_me, _try_me0);
break;
case retryme_op:
TRYCODE(_retry_me, _retry_me0);
break;
case trustme_op:
if (log_update && assembling == ASSEMBLING_INDEX) {
a_cl(_trust_logical_pred);
}
TRYCODE(_trust_me, _trust_me0);
break;
case try_op:
if (log_update)
if (log_update) {
a_cl(_try_logical_pred);
}
a_gl(_try_clause);
break;
case retry_op:
if (log_update) {
add_clref(cpc->rnd1);
}
a_gl(_retry);
break;
case trust_op:
if (log_update)
if (log_update) {
add_clref(cpc->rnd1);
a_cl(_trust_logical_pred);
}
a_gl(_trust);
break;
case try_in_op:
@ -2414,28 +2469,37 @@ do_pass(void)
a_4sw(_switch_on_type);
break;
case switch_c_op:
a_hx(_switch_on_cons);
a_hx(_switch_on_cons, cl_u, log_update);
break;
case switch_f_op:
a_hx(_switch_on_func);
a_hx(_switch_on_func, cl_u, log_update);
break;
case if_c_op:
if (cpc->rnd1 == 1) {
a_go(_go_on_cons);
a_if(_go_on_cons, cl_u, log_update);
} else {
a_if(_if_cons);
a_if(_if_cons, cl_u, log_update);
}
break;
case if_f_op:
if (cpc->rnd1 == 1) {
a_go(_go_on_func);
a_if(_go_on_func, cl_u, log_update);
} else {
a_if(_if_func);
a_if(_if_func, cl_u, log_update);
}
break;
case if_not_op:
a_ifnot(_if_not_then);
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:
a_bmap();
break;

8
C/arrays.c
View File

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

4
C/bb.c
View File

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

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

1821
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);
#endif /* LOW_LEVEL_TRACE */
CP = P;
P = (yamop *)(pen->CodeOfPred);
P = pen->CodeOfPred;
/* vsc: increment reduction counter at meta-call entry */
WRITE_UNLOCK(pen->PRWLock);
if (pen->PredFlags & ProfiledPredFlag) {
@ -170,6 +170,13 @@ CallClause(PredEntry *pen, Int position)
P = CLAUSECODE->clause;
WRITE_UNLOCK(pen->PRWLock);
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 {
for (; position > 1; position--)
q = NextClause(q);
@ -205,8 +212,7 @@ p_save_cp(void)
static Int
EnterCreepMode(SMALLUNSGN mod) {
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,1));
Term tn = Yap_MkApplTerm(Yap_MkFunctor(AtomMetaCall,1),1,&ARG1);
ARG1 = MkPairTerm(ModuleName[mod],tn);
ARG1 = MkPairTerm(ModuleName[mod],ARG1);
CreepFlag = CalculateStackGap();
P_before_spy = P;
return (CallPredicate(PredSpy, B));
@ -215,7 +221,7 @@ EnterCreepMode(SMALLUNSGN mod) {
inline static Int
do_execute(Term t, SMALLUNSGN mod)
{
if (yap_flags[SPY_CREEP_FLAG]) {
if (CreepFlag == (CELL)(LCL0+2)) {
return(EnterCreepMode(mod));
} else if (PRED_GOAL_EXPANSION_ON) {
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_userc:
if (gc_B->cp_ap == RETRY_C_RECORDED_CODE
|| gc_B->cp_ap == RETRY_C_RECORDED_K_CODE
|| gc_B->cp_ap == RETRY_C_DRECORDED_CODE
if (gc_B->cp_ap == RETRY_C_RECORDED_K_CODE
|| gc_B->cp_ap == RETRY_C_RECORDEDP_CODE) {
/* we have a reference from the choice-point stack to a term */
choiceptr old_b = B;

9
C/init.c
View File

@ -709,6 +709,7 @@ InitCodes(void)
INIT_YAMOP_LTT(&(heap_regs->tableanswerresolutioncode), 0);
#endif /* YAPOR */
#endif /* TABLING */
heap_regs->expand_op_code = Yap_opcode(_expand_index);
heap_regs->failcode->opc = Yap_opcode(_op_fail);
heap_regs->failcode_1 = 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_call_counting = 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->consultlow + heap_regs->consultcapacity;
heap_regs->compiler_compile_mode = 1;
@ -961,6 +962,10 @@ InitCodes(void)
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_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_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));
@ -981,7 +986,7 @@ InitCodes(void)
heap_regs->db_erased_marker->id = FunctorDBRef;
heap_regs->db_erased_marker->Flags = ErasedMask;
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;
INIT_LOCK(heap_regs->db_erased_marker->lock);
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));
} else if(IsPairTerm(ts)) {
CELL *pt;
if (i != 1 || i != 2) {
if (i < 1 || i > 2) {
if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return(FALSE);

4
C/modules.c
View File

@ -140,7 +140,9 @@ Yap_InitModules(void)
MkAtomTerm(Yap_LookupAtom("prolog"));
ModuleName[1] =
MkAtomTerm(Yap_LookupAtom("user"));
NoOfModules = 2;
ModuleName[2] =
MkAtomTerm(Yap_LookupAtom("idb"));
NoOfModules = 3;
CurrentModule = 0;
Yap_InitCPred("$current_module", 2, p_current_module, 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)
{
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) {
/* 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
@ -915,17 +915,17 @@ recompute_mask(DBRef dbr)
CELL *x = (CELL *)HeapTop, *tp;
unsigned int Arity, i;
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);
Arity = 2;
tp = (CELL *)(tbase + (CELL) RepPair(dbr->Entry));
tp = (CELL *)(tbase + (CELL) RepPair(dbr->DBT.Entry));
} else {
Functor f;
tp = (CELL *)(tbase + (CELL) RepAppl(dbr->Entry));
tp = (CELL *)(tbase + (CELL) RepAppl(dbr->DBT.Entry));
f = (Functor)(*tp++);
out = AbsAppl(x);
Arity = ArityOfFunctor(f);
@ -940,7 +940,7 @@ recompute_mask(DBRef dbr)
/* just fetch the functor from where it is in the data-base.
This guarantees we have access to references and friends. */
CELL offset = (CELL)RepAppl(tw);
if (offset > dbr->NOfCells*sizeof(CELL))
if (offset > dbr->DBT.NOfCells*sizeof(CELL))
*x = tw;
else
*x = AbsAppl((CELL *)(tbase + offset));

18
C/stdpreds.c
View File

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

34
C/tracer.c
View File

@ -102,6 +102,8 @@ check_trail_consistency(void) {
*/
static int vsc_xstop = FALSE;
void
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++;
#ifdef COMMENTED
if (vsc_count < 130000) return;
return;
if (vsc_count == 133000LL) {
if (vsc_count < 5530257LL) {
return;
}
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");
}
if (vsc_count > 500000) exit(0);
if (gc_calls < 1) return;
#endif
#if defined(__GNUC__)
@ -184,15 +198,17 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
}
break;
case retry_pred:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
mname = RepAtom(AtomOfTerm(Yap_Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0)
if (pred->ModuleOfPred == 2) {
s = "recorded";
arity = 3;
} else if (arity == 0) {
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
} else {
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);
break;
}

23
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* 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 */
@ -57,6 +57,7 @@ typedef struct various_codes {
yamop tablecompletioncode;
yamop tableanswerresolutioncode;
#endif /* TABLING */
OPCODE expand_op_code;
yamop comma_code[5];
yamop failcode[1];
OPCODE failcode_1;
@ -135,14 +136,15 @@ typedef struct various_codes {
OPCODE undef_op;
OPCODE index_op;
OPCODE fail_op;
yamop *retry_recorded_code,
*retry_recorded_k_code,
*retry_drecorded_code,
yamop *retry_recorded_k_code,
*retry_c_recordedp_code;
Int static_predicates_marked;
UInt int_keys_size;
UInt int_keys_timestamp;
Prop *IntKeys;
UInt int_lu_keys_size;
UInt int_lu_keys_timestamp;
Prop *IntLUKeys;
UInt int_bb_keys_size;
Prop *IntBBKeys;
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_meta_call;
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_handle_throw;
struct array_entry *dyn_array_list;
@ -353,6 +359,7 @@ typedef struct various_codes {
#define COMPLETION ((yamop *)&(heap_regs->tablecompletioncode ))
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */
#define EXPAND_OP_CODE heap_regs->expand_op_code
#define COMMA_CODE heap_regs->comma_code
#define FAILCODE heap_regs->failcode
#define TRUSTFAILCODE heap_regs->trustfailcode
@ -375,7 +382,6 @@ typedef struct various_codes {
#define UPDATE_MODE heap_regs->update_mode
#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_DRECORDED_CODE heap_regs->retry_drecorded_code
#define RETRY_C_RECORDEDP_CODE heap_regs->retry_c_recordedp_code
#define STATIC_PREDICATES_MARKED heap_regs->static_predicates_marked
#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_TIMESTAMP heap_regs->int_keys_timestamp
#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 heap_regs->IntBBKeys
#define CharConversionTable heap_regs->char_conversion_table
@ -513,6 +522,10 @@ typedef struct various_codes {
#define PredGoalExpansion heap_regs->pred_goal_expansion
#define PredMetaCall heap_regs->pred_meta_call
#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 PredHandleThrow heap_regs->pred_handle_throw
#define DynArrayList heap_regs->dyn_array_list

6
H/YapOpcodes.h
View File

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

4
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* 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 */
@ -55,6 +55,8 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term));
Prop STD_PROTO(Yap_GetPredPropByAtom,(Atom, 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_GetExpProp,(Atom,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_from_code(X) ((PredEntry *)(Unsigned(X)-(CELL)(&(((PredEntry *)NULL)->CodeOfPred))))
#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 PredOpCode(X) pred_entry(X)->OpcodeOfPred
#define TruePredCode(X) pred_entry(X)->TrueCodeOfPred
@ -676,11 +677,11 @@ Macros to check the limits of stacks
#if OS_HANDLES_TR_OVERFLOW
#define check_trail()
#define check_trail(x)
#else
#define check_trail() if (Unsigned(Yap_TrailTop) - Unsigned(TR) < MinTrailGap) \
#define check_trail(x) if (Unsigned(Yap_TrailTop) - Unsigned(x) < MinTrailGap) \
goto notrailleft
#endif
@ -1138,10 +1139,10 @@ trim_trail(choiceptr b, tr_fr_ptr tr, CELL *hbreg)
DO_TRAIL(d1, TrailVal(pt0));
}
pt0++;
ENDD(d1);
ENDD(d0);
}
ENDD(d1);
}
ENDD(d0);
return(TR);
}
#endif /* FROZEN_STACKS */
@ -1496,3 +1497,45 @@ loop:
}
#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;
CELL next;
} xx;
struct {
CELL x;
CELL x1;
struct pred_entry *p;
CELL next;
} xxp;
struct {
wamreg x;
wamreg x1;

83
H/clause.h
View File

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

3
H/compile.h
View File

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

34
H/index.h
View File

@ -43,7 +43,11 @@ typedef struct StructClauseDef {
Term Tag; /* if nonvar or nonlist, first argument */
yamop *Code; /* start of code for clause */
yamop *CurrentCode; /* start of code for clause */
yamop *WorkPC; /* start of code for clause */
union {
yamop *WorkPC; /* start of code for clause */
CELL *c_sreg;
Term t_ptr;
} u;
} ClauseDef;
@ -82,3 +86,31 @@ typedef struct {
#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

207
H/rheap.h
View File

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

24
docs/yap.tex
View File

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

1
library/Makefile.in
View File

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

4
m4/TermExt.h.m4
View File

@ -10,7 +10,7 @@
* File: TermExt.h *
* mods: *
* 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
@ -197,6 +197,8 @@ Inline(IsAttachFunc, Int, Functor, f, FALSE)
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])
#else

53
m4/Yatom.h.m4
View File

@ -170,6 +170,8 @@ typedef enum {
MetaPredFlag = 0x200000L, /* predicate subject to a meta declaration */
SyncPredFlag = 0x100000L, /* has to synch before it can execute*/
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 */
FastPredFlag = 0x020000L, /* is "compiled" */
TestPredFlag = 0x010000L, /* is a test (optim. comit) */
@ -215,13 +217,18 @@ typedef struct pred_entry {
struct yami *TrueCodeOfPred; /* code address */
struct yami *FirstClause;
struct yami *LastClause;
UInt NOfClauses;
UInt NOfClauses;
OPCODE ExpandCode;
} p_code;
CPredicate f_code;
CmpPredicate d_code;
} cs; /* if needing to spy or to lock */
Functor FunctorOfPred; /* functor for Predicate */
Atom OwnerFile; /* File where the predicate was defined */
union {
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 */
#if defined(YAPOR) || defined(THREADS)
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 */
/* There are several flags for code and data base entries */
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 */
DynamicMask = 0x8000, /* informs this is a dynamic predicate */
InUseMask = 0x4000, /* informs this block is being used */
@ -262,6 +271,16 @@ typedef enum {
/* *********************** 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 {
Functor id; /* allow pointers to this struct to id */
/* as dbref */
@ -269,7 +288,6 @@ typedef struct DB_STRUCT {
CELL NOfRefsTo; /* Number of references pointing here */
struct struct_dbentry *Parent; /* key of DBase reference */
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 *Next; /* Next element in chain */
#if defined(YAPOR) || defined(THREADS)
@ -278,18 +296,13 @@ typedef struct DB_STRUCT {
#endif
struct DB_STRUCT *p, *n; /* entry's age, negative if from recorda,
positive if it was recordz */
#ifdef COROUTINING
CELL attachments; /* attached terms */
#endif
CELL Mask; /* parts that should be cleared */
CELL Key; /* A mask that can be used to check before
you unify */
CELL NOfCells; /* Size of Term */
CELL Entry; /* entry point */
Term Contents[MIN_ARRAY]; /* stored term */
DBTerm DBT;
} 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)
#define INIT_DBREF_COUNT(X) (X)->ref_count = 0
@ -377,7 +390,7 @@ typedef struct {
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
Atom KeyOfBB; /* functor for this property */
DBRef Element; /* blackboard element */
DBTerm *Element; /* blackboard element */
#if defined(YAPOR) || defined(THREADS)
rwlock_t BBRWLock; /* a read-write lock to protect the entry */
#endif
@ -433,7 +446,7 @@ typedef union {
AtomEntry **ptrs;
Term *atoms;
Term *dbrefs;
DBRef *terms;
DBTerm **terms;
} statarray_elements;
/* next, the actual data structure */
@ -473,9 +486,9 @@ int STD_PROTO(Yap_RemoveIndexation,(PredEntry *));
/* dbase.c */
void STD_PROTO(Yap_ErDBE,(DBRef));
DBRef STD_PROTO(Yap_StoreTermInDB,(int,int));
Term STD_PROTO(Yap_FetchTermFromDB,(DBRef,int));
void STD_PROTO(Yap_ReleaseTermFromDB,(DBRef));
DBTerm *STD_PROTO(Yap_StoreTermInDB,(Term,int));
Term STD_PROTO(Yap_FetchTermFromDB,(DBTerm *,int));
void STD_PROTO(Yap_ReleaseTermFromDB,(DBTerm *));
/* init.c */
Atom STD_PROTO(Yap_GetOp,(OpEntry *,int *,int));
@ -532,3 +545,11 @@ void STD_PROTO(Yap_ReleasePreAllocCodeSpace, (ADDR));
#else
#define Yap_ReleasePreAllocCodeSpace(x)
#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
expand_exprs(Old,New) :-
('$get_value'('$c_arith',true) ->
(get_value('$c_arith',true) ->
Old = on ;
Old = off ),
'$set_arith_expan'(New).
'$set_arith_expan'(on) :- '$set_value'('$c_arith',true).
'$set_arith_expan'(off) :- '$set_value'('$c_arith',[]).
'$set_arith_expan'(on) :- set_value('$c_arith',true).
'$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) :-
'$get_value'('$c_arith',true), !,
get_value('$c_arith',true), !,
'$do_c_built_in'(IN, M, OUT).
'$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'(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) :-
nonvar(Y), % Don't rewrite variables
!,

201
pl/boot.yap
View File

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

56
pl/consult.yap
View File

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

2
pl/corout.yap
View File

@ -396,7 +396,7 @@ when(_,Goal) :-
'$generate_blocking_code'((Conds,OldConds), G, Code).
'$generate_blocking_code'(Conds, G, (G :- (If, !, when(When, 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).
%

997
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).
% do or do not machine code
yap_flag(fast,on) :- '$set_value'('$fast',true).
yap_flag(fast,off) :- !, '$set_value'('$fast',[]).
yap_flag(fast,on) :- set_value('$fast',true).
yap_flag(fast,off) :- !, set_value('$fast',[]).
% do or do not machine code
yap_flag(argv,L) :- '$argv'(L).
@ -128,48 +128,48 @@ yap_flag(unhide,Atom) :- !, unhide(Atom).
% control garbage collection
yap_flag(gc,V) :-
var(V), !,
( '$get_value'('$gc',[]) -> V = off ; V = on).
yap_flag(gc,on) :- !, '$set_value'('$gc',true).
yap_flag(gc,off) :- !, '$set_value'('$gc',[]).
( get_value('$gc',[]) -> V = off ; V = on).
yap_flag(gc,on) :- !, set_value('$gc',true).
yap_flag(gc,off) :- !, set_value('$gc',[]).
yap_flag(gc_margin,N) :-
( var(N) ->
'$get_value'('$gc_margin',N)
get_value('$gc_margin',N)
;
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))
).
yap_flag(gc_trace,V) :-
var(V), !,
'$get_value'('$gc_trace',N1),
'$get_value'('$gc_verbose',N2),
'$get_value'('$gc_very_verbose',N3),
get_value('$gc_trace',N1),
get_value('$gc_verbose',N2),
get_value('$gc_very_verbose',N3),
'$yap_flag_show_gc_tracing'(N1, N2, N3, V).
yap_flag(gc_trace,on) :- !,
'$set_value'('$gc_trace',true),
'$set_value'('$gc_verbose',[]),
'$set_value'('$gc_very_verbose',[]).
set_value('$gc_trace',true),
set_value('$gc_verbose',[]),
set_value('$gc_very_verbose',[]).
yap_flag(gc_trace,verbose) :- !,
'$set_value'('$gc_trace',[]),
'$set_value'('$gc_verbose',true),
'$set_value'('$gc_very_verbose',[]).
set_value('$gc_trace',[]),
set_value('$gc_verbose',true),
set_value('$gc_very_verbose',[]).
yap_flag(gc_trace,very_verbose) :- !,
'$set_value'('$gc_trace',[]),
'$set_value'('$gc_verbose',true),
'$set_value'('$gc_very_verbose',true).
set_value('$gc_trace',[]),
set_value('$gc_verbose',true),
set_value('$gc_very_verbose',true).
yap_flag(gc_trace,off) :-
'$set_value'('$gc_trace',[]),
'$set_value'('$gc_verbose',[]),
'$set_value'('$gc_very_verbose',[]).
set_value('$gc_trace',[]),
set_value('$gc_verbose',[]),
set_value('$gc_very_verbose',[]).
yap_flag(syntax_errors, V) :- var(V), !,
'$get_read_error_handler'(V).
yap_flag(syntax_errors, Option) :-
'$set_read_error_handler'(Option).
% compatibility flag
yap_flag(enhanced,on) :- !, '$set_value'('$enhanced',true).
yap_flag(enhanced,off) :- '$set_value'('$enhanced',[]).
yap_flag(enhanced,on) :- !, set_value('$enhanced',true).
yap_flag(enhanced,off) :- set_value('$enhanced',[]).
%
% show state of $
%
@ -224,9 +224,9 @@ yap_flag(index,X) :-
yap_flag(informational_messages,X) :- var(X), !,
'$get_value'('$verbose',X).
yap_flag(informational_messages,on) :- !, '$set_value'('$verbose',on).
yap_flag(informational_messages,off) :- !, '$set_value'('$verbose',off).
get_value('$verbose',X).
yap_flag(informational_messages,on) :- !, set_value('$verbose',on).
yap_flag(informational_messages,off) :- !, set_value('$verbose',off).
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) :-
var(X), !,
'$get_value'('$version_name',X).
get_value('$version_name',X).
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) :-
var(X), !,
('$get_value'(debug,1) ->
(get_value(debug,1) ->
X = on
;
X = off
@ -446,7 +446,7 @@ yap_flag(update_semantics,X) :-
yap_flag(toplevel_hook,X) :-
var(X), !,
( '$recorded'('$toplevel_hooks',G,_) -> G ; true ).
( recorded('$toplevel_hooks',G,_) -> G ; true ).
yap_flag(toplevel_hook,G) :- !,
'$set_toplevel_hook'(G).
@ -504,33 +504,33 @@ yap_flag(user_error,Stream) :-
yap_flag(debugger_print_options,OUT) :-
var(OUT),
'$recorded'('$print_options','$debugger'(OUT),_), !.
recorded('$print_options','$debugger'(OUT),_), !.
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) :-
var(OUT),
'$recorded'('$print_options','$toplevel'(OUT),_), !.
recorded('$print_options','$toplevel'(OUT),_), !.
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) :-
var(OUT), !,
'$get_value'(fileerrors,X0),
get_value(fileerrors,X0),
(X0 = [] -> X= 0 ; X = X0),
'$transl_to_on_off'(X,OUT).
yap_flag(fileerrors,on) :- !,
'$set_value'(fileerrors,1).
set_value(fileerrors,1).
yap_flag(fileerrors,off) :- !,
'$set_value'(fileerrors,0).
set_value(fileerrors,0).
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) :-
'$host_type'(X).

2
pl/errors.yap
View File

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

8
pl/init.yap
View File

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

5
pl/listing.yap
View File

@ -55,6 +55,11 @@ listing(V) :-
'$funcspec'(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) :-
( '$recordedp'(M:Pred,_,_) -> nl(Stream) ),
fail.

36
pl/modules.yap
View File

@ -17,8 +17,6 @@
% module handling
:- '$switch_log_upd'(1).
use_module(M) :-
'$use_module'(M).
@ -35,7 +33,7 @@ use_module(M) :-
'$change_module'(M0).
'$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)
;
'$ensure_loaded'(File)
@ -64,12 +62,12 @@ use_module(M,I) :-
;
% the following avoids import of all public predicates
'$consulting_file_name'(Stream,TrueFileName),
'$recorda'('$importing','$importing'(TrueFileName),R),
recorda('$importing','$importing'(TrueFileName),R),
'$reconsult'(File,Stream)
),
'$close'(Stream),
( 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)
;
'$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),
% the following avoids import of all public predicates
'$recorda'('$importing','$importing'(TrueFileName),R),
recorda('$importing','$importing'(TrueFileName),R),
'$reconsult'(File,Stream)
),
'$close'(Stream),
( 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)
;
@ -123,7 +121,7 @@ use_module(Mod,F,I) :-
'$abolish_module_data'(N),
'$module_dec'(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]),
'$abolish_module_data'(N),
fail
@ -172,7 +170,7 @@ use_module(Mod,F,I) :-
'$prepare_restore_hidden'(Old,Old) :- !.
'$prepare_restore_hidden'(Old,New) :-
'$recorda'('$system_initialisation', source_mode(New,Old), _).
recorda('$system_initialisation', source_mode(New,Old), _).
module(N) :-
var(N),
@ -180,7 +178,7 @@ module(N) :-
module(N) :-
atom(N), !,
'$current_module'(_,N),
'$get_value'('$consulting_file',F),
get_value('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true),
( recorded('$module','$module'(F,N,[]),_) ->
true ;
@ -191,10 +189,10 @@ module(N) :-
'$module_dec'(N,P) :-
'$current_module'(Old,N),
'$get_value'('$consulting_file',F),
get_value('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true),
recorda('$module','$module'(F,N,P),_),
( '$recorded'('$importing','$importing'(F),_) ->
( recorded('$importing','$importing'(F),_) ->
true
;
'$import'(P,N,Old)
@ -219,7 +217,7 @@ module(N) :-
'$import'(L,M,T).
'$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," Do you want to import it from ~w ? [y or n] ",M),
repeat,
@ -256,8 +254,8 @@ module(N) :-
'$abolish_module_data'(M) :-
'$current_module'(T),
( '$recorded'('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true),
'$recorded'('$module','$module'(_,M,_),R),
( recorded('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true),
recorded('$module','$module'(_,M,_),R),
erase(R),
fail.
'$abolish_module_data'(_).
@ -325,7 +323,7 @@ module(N) :-
'$expand_goal2'(G, M, NG, NM) :-
'$undefined'(G,M),
functor(G,F,N),
'$recorded'('$import','$import'(ExportingMod,M,F,N),_),
recorded('$import','$import'(ExportingMod,M,F,N),_),
ExportingMod \= M,
!,
'$expand_goal2'(G, ExportingMod, NG, NM).
@ -405,7 +403,7 @@ module(N) :-
'$imported_pred'(G, ImportingMod, ExportingMod) :-
'$undefined'(G, ImportingMod),
functor(G,F,N),
'$recorded'('$import','$import'(ExportingMod,ImportingMod,F,N),_),
recorded('$import','$import'(ExportingMod,ImportingMod,F,N),_),
ExportingMod \= ImportingMod.
% args are:
@ -534,7 +532,7 @@ current_module(Mod) :-
current_module(Mod,TFN) :-
'$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) :-
'$current_module'(Mod).
@ -542,6 +540,7 @@ source_module(Mod) :-
'$member'(X,[X|_]) :- !.
'$member'(X,[_|L]) :- '$member'(X,L).
:- meta_predicate
% [:,:],
abolish(:),
@ -643,5 +642,4 @@ source_module(Mod) :-
'$system_predicate'(G,M), !.
'$preprocess_body_before_mod_change'(G,M,_,M:G).
:- '$switch_log_upd'(0).

182
pl/preds.yap
View File

@ -40,24 +40,60 @@ assert(C) :-
'$do_error'(instantiation_error,assert(Mod:V)).
'$assert'(M:C,_,Where,R,P) :- !,
'$assert'(C,M,Where,R,P).
'$assert'((H:-G),M1,Where,R,P) :-
(var(H) -> '$do_error'(instantiation_error,P) ; H=M:C), !,
( M1 = M ->
'$assert'((C:-G),M1,Where,R,P)
;
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
'$assert'(C1,M,Where,R,P)
).
'$assert'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod),
'$check_head_and_body'(C,H,B,P),
'$assert'((H:-G),M1,Where,R,P) :- !,
'$assert_clause'(H, G, M1, Where, R, P).
'$assert'(H,M1,Where,R,_) :-
'$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),
C1 = (MH :- NG),
'$assert_clause2'(NH, NG, M, Where, R, P).
'$assert_clause'(H, G, M1, Where, R, P) :- !,
'$assert_clause2'(H, G, M1, Where, R, 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) ->
'$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)
;
'$undefined'(H,Mod) ->
functor(H, Na, Ar),
'$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
'$assert1'(Where,C,C0,Mod,H)
@ -81,14 +117,21 @@ assert(C) :-
).
'$assert_dynamic'(CI,Mod,Where,R,P) :-
'$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),
( '$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)
;
'$undefined'(H, Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod),
'$assertat_d'(Where,H,B,C0,Mod,R)
'$assert_dynamic2'(C0,C,Mod,Where,R,P)
;
functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
@ -130,7 +173,7 @@ assertz_static(C) :-
( '$is_dynamic'(H, Mod) ->
'$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)
;
'$assert1'(Where,C,C0,Mod,H)
@ -138,8 +181,8 @@ assertz_static(C) :-
'$assertat_d'(first,Head,Body,C0,Mod,R) :- !,
'$compile_dynamic'((Head:-Body), 2, Mod, CR),
( '$get_value'('$abol',true)
'$compile_dynamic'((Head:-Body), 2, C0, Mod, CR),
( get_value('$abol',true)
->
'$flags'(Head,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ),
@ -150,15 +193,15 @@ assertz_static(C) :-
'$head_and_body'(C0, H0, B0),
'$recordap'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(Head, Mod) ->
'$get_value'('$consulting_file',F),
get_value('$consulting_file',F),
functor(H0, Na, Ar),
'$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
recorda('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$assertat_d'(last,Head,Body,C0,Mod,R) :-
'$compile_dynamic'((Head:-Body), 0, Mod, CR),
( '$get_value'('$abol',true)
'$compile_dynamic'((Head:-Body), 0, C0, Mod, CR),
( get_value('$abol',true)
->
'$flags'(Head,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(Head,Mod) ; true ),
@ -169,9 +212,9 @@ assertz_static(C) :-
'$head_and_body'(C0, H0, B0),
'$recordzp'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(H0, Mod) ->
'$get_value'('$consulting_file',F),
get_value('$consulting_file',F),
functor(H0, Na, Ar),
'$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
recordz('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
@ -204,7 +247,7 @@ assertz_static(C) :-
'$remove_all_d_clauses'(_,_).
'$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),
erase(R1),
erase(R),
@ -235,6 +278,20 @@ clause(V,Q) :-
'$current_module'(M),
'$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'(P,M,Q,R).
clause(V,Q,R) :-
@ -249,6 +306,9 @@ clause(V,Q,R) :-
'$do_error'(type_error(callable,R),M:clause(R,Q)).
'$clause'(M:P,_,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) :-
'$some_recordedp'(M:P), !,
'$recordedp'(M:P,(P:-Q),R).
@ -260,6 +320,22 @@ clause(V,Q,R) :-
'$do_error'(permission_error(access,private_procedure,Name/Arity),
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_instancep'(P,I,R).
nth_clause(M:V,I,R) :- !,
@ -299,18 +375,23 @@ retract(C) :-
'$retract'(M:C,_) :- !,
'$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), !,
'$recordedp'(M:H,(H:-B),R), erase(R).
'$retract'(C,M) :-
'$check_head_and_body'(C,H,B,retract(M:C)),
'$retract2'(H,M,B) :-
'$undefined'(H,M), !,
functor(H,Na,Ar),
'$dynamic'(Na/Ar,M),
fail.
'$retract'(C,M) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)).
'$retract2'(H,M,B) :-
functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
retract(M:C,R) :- !,
'$retract'(C,M,R).
@ -359,15 +440,26 @@ retractall(V) :-
'$retractall'(M:V,_) :- !,
'$retractall'(V,M).
'$retractall'(T,M) :-
'$undefined'(T,M),
functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !.
'$retractall'(T,M) :-
\+ '$is_dynamic'(T,M), !,
functor(T,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T)).
'$retractall'(T,M) :-
'$erase_all_clauses_for_dynamic'(T, M).
(
'$is_log_updatable'(T, M) ->
'$retractall_lu'(T,M)
;
'$undefined'(T,M) ->
functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !
;
'$is_dynamic'(T,M) ->
'$erase_all_clauses_for_dynamic'(T, M)
;
functor(T,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
).
'$retractall_lu'(T,M) :-
'$log_update_retract'(T,M,_),
fail.
'$retractall_lu'(_,_).
'$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail.
@ -386,7 +478,7 @@ abolish(N,A) :-
'$abolish'(N,A,M) :- var(A), !,
'$do_error'(instantiation_error,abolish(M:N,A)).
'$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.
'$abolish'(N,A,M) :- functor(T,N,A),
( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ;
@ -591,7 +683,7 @@ dynamic_predicate(P,Sem) :-
'$expand_clause'(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)
;
true
@ -660,14 +752,14 @@ predicate_property(Pred,Prop) :-
'$predicate_property'(Pred,Mod,Mod,Prop).
'$predicate_property2'(Pred,Prop,Mod) :-
functor(Pred, N, K),
'$recorded'('$import','$import'(M,Mod,N,K),_),
recorded('$import','$import'(M,Mod,N,K),_),
'$predicate_property'(Pred,M,Mod,Prop).
'$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(M,Na,Ar),
functor(Pred, Na, Ar).
'$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).
@ -687,12 +779,12 @@ predicate_property(Pred,Prop) :-
'$is_multifile'(P,M).
'$predicate_property'(P,Mod,M,imported_from(Mod)) :-
functor(P,N,K),
'$recorded'('$import','$import'(Mod,M,N,K),_).
recorded('$import','$import'(Mod,M,N,K),_).
'$predicate_property'(P,M,_,public) :-
'$is_public'(P,M).
'$predicate_property'(P,M,M,exported) :-
functor(P,N,A),
'$recorded'('$module','$module'(_TFN,M,Publics),_),
recorded('$module','$module'(_TFN,M,Publics),_),
'$member'(N/A,Publics), !. /* defined in modules.yap */
'$predicate_property'(P,Mod,_,number_of_clauses(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
all(T,G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X).
all(T,G,S) :- '$recorda'('$$one','$',R), (
'$execute'(G), '$recorda'('$$one',T,_), fail ;
all(T,G,S) :- recorda('$$one','$',R), (
'$execute'(G), recorda('$$one',T,_), fail ;
'$$set'(S,R) ).
% $$set does its best to preserve space
'$$set'(S,R) :- '$$build'(S,[],R),
( S=[], !, fail;
'$recorda'('$$set',S,_), fail ).
'$$set'(S,_) :- '$recorded'('$$set',S,R), erase(R).
recorda('$$set',S,_), fail ).
'$$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;
'$$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.
alarm(Interval, Goal, Left) :-
'$current_module'(M),
'$recordz'('$alarm_handler',M:Goal,_),
recordz('$alarm_handler',M:Goal,_),
'$alarm'(Interval, Left).
on_signal(Signal,OldAction,default) :-
@ -264,7 +264,7 @@ on_signal(Signal,OldAction,Action) :-
recorded('$sig_handler', action(Signal,OldAction), Ref),
erase(Ref),
'$current_module'(M),
'$recordz'('$sig_handler', action(Signal,M:Action), _).
recordz('$sig_handler', action(Signal,M:Action), _).
%%% 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)).
save_program(A, G) :-
( atom(A) -> name(A,S) ; A = S),
'$recorda'('$restore_goal',G,R),
recorda('$restore_goal',G,R),
'$save_program'(S),
erase(R),
fail.
@ -303,18 +303,10 @@ restore(A) :- var(A), !,
restore(A) :- atom(A), !, name(A,S), '$restore'(S).
restore(S) :- '$restore'(S).
%%% Data base predicates -> the interface to the external world
recorda(Key,Term,Ref) :- '$recorda'(Key,Term,Ref).
recordz(Key,Term,Ref) :- '$recordz'(Key,Term,Ref).
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).
recordaifnot(K,T,R) :-
( recorded(K,T,R) -> fail ; recorda(K,T,R)).
recordzifnot(K,T,R) :-
( recorded(K,T,R) -> fail ; recordz(K,T,R)).
%%% current ....
@ -489,7 +481,7 @@ unknown(V0,V) :-
'$valid_unknown_handler'(New,Mod), fail.
% clean up previous unknown predicate handlers
'$unknown'(Old,New,Mod) :-
'$recorded'('$unknown','$unknown'(_,MyOld),Ref), !,
recorded('$unknown','$unknown'(_,MyOld),Ref), !,
erase(Ref),
'$cleanup_unknown_handler'(MyOld,Old),
'$new_unknown'(New, Mod).
@ -513,7 +505,7 @@ unknown(V0,V) :-
'$do_error'(domain_error(flag_value,unknown+S),yap_flag(unknown,S)).
'$ask_unknown_flag'(Old) :-
'$recorded'('$unknown','$unkonwn'(_,MyOld),_), !,
recorded('$unknown','$unkonwn'(_,MyOld),_), !,
'$cleanup_unknwon_handler'(MyOld,Old).
'$ask_unknown_flag'(fail).
@ -523,12 +515,12 @@ unknown(V0,V) :-
'$new_unknown'(fail,_) :- !.
'$new_unknown'(error,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_error'(P)),_).
recorda('$unknown','$unknown'(P,'$unknown_error'(P)),_).
'$new_unknown'(warning,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_warning'(P)),_).
recorda('$unknown','$unknown'(P,'$unknown_warning'(P)),_).
'$new_unknown'(X,M) :-
arg(1,X,A),
'$recorda'('$unknown','$unknown'(A,M:X),_).
recorda('$unknown','$unknown'(A,M:X),_).
'$unknown_error'(P) :-
'$do_error'(unknown,P).
@ -693,7 +685,7 @@ prolog_initialization(T) :- callable(T), !,
prolog_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'(_).
version :- '$version'.
@ -704,7 +696,7 @@ version(T) :- atom(T), !, '$assert_version'(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'(_).
term_variables(Term, L) :-
@ -729,11 +721,11 @@ user_defined_directive(Dir,Action) :-
'$current_module'(_, M).
'$set_toplevel_hook'(_) :-
'$recorded'('$toplevel_hooks',_,R),
recorded('$toplevel_hooks',_,R),
erase(R),
fail.
'$set_toplevel_hook'(H) :-
'$recorda'('$toplevel_hooks',H,_),
recorda('$toplevel_hooks',H,_),
fail.
'$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.
%
'$parallelizable'(_) :-
'$get_value'('$consulting_file',S), S\=[], !, fail.
get_value('$consulting_file',S), S\=[], !, fail.
'$parallelizable'((G1,G2)) :- !,
'$parallelizable'(G1),
'$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).
fileerrors :- '$set_value'(fileerrors,1).
nofileerrors :- '$set_value'(fileerrors,0).
fileerrors :- set_value(fileerrors,1).
nofileerrors :- set_value(fileerrors,0).
exists(F) :- '$exists'(F,read).
@ -350,7 +350,7 @@ read_term(Stream, T, Options) :-
'$preprocess_read_terms_options'([]).
'$preprocess_read_terms_options'([syntax_errors(NewVal)|L]) :- !,
'$get_read_error_handler'(OldVal),
'$set_value'('$read_term_error_handler', OldVal),
set_value('$read_term_error_handler', OldVal),
'$set_read_error_handler'(NewVal),
'$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_option'(syntax_errors(_), _, _, _) :-
'$get_value'('$read_term_error_handler', OldVal),
get_value('$read_term_error_handler', OldVal),
'$set_read_error_handler'(OldVal).
'$postprocess_read_terms_option'(variable_names(Vars), _, VL, _) :-
'$read_term_non_anonymous'(VL, Vars).
@ -515,8 +515,8 @@ format(Stream, S, A) :- '$format'(Stream, S, A).
'$portray'(T) :-
\+ '$undefined'(portray(_),user),
user:portray(T), !,
'$set_value'('$portray',true), fail.
'$portray'(_) :- '$set_value'('$portray',false), fail.
set_value('$portray',true), fail.
'$portray'(_) :- set_value('$portray',false), fail.
/* character I/O */
@ -891,12 +891,12 @@ absolute_file_name(RelFile, AbsFile) :-
'$file_expansion'(RelFile, AbsFile).
'$exists'(F,Mode,AbsFile) :-
'$get_value'(fileerrors,V),
'$set_value'(fileerrors,0),
get_value(fileerrors,V),
set_value(fileerrors,0),
( '$open'(F,Mode,S,0), !,
'$file_name'(S, AbsFile),
'$close'(S), '$set_value'(fileerrors,V);
'$set_value'(fileerrors,V), fail).
'$close'(S), set_value(fileerrors,V);
set_value(fileerrors,V), fail).
current_char_conversion(X,Y) :-