fix mess with add clause
improves on sigsegv handling git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1239 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
3fce73a11f
commit
52a46e5c5d
18
C/cdmgr.c
18
C/cdmgr.c
@ -11,8 +11,12 @@
|
||||
* File: cdmgr.c *
|
||||
* comments: Code manager *
|
||||
* *
|
||||
* Last rev: $Date: 2005-01-28 23:14:34 $,$Author: vsc $ *
|
||||
* Last rev: $Date: 2005-02-08 04:05:23 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.150 2005/01/28 23:14:34 vsc
|
||||
* move to Yap-4.5.7
|
||||
* Fix clause size
|
||||
*
|
||||
* Revision 1.149 2005/01/05 05:35:01 vsc
|
||||
* get rid of debugging stub.
|
||||
*
|
||||
@ -2058,12 +2062,16 @@ p_compile_dynamic(void)
|
||||
Term t1 = Deref(ARG2);
|
||||
Term mod = Deref(ARG4);
|
||||
yamop *code_adr;
|
||||
int old_optimize;
|
||||
int old_optimize, mode;
|
||||
|
||||
if (IsVarTerm(t1) || !IsAtomTerm(t1))
|
||||
if (IsVarTerm(t1) || !IsAtomicTerm(t1))
|
||||
return FALSE;
|
||||
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
||||
return FALSE;
|
||||
if (IsAtomTerm(t1)) {
|
||||
if (RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f') mode = asserta;
|
||||
else mode = assertz;
|
||||
} else mode = IntegerOfTerm(t1);
|
||||
old_optimize = optimizer_on;
|
||||
optimizer_on = FALSE;
|
||||
YAPEnterCriticalSection();
|
||||
@ -2074,7 +2082,7 @@ p_compile_dynamic(void)
|
||||
|
||||
|
||||
optimizer_on = old_optimize;
|
||||
addclause(t, code_adr, RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f', mod, &ARG5);
|
||||
addclause(t, code_adr, mode , mod, &ARG5);
|
||||
}
|
||||
if (Yap_ErrorMessage) {
|
||||
if (!Yap_Error_Term)
|
||||
@ -2425,7 +2433,7 @@ p_new_multifile(void)
|
||||
if (IsIntTerm(t))
|
||||
arity = IntOfTerm(t);
|
||||
else
|
||||
return (FALSE);
|
||||
return FALSE;
|
||||
if (arity == 0)
|
||||
pe = RepPredProp(PredPropByAtom(at, mod));
|
||||
else
|
||||
|
||||
@ -299,8 +299,12 @@ dump_stack(void)
|
||||
static void
|
||||
error_exit_yap (int value)
|
||||
{
|
||||
if (!Yap_PrologMode & BootMode)
|
||||
if (!Yap_PrologMode & BootMode) {
|
||||
#if DEBUG
|
||||
fprintf(stderr,"%d garbage collections\n", GcCalls);
|
||||
#endif
|
||||
dump_stack();
|
||||
}
|
||||
Yap_exit(value);
|
||||
}
|
||||
|
||||
|
||||
1
C/exec.c
1
C/exec.c
@ -230,6 +230,7 @@ EnterCreepMode(Term t, Term mod) {
|
||||
LOCK(SignalLock);
|
||||
CreepFlag = CalculateStackGap();
|
||||
UNLOCK(SignalLock);
|
||||
yap_flags[SPY_CREEP_FLAG] = TRUE;
|
||||
P_before_spy = P;
|
||||
return (CallPredicate(PredCreep, B, PredCreep->CodeOfPred));
|
||||
}
|
||||
|
||||
25
C/stdpreds.c
25
C/stdpreds.c
@ -11,8 +11,11 @@
|
||||
* File: stdpreds.c *
|
||||
* comments: General-purpose C implemented system predicates *
|
||||
* *
|
||||
* Last rev: $Date: 2005-01-05 05:32:37 $,$Author: vsc $ *
|
||||
* Last rev: $Date: 2005-02-08 04:05:35 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.80 2005/01/05 05:32:37 vsc
|
||||
* Ricardo's latest version of profiler.
|
||||
*
|
||||
* Revision 1.79 2004/12/28 22:20:36 vsc
|
||||
* some extra bug fixes for trail overflows: some cannot be recovered that easily,
|
||||
* some can.
|
||||
@ -655,6 +658,23 @@ p_creep(void)
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
static Int
|
||||
p_delayed_creep(void)
|
||||
{
|
||||
Atom at;
|
||||
PredEntry *pred;
|
||||
|
||||
at = Yap_FullLookupAtom("$creep");
|
||||
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
|
||||
CreepCode = pred;
|
||||
yap_flags[SPY_CREEP_FLAG] = FALSE;
|
||||
do_signal(YAP_CREEP_SIGNAL);
|
||||
LOCK(SignalLock);
|
||||
CreepFlag = CalculateStackGap();
|
||||
UNLOCK(SignalLock);
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
static Int
|
||||
p_stop_creep(void)
|
||||
{
|
||||
@ -2959,7 +2979,8 @@ Yap_InitCPreds(void)
|
||||
/* they are defined in analyst.c */
|
||||
/* Basic predicates for the debugger */
|
||||
Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
||||
Yap_InitCPred("$stop_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
||||
Yap_InitCPred("$late_creep", 0, p_delayed_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
||||
Yap_InitCPred("$do_not_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
||||
#ifdef DEBUG
|
||||
Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
||||
#endif
|
||||
|
||||
132
C/sysbits.c
132
C/sysbits.c
@ -879,7 +879,8 @@ HandleSIGSEGV(int sig, siginfo_t *sip, ucontext_t *uap)
|
||||
{
|
||||
|
||||
#if !USE_SYSTEM_MALLOC
|
||||
if (sip->si_code != SI_NOINFO &&
|
||||
if (
|
||||
sip->si_code != SI_NOINFO &&
|
||||
sip->si_code == SEGV_MAPERR &&
|
||||
(void *)(sip->si_addr) > (void *)(Yap_HeapBase) &&
|
||||
(void *)(sip->si_addr) < (void *)(Yap_TrailTop+64 * 1024L)) {
|
||||
@ -950,6 +951,135 @@ my_signal(int sig, void (*handler)(int, siginfo_t *, ucontext_t *))
|
||||
sigaction(sig,&sigact,NULL);
|
||||
}
|
||||
|
||||
#elif defined(__linux__)
|
||||
|
||||
STATIC_PROTO (RETSIGTYPE HandleMatherr, (int));
|
||||
STATIC_PROTO (RETSIGTYPE HandleSIGSEGV, (int,siginfo_t *,void *));
|
||||
STATIC_PROTO (void my_signal_info, (int, void (*)(int,siginfo_t *,void *)));
|
||||
STATIC_PROTO (void my_signal, (int, void (*)(int)));
|
||||
|
||||
/******** Handling floating point errors *******************/
|
||||
|
||||
|
||||
/* old code, used to work with matherror(), deprecated now:
|
||||
char err_msg[256];
|
||||
switch (x->type)
|
||||
{
|
||||
case DOMAIN:
|
||||
case SING:
|
||||
Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s", x->name);
|
||||
return(0);
|
||||
case OVERFLOW:
|
||||
Yap_Error(EVALUATION_ERROR_FLOAT_OVERFLOW, TermNil, "%s", x->name);
|
||||
return(0);
|
||||
case UNDERFLOW:
|
||||
Yap_Error(EVALUATION_ERROR_FLOAT_UNDERFLOW, TermNil, "%s", x->name);
|
||||
return(0);
|
||||
case PLOSS:
|
||||
case TLOSS:
|
||||
Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s(%g) = %g", x->name,
|
||||
x->arg1, x->retval);
|
||||
return(0);
|
||||
default:
|
||||
Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, NULL);
|
||||
return(0);
|
||||
}
|
||||
*/
|
||||
|
||||
|
||||
#if HAVE_FENV_H
|
||||
#include <fenv.h>
|
||||
#endif
|
||||
|
||||
static RETSIGTYPE
|
||||
HandleMatherr(int sig)
|
||||
{
|
||||
#if HAVE_FETESTEXCEPT
|
||||
|
||||
/* This should work in Linux, but it doesn't seem to. */
|
||||
|
||||
int raised = fetestexcept(FE_ALL_EXCEPT);
|
||||
|
||||
if (raised & FE_OVERFLOW) {
|
||||
Yap_matherror = EVALUATION_ERROR_FLOAT_OVERFLOW;
|
||||
} else if (raised & (FE_INVALID|FE_INEXACT)) {
|
||||
Yap_matherror = EVALUATION_ERROR_UNDEFINED;
|
||||
} else if (raised & FE_DIVBYZERO) {
|
||||
Yap_matherror = EVALUATION_ERROR_ZERO_DIVISOR;
|
||||
} else if (raised & FE_UNDERFLOW) {
|
||||
Yap_matherror = EVALUATION_ERROR_FLOAT_UNDERFLOW;
|
||||
} else
|
||||
#endif
|
||||
Yap_matherror = EVALUATION_ERROR_UNDEFINED;
|
||||
/* something very bad happened on the way to the forum */
|
||||
set_fpu_exceptions(FALSE);
|
||||
Yap_Error(Yap_matherror, TermNil, "");
|
||||
}
|
||||
|
||||
static void
|
||||
SearchForTrailFault(siginfo_t *siginfo)
|
||||
{
|
||||
void *ptr = siginfo->si_addr;
|
||||
|
||||
fprintf(stderr,"error at %p\n",ptr);
|
||||
/* If the TRAIL is very close to the top of mmaped allocked space,
|
||||
then we can try increasing the TR space and restarting the
|
||||
instruction. In the worst case, the system will
|
||||
crash again
|
||||
*/
|
||||
#if OS_HANDLES_TR_OVERFLOW && !USE_SYSTEM_MALLOC
|
||||
if ((ptr > (void *)Yap_TrailTop-1024 &&
|
||||
TR < (void *)Yap_TrailTop+(64*1024))) {
|
||||
if (!Yap_growtrail(64*1024, TRUE)) {
|
||||
Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP failed to reserve %ld bytes in growtrail", 64*1024L);
|
||||
}
|
||||
/* just in case, make sure the OS keeps the signal handler. */
|
||||
/* my_signal_info(SIGSEGV, HandleSIGSEGV); */
|
||||
} else
|
||||
#endif /* OS_HANDLES_TR_OVERFLOW */
|
||||
{
|
||||
Yap_Error(FATAL_ERROR, TermNil,
|
||||
"likely bug in YAP, segmentation violation at %p", ptr);
|
||||
}
|
||||
}
|
||||
|
||||
static RETSIGTYPE
|
||||
HandleSIGSEGV(int sig, siginfo_t *siginfo, void *context)
|
||||
{
|
||||
if (Yap_PrologMode & ExtendStackMode) {
|
||||
Yap_Error(FATAL_ERROR, TermNil, "OS memory allocation crashed at address %p, bailing out\n",Yap_TrailTop);
|
||||
}
|
||||
SearchForTrailFault(siginfo);
|
||||
}
|
||||
|
||||
static void
|
||||
my_signal_info(int sig, void (*handler)(int,siginfo_t *,void *))
|
||||
{
|
||||
struct sigaction sigact;
|
||||
|
||||
sigact.sa_sigaction = handler;
|
||||
sigemptyset(&sigact.sa_mask);
|
||||
#if HAVE_SIGINFO
|
||||
sigact.sa_flags = SA_SIGINFO;
|
||||
#else
|
||||
sigact.sa_flags = 0;
|
||||
#endif
|
||||
|
||||
sigaction(sig,&sigact,NULL);
|
||||
}
|
||||
|
||||
static void
|
||||
my_signal(int sig, void (*handler)(int))
|
||||
{
|
||||
struct sigaction sigact;
|
||||
|
||||
sigact.sa_handler=handler;
|
||||
sigemptyset(&sigact.sa_mask);
|
||||
sigact.sa_flags = 0;
|
||||
|
||||
sigaction(sig,&sigact,NULL);
|
||||
}
|
||||
|
||||
#else /* if not (defined(__svr4__) || defined(__SVR4)) */
|
||||
|
||||
STATIC_PROTO (RETSIGTYPE HandleMatherr, (int));
|
||||
|
||||
@ -3,6 +3,8 @@
|
||||
%
|
||||
%
|
||||
|
||||
|
||||
|
||||
:- module(evidence, [
|
||||
store_evidence/1,
|
||||
incorporate_evidence/2
|
||||
@ -22,7 +24,7 @@
|
||||
|
||||
:- meta_predicate store_evidence(:).
|
||||
|
||||
:- dynamic node/4, reachable_from_evidence/2, evidence/2.
|
||||
:- dynamic node/4, edge/2, evidence/2.
|
||||
|
||||
%
|
||||
% new evidence storage algorithm. The idea is that instead of
|
||||
@ -39,8 +41,7 @@ store_evidence(G) :-
|
||||
|
||||
compute_evidence(G, PreviousSolver) :-
|
||||
catch(call_residue(G, Vars), Ball, evidence_error(Ball,PreviousSolver)), !,
|
||||
store_graph(Vars,KEv),
|
||||
mark_from_evidence(Vars,KEv),
|
||||
store_graph(Vars),
|
||||
set_clpbn_flag(solver,PreviousSolver).
|
||||
compute_evidence(_, PreviousSolver) :-
|
||||
set_clpbn_flag(solver,PreviousSolver).
|
||||
@ -50,22 +51,21 @@ evidence_error(Ball,PreviousSolver) :-
|
||||
set_clpbn_flag(solver,PreviousSolver),
|
||||
throw(Ball).
|
||||
|
||||
store_graph([], _).
|
||||
store_graph([_-node(K,Dom,CPT,TVs,Ev)|Vars], Kev) :-
|
||||
store_graph([]).
|
||||
store_graph([_-node(K,Dom,CPT,TVs,Ev)|Vars]) :-
|
||||
\+ node(K,_,_,_), !,
|
||||
assert(node(K,Dom,CPT,TVs)),
|
||||
( nonvar(Ev) -> assert(evidence(K,Ev)), Kev = K ; true),
|
||||
store_graph(Vars, Kev).
|
||||
store_graph([_|Vars], Kev) :-
|
||||
store_graph(Vars, Kev).
|
||||
( nonvar(Ev) -> assert(evidence(K,Ev)) ; true),
|
||||
add_links(TVs,K),
|
||||
store_graph(Vars).
|
||||
store_graph([_|Vars]) :-
|
||||
store_graph(Vars).
|
||||
|
||||
add_links([],_).
|
||||
add_links([K0|TVs],K) :-
|
||||
assert(edge(K,K0)),
|
||||
add_links(TVs,K).
|
||||
|
||||
mark_from_evidence([], _).
|
||||
mark_from_evidence([_-node(K,_,_,_,_)|Vars], Kev) :-
|
||||
\+ reachable_from_evidence(K,Kev), !,
|
||||
assert(reachable_from_evidence(K,Kev)),
|
||||
mark_from_evidence(Vars, Kev).
|
||||
mark_from_evidence([_|Vars], Kev) :-
|
||||
mark_from_evidence(Vars, Kev).
|
||||
|
||||
incorporate_evidence(Vs,AllVs) :-
|
||||
new(Cache0),
|
||||
@ -116,6 +116,5 @@ add_evidence(_, _).
|
||||
check_for_evidence(_, V, Vf, Vf, C, C) :-
|
||||
clpbn:get_atts(V, [evidence(_)]), !.
|
||||
check_for_evidence(K, _, Vf0, Vff, C0, Ci) :-
|
||||
findall(Rt,reachable_from_evidence(K,Rt),Rts),
|
||||
findall(Rt,edge(Rt,K),Rts),
|
||||
add_variables(Rts, _, Vf0, Vff, C0, Ci).
|
||||
|
||||
|
||||
@ -68,11 +68,11 @@ get_rid_of_ev_vars([V|LVs0],[V|LVs]) :-
|
||||
|
||||
|
||||
find_all_clpbn_vars([], [], [], []) :- !.
|
||||
find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Deps,Sizes)|Tables]) :-
|
||||
var_with_deps(V, Table, Deps, Sizes, Ev, Vals), !,
|
||||
find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Sizes)|Tables]) :-
|
||||
var_with_deps(V, Table, Parents, Sizes, Ev, Vals), !,
|
||||
% variables with evidence should not be processed.
|
||||
(var(Ev) ->
|
||||
Var = var(V,I,Sz,Vals,Ev,_,_),
|
||||
Var = var(V,I,Sz,Vals,Parents,Ev,_,_),
|
||||
get_dist_size(V,Sz),
|
||||
ProcessedVars = [Var|ProcessedVars0]
|
||||
;
|
||||
@ -81,9 +81,9 @@ find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Deps,Sizes)|
|
||||
find_all_clpbn_vars(Vs, LV, ProcessedVars0, Tables).
|
||||
|
||||
var_with_deps(V, Table, Deps, Sizes, Ev, Vals) :-
|
||||
clpbn:get_atts(V, [dist(Vals,OTable,VDeps)]),
|
||||
clpbn:get_atts(V, [dist(Vals,OTable,Parents)]),
|
||||
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true),
|
||||
reorder_table([V|VDeps],Sizes0,OTable,Deps0,Table0),
|
||||
reorder_table([V|Parents],Sizes0,OTable,Deps0,Table0),
|
||||
simplify_evidence(Deps0, Table0, Deps0, Sizes0, Table, Deps, Sizes).
|
||||
|
||||
get_sizes([], []).
|
||||
@ -146,7 +146,7 @@ add_table_deps([V|Deps], I, Deps0, Table, Sizes, DepGraph0, [V-tab(Table,Deps0,S
|
||||
add_table_deps(Deps, I, Deps0, Table, Sizes, DepGraph0, DepGraph).
|
||||
|
||||
add_table_deps_to_variables([], []).
|
||||
add_table_deps_to_variables([var(V,_,_,_,_,Deps,K)|LV], DepGraph) :-
|
||||
add_table_deps_to_variables([var(V,_,_,_,_,_,Deps,K)|LV], DepGraph) :-
|
||||
steal_deps_for_variable(DepGraph, V, NDepGraph, Deps),
|
||||
compute_size(Deps,[],K),
|
||||
% ( clpbn:get_atts(V,[key(Key)]) -> write(Key:K), nl ; true),
|
||||
@ -186,14 +186,16 @@ process(LV0, _, Out) :-
|
||||
find_best([], V, _TF, V, _, [], _).
|
||||
%:-
|
||||
% clpbn:get_atts(V,[key(K)]), write(chosen:K:TF), nl.
|
||||
find_best([var(V,I,Sz,Vals,Ev,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :-
|
||||
% root_with_single_child
|
||||
%find_best([var(V,I,_,_,[],Ev,[Dep],K)|LV], _, _, V, [Dep], LVF, Inputs) :- !.
|
||||
find_best([var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :-
|
||||
( K < Threshold ; Threshold < 0),
|
||||
clpbn_not_var_member(Inputs, V), !,
|
||||
find_best(LV, V, K, VF, WorkTables,LV0, Inputs),
|
||||
(V == VF ->
|
||||
LVF = LV0, Deps = NWorktables
|
||||
;
|
||||
LVF = [var(V,I,Sz,Vals,Ev,Deps,K)|LV0], WorkTables = NWorktables
|
||||
LVF = [var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV0], WorkTables = NWorktables
|
||||
).
|
||||
find_best([V|LV], V0, Threshold, VF, WorkTables, [V|LVF], Inputs) :-
|
||||
find_best(LV, V0, Threshold, VF, WorkTables, LVF, Inputs).
|
||||
@ -227,7 +229,7 @@ generate_szs_with_evidence([_|Out],Ev,[not_ok|Evs]) :-
|
||||
|
||||
|
||||
fetch_tables([], []).
|
||||
fetch_tables([var(_,_,_,_,_,Deps,_)|LV0], Tables) :-
|
||||
fetch_tables([var(_,_,_,_,_,_,Deps,_)|LV0], Tables) :-
|
||||
append(Deps,Tables0,Tables),
|
||||
fetch_tables(LV0, Tables0).
|
||||
|
||||
@ -326,10 +328,10 @@ project_inner_loop(I,Sz,[_|Evs],NBase,F,Table,Ent0,Ent) :- !,
|
||||
|
||||
|
||||
include([],_,_,[]).
|
||||
include([var(V,P,VSz,D,Ev,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Ev,Tabs,Est)|NLV]) :-
|
||||
include([var(V,P,VSz,D,Parents,Ev,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Parents,Ev,Tabs,Est)|NLV]) :-
|
||||
clpbn_not_var_member(Vs,V), !,
|
||||
include(LV,tab(T,Vs,Sz),V1,NLV).
|
||||
include([var(V,P,VSz,D,Ev,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,Ev,NTabs,NEst)|NLV]) :-
|
||||
include([var(V,P,VSz,D,Parents,Ev,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,Parents,Ev,NTabs,NEst)|NLV]) :-
|
||||
update_tables(Tabs,NTabs,Table,NV),
|
||||
compute_size(NTabs, [], NEst),
|
||||
% ( clpbn:get_atts(V,[key(Key)]) -> write(Key:NEst), nl ; true),
|
||||
|
||||
70
pl/boot.yap
70
pl/boot.yap
@ -122,7 +122,7 @@ true :- true.
|
||||
format(user_error, '% trace~n', [])
|
||||
;
|
||||
recorded('$debug', on, _) ->
|
||||
format(user_error, '% debug~n', [])
|
||||
format(user_error, '% debug~n', [])
|
||||
),
|
||||
fail.
|
||||
'$enter_top_level' :-
|
||||
@ -260,25 +260,18 @@ repeat :- '$repeat'.
|
||||
'$process_directive'(G, top, _) :- !,
|
||||
'$do_error'(context_error((:- G),clause),query).
|
||||
%
|
||||
% always allow directives.
|
||||
%
|
||||
'$process_directive'(D, Mode, M) :-
|
||||
'$directive'(D), !,
|
||||
( '$exec_directive'(D, Mode, M) -> true ; true ).
|
||||
%
|
||||
% allow multiple directives
|
||||
%
|
||||
'$process_directive'((G1,G2), Mode, M) :-
|
||||
'$all_directives'(G1),
|
||||
'$all_directives'(G2), !,
|
||||
'$exec_directives'(G1, Mode, M),
|
||||
'$exec_directives'(G2, Mode, M).
|
||||
%
|
||||
% allow modules
|
||||
%
|
||||
'$process_directive'(M:G, Mode, _) :- !,
|
||||
'$process_directive'(G, Mode, M).
|
||||
%
|
||||
% default case
|
||||
%
|
||||
'$process_directive'(Gs, Mode, M) :-
|
||||
'$all_directives'(Gs), !,
|
||||
'$exec_directives'(Gs, Mode, M).
|
||||
|
||||
%
|
||||
% ISO does not allow goals (use initialization).
|
||||
%
|
||||
'$process_directive'(D, _, M) :-
|
||||
@ -288,15 +281,8 @@ repeat :- '$repeat'.
|
||||
% but YAP and SICStus does.
|
||||
%
|
||||
'$process_directive'(G, _, M) :-
|
||||
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ).
|
||||
|
||||
'$all_directives'(_:G1) :- !,
|
||||
'$all_directives'(G1).
|
||||
'$all_directives'((G1,G2)) :- !,
|
||||
'$all_directives'(G1),
|
||||
'$all_directives'(G2).
|
||||
'$all_directives'(G) :- !,
|
||||
'$directive'(G).
|
||||
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ),
|
||||
'$do_not_creep'.
|
||||
|
||||
'$continue_with_command'(reconsult,V,G,Source) :-
|
||||
'$go_compile_clause'(G,V,5,Source),
|
||||
@ -305,7 +291,8 @@ repeat :- '$repeat'.
|
||||
'$go_compile_clause'(G,V,13,Source),
|
||||
fail.
|
||||
'$continue_with_command'(top,V,G,_) :-
|
||||
'$query'(G,V).
|
||||
'$query'(G,V),
|
||||
'$do_not_creep'.
|
||||
|
||||
%
|
||||
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put
|
||||
@ -384,16 +371,16 @@ repeat :- '$repeat'.
|
||||
'$yes_no'(G,(?-)).
|
||||
'$query'(G,V) :-
|
||||
(
|
||||
( recorded('$trace',on,_) -> '$creep' ; true),
|
||||
( recorded('$trace',on,_) -> '$creep' ; true),
|
||||
'$execute'(G),
|
||||
'$do_stop_creep',
|
||||
'$do_not_creep',
|
||||
'$extract_goal_vars_for_dump'(V,LIV),
|
||||
'$show_frozen'(G,LIV,LGs),
|
||||
'$write_answer'(V, LGs, Written),
|
||||
'$write_query_answer_true'(Written),
|
||||
'$another',
|
||||
!, fail ;
|
||||
'$do_stop_creep',
|
||||
'$do_not_creep',
|
||||
( '$undefined'('$print_message'(_,_),prolog) ->
|
||||
'$present_answer'(user_error,"no~n", [])
|
||||
;
|
||||
@ -405,7 +392,7 @@ repeat :- '$repeat'.
|
||||
'$yes_no'(G,C) :-
|
||||
'$current_module'(M),
|
||||
'$do_yes_no'(G,M),
|
||||
'$do_stop_creep',
|
||||
'$do_not_creep',
|
||||
'$show_frozen'(G, [], LGs),
|
||||
'$write_answer'([], LGs, Written),
|
||||
( Written = [] ->
|
||||
@ -414,7 +401,7 @@ repeat :- '$repeat'.
|
||||
),
|
||||
fail.
|
||||
'$yes_no'(_,_) :-
|
||||
'$do_stop_creep',
|
||||
'$do_not_creep',
|
||||
( '$undefined'('$print_message'(_,_),prolog) ->
|
||||
'$present_answer'(user_error,"no~n", [])
|
||||
;
|
||||
@ -422,15 +409,11 @@ repeat :- '$repeat'.
|
||||
),
|
||||
fail.
|
||||
|
||||
% make sure we have Prolog code to force running any delayed goals.
|
||||
'$do_stop_creep' :-
|
||||
'$stop_creep'.
|
||||
|
||||
|
||||
'$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M).
|
||||
'$do_yes_no'(G, M) :-
|
||||
( recorded('$trace',on,_) -> '$creep' ; true),
|
||||
'$execute'(M:G).
|
||||
|
||||
'$extract_goal_vars_for_dump'([],[]).
|
||||
'$extract_goal_vars_for_dump'([[_|V]|VL],[V|LIV]) :-
|
||||
'$extract_goal_vars_for_dump'(VL,LIV).
|
||||
@ -845,8 +828,10 @@ break :-
|
||||
;
|
||||
'$print_message'(informational, loading(consulting, File))
|
||||
),
|
||||
( recorded('$trace', on, TraceR) -> erase(TraceR) ; true),
|
||||
'$loop'(Stream,consult),
|
||||
'$end_consult',
|
||||
( nonvar(TraceR) -> recorda('$trace', on, _) ; true),
|
||||
set_value('$consulting',Old),
|
||||
set_value('$consulting_file',OldF),
|
||||
'$current_module'(NewMod,OldModule),
|
||||
@ -955,7 +940,7 @@ break :-
|
||||
'$find_in_path'(user_input,user_input, _) :- !.
|
||||
'$find_in_path'(S,NewFile, _) :-
|
||||
S =.. [Name,File], !,
|
||||
user:file_search_path(Name, Dir),
|
||||
( user:file_search_path(Name, Dir) -> '$do_not_creep' ; '$do_not_creep'),
|
||||
'$dir_separator'(D),
|
||||
atom_codes(A,[D]),
|
||||
atom_concat([Dir,A,File],NFile),
|
||||
@ -990,11 +975,13 @@ break :-
|
||||
|
||||
expand_term(Term,Expanded) :-
|
||||
( \+ '$undefined'(term_expansion(_,_), user),
|
||||
user:term_expansion(Term,Expanded)
|
||||
user:term_expansion(Term,Expanded),
|
||||
'$do_not_creep'
|
||||
;
|
||||
'$do_not_creep',
|
||||
'$expand_term_grammar'(Term,Expanded)
|
||||
),
|
||||
!.
|
||||
!.
|
||||
|
||||
|
||||
%
|
||||
@ -1090,15 +1077,14 @@ throw(Ball) :-
|
||||
G \= '$',
|
||||
'$current_module'(M),
|
||||
'$system_catch'(once(M:G), M, Error, user:'$LoopError'(Error, top)),
|
||||
'$do_not_creep',
|
||||
fail.
|
||||
'$exec_initialisation_goals'.
|
||||
|
||||
'$run_toplevel_hooks' :-
|
||||
get_value('$break',0),
|
||||
recorded('$toplevel_hooks',H,_), !,
|
||||
( '$execute'(H) -> true ; true).
|
||||
( '$execute'(H) -> true ; true),
|
||||
'$do_not_creep'.
|
||||
'$run_toplevel_hooks'.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -126,8 +126,10 @@ reconsult(Fs) :-
|
||||
'$remove_multifile_clauses'(File),
|
||||
recorda('$initialisation','$',_),
|
||||
'$print_message'(informational, loading(reconsulting, File)),
|
||||
( recorded('$trace', on, TraceR) -> erase(TraceR) ; true),
|
||||
'$loop'(Stream,reconsult),
|
||||
'$end_consult',
|
||||
( nonvar(TraceR) -> recorda('$trace', on, _) ; true),
|
||||
'$clear_reconsulting',
|
||||
set_value('$consulting',Old),
|
||||
set_value('$consulting_file',OldF),
|
||||
|
||||
@ -617,9 +617,11 @@ call_residue(Goal,Residue) :-
|
||||
'$project_module'([Mod|LMods], LIV, LAV) :-
|
||||
\+ '$undefined'(project_attributes(LIV, LAV), Mod),
|
||||
'$execute'(Mod:project_attributes(LIV, LAV)), !,
|
||||
'$do_not_creep',
|
||||
attributes:all_attvars(NLAV),
|
||||
'$project_module'(LMods,LIV,NLAV).
|
||||
'$project_module'([_|LMods], LIV, LAV) :-
|
||||
'$do_not_creep',
|
||||
'$project_module'(LMods,LIV,LAV).
|
||||
|
||||
|
||||
@ -634,11 +636,13 @@ call_residue(Goal,Residue) :-
|
||||
'$do_convert_att_vars'([V|LAV], LIV, NGs) :-
|
||||
var(V),
|
||||
attributes:convert_att_var(V,G),
|
||||
'$do_not_creep',
|
||||
G \= true,
|
||||
!,
|
||||
'$split_goals_for_catv'(G,V,NGs,IGs),
|
||||
'$do_convert_att_vars'(LAV, LIV, IGs).
|
||||
'$do_convert_att_vars'([_|LAV], LIV, Gs) :-
|
||||
'$do_not_creep',
|
||||
'$do_convert_att_vars'(LAV, LIV, Gs).
|
||||
|
||||
'$split_goals_for_catv'((G,NG),V,[V-G|Gs],Gs0) :- !,
|
||||
|
||||
46
pl/debug.yap
46
pl/debug.yap
@ -23,7 +23,6 @@
|
||||
|
||||
:- op(900,fx,[spy,nospy]).
|
||||
|
||||
:- thread_local([idb:'$debug',idb:'$trace',idb:'$spy_skip',idb:'$spy_stop']).
|
||||
|
||||
% First part : setting and reseting spy points
|
||||
|
||||
@ -271,10 +270,11 @@ debugging :-
|
||||
% last argument to do_spy says that we are at the end of a context. It
|
||||
% is required to know whether we are controlled by the debugger.
|
||||
'$do_spy'(_, _, _, _) :-
|
||||
'$stop_debugging', fail.
|
||||
'$do_not_creep', fail.
|
||||
'$do_spy'(!, _, CP, _) :- !, '$cut_by'(CP).
|
||||
'$do_spy'('$cut_by'(M), _, _, _) :- !, '$cut_by'(M).
|
||||
'$do_spy'(true, _, _, _) :- !.
|
||||
%'$do_spy'(fail, _, _, _) :- !, fail.
|
||||
'$do_spy'(M:G, _, CP, InControl) :- !,
|
||||
'$do_spy'(G, M, CP, InControl).
|
||||
'$do_spy'((A,B), M, CP, InControl) :- !,
|
||||
@ -285,14 +285,16 @@ debugging :-
|
||||
;
|
||||
'$do_spy'(B, M, CP, InControl)
|
||||
).
|
||||
'$do_spy'((A;B), M, CP, InControl) :- !,
|
||||
(
|
||||
'$do_spy'(A, M, CP, yes)
|
||||
'$do_spy'((T->A|B), M, CP, InControl) :- !,
|
||||
( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes)
|
||||
;
|
||||
'$do_spy'(B, M, CP, InControl)
|
||||
).
|
||||
'$do_spy'((T->A|B), M, CP, InControl) :- !,
|
||||
( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes)
|
||||
'$do_spy'((T->A), M, CP, InControl) :- !,
|
||||
( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ).
|
||||
'$do_spy'((A;B), M, CP, InControl) :- !,
|
||||
(
|
||||
'$do_spy'(A, M, CP, yes)
|
||||
;
|
||||
'$do_spy'(B, M, CP, InControl)
|
||||
).
|
||||
@ -321,7 +323,7 @@ debugging :-
|
||||
|
||||
% handle weird things happening in the debugger.
|
||||
'$loop_spy_event'(_, _, _, _, _) :-
|
||||
'$stop_debugging', fail.
|
||||
'$do_not_creep', fail.
|
||||
'$loop_spy_event'('$retry_spy'(G0), GoalNumber, G, Module, InControl) :-
|
||||
G0 >= GoalNumber, !,
|
||||
'$loop_spy'(GoalNumber, G, Module, InControl).
|
||||
@ -355,20 +357,21 @@ debugging :-
|
||||
'$spycall'(G, Module, InControl),
|
||||
/* go execute the predicate */
|
||||
(
|
||||
'$stop_debugging',
|
||||
'$do_not_creep',
|
||||
'$show_trace'(exit,G,Module,GoalNumber), /* output message at exit */
|
||||
'$continue_debugging'(InControl)
|
||||
; /* exit */
|
||||
;
|
||||
/* exit */
|
||||
/* we get here when we want to redo a goal */
|
||||
'$stop_debugging',
|
||||
'$do_not_creep',
|
||||
'$show_trace'(redo,G,Module,GoalNumber), /* inform user_error */
|
||||
'$continue_debugging'(InControl),
|
||||
'$continue_debugging'(InControl,G,Module),
|
||||
fail /* to backtrack to spycalls */
|
||||
)
|
||||
;
|
||||
'$stop_debugging',
|
||||
'$do_not_creep',
|
||||
'$show_trace'(fail,G,Module,GoalNumber), /* inform at fail port */
|
||||
'$continue_debugging'(InControl),
|
||||
'$continue_debugging'(InControl,G,Module),
|
||||
fail
|
||||
).
|
||||
|
||||
@ -410,11 +413,11 @@ debugging :-
|
||||
% use the interpreter
|
||||
CP is '$last_choice_pt',
|
||||
'$clause'(G, M, Cl),
|
||||
'$stop_debugging',
|
||||
'$do_not_creep',
|
||||
'$do_spy'(Cl, M, CP, InControl).
|
||||
'$spycall'(G, M, InControl) :-
|
||||
% I lost control here.
|
||||
'$continue_debugging'(InControl),
|
||||
'$continue_debugging'(InControl,G,M),
|
||||
'$execute_nonstop'(G, M).
|
||||
|
||||
|
||||
@ -568,15 +571,18 @@ debugging :-
|
||||
fail.
|
||||
|
||||
% if we are in the interpreter, don't need to care about forcing a trace, do we?
|
||||
'$continue_debugging'(no) :- !.
|
||||
'$continue_debugging'(no,_,_) :- !.
|
||||
'$continue_debugging'(Flag,G,M) :-
|
||||
'$system_predicate'(G,M), !,
|
||||
( '$access_yap_flags'(10,1) -> '$late_creep' ; true).
|
||||
'$continue_debugging'(Flag,_,_) :-
|
||||
'$continue_debugging'(Flag).
|
||||
|
||||
'$continue_debugging'(_) :-
|
||||
'$access_yap_flags'(10,1), !,
|
||||
'$creep'.
|
||||
'$continue_debugging'(_).
|
||||
|
||||
'$stop_debugging' :-
|
||||
'$stop_creep'.
|
||||
|
||||
'$action_help' :-
|
||||
format(user_error,"newline creep a abort~n", []),
|
||||
format(user_error,"c creep e exit~n", []),
|
||||
|
||||
@ -15,6 +15,14 @@
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
'$all_directives'(_:G1) :- !,
|
||||
'$all_directives'(G1).
|
||||
'$all_directives'((G1,G2)) :- !,
|
||||
'$all_directives'(G1),
|
||||
'$all_directives'(G2).
|
||||
'$all_directives'(G) :- !,
|
||||
'$directive'(G).
|
||||
|
||||
'$directive'(multifile(_)).
|
||||
'$directive'(discontiguous(_)).
|
||||
'$directive'(initialization(_)).
|
||||
@ -42,6 +50,12 @@
|
||||
'$directive'(uncutable(_)).
|
||||
'$directive'(thread_local(_)).
|
||||
|
||||
'$exec_directives'((G1,G2), Mode, M) :- !,
|
||||
'$exec_directives'(G1, Mode, M),
|
||||
'$exec_directives'(G2, Mode, M).
|
||||
'$exec_directives'(G, Mode, M) :-
|
||||
'$exec_directive'(G, Mode, M).
|
||||
|
||||
'$exec_directive'(multifile(D), _, M) :-
|
||||
'$system_catch'('$multifile'(D, M), M,
|
||||
Error,
|
||||
@ -102,12 +116,6 @@
|
||||
'$uncutable'(PredSpec, M).
|
||||
|
||||
|
||||
'$exec_directives'((G1,G2), Mode, M) :- !,
|
||||
'$exec_directives'(G1, Mode, M),
|
||||
'$exec_directives'(G2, Mode, M).
|
||||
'$exec_directives'(G, Mode, M) :-
|
||||
'$exec_directive'(G, Mode, M).
|
||||
|
||||
yap_flag(V,Out) :-
|
||||
var(V), !,
|
||||
'$show_yap_flag_opts'(V,Out).
|
||||
|
||||
10
pl/init.yap
10
pl/init.yap
@ -20,12 +20,18 @@
|
||||
|
||||
% These are pseudo declarations
|
||||
% so that the user will get a redefining system predicate
|
||||
otherwise.
|
||||
fail :- fail.
|
||||
|
||||
false :- fail.
|
||||
|
||||
otherwise.
|
||||
|
||||
!.
|
||||
|
||||
(:- G) :- '$execute'(G), !.
|
||||
|
||||
'$$!'(CP) :- '$cut_by'(CP).
|
||||
|
||||
[] :- true.
|
||||
|
||||
|
||||
@ -66,6 +72,8 @@ false :- fail.
|
||||
'threads.yap',
|
||||
'yapor.yap'].
|
||||
|
||||
:- thread_local([idb:'$debug'/0,idb:'$trace'/0,idb:'$spy_skip'/0,idb:'$spy_stop'/0]).
|
||||
|
||||
:- ['protect.yap'].
|
||||
|
||||
version(yap,[4,1]).
|
||||
|
||||
@ -413,6 +413,8 @@ module(N) :-
|
||||
|
||||
:- dynamic_predicate('$meta_predicate'/4,logical).
|
||||
|
||||
:- multifile '$meta_predicate'/4.
|
||||
|
||||
'$meta_predicate'((P,Ps), M) :- !,
|
||||
'$meta_predicate'(P, M),
|
||||
'$meta_predicate'(Ps, M).
|
||||
|
||||
@ -388,7 +388,7 @@ nth_clause(V,I,R) :-
|
||||
M1 = M.
|
||||
'$nth_clause_ref'(P,M,I,R) :-
|
||||
'$nth_instancep'(M:P,I,R).
|
||||
|
||||
|
||||
retract(M:C) :- !,
|
||||
'$retract'(C,M).
|
||||
retract(C) :-
|
||||
|
||||
@ -31,8 +31,15 @@
|
||||
% if more signals alive, set creep flag
|
||||
'$continue_signals',
|
||||
'$wake_up_goal'(G, LG).
|
||||
'$do_signal'(sig_creep, G) :-
|
||||
'$start_creep'(G).
|
||||
'$do_signal'(sig_creep, [M|G]) :-
|
||||
( '$access_yap_flags'(10,0) ->
|
||||
% we're not allowed to creep for now,
|
||||
% maybe we're inside builtin.
|
||||
'$late_creep',
|
||||
'$execute'(M:G)
|
||||
;
|
||||
'$start_creep'([M|G])
|
||||
).
|
||||
'$do_signal'(sig_delay_creep, [M|G]) :-
|
||||
'$execute'(M:G),
|
||||
'$creep'.
|
||||
@ -93,7 +100,7 @@
|
||||
'$creep',
|
||||
'$execute_nonstop'(G,Mod).
|
||||
'$start_creep'([Mod|G]) :-
|
||||
'$stop_debugging',
|
||||
'$do_not_creep',
|
||||
CP is '$last_choice_pt',
|
||||
'$do_spy'(G, Mod, CP, yes).
|
||||
|
||||
|
||||
Reference in New Issue
Block a user