diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
5d27ad0243
yap-6.3/pl/preds.yap
Vítor Santos Costa 04ff7f3f2d fix warning
2015-03-11 22:22:27 +00:00

1323 lines
36 KiB
Prolog
Raw Blame History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: preds.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Predicate Manipulation for YAP *
* *
*************************************************************************/
/** @defgroup Database Using the Clausal Data Base
@ingroup builtins
@{
Predicates in YAP may be dynamic or static. By default, when
consulting or reconsulting, predicates are assumed to be static:
execution is faster and the code will probably use less space.
Static predicates impose some restrictions: in general there can be no
addition or removal of clauses for a procedure if it is being used in the
current execution.
Dynamic predicates allow programmers to change the Clausal Data Base with
the same flexibility as in C-Prolog. With dynamic predicates it is
always possible to add or remove clauses during execution and the
semantics will be the same as for C-Prolog. But the programmer should be
aware of the fact that asserting or retracting are still expensive operations,
and therefore he should try to avoid them whenever possible.
*/
:- system_module( '$_preds', [abolish/1,
abolish/2,
assert/1,
assert/2,
assert_static/1,
asserta/1,
asserta/2,
asserta_static/1,
assertz/1,
assertz/2,
assertz_static/1,
clause/2,
clause/3,
clause_property/2,
compile_predicates/1,
current_key/2,
current_predicate/1,
current_predicate/2,
dynamic_predicate/2,
hide_predicate/1,
nth_clause/3,
predicate_erased_statistics/4,
predicate_property/2,
predicate_statistics/4,
retract/1,
retract/2,
retractall/1,
stash_predicate/1,
system_predicate/1,
system_predicate/2,
unknown/2], ['$assert_static'/5,
'$assertz_dynamic'/4,
'$clause'/4,
'$current_predicate'/4,
'$init_preds'/0,
'$noprofile'/2,
'$public'/2,
'$unknown_error'/1,
'$unknown_warning'/1]).
:- use_system_module( '$_boot', ['$check_head_and_body'/4,
'$check_if_reconsulted'/2,
'$handle_throw'/3,
'$head_and_body'/3,
'$inform_as_reconsulted'/2]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_init', ['$do_log_upd_clause'/6,
'$do_log_upd_clause0'/6,
'$do_log_upd_clause_erase'/6,
'$do_static_clause'/5]).
:- use_system_module( '$_modules', ['$imported_pred'/4,
'$meta_predicate'/4,
'$module_expansion'/5]).
:- use_system_module( '$_preddecls', ['$check_multifile_pred'/3,
'$dynamic'/2]).
:- use_system_module( '$_strict_iso', ['$check_iso_strict_clause'/1]).
% The next predicates are applicable only
% to dynamic code
/** @pred asserta(+ _C_) is iso
Adds clause _C_ to the beginning of the program. If the predicate is
undefined, declare it as dynamic.
*/
asserta(Mod:C) :- !,
'$assert'(C,Mod,first,_,asserta(Mod:C)).
asserta(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,first,_,asserta(C)).
/** @pred assertz(+ _C_) is iso
Adds clause _C_ to the end of the program. If the predicate is
undefined, declare it as dynamic.
Most Prolog systems only allow asserting clauses for dynamic
predicates. This is also as specified in the ISO standard. YAP allows
asserting clauses for static predicates. The current version of YAP
supports this feature, but this feature is deprecated and support may go
away in future versions.
*/
assertz(Mod:C) :- !,
'$assert'(C,Mod,last,_,assertz(Mod:C)).
assertz(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,last,_,assertz(C)).
/** @pred assert(+ _C_)
Same as assertz/1. Adds clause _C_ to the program. If the predicate is undefined,
declare it as dynamic. New code should use assertz/1 for better portability.
Most Prolog systems only allow asserting clauses for dynamic
predicates. This is also as specified in the ISO standard. YAP allows
asserting clauses for static predicates, as long as the predicate is not
in use and the language flag is <tt>cprolog</tt>. Note that this feature is
deprecated, if you want to assert clauses for static procedures you
should use assert_static/1.
*/
assert(Mod:C) :- !,
'$assert'(C,Mod,last,_,assert(Mod:C)).
assert(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,last,_,assert(C)).
'$assert'(V,Mod,_,_,_) :- var(V), !,
'$do_error'(instantiation_error,assert(Mod:V)).
'$assert'(V,Mod,_,_,_) :- var(Mod), !,
'$do_error'(instantiation_error,assert(Mod:V)).
'$assert'(I,Mod,_,_,_) :- number(I), !,
'$do_error'(type_error(callable,I),assert(Mod:I)).
'$assert'(M:C,_,Where,R,P) :- !,
'$assert'(C,M,Where,R,P).
'$assert'((H:-G),M1,Where,R,P) :- !,
'$assert_clause'(H, G, M1, Where, R, P).
'$assert'(H,M1,Where,R,_) :-
strip_module(M1:H, HM, H1),
'$assert_fact'(H1, HM, Where, R).
'$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).
'$assert_clause'(H, G, M1, Where, R, P) :- !,
'$assert_clause2'(H, G, M1, Where, R, P).
'$assert_fact'(H,Mod,Where,R) :-
( '$is_log_updatable'(H, Mod) ->
'$compile_dynamic'(H, Where, H, Mod, R)
;
'$is_dynamic'(H, Mod) ->
'$assertat_d'(Where, H, true, H, Mod, R)
;
'$undefined'(H,Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod),
'$assert_fact'(H,Mod,Where,R)
;
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
'$assert1'(Where,H,H,Mod,H)
;
functor(H, Na, Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),Mod:assert(H))
).
'$assert_clause2'(HI,BI,Mod,Where,R,P) :-
'$expand_clause'((HI :- BI),C0,C,Mod,HM),
'$assert_clause3'(C0,C,HM,Where,R,P).
'$assert_clause3'(C0,C,Mod,Where,R,P) :-
'$check_head_and_body'(C,H,B,P),
( '$is_log_updatable'(H, Mod) ->
'$compile_dynamic'((H :- B), Where, C0, Mod, R)
;
'$is_dynamic'(H, Mod) ->
'$assertat_d'(Where, H, B, C0, Mod, R)
;
'$undefined'(H,Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod),
'$assert_clause3'(C0,C,Mod,Where,R,P)
;
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
'$assert1'(Where,C,C0,Mod,H)
;
functor(H, Na, Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
).
'$assert_dynamic'(V,Mod,_,_,_) :- var(V), !,
'$do_error'(instantiation_error,assert(Mod:V)).
'$assert_dynamic'(M:C,_,Where,R,P) :- !,
'$assert_dynamic'(C,M,Where,R,P).
'$assert_dynamic'((H:-_G),_M1,_Where,_R,P) :-
var(H), !, '$do_error'(instantiation_error,P).
'$assert_dynamic'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod,HM),
'$assert_dynamic2'(C0,C,HM,Where,R,P).
'$assert_dynamic2'(C0,C,Mod,Where,R,P) :-
'$check_head_and_body'(C,H,B,P),
( '$is_log_updatable'(H, Mod) ->
'$compile_dynamic'(C, Where, C0, Mod, R)
;
'$is_dynamic'(H, Mod) ->
'$assertat_d'(Where,H,B,C0,Mod,R)
;
'$undefined'(H, Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar, Mod),
'$assert_dynamic2'(C0,C,Mod,Where,R,P)
;
functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),P)
).
/** @pred assert_static(: _C_)
Adds clause _C_ to a static procedure. Asserting a static clause
for a predicate while choice-points for the predicate are available has
undefined results.
*/
assert_static(Mod:C) :- !,
'$assert_static'(C,Mod,last,_,assert_static(Mod:C)).
assert_static(C) :-
'$current_module'(Mod),
'$assert_static'(C,Mod,last,_,assert_static(C)).
/** @pred asserta_static(: _C_)
Adds clause _C_ to the beginning of a static procedure.
*/
asserta_static(Mod:C) :- !,
'$assert_static'(C,Mod,first,_,asserta_static(Mod:C)).
asserta_static(C) :-
'$current_module'(Mod),
'$assert_static'(C,Mod,first,_,asserta_static(C)).
asserta_static(Mod:C) :- !,
'$assert_static'(C,Mod,last,_,assertz_static(Mod:C)).
/** @pred assertz_static(: _C_)
Adds clause _C_ to the end of a static procedure. Asserting a
static clause for a predicate while choice-points for the predicate are
available has undefined results.
The following predicates can be used for dynamic predicates and for
static predicates, if source mode was on when they were compiled:
*/
assertz_static(C) :-
'$current_module'(Mod),
'$assert_static'(C,Mod,last,_,assertz_static(C)).
'$assert_static'(V,M,_,_,_) :- var(V), !,
'$do_error'(instantiation_error,assert(M:V)).
'$assert_static'(M:C,_,Where,R,P) :- !,
'$assert_static'(C,M,Where,R,P).
'$assert_static'((H:-_G),_M1,_Where,_R,P) :-
var(H), !, '$do_error'(instantiation_error,P).
'$assert_static'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod, HM),
'$check_head_and_body'(C,H,B,P),
( '$is_dynamic'(H, HM) ->
'$do_error'(permission_error(modify,dynamic_procedure,HM:Na/Ar),P)
;
'$undefined'(H,HM), get_value('$full_iso',true) ->
functor(H,Na,Ar), '$dynamic'(Na/Ar, HM), '$assertat_d'(Where,H,B,C0,HM,R)
;
'$assert1'(Where,C,C0,HM,H)
).
'$assertat_d'(first,Head,Body,C0,Mod,R) :- !,
'$compile_dynamic'((Head:-Body), first, C0, Mod, CR),
( get_value('$abol',true)
->
'$flags'(Head,Mod,Fl,Fl),
( Fl /\ 0x20000000 =\= 0 -> '$check_multifile_pred'(Head,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordap'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(Head, Mod) ->
source_location(F, _),
functor(H0, Na, Ar),
recorda('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$assertat_d'(last,Head,Body,C0,Mod,R) :-
'$compile_dynamic'((Head:-Body), last, C0, Mod, CR),
( get_value('$abol',true)
->
'$flags'(Head,Mod,Fl,Fl),
( Fl /\ 0x20000000 =\= 0 -> '$check_multifile_pred'(Head,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordzp'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(H0, Mod) ->
source_location(F, _),
functor(H0, Na, Ar),
recordz('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$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),
'$assertat_d'(last,H,B,C0,Mod,_).
'$assertz_dynamic'(X,C,C0,Mod) :-
'$head_and_body'(C,H,B),
functor(H,N,A),
('$check_if_reconsulted'(N,A) ->
true
;
(X/\8)=:=0 ->
'$inform_as_reconsulted'(N,A),
'$remove_all_d_clauses'(H,Mod)
;
true
),
'$assertat_d'(last,H,B,C0,Mod,_).
'$remove_all_d_clauses'(H,M) :-
'$is_multifile'(H, M), !,
functor(H, Na, A),
'$erase_all_mf_dynamic'(Na,A,M).
'$remove_all_d_clauses'(H,M) :-
'$recordedp'(M:H,_,R), erase(R), fail.
'$remove_all_d_clauses'(_,_).
'$erase_all_mf_dynamic'(Na,A,M) :-
source_location( F , _),
recorded('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1),
erase(R),
fail.
'$erase_all_mf_dynamic'(_,_,_).
/** @pred asserta(+ _C_,- _R_)
The same as `asserta(C)` but unifying _R_ with
the database reference that identifies the new clause, in a
one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
asserta(M:C,R) :- !,
'$assert_dynamic'(C,M,first,R,asserta(M:C,R)).
asserta(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,first,R,asserta(C,R)).
/** @pred assertz(+ _C_,- _R_)
The same as `assertz(C)` but unifying _R_ with
the database reference that identifies the new clause, in a
one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
assertz(M:C,R) :- !,
'$assert_dynamic'(C,M,last,R,assertz(M:C,R)).
assertz(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,last,R,assertz(C,R)).
/** @pred assert(+ _C_,- _R_)
The same as `assert(C)` ( (see Modifying the Database)) but
unifies _R_ with the database reference that identifies the new
clause, in a one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
assert(M:C,R) :- !,
'$assert_dynamic'(C,M,last,R,assert(M:C,R)).
assert(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,last,R,assert(C,R)).
/** @pred clause(+ _H_, _B_) is iso
A clause whose head matches _H_ is searched for in the
program. Its head and body are respectively unified with _H_ and
_B_. If the clause is a unit clause, _B_ is unified with
_true_.
This predicate is applicable to static procedures compiled with
`source` active, and to all dynamic procedures.
*/
clause(M:P,Q) :- !,
'$clause'(P,M,Q,_).
clause(V,Q) :-
'$current_module'(M),
'$clause'(V,M,Q,_).
/** @pred clause(+ _H_, _B_,- _R_)
The same as clause/2, plus _R_ is unified with the
reference to the clause in the database. You can use instance/2
to access the reference's value. Note that you may not use
erase/1 on the reference on static procedures.
*/
clause(P,Q,R) :- var(P), !,
'$current_module'(M),
'$clause'(P,M,Q,R).
clause(M:P,Q,R) :- !,
'$clause'(P,M,Q,R).
clause(V,Q,R) :-
'$current_module'(M),
'$clause'(V,M,Q,R).
'$clause'(P,M,Q,R) :-
'$instance_module'(R,M0), !,
M0 = M,
instance(R,T),
( T = (H :- B) -> P = H, Q = B ; P=T, Q = true).
'$clause'(V,M,Q,R) :- var(V), !,
'$do_error'(instantiation_error,clause(M:V,Q,R)).
'$clause'(C,M,Q,R) :-
number(C), !,
'$do_error'(type_error(callable,C),clause(M:C,Q,R)).
'$clause'(C,M,Q,R) :-
db_reference(C), !,
'$do_error'(type_error(callable,C),clause(M:R,Q,R)).
'$clause'(M:P,_,Q,R) :- !,
'$clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$is_exo'(P, M), !,
Q = true,
R = '$exo_clause'(M,P),
'$execute0'(P, M).
'$clause'(P,M,Q,R) :-
'$is_source'(P, M), !,
'$static_clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$is_log_updatable'(P, M), !,
'$log_update_clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$some_recordedp'(M:P), !,
'$recordedp'(M:P,(P:-Q),R).
'$clause'(P,M,Q,R) :-
\+ '$undefined'(P,M),
( '$system_predicate'(P,M) -> true ;
'$number_of_clauses'(P,M,N), N > 0 ),
functor(P,Name,Arity),
'$do_error'(permission_error(access,private_procedure,Name/Arity),
clause(M:P,Q,R)).
'$init_preds' :-
once('$handle_throw'(_,_,_)),
fail.
'$init_preds' :-
once('$do_static_clause'(_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause0'(_,_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause'(_,_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause_erase'(_,_,_,_,_,_)),
fail.
'$init_preds'.
:- '$init_preds'.
/** @pred nth_clause(+ _H_, _I_,- _R_)
Find the _I_th clause in the predicate defining _H_, and give
a reference to the clause. Alternatively, if the reference _R_ is
given the head _H_ is unified with a description of the predicate
and _I_ is bound to its position.
The following predicates can only be used for dynamic predicates:
*/
nth_clause(V,I,R) :-
'$current_module'(M),
strip_module(M:V, M1, P), !,
'$nth_clause'(P, M1, I, R).
'$nth_clause'(P,M,I,R) :-
var(I), var(R), !,
'$clause'(P,M,_,R),
'$fetch_nth_clause'(P,M,I,R).
'$nth_clause'(P,M,I,R) :-
'$fetch_nth_clause'(P,M,I,R).
/** @pred retract(+ _C_) is iso
Erases the first clause in the program that matches _C_. This
predicate may also be used for the static predicates that have been
compiled when the source mode was `on`. For more information on
source/0 ( (see Setting the Compiler)).
*/
retract(M:C) :- !,
'$retract'(C,M).
retract(C) :-
'$current_module'(M),
'$retract'(C,M).
'$retract'(V,_) :- var(V), !,
'$do_error'(instantiation_error,retract(V)).
'$retract'(M:C,_) :- !,
'$retract'(C,M).
'$retract'(C,M) :-
'$check_head_and_body'(C,H,B,retract(M:C)), !,
'$flags'(H, M, F, F),
'$retract2'(F, H,M,B,_).
'$retract2'(F, H, M, B, R) :-
F /\ 0x08000000 =:= 0x08000000, !,
% '$is_log_updatable'(H, M), !,
'$log_update_clause'(H,M,B,R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R).
'$retract2'(F, H, M, B, R) :-
% '$is_dynamic'(H,M), !,
F /\ 0x00002000 =:= 0x00002000, !,
'$recordedp'(M:H,(H:-B),R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,MRef),MR), erase(MR), erase(MRef), fail ; true),
erase(R).
'$retract2'(_, H,M,_,_) :-
'$undefined'(H,M), !,
functor(H,Na,Ar),
'$dynamic'(Na/Ar,M),
fail.
'$retract2'(_, H,M,B,_) :-
functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
/** @pred retract(+ _C_,- _R_)
Erases from the program the clause _C_ whose
database reference is _R_. The predicate must be dynamic.
*/
retract(M:C,R) :- !,
'$retract'(C,M,R).
retract(C,R) :-
'$current_module'(M),
'$retract'(C,M,R).
'$retract'(V,M,R) :- var(V), !,
'$do_error'(instantiation_error,retract(M:V,R)).
'$retract'(M:C,_,R) :- !,
'$retract'(C,M,R).
'$retract'(C, M, R) :-
'$check_head_and_body'(C,H,B,retract(C,R)),
db_reference(R), '$is_dynamic'(H,M), !,
instance(R,(H:-B)), erase(R).
'$retract'(C,M,R) :-
'$check_head_and_body'(C,H,B,retract(C,R)),
var(R), !,
'$retract2'(H, M, B, R).
'$retract'(C,M,_) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)).
'$fetch_predicate_indicator_from_clause'((C :- _), Na/Ar) :- !,
functor(C, Na, Ar).
'$fetch_predicate_indicator_from_clause'(C, Na/Ar) :-
functor(C, Na, Ar).
/** @pred retractall(+ _G_) is iso
Retract all the clauses whose head matches the goal _G_. Goal
_G_ must be a call to a dynamic predicate.
*/
retractall(M:V) :- !,
'$retractall'(V,M).
retractall(V) :-
'$current_module'(M),
'$retractall'(V,M).
'$retractall'(V,M) :- var(V), !,
'$do_error'(instantiation_error,retract(M:V)).
'$retractall'(M:V,_) :- !,
'$retractall'(V,M).
'$retractall'(T,M) :-
(
'$is_log_updatable'(T, M) ->
( '$is_multifile'(T, M) ->
'$retractall_lu_mf'(T,M)
;
'$retractall_lu'(T,M)
)
;
\+ callable(T) ->
'$do_error'(type_error(callable,T),retractall(T))
;
'$undefined'(T,M) ->
functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !
;
'$is_dynamic'(T,M) ->
'$erase_all_clauses_for_dynamic'(T, M)
;
functor(T,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
).
'$retractall_lu'(T,M) :-
'$free_arguments'(T), !,
( '$purge_clauses'(T,M), fail ; true ).
'$retractall_lu'(T,M) :-
'$log_update_clause'(T,M,_,R),
erase(R),
fail.
'$retractall_lu'(_,_).
'$retractall_lu_mf'(T,M) :-
'$log_update_clause'(T,M,_,R),
( recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R),
fail.
'$retractall_lu_mf'(_,_).
'$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T,M) :-
'$recordedp'(M:T,_,_), fail.
'$erase_all_clauses_for_dynamic'(_,_).
/** @pred abolish(+ _P_,+ _N_)
Completely delete the predicate with name _P_ and arity _N_. It will
remove both static and dynamic predicates. All state on the predicate,
including whether it is dynamic or static, multifile, or
meta-predicate, will be lost.
*/
abolish(Mod:N,A) :- !,
'$abolish'(N,A,Mod).
abolish(N,A) :-
'$current_module'(Mod),
'$abolish'(N,A,Mod).
'$abolish'(N,A,M) :- var(N), !,
'$do_error'(instantiation_error,abolish(M:N,A)).
'$abolish'(N,A,M) :- var(A), !,
'$do_error'(instantiation_error,abolish(M:N,A)).
'$abolish'(N,A,M) :-
( recorded('$predicate_defs','$predicate_defs'(N,A,M,_),R) -> erase(R) ),
fail.
'$abolish'(N,A,M) :- functor(T,N,A),
( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ;
/* else */ '$abolishs'(T,M) ).
/** @pred abolish(+ _PredSpec_) is iso
Deletes the predicate given by _PredSpec_ from the database. If
_PredSpec_ is an unbound variable, delete all predicates for the
current module. The
specification must include the name and arity, and it may include module
information. Under <tt>iso</tt> language mode this built-in will only abolish
dynamic procedures. Under other modes it will abolish any procedures.
*/
abolish(V) :- var(V), !,
'$do_error'(instantiation_error,abolish(V)).
abolish(Mod:V) :- var(V), !,
'$do_error'(instantiation_error,abolish(Mod:V)).
abolish(M:X) :- !,
'$abolish'(X,M).
abolish(X) :-
'$current_module'(M),
'$abolish'(X,M).
'$abolish'(X,M) :-
'$access_yap_flags'(8, 2), !,
'$new_abolish'(X,M).
'$abolish'(X, M) :-
'$old_abolish'(X,M).
'$new_abolish'(V,M) :- var(V), !,
'$abolish_all'(M).
'$new_abolish'(A,M) :- atom(A), !,
'$abolish_all_atoms'(A,M).
'$new_abolish'(M:PS,_) :- !,
'$new_abolish'(PS,M).
'$new_abolish'(Na//Ar1, M) :-
integer(Ar1),
!,
Ar is Ar1+2,
'$new_abolish'(Na//Ar, M).
'$new_abolish'(Na/Ar, M) :-
functor(H, Na, Ar),
'$is_dynamic'(H, M), !,
'$abolishd'(H, M).
'$new_abolish'(Na/Ar, M) :- % succeed for undefined procedures.
functor(T, Na, Ar),
'$undefined'(T, M), !.
'$new_abolish'(Na/Ar, M) :-
'$do_error'(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar)).
'$new_abolish'(T, M) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all'(M) :-
'$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M),
fail.
'$abolish_all'(_).
'$abolish_all_atoms'(Na, M) :-
'$current_predicate'(Na,M,S,_),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M),
fail.
'$abolish_all_atoms'(_,_).
'$check_error_in_predicate_indicator'(V, Msg) :-
var(V), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(M:S, Msg) :- !,
'$check_error_in_module'(M, Msg),
'$check_error_in_predicate_indicator'(S, Msg).
'$check_error_in_predicate_indicator'(S, Msg) :-
S \= _/_,
S \= _//_, !,
'$do_error'(type_error(predicate_indicator,S), Msg).
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
var(Na), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
\+ atom(Na), !,
'$do_error'(type_error(atom,Na), Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
var(Ar), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
\+ integer(Ar), !,
'$do_error'(type_error(integer,Ar), Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
Ar < 0, !,
'$do_error'(domain_error(not_less_than_zero,Ar), Msg).
% not yet implemented!
%'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
% Ar < maxarity, !,
% '$do_error'(type_error(representation_error(max_arity),Ar), Msg).
'$check_error_in_module'(M, Msg) :-
var(M), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_module'(M, Msg) :-
\+ atom(M), !,
'$do_error'(type_error(atom,M), Msg).
'$old_abolish'(V,M) :- var(V), !,
( '$access_yap_flags'(8, 1) ->
'$do_error'(instantiation_error,abolish(M:V))
;
'$abolish_all_old'(M)
).
'$old_abolish'(N/A, M) :- !,
'$abolish'(N, A, M).
'$old_abolish'(A,M) :- atom(A), !,
( '$access_yap_flags'(8, 1) ->
'$do_error'(type_error(predicate_indicator,A),abolish(M:A))
;
'$abolish_all_atoms_old'(A,M)
).
'$old_abolish'(M:N,_) :- !,
'$old_abolish'(N,M).
'$old_abolish'([], _) :- !.
'$old_abolish'([H|T], M) :- !, '$old_abolish'(H, M), '$old_abolish'(T, M).
'$old_abolish'(T, M) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all_old'(M) :-
'$current_predicate'(Na, M, S, _),
functor( S, Na, Ar ),
'$abolish'(Na, Ar, M),
fail.
'$abolish_all_old'(_).
'$abolish_all_atoms_old'(Na, M) :-
'$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$abolish'(Na, Ar, M),
fail.
'$abolish_all_atoms_old'(_,_).
'$abolishd'(T, M) :-
'$is_multifile'(T,M),
functor(T,Name,Arity),
recorded('$mf','$mf_clause'(_,Name,Arity,M,Ref),R),
erase(R),
erase(Ref),
fail.
'$abolishd'(T, M) :-
recorded('$import','$import'(_,M,_,T,_,_),R),
erase(R),
fail.
'$abolishd'(T, M) :-
'$purge_clauses'(T,M), fail.
'$abolishd'(T, M) :-
'$kill_dynamic'(T,M), fail.
'$abolishd'(_, _).
'$abolishs'(G, M) :- '$system_predicate'(G,M), !,
functor(G,Name,Arity),
'$do_error'(permission_error(modify,static_procedure,Name/Arity),abolish(M:G)).
'$abolishs'(G, Module) :-
'$access_yap_flags'(8, 2), % only do this in sicstus mode
'$undefined'(G, Module),
functor(G,Name,Arity),
print_message(warning,no_match(abolish(Module:Name/Arity))).
'$abolishs'(G, M) :-
'$is_multifile'(G,M),
functor(G,Name,Arity),
recorded('$mf','$mf_clause'(_,Name,Arity,M,_Ref),R),
erase(R),
% no need erase(Ref),
fail.
'$abolishs'(T, M) :-
recorded('$import','$import'(_,M,_,_,T,_,_),R),
erase(R),
fail.
'$abolishs'(G, M) :-
'$purge_clauses'(G, M), fail.
'$abolishs'(_, _).
/** @pred dynamic_predicate(+ _P_,+ _Semantics_)
Declares predicate _P_ or list of predicates [ _P1_,..., _Pn_]
as a dynamic predicate following either `logical` or
`immediate` semantics.
*/
dynamic_predicate(P,Sem) :-
'$bad_if_is_semantics'(Sem, dynamic(P,Sem)).
dynamic_predicate(P,Sem) :-
'$log_upd'(OldSem),
( Sem = logical -> '$switch_log_upd'(1) ; '$switch_log_upd'(0) ),
'$current_module'(M),
'$dynamic'(P, M),
'$switch_log_upd'(OldSem).
'$bad_if_is_semantics'(Sem, Goal) :-
var(Sem), !,
'$do_error'(instantiation_error,Goal).
'$bad_if_is_semantics'(Sem, Goal) :-
Sem \= immediate, Sem \= logical, !,
'$do_error'(domain_error(semantics_indicator,Sem),Goal).
'$expand_clause'((H:-B),C1,C2,Mod,HM) :- !,
strip_module(Mod:H, HM, H1),
% Mod has scope over the full clause
'$module_expansion'((H1:-B), C1, C2, HM, Mod, Mod),
( get_value('$strict_iso',on) ->
'$check_iso_strict_clause'(C1)
;
true
).
'$expand_clause'(H,H1,H1,Mod,HM) :-
strip_module(Mod:H, HM, H1).
'$is_public'(T, Mod) :-
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
'$is_public'(T, Mod) :-
'$flags'(T,Mod,F,F),
F\/0x00400000 =\= 0.
/** @pred stash_predicate(+ _Pred_) @anchor stash_predicate
Make predicate _Pred_ invisible to new code, and to `current_predicate/2`,
`listing`, and friends. New predicates with the same name and
functor can be declared.
**/
stash_predicate(V) :- var(V), !,
'$do_error'(instantiation_error,stash_predicate(V)).
stash_predicate(M:P) :- !,
'$stash_predicate2'(P, M).
stash_predicate(P) :-
'$current_module'(M),
'$stash_predicate2'(P, M).
'$stash_predicate2'(V, M) :- var(V), !,
'$do_error'(instantiation_error,stash_predicate(M:V)).
'$stash_predicate2'(N/A, M) :- !,
functor(S,N,A),
'$stash_predicate'(S, M) .
'$stash_predicate2'(PredDesc, M) :-
'$do_error'(type_error(predicate_indicator,PredDesc),stash_predicate(M:PredDesc)).
/** @pred @pred hide_predicate(+ _Pred_)
Make predicate _Pred_ invisible to `current_predicate/2`,
`listing`, and friends.
**/
hide_predicate(V) :- var(V), !,
'$do_error'(instantiation_error,hide_predicate(V)).
hide_predicate(M:P) :- !,
'$hide_predicate2'(P, M).
hide_predicate(P) :-
'$current_module'(M),
'$hide_predicate2'(P, M).
'$hide_predicate2'(V, M) :- var(V), !,
'$do_error'(instantiation_error,hide_predicate(M:V)).
'$hide_predicate2'(N/A, M) :- !,
functor(S,N,A),
'$hide_predicate'(S, M) .
'$hide_predicate2'(PredDesc, M) :-
'$do_error'(type_error(predicate_indicator,PredDesc),hide_predicate(M:PredDesc)).
/** @pred predicate_property( _P_, _Prop_) is iso
For the predicates obeying the specification _P_ unify _Prop_
with a property of _P_. These properties may be:
+ `built_in `
true for built-in predicates,
+ `dynamic`
true if the predicate is dynamic
+ `static `
true if the predicate is static
+ `meta_predicate( _M_) `
true if the predicate has a meta_predicate declaration _M_.
+ `multifile `
true if the predicate was declared to be multifile
+ `imported_from( _Mod_) `
true if the predicate was imported from module _Mod_.
+ `exported `
true if the predicate is exported in the current module.
+ `public`
true if the predicate is public; note that all dynamic predicates are
public.
+ `tabled `
true if the predicate is tabled; note that only static predicates can
be tabled in YAP.
+ `source (predicate_property flag) `
true if source for the predicate is available.
+ `number_of_clauses( _ClauseCount_) `
Number of clauses in the predicate definition. Always one if external
or built-in.
*/
predicate_property(Pred,Prop) :- var(Pred), !,
'$current_module'(Mod),
'$predicate_property2'(Pred,Prop,Mod).
predicate_property(Mod:Pred,Prop) :- !,
'$predicate_property2'(Pred,Prop,Mod).
predicate_property(Pred,Prop) :-
'$current_module'(Mod),
'$predicate_property2'(Pred,Prop,Mod).
'$predicate_property2'(Pred,Prop,M) :- var(M), !,
'$all_current_modules'(M),
'$predicate_property2'(Pred,Prop,M).
'$predicate_property2'(Pred,Prop,M0) :- var(Pred), !,
(M = M0 ; M = prolog), % prolog mode is automatically incorporate in every other module
'$generate_all_preds_from_mod'(Pred, SourceMod, M),
'$predicate_property'(Pred,SourceMod,M,Prop).
'$predicate_property2'(M:Pred,Prop,_) :- !,
'$predicate_property2'(Pred,Prop,M).
'$predicate_property2'(Pred,Prop,Mod) :-
'$pred_exists'(Pred,Mod), !,
'$predicate_property'(Pred,Mod,Mod,Prop).
'$predicate_property2'(Pred,Prop,Mod) :-
'$imported_pred'(Pred, Mod, NPred, M),
(
Prop = imported_from(M)
;
'$predicate_property'(NPred,M,M,Prop),
Prop \= exported
).
'$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(_Na,M,Pred,_).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_),
'$pred_exists'(Orig, SourceMod).
'$predicate_property'(P,M,_,built_in) :-
'$system_predicate'(P,M).
'$predicate_property'(P,M,_,source) :-
'$flags'(P,M,F,F),
F /\ 0x00400000 =\= 0.
'$predicate_property'(P,M,_,tabled) :-
'$flags'(P,M,F,F),
F /\ 0x00000040 =\= 0.
'$predicate_property'(P,M,_,dynamic) :-
'$is_dynamic'(P,M).
'$predicate_property'(P,M,_,static) :-
\+ '$is_dynamic'(P,M),
\+ '$undefined'(P,M).
'$predicate_property'(P,M,_,meta_predicate(Q)) :-
functor(P,Na,Ar),
'$meta_predicate'(Na,M,Ar,Q).
'$predicate_property'(P,M,_,multifile) :-
'$is_multifile'(P,M).
'$predicate_property'(P,M,_,public) :-
'$is_public'(P,M).
'$predicate_property'(P,M,_,thread_local) :-
'$is_thread_local'(P,M).
'$predicate_property'(P,M,M,exported) :-
functor(P,N,A),
once(recorded('$module','$module'(_TFN,M,_S,Publics,_L),_)),
lists:memberchk(N/A,Publics).
'$predicate_property'(P,Mod,_,number_of_clauses(NCl)) :-
'$number_of_clauses'(P,Mod,NCl).
'$predicate_property'(P,Mod,_,file(F)) :-
'$owner_file'(P,Mod,F).
/**
@pred predicate_statistics( _P_, _NCls_, _Sz_, _IndexSz_)
Given predicate _P_, _NCls_ is the number of clauses for
_P_, _Sz_ is the amount of space taken to store those clauses
(in bytes), and _IndexSz_ is the amount of space required to store
indices to those clauses (in bytes).
*/
predicate_statistics(V,NCls,Sz,ISz) :- var(V), !,
'$do_error'(instantiation_error,predicate_statistics(V,NCls,Sz,ISz)).
predicate_statistics(M:P,NCls,Sz,ISz) :- !,
'$predicate_statistics'(P,M,NCls,Sz,ISz).
predicate_statistics(P,NCls,Sz,ISz) :-
'$current_module'(M),
'$predicate_statistics'(P,M,NCls,Sz,ISz).
'$predicate_statistics'(M:P,_,NCls,Sz,ISz) :- !,
'$predicate_statistics'(P,M,NCls,Sz,ISz).
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
'$is_log_updatable'(P, M), !,
'$lu_statistics'(P,NCls,Sz,ISz,M).
'$predicate_statistics'(P,M,_,_,_) :-
'$system_predicate'(P,M), !, fail.
'$predicate_statistics'(P,M,_,_,_) :-
'$undefined'(P,M), !, fail.
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
'$static_pred_statistics'(P,M,NCls,Sz,ISz).
/** @pred predicate_erased_statistics( _P_, _NCls_, _Sz_, _IndexSz_)
Given predicate _P_, _NCls_ is the number of erased clauses for
_P_ that could not be discarded yet, _Sz_ is the amount of space
taken to store those clauses (in bytes), and _IndexSz_ is the amount
of space required to store indices to those clauses (in bytes).
*/
predicate_erased_statistics(P,NCls,Sz,ISz) :-
var(P), !,
current_predicate(_,P),
predicate_erased_statistics(P,NCls,Sz,ISz).
predicate_erased_statistics(M:P,NCls,Sz,ISz) :- !,
'$predicate_erased_statistics'(M:P,NCls,Sz,_,ISz).
predicate_erased_statistics(P,NCls,Sz,ISz) :-
'$current_module'(M),
'$predicate_erased_statistics'(M:P,NCls,Sz,_,ISz).
/** @pred current_predicate( _A_, _P_)
Defines the relation: _P_ is a currently defined predicate whose name is the atom _A_.
*/
current_predicate(A,T) :-
'$ground_module'(T, M, T0),
format('`0 ~w~n', [M:T0]),
(
'$current_predicate'(A, M, T0, Flags),
%TFlags is Flags /\ 0x00004000,
% format('1 ~w ~16r~n', [M:T0,Flags, TFlags]),
Flags /\ 0x00004000 =:= 0x0
;
'$imported_predicate'(A, M, A/_Arity, T0, Flags),
% format('2 ~w ~16r~n', [M:T0,Flags]),
Flags /\ 0x00004000 =:= 0x0
).
/** @pred system_predicate( _A_, _P_)
Defines the relation: _P_ is a built-in predicate whose name
is the atom _A_.
*/
system_predicate(A,T) :-
'$ground_module'(T, M, T0),
(
'$current_predicate'(A, M, T0, Flags)
;
'$current_predicate'(A, prolog, T0, Flags)
).
/** @pred system_predicate( ?_P_ )
Defines the relation: _P_ is a currently defined system predicate.
*/
system_predicate(P) :-
system_predicate(_, P).
/**
@pred current_predicate( _F_) is iso
True if _F_ is the predicate indicator for a currently defined user or
library predicate.The indicator _F_ is of the form _Mod_:_Na_/_Ar_ or _Na/Ar_,
where the atom _Mod_ is the module of the predicate,
_Na_ is the name of the predicate, and _Ar_ its arity.
*/
current_predicate(F0) :-
'$ground_module'(F0, M, F),
(
'$current_predicate'(N, M, S, _),
functor( S, N, Ar),
F = N/Ar
;
'$imported_predicate'(_Name, M, F, S, _)
),
\+ system_predicate(_, S).
'$imported_predicate'(A, ImportingMod, A/Arity, G, Flags) :-
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod),
functor(G, A, Arity),
'$pred_exists'(G, ExportingMod),
'$flags'(G0, ExportingMod, Flags, Flags).
/** @pred current_key(? _A_,? _K_)
Defines the relation: _K_ is a currently defined database key whose
name is the atom _A_. It can be used to generate all the keys for
the internal data-base.
*/
current_key(A,K) :-
'$current_predicate'(A,idb,K,_).
% do nothing for now.
'$noprofile'(_, _).
'$ifunctor'(Pred,Na,Ar) :-
(Ar > 0 ->
functor(Pred, Na, Ar)
;
Pred = Na
).
/** @pred compile_predicates(: _ListOfNameArity_)
Compile a list of specified dynamic predicates (see dynamic/1 and
assert/1 into normal static predicates. This call tells the
Prolog environment the definition will not change anymore and further
calls to assert/1 or retract/1 on the named predicates
raise a permission error. This predicate is designed to deal with parts
of the program that is generated at runtime but does not change during
the remainder of the program execution.
*/
compile_predicates(Ps) :-
'$current_module'(Mod),
'$compile_predicates'(Ps, Mod, compile_predicates(Ps)).
'$compile_predicates'(V, _, Call) :-
var(V), !,
'$do_error'(instantiation_error,Call).
'$compile_predicates'(M:Ps, _, Call) :-
'$compile_predicates'(Ps, M, Call).
'$compile_predicates'([], _, _).
'$compile_predicates'([P|Ps], M, Call) :-
'$compile_predicate'(P, M, Call),
'$compile_predicates'(Ps, M, Call).
'$compile_predicate'(P, _M, Call) :-
var(P), !,
'$do_error'(instantiation_error,Call).
'$compile_predicate'(M:P, _, Call) :-
'$compile_predicate'(P, M, Call).
'$compile_predicate'(Na/Ar, Mod, _Call) :-
functor(G, Na, Ar),
findall((G.B),clause(Mod:G,B),Cls),
abolish(Mod:Na,Ar),
'$add_all'(Cls, Mod).
'$add_all'([], _).
'$add_all'((G.B).Cls, Mod) :-
assert_static(Mod:(G:-B)),
'$add_all'(Cls, Mod).
clause_property(ClauseRef, file(FileName)) :-
( recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef),_R)
-> true
;
'$instance_property'(ClauseRef, 2, FileName) ).
clause_property(ClauseRef, source(FileName)) :-
( recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef),_R)
-> true
;
'$instance_property'(ClauseRef, 2, FileName) ).
clause_property(ClauseRef, line_count(LineNumber)) :-
'$instance_property'(ClauseRef, 4, LineNumber),
LineNumber > 0.
clause_property(ClauseRef, fact) :-
'$instance_property'(ClauseRef, 3, true).
clause_property(ClauseRef, erased) :-
'$instance_property'(ClauseRef, 0, true).
clause_property(ClauseRef, predicate(PredicateIndicator)) :-
'$instance_property'(ClauseRef, 1, PredicateIndicator).
'$set_predicate_attribute'(M:N/Ar, Flag, V) :-
functor(P, N, Ar),
'$set_flag'(P, M, Flag, V).
/**
@}
*/
Reference in New Issue View Git Blame Copy Permalink