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

SWI-portability changes

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2088 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2008-02-12 17:03:59 +00:00
parent 5b2cc724f3
commit af0fb4f4d9
59 changed files with 4541 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
C/absmi.c
View File

@ -10,8 +10,11 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2008-01-27 11:01:06 $,$Author: vsc $ *
* Last rev: $Date: 2008-02-12 17:03:50 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.234 2008/01/27 11:01:06 vsc
* make thread code more stable
*
* Revision 1.233 2008/01/23 17:57:44 vsc
* valgrind it!
* enable atom garbage collection.
@ -7926,7 +7929,7 @@ Yap_absmi(int inp)
PredEntry *pe = PredFromDefCode(PREG);
BEGD(d0);
/* avoid trouble with undefined dynamic procedures */
if (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag)) {
if (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|MultiFileFlag)) {
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
#endif

12
C/c_interface.c
View File

@ -10,8 +10,11 @@
* File: c_interface.c *
* comments: c_interface primitives definition *
* *
* Last rev: $Date: 2008-01-28 10:42:19 $,$Author: vsc $ *
* Last rev: $Date: 2008-02-12 17:03:50 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.105 2008/01/28 10:42:19 vsc
* fix BOM trouble
*
* Revision 1.104 2007/12/05 12:17:23 vsc
* improve JT
* fix graph compatibility with SICStus
@ -422,6 +425,7 @@ X_API void *STD_PROTO(YAP_BlobOfTerm,(Term));
X_API Term STD_PROTO(YAP_TermNil,(void));
X_API int STD_PROTO(YAP_AtomGetHold,(Atom));
X_API int STD_PROTO(YAP_AtomReleaseHold,(Atom));
X_API Agc_hook STD_PROTO(YAP_AGCRegisterHook,(Agc_hook));
static int (*do_getf)(void);
@ -2086,9 +2090,11 @@ YAP_AtomReleaseHold(Atom at)
return Yap_AtomReleaseHold(at);
}
X_API void
X_API Agc_hook
YAP_AGCRegisterHook(Agc_hook hook)
{
AGCHook = hook;
Agc_hook old = AGCHook;
AGCHook = hook;
return old;
}

24
C/exec.c
View File

@ -224,6 +224,8 @@ do_execute(Term t, Term mod)
else
XREGS[i] = d0;
#else
XREGS[i] = *pt++;
#endif
}
@ -1795,18 +1797,30 @@ p_restore_regs2(void)
static Int
p_clean_ifcp(void) {
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "cut_at/1");
return FALSE;
}
if (!IsIntegerTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER, t, "cut_at/1");
return FALSE;
}
#if SBA
choiceptr pt0 = (choiceptr)IntegerOfTerm(Deref(ARG1));
choiceptr pt0 = (choiceptr)IntegerOfTerm(t);
#else
choiceptr pt0 = (choiceptr)(LCL0-IntOfTerm(Deref(ARG1)));
choiceptr pt0 = cp_from_integer(t);
#endif
if (pt0 == B) {
if (pt0 < B) {
/* this should never happen */
return TRUE;
} else if (pt0 == B) {
B = B->cp_b;
HB = B->cp_h;
} else {
pt0->cp_ap = (yamop *)TRUSTFAILCODE;
}
return(TRUE);
return TRUE;
}
@ -2059,8 +2073,10 @@ Yap_InitExecFs(void)
Yap_InitCPred("$execute_clause", 4, p_execute_clause, HiddenPredFlag);
CurrentModule = HACKS_MODULE;
Yap_InitCPred("current_choice_point", 1, p_save_cp, HiddenPredFlag);
Yap_InitCPred("current_choicepoint", 1, p_save_cp, HiddenPredFlag);
Yap_InitCPred("env_choice_point", 1, p_save_env_b, HiddenPredFlag);
Yap_InitCPred("trail_suspension_marker", 1, p_trail_suspension_marker, HiddenPredFlag);
Yap_InitCPred("cut_at", 1, p_clean_ifcp, SafePredFlag);
CurrentModule = cm;
Yap_InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag|HiddenPredFlag);
Yap_InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag|HiddenPredFlag);

2
C/grow.c
View File

@ -148,8 +148,10 @@ SetHeapRegs(void)
ASP = PtoLocAdjust(ASP);
if (H0)
H0 = PtoGloAdjust(H0);
LOCK(SignalLock);
if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
UNLOCK(SignalLock);
if (H)
H = PtoGloAdjust(H);
if (HB)

6
C/init.c
View File

@ -352,11 +352,13 @@ static Opdef Ops[] = {
{"?-", fx, 1200},
{":-", fx, 1200},
{"dynamic", fx, 1150},
{"thread_local", fx, 1150},
{"initialization", fx, 1150},
{"mode", fx, 1150},
{"public", fx, 1150},
{"multifile", fx, 1150},
{"meta_predicate", fx, 1150},
{"module_transparent", fx, 1150},
{"discontiguous", fx, 1150},
#ifdef YAPOR
{"sequential", fx, 1150},
@ -371,6 +373,7 @@ static Opdef Ops[] = {
{"|", xfy, 1100},
/* {";", yf, 1100}, not allowed in ISO */
{"->", xfy, 1050},
{"*->", xfy, 1050},
{",", xfy, 1000},
{".", xfy, 999},
{"\\+", fy, 900},
@ -385,6 +388,8 @@ static Opdef Ops[] = {
{"@>", xfx, 700},
{"@=<", xfx, 700},
{"@>=", xfx, 700},
{"=@=", xfx, 700},
{"\\=@=", xfx, 700},
{"=:=", xfx, 700},
{"=\\=", xfx, 700},
{"<", xfx, 700},
@ -887,6 +892,7 @@ InitCodes(void)
Yap_heap_regs->readutil_module = MkAtomTerm(Yap_LookupAtom("readutil"));
Yap_heap_regs->hacks_module = MkAtomTerm(Yap_LookupAtom("yap_hacks"));
Yap_heap_regs->globals_module = MkAtomTerm(Yap_LookupAtom("nb"));
Yap_heap_regs->arg_module = MkAtomTerm(Yap_LookupAtom("arg"));
Yap_heap_regs->swi_module = MkAtomTerm(Yap_LookupAtom("swi"));
Yap_InitModules();
#ifdef BEAM

79
C/inlines.c
View File

@ -822,9 +822,85 @@ p_erroneous_call(void)
return(FALSE);
}
static Int
init_genarg(void)
{ /* getarg(?Atom) */
Term t0 = Deref(ARG1);
Term t1 = Deref(ARG2);
CELL *pt, *end;
int res;
UInt arity;
if (!IsVarTerm(t0)) {
res = p_arg();
if (res) {
cut_succeed();
} else {
cut_fail();
}
}
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"genarg/3");
return FALSE;
}
if (IsPrimitiveTerm(t1)) {
Yap_Error(TYPE_ERROR_COMPOUND,t1,"genarg/3");
return FALSE;
}
if (IsPairTerm(t1)) {
pt = RepPair(t1);
end = RepPair(t1)+1;
arity = 2;
} else {
arity = ArityOfFunctor(FunctorOfTerm(t1));
pt = RepAppl(t1);
end = pt+arity;
pt += 1;
}
res = Yap_unify(ARG1,MkIntTerm(1)) &&
Yap_unify(ARG3,pt[0]);
if (arity == 1) {
if (res) {
cut_succeed();
} else {
cut_fail();
}
}
EXTRA_CBACK_ARG(3,1) = (Term)(pt+1);
EXTRA_CBACK_ARG(3,2) = (Term)(end);
EXTRA_CBACK_ARG(3,3) = MkIntegerTerm(arity);
return res;
}
static Int
cont_genarg(void)
{ /* genarg(?Atom) */
CELL *pt, *end;
int res;
UInt arity;
pt = (CELL *)EXTRA_CBACK_ARG(3,1);
end = (CELL *)EXTRA_CBACK_ARG(3,2);
arity = IntegerOfTerm(EXTRA_CBACK_ARG(3,3));
if (pt == end) {
res = Yap_unify(ARG1,MkIntegerTerm(arity)) &&
Yap_unify(ARG3,pt[0]);
if (res) {
cut_succeed();
} else {
cut_fail();
}
}
EXTRA_CBACK_ARG(3,1) = (Term)(pt+1);
return Yap_unify(ARG1,MkIntegerTerm(arity-(end-pt))) &&
Yap_unify(ARG3,pt[0]);
}
void
Yap_InitInlines(void)
{
Term cm = CurrentModule;
Yap_InitAsmPred("$$cut_by", 1, _cut_by, p_cut_by, SafePredFlag);
Yap_InitAsmPred("atom", 1, _atom, p_atom, SafePredFlag);
Yap_InitAsmPred("atomic", 1, _atomic, p_atomic, SafePredFlag);
@ -849,5 +925,8 @@ Yap_InitInlines(void)
Yap_InitAsmPred("$or", 3, _or, p_erroneous_call, SafePredFlag);
Yap_InitAsmPred("$sll", 3, _sll, p_erroneous_call, SafePredFlag);
Yap_InitAsmPred("$slr", 3, _slr, p_erroneous_call, SafePredFlag);
CurrentModule = GLOBALS_MODULE;
Yap_InitCPredBack("genarg", 3, 3, init_genarg, cont_genarg,SafePredFlag);
CurrentModule = cm;
}

45
C/iopreds.c
View File

@ -176,6 +176,7 @@ STATIC_PROTO (Int p_type_of_char, (void));
STATIC_PROTO (void CloseStream, (int));
STATIC_PROTO (int get_wchar, (int));
STATIC_PROTO (int put_wchar, (int,wchar_t));
STATIC_PROTO (Term StreamPosition, (int));
static encoding_t
DefaultEncoding(void)
@ -3060,7 +3061,8 @@ p_check_stream (void)
int sno = CheckStream (ARG1,
AtomOfTerm (mode) == AtomRead ? Input_Stream_f : Output_Stream_f,
"check_stream/2");
UNLOCK(Stream[sno].streamlock);
if (sno != -1)
UNLOCK(Stream[sno].streamlock);
return sno != -1;
}
@ -3068,6 +3070,8 @@ static Int
p_check_if_stream (void)
{ /* '$check_stream'(Stream) */
int sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f | Socket_Stream_f, "check_stream/1");
if (sno != -1)
UNLOCK(Stream[sno].streamlock);
return sno != -1;
}
@ -3774,7 +3778,7 @@ static Int
#if EMACS
int emacs_cares = FALSE;
#endif
Term tmod = Deref(ARG3), OCurrentModule = CurrentModule;
Term tmod = Deref(ARG3), OCurrentModule = CurrentModule, tpos;
if (IsVarTerm(tmod)) {
tmod = CurrentModule;
@ -3811,6 +3815,7 @@ static Int
while (TRUE) {
old_H = H;
Yap_eot_before_eof = FALSE;
tpos = StreamPosition(inp_stream);
tokstart = Yap_tokptr = Yap_toktide = Yap_tokenizer(inp_stream);
if (Yap_Error_TYPE != YAP_NO_ERROR && seekable) {
H = old_H;
@ -3970,10 +3975,10 @@ static Int
}
Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
return Yap_unify(t, ARG2) && Yap_unify (v, ARG4) &&
Yap_unify(MkIntTerm(StartLine = tokstart->TokPos),ARG5);
Yap_unify(tpos,ARG5);
} else {
Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable);
return(Yap_unify(t, ARG2) && Yap_unify(MkIntTerm(StartLine = tokstart->TokPos),ARG5));
return(Yap_unify(t, ARG2) && Yap_unify(tpos,ARG5));
}
}
@ -4150,14 +4155,10 @@ p_show_stream_flags(void)
return (Yap_unify (ARG2, tout));
}
static Int
p_show_stream_position (void)
{ /* '$show_stream_position'(+Stream,Pos) */
Term sargs[5], tout;
int sno =
CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_position/2");
if (sno < 0)
return (FALSE);
static Term
StreamPosition(int sno)
{
Term sargs[5];
if (Stream[sno].status & (Tty_Stream_f|Socket_Stream_f|Pipe_Stream_f|InMemory_Stream_f))
sargs[0] = MkIntTerm (Stream[sno].charcount);
else if (Stream[sno].status & Null_Stream_f)
@ -4168,12 +4169,24 @@ p_show_stream_position (void)
else
sargs[0] = MkIntTerm (YP_ftell (Stream[sno].u.file.file));
}
sargs[1] = MkIntTerm (Stream[sno].linecount);
sargs[2] = MkIntTerm (Stream[sno].linepos);
sargs[1] = MkIntegerTerm (Stream[sno].linecount);
sargs[2] = MkIntegerTerm (Stream[sno].linepos);
sargs[3] = sargs[4] = MkIntTerm (0);
return Yap_MkApplTerm (FunctorStreamPos, 5, sargs);
}
static Int
p_show_stream_position (void)
{ /* '$show_stream_position'(+Stream,Pos) */
Term tout;
int sno =
CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_position/2");
if (sno < 0)
return (FALSE);
tout = StreamPosition(sno);
UNLOCK(Stream[sno].streamlock);
tout = Yap_MkApplTerm (FunctorStreamPos, 5, sargs);
return (Yap_unify (ARG2, tout));
return Yap_unify (ARG2, tout);
}
static Int

26
C/modules.c
View File

@ -215,12 +215,37 @@ init_current_module(void)
return cont_current_module();
}
static Int
p_strip_module(void)
{
Term t1 = Deref(ARG1), t2, tmod;
if (IsVarTerm(t1) ||
!IsApplTerm(t1) ||
FunctorOfTerm(t1) != FunctorModule ||
IsVarTerm(t2 = ArgOfTerm(1,t1)) ||
!IsAtomTerm(t2)) {
return Yap_unify(ARG3, t1) &&
Yap_unify(ARG2, CurrentModule);
}
do {
tmod = t2;
t1 = ArgOfTerm(2,t1);
} while (!IsVarTerm(t1) &&
IsApplTerm(t1) &&
FunctorOfTerm(t1) == FunctorModule &&
!IsVarTerm(t2 = ArgOfTerm(1,t1)) &&
IsAtomTerm(t2));
return Yap_unify(ARG3, t1) &&
Yap_unify(ARG2, tmod);
}
void
Yap_InitModulesC(void)
{
Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, cont_current_module,
SafePredFlag|SyncPredFlag|HiddenPredFlag);
}
@ -238,6 +263,7 @@ Yap_InitModules(void)
LookupModule(SYSTEM_MODULE);
LookupModule(READUTIL_MODULE);
LookupModule(HACKS_MODULE);
LookupModule(ARG_MODULE);
LookupModule(GLOBALS_MODULE);
CurrentModule = PROLOG_MODULE;
}

12
C/threads.c
View File

@ -47,8 +47,8 @@ allocate_new_tid(void)
(ThreadHandle[new_worker_id].in_use == TRUE ||
ThreadHandle[new_worker_id].zombie == TRUE) )
new_worker_id++;
ThreadHandle[new_worker_id].in_use = TRUE;
pthread_mutex_lock(&(ThreadHandle[new_worker_id].tlock));
ThreadHandle[new_worker_id].in_use = TRUE;
UNLOCK(ThreadHandlesLock);
if (new_worker_id == MAX_WORKERS)
return -1;
@ -87,12 +87,14 @@ kill_thread_engine (int wid)
Yap_FreeCodeSpace((char *)ap);
}
Yap_KillStacks(wid);
Yap_FreeCodeSpace((ADDR)(ThreadHandle[wid].tgoal));
Yap_heap_regs->wl[wid].active_signals = 0L;
pthread_mutex_lock(&(ThreadHandle[wid].tlock));
free(Yap_heap_regs->wl[wid].scratchpad.ptr);
free(ThreadHandle[wid].default_yaam_regs);
ThreadHandle[wid].current_yaam_regs = NULL;
free(ThreadHandle[wid].start_of_timesp);
free(ThreadHandle[wid].last_timep);
pthread_mutex_lock(&(ThreadHandle[wid].tlock));
ThreadHandle[wid].zombie = FALSE;
pthread_mutex_unlock(&(ThreadHandle[wid].tlock));
}
@ -577,12 +579,14 @@ p_thread_signal(void)
Int wid = IntegerOfTerm(Deref(ARG1));
/* make sure the lock is available */
pthread_mutex_lock(&(ThreadHandle[wid].tlock));
if (!ThreadHandle[wid].in_use) {
if (!ThreadHandle[wid].in_use ||
!ThreadHandle[wid].current_yaam_regs) {
pthread_mutex_unlock(&(ThreadHandle[wid].tlock));
return TRUE;
}
LOCK(Yap_heap_regs->wl[wid].signal_lock);
ThreadHandle[wid].current_yaam_regs->CreepFlag_ = Unsigned(LCL0);
ThreadHandle[wid].current_yaam_regs->CreepFlag_ =
Unsigned(ThreadHandle[wid].current_yaam_regs->LCL0_);
Yap_heap_regs->wl[wid].active_signals |= YAP_ITI_SIGNAL;
UNLOCK(Yap_heap_regs->wl[wid].signal_lock);
pthread_mutex_unlock(&(ThreadHandle[wid].tlock));

59
C/utilpreds.c
View File

@ -2027,6 +2027,65 @@ camacho_dum(void)
#endif /* DEBUG */
static Int
cont_current_atom(void)
{
Atom catom;
Int i = IntOfTerm(EXTRA_CBACK_ARG(1,2));
AtomEntry *ap; /* nasty hack for gcc on hpux */
/* protect current hash table line */
if (IsAtomTerm(EXTRA_CBACK_ARG(1,1)))
catom = AtomOfTerm(EXTRA_CBACK_ARG(1,1));
else
catom = NIL;
if (catom == NIL){
i++;
/* move away from current hash table line */
while (i < AtomHashTableSize) {
READ_LOCK(HashChain[i].AERWLock);
catom = HashChain[i].Entry;
READ_UNLOCK(HashChain[i].AERWLock);
if (catom != NIL) {
break;
}
i++;
}
if (i == AtomHashTableSize) {
cut_fail();
}
}
ap = RepAtom(catom);
if (Yap_unify_constant(ARG1, MkAtomTerm(catom))) {
READ_LOCK(ap->ARWLock);
if (ap->NextOfAE == NIL) {
READ_UNLOCK(ap->ARWLock);
i++;
while (i < AtomHashTableSize) {
READ_LOCK(HashChain[i].AERWLock);
catom = HashChain[i].Entry;
READ_UNLOCK(HashChain[i].AERWLock);
if (catom != NIL) {
break;
}
i++;
}
if (i == AtomHashTableSize) {
cut_fail();
} else {
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(catom);
}
} else {
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(ap->NextOfAE);
READ_UNLOCK(ap->ARWLock);
}
EXTRA_CBACK_ARG(1,2) = MkIntTerm(i);
return TRUE;
} else {
return FALSE;
}
}
void Yap_InitUtilCPreds(void)
{
Term cm = CurrentModule;

9
CLPBN/Makefile.in
View File

@ -27,6 +27,8 @@ CLPBN_TOP= $(srcdir)/clpbn.yap
CLPBN_SRCDIR = $(srcdir)/clpbn
CLPBN_LEARNING_SRCDIR = $(srcdir)/learning
CLPBN_EXDIR = $(srcdir)/clpbn/examples
CLPBN_PROGRAMS= \
@ -48,6 +50,11 @@ CLPBN_PROGRAMS= \
$(CLPBN_SRCDIR)/viterbi.yap \
$(CLPBN_SRCDIR)/xbif.yap
CLPBN_LEARNING_PROGRAMS= \
$(CLPBN_LEARNING_SRCDIR)/bnt_parms.yap \
$(CLPBN_LEARNING_SRCDIR)/learn_utils.yap \
$(CLPBN_LEARNING_SRCDIR)/mle.yap
CLPBN_EXAMPLES= \
$(CLPBN_EXDIR)/cg.yap \
$(CLPBN_EXDIR)/School/README \
@ -62,9 +69,11 @@ CLPBN_EXAMPLES= \
install: $(CLBN_TOP) $(CLBN_PROGRAMS) $(CLPBN_PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn/learning
mkdir -p $(DESTDIR)$(SHAREDIR)/examples
mkdir -p $(DESTDIR)$(SHAREDIR)/clpbn/examples/School
for h in $(CLPBN_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR); done
for h in $(CLPBN_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn; done
for h in $(CLPBN_LEARNING_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/clpbn/learning; done
for h in $(CLPBN_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(SHAREDIR)/examples; done

97
CLPBN/clpbn.yap
View File

@ -25,38 +25,48 @@
:- attribute key/1, dist/2, evidence/1, starter/0.
:- use_module('clpbn/vel', [vel/3,
check_if_vel_done/1
]).
:- use_module('clpbn/vel',
[vel/3,
check_if_vel_done/1
]).
:- use_module('clpbn/jt', [jt/3
]).
:- use_module('clpbn/jt',
[jt/3
]).
:- use_module('clpbn/bnt', [do_bnt/3,
check_if_bnt_done/1
]).
:- use_module('clpbn/bnt',
[do_bnt/3,
check_if_bnt_done/1
]).
:- use_module('clpbn/gibbs', [gibbs/3,
check_if_gibbs_done/1
]).
:- use_module('clpbn/gibbs',
[gibbs/3,
check_if_gibbs_done/1
]).
:- use_module('clpbn/graphs', [
clpbn2graph/1
]).
:- use_module('clpbn/graphs',
[
clpbn2graph/1
]).
:- use_module('clpbn/dists', [
dist/3,
get_dist/4
]).
:- use_module('clpbn/dists',
[
dist/3,
get_dist/4,
get_evidence_position/3,
get_evidence_from_position/3
]).
:- use_module('clpbn/evidence', [
store_evidence/1,
incorporate_evidence/2
]).
:- use_module('clpbn/evidence',
[
store_evidence/1,
incorporate_evidence/2
]).
:- use_module('clpbn/utils', [
sort_vars_by_key/3
]).
:- use_module('clpbn/utils',
[
sort_vars_by_key/3
]).
:- dynamic solver/1,output/1,use/1.
@ -91,7 +101,7 @@ clpbn_flag(bnt_model,Before,After) :-
{Var = Key with Dist} :-
put_atts(El,[key(Key),dist(DistInfo,Parents)]),
dist(Dist, DistInfo, Parents),
add_evidence(Var,El).
add_evidence(Var,DistInfo,El).
check_constraint(Constraint, _, _, Constraint) :- var(Constraint), !.
check_constraint((A->D), _, _, (A->D)) :- var(A), !.
@ -109,10 +119,11 @@ replace_var([V|_], V0, [NV|_], NV) :- V == V0, !.
replace_var([_|Vars], V, [_|NVars], NV) :-
replace_var(Vars, V, NVars, NV).
add_evidence(V,NV) :-
add_evidence(V,Distinfo,NV) :-
nonvar(V), !,
clpbn:put_atts(NV,evidence(V)).
add_evidence(V,V).
get_evidence_position(V, Distinfo, Pos),
clpbn:put_atts(NV,evidence(Pos)).
add_evidence(V,_,V).
clpbn_marginalise(V, Dist) :-
attributes:all_attvars(AVars),
@ -128,7 +139,8 @@ project_attributes(GVars, AVars) :-
solver(Solver),
( GVars = [_|_] ; Solver = graphs), !,
clpbn_vars(AVars, DiffVars, AllVars),
get_clpbn_vars(GVars,CLPBNGVars),
get_clpbn_vars(GVars,CLPBNGVars0),
simplify_query_vars(CLPBNGVars0, CLPBNGVars),
write_out(Solver,CLPBNGVars, AllVars, DiffVars).
project_attributes(_, _).
@ -143,6 +155,23 @@ get_clpbn_vars([V|GVars],[V|CLPBNGVars]) :-
get_clpbn_vars([_|GVars],CLPBNGVars) :-
get_clpbn_vars(GVars,CLPBNGVars).
simplify_query_vars(LVs0, LVs) :-
sort(LVs0,LVs1),
get_rid_of_ev_vars(LVs1,LVs).
%
% some variables might already have evidence in the data-base.
%
get_rid_of_ev_vars([],[]).
get_rid_of_ev_vars([V|LVs0],LVs) :-
clpbn:get_atts(V, [dist(Id,_),evidence(Pos)]), !,
get_evidence_from_position(Ev, Id, Pos),
clpbn_display:put_atts(V, [posterior([],Ev,[],[])]), !,
get_rid_of_ev_vars(LVs0,LVs).
get_rid_of_ev_vars([V|LVs0],[V|LVs]) :-
get_rid_of_ev_vars(LVs0,LVs).
write_out(vel, GVars, AVars, DiffVars) :-
vel(GVars, AVars, DiffVars).
write_out(jt, GVars, AVars, DiffVars) :-
@ -250,7 +279,13 @@ bind_clpbns(Key, Dist, Parents, Key1, Dist1, Parents1) :-
Key == Key1, !,
get_dist(Dist,Type,Domain,Table),
get_dist(Dist1,Type1,Domain1,Table1),
( Dist == Dist1, same_parents(Parents,Parents1) -> true ; throw(error(domain_error(bayesian_domain),bind_clpbns(var(Key, Type, Domain, Table, Parents),var(Key1, Type1, Domain1, Table1, Parents1))))).
( Dist == Dist1,
same_parents(Parents,Parents1)
->
true
;
throw(error(domain_error(bayesian_domain),bind_clpbns(var(Key, Type, Domain, Table, Parents),var(Key1, Type1, Domain1, Table1, Parents1))))
).
bind_clpbns(Key, _, _, _, Key1, _, _, _) :-
Key\=Key1, !, fail.
bind_clpbns(_, _, _, _, _, _, _, _) :-

4
CLPBN/clpbn/bnt.yap
View File

@ -374,9 +374,7 @@ add_evidence(Graph, Size, Is) :-
mk_evidence([], [], []).
mk_evidence([V|L], [I|Is], [ar(1,I,Val)|LN]) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,_)]), !,
get_dist_domain(Id, Domain),
evidence_val(Ev,1,Domain,Val),
clpbn:get_atts(V, [evidence(EvVal),dist(Id,_)]), !,
mk_evidence(L, Is, LN).
mk_evidence([_|L], [_|Is], LN) :-
mk_evidence(L, Is, LN).

14
CLPBN/clpbn/discrete_utils.yap
View File

@ -19,7 +19,7 @@ project_from_CPT(V,tab(Table,Deps,Szs),tab(NewTable,NDeps,NSzs)) :-
propagate_evidence(V, Evs) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,_)]), !,
get_dist_domain(Id, Out),
generate_szs_with_evidence(Out,Ev,Evs,Found),
generate_szs_with_evidence(Out,Ev,0,Evs,Found),
(var(Found) ->
clpbn:get_atts(V, [key(K)]),
throw(clpbn(evidence_does_not_match,K,Ev,[Out]))
@ -28,11 +28,13 @@ propagate_evidence(V, Evs) :-
).
propagate_evidence(_, _).
generate_szs_with_evidence([],_,[],_).
generate_szs_with_evidence([Ev|Out],Ev,[ok|Evs],found) :- !,
generate_szs_with_evidence(Out,Ev,Evs,found).
generate_szs_with_evidence([_|Out],Ev,[not_ok|Evs],Found) :-
generate_szs_with_evidence(Out,Ev,Evs,Found).
generate_szs_with_evidence([],_,_,[],_).
generate_szs_with_evidence([_|Out],Ev,Ev,[ok|Evs],found) :- !,
I is Ev+1,
generate_szs_with_evidence(Out,Ev,I,Evs,found).
generate_szs_with_evidence([_|Out],Ev,I0,[not_ok|Evs],Found) :-
I is I0+1,
generate_szs_with_evidence(Out,Ev,I0,Evs,Found).
find_projection_factor([V|Deps], V1, Deps, [Sz|Szs], Szs, F, Sz) :-
V == V1, !,

22
CLPBN/clpbn/dists.yap
View File

@ -12,10 +12,12 @@
get_dist_params/2,
get_dist_domain_size/2,
get_dist_tparams/2,
get_evidence_position/3,
get_evidence_from_position/3,
dist_to_term/2
]).
:- use_module(library(lists),[is_list/1]).
:- use_module(library(lists),[is_list/1,nth0/3]).
:- use_module(library(matrix),
[matrix_new/4,
@ -176,4 +178,22 @@ get_dist_domain(Id, Domain) :-
get_dist_nparams(Id, NParms) :-
recorded(clpbn_dist_db, db(Id, _, _, _, NParms, _), _).
get_evidence_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, Domain, _, _), _),
nth0(Pos, El, Domain), !.
get_evidence_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, Domain, _, _), _), !,
throw(error(domain_error(evidence,Id),add_evidence(Ev,Domain))).
get_evidence_position(El, Id, Pos) :-
throw(error(domain_error(no_distribution,Id),add_evidence(Ev,Domain))).
get_evidence_from_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, Domain, _, _), _),
nth0(Pos, El, Domain), !.
get_evidence_from_position(El, Id, Pos) :-
recorded(clpbn_dist_db, db(Id, _, _, Domain, _, _), _), !,
throw(error(domain_error(evidence,Id),add_evidence(Ev,Domain))).
get_evidence_from_position(El, Id, Pos) :-
throw(error(domain_error(no_distribution,Id),add_evidence(Ev,Domain))).
dist_to_term(_Id,_Term).

14
CLPBN/clpbn/evidence.yap
View File

@ -3,10 +3,12 @@
%
%
:- module(clpbn_evidence, [
store_evidence/1,
incorporate_evidence/2
]).
:- module(clpbn_evidence,
[
store_evidence/1,
incorporate_evidence/2,
get_evidence_position/3
]).
:- use_module(library(clpbn), [
{}/1,
@ -107,7 +109,9 @@ extract_vars([_-V|Cache], [V|AllVs]) :-
add_evidence(K, V) :-
evidence(K, Ev), !,
clpbn:put_atts(V, [evidence(Ev)]).
clpbn:get_atts(V, [dist(Id,_)]).
get_evidence_position(Ev, Id, EvPos),
clpbn:put_atts(V, [evidence(EvPos)]).
add_evidence(_, _).

2
CLPBN/clpbn/graphs.yap
View File

@ -30,7 +30,7 @@ attribute_goal(V, node(K,Dom,CPT,TVs,Ev)) :-
clpbn:get_atts(V, [key(K),dist(Id,Vs)]),
get_dist(Id,_,Dom,CPT),
translate_vars(Vs,TVs),
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true).
( clpbn:get_atts(V, [evidence(_)]) -> true ; true).
translate_vars([],[]).
translate_vars([V|Vs],[K|Ks]) :-

4
CLPBN/clpbn/jt.yap
View File

@ -99,9 +99,7 @@ run_vars([V|LVs], Edges, [V|Vs], [CPTVars-dist([V|Parents],Id)|CPTs], Ev) :-
run_vars(LVs, Edges0, Vs, CPTs, Ev0).
add_evidence(V, Id, [e(V,P)|Evs], Evs) :-
clpbn:get_atts(V, [evidence(Ev)]), !,
get_dist_domain(Id, D),
find_nth0(D, Ev, 0, P).
clpbn:get_atts(V, [evidence(P)]), !.
add_evidence(_, _, Evs, Evs).
find_nth0([Id|_], Id, P, P) :- !.

6
CLPBN/clpbn/matrix_cpt_utils.yap
View File

@ -34,8 +34,6 @@
matrix_set_all_that_disagree/5,
matrix_to_list/2]).
:- use_module(library(lists), [nth0/3]).
init_CPT(List, Sizes, TAB) :-
matrix_new(floats, Sizes, List, TAB),
matrix_to_logs(TAB).
@ -51,9 +49,7 @@ project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
matrix_dims(NewTable, NSzs).
evidence(V, Pos) :-
clpbn:get_atts(V, [evidence(Ev),dist(Id,_)]),
get_dist_domain(Id, Dom),
nth0(Pos, Dom, Ev).
clpbn:get_atts(V, [evidence(Pos),dist(Id,_)]).
vnth([V1|Deps], N, V, N, Deps) :-
V == V1, !.

23
CLPBN/clpbn/vel.yap
View File

@ -52,13 +52,8 @@
check_if_vel_done(Var) :-
get_atts(Var, [size(_)]), !.
vel(LVs0,Vs0,AllDiffs) :-
sort(LVs0,LVs1),
get_rid_of_ev_vars(LVs1,LVs),
do_vel(LVs,Vs0,AllDiffs).
do_vel([],_,_) :- !.
do_vel(LVs,Vs0,AllDiffs) :-
vel([],_,_) :- !.
vel(LVs,Vs0,AllDiffs) :-
check_for_hidden_vars(Vs0, Vs0, Vs1),
sort(Vs1,Vs),
find_all_clpbn_vars(Vs, LV0, LVi, Tables0),
@ -70,18 +65,6 @@ do_vel(LVs,Vs0,AllDiffs) :-
list_from_CPT(Ps, LPs),
clpbn_bind_vals(LVs,LPs,AllDiffs).
%
% some variables might already have evidence in the data-base.
%
get_rid_of_ev_vars([],[]).
get_rid_of_ev_vars([V|LVs0],LVs) :-
clpbn:get_atts(V, [evidence(Ev)]), !,
clpbn_display:put_atts(V, [posterior([],Ev,[],[])]), !,
get_rid_of_ev_vars(LVs0,LVs).
get_rid_of_ev_vars([V|LVs0],[V|LVs]) :-
get_rid_of_ev_vars(LVs0,LVs).
find_all_clpbn_vars([], [], [], []) :- !.
find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Sizes)|Tables]) :-
var_with_deps(V, Table, Parents, Sizes, Ev, Vals), !,
@ -98,7 +81,7 @@ find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Size
var_with_deps(V, Table, Deps, Sizes, Ev, Vals) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
get_dist_matrix(Id,Parents,_,Vals,TAB0),
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true),
( clpbn:get_atts(V, [evidence(_)]) -> true ; true),
reorder_CPT([V|Parents],TAB0,Deps0,TAB1,Sizes1),
simplify_evidence(Deps0, TAB1, Deps0, Sizes1, Table, Deps, Sizes).

40
GPL/Makefile.in Normal file
View File

@ -0,0 +1,40 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
YAP_EXTRAS=@YAP_EXTRAS@
PROGRAMS= \
$(srcdir)/aggregate.pl \
$(srcdir)/apply.pl \
$(srcdir)/error.pl \
$(srcdir)/occurs.yap \
$(srcdir)/pairs.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/logtalk
for p in $(LOGTALK_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/logtalk; done

544
GPL/aggregate.pl Normal file
View File

@ -0,0 +1,544 @@
/* $Id: aggregate.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2008, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(aggretate,
[ foreach/2, % :Generator, :Goal
aggregate/3, % +Templ, :Goal, -Result
aggregate/4, % +Templ, +Discrim, :Goal, -Result
aggregate_all/3, % +Templ, :Goal, -Result
aggregate_all/4, % +Templ, +Discrim, :Goal, -Result
free_variables/4 % :Generator, :Template, +Vars0, -Vars
]).
:- use_module(library(ordsets)).
:- use_module(library(pairs)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- module_transparent
foreach/2,
aggregate/3,
aggregate/4,
aggregate_all/3,
aggregate_all/4.
/** <module> Aggregation operators on backtrackable predicates
This library provides aggregating operators over the solutions of a
predicate. The operations are a generalisation of the bagof/3, setof/3
and findall/3 built-in predicates. The defined aggregation operations
are counting, computing the sum, minimum, maximum, a bag of solutions
and a set of solutions. We first give a simple example, computing the
country with the smallest area:
==
average_country_area(Name, Area) :-
aggregate(min(A, N), country(N, A), min(Area, Name)).
==
There are four aggregation predicates, distinguished on two properties.
$ aggregate vs. aggregate_all :
The aggregate predicates use setof/3 (aggregate/4) or bagof/3
(aggregate/3), dealing with existential qualified variables
(Var^Goal) and providing multiple solutions for the remaining free
variables in Goal. The aggregate_all/3 predicate uses findall/3,
implicitely qualifying all free variables and providing exactly one
solution, while aggregate_all/4 uses sort/2 over solutions and
Distinguish (see below) generated using findall/3.
$ The Distinguish argument :
The versions with 4 arguments provide a Distinguish argument that
allow for keeping duplicate bindings of a variable in the result.
For example, if we wish to compute the total population of all
countries we do not want to loose results because two countries
have the same population. Therefore we use:
==
aggregate(sum(P), Name, country(Name, P), Total)
==
All aggregation predicates support the following operator below in
Template. In addition, they allow for an arbitrary named compound term
where each of the arguments is a term from the list below. I.e. the term
r(min(X), max(X)) computes both the minimum and maximum binding for X.
* count
Count number of solutions. Same as sum(1).
* sum(Expr)
Sum of Expr for all solutions.
* min(Expr)
Minimum of Expr for all solutions.
* min(Expr, Witness)
A term min(Min, Witness), where Min is the minimal version
of Expr over all Solution and Witness is any other template
the applied to the solution that produced Min. If multiple
solutions provide the same minimum, Witness corresponds to
the first solution.
* max(Expr)
Maximum of Expr for all solutions.
* max(Expr, Witness)
As min(Expr, Witness), but producing the maximum result.
* set(X)
An ordered set with all solutions for X.
* bag(X)
A list of all solutions for X.
---+++ Acknowledgements
_|The development of this library was sponsored by SecuritEase,
http://www.securitease.com
|_
@compat Quintus, SICStus 4. The forall/2 is a SWI-Prolog built-in and
term_variables/3 is a SWI-Prolog with a *|different definition|*.
@tbd Analysing the aggregation template and compiling a predicate
for the list aggregation can be done at compile time.
@tbd aggregate_all/3 can be rewritten to run in constant space using
non-backtrackable assignment on a term.
*/
/*******************************
* AGGREGATE *
*******************************/
%% aggregate(+Template, :Goal, -Result) is nondet.
%
% Aggregate bindings in Goal according to Template. The aggregate/3
% version performs bagof/3 on Goal.
aggregate(Template, Goal0, Result) :-
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
bagof(Pattern, Goal, List),
aggregate_list(Aggregate, List, Result).
%% aggregate(+Template, +Discriminator, :Goal, -Result) is nondet.
%
% Aggregate bindings in Goal according to Template. The aggregate/3
% version performs setof/3 on Goal.
aggregate(Template, Discriminator, Goal0, Result) :-
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
setof(Discriminator-Pattern, Goal, Pairs),
pairs_values(Pairs, List),
aggregate_list(Aggregate, List, Result).
%% aggregate_all(+Template, :Goal, -Result) is semidet.
%
% Aggregate bindings in Goal according to Template. The aggregate_all/3
% version performs findall/3 on Goal.
aggregate_all(Template, Goal0, Result) :-
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
findall(Pattern, Goal, List),
aggregate_list(Aggregate, List, Result).
%% aggregate_all(+Template, +Discriminator, :Goal, -Result) is semidet.
%
% Aggregate bindings in Goal according to Template. The aggregate_all/3
% version performs findall/3 followed by sort/2 on Goal.
aggregate_all(Template, Discriminator, Goal0, Result) :-
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
findall(Discriminator-Pattern, Goal, Pairs0),
sort(Pairs0, Pairs),
pairs_values(Pairs, List),
aggregate_list(Aggregate, List, Result).
template_to_pattern(_All, Template, Pattern, Goal0, Goal, Aggregate) :-
template_to_pattern(Template, Pattern, Post, Vars, Aggregate),
existential_vars(Goal0, Goal1, AllVars, Vars),
clean_body((Goal1, Post), Goal2),
add_existential_vars(AllVars, Goal2, Goal).
existential_vars(Var, Var) -->
{ var(Var) }, !.
existential_vars(Var^G0, G) --> !,
[Var],
existential_vars(G0, G).
existential_vars(G, G) -->
[].
add_existential_vars([], G, G).
add_existential_vars([H|T], G0, H^G1) :-
add_existential_vars(T, G0, G1).
%% clean_body(+Goal0, -Goal) is det.
%
% Remove redundant =true= from Goal0.
clean_body((Goal0,Goal1), Goal) :- !,
clean_body(Goal0, GoalA),
clean_body(Goal1, GoalB),
( GoalA == true
-> Goal = GoalB
; GoalB == true
-> Goal = GoalA
; Goal = (GoalA,GoalB)
).
clean_body(Goal, Goal).
%% template_to_pattern(+Template, -Pattern, -Post, -Vars, -Agregate)
%
% Determine which parts of the goal we must remember in the
% findall/3 pattern.
%
% @param Post is a body-term that evaluates expressions to reduce
% storage requirements.
% @param Vars is a list of intermediate variables that must be
% added to the existential variables for bagof/3.
% @param Agregate defines the aggregation operation to execute.
template_to_pattern(sum(X), X, true, [], sum) :- var(X), !.
template_to_pattern(sum(X0), X, X is X0, [X0], sum) :- !.
template_to_pattern(count, 1, true, [], count) :- !.
template_to_pattern(min(X), X, true, [], min) :- var(X), !.
template_to_pattern(min(X0), X, X is X0, [X0], min) :- !.
template_to_pattern(min(X0, Witness), X-Witness, X is X0, [X0], min_witness) :- !.
template_to_pattern(max(X0), X, X is X0, [X0], max) :- !.
template_to_pattern(max(X0, Witness), X-Witness, X is X0, [X0], max_witness) :- !.
template_to_pattern(set(X), X, true, [], set) :- !.
template_to_pattern(bag(X), X, true, [], bag) :- !.
template_to_pattern(Term, Pattern, Goal, Vars, term(MinNeeded, Functor, AggregateArgs)) :-
compound(Term), !,
Term =.. [Functor|Args0],
templates_to_patterns(Args0, Args, Goal, Vars, AggregateArgs),
needs_one(AggregateArgs, MinNeeded),
Pattern =.. [Functor|Args].
template_to_pattern(Term, _, _, _, _) :-
type_error(aggregate_template, Term).
templates_to_patterns([], [], true, [], []).
templates_to_patterns([H0], [H], G, Vars, [A]) :- !,
template_to_pattern(H0, H, G, Vars, A).
templates_to_patterns([H0|T0], [H|T], (G0,G), Vars, [A0|A]) :-
template_to_pattern(H0, H, G0, V0, A0),
append(V0, RV, Vars),
templates_to_patterns(T0, T, G, RV, A).
%% needs_one(+Ops, -OneOrZero)
%
% If one of the operations in Ops needs at least one answer,
% unify OneOrZero to 1. Else 0.
needs_one(Ops, 1) :-
member(Op, Ops),
needs_one(Op), !.
needs_one(_, 0).
needs_one(min).
needs_one(min_witness).
needs_one(max).
needs_one(max_witness).
%% aggregate_list(+Op, +List, -Answer) is semidet.
%
% Aggregate the answer from the list produced by findall/3,
% bagof/3 or setof/3. The latter two cases deal with compound
% answers.
%
% @tbd Compile code for incremental state update, which we will use
% for aggregate_all/3 as well. We should be using goal_expansion
% to generate these clauses.
aggregate_list(bag, List0, List) :- !,
List = List0.
aggregate_list(set, List, Set) :- !,
sort(List, Set).
aggregate_list(sum, List, Sum) :-
sumlist(List, Sum).
aggregate_list(count, List, Count) :-
length(List, Count).
aggregate_list(max, List, Sum) :-
max_list(List, Sum).
aggregate_list(max_witness, List, max(Max, Witness)) :-
max_pair(List, Max, Witness).
aggregate_list(min, List, Sum) :-
min_list(List, Sum).
aggregate_list(min_witness, List, min(Min, Witness)) :-
min_pair(List, Min, Witness).
aggregate_list(term(0, Functor, Ops), List, Result) :- !,
maplist(state0, Ops, StateArgs, FinishArgs),
State0 =.. [Functor|StateArgs],
aggregate_term_list(List, Ops, State0, Result0),
finish_result(Ops, FinishArgs, Result0, Result).
aggregate_list(term(1, Functor, Ops), [H|List], Result) :-
H =.. [Functor|Args],
maplist(state1, Ops, Args, StateArgs, FinishArgs),
State0 =.. [Functor|StateArgs],
aggregate_term_list(List, Ops, State0, Result0),
finish_result(Ops, FinishArgs, Result0, Result).
aggregate_term_list([], _, State, State).
aggregate_term_list([H|T], Ops, State0, State) :-
step_term(Ops, H, State0, State1),
aggregate_term_list(T, Ops, State1, State).
%% min_pair(+Pairs, -Key, -Value) is det.
%% max_pair(+Pairs, -Key, -Value) is det.
%
% True if Key-Value has the smallest/largest key in Pairs. If
% multiple pairs share the smallest/largest key, the first pair is
% returned.
min_pair([M0-W0|T], M, W) :-
min_pair(T, M0, W0, M, W).
min_pair([], M, W, M, W).
min_pair([M0-W0|T], M1, W1, M, W) :-
( M0 > M1
-> min_pair(T, M0, W0, M, W)
; min_pair(T, M1, W1, M, W)
).
max_pair([M0-W0|T], M, W) :-
max_pair(T, M0, W0, M, W).
max_pair([], M, W, M, W).
max_pair([M0-W0|T], M1, W1, M, W) :-
( M0 > M1
-> max_pair(T, M0, W0, M, W)
; max_pair(T, M1, W1, M, W)
).
%% step(+AggregateAction, +New, +State0, -State1).
step(bag, X, [X|L], L).
step(set, X, [X|L], L).
step(count, _, X0, X1) :-
succ(X0, X1).
step(sum, X, X0, X1) :-
X1 is X0+X.
step(max, X, X0, X1) :-
X1 is max(X0, X).
step(min, X, X0, X1) :-
X1 is min(X0, X).
step(max_witness, X-W, X0-W0, X1-W1) :-
( X > X0
-> X1 = X, W1 = W
; X1 = X0, W1 = W0
).
step(min_witness, X-W, X0-W0, X1-W1) :-
( X < X0
-> X1 = X, W1 = W
; X1 = X0, W1 = W0
).
step(term(Ops), Row, Row0, Row1) :-
step_term(Ops, Row, Row0, Row1).
step_term(Ops, Row, Row0, Row1) :-
functor(Row, Name, Arity),
functor(Row1, Name, Arity),
step_list(Ops, 1, Row, Row0, Row1).
step_list([], _, _, _, _).
step_list([Op|OpT], Arg, Row, Row0, Row1) :-
arg(Arg, Row, X),
arg(Arg, Row0, X0),
arg(Arg, Row1, X1),
step(Op, X, X0, X1),
succ(Arg, Arg1),
step_list(OpT, Arg1, Row, Row0, Row1).
finish_result(Ops, Finish, R0, R) :-
functor(R0, Functor, Arity),
functor(R, Functor, Arity),
finish_result(Ops, Finish, 1, R0, R).
finish_result([], _, _, _, _).
finish_result([Op|OpT], [F|FT], I, R0, R) :-
arg(I, R0, A0),
arg(I, R, A),
finish_result1(Op, F, A0, A),
succ(I, I2),
finish_result(OpT, FT, I2, R0, R).
finish_result1(bag, Bag0, [], Bag) :- !,
Bag = Bag0.
finish_result1(set, Bag, [], Set) :- !,
sort(Bag, Set).
finish_result1(max_witness, _, M-W, R) :- !,
R = max(M,W).
finish_result1(min_witness, _, M-W, R) :- !,
R = min(M,W).
finish_result1(_, _, A, A).
%% state0(+Op, -State, -Finish)
state0(bag, L, L).
state0(set, L, L).
state0(count, 0, _).
state0(sum, 0, _).
%% state1(+Op, +First, -State, -Finish)
state1(bag, X, [X|L], L).
state1(set, X, [X|L], L).
state1(_, X, X, _).
/*******************************
* FOREACH *
*******************************/
%% foreach(:Generator, :Goal)
%
% True if the conjunction of instances of Goal using the bindings
% from Generator is true. Unlike forall/2, which runs a
% failure-driven loop that proves Goal for each solution of
% Generator, foreach creates a conjunction. Each member of the
% conjunction is a copy of Goal, where the variables it shares
% with Generator are filled with the values from the corresponding
% solution.
%
% The implementation executes forall/2 if Goal does not contain
% any variables that are not shared with Generator.
%
% Here is an example:
%
% ==
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 5.
% Y = 5
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 3.
% No
% ==
%
% @bug Goal is copied repeatetly, which may cause problems if
% attributed variables are involved.
foreach(Generator, Goal0) :-
strip_module(Goal0, M, G),
Goal = M:G,
term_variables(Generator, GenVars0), sort(GenVars0, GenVars),
term_variables(Goal, GoalVars0), sort(GoalVars0, GoalVars),
ord_subtract(GoalVars, GenVars, SharedGoalVars),
( SharedGoalVars == []
-> \+ (Generator, \+Goal) % = forall(Generator, Goal)
; ord_intersection(GenVars, GoalVars, SharedVars),
Templ =.. [v|SharedVars],
SharedTempl =.. [v|SharedGoalVars],
findall(Templ, Generator, List),
prove_list(List, Templ, SharedTempl, Goal)
).
prove_list([], _, _, _).
prove_list([H|T], Templ, SharedTempl, Goal) :-
copy_term(Templ+SharedTempl+Goal,
H+SharedTempl+Copy),
Copy,
prove_list(T, Templ, SharedTempl, Goal).
%% free_variables(:Generator, +Template, +VarList0, -VarList) is det.
%
% In order to handle variables properly, we have to find all the
% universally quantified variables in the Generator. All variables
% as yet unbound are universally quantified, unless
%
% 1. they occur in the template
% 2. they are bound by X^P, setof, or bagof
%
% free_variables(Generator, Template, OldList, NewList) finds this
% set, using OldList as an accumulator.
%
% @author Richard O'Keefe
% @author Jan Wielemaker (made some SWI-Prolog enhancements)
% @license Public domain (from DEC10 library).
% @tbd Distinguish between control-structures and data terms.
% @tbd Exploit our built-in term_variables/2 at some places?
free_variables(Term, Bound, VarList, [Term|VarList]) :-
var(Term),
term_is_free_of(Bound, Term),
list_is_free_of(VarList, Term), !.
free_variables(Term, _Bound, VarList, VarList) :-
var(Term), !.
free_variables(Term, Bound, OldList, NewList) :-
explicit_binding(Term, Bound, NewTerm, NewBound), !,
free_variables(NewTerm, NewBound, OldList, NewList).
free_variables(Term, Bound, OldList, NewList) :-
functor(Term, _, N),
free_variables(N, Term, Bound, OldList, NewList).
free_variables(0, _, _, VarList, VarList) :- !.
free_variables(N, Term, Bound, OldList, NewList) :-
arg(N, Term, Argument),
free_variables(Argument, Bound, OldList, MidList),
M is N-1, !,
free_variables(M, Term, Bound, MidList, NewList).
% explicit_binding checks for goals known to existentially quantify
% one or more variables. In particular \+ is quite common.
explicit_binding(\+ _Goal, Bound, fail, Bound ) :- !.
explicit_binding(not(_Goal), Bound, fail, Bound ) :- !.
explicit_binding(Var^Goal, Bound, Goal, Bound+Var) :- !.
explicit_binding(setof(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !.
explicit_binding(bagof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !.
%% term_is_free_of(+Term, +Var) is semidet.
%
% True if Var does not appear in Term. This has been rewritten
% from the DEC10 library source to exploit our non-deterministic
% arg/3.
term_is_free_of(Term, Var) :-
\+ var_in_term(Term, Var).
var_in_term(Term, Var) :-
Var == Term, !.
var_in_term(Term, Var) :-
compound(Term),
arg(_, Term, Arg),
var_in_term(Arg, Var), !.
%% list_is_free_of(+List, +Var) is semidet.
%
% True if Var is not in List.
list_is_free_of([Head|Tail], Var) :-
Head \== Var, !,
list_is_free_of(Tail, Var).
list_is_free_of([], _).
% term_variables(+Term, +Vars0, -Vars) is det.
%
% True if Vars is the union of variables in Term and Vars0.
% We cannot have this as term_variables/3 is already defined
% as a difference-list version of term_variables/2.
%term_variables(Term, Vars0, Vars) :-
% term_variables(Term+Vars0, Vars).

144
GPL/apply.pl Normal file
View File

@ -0,0 +1,144 @@
/* $Id: apply.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(apply,
[ include/3, % :Pred, +List, -Ok
exclude/3, % :Pred. +List, -NotOk
partition/4, % :Pred, +List, -Included, -Excluded
partition/5 % :Pred, +List, ?Less, ?Equal, ?Greater
]).
:- use_module(library(error)).
/** <module> Apply predicates on a list
This module defines meta-predicates that apply a predicate on all
members of a list.
@see apply_macros.pl provides compile-time expansion for part of this
library.
@see http://www.cs.otago.ac.nz/staffpriv/ok/pllib.htm
@tbd Move maplist/N from boot/apply.pl to here.
@tbd Add include/4, include/5, exclude/4, exclude/5
*/
:- module_transparent
include/3,
include_/3,
exclude/3,
exclude_/3,
partition/4,
partition_/4,
partition/5,
partition_/5,
partition_7.
%% include(:Goal, +List1, ?List2) is det.
%
% Filter elements for which Goal succeed. True if List2 contains
% those elements Xi of List1 for which call(Goal, Xi) succeeds.
%
% @see Older versions of SWI-Prolog had sublist/3 with the same
% arguments and semantics.
include(Goal, List, Included) :-
include_(List, Goal, Included).
include_([], _, []).
include_([X1|Xs1], P, Included) :-
( call(P, X1)
-> Included = [X1|Included1]
; Included = Included1
),
include_(Xs1, P, Included1).
%% exclude(:Goal, +List1, ?List2) is det.
%
% Filter elements for which Goal fails. True if List2 contains
% those elements Xi of List1 for which call(Goal, Xi) fails.
exclude(Goal, List, Included) :-
exclude_(List, Goal, Included).
exclude_([], _, []).
exclude_([X1|Xs1], P, Included) :-
( call(P, X1)
-> Included = Included1
; Included = [X1|Included1]
),
exclude_(Xs1, P, Included1).
%% partition(:Pred, +List, ?Included, ?Excluded) is det.
%
% Filter elements of List according to Pred. True if Included
% contains all elements for which call(Pred, X) succeeds and
% Excluded contains the remaining elements.
partition(Pred, List, Included, Excluded) :-
partition_(List, Pred, Included, Excluded).
partition_([], _, [], []).
partition_([H|T], Pred, Incl, Excl) :-
( call(Pred, H)
-> Incl = [H|I],
partition_(T, Pred, I, Excl)
; Excl = [H|E],
partition_(T, Pred, Incl, E)
).
%% partition(:Pred, +List, ?Less, ?Equal, ?Greater) is semidet.
%
% Filter list according to Pred in three sets. For each element Xi
% of List, its destination is determined by call(Pred, Xi, Place),
% where Place must be unified to one of =|<|=, =|=|= or =|>|=.
% Pred must be deterministic.
partition(Pred, List, Less, Equal, Greater) :-
partition_(List, Pred, Less, Equal, Greater).
partition_([], _, [], [], []).
partition_([H|T], Pred, L, E, G) :-
call(Pred, H, Diff),
partition_(Diff, H, Pred, T, L, E, G).
partition_(<, H, Pred, T, [H|L], E, G) :- !,
partition_(T, Pred, L, E, G).
partition_(=, H, Pred, T, L, [H|E], G) :- !,
partition_(T, Pred, L, E, G).
partition_(>, H, Pred, T, L, E, [H|G]) :- !,
partition_(T, Pred, L, E, G).
partition_(Diff, _, _, _, _, _, _) :-
must_be(oneof([<.=,>]), Diff).

261
GPL/error.pl Normal file
View File

@ -0,0 +1,261 @@
/* $Id: error.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(error,
[ type_error/2, % +Type, +Term
domain_error/2, % +Domain, +Term
existence_error/2, % +Type, +Term
permission_error/3, % +Action, +Type, +Term
instantiation_error/1, % +Term
representation_error/1, % +Reason
must_be/2, % +Type, +Term
is_of_type/2 % +Type, +Term
]).
:- if(current_prolog_flag(dialect, yap)).
:- use_module(library(lists),[memberchk/2]).
:- endif.
/** <module> Error generating support
This module provides predicates to simplify error generation and
checking. It's implementation is based on a discussion on the SWI-Prolog
mailinglist on best practices in error handling. The utility predicate
must_be/2 provides simple run-time type validation. The *_error
predicates are simple wrappers around throw/1 to simplify throwing the
most common ISO error terms.
@author Jan Wielemaker
@author Richard O'Keefe
@see library(debug) and library(prolog_stack).
*/
:- multifile
has_type/2.
%% type_error(+Type, +Term).
%% domain_error(+Type, +Term).
%% existence_error(+Type, +Term).
%% permission_error(+Action, +Type, +Term).
%% instantiation_error(+Term).
%% representation_error(+Reason).
%
% Throw ISO compliant error messages.
type_error(Type, Term) :-
throw(error(type_error(Type, Term), _)).
domain_error(Type, Term) :-
throw(error(domain_error(Type, Term), _)).
existence_error(Type, Term) :-
throw(error(existence_error(Type, Term), _)).
permission_error(Action, Type, Term) :-
throw(error(permission_error(Action, Type, Term), _)).
instantiation_error(_Term) :-
throw(error(instantiation_error, _)).
representation_error(Reason) :-
throw(error(representation_error(Reason), _)).
%% must_be(+Type, @Term) is det.
%
% True if Term satisfies the type constraints for Type. Defined
% types are =atom=, =atomic=, =between=, =boolean=, =callable=,
% =chars=, =codes=, =text=, =compound=, =constant=, =float=,
% =integer=, =nonneg=, =positive_integer=, =negative_integer=,
% =nonvar=, =number=, =oneof=, =list=, =list_or_partial_list=,
% =symbol=, =var=, =rational= and =string=.
%
% Most of these types are defined by an arity-1 built-in predicate
% of the same name. Below is a brief definition of the other
% types.
%
% | boolean | one of =true= or =false= |
% | chars | Proper list of 1-character atoms |
% | codes | Proper list of Unicode character codes |
% | text | One of =atom=, =string=, =chars= or =codes= |
% | between(L,U) | Number between L and U (including L and U) |
% | nonneg | Integer >= 0 |
% | positive_integer | Integer > 0 |
% | negative_integer | Integer < 0 |
% | oneof(L) | Ground term that is member of L |
% | list(Type) | Proper list with elements of Type |
% | list_or_partial_list | A list or an open list (ending in a variable |
%
% @throws instantiation_error if Term is insufficiently
% instantiated and type_error(Type, Term) if Term is not of Type.
must_be(Type, X) :-
( has_type(Type, X)
-> true
; is_not(Type, X)
).
%% is_not(+Type, @Term)
%
% Throws appropriate error. It is _known_ that Term is not of type
% Type.
%
% @throws type_error(Type, Term)
% @throws instantiation_error
is_not(list, X) :- !,
not_a_list(list, X).
is_not(list(_), X) :- !,
not_a_list(list, X).
is_not(list_or_partial_list, X) :- !,
type_error(list, X).
is_not(chars, X) :- !,
not_a_list(chars, X).
is_not(codes, X) :- !,
not_a_list(codes, X).
is_not(var,_X) :- !,
representation_error(variable).
is_not(rational, X) :- !,
not_a_rational(X).
is_not(Type, X) :-
( var(X)
-> instantiation_error(X)
; ground_type(Type), \+ ground(X)
-> instantiation_error(X)
; type_error(Type, X)
).
ground_type(ground).
ground_type(oneof(_)).
ground_type(stream).
ground_type(text).
ground_type(string).
not_a_list(Type, X) :-
'$skip_list'(_, X, Rest),
( var(Rest)
-> instantiation_error(X)
; type_error(Type, X)
).
:- if(current_prolog_flag(dialect, yap)).
% vsc: I hope it works like this
'$skip_list'(_, Rest, Rest) :- var(Rest), !.
'$skip_list'(_, [], _) :- !, fail.
'$skip_list'(Anything, [_|More], Rest) :-
'$skip_list'(Anything, [_|More], Rest).
'$skip_list'(Anything, [_|More], Rest) :-
'$skip_list'(Anything, More, Rest).
'$skip_list'(Anything, Rest, Rest).
:- endif.
not_a_rational(X) :-
( var(X)
-> instantiation_error(X)
; X = rdiv(N,D)
-> must_be(integer, N), must_be(integer, D),
type_error(rational,X)
; type_error(rational,X)
).
%% is_of_type(+Type, @Term) is semidet.
%
% True if Term satisfies Type.
is_of_type(Type, Term) :-
has_type(Type, Term).
%% has_type(+Type, @Term) is semidet.
%
% True if Term satisfies Type.
has_type(impossible, _) :- instantiation_error(_).
has_type(any, _).
has_type(atom, X) :- atom(X).
has_type(atomic, X) :- atomic(X).
has_type(between(L,U), X) :- ( integer(L)
-> integer(X), between(L,U,X)
; number(X), X >= L, X =< U
).
has_type(boolean, X) :- (X==true;X==false), !.
has_type(callable, X) :- callable(X).
has_type(chars, X) :- chars(X).
has_type(codes, X) :- codes(X).
has_type(text, X) :- text(X).
has_type(compound, X) :- compound(X).
has_type(constant, X) :- atomic(X).
has_type(float, X) :- float(X).
has_type(ground, X) :- ground(X).
has_type(integer, X) :- integer(X).
has_type(nonneg, X) :- integer(X), X >= 0.
has_type(positive_integer, X) :- integer(X), X > 0.
has_type(negative_integer, X) :- integer(X), X < 0.
has_type(nonvar, X) :- nonvar(X).
has_type(number, X) :- number(X).
has_type(oneof(L), X) :- ground(X), memberchk(X, L).
has_type(proper_list, X) :- is_list(X).
has_type(list, X) :- is_list(X).
has_type(list_or_partial_list, X) :- is_list_or_partial_list(X).
has_type(symbol, X) :- atom(X).
has_type(var, X) :- var(X).
has_type(rational, X) :- rational(X).
has_type(string, X) :- string(X).
has_type(stream, X) :- is_stream(X).
has_type(list(Type), X) :- is_list(X), element_types(X, Type).
chars(0) :- !, fail.
chars([]).
chars([H|T]) :-
atom(H), atom_length(H, 1),
chars(T).
codes(x) :- !, fail.
codes([]).
codes([H|T]) :-
integer(H), between(1, 0x10ffff, H),
codes(T).
text(X) :-
( atom(X)
; string(X)
; chars(X)
; codes(X)
), !.
element_types([], _).
element_types([H|T], Type) :-
must_be(Type, H),
element_types(T, Type).
is_list_or_partial_list(L0) :-
'$skip_list'(_, L0,L),
( var(L) -> true ; L == [] ).

141
GPL/occurs.yap Normal file
View File

@ -0,0 +1,141 @@
/* $Id: occurs.yap,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(occurs,
[ contains_term/2, % +SubTerm, +Term
contains_var/2, % +SubTerm, +Term
free_of_term/2, % +SubTerm, +Term
free_of_var/2, % +SubTerm, +Term
occurrences_of_term/3, % +SubTerm, +Term, ?Tally
occurrences_of_var/3, % +SubTerm, +Term, ?Tally
sub_term/2, % -SubTerm, +Term
sub_var/2 % -SubTerm, +Term (SWI extra)
]).
:- use_module(library(arg),
[genarg/3]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This is a SWI-Prolog implementation of the corresponding Quintus
library, based on the generalised arg/3 predicate of SWI-Prolog.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
%% contains_term(+Sub, +Term) is semidet.
%
% Succeeds if Sub is contained in Term (=, deterministically)
contains_term(X, X) :- !.
contains_term(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
contains_term(X, Arg), !.
%% contains_var(+Sub, +Term) is det.
%
% Succeeds if Sub is contained in Term (==, deterministically)
contains_var(X0, X1) :-
X0 == X1, !.
contains_var(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
contains_var(X, Arg), !.
%% free_of_term(+Sub, +Term)
%
% Succeeds of Sub does not unify to any subterm of Term
free_of_term(Sub, Term) :-
\+ contains_term(Sub, Term).
%% free_of_var(+Sub, +Term)
%
% Succeeds of Sub is not equal (==) to any subterm of Term
free_of_var(Sub, Term) :-
\+ contains_var(Sub, Term).
%% occurrences_of_term(+SubTerm, +Term, ?Count)
%
% Count the number of SubTerms in Term
occurrences_of_term(Sub, Term, Count) :-
count(sub_term(Sub, Term), Count).
%% occurrences_of_var(+SubTerm, +Term, ?Count)
%
% Count the number of SubTerms in Term
occurrences_of_var(Sub, Term, Count) :-
count(sub_var(Sub, Term), Count).
%% sub_term(-Sub, +Term)
%
% Generates (on backtracking) all subterms of Term.
sub_term(X, X).
sub_term(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
sub_term(X, Arg).
%% sub_var(-Sub, +Term)
%
% Generates (on backtracking) all subterms (==) of Term.
sub_var(X0, X1) :-
X0 == X1.
sub_var(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
sub_var(X, Arg).
/*******************************
* UTIL *
*******************************/
%% count(+Goal, -Count)
%
% Count number of times Goal succeeds.
count(Goal, Count) :-
State = count(0),
( Goal,
arg(1, State, N0),
N is N0 + 1,
nb_setarg(1, State, N),
fail
; arg(1, State, Count)
).

162
GPL/pairs.pl Normal file
View File

@ -0,0 +1,162 @@
/* $Id: pairs.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(pairs,
[ pairs_keys_values/3,
pairs_values/2,
pairs_keys/2,
group_pairs_by_key/2,
transpose_pairs/2,
map_list_to_pairs/3
]).
/** <module> Operations on key-value lists
This module implements common operations on Key-Value lists, also known
as _Pairs_. Pairs have great practical value, especially due to
keysort/2 and the library assoc.pl.
This library is based on disussion in the SWI-Prolog mailinglist,
including specifications from Quintus and a library proposal by Richard
O'Keefe.
@see keysort/2, library(assoc)
@author Jan Wielemaker
*/
%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det.
%
% True if Keys holds the keys of Pairs and Values the values.
%
% Deterministic if any argument is instantiated to a finite list
% and the others are either free or finite lists.
pairs_keys_values(Pairs, Keys, Values) :-
( nonvar(Pairs) ->
pairs_keys_values_(Pairs, Keys, Values)
; nonvar(Keys) ->
keys_values_pairs(Keys, Values, Pairs)
; values_keys_pairs(Values, Keys, Pairs)
).
pairs_keys_values_([], [], []).
pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :-
pairs_keys_values_(Pairs, Keys, Values).
keys_values_pairs([], [], []).
keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :-
keys_values_pairs(Ks, Vs, Pairs).
values_keys_pairs([], [], []).
values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :-
values_keys_pairs(Vs, Ks, Pairs).
%% pairs_values(+Pairs, -Values) is det.
%
% Remove the keys from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, _, Values)
pairs_values([], []).
pairs_values([_-V|T0], [V|T]) :-
pairs_values(T0, T).
%% pairs_keys(+Pairs, -Keys) is det.
%
% Remove the values from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, Keys, _)
pairs_keys([], []).
pairs_keys([K-_|T0], [K|T]) :-
pairs_keys(T0, T).
%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det.
%
% Group values with the same key. For example:
%
% ==
% ?- group_pairs_by_key([a-2, a-1, b-4], X).
%
% X = [a-[2,1], b-[4]]
% ==
%
% @param Pairs Key-Value list, sorted to the standard order
% of terms (as keysort/2 does)
% @param Joined List of Key-Group, where Group is the
% list of Values associated with Key.
group_pairs_by_key([], []).
group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :-
same_key(M, T0, TN, T1),
group_pairs_by_key(T1, T).
same_key(M, [M-N|T0], [N|TN], T) :- !,
same_key(M, T0, TN, T).
same_key(_, L, [], L).
%% transpose_pairs(+Pairs, -Transposed) is det.
%
% Swap Key-Value to Value-Key and sort the result on Value
% (the new key) using keysort/2.
transpose_pairs(Pairs, Transposed) :-
flip_pairs(Pairs, Flipped),
keysort(Flipped, Transposed).
flip_pairs([], []).
flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :-
flip_pairs(Pairs, Flipped).
%% map_list_to_pairs(:Function, +List, -Keyed)
%
% Create a key-value list by mapping each element of List.
% For example, if we have a list of lists we can create a
% list of Length-List using
%
% ==
% map_list_to_pairs(length, ListOfLists, Pairs),
% ==
:- module_transparent
map_list_to_pairs/3,
map_list_to_pairs2/3.
map_list_to_pairs(Function, List, Pairs) :-
map_list_to_pairs2(List, Function, Pairs).
map_list_to_pairs2([], _, []).
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
call(Pred, H, K),
map_list_to_pairs2(T0, Pred, T).

4
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.124 2008-01-27 11:01:07 vsc Exp $ *
* version: $Id: Heap.h,v 1.125 2008-02-12 17:03:52 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -500,6 +500,7 @@ typedef struct various_codes {
system_module,
readutil_module,
hacks_module,
arg_module,
globals_module,
swi_module;
void *last_wtime;
@ -809,6 +810,7 @@ struct various_codes *Yap_heap_regs;
#define READUTIL_MODULE Yap_heap_regs->readutil_module
#define HACKS_MODULE Yap_heap_regs->hacks_module
#define GLOBALS_MODULE Yap_heap_regs->globals_module
#define ARG_MODULE Yap_heap_regs->arg_module
#define SWI_MODULE Yap_heap_regs->swi_module
#define PredGoalExpansion Yap_heap_regs->pred_goal_expansion
#define PredMetaCall Yap_heap_regs->pred_meta_call

6
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2008-02-07 21:39:51 $,$Author: vsc $ *
* Last rev: $Date: 2008-02-12 17:03:52 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.84 2008/02/07 21:39:51 vsc
* fix case where predicate is for an integer (DBEntry).
*
* Revision 1.83 2008/01/23 17:57:55 vsc
* valgrind it!
* enable atom garbage collection.
@ -782,6 +785,7 @@ restore_codes(void)
Yap_heap_regs->system_module = AtomTermAdjust(Yap_heap_regs->system_module);
Yap_heap_regs->readutil_module = AtomTermAdjust(Yap_heap_regs->readutil_module);
Yap_heap_regs->globals_module = AtomTermAdjust(Yap_heap_regs->globals_module);
Yap_heap_regs->arg_module = AtomTermAdjust(Yap_heap_regs->arg_module);
Yap_heap_regs->swi_module = AtomTermAdjust(Yap_heap_regs->swi_module);
Yap_heap_regs->global_hold_entry = HoldEntryAdjust(Yap_heap_regs->global_hold_entry);
if (Yap_heap_regs->file_aliases != NULL) {

40
LGPL/Makefile.in Normal file
View File

@ -0,0 +1,40 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
YAP_EXTRAS=@YAP_EXTRAS@
PROGRAMS= $(srcdir)/debug.pl \
$(srcdir)/maplist.pl \
$(srcdir)/operators.pl \
$(srcdir)/option.pl \
$(srcdir)/prolog_source.pl \
$(srcdir)/prolog_xref.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/logtalk
for p in $(LOGTALK_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/logtalk; done

242
LGPL/debug.pl Normal file
View File

@ -0,0 +1,242 @@
/* $Id: debug.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_debug,
[ debug/3, % +Topic, +Format, +Args
debug/1, % +Topic
nodebug/1, % +Topic
debugging/1, % ?Topic
debugging/2, % ?Topic, ?Bool
list_debug_topics/0,
assertion/1 % :Goal
]).
:- meta_predicate(assertion(:)).
:- set_prolog_flag(generate_debug_info, false).
:- if(current_prolog_flag(dialect, yap)).
:- use_module(library(hacks), [stack_dump/1]).
% this is as good as I can do.
backtrace(N) :-
stack_dump(N).
:- endif.
:- dynamic
debugging/2.
/** <module> Print debug messages
This library is a replacement for format/3 for printing debug messages.
Messages are assigned a _topic_. By dynamically enabling or disabling
topics the user can select desired messages. Debug statements are
removed when the code is compiled for optimization.
See manual for details. With XPCE, you can use the call below to start a
graphical monitorring tool.
==
?- prolog_ide(debug_monitor).
==
Using the predicate assertion/1 you can make assumptions about your
program explicit, trapping the debugger if the condition does not hold.
@author Jan Wielemaker
*/
%% debugging(+Topic) is semidet.
%% debugging(-Topic) is nondet.
%% debugging(?Topic, ?Bool) is nondet.
%
% Check whether we are debugging Topic or enumerate the topics we
% are debugging.
debugging(Topic) :-
debugging(Topic, true).
%% debug(+Topic) is det.
%% nodebug(+Topic) is det.
%
% Add/remove a topic from being printed. nodebug(_) removes all
% topics. Gives a warning if the topic is not defined unless it is
% used from a directive. The latter allows placing debug topics at
% the start a a (load-)file without warnings.
debug(Topic) :-
debug(Topic, true).
nodebug(Topic) :-
debug(Topic, false).
debug(Topic, Val) :-
( ( retract(debugging(Topic, _))
*-> assert(debugging(Topic, Val)),
fail
; ( prolog_load_context(file, _)
-> true
; print_message(warning, debug_no_topic(Topic))
),
assert(debugging(Topic, Val))
)
-> true
; true
).
%% debug_topic(+Topic) is det.
%
% Declare a topic for debugging. This can be used to find all
% topics available for debugging.
debug_topic(Topic) :-
( debugging(Registered, _),
Registered =@= Topic
-> true
; assert(debugging(Topic, false))
).
%% list_debug_topics is det.
%
% List currently known debug topics and their setting.
list_debug_topics :-
format(user_error, '~*t~40|~n', "-"),
format(user_error, '~w~t~30| ~w~n', ['Debug Topic', 'Activated']),
format(user_error, '~*t~40|~n', "-"),
( debugging(Topic, Value),
format(user_error, '~w~t~30| ~w~n', [Topic, Value]),
fail
; true
).
%% debug(+Topic, +Format, +Args) is det.
%
% As format/3 to user_error, but only does something if Topic
% is activated through debug/1.
debug(Topic, Format, Args) :-
debugging(Topic, true), !,
print_debug(Topic, Format, Args).
debug(_, _, _).
:- multifile
prolog:debug_print_hook/3.
print_debug(Topic, Format, Args) :-
prolog:debug_print_hook(Topic, Format, Args), !.
print_debug(_, Format, Args) :-
print_message(informational, debug(Format, Args)).
/*******************************
* ASSERTION *
*******************************/
%% assertion(:Goal) is det.
%
% Acts similar to C assert() macro. It has no effect of Goal
% succeeds. If Goal fails it prints a message, a stack-trace
% and finally traps the debugger.
assertion(G) :-
\+ \+ G, !. % avoid binding variables
assertion(G) :-
print_message(error, assumption_failed(G)),
backtrace(10),
trace,
assertion_failed.
assertion_failed.
%% assume(:Goal) is det.
%
% Acts similar to C assert() macro. It has no effect of Goal
% succeeds. If Goal fails it prints a message, a stack-trace
% and finally traps the debugger.
%
% @deprecated Use assertion/1 in new code.
/*******************************
* EXPANSION *
*******************************/
:- multifile
user:goal_expansion/2.
user:goal_expansion(debug(Topic,_,_), true) :-
( current_prolog_flag(optimise, true)
-> true
; debug_topic(Topic),
fail
).
user:goal_expansion(debugging(Topic), fail) :-
( current_prolog_flag(optimise, true)
-> true
; debug_topic(Topic),
fail
).
user:goal_expansion(assertion(G), Goal) :-
( current_prolog_flag(optimise, true)
-> Goal = true
; expand_goal(G, G2),
Goal = assertion(G2)
).
user:goal_expansion(assume(G), Goal) :-
print_message(informational,
compatibility(renamed(assume/1, assertion/1))),
( current_prolog_flag(optimise, true)
-> Goal = true
; expand_goal(G, G2),
Goal = assertion(G2)
).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message/3.
prolog:message(assumption_failed(G)) -->
[ 'Assertion failed: ~p'-[G] ].
prolog:message(debug(Fmt, Args)) -->
{ thread_self(Me) },
( { Me == main }
-> [ Fmt-Args ]
; [ '[Thread ~w] '-[Me], Fmt-Args ]
).
prolog:message(debug_no_topic(Topic)) -->
[ '~q: no matching debug topic (yet)'-[Topic] ].

112
LGPL/maplist.pl Normal file
View File

@ -0,0 +1,112 @@
/* $Id: maplist.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(maplist,
[ maplist/2, % :Goal, +List
maplist/3, % :Goal, ?List1, ?List2
maplist/4, % :Goal, ?List1, ?List2, ?List3
maplist/5, % :Goal, ?List1, ?List2, ?List3, List4
forall/2 % :Goal, :Goal
]).
:- module_transparent
maplist/2,
maplist2/2,
maplist/3,
maplist2/3,
maplist/4,
maplist2/4,
maplist/5,
maplist2/5,
forall/2.
% maplist(:Goal, +List)
%
% True if Goal can succesfully be applied on all elements of List.
% Arguments are reordered to gain performance as well as to make
% the predicate deterministic under normal circumstances.
maplist(Goal, List) :-
maplist2(List, Goal).
maplist2([], _).
maplist2([Elem|Tail], Goal) :-
call(Goal, Elem),
maplist2(Tail, Goal).
% maplist(:Goal, ?List1, ?List2)
%
% True if Goal can succesfully be applied to all succesive pairs
% of elements of List1 and List2.
maplist(Goal, List1, List2) :-
maplist2(List1, List2, Goal).
maplist2([], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], Goal) :-
call(Goal, Elem1, Elem2),
maplist2(Tail1, Tail2, Goal).
% maplist(:Goal, ?List1, ?List2, ?List3)
%
% True if Goal can succesfully be applied to all succesive triples
% of elements of List1..List3.
maplist(Goal, List1, List2, List3) :-
maplist2(List1, List2, List3, Goal).
maplist2([], [], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :-
call(Goal, Elem1, Elem2, Elem3),
maplist2(Tail1, Tail2, Tail3, Goal).
% maplist(:Goal, ?List1, ?List2, ?List3, List4)
%
% True if Goal can succesfully be applied to all succesive
% quadruples of elements of List1..List4
maplist(Goal, List1, List2, List3, List4) :-
maplist2(List1, List2, List3, List4, Goal).
maplist2([], [], [], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :-
call(Goal, Elem1, Elem2, Elem3, Elem4),
maplist2(Tail1, Tail2, Tail3, Tail4, Goal).
% forall(+Condition, +Action)
%
% True if Action if true for all variable bindings for which Condition
% if true.
:- noprofile(forall/2).
forall(Cond, Action) :-
\+ (Cond, \+ Action).

198
LGPL/operators.pl Normal file
View File

@ -0,0 +1,198 @@
/* $Id: operators.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2004, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_operator,
[ push_operators/1, % +List
push_operators/2, % +List, -Undo
pop_operators/0,
pop_operators/1, % +Undo
push_op/3 % Precedence, Type, Name
]).
/** <module> Manage operators
Often, one wants to define operators to improve the readibility of some
very specific code. Operators in Prolog are global objects and changing
operators changes syntax and possible semantics of existing sources. For
this reason it is desirable to reset operator declarations after the
code that needs them has been read. This module defines a rather cruel
-but portable- method to do this.
Usage:
==
:- push_operators(
[ op(900, fx, hello_world)
, op(600, xf, *)
]).
hello_world World :-
....
:- pop_operators.
==
While the above are for source-code, the calls push_operators/2 and
pop_operators/1 can be used for local processing where it is more
comfortable to carry the undo context around.
NOTE: In recent versions of SWI-Prolog operators are local to a module
and can be exported using the syntax below. This is not portable, but
otherwise a more structured approach for operator handling.
==
:- module(mymodule,
[ mypred/1,
op(500, fx, myop)
]).
==
@compat SWI-Prolog
*/
:- thread_local
operator_stack/1.
:- module_transparent
push_operators/1,
push_operators/2,
push_op/3.
%% push_operators(:New) is det.
%% push_operators(:New, -Undo) is det.
%
% Installs the operators from New, where New is a list of op(Prec,
% Type, :Name). The modifications to the operator table are undone
% in a matching call to pop_operators/0.
push_operators(New, Undo) :-
strip_module(New, Module, Ops0),
tag_ops(Ops0, Module, Ops),
undo_operators(Ops, Undo),
set_operators(Ops).
push_operators(New) :-
push_operators(New, Undo),
assert_op(mark),
assert_op(Undo).
%% push_op(+Precedence, +Type, :Name) is det.
%
% As op/3, but this call must appear between push_operators/1 and
% pop_operators/0. The change is undone by the call to
% pop_operators/0
push_op(P, T, A0) :-
( A0 = _:_
-> A = A0
; context_module(M),
A = M:A0
),
undo_operator(op(P,T,A), Undo),
assert_op(Undo),
op(P, T, A).
%% pop_operators is det.
%
% Revert all changes to the operator table realised since the last
% push_operators/1.
pop_operators :-
retract_op(Undo),
( Undo == mark
-> !
; set_operators(Undo),
fail
).
%% pop_operators(+Undo) is det.
%
% Reset operators as pushed by push_operators/2.
pop_operators(Undo) :-
set_operators(Undo).
tag_ops([], _, []).
tag_ops([op(P,Tp,N0)|T0], M, [op(P,Tp,N)|T]) :-
( N0 = _:_
-> N = N0
; N = M:N0
),
tag_ops(T0, M, T).
set_operators([]).
set_operators([H|R]) :-
set_operators(H),
set_operators(R).
set_operators(op(P,T,A)) :-
op(P, T, A).
undo_operators([], []).
undo_operators([O0|T0], [U0|T]) :-
undo_operator(O0, U0),
undo_operators(T0, T).
undo_operator(op(_P, T, N), op(OP, OT, N)) :-
current_op(OP, OT, N),
same_op_type(T, OT), !.
undo_operator(op(P, T, [H|R]), [OH|OT]) :- !,
undo_operator(op(P, T, H), OH),
undo_operator(op(P, T, R), OT).
undo_operator(op(_, _, []), []) :- !.
undo_operator(op(_P, T, N), op(0, T, N)).
same_op_type(T, OT) :-
op_type(T, Type),
op_type(OT, Type).
op_type(fx, prefix).
op_type(fy, prefix).
op_type(xfx, infix).
op_type(xfy, infix).
op_type(yfx, infix).
op_type(yfy, infix).
op_type(xf, postfix).
op_type(yf, postfix).
%% assert_op(+Term) is det.
%% retract_op(-Term) is det.
%
% Force local assert/retract.
assert_op(Term) :-
asserta(operator_stack(Term)).
retract_op(Term) :-
retract(operator_stack(Term)).

118
LGPL/option.pl Normal file
View File

@ -0,0 +1,118 @@
/* $Id: option.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(swi_option,
[ option/2, % +Term, +List
option/3, % +Term, +List, +Default
select_option/3, % +Term, +Options, -RestOpts
select_option/4 % +Term, +Options, -RestOpts, +Default
]).
:- use_module(library(lists)).
%% option(?Option, +OptionList, +Default)
%
% Get an option from a OptionList. OptionList can use the
% Name=Value as well as the Name(Value) convention.
%
% @param Option Term of the form Name(?Value).
option(Opt, Options, Default) :- % make option processing stead-fast
arg(1, Opt, OptVal),
nonvar(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
option(Gen, Options, Default),
Opt = Gen.
option(Opt, Options, _) :-
get_option(Opt, Options), !.
option(Opt, _, Default) :-
arg(1, Opt, Default).
%% option(?Option, +OptionList)
%
% Get an option from a OptionList. OptionList can use the
% Name=Value as well as the Name(Value) convention. Fails silently
% if the option does not appear in OptionList.
%
% @param Option Term of the form Name(?Value).
option(Opt, Options) :- % make option processing stead-fast
arg(1, Opt, OptVal),
nonvar(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
option(Gen, Options),
Opt = Gen.
option(Opt, Options) :-
get_option(Opt, Options), !.
get_option(Opt, Options) :-
memberchk(Opt, Options), !.
get_option(Opt, Options) :-
functor(Opt, OptName, 1),
arg(1, Opt, OptVal),
memberchk(OptName=OptVal, Options), !.
%% select_option(?Option, +Options, -RestOptions) is semidet.
%
% As option/2, removing the matching option from Options and
% unifying the remaining options with RestOptions.
select_option(Opt, Options0, Options) :- % stead-fast
arg(1, Opt, OptVal),
nonvar(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
select_option(Gen, Options0, Options),
Opt = Gen.
select_option(Opt, Options0, Options) :-
get_option(Opt, Options0, Options), !.
get_option(Opt, Options0, Options) :-
select(Opt, Options0, Options), !.
get_option(Opt, Options0, Options) :-
functor(Opt, OptName, 1),
arg(1, Opt, OptVal),
select(OptName=OptVal, Options0, Options), !.
%% select_option(?Option, +Options, -RestOptions, +Default) is det.
%
% As select_option/3, but if Option is not in Options, its value
% is unified with Default and RestOptions with Options.
select_option(Option, Options, RestOptions, _Default) :-
select_option(Option, Options, RestOptions), !.
select_option(Option, Options, Options, Default) :-
arg(1, Option, Default).

242
LGPL/prolog_source.pl Normal file
View File

@ -0,0 +1,242 @@
/* $Id: prolog_source.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2005, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_source,
[ prolog_read_source_term/4, % +Stream, -Term, -Expanded, +Options
prolog_open_source/2, % +Source, -Stream
prolog_close_source/1, % +Stream
prolog_canonical_source/2 % +Spec, -Id
]).
:- use_module(operators).
:- use_module(debug).
/** <module> Examine Prolog source-files
The modile prolog_source.pl provides predicates to open, close and read
terms from Prolog source-files. This may seem easy, but there are a
couple of problems that must be taken care of.
* Source files may start with #!, supporting PrologScript
* Embeded operators declarations must be taken into account
* Style-check options must be taken into account
* Operators and style-check options may be implied by directives
* On behalf of the development environment we also wish to
parse PceEmacs buffers
This module concentrates these issues in a single library. Intended
users of the library are:
$ prolog_xref.pl : The Prolog cross-referencer
$ PceEmacs : Emacs syntax-colouring
$ PlDoc : The documentation framework
*/
:- thread_local
open_source/2. % Stream, State
:- multifile
requires_library/2,
prolog:xref_source_identifier/2, % +Source, -Id
prolog:xref_open_source/2. % +SourceId, -Stream
:- if(current_prolog_flag(dialect, yap)).
% yap
'$set_source_module'(M1, M2) :-
source_module(M1),
module(M2).
'$style_check'([Singleton,Discontiguous,Multiple], StyleF) :-
(
prolog_flag(single_var_warnings,on)
->
Singleton = singleton
;
Singleton = -singleton
),
(
prolog_flag(discontiguous_warnings,on)
->
Discontiguous = discontiguous
;
Discontiguous = -discontiguous
),
(
prolog_flag(redefine_warnings,on)
->
Multiple = multiple
;
Multiple = -multiple
),
style_check(StyleF).
:- endif.
/*******************************
* READING *
*******************************/
%% prolog_read_source_term(+In, -Term, -Expanded, +Options) is det.
%
% Read a term from a Prolog source-file. Options is a option list
% as normally provided to read_term/3.
%
% @param Term Term read
% @param Expanded Result of term-expansion on the term
prolog_read_source_term(In, Term, Expanded, Options) :-
'$set_source_module'(SM, SM),
read_term(In, Term,
[ module(SM)
| Options
]),
expand(Term, Expanded),
update_state(Expanded).
expand(Var, Var) :-
var(Var), !.
expand(Term, _) :-
requires_library(Term, Lib),
ensure_loaded(user:Lib),
fail.
expand('$:-'(X), '$:-'(X)) :- !, % boot module
style_check(+dollar).
expand(Term, Expanded) :-
expand_term(Term, Expanded).
%% requires_library(+Term, -Library)
%
% known expansion hooks. May be expanded as multifile predicate.
requires_library((:- emacs_begin_mode(_,_,_,_,_)), library(emacs_extend)).
requires_library((:- draw_begin_shape(_,_,_,_)), library(pcedraw)).
%% update_state(+Expanded) is det.
%
% Update operators and style-check options from the expanded term.
update_state([]) :- !.
update_state([H|T]) :- !,
update_state(H),
update_state(T).
update_state((:- Directive)) :- !,
update_directive(Directive).
update_state((?- Directive)) :- !,
update_directive(Directive).
update_state(_).
update_directive(module(Module, Public)) :- !,
'$set_source_module'(_, Module),
public_operators(Public).
update_directive(op(P,T,N)) :- !,
'$set_source_module'(SM, SM),
push_op(P,T,SM:N).
update_directive(style_check(Style)) :-
style_check(Style), !.
update_directive(_).
public_operators([]).
public_operators([H|T]) :- !,
( H = op(_,_,_)
-> update_directive(H)
; true
),
public_operators(T).
/*******************************
* SOURCES *
*******************************/
%% prolog_open_source(+CanonicalId:atomic, -Stream:stream) is det.
%
% Open source with given canonical id (see
% prolog_canonical_source/2) and remove the #! line if any.
% Streams opened using this predicate must be closed using
% prolog_close_source/1. Typically using the skeleton below. Using
% this skeleton, operator and style-check options are
% automatically restored to the values before opening the source.
%
% ==
% process_source(Src) :-
% prolog_open_source(Src, In),
% call_cleanup(process(Src), prolog_close_source(In)).
% ==
prolog_open_source(Src, Fd) :-
( prolog:xref_open_source(Src, Fd)
-> true
; open(Src, read, Fd)
),
( peek_char(Fd, #) % Deal with #! script
-> skip(Fd, 10)
; true
),
push_operators([]),
'$set_source_module'(SM, SM),
'$style_check'(Style, Style),
asserta(open_source(Fd, state(Style, SM))).
%% prolog_close_source(+In:stream) is det.
%
% Close a stream opened using prolog_open_source/2. Restores
% operator and style options.
prolog_close_source(In) :-
pop_operators,
( retract(open_source(In, state(Style, SM)))
-> '$style_check'(_, Style),
'$set_source_module'(_, SM)
; assertion(fail)
),
close(In).
%% prolog_canonical_source(+SourceSpec:ground, -Id:atomic) is det.
%
% Given a user-specification of a source, generate a unique and
% indexable identifier for it. For files we use the
% prolog_canonical absolute filename.
prolog_canonical_source(Src, Id) :- % Call hook
prolog:xref_source_identifier(Src, Id), !.
prolog_canonical_source(User, user) :-
User == user, !.
prolog_canonical_source(Source, Src) :-
absolute_file_name(Source,
[ file_type(prolog),
access(read),
file_errors(fail)
],
Src), !.
prolog_canonical_source(Source, Src) :-
var(Source), !,
Src = Source.

1290
LGPL/prolog_xref.pl Normal file
View File

File diff suppressed because it is too large Load Diff

6
Makefile.in
View File

@ -92,7 +92,7 @@ VERSION=Yap-5.1.3
MYDDAS_VERSION=MYDDAS-0.9.1
#
INTERFACE_HEADERS = $(srcdir)/include/c_interface.h $(srcdir)/include/yap_structs.h $(srcdir)/include/YapInterface.h
INTERFACE_HEADERS = $(srcdir)/include/c_interface.h $(srcdir)/include/yap_structs.h $(srcdir)/include/YapInterface.h $(srcdir)/include/SWI-Prolog.h $(srcdir)/include/SWI-Stream.h
HEADERS = \
$(srcdir)/H/TermExt.h $(srcdir)/H/Atoms.h \
@ -515,7 +515,7 @@ sys.o: $(srcdir)/library/system/sys.c
$(CC) -c $(CFLAGS) -I$(srcdir)/include $(srcdir)/library/system/sys.c -o $@
yap2swi.o: $(srcdir)/library/yap2swi/yap2swi.c
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir)/library/yap2swi $(srcdir)/library/yap2swi/yap2swi.c -o $@
$(CC) -c $(CFLAGS) -I$(srcdir)/include $(srcdir)/library/yap2swi/yap2swi.c -o $@
random.o: $(srcdir)/library/random/random.c
$(CC) -c $(CFLAGS) -I$(srcdir)/include $(srcdir)/library/random/random.c -o $@
@ -632,6 +632,8 @@ install_library: @YAPLIB@
install_data:
(cd library ; make install)
(cd LGPL ; make install)
(cd GPL ; make install)
@ENABLE_JPL@ (cd LGPL/JPL ; make install)
@ENABLE_JPL@ (cd LGPL/JPL/java; make install)
$(INSTALL_DATA) $(srcdir)/LGPL/pillow/icon_address.pl $(DESTDIR)$(SHAREDIR)/Yap/

6
changes-5.1.html
View File

@ -17,6 +17,12 @@ xb
<h2>Yap-5.1.3:</h2>
<ul>
<li> NEW: time_file/2 (SWI-compatibility).</li>
<li> NEW: module_transparent declaration (SWI-compatibility).</li>
<li> NEW: strip_module/3 (SWI-compatibility).</li>
<li> FIXED: head of if/3, ->/2, *->/2 and once/1 should not be able to
cut up to predicate level. Don't ask me why.</li>
<li> NEW: *->/2 (SWI-compatibility).</li>
<li> NEW: variable_names_may_end_with_quotes allows A' in variable
names (request from Nicos Angelopoulos).</li>
<li> SPEEDUP: quickly check if we are importing an undefined goal.</li>

7
configure vendored
View File

@ -16140,9 +16140,11 @@ mkdir -p LGPL/JPL/src
mkdir -p LGPL/clp
mkdir -p LGPL/clpr
mkdir -p LGPL/chr
mkdir -p GPL
mkdir -p GPL/http
mkdir -p cplint
ac_config_files="$ac_config_files Makefile library/matrix/Makefile library/matlab/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 cplint/Makefile"
ac_config_files="$ac_config_files Makefile library/matrix/Makefile library/matlab/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/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 GPL/http/Makefile GPL/Makefile cplint/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@ -16708,6 +16710,7 @@ do
"library/mpi/Makefile") CONFIG_FILES="$CONFIG_FILES library/mpi/Makefile" ;;
".depend") CONFIG_FILES="$CONFIG_FILES .depend" ;;
"library/Makefile") CONFIG_FILES="$CONFIG_FILES library/Makefile" ;;
"LGPL/Makefile") CONFIG_FILES="$CONFIG_FILES LGPL/Makefile" ;;
"LGPL/chr/Makefile") CONFIG_FILES="$CONFIG_FILES LGPL/chr/Makefile" ;;
"LGPL/chr/chr_swi_bootstrap.yap") CONFIG_FILES="$CONFIG_FILES LGPL/chr/chr_swi_bootstrap.yap" ;;
"CLPBN/Makefile") CONFIG_FILES="$CONFIG_FILES CLPBN/Makefile" ;;
@ -16719,6 +16722,8 @@ do
"LGPL/JPL/src/Makefile") CONFIG_FILES="$CONFIG_FILES LGPL/JPL/src/Makefile" ;;
"LGPL/JPL/java/Makefile") CONFIG_FILES="$CONFIG_FILES LGPL/JPL/java/Makefile" ;;
"LGPL/JPL/jpl_paths.yap") CONFIG_FILES="$CONFIG_FILES LGPL/JPL/jpl_paths.yap" ;;
"GPL/http/Makefile") CONFIG_FILES="$CONFIG_FILES GPL/http/Makefile" ;;
"GPL/Makefile") CONFIG_FILES="$CONFIG_FILES GPL/Makefile" ;;
"cplint/Makefile") CONFIG_FILES="$CONFIG_FILES cplint/Makefile" ;;
*) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5

4
configure.in
View File

@ -1402,9 +1402,11 @@ mkdir -p LGPL/JPL/src
mkdir -p LGPL/clp
mkdir -p LGPL/clpr
mkdir -p LGPL/chr
mkdir -p GPL
mkdir -p GPL/http
mkdir -p cplint
AC_OUTPUT(Makefile library/matrix/Makefile library/matlab/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 cplint/Makefile)
AC_OUTPUT(Makefile library/matrix/Makefile library/matlab/Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/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 GPL/http/Makefile GPL/Makefile cplint/Makefile)
make depend

51
docs/yap.tex
View File

@ -2297,6 +2297,7 @@ that the system already includes declarations for all built-ins.
@end table
In the previous example, the only argument to @code{call/1} must be
expanded, resulting in the following code:
@ -2311,6 +2312,20 @@ a(G) :- call(example:G)
@end example
You can avoid goal expansion by using @code{module_transparent/1}.
@table @code
@item module_transparent +@var{Preds}
@findex module_transparent/1 (directive)
@syindex module_transparent/1 (directive)
@cnindex module_transparent/1 (directive)
@var{Preds} is a comma separated list of name/arity pairs (like
@code{dynamic/1}). Each goal associated with a transparent declared
predicate will inherit the context module from its parent goal.
@end table
@node Re-Exporting Modules, , Meta-Predicates in Modules, Modules
@section Re-Exporting Predicates From Other Modules
@ -2572,6 +2587,21 @@ Note also that you can use chains of commit operators like:
Note that @code{(->)/2} does not affect the scope of cuts in its
arguments.
@item +@var{Conditon} *-> +@var{Action} ; +@var{Else}
@findex ->*/2
@snindex ->*/2
@cnindex ->*/2
This construct implements the so-called @emph{soft-cut}. The control is
defined as follows: If @var{Condition} succeeds at least once, the
semantics is the same as (@var{Condition}, @var {Action}). If
@var{Condition} does not succeed, the semantics is that of (\+
@var{Condition}, @var{Else}). In other words, If @var{Condition}
succeeds at least once, simply behave as the conjunction of
@var{Condition} and @var{Action}, otherwise execute @var{Else}.
The construct @var{A *-> B}, i.e. without an @var{Else} branch, is
translated as the normal conjunction @var{A}, @var{B}.
@item repeat [ISO]
@findex repeat/0
@syindex repeat/0
@ -3932,6 +3962,14 @@ Closes the stream @var{S}, following options @var{O}.
The only valid options are @code{force(true)} and @code{force(false)}.
YAP currently ignores these options.
@item time_file(+@var{File},-@var{Time})
@findex time_file/2
@snindex time_file/2
@cnindex time_file/2
Unify the last modification time of @vaar{File} with
@var{Time}. @var{Time} is a floating point number expressing the seconds
elapsed since Jan 1, 1970.
@item absolute_file_name(+@var{Name},+@var{Options}, -@var{FullPath})
@item absolute_file_name(+@var{Name}, -@var{FullPath},+@var{Options})
@findex absolute_file_name/3
@ -4009,6 +4047,12 @@ in mode @var{M}. It might be used to obtain all open streams (by
backtracking) or to access the stream for a file @var{F} in mode
@var{M}, or to find properties for a stream @var{S}.
@item is_stream(@var{S})
@findex is_stream/1
@snindex is_stream/1
@cnindex is_stream/1
Succeeds if @var{S} is a currently open stream.
@item flush_output [ISO]
@findex flush_output/0
@syindex flush_output/0
@ -8261,6 +8305,13 @@ True when all three arguments are lists, and the members of
It may be used to form @var{Combined} from a given @var{Prefix}, @var{Suffix} or to take
a given @var{Combined} apart.
@item append(?@var{Lists},?@var{Combined})
@findex append/2
@syindex append/2
@cnindex append/2
Holds if the lists of @var{Lists} can be concatenated as a
@var{Combined} list.
@item delete(+@var{List}, ?@var{Element}, ?@var{Residue})
@findex delete/3
@syindex delete/3

20
include/SWI-Prolog.h
View File

@ -1,6 +1,6 @@
/* yap2swi.h */
/*
* Project: jpl for Yap Prolog
* Project: SWI emulation for Yap Prolog
* Author: Steve Moyle and Vitor Santos Costa
* Email: steve.moyle@comlab.ox.ac.uk
* Date: 21 January 2002
@ -10,12 +10,20 @@
*/
#ifndef _FLI_H_INCLUDED
#define _FLI_H_INCLUDED
#ifndef __SWI_PROLOG__ /* use this to switch on Prolog dialect */
#define __SWI_PROLOG__ /* normally defined by the plld compiler driver */
#endif
//=== includes ===============================================================
#include "config.h"
#include <YapInterface.h>
#include <stdarg.h>
#include <wchar.h>
#include <stdlib.h>
#include <stddef.h>
#if HAVE_TIME_H
#include <time.h>
#endif
@ -69,6 +77,7 @@ typedef void *PL_engine_t;
#define PL_FA_TRANSPARENT (0x02) /* foreign is module transparent */
#define PL_FA_NONDETERMINISTIC (0x04) /* foreign is non-deterministic */
#define PL_FA_VARARGS (0x08) /* call using t0, ac, ctx */
#define PL_FA_CREF (0x10) /* Internal: has clause-reference */
/* begin from pl-itf.h */
#define PL_VARIABLE (1) /* nothing */
@ -145,6 +154,7 @@ extern X_API void PL_reset_term_refs(term_t);
extern X_API int PL_get_arg(int, term_t, term_t);
extern X_API int PL_get_atom(term_t, atom_t *);
extern X_API int PL_get_atom_chars(term_t, char **);
extern X_API int PL_get_bool(term_t, int *);
extern X_API int PL_get_chars(term_t, char **, unsigned);
extern X_API int PL_get_nchars(term_t, size_t *, char **, unsigned);
extern X_API int PL_get_wchars(term_t, size_t *, wchar_t **, unsigned);
@ -239,6 +249,7 @@ extern X_API void PL_close_query(qid_t);
extern X_API term_t PL_exception(qid_t);
extern X_API int PL_call_predicate(module_t, int, predicate_t, term_t);
extern X_API int PL_call(term_t, module_t);
extern X_API void PL_register_foreign_in_module(const char *, const char *, int, foreign_t (*)(void), int);
extern X_API void PL_register_extensions(PL_extension *);
extern X_API void PL_load_extensions(PL_extension *);
extern X_API int PL_thread_self(void);
@ -250,9 +261,14 @@ extern X_API int PL_destroy_engine(PL_engine_t);
extern X_API int PL_set_engine(PL_engine_t,PL_engine_t *);
extern X_API int PL_get_string_chars(term_t, char **, int *);
extern X_API int PL_action(int,...);
extern X_API void *PL_malloc(int);
extern X_API void PL_free(void *);
#define PL_register_foreign(name, arity, function, flags) PL_register_foreign_in_module(NULL, (name), (arity), (function), (flags))
extern X_API int Sprintf(char *,...);
extern X_API int Sdprintf(char *,...);
void swi_install(void);
#endif /* _FLI_H_INCLUDED */

142
include/SWI-Stream.h
View File

@ -0,0 +1,142 @@
#ifndef _PL_STREAM_H
#define _PL_STREAM_H
/* This appears to make the wide-character support compile and work
on HPUX 11.23. There really should be a cleaner way ...
*/
#if defined(__hpux)
#include <sys/_mbstate_t.h>
#endif
#if defined(_MSC_VER) && !defined(__WINDOWS__)
#define __WINDOWS__ 1
#endif
#include <stdarg.h>
#include <wchar.h>
#include <stddef.h>
#ifdef __WINDOWS__
typedef __int64 int64_t;
#if (_MSC_VER < 1300)
typedef long intptr_t;
typedef unsigned long uintptr_t;
#endif
typedef intptr_t ssize_t; /* signed version of size_t */
#else
#include <unistd.h>
#include <inttypes.h> /* more portable than stdint.h */
#endif
#ifdef __cplusplus
extern "C" {
#endif
#ifdef __cplusplus
}
#endif
/*******************************
* CONSTANTS *
*******************************/
#ifndef EOF
#define EOF (-1)
#endif
#ifndef NULL
#define NULL ((void *)0)
#endif
#if defined(__WINDOWS__) && !defined(EWOULDBLOCK)
#define EWOULDBLOCK 1000 /* Needed for socket handling */
#endif
#define EPLEXCEPTION 1001 /* errno: pending Prolog exception */
#define SIO_BUFSIZE (4096) /* buffering buffer-size */
#define SIO_LINESIZE (1024) /* Sgets() default buffer size */
#define SIO_MAGIC (7212676) /* magic number */
#define SIO_CMAGIC (42) /* we are close (and thus illegal!) */
typedef ssize_t (*Sread_function)(void *handle, char *buf, size_t bufsize);
typedef ssize_t (*Swrite_function)(void *handle, char*buf, size_t bufsize);
typedef long (*Sseek_function)(void *handle, long pos, int whence);
typedef int64_t (*Sseek64_function)(void *handle, int64_t pos, int whence);
typedef int (*Sclose_function)(void *handle);
typedef int (*Scontrol_function)(void *handle, int action, void *arg);
#if defined(O_PLMT) && defined(PL_KERNEL)
#include "pl-mutex.h"
#define IOLOCK recursiveMutex
#else
typedef void * IOLOCK; /* Definition for external use */
#endif
typedef struct io_functions
{ Sread_function read; /* fill the buffer */
Swrite_function write; /* empty the buffer */
Sseek_function seek; /* seek to position */
Sclose_function close; /* close stream */
Scontrol_function control; /* Info/control */
Sseek64_function seek64; /* seek to position (intptr_t files) */
} IOFUNCTIONS;
typedef struct io_position
{ int64_t byteno; /* byte-position in file */
int64_t charno; /* character position in file */
int lineno; /* lineno in file */
int linepos; /* position in line */
intptr_t reserved[2]; /* future extensions */
} IOPOS;
/* NOTE: check with encoding_names */
/* in pl-file.c */
typedef enum
{ ENC_UNKNOWN = 0, /* invalid/unknown */
ENC_OCTET, /* raw 8 bit input */
ENC_ASCII, /* US-ASCII (0..127) */
ENC_ISO_LATIN_1, /* ISO Latin-1 (0..256) */
ENC_ANSI, /* default (multibyte) codepage */
ENC_UTF8,
ENC_UNICODE_BE, /* big endian unicode file */
ENC_UNICODE_LE, /* little endian unicode file */
ENC_WCHAR /* pl_wchar_t */
} IOENC;
#define SIO_NL_POSIX 0 /* newline as \n */
#define SIO_NL_DOS 1 /* newline as \r\n */
#define SIO_NL_DETECT 3 /* detect processing mode */
typedef struct io_stream
{ char *bufp; /* `here' */
char *limitp; /* read/write limit */
char *buffer; /* the buffer */
char *unbuffer; /* Sungetc buffer */
int lastc; /* last character written */
int magic; /* magic number SIO_MAGIC */
int bufsize; /* size of the buffer */
int flags; /* Status flags */
IOPOS posbuf; /* location in file */
IOPOS * position; /* pointer to above */
void *handle; /* function's handle */
IOFUNCTIONS *functions; /* open/close/read/write/seek */
int locks; /* lock/unlock count */
IOLOCK * mutex; /* stream mutex */
/* SWI-Prolog 4.0.7 */
void (*close_hook)(void* closure);
void * closure;
/* SWI-Prolog 5.1.3 */
int timeout; /* timeout (milliseconds) */
/* SWI-Prolog 5.4.4 */
char * message; /* error/warning message */
IOENC encoding; /* character encoding used */
struct io_stream * tee; /* copy data to this stream */
mbstate_t * mbstate; /* ENC_ANSI decoding */
struct io_stream * upstream; /* stream providing our input */
struct io_stream * downstream; /* stream providing our output */
unsigned newline : 2; /* Newline mode */
intptr_t reserved[3]; /* reserved for extension */
} IOSTREAM;
#endif /*_PL_STREAM_H*/

2
include/YapInterface.h
View File

@ -413,7 +413,7 @@ extern X_API int PROTO(YAP_AtomGetHold,(YAP_Atom));
extern X_API int PROTO(YAP_AtomReleaseHold,(YAP_Atom));
/* void YAP_AtomReleaseHold(YAP_Atom) */
extern X_API void PROTO(YAP_AGCRegisterHook,(YAP_agc_hook));
extern X_API YAP_agc_hook PROTO(YAP_AGCRegisterHook,(YAP_agc_hook));
/* thread stuff */
extern X_API int PROTO(YAP_ThreadSelf,(void));

1
library/Makefile.in
View File

@ -25,6 +25,7 @@ srcdir=@srcdir@
YAP_EXTRAS=@YAP_EXTRAS@
PROGRAMS= $(srcdir)/apply_macros.yap \
$(srcdir)/arg.yap \
$(srcdir)/assoc.yap \
$(srcdir)/atts.yap \
$(srcdir)/avl.yap \

34
library/hacks.yap
View File

@ -4,44 +4,54 @@
% Purpose: Prolog hacking
:- module(yap_hacks, [
current_choicepoint/1,
cut_by/1,
cut_at/1,
current_choicepoints/1,
choicepoint/7,
current_continuations/1,
continuation/4,
stack_dump/0
stack_dump/0,
stack_dump/1
]).
stack_dump :-
stack_dump(-1).
stack_dump(Max) :-
current_choicepoints(CPs),
current_continuations([Env|Envs]),
continuation(Env,_,ContP,_),
length(CPs, LCPs),
length(Envs, LEnvs),
format(user_error,'~n~n~tStack Dump~t~40+~n~nAddress~tChoiceP~16+ Cur/Next Clause Goal~n',[LCPs,LEnvs]),
display_stack_info(CPs,Envs,ContP).
display_stack_info(CPs,Envs,Max,ContP).
display_stack_info([],[],_).
display_stack_info([CP|CPs],[],_) :-
display_stack_info(_,_,0,_) :- !.
display_stack_info([],[],_,_).
display_stack_info([CP|CPs],[],I,_) :-
show_lone_cp(CP),
display_stack_info(CPs,[],_).
display_stack_info([],[Env|Envs],Cont) :-
I1 is I-1,
display_stack_info(CPs,[],I1,_).
display_stack_info([],[Env|Envs],I,Cont) :-
show_env(Env, Cont, NCont),
display_stack_info([], Envs, NCont).
display_stack_info([CP|LCPs],[Env|LEnvs],Cont) :-
continuation(Env, _, NCont, CB),
I1 is I-1,
display_stack_info([], Envs, I1, NCont).
display_stack_info([CP|LCPs],[Env|LEnvs],I,Cont) :-
continuation(Env, _, NCont, CB),
I1 is I-1,
( CP == Env, CB < CP ->
% if we follow choice-point and we cut to before choice-point
% we are the same goal
show_cp(CP, 'Cur'), %
display_stack_info(LCPs, LEnvs, NCont)
display_stack_info(LCPs, LEnvs, I1, NCont)
;
CP > Env ->
show_cp(CP, 'Next'),
display_stack_info(LCPs,[Env|LEnvs],Cont)
display_stack_info(LCPs,[Env|LEnvs],I1,Cont)
;
show_env(Env,Cont,NCont),
display_stack_info([CP|LCPs],LEnvs,NCont)
display_stack_info([CP|LCPs],LEnvs,I1,NCont)
).
show_cp(CP, Continuation) :-

74
library/lists.yap
View File

@ -3,33 +3,36 @@
%
% This file includes code from Bob Welham, Lawrence Byrd, and R. A. O'Keefe.
%
:- module(lists,[append/3,
delete/3,
is_list/1,
last/2,
member/2,
memberchk/2,
nextto/3,
nth/3,
nth/4,
nth0/3,
nth0/4,
permutation/2,
prefix/2,
remove_duplicates/2,
reverse/2,
same_length/2,
select/3,
sublist/2,
substitute/4,
sum_list/2,
suffix/2,
sumlist/2,
list_concat/2,
flatten/2,
max_list/2,
min_list/2
]).
:- module(lists,
[
append/3,
append/2,
delete/3,
is_list/1,
last/2,
member/2,
memberchk/2,
nextto/3,
nth/3,
nth/4,
nth0/3,
nth0/4,
permutation/2,
prefix/2,
remove_duplicates/2,
reverse/2,
same_length/2,
select/3,
sublist/2,
substitute/4,
sum_list/2,
suffix/2,
sumlist/2,
list_concat/2,
flatten/2,
max_list/2,
min_list/2
]).
% append(Prefix, Suffix, Combined)
@ -44,6 +47,23 @@ append([H|T], L, [H|R]) :-
append(T, L, R).
%% append(+ListOfLists, ?List)
%
% Concatenate a list of lists. Is true if Lists is a list of
% lists, and List is the concatenation of these lists.
%
% @param ListOfLists must be a list of -possibly- partial lists
append(ListOfLists, List) :-
% must_be(list, ListOfLists),
append_(ListOfLists, List).
append_([], []).
append_([L|Ls], As) :-
append(L, Ws, As),
append_(Ls, Ws).
% delete(List, Elem, Residue)
% is true when List is a list, in which Elem may or may not occur, and
% Residue is a copy of List with all elements identical to Elem deleted.

63
library/yap2swi/yap2swi.c
View File

@ -14,7 +14,7 @@
#include <string.h>
#include <stdio.h>
#include <yap2swi.h>
#include <SWI-Prolog.h>
#define BUF_SIZE 256
#define TMP_BUF_SIZE 2*BUF_SIZE
@ -35,11 +35,10 @@ alloc_ring_buf(void)
/* SWI: void PL_agc_hook(void) */
/* dummy function for now (until Vitor comes through!)*/
X_API PL_agc_hook_t
PL_agc_hook(PL_agc_hook_t entry)
{
YAP_AGCRegisterHook((YAP_agc_hook)entry);
return (PL_agc_hook_t)YAP_AGCRegisterHook((YAP_agc_hook)entry);
}
/* SWI: char* PL_atom_chars(atom_t atom)
@ -338,6 +337,27 @@ X_API int PL_get_integer(term_t ts, int *i)
return 1;
}
/* SWI: int PL_get_bool(term_t t, int *i)
YAP: long int YAP_AtomOfTerm(Term) */
X_API int PL_get_bool(term_t ts, int *i)
{
YAP_Term t = YAP_GetFromSlot(ts);
char *sp;
if (!YAP_IsAtomTerm(t) )
return 0;
sp = (char *)YAP_AtomName(YAP_AtomOfTerm(t));
if (!strcmp(sp,"true")) {
*sp = TRUE;
return 1;
}
if (!strcmp(sp,"false")) {
*sp = FALSE;
return 1;
}
return 0;
}
X_API int PL_get_long(term_t ts, long *i)
{
YAP_Term t = YAP_GetFromSlot(ts);
@ -1335,13 +1355,33 @@ X_API int PL_call(term_t tp, module_t m)
X_API void PL_register_extensions(PL_extension *ptr)
{
/* ignore flags for now */
while(ptr->predicate_name != NULL) {
YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_CurrentModule());
if (ptr->flags & (PL_FA_NOTRACE|PL_FA_NONDETERMINISTIC|PL_FA_VARARGS|PL_FA_CREF)) {
YAP_Error(0,YAP_MkIntTerm(ptr->flags),"non-implemented flag %x when creating predicates", ptr->flags);
return;
}
if (ptr->flags & PL_FA_TRANSPARENT)
YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_MkAtomTerm(YAP_LookupAtom("prolog")));
else
YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_CurrentModule());
ptr++;
}
}
X_API void PL_register_foreign_in_module(const char *module, const char *name, int arity, foreign_t (*function)(void), int flags)
{
if (flags & (PL_FA_NOTRACE|PL_FA_NONDETERMINISTIC|PL_FA_VARARGS|PL_FA_CREF)) {
YAP_Error(0,YAP_MkIntTerm(flags),"non-implemented flag %x when creating predicates", flags);
return;
}
if (flags & PL_FA_TRANSPARENT)
YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_MkAtomTerm(YAP_LookupAtom("prolog")));
else if (module == NULL)
YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_CurrentModule());
else
YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_MkAtomTerm(YAP_LookupAtom(module)));
}
X_API void PL_load_extensions(PL_extension *ptr)
{
/* ignore flags for now */
@ -1447,6 +1487,19 @@ PL_set_engine(PL_engine_t engine, PL_engine_t *old)
}
X_API void *
PL_malloc(int sz)
{
return YAP_AllocSpaceFromYap(sz);
}
X_API void
PL_free(void *obj)
{
return YAP_FreeSpaceFromYap(obj);
}
/* note: fprintf may be called from anywhere, so please don't try
to be smart and allocate stack from somewhere else */
X_API int Sprintf(char *format,...)

8
library/yap2swi/yap2swi.h
View File

@ -10,11 +10,19 @@
*/
#ifndef _FLI_H_INCLUDED
#define _FLI_H_INCLUDED
#ifndef __SWI_PROLOG__ /* use this to switch on Prolog dialect */
#define __SWI_PROLOG__ /* normally defined by the plld compiler driver */
#endif
//=== includes ===============================================================
#include "config.h"
#include <YapInterface.h>
#include <stdarg.h>
#include <wchar.h>
#if HAVE_TIME_H
#include <time.h>
#endif

46
pl/arith.yap
View File

@ -30,41 +30,51 @@ compile_expressions :- set_value('$c_arith',true).
do_not_compile_expressions :- set_value('$c_arith',[]).
'$c_built_in'(IN, M, OUT) :-
'$c_built_in'(IN, M, OUT, MT) :-
get_value('$c_arith',true), !,
'$do_c_built_in'(IN, M, OUT).
'$c_built_in'(IN, _, IN).
'$do_c_built_in'(IN, M, OUT, MT).
'$c_built_in'(IN, _, IN, _).
'$do_c_built_in'(G, M, OUT) :- var(G), !,
'$do_c_built_in'(call(M:G),M,OUT).
'$do_c_built_in'(Mod:G, _, GN) :- !,
'$do_c_built_in'(G, Mod, GN0),
'$do_c_built_in'(G, M, OUT, MT) :- var(G), !,
(MT = on -> NG = G ; NG = M:G),
'$do_c_built_in'(call(NG),M,OUT).
'$do_c_built_in'(Mod:G, _, GN, MT) :- !,
'$do_c_built_in'(G, Mod, GN0, MT),
(GN0 = (_,_) -> GN = GN0 ; GN = Mod:GN0).
'$do_c_built_in'(\+ G, _, OUT) :-
'$do_c_built_in'(\+ G, _, OUT, _) :-
nonvar(G),
G = (A = B),
!,
OUT = (A \= B).
'$do_c_built_in'(call(G), _, OUT) :-
'$do_c_built_in'(call(G), _, OUT, _) :-
nonvar(G),
G = (Mod:G1), !,
'$do_c_built_metacall'(G1, Mod, OUT).
'$do_c_built_in'(call(G), M, OUT) :-
'$do_c_built_in'(call(G), M, OUT, off) :-
var(G), !,
'$do_c_built_metacall'(G, M, OUT).
'$do_c_built_in'(depth_bound_call(G,D), M, OUT) :- !,
'$do_c_built_in'(G, M, NG),
'$do_c_built_in'(depth_bound_call(G,D), M, OUT, MT) :- !,
'$do_c_built_in'(G, M, NG, MT),
% make sure we don't have something like (A,B) -> $depth_next(D), A, B.
( '$composed_built_in'(NG) ->
OUT = depth_bound_call(NG,D)
;
OUT = ('$set_depth_limit_for_next_call'(D),NG)
).
'$do_c_built_in'(once(G), M, (yap_hacks:current_choice_point(CP),NG,'$$cut_by'(CP))) :- !,
'$do_c_built_in'(G,M,NG).
'$do_c_built_in'('C'(A,B.C), _, (A=[B|C])) :- !.
'$do_c_built_in'(X is Y, _, P) :-
'$do_c_built_in'(once(G), M, (yap_hacks:current_choice_point(CP),NG,'$$cut_by'(CP)), MT) :- !,
'$do_c_built_in'(G,M,NG0, MT),
'$clean_cuts'(NG0, NG).
'$do_c_built_in'(if(G,A,B), M, (yap_hacks:current_choicepoint(DCP),NG,yap_hacks:cut_at(DCP),NA; NB), MT) :- !,
'$do_c_built_in'(A,M,NA0, MT),
'$clean_cuts'(NA0, NA),
'$do_c_built_in'(B,M,NB, MT).
'$do_c_built_in'((G*->A), M, (NG,NA), MT) :- !,
'$do_c_built_in'(G,M,NG0, MT),
'$clean_cuts'(NG0, NG),
'$do_c_built_in'(A,M,NA, MT).
'$do_c_built_in'('C'(A,B.C), _, (A=[B|C]), _) :- !.
'$do_c_built_in'(X is Y, _, P, _) :-
nonvar(Y), % Don't rewrite variables
!,
(
@ -74,7 +84,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$drop_is'(X0, X, P1),
'$do_and'(P0, P1, P)
).
'$do_c_built_in'(Comp0, _, R) :- % now, do it for comparisons
'$do_c_built_in'(Comp0, _, R), _ :- % now, do it for comparisons
'$compop'(Comp0, Op, E, F),
!,
'$compop'(Comp, Op, U, V),
@ -82,7 +92,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$expand_expr'(F, Q, V),
'$do_and'(P, Q, R0),
'$do_and'(R0, Comp, R).
'$do_c_built_in'(P, _, P).
'$do_c_built_in'(P, _, P, _).
'$do_c_built_metacall'(G1, Mod, '$execute_wo_mod'(G1,Mod)) :-
var(Mod), !.

59
pl/boot.yap
View File

@ -691,6 +691,26 @@ incore(G) :- '$execute'(G).
'$current_module'(M),
'$call'(X,CP,(X,Y),M),
'$call'(Y,CP,(X,Y),M).
';'((X->A),Y) :- !,
yap_hacks:env_choice_point(CP),
'$current_module'(M),
( '$execute'(X)
->
'$call'(A,CP,(X->A;Y),M)
;
'$call'(Y,CP,(X->A;Y),M)
).
';'((X*->A),Y) :- !,
yap_hacks:env_choice_point(CP),
'$current_module'(M),
(
yap_hacks:current_choicepoint(DCP),
'$execute'(X),
yap_hacks:cut_at(DCP),
'$call'(A,CP,((X*->A),Y),M)
;
'$call'(Y,CP,((X*->A),Y),M)
).
';'(X,Y) :-
yap_hacks:env_choice_point(CP),
'$current_module'(M),
@ -703,6 +723,10 @@ incore(G) :- '$execute'(G).
yap_hacks:env_choice_point(CP),
'$current_module'(M),
( '$call'(X,CP,(X->Y),M) -> '$call'(Y,CP,(X->Y),M) ).
'*->'(X,Y) :-
yap_hacks:env_choice_point(CP),
'$current_module'(M),
( '$call'(X,CP,(X*->Y),M), '$call'(Y,CP,(X*->Y),M) ).
\+(G) :- \+ '$execute'(G).
not(G) :- \+ '$execute'(G).
@ -733,18 +757,30 @@ not(G) :- \+ '$execute'(G).
'$call'(Y,CP,G0,M).
'$call'((X->Y),CP,G0,M) :- !,
(
'$call'(X,CP,G0,M)
'$execute'(X)
->
'$call'(Y,CP,G0,M)
'$call'(Y,CP,G0,M)
).
'$call'((X*->Y),CP,G0,M) :- !,
'$execute'(X),
'$call'(Y,CP,G0,M).
'$call'((X->Y; Z),CP,G0,M) :- !,
(
'$call'(X,CP,G0,M)
'$execute'(X)
->
'$call'(Y,CP,G0,M)
;
'$call'(Z,CP,G0,M)
).
'$call'((X*->Y; Z),CP,G0,M) :- !,
(
yap_hacks:current_choicepoint(DCP),
'$execute'(X),
yap_hacks:cut_at(DCP),
'$call'(Y,CP,G0,M)
;
'$call'(Z,CP,G0,M)
).
'$call'((A;B),CP,G0,M) :- !,
(
'$call'(A,CP,G0,M)
@ -753,12 +789,21 @@ not(G) :- \+ '$execute'(G).
).
'$call'((X->Y| Z),CP,G0,M) :- !,
(
'$call'(X,CP,G0,M)
'$execute'(X)
->
'$call'(Y,CP,G0,M)
;
'$call'(Z,CP,G0,M)
).
'$call'((X*->Y| Z),CP,G0,M) :- !,
(
yap_hacks:current_choicepoint(DCP),
'$execute'(X),
yap_hacks:cut_at(DCP),
'$call'(Y,CP,G0,M)
;
'$call'(Z,CP,G0,M)
).
'$call'((A|B),CP, G0,M) :- !,
(
'$call'(A,CP,G0,M)
@ -812,9 +857,11 @@ not(G) :- \+ '$execute'(G).
% for undefined_predicates.
(
recorded('$import','$import'(NM,M,Goal,G,_,_),_)
->
true
;
'$enter_undefp',
once('$find_undefp_handler'(G,M,Goal,NM))
'$enter_undefp',
once('$find_undefp_handler'(G,M,Goal,NM))
),
!,
'$execute0'(Goal,NM).

3
pl/consult.yap
View File

@ -383,8 +383,7 @@ prolog_load_context(file, FileName) :-
( IncFileName = [] ->
nb_getval('$consulting_file',FileName)
;
FileName
= IncFileName
FileName = IncFileName
).
prolog_load_context(module, X) :-
'$current_module'(X).

12
pl/debug.yap
View File

@ -466,12 +466,16 @@ debugging :-
( '$do_spy'(Cl, M, CP, InControl) ; InRedo = true ).
'$spycall'(G, M, InControl, InRedo) :-
'$undefined'(G, M), !,
'$enter_undefp',
(
'$find_undefp_handler'(G,M,Goal,NM)
recorded('$import','$import'(NM,M,Goal,G,_,_),_)
->
'$spycall'(Goal, NM, InControl, InRedo)
).
'$spycall'(Goal, NM, InControl, InRedo)
;
'$enter_undefp',
'$find_undefp_handler'(G,M,Goal,NM)
->
'$spycall'(Goal, NM, InControl, InRedo)
).
'$spycall'(G, M, InControl, InRedo) :-
% I lost control here.
CP is '$last_choice_pt',

41
pl/directives.yap
View File

@ -30,8 +30,10 @@
'$directive'(module(_,_)).
'$directive'(module(_,_,_)).
'$directive'(meta_predicate(_)).
'$directive'(module_transparent(_)).
'$directive'(public(_)).
'$directive'(dynamic(_)).
'$directive'(noprofile(_)).
'$directive'(op(_,_,_)).
'$directive'(set_prolog_flag(_,_)).
'$directive'(ensure_loaded(_)).
@ -89,6 +91,10 @@
'$module'(Status,N,P,Op).
'$exec_directive'(meta_predicate(P), _, M) :-
'$meta_predicate'(P, M).
'$exec_directive'(module_transparent(P), _, M) :-
'$module_transparent'(P, M).
'$exec_directive'(noprofile(P), _, M) :-
'$noprofile'(P, M).
'$exec_directive'(dynamic(P), _, M) :-
'$dynamic'(P, M).
'$exec_directive'(thread_local(P), _, M) :-
@ -137,6 +143,15 @@
'$endif'(Context).
yap_flag(V,Out) :-
'$user_defined_flag'(V,_),
(nonvar(V) ->
!
;
true
),
'$user_flag_value'(V, Out).
yap_flag(V,Out) :-
var(V), !,
'$show_yap_flag_opts'(V,Out).
@ -943,3 +958,29 @@ user_defined_directive(Dir,Action) :-
assert_static(('$exec_directive'(Dir, _, _) :- Action)),
'$current_module'(_, M).
%
% allow users to define their own flags.
%
user_defined_flag(Atom) :- var(Atom), !,
'$do_error'(instantiation_error,user_defined_flag(Atom)).
user_defined_flag(Atom) :-
'$user_defined_flag'(Atom,_), !.
user_defined_flag(Atom) :-
yap_flag(Atom, _), !,
'$do_error'(domain_error(user_defined_prolog_flag,Atom),user_defined_flag(Atom)).
user_defined_flag(Atom) :-
assert(prolog:'$user_defined_flag'(Atom,[])).
'$enumerate_user_flag'(V, Out) :-
'$user_defined_flag'(V, Out).
'$user_flag_value'(F, Val) :-
var(Val), !,
'$user_defined_flag'(F,Val).
'$user_flag_value'(F, Val) :-
atomic(Val), !,
retractall(prolog:'$user_defined_flag'(F,_)),
assert(prolog:'$user_defined_flag'(Atom,Val)).
'$user_flag_value'(F, Val) :-
'$do_error'(type_error(atomic,Val),yap_flag(F,Val)).

3
pl/init.yap
View File

@ -74,6 +74,9 @@ otherwise.
'chtypes.yap',
'yapor.yap'].
:- dynamic prolog:'$user_defined_flag'/2.
:- ['protect.yap'].
version(yap,[5,1]).

162
pl/modules.yap
View File

@ -182,34 +182,37 @@ module(N) :-
% expand module names in a clause
'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !,
'$prepare_body_with_correct_modules'(B, M, B0),
'$is_mt'(Mod,H,MT),
'$prepare_body_with_correct_modules'(B, M, MT, B0),
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$module_expansion'(B0,B1,BO,M,M,M,UVars). % expand body
'$module_expansion'(B0,B1,BO,M,M,M,UVars,MT). % expand body
'$module_expansion'((H:-B),(H:-B1),(H:-BO),M) :-
'$is_mt'(Mod,H,MT),
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$module_expansion'(B,B1,BO,M,M,M,UVars). % expand body
'$module_expansion'(B,B1,BO,M,M,M,UVars,MT). % expand body
% $trace_module((H:-B),(H:-B1)).
% expand module names in a body
'$prepare_body_with_correct_modules'(V,M,call(M:V)) :- var(V), !.
'$prepare_body_with_correct_modules'((A,B),M,(A1,B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'((A;B),M,(A1;B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'((A->B),M,(A1->B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'(true,_,true) :- !.
'$prepare_body_with_correct_modules'(fail,_,fail) :- !.
'$prepare_body_with_correct_modules'(false,_,false) :- !.
'$prepare_body_with_correct_modules'(V,M,MT,call(G)) :- var(V), !,
(MT = on -> G = M:V ; G = V).
'$prepare_body_with_correct_modules'((A,B),M,MT,(A1,B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'((A;B),M,MT,(A1;B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'((A->B),M,MT,(A1->B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'(true,_,_,true) :- !.
'$prepare_body_with_correct_modules'(fail,_,_,fail) :- !.
'$prepare_body_with_correct_modules'(false,_,_,false) :- !.
'$prepare_body_with_correct_modules'(M:G,_,M:G) :- !.
'$prepare_body_with_correct_modules'(G,M,G) :-
'$prepare_body_with_correct_modules'(G,M,MT,G) :-
'$system_predicate'(G,M), !.
'$prepare_body_with_correct_modules'(G,M,M:G).
'$prepare_body_with_correct_modules'(G,M,MT,M:G).
'$trace_module'(X) :-
@ -239,31 +242,38 @@ module(N) :-
% current module for fixing up meta-call arguments
% current module for predicate
% head variables.
'$module_expansion'(V,call(MM:V),call(MM:V),_M,MM,_TM,_) :- var(V), !.
'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A;B),(A1;B1),(AO;BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A|B),(A1|B1),(AO|BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A->B),(A1->B1),(AO->BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'(\+A,\+A1,\+AO,M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars).
'$module_expansion'(not(A),not(A1),not(AO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars).
'$module_expansion'(V,call(G),call(G),_M,MM,_TM,_,MT) :- var(V), !,
(MT = on -> G = MM:V ; G = V).
'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A*->B;C),(A1*->B1;C1),(yap_hacks:current_choicepoint(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars,MT),
'$clean_cuts'(AOO, AO),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT),
'$module_expansion'(C,C1,CO,M,MM,TM,HVars,MT).
'$module_expansion'((A;B),(A1;B1),(AO;BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A|B),(A1|B1),(AO|BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A->B),(A1->B1),(AO->BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars,MT),
'$clean_cuts'(AOO, AO),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'(\+A,\+A1,\+AO,M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT).
'$module_expansion'(not(A),not(A1),not(AO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT).
'$module_expansion'(true,true,true,_,_,_,_) :- !.
'$module_expansion'(fail,fail,fail,_,_,_,_) :- !.
'$module_expansion'(false,false,false,_,_,_,_) :- !.
% if I don't know what the module is, I cannot do anything to the goal,
% so I just put a call for later on.
'$module_expansion'(M:G,call(M:G),'$execute_wo_mod'(G,M),_,_,_,_) :- var(M), !.
'$module_expansion'(M:G,G1,GO,_,_,TM,HVars) :-
'$module_expansion'(G,G1,GO,M,M,TM,HVars).
'$module_expansion'(M:G,call(M:G),'$execute_wo_mod'(G,M),_,_,_,_,_) :- var(M), !.
'$module_expansion'(M:G,G1,GO,_,_,TM,HVars,MT) :-
'$module_expansion'(G,G1,GO,M,M,TM,HVars,MT).
% if M1 is given explicitly process G within M1's context.
% '$module_expansion'(M:G,G1,GO,_Mod,_MM,TM,HVars) :- !,
% % is this imported from some other module M1?
@ -281,16 +291,19 @@ module(N) :-
%
% next, check if this is something imported.
%
'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars) :-
'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars,MT) :-
% is this imported from some other module M1?
( '$imported_pred'(G, CurMod, GG, M1) ->
'$module_expansion'(GG, G1, GO, M1, MM, TM, HVars)
'$module_expansion'(GG, G1, GO, M1, MM, TM, HVars,MT)
;
( '$meta_expansion'(CurMod, MM, G, GI, HVars)
;
GI = G
(
% only expand meta-predicates if we are not module transparent!
MT = off,
'$meta_expansion'(CurMod, MM, G, GI, HVars)
;
GI = G
),
'$complete_goal_expansion'(GI, CurMod, MM, TM, G1, GO, HVars)
'$complete_goal_expansion'(GI, CurMod, MM, TM, G1, GO, HVars, MT)
).
@ -306,15 +319,15 @@ module(N) :-
% goal to pass to compiler
% goal to pass to listing
% head variables.
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :-
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars, MT) :-
'$pred_goal_expansion_on',
user:goal_expansion(G,M,GI), !,
'$module_expansion'(GI,G1,G2,M,CM,TM,HVars).
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :-
'$module_expansion'(GI, G1, G2, M, CM, TM, HVars, MT).
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars, MT) :-
'$all_system_predicate'(G,M), !,
'$c_built_in'(G,M,Gi),
'$c_built_in'(G, M, Gi, MT),
(Gi \== G ->
'$module_expansion'(Gi,_,G2,M,CM,TM,HVars),
'$module_expansion'(Gi, _, G2, M, CM, TM, HVars, MT),
% make built-in processing transparent.
(TM = M -> G1 = G ; G1 = M:G)
; TM = M ->
@ -322,8 +335,28 @@ module(N) :-
;
G2 = M:G, G1 = M:G % atts:
).
'$complete_goal_expansion'(G, Mod, _, Mod, G, G, _) :- !.
'$complete_goal_expansion'(G, GMod, _, _, GMod:G, GMod:G, _).
'$complete_goal_expansion'(G, Mod, _, Mod, G, G, _, _) :- !.
'$complete_goal_expansion'(G, GMod, _, _, GMod:G, GMod:G, _, _).
% module_transparent declaration
%
:- dynamic('$module_transparent'/4).
'$module_transparent'((P,Ps), M) :- !,
'$module_transparent'(P, M),
'$module_transparent'(Ps, M).
'$module_transparent'(M:D, _) :- !,
'$module_transparent'(D, M).
'$module_transparent'(F/N, M) :-
functor(P,F,N),
( retractall('$module_transparent'(F,M,N,_)), fail ; true),
asserta(prolog:'$module_transparent'(F,M,N,P)).
'$is_mt'(Mod,H,on) :-
'$module_transparent'(_,M,_,H), !.
'$is_mt'(_,_,off).
% meta_predicate declaration
% records $meta_predicate(SourceModule,Functor,Arity,Declaration)
@ -629,3 +662,30 @@ abolish_module(_).
G1=..[N1|Args],
recordaifnot('$import','$import'(ModR,Mod,G,G1,N0,K0),_),
'$add_to_imports'(Tab, Mod, ModR).
% I assume the clause has been processed, so the
% var case is long gone! Yes :)
'$clean_cuts'(G,(yap_hacks:current_choicepoint(DCP),NG)) :-
'$conj_has_cuts'(G,DCP,NG,OK), OK == ok, !.
'$clean_cuts'(G,G).
'$conj_has_cuts'(!,DCP,'$$cut_by'(DCP), ok) :- !.
'$conj_has_cuts'((G1,G2),DCP,(NG1,NG2), OK) :- !,
'$conj_has_cuts'(G1, DCP, NG1, OK),
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1;G2),DCP,(NG1;NG2), OK) :- !,
'$conj_has_cuts'(G1, DCP, NG1, OK),
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1->G2),DCP,(G1;NG2), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1*->G2),DCP,(G1;NG2), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'(if(G1,G2,G3),DCP,if(G1,NG2,NG3), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK),
'$conj_has_cuts'(G3, DCP, NG3, OK).
'$conj_has_cuts'(G,_,G, _).

3
pl/preds.yap
View File

@ -972,4 +972,5 @@ current_key(A,K) :-
current_key(A,K) :-
'$current_immediate_key'(A,K).
% do nothing for now.
'$noprofile'(_, _).

2
pl/statistics.yap
View File

@ -150,7 +150,7 @@ time(Goal) :-
),
TimeSecs is Time/1000,
WallSecs is Wall/1000,
format("% ~3f CPU in ~3f seconds (~|~t~w~3+% CPU)~n", [TimeSecs, WallSecs, CPU]),
format(user_error,'% ~3f CPU in ~3f seconds (~|~t~w~3+% CPU)~n', [TimeSecs, WallSecs, CPU]),
( nonvar(E)
-> throw(E)
; Result == yes

18
pl/utils.yap
View File

@ -17,13 +17,17 @@
once(G) :- '$execute'(G), !.
if(X,Y,_Z) :-
CP is '$last_choice_pt',
'$execute'(X),
'$clean_ifcp'(CP),
'$execute'(Y).
if(_X,_Y,Z) :-
'$execute'(Z).
if(X,Y,Z) :-
yap_hacks:env_choice_point(CP0),
(
CP is '$last_choice_pt',
'$call'(X,CP,if(X,Y,Z),M),
'$execute'(X),
'$clean_ifcp'(CP),
'$call'(Y,CP,if(X,Y,Z),M)
;
'$call'(Z,CP,if(X,Y,Z),M)
).
call(X,A) :- '$execute'(X,A).

10
pl/yio.yap
View File

@ -1059,3 +1059,13 @@ current_stream(File, Opts, Stream) :-
write_depth(T,L) :- write_depth(T,L,_).
is_stream(S) :-
'$check_stream'(S).
time_file(File, Time) :-
'$file_age'(File, Time).
stream_position_data(line_count, '$stream_position'(_,Data,_,_,_), Data).
stream_position_data(line_position, '$stream_position'(_,_,Data,_,_), Data).
%stream_position_data(char_count, '$stream_position'(Data,_,_,_,_), Data).
stream_position_data(byte_count, '$stream_position'(Data,_,_,_,_), Data).