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

several debugger and CLP(BN) improvements. 

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1732 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2006-12-13 16:10:26 +00:00
parent ce45aab144
commit 90c1641841
37 changed files with 831 additions and 594 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
C/agc.c
View File

@ -173,7 +173,10 @@ mark_hash_entry(AtomHashEntry *HashPtr)
AtomEntry *at = RepAtom(atm);
do {
#ifdef DEBUG_RESTORE1 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE);
if (IsWideAtom(atm))
fprintf(errout, "Restoring %S\n", at->WStrOfAE);
else
fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE;
@ -211,7 +214,10 @@ mark_atoms(void)
}
do {
#ifdef DEBUG_RESTORE1 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE);
if (IsWideAtom(atm))
fprintf(errout, "Restoring %S\n", at->WStrOfAE);
else
fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE;
@ -330,12 +336,19 @@ clean_atom(AtomHashEntry *HashPtr)
atm = at->NextOfAE;
NOfAtoms--;
} else {
if (IsWideAtom(atm)) {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s\n", at, at->StrOfAE);
fprintf(errout, "Purged %p:%S\n", at, at->WStrOfAE);
#endif
agc_collected += sizeof(AtomEntry)+wcslen(at->WStrOfAE);
} else {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s\n", at, at->StrOfAE);
#endif
agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
}
*patm = at->NextOfAE;
atm = at->NextOfAE;
agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
Yap_FreeCodeSpace((char *)at);
}
}
@ -370,12 +383,19 @@ clean_atoms(void)
NOfAtoms--;
atm = at->NextOfAE;
} else {
#ifdef DEBUG_RESTORE1
fprintf(stderr, "Purged %s\n", at->StrOfAE);
if (IsWideAtom(atm)) {
#ifdef DEBUG_RESTORE3
fprintf(errout, "Purged %p:%S\n", at, at->WStrOfAE);
#endif
agc_collected += sizeof(AtomEntry)+wcslen(at->WStrOfAE);
} else {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s\n", at, at->StrOfAE);
#endif
agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
}
*patm = at->NextOfAE;
atm = at->NextOfAE;
agc_collected += sizeof(AtomEntry) + strlen(at->StrOfAE);
Yap_FreeCodeSpace((char *)at);
}
}

16
C/amasm.c
View File

@ -11,8 +11,11 @@
* File: amasm.c *
* comments: abstract machine assembler *
* *
* Last rev: $Date: 2006-11-15 00:13:36 $ *
* Last rev: $Date: 2006-12-13 16:10:14 $ *
* $Log: not supported by cvs2svn $
* Revision 1.92 2006/11/15 00:13:36 vsc
* fixes for indexing code.
*
* Revision 1.91 2006/11/06 18:35:03 vsc
* 1estranha
*
@ -1310,7 +1313,8 @@ compile_cmp_flags(char *s)
wamreg
Yap_compile_cmp_flags(PredEntry *pred)
{
return compile_cmp_flags(RepAtom(NameOfFunctor(pred->FunctorOfPred))->StrOfAE);
return
compile_cmp_flags(RepAtom(NameOfFunctor(pred->FunctorOfPred))->StrOfAE);
}
static yamop *
@ -3506,12 +3510,16 @@ Yap_InitComma(void)
Functor fp = Yap_MkFunctor(Yap_FullLookupAtom("$generate_pred_info"),4);
code_p->opc = emit_op(_call_cpred);
code_p->u.sla.s = emit_count(-Signed(RealEnvSize));
code_p->u.sla.sla_u.p = RepPredProp(Yap_GetPredPropByFunc(fp,0));
code_p->u.sla.sla_u.p =
code_p->u.sla.p0 =
RepPredProp(Yap_GetPredPropByFunc(fp,0));
code_p->u.sla.bmap = NULL;
GONEXT(sla);
code_p->opc = emit_op(_call);
code_p->u.sla.s = emit_count(-Signed(RealEnvSize));
code_p->u.sla.sla_u.p = PredMetaCall;
code_p->u.sla.sla_u.p =
code_p->u.sla.p0 =
PredMetaCall;
code_p->u.sla.bmap = NULL;
GONEXT(sla);
code_p->opc = emit_op(_deallocate);

33
C/analyst.c
View File

@ -87,16 +87,26 @@ static Int
p_show_op_counters()
{
int i;
char *program;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1)) {
return FALSE;
} else {
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
Atom at1 = AtomOfTerm(t1);
if (IsWideAtom(at1)) {
wchar_t *program;
program = RepAtom(at1)->WStrOfAE;
fprintf(Yap_stderr, "\n Instructions Executed in %S\n", program);
} else {
char *program;
program = RepAtom(at1)->StrOfAE;
fprintf(Yap_stderr, "\n Instructions Executed in %s\n", program);
}
}
fprintf(Yap_stderr, "\n Instructions Executed in %s \n", program);
for (i = 0; i <= _std_top; ++i)
print_instruction(i);
fprintf(Yap_stderr, "\n Control Instructions \n");
@ -300,14 +310,24 @@ p_show_ops_by_group(void)
ccpcount c_cp;
int gets, unifies, puts, writes, controls, choice_pts, indexes, misc,
total;
char *program;
Term t1;
Atom at1;
t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return (FALSE);
else
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
at1 = AtomOfTerm(t1);
if (IsWideAtom(at1)) {
wchar_t *program;
program = RepAtom(at1)->WStrOfAE;
fprintf(Yap_stderr, "\n Instructions Executed in %S\n", program);
} else {
char *program;
program = RepAtom(at1)->StrOfAE;
fprintf(Yap_stderr, "\n Instructions Executed in %s\n", program);
}
c_get.nxvar =
Yap_opcount[_get_x_var];
@ -634,7 +654,6 @@ p_show_ops_by_group(void)
* print_instruction(i);
*/
fprintf(Yap_stderr, "\n Instructions Executed in %s\n", program);
fprintf(Yap_stderr, "Groups are\n\n");
fprintf(Yap_stderr, " GET instructions: %8d (%3d%%)\n", gets,
(gets * 100) / total);

127
C/c_interface.c
View File

@ -10,8 +10,11 @@
* File: c_interface.c *
* comments: c_interface primitives definition *
* *
* Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* Last rev: $Date: 2006-12-13 16:10:14 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.86 2006/11/27 17:42:02 vsc
* support for UNICODE, and other bug fixes.
*
* Revision 1.85 2006/05/16 18:37:30 vsc
* WIN32 fixes
* compiler bug fixes
@ -338,10 +341,9 @@ X_API CELL STD_PROTO(YAP_ThreadCreateEngine,(thread_attr *));
X_API int STD_PROTO(YAP_ThreadAttachEngine,(int));
X_API int STD_PROTO(YAP_ThreadDetachEngine,(int));
X_API int STD_PROTO(YAP_ThreadDestroyEngine,(int));
X_API int STD_PROTO(YAP_ArgsToIntArray,(Term, UInt, const Int *));
X_API Term STD_PROTO(YAP_IntArrayToArgs,(UInt, const Int *));
X_API int STD_PROTO(YAP_ArgsToFloatArray,(Term, UInt, const Float *));
X_API Term STD_PROTO(YAP_FloatArrayToArgs,(UInt, const Float *));
X_API Term STD_PROTO(YAP_MkBlobTerm,(unsigned int));
X_API void *STD_PROTO(YAP_BlobOfTerm,(Term));
X_API Term STD_PROTO(YAP_TermNil,(void));
static int (*do_getf)(void);
@ -475,6 +477,40 @@ YAP_BigNumOfTerm(Term t, void *b)
#endif /* USE_GMP */
}
X_API Term
YAP_MkBlobTerm(unsigned int sz)
{
Term I;
MP_INT *dst;
BACKUP_H();
I = AbsAppl(H);
if (H+(sz+sizeof(MP_INT)/sizeof(CELL)+2) > ASP-1024)
return TermNil;
H[0] = (CELL)FunctorBigInt;
dst = (MP_INT *)(H+1);
dst->_mp_size = 0L;
dst->_mp_alloc = sz;
H += (1+sizeof(MP_INT)/sizeof(CELL));
H[sz] = EndSpecials;
H += sz+1;
RECOVER_H();
return I;
}
X_API void *
YAP_BlobOfTerm(Term t)
{
MP_INT *src;
if (IsVarTerm(t))
return NULL;
if (!IsBigIntTerm(t))
return NULL;
src = (MP_INT *)(RepAppl(t)+1);
return (void *)(src+1);
}
X_API Term
YAP_MkFloatTerm(double n)
{
@ -1640,86 +1676,9 @@ YAP_ThreadDestroyEngine(int wid)
#endif
}
/* Copy a number of terms to an array of integers */
X_API int
YAP_ArgsToIntArray(Term t, UInt size, const Int *ar)
{
Int *dest = (Int *)ar;
CELL *ptr;
if (IsVarTerm(t) ||
!IsApplTerm(t)) return FALSE;
if (ArityOfFunctor(FunctorOfTerm(t)) != size)
return FALSE;
ptr = RepAppl(t)+1;
while (size) {
Term t = *ptr++;
if (IsVarTerm(t) || !IsIntegerTerm(t))
return FALSE;
*dest++ = IntegerOfTerm(t);
}
return TRUE;
}
X_API Term
YAP_IntArrayToArgs(UInt size, const Int *ar)
YAP_TermNil(void)
{
Term t;
BACKUP_H();
CELL *ptr = H+1;
Int *source = (Int *)ar;
if (H+(size+1) >= ASP) {
return TermNil;
}
t = AbsAppl(H);
*H++ = (CELL)Yap_MkFunctor(Yap_LookupAtom("data"),size);
H+=size;
while (size) {
*ptr++ = MkIntegerTerm(*source++);
}
RECOVER_H();
return t;
}
X_API int
YAP_ArgsToFloatArray(Term t, UInt size, const Float *ar)
{
CELL *ptr;
Float *dest = (Float *)ar;
if (IsVarTerm(t) ||
!IsApplTerm(t)) return FALSE;
if (ArityOfFunctor(FunctorOfTerm(t)) != size)
return FALSE;
ptr = RepAppl(t)+1;
while (size) {
Term t = *ptr++;
if (IsVarTerm(t) || !IsFloatTerm(t))
return FALSE;
*dest++ = FloatOfTerm(t);
}
return TRUE;
}
X_API Term
YAP_FloatArrayToArgs(UInt size, const Float *ar)
{
Term t;
BACKUP_H();
CELL *ptr = H+1;
Float *source = (Float *)ar;
if (H+(size+1) >= ASP) {
return TermNil;
}
t = AbsAppl(H);
*H++ = (CELL)Yap_MkFunctor(Yap_LookupAtom("data"),size);
H+=size;
while (size) {
*ptr++ = MkFloatTerm(*source++);
}
RECOVER_H();
return t;
return TermNil;
}

107
C/cdmgr.c
View File

@ -11,8 +11,11 @@
* File: cdmgr.c *
* comments: Code manager *
* *
* Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* Last rev: $Date: 2006-12-13 16:10:14 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.200 2006/11/27 17:42:02 vsc
* support for UNICODE, and other bug fixes.
*
* Revision 1.199 2006/11/15 00:13:36 vsc
* fixes for indexing code.
*
@ -3375,6 +3378,12 @@ p_all_choicepoints(void)
return Yap_unify(ARG1,all_cps(B));
}
static Int
p_all_envs(void)
{
return Yap_unify(ARG1,all_envs(ENV));
}
static Int
p_current_stack(void)
{
@ -5680,12 +5689,69 @@ p_program_continuation(void)
static Term
BuildActivePred(PredEntry *ap, CELL *vect)
{
UInt i;
if (!ap->ArityOfPE) {
return MkVarTerm();
}
for (i = 0; i < ap->ArityOfPE; i++) {
Term t = Deref(vect[i]);
if (IsVarTerm(t)) {
CELL *pt = VarOfTerm(t);
/* one stack */
if (pt > H) {
Term nt = MkVarTerm();
Yap_unify(t, nt);
}
}
}
return Yap_MkApplTerm(ap->FunctorOfPred, ap->ArityOfPE, vect);
}
static int
UnifyPredInfo(PredEntry *pe, int start_arg) {
UInt arity = pe->ArityOfPE;
Term tmod, tname;
if (pe->ModuleOfPred != IDB_MODULE) {
if (pe->ModuleOfPred == PROLOG_MODULE) {
tmod = TermProlog;
} else {
tmod = pe->ModuleOfPred;
}
if (pe->ArityOfPE == 0) {
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
} else {
Functor f = pe->FunctorOfPred;
tname = MkAtomTerm(NameOfFunctor(f));
}
} else {
tmod = pe->ModuleOfPred;
if (pe->PredFlags & NumberDBPredFlag) {
tname = MkIntegerTerm(pe->src.IndxId);
} else if (pe->PredFlags & AtomDBPredFlag) {
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
} else {
Functor f = pe->FunctorOfPred;
tname = MkAtomTerm(NameOfFunctor(f));
}
}
return Yap_unify(XREGS[start_arg], tmod) &&
Yap_unify(XREGS[start_arg+1],tname) &&
Yap_unify(XREGS[start_arg+2],MkIntegerTerm(arity));
}
static Int
p_env_info(void)
{
PredEntry *pe;
yamop *env_cp = (yamop *)IntegerOfTerm(Deref(ARG1));
pe = PREVOP(env_cp,sla)->u.sla.p0;
return UnifyPredInfo(pe, 2);
}
static Int
p_choicepoint_info(void)
{
@ -5693,8 +5759,7 @@ p_choicepoint_info(void)
PredEntry *pe;
int go_on = TRUE;
yamop *ipc = cptr->cp_ap;
Term t, tname, tmod;
UInt arity;
Term t;
while (go_on) {
op_numbers opnum = Yap_op_from_opcode(ipc->opc);
@ -5812,6 +5877,12 @@ p_choicepoint_info(void)
t = BuildActivePred(pe, cptr->cp_args);
break;
case _Nstop:
{
Atom at = Yap_FullLookupAtom("$live");
t = MkAtomTerm(at);
pe = RepPredProp(PredPropByAtom(at, CurrentModule));
}
break;
case _Ystop:
default:
pe = NULL;
@ -5819,33 +5890,7 @@ p_choicepoint_info(void)
return FALSE;
}
}
arity = pe->ArityOfPE;
if (pe->ModuleOfPred != IDB_MODULE) {
if (pe->ModuleOfPred == PROLOG_MODULE) {
tmod = TermProlog;
} else {
tmod = pe->ModuleOfPred;
}
if (pe->ArityOfPE == 0) {
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
} else {
Functor f = pe->FunctorOfPred;
tname = MkAtomTerm(NameOfFunctor(f));
}
} else {
tmod = pe->ModuleOfPred;
if (pe->PredFlags & NumberDBPredFlag) {
tname = MkIntegerTerm(pe->src.IndxId);
} else if (pe->PredFlags & AtomDBPredFlag) {
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
} else {
Functor f = pe->FunctorOfPred;
tname = MkAtomTerm(NameOfFunctor(f));
}
}
return Yap_unify(ARG2, tmod) &&
Yap_unify(ARG3,tname) &&
Yap_unify(ARG4,MkIntegerTerm(arity)) &&
return UnifyPredInfo(pe, 2) &&
Yap_unify(ARG5,t);
}
@ -5906,7 +5951,9 @@ Yap_InitCdMgr(void)
Yap_InitCPred("$p_nth_clause", 4, p_nth_clause, SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$program_continuation", 3, p_program_continuation, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$all_choicepoints", 1, p_all_choicepoints, HiddenPredFlag);
Yap_InitCPred("$all_envs", 1, p_all_envs, HiddenPredFlag);
Yap_InitCPred("$choicepoint_info", 5, p_choicepoint_info, HiddenPredFlag);
Yap_InitCPred("$env_info", 4, p_env_info, HiddenPredFlag);
Yap_InitCPred("$predicate_erased_statistics", 5, p_predicate_erased_statistics, SyncPredFlag);
#ifdef DEBUG
Yap_InitCPred("$predicate_live_cps", 4, p_predicate_lu_cps, 0L);

16
C/dbase.c
View File

@ -4845,22 +4845,6 @@ cont_current_key(void)
READ_UNLOCK(HashChain[i].AERWLock);
i++;
}
i = 0;
while (i < WideAtomHashTableSize) {
/* protect current hash table line, notice that the current
LOCK/UNLOCK algorithm assumes new entries are added to
the *front* of the list, otherwise I should have locked
earlier.
*/
READ_LOCK(HashChain[i].AERWLock);
a = HashChain[i].Entry;
if (a != NIL) {
break;
}
/* move to next entry */
READ_UNLOCK(HashChain[i].AERWLock);
i++;
}
if (i == AtomHashTableSize) {
/* we have left the atom hash table */
/* we don't have a lock over the hash table any longer */

4
C/exec.c
View File

@ -362,7 +362,6 @@ EnterCreepMode(Term t, Term mod) {
LOCK(SignalLock);
CreepFlag = CalculateStackGap();
UNLOCK(SignalLock);
yap_flags[SPY_CREEP_FLAG] = TRUE;
P_before_spy = P;
return (CallPredicate(PredCreep, B, PredCreep->CodeOfPred));
}
@ -601,6 +600,8 @@ p_execute_nonstop(void)
/* call may not define new system predicates!! */
if (RepPredProp(pe)->PredFlags & SpiedPredFlag) {
return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->cs.p_code.TrueCodeOfPred);
} else if (RepPredProp(pe)->PredFlags & (AsmPredFlag|CPredFlag)) {
return RepPredProp(pe)->cs.f_code();
} else {
return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->CodeOfPred);
}
@ -1241,7 +1242,6 @@ exec_absmi(int top)
restore_B();
/* H is not so important, because we're gonna backtrack */
restore_H();
yap_flags[SPY_CREEP_FLAG] = 0;
LOCK(SignalLock);
CreepFlag = CalculateStackGap();
Yap_PrologMode = UserMode;

19
C/globals.c
View File

@ -145,12 +145,14 @@ NewDelayArena(UInt size)
{
attvar_record *max = DelayTop(), *min = max-size;
Term out;
UInt howmuch;
while ((ADDR)min < Yap_GlobalBase+1024) {
if (!Yap_InsertInGlobal((CELL *)max, size*sizeof(attvar_record))) {
if ((howmuch = Yap_InsertInGlobal((CELL *)max, size*sizeof(attvar_record))==0)) {
Yap_Error(OUT_OF_STACK_ERROR,TermNil,"No Stack Space for Non-Backtrackable terms");
return TermNil;
}
size = howmuch/sizeof(attvar_record);
max = DelayTop(), min = max-size;
}
out = CreateDelayArena(max, min);
@ -162,6 +164,8 @@ static Term
GrowDelayArena(Term *arenap, UInt old_size, UInt size, UInt arity)
{
Term arena = *arenap;
UInt howmuch;
if (size == 0) {
if (old_size < 1024) {
size = old_size;
@ -173,10 +177,11 @@ GrowDelayArena(Term *arenap, UInt old_size, UInt size, UInt arity)
size = 64;
}
XREGS[arity+1] = (CELL)arenap;
if (!Yap_InsertInGlobal((CELL *)arena, (size-old_size)*sizeof(attvar_record))) {
if ((howmuch = Yap_InsertInGlobal((CELL *)arena, (size-old_size)*sizeof(attvar_record)))==0) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return TermNil;
}
size = howmuch/sizeof(attvar_record)+old_size;
arenap = (CELL *)XREGS[arity+1];
arena = *arenap;
CreateDelayArena(DelayArenaPt(arena), DelayArenaPt(arena)-size);
@ -189,6 +194,7 @@ static Term
NewArena(UInt size, UInt arity, CELL *where)
{
Term t;
UInt new_size;
if (where == NULL || where == H) {
while (H+size > ASP-1024) {
@ -200,10 +206,11 @@ NewArena(UInt size, UInt arity, CELL *where)
t = CreateNewArena(H, size);
H += size;
} else {
if (!Yap_InsertInGlobal(where, size*sizeof(CELL))) {
if ((new_size=Yap_InsertInGlobal(where, size*sizeof(CELL)))==0) {
Yap_Error(OUT_OF_STACK_ERROR,TermNil,"No Stack Space for Non-Backtrackable terms");
return TermNil;
}
size = new_size/sizeof(CELL);
t = CreateNewArena(where, size);
}
return t;
@ -291,10 +298,11 @@ GrowArena(Term arena, CELL *pt, UInt old_size, UInt size, UInt arity)
H += size;
} else {
XREGS[arity+1] = arena;
if (!Yap_InsertInGlobal(pt, size*sizeof(CELL))) {
if ((size=Yap_InsertInGlobal(pt, size*sizeof(CELL)))==0) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
size = size/sizeof(CELL);
arena = XREGS[arity+1];
}
CreateNewArena(ArenaPt(arena), size+old_size);
@ -1474,10 +1482,11 @@ p_nb_heap_add_to_heap(void)
} else {
extra_size = hmsize;
}
if (!Yap_InsertInGlobal(top, extra_size*2*sizeof(CELL))) {
if ((extra_size=Yap_InsertInGlobal(top, extra_size*2*sizeof(CELL)))==0) {
Yap_Error(OUT_OF_STACK_ERROR,TermNil,"No Stack Space for Non-Backtrackable terms");
return FALSE;
}
extra_size = extra_size/(2*sizeof(CELL));
qd = GetHeap(ARG1,"add_to_heap");
hmsize += extra_size;
if (!qd)

36
C/grow.c
View File

@ -607,7 +607,11 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
}
if (size < ((char *)H0-omax)/8)
size = ((char *)H0-omax)/8;
size0 = size = AdjustPageSize(size);
if (do_grow) {
size0 = size = AdjustPageSize(size);
} else {
size0 = size;
}
/* adjust to a multiple of 256) */
Yap_ErrorMessage = NULL;
Yap_PrologMode |= GrowStackMode;
@ -621,7 +625,7 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
if (size < 0) {
Yap_ErrorMessage = "Global Stack crashed against Local Stack";
Yap_PrologMode &= ~GrowStackMode;
return FALSE;
return 0;
}
}
}
@ -705,7 +709,7 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
fprintf(Yap_stderr, "%% %cO Total of %g sec expanding stacks \n", vb_msg1, (double)total_delay_overflow_time/1000);
}
Yap_PrologMode &= ~GrowStackMode;
return(TRUE);
return size0;
}
static void
@ -1062,19 +1066,7 @@ Yap_growglobal(CELL **ptr)
return(FALSE);
}
#endif
if (!static_growglobal(sz, ptr, NULL))
return(FALSE);
#ifdef TABLING
fix_tabling_info();
#endif /* TABLING */
return(TRUE);
}
int
Yap_InsertInGlobal(CELL *where, UInt howmuch)
{
if (!static_growglobal(howmuch, NULL, where))
if ( static_growglobal(sz, ptr, NULL) == 0)
return FALSE;
#ifdef TABLING
fix_tabling_info();
@ -1083,6 +1075,18 @@ Yap_InsertInGlobal(CELL *where, UInt howmuch)
}
UInt
Yap_InsertInGlobal(CELL *where, UInt howmuch)
{
if ((howmuch = static_growglobal(howmuch, NULL, where)) == 0)
return 0;
#ifdef TABLING
fix_tabling_info();
#endif /* TABLING */
return howmuch;
}
int
Yap_growstack(long size)
{

7
C/init.c
View File

@ -528,7 +528,9 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
p_code->opc = Yap_opcode(_call_cpred);
p_code->u.sla.bmap = NULL;
p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.sla_u.p = pe;
p_code->u.sla.sla_u.p =
p_code->u.sla.p0 =
pe;
p_code = NEXTOP(p_code,sla);
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate);
@ -628,7 +630,7 @@ Yap_InitAsmPred(char *Name, unsigned long int Arity, int code, CPredicate def,
p_code->opc = pe->OpcodeOfPred = Yap_opcode(_call_cpred);
p_code->u.sla.bmap = NULL;
p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.sla_u.p = pe;
p_code->u.sla.sla_u.p = p_code->u.sla.p0 = pe;
p_code = NEXTOP(p_code,sla);
p_code->opc = Yap_opcode(_procceed);
p_code->u.p.p = pe;
@ -837,7 +839,6 @@ InitFlags(void)
yap_flags[YAP_TO_CHARS_FLAG] = QUINTUS_TO_CHARS;
yap_flags[LANGUAGE_MODE_FLAG] = 0;
yap_flags[STRICT_ISO_FLAG] = FALSE;
yap_flags[SPY_CREEP_FLAG] = 0;
yap_flags[SOURCE_MODE_FLAG] = FALSE;
yap_flags[CHARACTER_ESCAPE_FLAG] = SICSTUS_CHARACTER_ESCAPES;
yap_flags[WRITE_QUOTED_STRING_FLAG] = FALSE;

141
C/iopreds.c
View File

@ -83,8 +83,10 @@ static char SccsId[] = "%W% %G%";
STATIC_PROTO (Int PlIOError, (yap_error_number, Term, char *));
STATIC_PROTO (int FilePutc, (int, int));
STATIC_PROTO (int MemPutc, (int, int));
STATIC_PROTO (int console_post_process_read_char, (int, StreamDesc *));
STATIC_PROTO (int console_post_process_read_char, (wchar_t, StreamDesc *));
STATIC_PROTO (int console_post_process_eof, (StreamDesc *));
STATIC_PROTO (int post_process_read_char, (int, StreamDesc *));
STATIC_PROTO (int post_process_eof, (StreamDesc *));
#if USE_SOCKET
STATIC_PROTO (int SocketPutc, (int, int));
STATIC_PROTO (int ConsoleSocketPutc, (int, int));
@ -999,7 +1001,7 @@ static int
ReadlineGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
register wchar_t ch;
while (ttyptr == NULL) {
/* Only sends a newline if we are at the start of a line */
@ -1042,7 +1044,7 @@ ReadlineGetc(int sno)
if (Yap_PrologMode & AbortMode) {
Yap_Error(PURE_ABORT, TermNil, "");
Yap_ErrorMessage = "Abort";
return(console_post_process_read_char(EOF, s));
return console_post_process_eof(s);
}
continue;
} else {
@ -1052,7 +1054,7 @@ ReadlineGetc(int sno)
strncpy (Prompt, RepAtom (*AtPrompt)->StrOfAE, MAX_PROMPT);
/* window of vulnerability closed */
if (myrl_line == NULL)
return(console_post_process_read_char(EOF, s));
return console_post_process_eof(s);
if (myrl_line[0] != '\0' && myrl_line[1] != '\0')
add_history (myrl_line);
ttyptr = myrl_line;
@ -1064,7 +1066,7 @@ ReadlineGetc(int sno)
ch = *((unsigned char *)ttyptr);
ttyptr++;
}
return(console_post_process_read_char(ch, s));
return console_post_process_read_char(ch, s);
}
#endif /* HAVE_LIBREADLINE */
@ -1073,7 +1075,7 @@ ReadlineGetc(int sno)
int
Yap_GetCharForSIGINT(void)
{
int ch;
wchar_t ch;
#if HAVE_LIBREADLINE
if ((Yap_PrologMode & ConsoleGetcMode) && myrl_line != (char *) NULL) {
ch = myrl_line[0];
@ -1175,54 +1177,62 @@ EOFGetc(int sno)
static int
post_process_read_char(int ch, StreamDesc *s)
{
++s->charcount;
++s->linepos;
if (ch == '\n') {
++s->linecount;
++s->charcount;
s->linepos = 0;
/* don't convert if the stream is binary */
if (!(s->status & Binary_Stream_f))
ch = 10;
} else if (ch == EOF) {
s->status |= Eof_Stream_f;
s->stream_getc = EOFGetc;
s->stream_wgetc = get_wchar;
if (CharConversionTable != NULL)
s->stream_wgetc_for_read = ISOWGetc;
else
s->stream_wgetc_for_read = s->stream_wgetc;
return EOFCHAR;
} else {
++s->charcount;
++s->linepos;
}
return ch;
}
/* check if we read a newline or an EOF */
static int
console_post_process_read_char(int ch, StreamDesc *s)
post_process_eof(StreamDesc *s)
{
s->status |= Eof_Stream_f;
s->stream_getc = EOFGetc;
s->stream_wgetc = get_wchar;
if (CharConversionTable != NULL)
s->stream_wgetc_for_read = ISOWGetc;
else
s->stream_wgetc_for_read = s->stream_wgetc;
return EOFCHAR;
}
/* check if we read a newline or an EOF */
static int
console_post_process_read_char(wchar_t ch, StreamDesc *s)
{
if (ch == '\n') {
++s->linecount;
++s->charcount;
s->linepos = 0;
newline = TRUE;
} else if (ch == EOF) {
s->status |= Eof_Stream_f;
s->stream_getc = EOFGetc;
s->stream_wgetc = get_wchar;
if (CharConversionTable != NULL)
s->stream_wgetc_for_read = ISOWGetc;
else
s->stream_wgetc_for_read = s->stream_wgetc;
newline = FALSE;
return (EOFCHAR);
} else {
++s->charcount;
++s->linepos;
newline = FALSE;
}
return(ch);
return ch;
}
/* check if we read a newline or an EOF */
static int
console_post_process_eof(StreamDesc *s)
{
s->status |= Eof_Stream_f;
s->stream_getc = EOFGetc;
s->stream_wgetc = get_wchar;
if (CharConversionTable != NULL)
s->stream_wgetc_for_read = ISOWGetc;
else
s->stream_wgetc_for_read = s->stream_wgetc;
newline = FALSE;
return EOFCHAR;
}
#if USE_SOCKET
@ -1234,7 +1244,7 @@ static int
SocketGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
register Int ch;
char c;
int count;
/* should be able to use a buffer */
@ -1245,7 +1255,7 @@ SocketGetc(int sno)
#endif
if (count == 0) {
s->u.socket.flags = closed_socket;
ch = EOF;
return post_process_eof(s);
} else if (count > 0) {
ch = c;
} else {
@ -1256,9 +1266,9 @@ SocketGetc(int sno)
Yap_Error(SYSTEM_ERROR, TermNil,
"(socket_getc)");
#endif
return EOF;
return post_process_eof(s);
}
return(post_process_read_char(ch, s));
return post_process_read_char(ch, s);
}
/*
@ -1269,8 +1279,8 @@ static int
ConsoleSocketGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
char c;
register wchar_t ch;
Int c;
int count;
/* send the prompt away */
@ -1292,14 +1302,14 @@ ConsoleSocketGetc(int sno)
#endif
Yap_PrologMode &= ~ConsoleGetcMode;
if (count == 0) {
ch = EOF;
return console_post_process_eof(s);
} else if (count > 0) {
ch = c;
} else {
Yap_Error(SYSTEM_ERROR, TermNil, "read");
return(EOF);
return console_post_process_eof(s);
}
return(console_post_process_read_char(ch, s));
return console_post_process_read_char(ch, s);
}
#endif
@ -1307,9 +1317,10 @@ static int
PipeGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
register Int ch;
char c;
/* should be able to use a buffer */
/* should be able to use a buffer */
#if _MSC_VER || defined(__MINGW32__)
DWORD count;
if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &count, NULL) == FALSE) {
@ -1321,14 +1332,14 @@ PipeGetc(int sno)
count = read(s->u.pipe.fd, &c, sizeof(char));
#endif
if (count == 0) {
ch = EOF;
return post_process_eof(s);
} else if (count > 0) {
ch = c;
} else {
Yap_Error(SYSTEM_ERROR, TermNil, "read");
return(EOF);
return post_process_eof(s);
}
return(post_process_read_char(ch, s));
return post_process_read_char(ch, s);
}
/*
@ -1339,7 +1350,7 @@ static int
ConsolePipeGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
register wchar_t ch;
char c;
#if _MSC_VER || defined(__MINGW32__)
DWORD count;
@ -1362,7 +1373,7 @@ ConsolePipeGetc(int sno)
Yap_PrologMode |= ConsoleGetcMode;
PlIOError (SYSTEM_ERROR,TermNil, "read from pipe returned error");
Yap_PrologMode &= ~ConsoleGetcMode;
return(EOF);
return console_post_process_eof(s);
}
#else
/* should be able to use a buffer */
@ -1371,14 +1382,14 @@ ConsolePipeGetc(int sno)
Yap_PrologMode &= ~ConsoleGetcMode;
#endif
if (count == 0) {
ch = EOF;
return console_post_process_eof(s);
} else if (count > 0) {
ch = c;
} else {
Yap_Error(SYSTEM_ERROR, TermNil, "read");
return(EOF);
return console_post_process_eof(s);
}
return(console_post_process_read_char(ch, s));
return console_post_process_read_char(ch, s);
}
/* standard routine, it should read from anything pointed by a FILE *.
@ -1388,10 +1399,12 @@ static int
PlGetc (int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
register Int ch;
ch = YP_getc (s->u.file.file);
return(post_process_read_char(ch, s));
if (ch == EOF)
return post_process_eof(s);
return post_process_read_char(ch, s);
}
/* standard routine, it should read from anything pointed by a FILE *.
@ -1403,8 +1416,9 @@ PlGets (int sno, UInt size, char *buf)
register StreamDesc *s = &Stream[sno];
UInt len;
if (fgets (buf, size, s->u.file.file) == NULL)
return -1;
if (fgets (buf, size, s->u.file.file) == NULL) {
return post_process_eof(s);
}
len = strlen(buf);
s->charcount += len-1;
post_process_read_char(buf[len-2], s);
@ -1418,7 +1432,7 @@ static int
DefaultGets (int sno, UInt size, char *buf)
{
StreamDesc *s = &Stream[sno];
int ch;
char ch;
char *pt = buf;
@ -1435,23 +1449,24 @@ static int
MemGetc (int sno)
{
register StreamDesc *s = &Stream[sno];
Int ch, spos;
Int ch;
int spos;
spos = s->u.mem_string.pos;
if (spos == s->u.mem_string.max_size) {
ch = -1;
return post_process_eof(s);
} else {
ch = s->u.mem_string.buf[spos];
s->u.mem_string.pos = ++spos;
}
return(post_process_read_char(ch, s));
return post_process_read_char(ch, s);
}
/* I dispise this code!!!!! */
static wchar_t
ISOWGetc (int sno)
{
wchar_t ch = Stream[sno].stream_wgetc(sno);
Int ch = Stream[sno].stream_wgetc(sno);
if (ch != EOF && CharConversionTable != NULL) {
if (ch < NUMBER_OF_CHARS) {
@ -1468,7 +1483,7 @@ static int
ConsoleGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
char ch;
int ch;
restart:
if (newline) {
@ -1497,13 +1512,15 @@ ConsoleGetc(int sno)
if (Yap_PrologMode & AbortMode) {
Yap_Error(PURE_ABORT, TermNil, "");
Yap_ErrorMessage = "Abort";
return(console_post_process_read_char(EOF, s));
return console_post_process_eof(s);
}
goto restart;
} else {
Yap_PrologMode &= ~ConsoleGetcMode;
}
return(console_post_process_read_char(ch, s));
if (ch == EOF)
return console_post_process_eof(s);
return console_post_process_read_char(ch, s);
}
/* reads a character from a buffer and does the rest */

4
C/scanner.c
View File

@ -983,7 +983,7 @@ Yap_tokenizer(int inp_stream)
Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)";
break;
}
if (ch >= 0xff){
if (ch > MAX_ISO_LATIN1){
/* does not fit in ISO-LATIN */
wcharp = ch_to_wide(TokImage, charp);
}
@ -1007,7 +1007,7 @@ Yap_tokenizer(int inp_stream)
*wcharp++ = read_quoted_char(&scan_next, inp_stream, QuotedNxtch);
else {
wchar_t next = read_quoted_char(&scan_next, inp_stream, QuotedNxtch);
if (next >= 0xff){
if (next > MAX_ISO_LATIN1){
/* does not fit in ISO-LATIN */
wcharp = ch_to_wide(TokImage, charp);
*wcharp++ = next;

70
C/stdpreds.c
View File

@ -11,8 +11,11 @@
* File: stdpreds.c *
* comments: General-purpose C implemented system predicates *
* *
* Last rev: $Date: 2006-11-28 13:46:41 $,$Author: vsc $ *
* Last rev: $Date: 2006-12-13 16:10:23 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.115 2006/11/28 13:46:41 vsc
* fix wide_char support for name/2.
*
* Revision 1.114 2006/11/27 17:42:03 vsc
* support for UNICODE, and other bug fixes.
*
@ -441,7 +444,6 @@ p_creep(void)
at = Yap_FullLookupAtom("$creep");
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
CreepCode = pred;
yap_flags[SPY_CREEP_FLAG] = TRUE;
do_signal(YAP_CREEP_SIGNAL);
return TRUE;
}
@ -455,7 +457,6 @@ p_delayed_creep(void)
at = Yap_FullLookupAtom("$creep");
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
CreepCode = pred;
yap_flags[SPY_CREEP_FLAG] = FALSE;
do_signal(YAP_CREEP_SIGNAL);
LOCK(SignalLock);
CreepFlag = CalculateStackGap();
@ -754,28 +755,52 @@ p_char_code(void)
return(FALSE);
} else {
Int code = IntegerOfTerm(t1);
char codes[2];
Term tout;
if (code < 0 || code > 256) {
if (code < 0) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,t1,"char_code/2");
return(FALSE);
}
codes[0] = code;
codes[1] = '\0';
tout = MkAtomTerm(Yap_LookupAtom(codes));
return(Yap_unify(ARG1,tout));
if (code > MAX_ISO_LATIN1) {
wchar_t wcodes[2];
wcodes[0] = code;
wcodes[1] = '\0';
tout = MkAtomTerm(Yap_LookupWideAtom(wcodes));
} else {
char codes[2];
codes[0] = code;
codes[1] = '\0';
tout = MkAtomTerm(Yap_LookupAtom(codes));
}
return Yap_unify(ARG1,tout);
}
} else if (!IsAtomTerm(t0)) {
Yap_Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
return(FALSE);
} else {
char *c = RepAtom(AtomOfTerm(t0))->StrOfAE;
if (c[1] != '\0') {
Yap_Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
return(FALSE);
Atom at = AtomOfTerm(t0);
Term tf;
if (IsWideAtom(at)) {
wchar_t *c = RepAtom(at)->WStrOfAE;
if (c[1] != '\0') {
Yap_Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
return FALSE;
}
tf = MkIntegerTerm(c[0]);
} else {
char *c = RepAtom(at)->StrOfAE;
if (c[1] != '\0') {
Yap_Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
return FALSE;
}
tf = MkIntTerm((unsigned char)(c[0]));
}
return(Yap_unify(ARG2,MkIntTerm((Int)(c[0]))));
return Yap_unify(ARG2,tf);
}
}
@ -3309,11 +3334,6 @@ p_set_yap_flags(void)
return(FALSE);
yap_flags[STRICT_ISO_FLAG] = value;
break;
case SPY_CREEP_FLAG:
if (value != 0 && value != 1)
return(FALSE);
yap_flags[SPY_CREEP_FLAG] = value;
break;
case SOURCE_MODE_FLAG:
if (value != 0 && value != 1)
return(FALSE);
@ -3403,6 +3423,17 @@ p_set_yap_flags(void)
return(TRUE);
}
static Int
p_system_mode(void)
{
Int i = IntegerOfTerm(Deref(ARG1));
if (i == 0)
Yap_PrologMode &= ~SystemMode;
else
Yap_PrologMode |= SystemMode;
return TRUE;
}
static Int
p_lock_system(void)
{
@ -3631,6 +3662,7 @@ Yap_InitCPreds(void)
Yap_InitCPred("$walltime", 2, p_walltime, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$access_yap_flags", 2, p_access_yap_flags, SafePredFlag|HiddenPredFlag);
Yap_InitCPred("$set_yap_flags", 2, p_set_yap_flags, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$p_system_mode", 1, p_system_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("abort", 0, p_abort, SyncPredFlag);
Yap_InitCPred("$max_tagged_integer", 1, p_max_tagged_integer, SafePredFlag|HiddenPredFlag);
Yap_InitCPred("$min_tagged_integer", 1, p_min_tagged_integer, SafePredFlag|HiddenPredFlag);

2
C/unify.c
View File

@ -309,7 +309,7 @@ OCUnify_complex(register CELL *pt0, register CELL *pt0_end,
}
}
/* Do we still have compound terms to visit */
if (to_visit < to_visit_max) {
if (to_visit < to_visit_base) {
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];

11
CLPBN/clpbn.yap
View File

@ -3,7 +3,9 @@
:- module(clpbn, [{}/1,
clpbn_flag/2,
set_clpbn_flag/2,
clpbn_flag/3]).
clpbn_flag/3,
clpbn_key/2,
clpbn_marginalise/2]).
:- use_module(library(atts)).
:- use_module(library(lists)).
@ -111,6 +113,11 @@ add_evidence(V,NV) :-
clpbn:put_atts(NV,evidence(V)).
add_evidence(V,V).
clpbn_marginalise(V, Dist) :-
attributes:all_attvars(AVars),
project_attributes([V], AVars),
vel:get_atts(V, posterior(_,_,Dist,_)).
%
% called by top-level
% or by call_residue/2
@ -244,3 +251,5 @@ user:term_expansion((A :- {}), ( :- true )) :- !, % evidence
prolog_load_context(module, M),
store_evidence(M:A).
clpbn_key(Var,Key) :-
get_atts(Var, [key(Key)]).

2
CLPBN/clpbn/evidence.yap
View File

@ -5,7 +5,7 @@
:- module(evidence, [
:- module(clpbn_evidence, [
store_evidence/1,
incorporate_evidence/2
]).

4
CLPBN/clpbn/examples/School/tables.yap
View File

@ -1,7 +1,9 @@
:- use_module(library('clpbn/aggregates'),[cpt_average/5]).
int_table(_, [0.5, 0.4, 0.1],[h, m, l]).
int_table(_, [0.5,
0.4,
0.1],[h, m, l]).
grade_table(I, D,
/* h h h m h l m h m m m l l h l m l l */

11
H/Atoms.h
View File

@ -22,6 +22,8 @@
#define EXTERN
#endif
#include <wchar.h>
/********* operations for atoms ****************************************/
/* Atoms are assumed to be uniquely represented by an OFFSET and to have
@ -47,10 +49,17 @@ typedef struct AtomEntryStruct
rwlock_t ARWLock;
#endif
char StrOfAE[MIN_ARRAY]; /* representation of atom as a string */
union {
char uStrOfAE[MIN_ARRAY]; /* representation of atom as a string */
wchar_t uWStrOfAE[MIN_ARRAY]; /* representation of atom as a string */
} rep;
}
AtomEntry;
#define StrOfAE rep.uStrOfAE
#define WStrOfAE rep.uWStrOfAE
/* Props and Atoms are stored in chains, ending with a NIL */
#if USE_OFFSETS
# define EndOfPAEntr(P) ( Addr(P) == AtomBase)

6
H/Yap.h
View File

@ -10,7 +10,7 @@
* File: Yap.h.m4 *
* mods: *
* comments: main header file for YAP *
* version: $Id: Yap.h,v 1.17 2006-11-27 17:42:03 vsc Exp $ *
* version: $Id: Yap.h,v 1.18 2006-12-13 16:10:25 vsc Exp $ *
*************************************************************************/
#include "config.h"
@ -513,7 +513,6 @@ typedef enum
YAP_TO_CHARS_FLAG = 7,
LANGUAGE_MODE_FLAG = 8,
STRICT_ISO_FLAG = 9,
SPY_CREEP_FLAG = 10,
SOURCE_MODE_FLAG = 11,
CHARACTER_ESCAPE_FLAG = 12,
WRITE_QUOTED_STRING_FLAG = 13,
@ -1152,7 +1151,8 @@ typedef enum
CCallMode = 0x1000, /* In c Call */
UnifyMode = 0x2000, /* In Unify Code */
UserCCallMode = 0x4000, /* In User C-call Code */
MallocMode = 0x8000 /* Doing malloc, realloc, free */
MallocMode = 0x8000, /* Doing malloc, realloc, free */
SystemMode = 0x10000, /* in system mode */
} prolog_exec_mode;
extern prolog_exec_mode Yap_PrologMode;

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.76 2006-08-22 16:12:46 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.77 2006-12-13 16:10:25 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -172,7 +172,7 @@ void STD_PROTO(Yap_InitGlobals,(void));
/* grow.c */
Int STD_PROTO(Yap_total_stack_shift_time,(void));
void STD_PROTO(Yap_InitGrowPreds, (void));
int STD_PROTO(Yap_InsertInGlobal, (CELL *, UInt));
UInt STD_PROTO(Yap_InsertInGlobal, (CELL *, UInt));
int STD_PROTO(Yap_growheap, (int, UInt, void *));
int STD_PROTO(Yap_growstack, (long));
int STD_PROTO(Yap_growtrail, (long, int));

4
Makefile.in
View File

@ -528,6 +528,7 @@ all: startup
@INSTALL_DLLS@ (cd library/yap2swi; make)
@INSTALL_DLLS@ (cd library/Tries; make)
@INSTALL_DLLS@ (cd library/lammpi; make)
@INSTALL_DLLS@ (cd library/matrix; make)
@ENABLE_JPL@ @INSTALL_DLLS@ (cd LGPL/JPL/src; make)
startup: yap@EXEC_SUFFIX@ $(PL_SOURCES)
@ -564,6 +565,7 @@ install_unix: startup libYap.a
@INSTALL_DLLS@ (cd library/yap2swi; make install)
@INSTALL_DLLS@ (cd library/Tries; make install)
@INSTALL_DLLS@ (cd library/lammpi; make install)
@INSTALL_DLLS@ (cd library/matrix; make install)
@ENABLE_JPL@ @INSTALL_DLLS@ (cd LGPL/JPL/src; make install)
mkdir -p $(DESTDIR)$(INCLUDEDIR)
for h in $(INTERFACE_HEADERS); do $(INSTALL) $$h $(DESTDIR)$(INCLUDEDIR); done
@ -584,6 +586,7 @@ install_win32: startup
for h in $(INTERFACE_HEADERS); do $(INSTALL) $$h $(DESTDIR)$(INCLUDEDIR); done
$(INSTALL) config.h $(INCLUDEDIR)/config.h
(cd library/random; make install)
(cd library/matrix; make install)
(cd library/regex; make install)
(cd library/system; make install)
(cd library/yap2swi; make install)
@ -621,6 +624,7 @@ depend: $(HEADERS) $(C_SOURCES)
clean: clean_docs
rm -f *.o *~ *.BAK *.a
@INSTALL_DLLS@ (cd library/matrix; make clean)
@INSTALL_DLLS@ (cd library/random; make clean)
@INSTALL_DLLS@ (cd library/regex; make clean)
@INSTALL_DLLS@ (cd library/system; make clean)

4
changes-5.1.html
View File

@ -16,6 +16,10 @@
<h2>Yap-5.1.2:</h2>
<ul>
<li> NEW: keep history around (use nb and friends).</li>
<li> NEW: fix determinsitic debugging.</li>
<li> NEW: make debugger compatible with threads (use nb and friends).</li>
<li> FIXED: debugger was confused when crossing between regions.</li>
<li> NEW: unify_with_occurs_check was very broken (obs from Aline Paes).</li>
<li> NEW: partial support for UNICODE.</li>
<li> FIXED: &yuml; has ISO-LATIN1 code 255, so it would be confused with EOF

6
configure vendored
View File

@ -15428,7 +15428,7 @@ _ACEOF
fi
mkdir -p library/matrices
mkdir -p library/matrix
mkdir -p library/mpi
mkdir -p library/random
mkdir -p library/regex
@ -15449,7 +15449,7 @@ mkdir -p LGPL/clp
mkdir -p LGPL/clpr
mkdir -p LGPL/chr
ac_config_files="$ac_config_files Makefile library/matrices/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/lammpi/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap"
ac_config_files="$ac_config_files Makefile library/matrix/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/lammpi/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
@ -15976,7 +15976,7 @@ do
case "$ac_config_target" in
# Handling of arguments.
"Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"library/matrices/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/matrices/Makefile" ;;
"library/matrix/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/matrix/Makefile" ;;
"library/regex/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/regex/Makefile" ;;
"library/system/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/system/Makefile" ;;
"library/random/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/random/Makefile" ;;

4
configure.in
View File

@ -1278,7 +1278,7 @@ AC_DEFINE(GC_NO_TAGS,1)
AC_DEFINE(USE_DL_MALLOC,1)
fi
mkdir -p library/matrices
mkdir -p library/matrix
mkdir -p library/mpi
mkdir -p library/random
mkdir -p library/regex
@ -1299,7 +1299,7 @@ mkdir -p LGPL/clp
mkdir -p LGPL/clpr
mkdir -p LGPL/chr
AC_OUTPUT(Makefile library/matrices/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/lammpi/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap)
AC_OUTPUT(Makefile library/matrix/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/lammpi/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap)
make depend

11
include/YapInterface.h
View File

@ -151,6 +151,9 @@ extern X_API YAP_Term PROTO(YAP_HeadOfTerm,(YAP_Term));
/* Term TailOfTerm(Term) */
extern X_API YAP_Term PROTO(YAP_TailOfTerm,(YAP_Term));
/* Term TailOfTerm(Term) */
extern X_API YAP_Term PROTO(YAP_TermNil,(void));
/* YAP_Term MkApplTerm(YAP_Functor f, unsigned int n, YAP_Term[] args) */
extern X_API YAP_Term PROTO(YAP_MkApplTerm,(YAP_Functor,unsigned int,YAP_Term *));
@ -366,11 +369,9 @@ extern X_API int PROTO(YAP_ThreadAttachEngine,(int));
extern X_API int PROTO(YAP_ThreadDetachEngine,(int));
extern X_API int PROTO(YAP_ThreadDestroyEngine,(int));
/* matrices stuff */
extern X_API int PROTO(YAP_ArgsToIntArray,(YAP_Term, YAP_UInt, const YAP_Int *));
extern X_API YAP_Term PROTO(YAP_IntArrayToArgs,(YAP_UInt, const YAP_Int *));
extern X_API int PROTO(YAP_ArgsToFloatArray,(YAP_Term, YAP_UInt, const YAP_Float *));
extern X_API YAP_Term PROTO(YAP_FloatArrayToArgs,(YAP_UInt, const YAP_Float *));
/* blob stuff */
extern X_API YAP_Term PROTO(YAP_MkBlobTerm,(unsigned int));
extern X_API void *PROTO(YAP_BlobOfTerm,(YAP_Term));
/* term comparison */
extern X_API int PROTO(YAP_CompareTerms,(YAP_Term, YAP_Term));

2
library/Makefile.in
View File

@ -37,9 +37,9 @@ PROGRAMS= $(srcdir)/apply_macros.yap \
$(srcdir)/listing.yap \
$(srcdir)/lists.yap \
$(srcdir)/logtalk.yap \
$(srcdir)/matrices.yap \
$(srcdir)/nb.yap \
$(srcdir)/ordsets.yap \
$(srcdir)/matrix.yap \
$(srcdir)/prandom.yap \
$(srcdir)/queues.yap \
$(srcdir)/random.yap \

2
library/swi.yap
View File

@ -149,7 +149,7 @@ cvt_to_swi_atts(att(Mod,Attribute,Atts), ModAttribute) :-
bindings_message(V) -->
{ cvt_bindings(V, Bindings) },
prolog:message(query(YesNo,Bindings)), !.
prolog:message(query(_YesNo,Bindings)), !.
cvt_bindings([],[]).
cvt_bindings([[Name|Value]|L],[AName=Value|Bindings]) :-

7
misc/yap.def
View File

@ -92,7 +92,6 @@ YAP_ThreadAttachEngine
YAP_ThreadDetachEngine
YAP_ThreadDestroyEngine
YAP_CompareTerms
YAP_ArgsToIntArray
YAP_IntArrayToArgs
YAP_ArgsToFloatArray
YAP_FloatArrayToArgs
YAP_MkBlobTerm
YAP_BlobOfTerm
YAP_TermNil

179
pl/boot.yap
View File

@ -45,43 +45,38 @@ true :- true.
;
true
),
'$set_yap_flags'(10,0),
'$allocate_default_arena'(1024, 64),
'$enter_system_mode',
set_value(fileerrors,1),
set_value('$gc',on),
set_value('$lf_verbose',informational),
('$exit_undefp' -> true ; true),
prompt(' ?- '),
get_value('$break',BreakLevel),
nb_setval('$break',0),
% '$set_read_error_handler'(error), let the user do that
nb_setval('$debug',off),
nb_setval('$trace',off),
b_setval('$spy_glist',[]),
% simple trick to find out if this is we are booting from Prolog.
get_value('$user_module',V),
(
BreakLevel =:= 0
V == []
->
% '$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),
( V = [] ->
'$current_module'(_,prolog)
;
'$current_module'(_,V), '$compile_mode'(_,0),
('$access_yap_flags'(16,0) ->
( exists('~/.yaprc') -> load_files('~/.yaprc', []) ; true ),
( exists('~/.prologrc') -> load_files('~/.prologrc', []) ; true ),
( exists('~/prolog.ini') -> load_files('~/prolog.ini', []) ; true )
;
true
)
),
'$db_clean_queues'(0),
'$startup_reconsult',
'$startup_goals'
;
'$print_message'(informational,break(BreakLevel))
).
'$current_module'(_,prolog)
;
'$current_module'(_,V), '$compile_mode'(_,0),
('$access_yap_flags'(16,0) ->
( exists('~/.yaprc') -> load_files('~/.yaprc', []) ; true ),
( exists('~/.prologrc') -> load_files('~/.prologrc', []) ; true ),
( exists('~/prolog.ini') -> load_files('~/prolog.ini', []) ; true )
;
true
)
),
'$db_clean_queues'(0),
'$startup_reconsult',
'$startup_goals'.
%
% encapsulate $cut_by because of co-routining.
%
'$cut_by'(X) :- '$$cut_by'(X).
@ -120,14 +115,17 @@ true :- true.
'$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)),
fail.
'$enter_top_level' :-
get_value('$break',BreakLevel),
( recorded('$trace',on,_) ->
TraceDebug = trace
nb_getval('$break',BreakLevel),
(
nb_getval('$trace',on)
->
TraceDebug = trace
;
recorded('$debug', on, _) ->
TraceDebug = debug
nb_getval('$debug', on)
->
TraceDebug = debug
;
true
true
),
'$print_message'(informational,prompt(BreakLevel,TraceDebug)),
fail.
@ -141,9 +139,10 @@ true :- true.
prompt(' | '),
'$run_toplevel_hooks',
'$read_vars'(user_input,Command,_,_,Varnames),
set_value(spy_gn,1),
( recorded('$spy_skip',_,R), erase(R), fail ; true),
( recorded('$spy_stop',_,R), erase(R), fail ; true),
nb_setval('$spy_gn',1),
% stop at spy-points if debugging is on.
nb_setval('$debug_run',off),
nb_setval('$debug_zip',off),
prompt(_,' |: '),
'$command'((?-Command),Varnames,top),
'$sync_mmapped_arrays',
@ -209,15 +208,6 @@ true :- true.
%
% remove any debugging info after an abort.
%
'$clean_debugging_info' :-
recorded('$spy',_,R),
erase(R),
fail.
'$clean_debugging_info'.
'$erase_sets' :-
eraseall('$'),
eraseall('$$set'),
@ -342,8 +332,7 @@ true :- true.
% but YAP and SICStus does.
%
'$process_directive'(G, _, M) :-
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ),
'$do_not_creep'.
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ).
'$continue_with_command'(reconsult,V,G,Source) :-
'$go_compile_clause'(G,V,5,Source),
@ -352,8 +341,7 @@ true :- true.
'$go_compile_clause'(G,V,13,Source),
fail.
'$continue_with_command'(top,V,G,_) :-
'$query'(G,V),
'$do_not_creep'.
'$query'(G,V).
%
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put
@ -428,27 +416,22 @@ true :- true.
'$yes_no'(G,(?-)).
'$query'(G,V) :-
(
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(G),
'$do_not_creep',
'$output_frozen'(G, V, LGs),
'$write_answer'(V, LGs, Written),
'$write_query_answer_true'(Written),
'$another',
!, fail ;
'$do_not_creep',
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
print_message(help,no)
),
fail
'$exit_system_mode',
'$execute'(G),
( '$enter_system_mode' ; '$exit_system_mode', fail),
'$output_frozen'(G, V, LGs),
'$write_answer'(V, LGs, Written),
'$write_query_answer_true'(Written),
'$another',
!, fail
;
'$enter_system_mode',
'$out_neg_answer'
).
'$yes_no'(G,C) :-
'$current_module'(M),
'$do_yes_no'(G,M),
'$do_not_creep',
'$output_frozen'(G, [], LGs),
'$write_answer'([], LGs, Written),
( Written = [] ->
@ -457,7 +440,11 @@ true :- true.
),
fail.
'$yes_no'(_,_) :-
'$do_not_creep',
'$out_neg_answer'.
'$add_env_and_fail' :- fail.
'$out_neg_answer' :-
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
@ -467,8 +454,9 @@ true :- true.
'$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M).
'$do_yes_no'(G, M) :-
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(M:G).
'$exit_system_mode',
'$execute'(M:G),
( '$enter_system_mode' ; '$exit_system_mode', fail ).
'$write_query_answer_true'([]) :- !,
format(user_error,'~ntrue',[]).
@ -494,7 +482,7 @@ true :- true.
'$flush_all_streams',
fail.
'$present_answer'((?-), Answ) :-
get_value('$break',BL),
nb_getval('$break',BL),
( BL \= 0 -> format(user_error, '[~p] ',[BL]) ;
true ),
( recorded('$print_options','$toplevel'(Opts),_) ->
@ -827,29 +815,26 @@ not(G) :- \+ '$execute'(G).
debugger state */
break :-
( recorded('$trace',Val,R) -> Trace = Val, erase(R); true),
( recorded('$debug',Val,R1) -> Debug = Val, erase(R1); true),
get_value('$break',BL), NBL is BL+1,
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),
nb_getval('$trace',Trace),
nb_setval('$trace',off),
nb_getval('$debug',Debug),
nb_setval('$debug',off),
nb_getval('$break',BL), NBL is BL+1,
nb_getval('$spy_gn',SPY_GN),
b_getval('$spy_glist',GList),
b_setval('$spy_glist',[]),
nb_setval('$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_gn,SPY_GN),
'$set_yap_flags'(10,SPY_CREEP),
set_value(spy_cl,SPY_CL),
set_value(spy_leap,Leap),
b_setval('$spy_glist',GList),
nb_setval('$spy_gn',SPY_GN),
'$set_input'(InpStream), '$set_output'(OutStream),
( recorded('$trace',_,R2), erase(R2), fail; true),
( recorded('$debug',_,R3), erase(R3), fail; true),
(nonvar(Trace) -> recorda('$trace',Trace,_); true),
(nonvar(Debug) -> recorda('$debug',Debug,_); true),
set_value('$break',BL).
nb_setval('$debug',Debug),
nb_setval('$trace',Trace),
nb_setval('$break',BL).
'$silent_bootstrap'(F) :-
get_value('$lf_verbose',OldSilent),
@ -944,14 +929,14 @@ bootstrap(F) :-
'$find_in_path'(library(File),NewFile, _) :-
'$dir_separator'(D),
atom_codes(A,[D]),
( user:library_directory(Dir), '$do_not_creep' ; '$do_not_creep', fail),
user:library_directory(Dir),
'$extend_path'(Dir, A, File, NFile, Goal),
'$search_in_path'(NFile, NewFile), !.
'$find_in_path'(S,NewFile, _) :-
S =.. [Name,File], !,
'$dir_separator'(D),
atom_codes(A,[D]),
( user:file_search_path(Name, Dir), '$do_not_creep' ; '$do_not_creep', fail),
user:file_search_path(Name, Dir),
'$extend_path'(Dir, A, File, NFile, Goal),
'$search_in_path'(NFile, NewFile), !.
'$find_in_path'(File,NewFile,_) :- atom(File), !,
@ -993,10 +978,8 @@ bootstrap(F) :-
expand_term(Term,Expanded) :-
( \+ '$undefined'(term_expansion(_,_), user),
user:term_expansion(Term,Expanded),
'$do_not_creep'
user:term_expansion(Term,Expanded)
;
'$do_not_creep',
'$expand_term_grammar'(Term,Expanded)
),
!.
@ -1079,9 +1062,15 @@ throw(Ball) :-
).
'$run_toplevel_hooks' :-
get_value('$break',0),
nb_getval('$break',0),
recorded('$toplevel_hooks',H,_), !,
( '$execute'(H) -> true ; true),
'$do_not_creep'.
( '$execute'(H) -> true ; true).
'$run_toplevel_hooks'.
'$enter_system_mode' :-
nb_setval('$system_mode',on).
'$exit_system_mode' :-
nb_setval('$system_mode',off),
( nb_getval('$trace',on) -> '$creep' ; true).

28
pl/consult.yap
View File

@ -122,7 +122,7 @@ load_files(Files,Opts) :-
'$lf'(user, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,Reconsult,UseModule) :- !,
'$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,SkipUnixComments,Reconsult,UseModule).
'$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,Reconsult,UseModule) :- !,
'$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,Reconsult,UseModule).
'$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,SkipUnixComments,Reconsult,UseModule).
'$lf'(X, Mod, Call, InfLevel,_,Changed,CompilationMode,Imports,_,Enc,SkipUnixComments,Reconsult,UseModule) :-
'$find_in_path'(X, Y, Call),
'$open'(Y, '$csult', Stream, 0, Enc), !,
@ -184,6 +184,8 @@ use_module(F,Is) :-
use_module(M,F,Is) :-
'$use_module'(M,F,Is).
'$use_module'(U,F,Is) :- nonvar(U), U = user, !,
'$import_to_current_module'(user_input, user, Is).
'$use_module'(M,F,Is) :- nonvar(M), !,
recorded('$module','$module'(F1,M,_),_),
'$load_files'(F1, [if(not_loaded),imports(Is)], use_module(M,F,Is)),
@ -198,6 +200,8 @@ use_module(M,F,Is) :-
'$csult'([F|L], M) :- '$consult'(F, M), '$csult'(L, M).
'$do_lf'(F, ContextModule, Stream, InfLevel, _, Imports, SkipUnixComments, Reconsult, UseModule) :-
nb_getval('$system_mode', OldMode),
( OldMode == off -> '$enter_system_mode' ; true ),
'$record_loaded'(Stream, M),
'$current_module'(OldModule,ContextModule),
getcwd(OldD),
@ -223,7 +227,6 @@ use_module(M,F,Is) :-
EndMsg = consulted
),
'$print_message'(InfLevel, loading(StartMsg, File)),
( recorded('$trace', on, TraceR) -> erase(TraceR) ; true),
( SkipUnixComments == skip_unix_comments ->
'$skip_unix_comments'(Stream)
;
@ -231,7 +234,6 @@ use_module(M,F,Is) :-
),
'$loop'(Stream,Reconsult),
'$end_consult',
( nonvar(TraceR) -> recorda('$trace', on, _) ; true),
(
Reconsult = reconsult ->
'$clear_reconsulting'
@ -248,6 +250,7 @@ use_module(M,F,Is) :-
( LC == 0 -> prompt(_,' |: ') ; true),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
'$print_message'(InfLevel, loaded(EndMsg, File, Mod, T, H)),
( OldMode == off -> '$exit_system_mode' ; true ),
'$exec_initialisation_goals',
!.
@ -300,9 +303,17 @@ use_module(M,F,Is) :-
erase(R),
G \= '$',
'$current_module'(M),
'$system_catch'(once(M:G), M, Error, user:'$LoopError'(Error, top)),
'$do_not_creep',
fail.
nb_getval('$system_mode', OldMode),
( OldMode == on -> '$exit_system_mode' ; true ),
% run initialization under user control (so allow debugging this stuff).
(
'$system_catch'(once(M:G), M, Error, user:'$LoopError'(Error, top)),
fail
;
OldMode = on,
'$enter_system_mode',
fail
).
'$exec_initialisation_goals'.
'$include'(V, _) :- var(V), !,
@ -333,8 +344,11 @@ use_module(M,F,Is) :-
'$system_catch'(load_files(X, []),Module,Error,'$Error'(Error))
;
set_value('$verbose',off),
load_files(X, [silent(true),skip_unix_comments])
'$system_catch'(load_files(X, [silent(true),skip_unix_comments]),Module,_,fail)
;
true
),
!,
( '$access_yap_flags'(15, 0) -> true ; halt).
'$skip_unix_comments'(Stream) :-

4
pl/corout.yap
View File

@ -641,11 +641,9 @@ call_residue(Goal,Residue) :-
'$project_module'([Mod|LMods], LIV, LAV) :-
\+ '$undefined'(project_attributes(LIV, LAV), Mod),
'$execute'(Mod:project_attributes(LIV, LAV)), !,
'$do_not_creep',
attributes:all_attvars(NLAV),
'$project_module'(LMods,LIV,NLAV).
'$project_module'([_|LMods], LIV, LAV) :-
'$do_not_creep',
'$project_module'(LMods,LIV,LAV).
@ -662,11 +660,9 @@ call_residue(Goal,Residue) :-
attributes:convert_att_var(V,G),
G \= true,
!,
'$do_not_creep',
'$split_goals_for_catv'(G,V,NGs,IGs),
'$do_convert_att_vars'(LAV, LIV, IGs).
'$do_convert_att_vars'([_|LAV], LIV, Gs) :-
'$do_not_creep',
'$do_convert_att_vars'(LAV, LIV, Gs).
'$split_goals_for_catv'((G,NG),V,[V-G|Gs],Gs0) :- !,

444
pl/debug.yap
View File

@ -135,36 +135,37 @@ nospyall.
% debug mode -> debug flag = 1
debug :- recordaifnot('$debug',on,_), !,
debug :-
'$start_debugging'(on),
'$print_message'(informational,debug(debug)).
debug.
'$start_debugging'(Mode) :-
nb_setval('$debug',Mode),
nb_setval('$debug_run',off).
nodebug :-
recorded('$debug',_,R), erase(R), fail.
nodebug :-
recorded('$trace',_,R), erase(R), fail.
nodebug :- nospyall,
'$set_yap_flags'(10,0),
'$start_debugging'(Mode) :-
nb_setval('$debug',Mode),
nb_setval('$debug_run',off).
nodebug :-
nb_setval('$debug',off),
nb_setval('$trace',off),
'$print_message'(informational,debug(off)).
%
% remove any debugging info after an abort.
%
trace :-
recorded('$trace',on,_), !.
trace :-
recorded('$spy_skip',_,R), erase(R), fail.
nb_getval('$trace',on), !.
trace :-
( recordaifnot('$trace',on,_) -> true ; true),
( recordaifnot('$debug',on,_) -> true ; true),
( recordaifnot('$spy_stop',on,_) -> true ; true),
'$set_yap_flags'(10,1),
nb_setval('$trace',on),
'$start_debugging'(on),
'$print_message'(informational,debug(trace)),
'$creep'.
notrace :-
recorded('$debug',_,R), erase(R), fail.
notrace :-
recorded('$trace',_,R), erase(R), fail.
notrace :-
'$print_message'(informational,debug(off)).
notrace :-
nodebug.
/*-----------------------------------------------------------------------------
@ -185,35 +186,35 @@ leash(X) :-
'$show_leash'(Msg,0) :-
'$print_message'(Msg,leash([])).
'$show_leash'(Msg,Code) :-
'$check_leash_bit'(Code,2'1000,L3,call,LF),
'$check_leash_bit'(Code,2'0100,L2,exit,L3),
'$check_leash_bit'(Code,2'0010,L1,redo,L2),
'$check_leash_bit'(Code,2'0001,[],fail,L1),
'$check_leash_bit'(Code,0x8,L3,call,LF),
'$check_leash_bit'(Code,0x4,L2,exit,L3),
'$check_leash_bit'(Code,0x2,L1,redo,L2),
'$check_leash_bit'(Code,0x1,[],fail,L1),
'$print_message'(Msg,leash(LF)).
'$check_leash_bit'(Code,Bit,L0,_,L0) :- Bit /\ Code =:= 0, !.
'$check_leash_bit'(_,_,L0,Name,[Name|L0]).
'$leashcode'(full,2'1111) :- !.
'$leashcode'(on,2'1111) :- !.
'$leashcode'(half,2'1010) :- !.
'$leashcode'(loose,2'1000) :- !.
'$leashcode'(off,2'0000) :- !.
'$leashcode'(none,2'0000) :- !.
'$leashcode'(full,0xf) :- !.
'$leashcode'(on,0xf) :- !.
'$leashcode'(half,0xb) :- !.
'$leashcode'(loose,0x8) :- !.
'$leashcode'(off,0x0) :- !.
'$leashcode'(none,0x0) :- !.
%'$leashcode'([L|M],Code) :- !, '$leashcode_list'([L|M],Code).
'$leashcode'([L|M],Code) :- !,
'$list2Code'([L|M],Code).
'$leashcode'(N,N) :- integer(N), N >= 0, N =< 2'1111.
'$leashcode'(N,N) :- integer(N), N >= 0, N =< 0xf.
'$list2Code'(V,_) :- var(V), !,
'$do_error'(instantiation_error,leash(V)).
'$list2Code'([],0) :- !.
'$list2Code'([V|L],_) :- var(V), !,
'$do_error'(instantiation_error,leash([V|L])).
'$list2Code'([call|L],N) :- '$list2Code'(L,N1), N is 2'1000 + N1.
'$list2Code'([exit|L],N) :- '$list2Code'(L,N1), N is 2'0100 + N1.
'$list2Code'([redo|L],N) :- '$list2Code'(L,N1), N is 2'0010 + N1.
'$list2Code'([fail|L],N) :- '$list2Code'(L,N1), N is 2'0001 + N1.
'$list2Code'([call|L],N) :- '$list2Code'(L,N1), N is 0x8 + N1.
'$list2Code'([exit|L],N) :- '$list2Code'(L,N1), N is 0x4 + N1.
'$list2Code'([redo|L],N) :- '$list2Code'(L,N1), N is 0x2 + N1.
'$list2Code'([fail|L],N) :- '$list2Code'(L,N1), N is 0x1 + N1.
/*-----------------------------------------------------------------------------
@ -223,7 +224,7 @@ leash(X) :-
debugging :-
( recorded('$debug',on,_) ->
( nb_getval('$debug',on) ->
'$print_message'(help,debug(debug))
;
'$print_message'(help,debug(off))
@ -239,7 +240,6 @@ debugging :-
-----------------------------------------------------------------------------*/
% ok, I may have a spy point for this goal, or not.
% if I do, I should check what mode I am in.
% Goal/Mode Have Spy Not Spied
@ -255,7 +255,7 @@ debugging :-
% spy_gn goal number 1 1...
% spy_trace trace 0 0, 1
% spy_skip leap off Num (stop level)
% spy_stop stop at spy points on on,off
% debug_prompt stop at spy points on on,off
% a flip-flop is also used
% when 1 spying is enabled *(the same as spy stop).
@ -266,14 +266,18 @@ debugging :-
% take care with hidden goals.
%
% $spy may be called from user code, so be careful.
'$spy'([Mod|G]) :-
nb_getval('$debug',off), !,
'$execute_nonstop'(G,Mod).
'$spy'([Mod|G]) :-
nb_getval('$system_mode',on), !,
'$execute_nonstop'(G,Mod).
'$spy'([Mod|G]) :-
CP is '$last_choice_pt',
'$do_spy'(G, Mod, CP, yes).
% last argument to do_spy says that we are at the end of a context. It
% is required to know whether we are controlled by the debugger.
'$do_spy'(_, _, _, _) :-
'$do_not_creep', fail.
'$do_spy'(!, _, CP, _) :- !, '$cut_by'(CP).
'$do_spy'('$cut_by'(M), _, _, _) :- !, '$cut_by'(M).
'$do_spy'(true, _, _, _) :- !.
@ -312,21 +316,22 @@ debugging :-
'$do_spy'((not(G)), M, CP, InControl) :- !,
\+ '$do_spy'(G, M, CP, InControl).
'$do_spy'(G, Module, _, InControl) :-
get_value(spy_gn,L), /* get goal no. */
L1 is L+1, /* bump it */
set_value(spy_gn,L1), /* and save it globaly */
'$loop_spy'(L, G, Module, InControl). /* set creep on */
nb_getval('$spy_gn',L), /* get goal no. */
L1 is L+1, /* bump it */
nb_setval('$spy_gn',L1), /* and save it globaly */
b_getval('$spy_glist',History), /* get goal list */
b_setval('$spy_glist',[info(L,Module,G,Retry,Det)|History]), /* and update it */
'$loop_spy'(L, G, Module, InControl). /* set creep on */
% we are skipping, so we can just call the goal,
% while leaving the minimal structure in place.
'$loop_spy'(GoalNumber, G, Module, InControl) :-
'$system_catch'('$loop_spy2'(GoalNumber, G, Module, InControl),
'$save_current_choice_point'(CP),
'$system_catch'('$loop_spy2'(GoalNumber, G, Module, InControl, CP),
Module, Event,
'$loop_spy_event'(Event, GoalNumber, G, Module, InControl)).
% handle weird things happening in the debugger.
'$loop_spy_event'(_, _, _, _, _) :-
'$do_not_creep', fail.
'$loop_spy_event'('$retry_spy'(G0), GoalNumber, G, Module, InControl) :-
G0 >= GoalNumber, !,
'$loop_spy'(GoalNumber, G, Module, InControl).
@ -337,7 +342,7 @@ debugging :-
'$loop_fail'(GoalNumber, G, Module, InControl).
'$loop_spy_event'('$fail_spy'(GoalNumber), _, _, _, _) :- !,
throw('$fail_spy'(GoalNumber)).
'$loop_spy_event'('$done_spy'(G0), GoalNumber, _, _, _) :-
'$loop_spy_event'('$done_spy'(G0,G), GoalNumber, G, _, _) :-
G0 >= GoalNumber, !,
'$continue_debugging'.
'$loop_spy_event'('$done_spy'(GoalNumber), _, _, _, _) :- !,
@ -347,7 +352,7 @@ debugging :-
'$loop_spy_event'(Event, GoalNumber, G, Module, InControl) :-
'$debug_error'(Event),
'$system_catch'(
('$trace'(exception,G,Module,GoalNumber),fail),
('$trace'(exception,G,Module,GoalNumber,_),fail),
Module,NewEvent,
'$loop_spy_event'(NewEvent, GoalNumber, G, Module, InControl)).
@ -358,38 +363,49 @@ debugging :-
'$loop_fail'(GoalNumber, G, Module, InControl) :-
'$system_catch'(('$trace'(fail, G, Module, GoalNumber),
'$system_catch'(('$trace'(fail, G, Module, GoalNumber,_),
fail ),
Module, Event,
'$loop_spy_event'(Event, GoalNumber, G, Module, InControl)).
% if we are in
'$loop_spy2'(GoalNumber, G, Module, InControl) :-
'$loop_spy2'(GoalNumber, G, Module, InControl, CP) :-
/* the following choice point is where the predicate is called */
b_getval('$spy_glist',[info(_,_,_,Retry,Det)|_]), /* get goal list */
(
/* call port */
'$enter_goal'(GoalNumber, G, Module),
'$spycall'(G, Module, InControl),
(
'$debugger_deterministic_goal'(G) ->
Det=true
;
Det=false
),
/* go execute the predicate */
(
'$do_not_creep',
'$show_trace'(exit,G,Module,GoalNumber), /* output message at exit */
'$show_trace'(exit,G,Module,GoalNumber,Det), /* output message at exit */
/* exit port */
/* get rid of deterministic computations */
('$debugger_deterministic_goal'(G) -> throw('$done_spy'(GoalNumber)) ; true),
'$continue_debugging'
;
(
Det == true
->
'$cut_by'(CP)
;
true
),
'$continue_debugging'
;
/* backtracking from exit */
/* we get here when we want to redo a goal */
'$do_not_creep',
/* redo port */
'$show_trace'(redo,G,Module,GoalNumber), /* inform user_error */
'$show_trace'(redo,G,Module,GoalNumber,_), /* inform user_error */
Retry = true,
'$continue_debugging'(InControl,G,Module),
fail /* to backtrack to spycalls */
)
;
'$do_not_creep',
'$show_trace'(fail,G,Module,GoalNumber), /* inform at fail port */
'$show_trace'(fail,G,Module,GoalNumber,_), /* inform at fail port */
'$continue_debugging',
/* fail port */
fail
@ -397,36 +413,45 @@ debugging :-
'$enter_goal'(GoalNumber, G, Module) :-
'$avoid_goal'(GoalNumber, G, Module), !.
'$zip'(GoalNumber, G, Module), !.
'$enter_goal'(GoalNumber, G, Module) :-
'$trace'(call, G, Module, GoalNumber).
'$trace'(call, G, Module, GoalNumber, _).
'$show_trace'(_, G, Module, GoalNumber) :-
'$avoid_goal'(GoalNumber, G, Module), !.
'$show_trace'(P,G,Module,GoalNumber) :-
'$trace'(P,G,Module,GoalNumber).
'$show_trace'(_, G, Module, GoalNumber,_) :-
'$zip'(GoalNumber, G, Module), !.
'$show_trace'(P,G,Module,GoalNumber,Deterministic) :-
'$trace'(P,G,Module,GoalNumber,Deterministic).
'$avoid_goal'(_, _, _) :-
\+ recorded('$debug',on,_), !.
'$avoid_goal'(GoalNumber, G, Module) :-
recorded('$spy_skip', Value, _),
'$continue_avoid_goal'(GoalNumber, G, Module, Value).
% for leap keep on going until finding something spied.
'$continue_avoid_goal'(_, G, Module, _) :-
recorded('$spy_stop', on, _), !,
\+ '$pred_being_spied'(G, Module).
% for skip keep on going until we get back.
'$continue_avoid_goal'(GoalNumber, _, _, Value) :-
number(Value),
Value < GoalNumber.
%
% skip a goal or a port
%
'$zip'(GoalNumber, G, Module) :-
nb_getval('$debug_run',StopPoint),
% zip mode off, we cannot zip
StopPoint \= off,
(
% skip spy points (eg, s).
StopPoint == spy
->
\+ '$pred_being_spied'(G, Module)
;
% skip goals (eg, l).
number(StopPoint)
->
StopPoint < GoalNumber
;
% skip goals and ports (eg, l).
StopPoint == spy(StoPoint)
->
\+ '$pred_being_spied'(G, Module), StopPoint < GoalNumber
).
%
'$spycall'(G, M, _) :-
( '$access_yap_flags'(10,0);
'$system_predicate'(G,M), \+ '$is_metapredicate'(G,M)
), !,
'$system_predicate'(G,M),
\+ '$is_metapredicate'(G,M),
!,
'$execute_nonstop'(G, M).
'$spycall'(G, M, InControl) :-
'$flags'(G,M,F,F),
@ -434,7 +459,6 @@ debugging :-
% use the interpreter
CP is '$last_choice_pt',
'$clause'(G, M, Cl),
'$do_not_creep',
'$do_spy'(Cl, M, CP, InControl).
'$spycall'(G, M, InControl) :-
'$undefined'(G, M), !,
@ -451,34 +475,38 @@ debugging :-
'$continue_debugging'(InControl, G, M),
'$execute_clause'(G, M, R, CP).
'$trace'(P,G,Module,L) :-
'$trace'(P,G,Module,L,Deterministic) :-
% at this point we are done with leap or skip
nb_setval('$debug_run',off),
% make sure we run this code outside debugging mode.
nb_setval('$debug', off),
repeat,
'$trace_msg'(P,G,Module,L,Deterministic),
(
'$unleashed'(P),
'$action'(10,P,L,G,Module,Debug)
;
write(user_error,' ? '), get0(user_input,C),
'$action'(C,P,L,G,Module,Debug)
),
nb_setval('$debug', Debug),
!.
'$trace_msg'(P,G,Module,L,Deterministic) :-
flush_output(user_output),
flush_output(user_error),
recorded('$debug',on,R0), erase(R0),
repeat,
(P = exit, \+ '$debugger_deterministic_goal'(G) -> Det = '?' ; Det = ''),
('$pred_being_spied'(G,Module) -> CSPY = '*' ; CSPY = ' '),
(P = exit, Deterministic \= true -> Det = '?' ; Det = ' '),
('$pred_being_spied'(G,Module) -> CSPY = '*' ; CSPY = ' '),
% vsc: fix this
% ( SL = L -> SLL = '>' ; SLL = ' '),
SLL = ' ',
( recorded('$debug',on, R), erase(R), fail ; true),
( Module\=prolog,
Module\=user ->
format(user_error,"~a~a~a (~d) ~q: ~a:",[Det,CSPY,SLL,L,P,Module])
;
format(user_error,"~a~a~a (~d) ~q:",[Det,CSPY,SLL,L,P])
),
'$debugger_write'(user_error,G),
( nonvar(R0), recordaifnot('$debug',on,_), fail ; true),
(
'$unleashed'(P),
'$action'(10,P,L,G,Module)
;
write(user_error,' ? '), get0(user_input,C),
'$action'(C,P,L,G,Module)
),
!.
% ( SL = L -> SLL = '>' ; SLL = ' '),
SLL = ' ',
( Module\=prolog,
Module\=user ->
format(user_error,'~a~a~a (~d) ~q: ~a:',[Det,CSPY,SLL,L,P,Module])
;
format(user_error,'~a~a~a (~d) ~q:',[Det,CSPY,SLL,L,P])
),
'$debugger_write'(user_error,G).
'$unleashed'(call) :- get_value('$leash',L), L /\ 2'1000 =:= 0.
'$unleashed'(exit) :- get_value('$leash',L), L /\ 2'0100 =:= 0.
@ -493,55 +521,53 @@ debugging :-
'$debugger_write'(Stream, G) :-
writeq(Stream, G).
'$action'(10,_,_,_,_) :- % newline creep
( recorded('$spy_skip',_,R), erase(R), fail ; true ),
'$set_yap_flags'(10,1).
'$action'(0'!,_,_,_,_) :- !, % ! g execute
'$action'(10,_,_,_,_,on). % newline creep
'$action'(0'!,_,_,_,_,_) :- !, % ! g execute
read(user,G),
% don't allow yourself to be caught by creep.
'$access_yap_flags'(10, CL),
'$set_yap_flags'(10, 0),
nb_getval('$debug',OldDeb),
nb_setval('$debug',off),
( '$execute'(G) -> true ; true),
'$set_yap_flags'(10, CL),
nb_setval('$debug',OldDeb),
% '$skipeol'(0'!),
fail.
'$action'(0'<,_,_,_,_) :- !, % <Depth
'$action'(0'<,_,_,_,_,_) :- !, % <Depth
'$new_deb_depth',
'$skipeol'(0'<),
fail.
'$action'(0'^,_,_,G,_) :- !,
'$action'(0'^,_,_,G,_,_) :- !,
'$print_deb_sterm'(G),
'$skipeol'(0'^),
fail.
'$action'(0'a,_,_,_,_) :- !, % a abort
'$action'(0'a,_,_,_,_,off) :- !, % a abort
'$skipeol'(0'a),
abort.
'$action'(0'b,_,_,_,_) :- !, % b break
'$action'(0'b,_,_,_,_,_) :- !, % b break
'$skipeol'(0'b),
break,
fail.
'$action'(0'A,_,_,_,_) :- !, % b break
'$action'(0'A,_,_,_,_,_) :- !, % b break
'$skipeol'(0'A),
'$show_choicepoint_stack',
fail.
'$action'(0'c,_,_,_,_) :- !, % c creep
'$set_yap_flags'(10,1),
'$action'(0'c,_,_,_,_,on) :- !, % c creep
'$skipeol'(0'c).
'$action'(0'e,_,_,_,_) :- !, % e exit
'$action'(0'e,_,_,_,_,_) :- !, % e exit
'$skipeol'(0'e),
halt.
'$action'(0'f,_,CallId,_,_) :- !, % f fail
'$action'(0'f,_,CallId,_,_,_) :- !, % f fail
'$scan_number'(0'f, CallId, GoalId),
nb_setval('$debug,on'),
throw('$fail_spy'(GoalId)).
'$action'(0'h,_,_,_,_) :- !, % h help
'$action'(0'h,_,_,_,_,_) :- !, % h help
'$action_help',
'$skipeol'(104),
fail.
'$action'(0'?,_,_,_,_) :- !, % ? help
'$action'(0'?,_,_,_,_,_) :- !, % ? help
'$action_help',
'$skipeol'(104),
fail.
'$action'(0'p,_,_,G,Module) :- !, % p print
'$action'(0'p,_,_,G,Module,_) :- !, % p print
((Module = prolog ; Module = user) ->
print(user_error,G), nl(user_error)
;
@ -549,7 +575,7 @@ debugging :-
),
'$skipeol'(0'p),
fail.
'$action'(0'd,_,_,G,Module) :- !, % d display
'$action'(0'd,_,_,G,Module,_) :- !, % d display
((Module = prolog ; Module = user) ->
display(user_error,G), nl(user_error)
;
@ -557,53 +583,55 @@ debugging :-
),
'$skipeol'(0'd),
fail.
'$action'(0'l,_,CallNumber,_,_) :- !, % l leap
'$action'(0'l,_,CallNumber,_,_,on) :- !, % l leap
'$skipeol'(0'l),
( recorded('$spy_skip',_,R), erase(R), fail ; recorda('$spy_skip',CallNumber,_) ),
( recordaifnot('$spy_stop',on,_) -> true ; true ),
'$set_yap_flags'(10,1).
'$action'(0'n,_,_,_,_) :- !, % n nodebug
'$skipeol'(0'n),
'$set_yap_flags'(10,0),
( recorded('$spy_stop',_,R), erase(R), fail ; true),
nodebug.
'$action'(0'k,_,CallNumber,_,_) :- !, % k quasi leap
'$skipeol'(0'k),
( recorded('$spy_skip',_,R), erase(R), fail ; recorda('$spy_skip',CallNumber,_) ),
( recordaifnot('$spy_stop',on,_) -> true ; true ),
'$set_yap_flags'(10,0).
nb_setval('$debug_run',spy).
'$action'(0'z,_,CallNumber,_,_,zip) :- !, % k zip, fast leap
'$skipeol'(0'z),
nb_setval('$debug_run',spy).
% skip first call (for current goal),
% stop next time.
'$action'(0'r,_,CallId,_,_) :- !, % r retry
'$scan_number'(0'r,CallId,ScanNumber),
'$action'(0'k,_,CallNumber,_,_,zip) :- !, % k zip, fast leap
'$skipeol'(0'k),
nb_setval('$debug_run',spy).
% skip first call (for current goal),
% stop next time.
'$action'(0'n,_,_,_,_,off) :- !, % n nodebug
'$skipeol'(0'n),
% tell debugger never to stop.
nb_setval('$debug_run', -1),
nodebug.
'$action'(0'r,_,CallId,_,_,_) :- !, % r retry
'$scan_number'(0'r,CallId,ScanNumber),
nb_setval('$debug',on),
throw('$retry_spy'(ScanNumber)).
'$action'(0's,P,CallNumber,_,_) :- !, % s skip
'$action'(0's,P,CallNumber,_,_,on) :- !, % s skip
'$skipeol'(0's),
( (P=call; P=redo) ->
'$set_yap_flags'(10,1),
( recorded('$spy_skip',_,R), erase(R), fail ; recorda('$spy_skip',CallNumber,_) ),
( recorded('$spy_stop',_,R), erase(R), fail ; true)
nb_setval('$debug_run',CallNumber)
;
'$ilgl'(0's)
).
'$action'(0't,P,CallNumber,_,_) :- !, % t fast skip
'$action'(0't,P,CallNumber,_,_,zip) :- !, % t fast skip
'$skipeol'(0't),
( (P=call; P=redo) ->
( recorded('$spy_skip',_,R), erase(R), fail ; recorda('$spy_skip',CallNumber,_) ),
( recorded('$spy_stop',_,R), erase(R), fail ; true),
'$set_yap_flags'(10,0)
;
'$ilgl'(0't)
nb_setval('$debug_run',CallNumber)
;
'$ilgl'(0't)
).
'$action'(0'+,_,_,G,M) :- !, % + spy this
'$action'(0'+,_,_,G,M,_) :- !, % + spy this
functor(G,F,N), spy(M:(F/N)),
'$skipeol'(0'+),
fail.
'$action'(0'-,_,_,G,M) :- !, % - nospy this
'$action'(0'-,_,_,G,M,_) :- !, % - nospy this
functor(G,F,N), nospy(M:(F/N)),
'$skipeol'(0'-),
fail.
'$action'(C,_,_,_,_) :-
'$action'(0'g,_,_,_,_,_) :- !, % g ancestors
'$scan_number'(0'g,-1,HowMany),
'$show_ancestors'(HowMany),
fail.
'$action'(C,_,_,_,_,_) :-
'$skipeol'(C),
'$ilgl'(C),
fail.
@ -612,29 +640,60 @@ debugging :-
'$continue_debugging'(no,_,_) :- !.
'$continue_debugging'(_,G,M) :-
'$system_predicate'(G,M), !,
( '$access_yap_flags'(10,1) -> '$late_creep' ; true).
'$late_creep'.
'$continue_debugging'(_,G,M) :-
'nb_getval'('$debug_run',Zip),
(Zip == nodebug ; number(Zip) ; Zip = spy(_) ), !.
'$continue_debugging'(_,_,_) :-
'$continue_debugging'.
'$continue_debugging' :-
'$access_yap_flags'(10,1), !,
'$creep'.
'$continue_debugging'.
'$show_ancestors'(HowMany) :-
b_getval('$spy_glist',[_|History]),
(
History == []
->
'$print_message'(help, ancestors([]))
;
'$show_ancestors'(History,HowMany),
nl(user_error)
).
'$show_ancestors'([],_).
'$show_ancestors'([_|_],0) :- !.
'$show_ancestors'([info(L,M,G,Retry,Det)|History],HowMany) :-
'$show_ancestor'(L,M,G,Retry,Det,HowMany,HowMany1),
'$show_ancestors'(History,HowMany1).
% skip exit port, we're looking at true ancestors
'$show_ancestor'(_,_,_,_,Det,HowMany,HowMany) :-
nonvar(Det), !.
% look at retry
'$show_ancestor'(GoalNumber, M, G, Retry, Det, HowMany, HowMany1) :-
nonvar(Retry), !,
HowMany1 is HowMany-1,
'$trace_msg'(redo, G, M, GoalNumber, _), nl(user_error).
'$show_ancestor'(GoalNumber, M, G, Retry, Det, HowMany, HowMany1) :-
HowMany1 is HowMany-1,
'$trace_msg'(call, G, M, GoalNumber, _), nl(user_error).
'$action_help' :-
format(user_error,"newline creep a abort~n", []),
format(user_error,"c creep e exit~n", []),
format(user_error,"f Goal fail h help~n", []),
format(user_error,"l leap r Goal retry~n", []),
format(user_error,"s skip t fastskip~n", []),
format(user_error,"q quasiskip k quasileap~n", []),
format(user_error,"b break n no debug~n", []),
format(user_error,"p print d display~n", []),
format(user_error,"<D depth D < full term~n", []),
format(user_error,"+ spy this - nospy this~n", []),
format(user_error,"^ view subg ^^ view using~n", []),
format(user_error,"A alternatives~n", []),
format(user_error,"! g execute goal~n", []).
format(user_error,'newline creep a abort~n', []),
format(user_error,'c creep e exit~n', []),
format(user_error,'f Goal fail h help~n', []),
format(user_error,'l leap r Goal retry~n', []),
format(user_error,'s skip t fastskip~n', []),
format(user_error,'q quasiskip k quasileap~n', []),
format(user_error,'b break n no debug~n', []),
format(user_error,'p print d display~n', []),
format(user_error,'<D depth D < full term~n', []),
format(user_error,'+ spy this - nospy this~n', []),
format(user_error,'^ view subg ^^ view using~n', []),
format(user_error,'A choices g [N] ancestors~n', []),
format(user_error,'! g execute goal~n', []).
'$ilgl'(C) :-
'$print_message'(warning, trace_command(C)),
@ -661,8 +720,8 @@ debugging :-
'$scan_number3'(10, Nb, Nb) :- !, Nb > 0.
'$scan_number3'( C, Nb0, Nb) :-
C >= 0'0, C =< 0'9,
NbI is Nb0*10+(C-0'0),
C >= "0", C =< "9",
NbI is Nb0*10+(C-"0"),
get0(user, NC),
'$scan_number3'( NC, NbI, Nb).
@ -670,7 +729,7 @@ debugging :-
'$get_sterm_list'(L), !,
'$deb_get_sterm_in_g'(L,G,A),
recorda('$debug_sub_skel',L,_),
format(user_error,"~n~w~n~n",[A]).
format(user_error,'~n~w~n~n',[A]).
'$print_deb_sterm'(_) :- '$skipeol'(94).
'$get_sterm_list'(L) :-
@ -768,16 +827,27 @@ debugging :-
'$debugger_deterministic_goal'(G) :-
'$all_choicepoints'(CPs),
'$debugger_check_traces'(CPs,CPs1),
'$debugger_check_loop_spy2'(CPs1,[Catch|_]),
'$debugger_skip_traces'(CPs,CPs1),
'$debugger_skip_loop_spy2'(CPs1,[Catch|_]),
'$choicepoint_info'(Catch,prolog,'$catch',3,'$catch'(_,'$loop_spy_event'(_,_,G,_,_),_)).
'$debugger_check_traces'([CP|CPs],CPs1) :-
'$choicepoint_info'(CP,prolog,'$trace',4,(_;_)), !,
'$debugger_check_traces'(CPs,CPs1).
'$debugger_check_traces'(CPs,CPs).
'$debugger_check_loop_spy2'([CP|CPs],CPs1) :-
'$cps'([CP|CPs]) :-
'$choicepoint_info'(CP,A,B,C,D),
write(A:B:C:D:CPs),nl,
'$cps'(CPs).
'$cps'([]).
'$debugger_skip_traces'([CP|CPs],CPs1) :-
'$choicepoint_info'(CP,prolog,'$trace',4,(_;_)), !,
'$debugger_skip_traces'(CPs,CPs1).
'$debugger_skip_traces'(CPs,CPs).
'$debugger_skip_loop_spy2'([CP|CPs],CPs1) :-
'$choicepoint_info'(CP,prolog,'$loop_spy2',5,(_;_)), !,
'$debugger_check_loop_spy2'(CPs,CPs1).
'$debugger_check_loop_spy2'(CPs,CPs).
'$debugger_skip_loop_spy2'(CPs,CPs1).
'$debugger_skip_loop_spy2'(CPs,CPs).

6
pl/directives.yap
View File

@ -417,11 +417,7 @@ yap_flag(language,X) :-
yap_flag(debug,X) :-
var(X), !,
(recorded('$debug',on,_) ->
X = on
;
X = off
).
nb_getval('$debug',X).
yap_flag(debug,X) :-
'$transl_to_on_off'(_,X), !,
(X = on -> debug ; nodebug).

8
pl/errors.yap
View File

@ -11,8 +11,11 @@
* File: errors.yap *
* comments: error messages for YAP *
* *
* Last rev: $Date: 2006-05-22 16:12:01 $,$Author: tiagosoares $ *
* Last rev: $Date: 2006-12-13 16:10:26 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.78 2006/05/22 16:12:01 tiagosoares
* MYDDAS: MYDDAS version boot message
*
* Revision 1.77 2006/04/10 19:24:52 vsc
* fix syntax error message handling
* improve redblack trees and use it to reimplement association lists and
@ -276,6 +279,9 @@ print_message(Level, Mss) :-
%message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !,
'$do_print_message'(format(Msg, Args)) :- !,
format(user_error,Msg,Args).
'$do_print_message'(ancestors([])) :- !,
format(user_error,'There are no ancestors.',
[]).
'$do_print_message'(breakp(bp(debugger,_,_,M:F/N,_),add,already)) :- !,
format(user_error,'There is already a spy point on ~w:~w/~w.',
[M,F,N]).

2
pl/init.yap
View File

@ -73,8 +73,6 @@ otherwise.
'eam.yap',
'yapor.yap'].
:- thread_local([idb:'$debug'/0,idb:'$trace'/0,idb:'$spy_skip'/0,idb:'$spy_stop'/0]).
:- ['protect.yap'].
version(yap,[4,1]).

58
pl/signals.yap
View File

@ -32,14 +32,7 @@
'$continue_signals',
'$wake_up_goal'(G, LG).
'$do_signal'(sig_creep, [M|G]) :-
( '$access_yap_flags'(10,0) ->
% we're not allowed to creep for now,
% maybe we're inside builtin.
'$late_creep',
'$execute'(M:G)
;
'$start_creep'([M|G])
).
'$start_creep'([M|G]).
'$do_signal'(sig_delay_creep, [M|G]) :-
'$execute'(M:G),
'$creep'.
@ -87,6 +80,13 @@
'$current_module'(M0),
'$execute0'((Goal,M:G),M0).
% do not debug if we are not in debug mode.
'$start_creep'([Mod|G]) :-
nb_getval('$debug',off), !,
'$execute_nonstop'(G,Mod).
'$start_creep'([Mod|G]) :-
nb_getval('$system_mode',on), !,
'$execute_nonstop'(G,Mod).
% notice that the last signal to be processed must always be creep
'$start_creep'([_|'$cut_by'(CP)]) :- !,
'$cut_by'(CP),
@ -98,7 +98,17 @@
'$creep',
'$execute_nonstop'(G,Mod).
'$start_creep'([Mod|G]) :-
'$do_not_creep',
'$system_predicate'(G, Mod),
'$protected_env', !,
'$creep',
'$execute_nonstop'(G,Mod).
% do not debug if we are zipping through.
'$start_creep'([Mod|G]) :-
nb_getval('$debug_zip',on),
'$zip'(-1, G, Mod), !,
'$creep',
'$execute_nonstop'(G,Mod).
'$start_creep'([Mod|G]) :-
CP is '$last_choice_pt',
'$do_spy'(G, Mod, CP, yes).
@ -154,3 +164,33 @@ read_sig :-
read_sig.
'$protected_env' :-
'$all_envs'(Envs),
%'$envs'(Envs),
'$skim_envs'(Envs,Mod,Name,Arity),
\+ '$external_call_seen'(Mod,Name,Arity).
% '$envs'([Env|Envs]) :-
% '$env_info'(Env,Mod0,Name0,Arity0),
% format(user_error,'~a:~w/~w~n',[Mod0,Name0,Arity0]),
% '$envs'(Envs).
% '$envs'([]).
'$skim_envs'([Env|Envs],Mod,Name,Arity) :-
'$env_info'(Env,Mod0,Name0,Arity0),
'$debugger_env'(Mod0,Name0,Arity0), !,
'$skim_envs'(Envs,Mod,Name,Arity).
'$skim_envs'([Env|Envs],Mod,Name,Arity) :-
'$env_info'(Env,Mod,Name,Arity).
'$debugger_env'(prolog,'$start_creep',1).
'$external_call_seen'(prolog,Name,Arity) :- !,
'$allowed'(Name,Arity).
'$external_call_seen'(_,_,_).
'$allowed'('$spycall',3).
'$allowed'('$query',2).

2
pl/yio.yap
View File

@ -528,7 +528,7 @@ print(_,_).
/* interface to user portray */
'$portray'(T) :-
\+ '$undefined'(portray(_),user),
user:portray(T), !,
'$system_catch'(call(portray(T)),user,Error,user:'$Error'(Error)), !,
set_value('$portray',true), fail.
'$portray'(_) :- set_value('$portray',false), fail.