code review
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1576 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
8947654162
commit
8ed6f693bb
@ -12,7 +12,7 @@
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: allocating space *
|
||||
* version:$Id: alloc.c,v 1.80 2006-01-08 23:01:46 vsc Exp $ *
|
||||
* version:$Id: alloc.c,v 1.81 2006-03-24 16:26:25 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
@ -213,7 +213,7 @@ Yap_InitHeap(void *heap_addr)
|
||||
static void
|
||||
InitExStacks(int Trail, int Stack)
|
||||
{
|
||||
UInt pm, sa, ta;
|
||||
UInt pm, sa;
|
||||
|
||||
/* sanity checking for data areas */
|
||||
if (Trail < MinTrailSpace)
|
||||
@ -235,6 +235,8 @@ InitExStacks(int Trail, int Stack)
|
||||
|
||||
#ifdef DEBUG
|
||||
if (Yap_output_msg) {
|
||||
Uint ta;
|
||||
|
||||
fprintf(stderr, "HeapBase = %p GlobalBase = %p\n LocalBase = %p TrailTop = %p\n",
|
||||
Yap_HeapBase, Yap_GlobalBase, Yap_LocalBase, Yap_TrailTop);
|
||||
|
||||
|
||||
144
C/cdmgr.c
144
C/cdmgr.c
@ -11,8 +11,11 @@
|
||||
* File: cdmgr.c *
|
||||
* comments: Code manager *
|
||||
* *
|
||||
* Last rev: $Date: 2006-03-22 20:07:28 $,$Author: vsc $ *
|
||||
* Last rev: $Date: 2006-03-24 16:26:26 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.181 2006/03/22 20:07:28 vsc
|
||||
* take better care of zombies
|
||||
*
|
||||
* Revision 1.180 2006/03/22 16:14:20 vsc
|
||||
* don't be too eager at throwing indexing code for static predicates away.
|
||||
*
|
||||
@ -362,6 +365,8 @@ STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void));
|
||||
STATIC_PROTO(Atom YapConsultingFile, (void));
|
||||
STATIC_PROTO(Int PredForCode,(yamop *, Atom *, UInt *, Term *));
|
||||
STATIC_PROTO(void kill_first_log_iblock,(LogUpdIndex *, LogUpdIndex *, PredEntry *));
|
||||
STATIC_PROTO(LogUpdIndex *find_owner_log_index,(LogUpdIndex *, yamop *));
|
||||
STATIC_PROTO(StaticIndex *find_owner_static_index,(StaticIndex *, yamop *));
|
||||
|
||||
#define PredArity(p) (p->ArityOfPE)
|
||||
#define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G)
|
||||
@ -456,7 +461,7 @@ static int
|
||||
static_in_use(PredEntry *p, int check_everything)
|
||||
{
|
||||
#if defined(YAPOR) || defined(THREADS)
|
||||
return(FALSE);
|
||||
return TRUE;
|
||||
#else
|
||||
CELL pflags = p->PredFlags;
|
||||
if (pflags & (DynamicPredFlag|LogUpdatePredFlag)) {
|
||||
@ -1011,6 +1016,7 @@ kill_children(LogUpdIndex *c, PredEntry *ap)
|
||||
UNLOCK(c->ClLock);
|
||||
}
|
||||
|
||||
/* assumes c is already locked */
|
||||
static void
|
||||
kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
||||
{
|
||||
@ -1027,10 +1033,8 @@ kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
||||
parent->ClRefCount == 0) {
|
||||
/* cool, I can erase the father too. */
|
||||
if (parent->ClFlags & SwitchRootMask) {
|
||||
UNLOCK(parent->ClLock);
|
||||
kill_off_lu_block(parent, NULL, ap);
|
||||
} else {
|
||||
UNLOCK(parent->ClLock);
|
||||
kill_off_lu_block(parent, parent->ParentIndex, ap);
|
||||
}
|
||||
} else {
|
||||
@ -1058,7 +1062,6 @@ static void
|
||||
kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
||||
{
|
||||
/* parent is always locked, now I lock myself */
|
||||
LOCK(c->ClLock);
|
||||
if (parent != NULL) {
|
||||
/* remove myself from parent */
|
||||
LOCK(parent->ClLock);
|
||||
@ -1108,7 +1111,6 @@ kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
||||
DBErasedIList = c;
|
||||
UNLOCK(c->ClLock);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
static void
|
||||
@ -1294,10 +1296,10 @@ retract_all(PredEntry *p, int in_use)
|
||||
StaticClause *ncl = cl->ClNext;
|
||||
|
||||
if (in_use|| cl->ClFlags & HasBlobsMask) {
|
||||
LOCK(StaticClausesLock);
|
||||
LOCK(DeadStaticClausesLock);
|
||||
cl->ClNext = DeadStaticClauses;
|
||||
DeadStaticClauses = cl;
|
||||
UNLOCK(StaticClausesLock);
|
||||
UNLOCK(DeadStaticClausesLock);
|
||||
} else {
|
||||
Yap_InformOfRemoval((CODEADDR)cl);
|
||||
Yap_FreeCodeSpace((char *)cl);
|
||||
@ -1994,10 +1996,10 @@ Yap_EraseStaticClause(StaticClause *cl, Term mod) {
|
||||
#endif
|
||||
WRITE_UNLOCK(ap->PRWLock);
|
||||
if (cl->ClFlags & HasBlobsMask || static_in_use(ap,TRUE)) {
|
||||
LOCK(DeadStaticClauses);
|
||||
LOCK(DeadStaticClausesLock);
|
||||
cl->ClNext = DeadStaticClauses;
|
||||
DeadStaticClauses = cl;
|
||||
UNLOCK(DeadStaticClauses);
|
||||
UNLOCK(DeadStaticClausesLock);
|
||||
} else {
|
||||
Yap_InformOfRemoval((CODEADDR)cl);
|
||||
Yap_FreeCodeSpace((char *)cl);
|
||||
@ -2988,7 +2990,7 @@ p_compile_mode(void)
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
#if !defined(YAPOR)
|
||||
#if !defined(YAPOR) && !defined(THREADS)
|
||||
static yamop *cur_clause(PredEntry *pe, yamop *codeptr)
|
||||
{
|
||||
StaticClause *cl;
|
||||
@ -3020,59 +3022,6 @@ static yamop *cur_log_upd_clause(PredEntry *pe, yamop *codeptr)
|
||||
return(NULL);
|
||||
}
|
||||
|
||||
static LogUpdIndex *
|
||||
find_owner_log_index(LogUpdIndex *cl, yamop *code_p)
|
||||
{
|
||||
yamop *code_beg = cl->ClCode;
|
||||
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
||||
|
||||
if (code_p >= code_beg && code_p <= code_end) {
|
||||
return cl;
|
||||
}
|
||||
cl = cl->ChildIndex;
|
||||
while (cl != NULL) {
|
||||
LogUpdIndex *out;
|
||||
if ((out = find_owner_log_index(cl, code_p)) != NULL) {
|
||||
return out;
|
||||
}
|
||||
cl = cl->SiblingIndex;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static StaticIndex *
|
||||
find_owner_static_index(StaticIndex *cl, yamop *code_p)
|
||||
{
|
||||
yamop *code_beg = cl->ClCode;
|
||||
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
||||
|
||||
if (code_p >= code_beg && code_p <= code_end) {
|
||||
return cl;
|
||||
}
|
||||
cl = cl->ChildIndex;
|
||||
while (cl != NULL) {
|
||||
StaticIndex *out;
|
||||
if ((out = find_owner_static_index(cl, code_p)) != NULL) {
|
||||
return out;
|
||||
}
|
||||
cl = cl->SiblingIndex;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
ClauseUnion *
|
||||
Yap_find_owner_index(yamop *ipc, PredEntry *ap)
|
||||
{
|
||||
/* we assume we have an owner index */
|
||||
if (ap->PredFlags & LogUpdatePredFlag) {
|
||||
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred);
|
||||
return (ClauseUnion *)find_owner_log_index(cl,ipc);
|
||||
} else {
|
||||
StaticIndex *cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
|
||||
return (ClauseUnion *)find_owner_static_index(cl,ipc);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
search_for_static_predicate_in_use(PredEntry *p, int check_everything)
|
||||
{
|
||||
@ -3190,7 +3139,60 @@ do_toggle_static_predicates_in_use(int mask)
|
||||
STATIC_PREDICATES_MARKED = mask;
|
||||
}
|
||||
|
||||
#endif
|
||||
#endif /* !defined(YAPOR) && !defined(THREADS) */
|
||||
|
||||
static LogUpdIndex *
|
||||
find_owner_log_index(LogUpdIndex *cl, yamop *code_p)
|
||||
{
|
||||
yamop *code_beg = cl->ClCode;
|
||||
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
||||
|
||||
if (code_p >= code_beg && code_p <= code_end) {
|
||||
return cl;
|
||||
}
|
||||
cl = cl->ChildIndex;
|
||||
while (cl != NULL) {
|
||||
LogUpdIndex *out;
|
||||
if ((out = find_owner_log_index(cl, code_p)) != NULL) {
|
||||
return out;
|
||||
}
|
||||
cl = cl->SiblingIndex;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static StaticIndex *
|
||||
find_owner_static_index(StaticIndex *cl, yamop *code_p)
|
||||
{
|
||||
yamop *code_beg = cl->ClCode;
|
||||
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
||||
|
||||
if (code_p >= code_beg && code_p <= code_end) {
|
||||
return cl;
|
||||
}
|
||||
cl = cl->ChildIndex;
|
||||
while (cl != NULL) {
|
||||
StaticIndex *out;
|
||||
if ((out = find_owner_static_index(cl, code_p)) != NULL) {
|
||||
return out;
|
||||
}
|
||||
cl = cl->SiblingIndex;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
ClauseUnion *
|
||||
Yap_find_owner_index(yamop *ipc, PredEntry *ap)
|
||||
{
|
||||
/* we assume we have an owner index */
|
||||
if (ap->PredFlags & LogUpdatePredFlag) {
|
||||
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred);
|
||||
return (ClauseUnion *)find_owner_log_index(cl,ipc);
|
||||
} else {
|
||||
StaticIndex *cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
|
||||
return (ClauseUnion *)find_owner_static_index(cl,ipc);
|
||||
}
|
||||
}
|
||||
|
||||
static Term
|
||||
all_envs(CELL *env_ptr)
|
||||
@ -3304,7 +3306,7 @@ p_toggle_static_predicates_in_use(void)
|
||||
}
|
||||
do_toggle_static_predicates_in_use(mask);
|
||||
#endif
|
||||
return(TRUE);
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
static void
|
||||
@ -4263,7 +4265,7 @@ p_pred_for_code(void) {
|
||||
yamop *codeptr;
|
||||
Atom at;
|
||||
UInt arity;
|
||||
Term module;
|
||||
Term tmodule = TermProlog;
|
||||
Int cl;
|
||||
Term t = Deref(ARG1);
|
||||
|
||||
@ -4278,14 +4280,14 @@ p_pred_for_code(void) {
|
||||
} else {
|
||||
return FALSE;
|
||||
}
|
||||
cl = PredForCode(codeptr, &at, &arity, &module);
|
||||
if (!module) module = TermProlog;
|
||||
cl = PredForCode(codeptr, &at, &arity, &tmodule);
|
||||
if (!tmodule) tmodule = TermProlog;
|
||||
if (cl == 0) {
|
||||
return(Yap_unify(ARG5,MkIntTerm(0)));
|
||||
return Yap_unify(ARG5,MkIntTerm(0));
|
||||
} else {
|
||||
return(Yap_unify(ARG2,MkAtomTerm(at)) &&
|
||||
Yap_unify(ARG3,MkIntegerTerm(arity)) &&
|
||||
Yap_unify(ARG4,module) &&
|
||||
Yap_unify(ARG4,tmodule) &&
|
||||
Yap_unify(ARG5,MkIntegerTerm(cl)));
|
||||
}
|
||||
}
|
||||
|
||||
@ -245,9 +245,9 @@ Yap_op_from_opcode(OPCODE opc)
|
||||
#endif /* USE_THREADED_CODE */
|
||||
|
||||
#if defined(YAPOR) || defined(THREADS)
|
||||
static int same_lu_block(yamop **, yamop *);
|
||||
static inline int same_lu_block(yamop **, yamop *);
|
||||
|
||||
static int
|
||||
static inline int
|
||||
same_lu_block(yamop **paddr, yamop *p)
|
||||
{
|
||||
yamop *np = *paddr;
|
||||
|
||||
@ -16,6 +16,9 @@
|
||||
|
||||
<h2>Yap-5.1.0:</h2>
|
||||
<ul>
|
||||
<li> FIXED: check for singleton warnings in .yap files, try to catch
|
||||
bugs before they bite people.</li>
|
||||
<li> FIXED: make threads compile again, fix some compilation warnings.</li>
|
||||
<li> FIXED: use different chains for dead static clauses, static
|
||||
indices and dead mega clauses. Extend dead clauses with next field so that
|
||||
they can added into chain. Fix restore to see dead clauses.</li>
|
||||
|
||||
@ -88,7 +88,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
|
||||
var(G1), var(Mod), !.
|
||||
'$do_c_built_metacall'(G1, Mod, '$execute_in_mod'(G1,Mod)) :-
|
||||
var(G1), atom(Mod), !.
|
||||
'$do_c_built_metacall'(Mod:G1, _, call(Mod:G1)) :- !,
|
||||
'$do_c_built_metacall'(Mod:G1, _, OUT) :- !,
|
||||
'$do_c_built_metacall'(G1, Mod, OUT).
|
||||
'$do_c_built_metacall'(G1, Mod, '$execute_in_mod'(G1,Mod)) :-
|
||||
atom(Mod), !.
|
||||
|
||||
15
pl/boot.yap
15
pl/boot.yap
@ -131,7 +131,6 @@ true :- true.
|
||||
'$print_message'(informational,prompt(BreakLevel,TraceDebug)),
|
||||
fail.
|
||||
'$enter_top_level' :-
|
||||
'$current_module'(Module),
|
||||
get_value('$top_level_goal',GA), GA \= [], !,
|
||||
set_value('$top_level_goal',[]),
|
||||
'$run_atom_goal'(GA),
|
||||
@ -387,10 +386,6 @@ true :- true.
|
||||
( NFl \= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ;
|
||||
'$compile'(G, L, G0, Mod) ).
|
||||
|
||||
% process a clause for a static predicate
|
||||
'$$compile_stat'(G,G0,L,H, Mod) :-
|
||||
'$compile'(G,L,G0,Mod).
|
||||
|
||||
'$check_if_reconsulted'(N,A) :-
|
||||
recorded('$reconsulted',X,_),
|
||||
( X = N/A , !;
|
||||
@ -475,7 +470,7 @@ true :- true.
|
||||
format(user_error,'~ntrue',[]).
|
||||
'$write_query_answer_true'(_).
|
||||
|
||||
'$output_frozen'(G,V,LGs) :-
|
||||
'$output_frozen'(_,V,LGs) :-
|
||||
\+ '$undefined'(bindings_message(_,_,_), swi),
|
||||
swi:bindings_message(V, LGs, []), !.
|
||||
'$output_frozen'(G,V,LGs) :-
|
||||
@ -670,7 +665,7 @@ incore(G) :- '$execute'(G).
|
||||
'->'(X,Y) :-
|
||||
'$save_current_choice_point'(CP),
|
||||
'$current_module'(M),
|
||||
( '$call'(X,CP,G0,M) -> '$call'(Y,CP,(X->Y),M) ).
|
||||
( '$call'(X,CP,(X->Y),M) -> '$call'(Y,CP,(X->Y),M) ).
|
||||
\+(G) :- \+ '$execute'(G).
|
||||
not(G) :- \+ '$execute'(G).
|
||||
|
||||
@ -732,9 +727,9 @@ not(G) :- \+ '$execute'(G).
|
||||
;
|
||||
'$call'(B,CP,G0,M)
|
||||
).
|
||||
'$call'(\+ X, CP, G0, M) :- !,
|
||||
'$call'(\+ X, _CP, _G0, _M) :- !,
|
||||
\+ '$execute'(X).
|
||||
'$call'(not(X), CP, G0, M) :- !,
|
||||
'$call'(not(X), _CP, _G0, _M) :- !,
|
||||
\+ '$execute'(X).
|
||||
'$call'(!, CP, _,_) :- !,
|
||||
'$$cut_by'(CP).
|
||||
@ -799,7 +794,7 @@ not(G) :- \+ '$execute'(G).
|
||||
'$find_undefp_handler'(G,M,US,user) :-
|
||||
recorded('$unknown','$unknown'(M:G,US),_), !,
|
||||
'$exit_undefp'.
|
||||
'$find_undefp_handler'(G,M,_,_) :-
|
||||
'$find_undefp_handler'(_,_,_,_) :-
|
||||
'$exit_undefp',
|
||||
fail.
|
||||
|
||||
|
||||
@ -29,7 +29,7 @@ call_count(Calls, Retries, Both) :-
|
||||
|
||||
'$check_if_call_count_on'(Calls, 1) :- integer(Calls), !.
|
||||
'$check_if_call_count_on'(Calls, 0) :- var(Calls), !.
|
||||
'$check_if_call_count_on'(Calls, _) :-
|
||||
'$check_if_call_count_on'(Calls, A) :-
|
||||
'$do_error'(type_error(integer,Calls),call_count(A)).
|
||||
|
||||
|
||||
|
||||
@ -11,8 +11,14 @@
|
||||
* File: checker.yap *
|
||||
* comments: style checker for Prolog *
|
||||
* *
|
||||
* Last rev: $Date: 2005-11-05 23:56:10 $,$Author: vsc $ *
|
||||
* Last rev: $Date: 2006-03-24 16:26:31 $,$Author: vsc $ *
|
||||
* $Log: not supported by cvs2svn $
|
||||
* Revision 1.20 2005/11/05 23:56:10 vsc
|
||||
* should have meta-predicate definitions for calls,
|
||||
* multifile and discontiguous.
|
||||
* have discontiguous as a builtin, not just as a
|
||||
* declaration.
|
||||
*
|
||||
* Revision 1.19 2005/10/28 17:38:50 vsc
|
||||
* sveral updates
|
||||
*
|
||||
@ -144,7 +150,6 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
|
||||
'$sv_warning'(SVs,T) :-
|
||||
'$current_module'(OM),
|
||||
'$xtract_head'(T,OM,M,H,Name,Arity),
|
||||
'$start_line'(LN),
|
||||
( get_value('$consulting',false),
|
||||
'$first_clause_in_file'(Name,Arity, OM) ->
|
||||
ClN = 1 ;
|
||||
@ -193,7 +198,6 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
|
||||
|
||||
'$test_if_well_reconsulting'(F,F,_) :- !.
|
||||
'$test_if_well_reconsulting'(_,Fil,P) :-
|
||||
'$start_line'(LN),
|
||||
print_message(warning,defined_elsewhere(P,Fil)).
|
||||
|
||||
'$multifile'(V, _) :- var(V), !,
|
||||
|
||||
@ -44,7 +44,7 @@
|
||||
'$show_frozen'(_,_,[]).
|
||||
|
||||
|
||||
'$convert_to_list_of_frozen_goals'(LIV,LAV,G,NLG) :-
|
||||
'$convert_to_list_of_frozen_goals'(LIV,LAV,_,NLG) :-
|
||||
'$project'(LAV,LIV,NLG).
|
||||
|
||||
|
||||
@ -620,7 +620,7 @@ call_residue(Goal,Residue) :-
|
||||
'$project'([],_,[]).
|
||||
'$project'(Vs,_,LGs) :-
|
||||
% we don't have constraints yet, so we must be talking about delays.
|
||||
'$undefined'(modules_with_attributes(LAV),attributes), !,
|
||||
'$undefined'(modules_with_attributes(_),attributes), !,
|
||||
'$fetch_delays'(Vs, LGs, []).
|
||||
'$project'([V|LAV],LIV,LDs) :-
|
||||
attvar(V), !,
|
||||
@ -654,7 +654,7 @@ call_residue(Goal,Residue) :-
|
||||
'$undefined'(convert_att_var(Vs,LIV),attributes), !.
|
||||
'$convert_att_vars'(Vs0, LIV, LGs) :-
|
||||
'$sort'(Vs0, Vs),
|
||||
'$do_convert_att_vars'(Vs0, LIV, LGs).
|
||||
'$do_convert_att_vars'(Vs, LIV, LGs).
|
||||
|
||||
'$do_convert_att_vars'([], _, []).
|
||||
'$do_convert_att_vars'([V|LAV], LIV, NGs) :-
|
||||
@ -695,7 +695,7 @@ call_residue(Goal,Residue) :-
|
||||
'$frozen_goals'(V,G), !,
|
||||
'$hole_in_frozen_goals'(G,GF,G1),
|
||||
'$do_fetch_delays'(NLAV, G1).
|
||||
'$do_fetch_delays'([V|NLAV], GF) :-
|
||||
'$do_fetch_delays'([_|NLAV], GF) :-
|
||||
'$do_fetch_delays'(NLAV, GF).
|
||||
|
||||
|
||||
|
||||
32
pl/debug.yap
32
pl/debug.yap
@ -47,11 +47,13 @@
|
||||
% just check one such predicate exists
|
||||
(
|
||||
current_predicate(A,M:_)
|
||||
->
|
||||
M = EM
|
||||
;
|
||||
recorded('$import','$import'(EM,M,A,_),_)
|
||||
),
|
||||
!,
|
||||
'$do_suspy_predicates_by_name'(A,S,M).
|
||||
'$do_suspy_predicates_by_name'(A,S,EM).
|
||||
'$suspy_predicates_by_name'(A,spy,M) :- !,
|
||||
'$print_message'(warning,no_match(spy(M:A))).
|
||||
'$suspy_predicates_by_name'(A,nospy,M) :-
|
||||
@ -82,7 +84,7 @@
|
||||
).
|
||||
'$do_suspy'(S, F, N, T, M) :-
|
||||
'$system_predicate'(T,M),
|
||||
'$flags'(T,Mod,F,F),
|
||||
'$flags'(T,M,F,F),
|
||||
F /\ 0x118dd080 =\= 0,
|
||||
( S = spy ->
|
||||
'$do_error'(permission_error(access,private_procedure,T),spy(M:F/N))
|
||||
@ -291,7 +293,7 @@ debugging :-
|
||||
;
|
||||
'$do_spy'(B, M, CP, InControl)
|
||||
).
|
||||
'$do_spy'((T->A), M, CP, InControl) :- !,
|
||||
'$do_spy'((T->A), M, CP, _) :- !,
|
||||
( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ).
|
||||
'$do_spy'((A;B), M, CP, InControl) :- !,
|
||||
(
|
||||
@ -307,7 +309,7 @@ debugging :-
|
||||
).
|
||||
'$do_spy'((\+G), M, CP, InControl) :- !,
|
||||
\+ '$do_spy'(G, M, CP, InControl).
|
||||
'$do_spy'((not(G)), M, InControl) :- !,
|
||||
'$do_spy'((not(G)), M, CP, InControl) :- !,
|
||||
\+ '$do_spy'(G, M, CP, InControl).
|
||||
'$do_spy'(G, Module, _, InControl) :-
|
||||
get_value(spy_gn,L), /* get goal no. */
|
||||
@ -335,7 +337,7 @@ debugging :-
|
||||
'$loop_fail'(GoalNumber, G, Module, InControl).
|
||||
'$loop_spy_event'('$fail_spy'(GoalNumber), _, _, _, _) :- !,
|
||||
throw('$fail_spy'(GoalNumber)).
|
||||
'$loop_spy_event'('$done_spy'(G0), GoalNumber, G, Module, InControl) :-
|
||||
'$loop_spy_event'('$done_spy'(G0), GoalNumber, _, _, _) :-
|
||||
G0 >= GoalNumber, !,
|
||||
'$continue_debugging'.
|
||||
'$loop_spy_event'('$done_spy'(GoalNumber), _, _, _, _) :- !,
|
||||
@ -404,7 +406,7 @@ debugging :-
|
||||
'$show_trace'(P,G,Module,GoalNumber) :-
|
||||
'$trace'(P,G,Module,GoalNumber).
|
||||
|
||||
'$avoid_goal'(GoalNumber, G, Module) :-
|
||||
'$avoid_goal'(_, _, _) :-
|
||||
\+ recorded('$debug',on,_), !.
|
||||
'$avoid_goal'(GoalNumber, G, Module) :-
|
||||
recorded('$spy_skip', Value, _),
|
||||
@ -445,7 +447,7 @@ debugging :-
|
||||
'$spycall'(G, M, InControl) :-
|
||||
% I lost control here.
|
||||
CP is '$last_choice_pt',
|
||||
'$static_clause'(G,M,C,R),
|
||||
'$static_clause'(G,M,_,R),
|
||||
'$continue_debugging'(InControl, G, M),
|
||||
'$execute_clause'(G, M, R, CP).
|
||||
|
||||
@ -456,7 +458,9 @@ debugging :-
|
||||
repeat,
|
||||
(P = exit, \+ '$debugger_deterministic_goal'(G) -> Det = '?' ; Det = ''),
|
||||
('$pred_being_spied'(G,Module) -> CSPY = '*' ; CSPY = ' '),
|
||||
( SL = L -> SLL = '>' ; SLL = ' '),
|
||||
% vsc: fix this
|
||||
% ( SL = L -> SLL = '>' ; SLL = ' '),
|
||||
SLL = ' ',
|
||||
( recorded('$debug',on, R), erase(R), fail ; true),
|
||||
( Module\=prolog,
|
||||
Module\=user ->
|
||||
@ -570,7 +574,7 @@ debugging :-
|
||||
'$set_yap_flags'(10,0).
|
||||
% skip first call (for current goal),
|
||||
% stop next time.
|
||||
'$action'(0'r,P,CallId,_,_) :- !, % r retry
|
||||
'$action'(0'r,_,CallId,_,_) :- !, % r retry
|
||||
'$scan_number'(0'r,CallId,ScanNumber),
|
||||
throw('$retry_spy'(ScanNumber)).
|
||||
'$action'(0's,P,CallNumber,_,_) :- !, % s skip
|
||||
@ -606,10 +610,10 @@ debugging :-
|
||||
|
||||
% if we are in the interpreter, don't need to care about forcing a trace, do we?
|
||||
'$continue_debugging'(no,_,_) :- !.
|
||||
'$continue_debugging'(Flag,G,M) :-
|
||||
'$continue_debugging'(_,G,M) :-
|
||||
'$system_predicate'(G,M), !,
|
||||
( '$access_yap_flags'(10,1) -> '$late_creep' ; true).
|
||||
'$continue_debugging'(Flag,_,_) :-
|
||||
'$continue_debugging'(_,_,_) :-
|
||||
'$continue_debugging'.
|
||||
|
||||
'$continue_debugging' :-
|
||||
@ -749,8 +753,8 @@ debugging :-
|
||||
format(user_error,' [~d] ',[Level]),
|
||||
'$debugger_write'(user_error,Goal),
|
||||
nl(user_error).
|
||||
'$continue_debug_show_cp'(Module,Name,Arity,Goal,_) :-
|
||||
functor(G0, Name, Arity), fail,
|
||||
'$continue_debug_show_cp'(Module,Name,Arity,_,_) :-
|
||||
functor(G0, Name, Arity),
|
||||
'$hidden_predicate'(G0,Module),
|
||||
!.
|
||||
'$continue_debug_show_cp'(Module,Name,Arity,Goal,Level) :-
|
||||
@ -759,7 +763,7 @@ debugging :-
|
||||
'$continue_debug_show_cp'(Module,Name,Arity,(V1;V2),Level) :-
|
||||
var(V1), var(V2), !,
|
||||
format(user_error,' [~d] ~q:~q/~d: ;/2~n',[Level,Module,Name,Arity]).
|
||||
'$continue_debug_show_cp'(Module,Name,Arity,G,Level) :-
|
||||
'$continue_debug_show_cp'(_,_,_,G,Level) :-
|
||||
format(user_error,' [~d] ~q~n',[Level,G]).
|
||||
|
||||
'$debugger_deterministic_goal'(G) :-
|
||||
|
||||
@ -89,7 +89,7 @@
|
||||
'$exec_directive'(set_prolog_flag(F,V), _, _) :-
|
||||
set_prolog_flag(F,V).
|
||||
'$exec_directive'(ensure_loaded(Fs), _, M) :-
|
||||
'$load_files'(Fs, [if(changed)],ensure_loaded(Fs)).
|
||||
'$load_files'(M:Fs, [if(changed)], ensure_loaded(Fs)).
|
||||
'$exec_directive'(char_conversion(IN,OUT), _, _) :-
|
||||
char_conversion(IN,OUT).
|
||||
'$exec_directive'(public(P), _, M) :-
|
||||
|
||||
@ -48,7 +48,7 @@
|
||||
|
||||
'$t_hlist'(V, _, _, _, G0) :- var(V), !,
|
||||
'$do_error'(instantiation_error,G0).
|
||||
'$t_hlist'([], S0, SR, true, _).
|
||||
'$t_hlist'([], _, _, true, _).
|
||||
'$t_hlist'([H], S0, SR, ('C'(SR,H,S0)), _) :- !.
|
||||
'$t_hlist'([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !,
|
||||
'$t_hlist'(List, S0, S1, G0, Goal).
|
||||
@ -80,7 +80,7 @@
|
||||
'$t_body'((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
|
||||
'$t_body'(T, ToFill, not_last, S, SR1, Tt),
|
||||
'$t_body'(R, ToFill, Last, SR1, SR, Rt).
|
||||
'$t_body'(\+T, ToFill, Last, S, SR, (Tt->fail ; S=SR)) :- !,
|
||||
'$t_body'(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !,
|
||||
'$t_body'(T, ToFill, not_last, S, _, Tt).
|
||||
'$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
|
||||
'$t_body'(T, _, last, S, SR, Tt),
|
||||
|
||||
@ -77,17 +77,17 @@ portray_clause(_).
|
||||
'$portray_clause'(Stream, (Pred :- true)) :- !,
|
||||
'$beautify_vars'(Pred),
|
||||
writeq(Stream, Pred),
|
||||
format(Stream, ".~n", []).
|
||||
format(Stream, '.~n', []).
|
||||
'$portray_clause'(Stream, (Pred:-Body)) :- !,
|
||||
'$beautify_vars'((Pred:-Body)),
|
||||
writeq(Stream, Pred),
|
||||
format(Stream, " :-", []),
|
||||
format(Stream, ' :-', []),
|
||||
'$write_body'(Body, 3, ',', Stream),
|
||||
format(Stream, ".~n", []).
|
||||
format(Stream, '.~n', []).
|
||||
'$portray_clause'(Stream, Pred) :- !,
|
||||
'$beautify_vars'(Pred),
|
||||
writeq(Stream, Pred),
|
||||
format(Stream, ".~n", []).
|
||||
format(Stream, '.~n', []).
|
||||
|
||||
'$write_body'(X,I,T,Stream) :- var(X), !,
|
||||
'$beforelit'(T,I,Stream),
|
||||
@ -95,44 +95,44 @@ portray_clause(_).
|
||||
'$write_body'((P,Q), I, T, Stream) :-
|
||||
!,
|
||||
'$write_body'(P,I,T, Stream),
|
||||
put(Stream, ","),
|
||||
put(Stream, ','),
|
||||
'$write_body'(Q,I,',',Stream).
|
||||
'$write_body'((P->Q;S),I,_, Stream) :-
|
||||
!,
|
||||
format(Stream, "~n~*c(",[I,0' ]),
|
||||
format(Stream, '~n~*c(',[I,0' ]),
|
||||
I1 is I+2,
|
||||
'$write_body'(P,I1,'(',Stream),
|
||||
format(Stream, " ->",[]),
|
||||
format(Stream, ' ->',[]),
|
||||
'$write_disj'((Q;S),I,I1,'->',Stream),
|
||||
format(Stream, "~n~*c)",[I,0' ]).
|
||||
format(Stream, '~n~*c)',[I,0' ]).
|
||||
'$write_body'((P->Q|S),I,_,Stream) :-
|
||||
!,
|
||||
format(Stream, "~n~*c(",[I,0' ]),
|
||||
format(Stream, '~n~*c(',[I,0' ]),
|
||||
I1 is I+2,
|
||||
'$write_body'(P,I,'(',Stream),
|
||||
format(Stream, " ->",[]),
|
||||
format(Stream, ' ->',[]),
|
||||
'$write_disj'((Q|S),I,I1,'->',Stream),
|
||||
format(Stream, "~n~*c)",[I,0' ]).
|
||||
format(Stream, '~n~*c)',[I,0' ]).
|
||||
'$write_body'((P->Q),I,_,Stream) :-
|
||||
!,
|
||||
format(Stream, "~n~*c(",[I,0' ]),
|
||||
format(Stream, '~n~*c(',[I,0' ]),
|
||||
I1 is I+2,
|
||||
'$write_body'(P,I1,'(',Stream),
|
||||
format(Stream, " ->",[]),
|
||||
format(Stream, ' ->',[]),
|
||||
'$write_body'(Q,I1,'->',Stream),
|
||||
format(Stream, "~n~*c)",[I,0' ]).
|
||||
format(Stream, '~n~*c)',[I,0' ]).
|
||||
'$write_body'((P;Q),I,_,Stream) :-
|
||||
!,
|
||||
format(Stream, "~n~*c(",[I,0' ]),
|
||||
format(Stream, '~n~*c(',[I,0' ]),
|
||||
I1 is I+2,
|
||||
'$write_disj'((P;Q),I,I1,'->',Stream),
|
||||
format(Stream, "~n~*c)",[I,0' ]).
|
||||
format(Stream, '~n~*c)',[I,0' ]).
|
||||
'$write_body'((P|Q),I,_,Stream) :-
|
||||
!,
|
||||
format(Stream, "~n~*c(",[I,0' ]),
|
||||
format(Stream, '~n~*c(',[I,0' ]),
|
||||
I1 is I+2,
|
||||
'$write_disj'((P|Q),I,I1,'->',Stream),
|
||||
format(Stream, "~n~*c)",[I,0' ]).
|
||||
format(Stream, '~n~*c)',[I,0' ]).
|
||||
'$write_body'(X,I,T,Stream) :-
|
||||
'$beforelit'(T,I,Stream),
|
||||
writeq(Stream,X).
|
||||
@ -140,18 +140,18 @@ portray_clause(_).
|
||||
|
||||
'$write_disj'((Q;S),I0,I,C,Stream) :- !,
|
||||
'$write_body'(Q,I,C,Stream),
|
||||
format(Stream, "~n~*c;",[I0,0' ]),
|
||||
format(Stream, '~n~*c;',[I0,0' ]),
|
||||
'$write_disj'(S,I0,I,';',Stream).
|
||||
'$write_disj'((Q|S),I0,I,C,Stream) :- !,
|
||||
'$write_body'(Q,I,C,Stream),
|
||||
format(Stream, "~n~*c|",[I0,0' ]),
|
||||
format(Stream, '~n~*c|',[I0,0' ]),
|
||||
'$write_disj'(S,I0,I,'|',Stream).
|
||||
'$write_disj'(S,I0,I,C,Stream) :-
|
||||
'$write_disj'(S,_,I,C,Stream) :-
|
||||
'$write_body'(S,I,C,Stream).
|
||||
|
||||
|
||||
'$beforelit'('(',_,Stream) :- !, format(Stream," ",[]).
|
||||
'$beforelit'(_,I,Stream) :- format(Stream,"~n~*c",[I,0' ]).
|
||||
'$beforelit'('(',_,Stream) :- !, format(Stream,' ',[]).
|
||||
'$beforelit'(_,I,Stream) :- format(Stream,'~n~*c',[I,0' ]).
|
||||
|
||||
'$beautify_vars'(T) :-
|
||||
'$list_get_vars'(T,[],L),
|
||||
|
||||
@ -76,7 +76,7 @@ module(N) :-
|
||||
'$do_error'(type_error(atom,N),module(N)).
|
||||
|
||||
'$module_dec'(N,P) :-
|
||||
'$current_module'(Old,N),
|
||||
'$current_module'(_,N),
|
||||
get_value('$consulting_file',F),
|
||||
'$add_module_on_file'(N, F, P).
|
||||
|
||||
@ -90,16 +90,16 @@ module(N) :-
|
||||
'$process_exports'([],_,[]).
|
||||
'$process_exports'([Name/Arity|Exports],Mod,[Name/Arity|ExportedPreds]):- !,
|
||||
'$process_exports'(Exports,Mod,ExportedPreds).
|
||||
'$process_exports'([op(Prio,Assoc,Name)|Exports],Mod,ExportedPreds) :- !,
|
||||
% '$opdec'(Prio,Assoc,Name,Mod),
|
||||
'$process_exports'([op(_Prio,_Assoc,_Name)|Exports],Mod,ExportedPreds) :- !,
|
||||
% '$opdec'(_Prio,_Assoc,_Name,Mod),
|
||||
'$process_exports'(Exports,Mod,ExportedPreds).
|
||||
'$process_exports'([Trash|Exports],Mod,_) :-
|
||||
'$process_exports'([Trash|_],Mod,_) :-
|
||||
'$do_error'(type_error(predicate_indicator,Trash),module(Mod,[Trash])).
|
||||
|
||||
% redefining a previously-defined file, no problem.
|
||||
'$add_preexisting_module_on_file'(F, F, Mod, Exports, R) :- !,
|
||||
erase(R),
|
||||
( recorded('$import','$import'(M,T,_,_),R), erase(R), fail; true),
|
||||
( recorded('$import','$import'(Mod,_,_,_),R), erase(R), fail; true),
|
||||
recorda('$module','$module'(F,Mod,Exports),_).
|
||||
'$add_preexisting_module_on_file'(F,F0,Mod,Exports,R) :-
|
||||
repeat,
|
||||
@ -129,13 +129,13 @@ module(N) :-
|
||||
true
|
||||
),
|
||||
'$import'(L,M,T).
|
||||
'$import'([PS|L],M,T) :-
|
||||
'$import'([PS|L],_,_) :-
|
||||
'$do_error'(domain_error(predicate_spec,PS),import([PS|L])).
|
||||
|
||||
'$check_import'(M,T,N,K) :-
|
||||
recorded('$import','$import'(MI,T,N,K),_),
|
||||
recorded('$import','$import'(MI,T,N,K),R),
|
||||
\+ '$module_produced by'(M,T,N,K), !,
|
||||
format(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[M1:N/K,T]),
|
||||
format(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[MI:N/K,T]),
|
||||
format(user_error," Do you want to import it from ~w ? [y or n] ",M),
|
||||
repeat,
|
||||
get0(C), '$skipeol'(C),
|
||||
|
||||
42
pl/preds.yap
42
pl/preds.yap
@ -45,7 +45,7 @@ assert(C) :-
|
||||
'$assert'(H,M1,Where,R,_) :-
|
||||
'$assert_fact'(H, M1, Where, R).
|
||||
|
||||
'$assert_clause'(H, G, M1, Where, R, P) :-
|
||||
'$assert_clause'(H, _, _, _, _, P) :-
|
||||
var(H), !, '$do_error'(instantiation_error,P).
|
||||
'$assert_clause'(M1:C, G, M1, Where, R, P) :- !,
|
||||
'$assert_clause2'(C, G, M1, Where, R, P).
|
||||
@ -72,7 +72,7 @@ assert(C) :-
|
||||
'$assert1'(Where,H,H,Mod,H)
|
||||
;
|
||||
functor(H, Na, Ar),
|
||||
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
|
||||
'$do_error'(permission_error(modify,static_procedure,Na/Ar),Mod:assert(H))
|
||||
).
|
||||
|
||||
|
||||
@ -216,8 +216,8 @@ assertz_static(C) :-
|
||||
true
|
||||
).
|
||||
|
||||
'$assert1'(last,C,C0,Mod,H) :- '$compile'(C,0,C0,Mod).
|
||||
'$assert1'(first,C,C0,Mod,H) :- '$compile'(C,2,C0,Mod).
|
||||
'$assert1'(last,C,C0,Mod,_) :- '$compile'(C,0,C0,Mod).
|
||||
'$assert1'(first,C,C0,Mod,_) :- '$compile'(C,2,C0,Mod).
|
||||
|
||||
'$assertz_dynamic'(X, C, C0, Mod) :- (X/\4)=:=0, !,
|
||||
'$head_and_body'(C,H,B),
|
||||
@ -273,7 +273,7 @@ clause(M:P,Q) :- !,
|
||||
'$clause'(P,M,Q,_).
|
||||
clause(V,Q) :-
|
||||
'$current_module'(M),
|
||||
'$clause'(V,M,Q,R).
|
||||
'$clause'(V,M,Q,_).
|
||||
|
||||
'$clause'(V,M,Q) :- var(V), !,
|
||||
'$do_error'(instantiation_error,M:clause(V,Q)).
|
||||
@ -332,26 +332,26 @@ clause(V,Q,R) :-
|
||||
'$do_log_upd_clause'(_,_,_,_,_).
|
||||
'$do_log_upd_clause'(A,B,C,D,E) :-
|
||||
'$continue_log_update_clause'(A,B,C,D,E).
|
||||
'$do_log_upd_clause'(A,B,C,D,E).
|
||||
'$do_log_upd_clause'(_,_,_,_,_).
|
||||
|
||||
:- '$do_log_upd_clause'(_,_,_,_,_), !.
|
||||
|
||||
'$do_log_upd_clause'(_,_,_,_).
|
||||
'$do_log_upd_clause'(A,B,C,D) :-
|
||||
'$continue_log_update_clause'(A,B,C,D).
|
||||
'$do_log_upd_clause'(A,B,C,D).
|
||||
'$do_log_upd_clause'(_,_,_,_).
|
||||
|
||||
:- '$do_log_upd_clause'(_,_,_,_), !.
|
||||
|
||||
'$do_static_clause'(_,_,_,_,_).
|
||||
'$do_static_clause'(A,B,C,D,E) :-
|
||||
'$continue_static_clause'(A,B,C,D,E).
|
||||
'$do_static_clause'(A,B,C,D,E).
|
||||
'$do_static_clause'(_,_,_,_,_).
|
||||
|
||||
:- '$do_static_clause'(_,_,_,_,_), !.
|
||||
|
||||
nth_clause(V,I,R) :- var(V), var(R), !,
|
||||
'$do_error'(instantiation_error,M:nth_clause(V,I,R)).
|
||||
'$do_error'(instantiation_error,nth_clause(V,I,R)).
|
||||
nth_clause(M:V,I,R) :- !,
|
||||
'$nth_clause'(V,M,I,R).
|
||||
nth_clause(V,I,R) :-
|
||||
@ -373,7 +373,7 @@ nth_clause(V,I,R) :-
|
||||
( '$is_log_updatable'(P,M) ; '$is_source'(P,M) ), !,
|
||||
'$p_nth_clause'(P,M,I,R).
|
||||
'$nth_clause'(P,M,I,R) :-
|
||||
'$is_dynamic'(H,M), !,
|
||||
'$is_dynamic'(P,M), !,
|
||||
'$nth_instancep'(M:P,I,R).
|
||||
'$nth_clause'(P,M,I,R) :-
|
||||
( '$system_predicate'(P,M) -> true ;
|
||||
@ -383,7 +383,7 @@ nth_clause(V,I,R) :-
|
||||
nth_clause(M:P,I,R)).
|
||||
|
||||
'$nth_clause_ref'(Cl,M,I,R) :-
|
||||
'$pred_for_code'(R, At, Ar, M1, I), I > 0, !,
|
||||
'$pred_for_code'(R, _, _, M1, I), I > 0, !,
|
||||
instance(R, Cl),
|
||||
M1 = M.
|
||||
'$nth_clause_ref'(P,M,I,R) :-
|
||||
@ -411,7 +411,7 @@ retract(C) :-
|
||||
'$retract2'(H,M,B) :-
|
||||
'$is_dynamic'(H,M), !,
|
||||
'$recordedp'(M:H,(H:-B),R), erase(R).
|
||||
'$retract2'(H,M,B) :-
|
||||
'$retract2'(H,M,_) :-
|
||||
'$undefined'(H,M), !,
|
||||
functor(H,Na,Ar),
|
||||
'$dynamic'(Na/Ar,M),
|
||||
@ -440,8 +440,8 @@ retract(C,R) :-
|
||||
var(R),
|
||||
'$recordedp'(M:H,(H:-B),R),
|
||||
erase(R).
|
||||
'$retract'(C,M,_) :-
|
||||
'$check_head_and_body'(C,H,B,retract(M:C,R)),
|
||||
'$retract'(C,M,R) :-
|
||||
'$check_head_and_body'(C,H,_,retract(M:C,R)),
|
||||
'$undefined'(H,M), !,
|
||||
functor(H,Na,Ar),
|
||||
'$dynamic'(Na/Ar,M),
|
||||
@ -773,7 +773,7 @@ hide_predicate(P) :-
|
||||
functor(S,N,A),
|
||||
'$hide_predicate'(S, M) .
|
||||
'$hide_predicate2'(PredDesc, M) :-
|
||||
'$do_error'(type_error(predicate_indicator,T),hide_predicate(M:PredDesc)).
|
||||
'$do_error'(type_error(predicate_indicator,PredDesc),hide_predicate(M:PredDesc)).
|
||||
|
||||
predicate_property(Mod:Pred,Prop) :- !,
|
||||
'$predicate_property2'(Pred,Prop,Mod).
|
||||
@ -805,10 +805,10 @@ predicate_property(Pred,Prop) :-
|
||||
'$predicate_property'(P,M,_,built_in) :-
|
||||
'$system_predicate'(P,M), !.
|
||||
'$predicate_property'(P,M,_,source) :-
|
||||
'$flags'(G,M,F,F),
|
||||
'$flags'(P,M,F,F),
|
||||
F /\ 0x00400000 =\= 0.
|
||||
'$predicate_property'(P,M,_,tabled) :-
|
||||
'$flags'(G,M,F,F),
|
||||
'$flags'(P,M,F,F),
|
||||
F /\ 0x00000040 =\= 0.
|
||||
'$predicate_property'(P,M,_,dynamic) :-
|
||||
'$is_dynamic'(P,M).
|
||||
@ -842,11 +842,11 @@ predicate_statistics(P,NCls,Sz,ISz) :-
|
||||
'$predicate_statistics'(P,M,NCls,Sz,ISz).
|
||||
|
||||
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
|
||||
'$is_dynamic'(H, M), !,
|
||||
'$key_statistics'(M:H,NCls,Sz,ISz).
|
||||
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
|
||||
'$is_dynamic'(P, M), !,
|
||||
'$key_statistics'(M:P,NCls,Sz,ISz).
|
||||
'$predicate_statistics'(P,M,_,_,_) :-
|
||||
'$system_predicate'(P,M), !, fail.
|
||||
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
|
||||
'$predicate_statistics'(P,M,_,_,_) :-
|
||||
'$undefined'(P,M), !, fail.
|
||||
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
|
||||
'$static_pred_statistics'(P,M,NCls,Sz,ISz).
|
||||
|
||||
@ -17,7 +17,7 @@
|
||||
|
||||
:- meta_predicate profile_data(:,+,-).
|
||||
|
||||
profile_data(M:D, Parm, Data) :- P = M:D, !,
|
||||
profile_data(M:D, Parm, Data) :-!,
|
||||
(
|
||||
var(M) ->
|
||||
'$do_error'(instantiation_error,profile_data(M:D, Parm, Data))
|
||||
@ -70,7 +70,7 @@ showprofres :-
|
||||
('$profison' -> profoff, Stop = true ; Stop = false),
|
||||
'$profglobs'(Tot,GCs,HGrows,SGrows,Mallocs,ProfOns),
|
||||
% root node has no useful info.
|
||||
'$get_all_profinfo'(0,[],ProfInfo0,0,TotCode),
|
||||
'$get_all_profinfo'(0,[],ProfInfo0,0,_TotCode),
|
||||
msort(ProfInfo0,ProfInfo),
|
||||
'$get_ppreds'(ProfInfo,Preds0),
|
||||
'$add_extras_prof'(GCs, HGrows, SGrows, Mallocs, Preds0, PredsI),
|
||||
@ -105,7 +105,7 @@ showprofres :-
|
||||
'$get_ppreds'([],[]).
|
||||
'$get_ppreds'([gprof(0,_,0)|Cls],Ps) :- !,
|
||||
'$get_ppreds'(Cls,Ps).
|
||||
'$get_ppreds'([gprof(0,_,Count)|Cls],Ps) :- !,
|
||||
'$get_ppreds'([gprof(0,_,Count)|_],_) :- !,
|
||||
'$do_error'(system_error,showprofres(gprof(0,_,Count))).
|
||||
'$get_ppreds'([gprof(PProfInfo,_,Count0)|Cls],[Sum-(Mod:Name/Arity)|Ps]) :-
|
||||
'$get_more_ppreds'(Cls,PProfInfo,Count0,NCls,Sum),
|
||||
|
||||
@ -72,8 +72,7 @@ findall(Template, Generator, Answers, SoFar) :-
|
||||
'$db_dequeue'(Ref, Term), !,
|
||||
Out = [Term|Answers],
|
||||
'$collect_for_findall'(Ref, SoFar, Answers).
|
||||
'$collect_for_findall'(Ref, SoFar, SoFar) :-
|
||||
Out = SoFar.
|
||||
'$collect_for_findall'(_, SoFar, SoFar).
|
||||
|
||||
% findall_with_key is very similar to findall, but uses the SICStus
|
||||
% algorithm to guarantee that variables will have the same names.
|
||||
@ -222,7 +221,7 @@ all(T,G,S) :-
|
||||
'$$build2'([X|Ns],Hash,R,X) :-
|
||||
'$$new'(Hash,X), !,
|
||||
'$$build'(Ns,Hash,R).
|
||||
'$$build2'(Ns,Hash,R,X) :-
|
||||
'$$build2'(Ns,Hash,R,_) :-
|
||||
'$$build'(Ns,Hash,R).
|
||||
|
||||
'$$new'(V,El) :- var(V), !, V = n(_,El,_).
|
||||
|
||||
@ -43,12 +43,13 @@
|
||||
'$do_signal'(sig_delay_creep, [M|G]) :-
|
||||
'$execute'(M:G),
|
||||
'$creep'.
|
||||
'$do_signal'(sig_iti, G) :-
|
||||
'$do_signal'(sig_iti, [M|G]) :-
|
||||
'$thread_gfetch'(Goal),
|
||||
% if more signals alive, set creep flag
|
||||
'$continue_signals',
|
||||
'$current_module'(M0),
|
||||
'$execute0'(G,M0).
|
||||
'$execute0'(Goal,M0),
|
||||
'$execute'(M:G).
|
||||
'$do_signal'(sig_trace, [M|G]) :-
|
||||
'$continue_signals',
|
||||
trace,
|
||||
@ -121,7 +122,7 @@ on_signal(Signal,OldAction,default) :-
|
||||
'$reset_signal'(Signal, OldAction).
|
||||
on_signal(Signal,OldAction,Action) :-
|
||||
var(Action), !,
|
||||
'$check_signal'(OldAction),
|
||||
'$check_signal'(Signal, OldAction),
|
||||
Action = OldAction.
|
||||
on_signal(Signal,OldAction,Action) :-
|
||||
'$reset_signal'(Signal, OldAction),
|
||||
@ -135,7 +136,7 @@ on_signal(Signal,OldAction,Action) :-
|
||||
|
||||
'$check_signal'(Signal, OldAction) :-
|
||||
recorded('$signal_handler', action(Signal,OldAction), _), !.
|
||||
'$reset_signal'(_, default).
|
||||
'$check_signal'(_, default).
|
||||
|
||||
|
||||
alarm(Interval, Goal, Left) :-
|
||||
|
||||
@ -125,7 +125,7 @@ tabling_mode(Pred,Options) :-
|
||||
'$set_tabling_mode'(Mod,PredFunctor,Options) :-
|
||||
var(Options), !,
|
||||
'$c_tabling_mode'(Mod,PredFunctor,Options).
|
||||
'$set_tabling_mode'(Mod,PredFunctor,[]) :- !.
|
||||
'$set_tabling_mode'(_,_,[]) :- !.
|
||||
'$set_tabling_mode'(Mod,PredFunctor,[HOption|TOption]) :- !,
|
||||
'$set_tabling_mode'(Mod,PredFunctor,HOption),
|
||||
'$set_tabling_mode'(Mod,PredFunctor,TOption).
|
||||
|
||||
@ -91,7 +91,7 @@ thread_create(Goal, Id, Options) :-
|
||||
( \+ integer(Stack) -> '$do_error'(type_error(integer,Stack),G0) ; true ).
|
||||
'$thread_option'(trail(Trail), Aliases, _, Trail, _, _, G0, Aliases) :- !,
|
||||
( \+ integer(Trail) -> '$do_error'(type_error(integer,Trail),G0) ; true ).
|
||||
'$thread_option'(system(Trail), Aliases, _, _, System, _, G0, Aliases) :- !,
|
||||
'$thread_option'(system(System), Aliases, _, _, System, _, G0, Aliases) :- !,
|
||||
( \+ integer(System) -> '$do_error'(type_error(integer,System),G0) ; true ).
|
||||
'$thread_option'(alias(Alias), [Alias|Aliases], _, _, _, _, G0, Aliases) :- !,
|
||||
( \+ atom(Alias) -> '$do_error'(type_error(atom,Alias),G0) ; true ).
|
||||
@ -103,8 +103,8 @@ thread_create(Goal, Id, Options) :-
|
||||
'$thread_ground_stacks'(0) :- !.
|
||||
'$thread_ground_stacks'(_).
|
||||
|
||||
'$add_thread_aliases'([Alias|Aliases], Id) :-
|
||||
recorded('$thread_alias',[Id0|Alias],_), !,
|
||||
'$add_thread_aliases'([Alias|_], Id) :-
|
||||
recorded('$thread_alias',[_|Alias],_), !,
|
||||
'$do_error'(permission_error(alias,new,Alias),thread_create_alias(Id,Alias)).
|
||||
'$add_thread_aliases'([Alias|Aliases], Id) :-
|
||||
recorda('$thread_alias',[Id|Alias],_),
|
||||
@ -315,7 +315,7 @@ message_queue_destroy(Queue) :-
|
||||
'$clean_mqueue'(CName).
|
||||
message_queue_destroy(Queue) :-
|
||||
atom(Queue), !,
|
||||
'$do_error'(existence_error(queue,Queue),message_queue_destroy(QUeue)).
|
||||
'$do_error'(existence_error(queue,Queue),message_queue_destroy(Queue)).
|
||||
message_queue_destroy(Name) :-
|
||||
'$do_error'(type_error(atom,Name),message_queue_destroy(Name)).
|
||||
|
||||
|
||||
14
pl/utils.yap
14
pl/utils.yap
@ -242,9 +242,9 @@ unix(putenv(X,Y)) :- '$putenv'(X,Y).
|
||||
'$is_list_of_atoms'(H,L0) :-
|
||||
'$do_error'(type_error(list,H),unix(argv(L0))).
|
||||
|
||||
'$check_if_head_may_be_atom'(H,L0) :-
|
||||
'$check_if_head_may_be_atom'(H,_) :-
|
||||
var(H), !.
|
||||
'$check_if_head_may_be_atom'(H,L0) :-
|
||||
'$check_if_head_may_be_atom'(H,_) :-
|
||||
atom(H), !.
|
||||
'$check_if_head_may_be_atom'(H,L0) :-
|
||||
'$do_error'(type_error(atom,H),unix(argv(L0))).
|
||||
@ -456,7 +456,7 @@ unknown(V0,V) :-
|
||||
'$unknown_warning'(Mod:Goal) :-
|
||||
functor(Goal,Name,Arity),
|
||||
'$program_continuation'(PMod,PName,PAr),
|
||||
'$print_message'(error,error(existence_error(procedure,Name/Ar), context(Mod:Goal,PMod:PName/PAr))),
|
||||
'$print_message'(error,error(existence_error(procedure,Name/Arity), context(Mod:Goal,PMod:PName/PAr))),
|
||||
fail.
|
||||
|
||||
%%% Some "dirty" predicates
|
||||
@ -585,7 +585,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
|
||||
Total >= After,
|
||||
atom_codes(SubAt,SubAts).
|
||||
% SubAt, Size, and After are unbound.
|
||||
'$sub_atom3'(Size, After, SubAt, Atl, ErrorTerm) :-
|
||||
'$sub_atom3'(Size, After, SubAt, Atl, _) :-
|
||||
'$$_length1'(Atl,0,Len),
|
||||
'$sub_atom_split'(Atl,Len,SubAts,Size,_,After),
|
||||
atom_codes(SubAt,SubAts).
|
||||
@ -608,7 +608,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
|
||||
'$sub_atom_split'(SubAt0,Size0,_,Bef,SubAts,Size),
|
||||
atom_codes(SubAt,SubAts).
|
||||
% ok: just do everything
|
||||
'$sub_atombv'(Bef, Size, After, SubAt, Atl, ErrorTerm) :-
|
||||
'$sub_atombv'(Bef, Size, After, SubAt, Atl, _) :-
|
||||
'$$_length1'(Atl, 0, Len),
|
||||
'$sub_atom_split'(Atl,Len,_,Bef,Atls2,Len2),
|
||||
'$sub_atom_split'(Atls2,Len2,SubAts,Size,_,After),
|
||||
@ -646,7 +646,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
|
||||
N is N1-1,
|
||||
'$sub_atom_check_length'(L,N).
|
||||
|
||||
'$sub_atom_get_last_subchars'([],[],After,0,0).
|
||||
'$sub_atom_get_last_subchars'([],[],_,0,0).
|
||||
'$sub_atom_get_last_subchars'([C|Atl],SubAt,After,Total,Size) :-
|
||||
'$sub_atom_get_last_subchars'(Atl,SubAt0,After,Total0,Size0),
|
||||
Total is Total0+1,
|
||||
@ -670,7 +670,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
|
||||
'$do_error'(type_error(integer,I),ErrorTerm).
|
||||
|
||||
'$sub_atom_needs_atom'(V,_) :- var(V), !.
|
||||
'$sub_atom_needs_atom'(A,ErrorTerm) :- atom(A), !.
|
||||
'$sub_atom_needs_atom'(A,_) :- atom(A), !.
|
||||
'$sub_atom_needs_atom'(A,ErrorTerm) :-
|
||||
'$do_error'(type_error(atom,A),ErrorTerm).
|
||||
|
||||
|
||||
Reference in New Issue
Block a user