2001-04-09 20:54:03 +01:00
|
|
|
/*************************************************************************
|
|
|
|
* *
|
|
|
|
* 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 *
|
|
|
|
* *
|
|
|
|
*************************************************************************/
|
|
|
|
|
|
|
|
% The next predicates are applicable only
|
|
|
|
% to dynamic code
|
|
|
|
|
|
|
|
asserta(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,asserta(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
asserta(C) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert'(C,Mod,first,_,asserta(C)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
assertz(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assertz(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
assertz(C) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert'(C,Mod,last,_,assertz(C)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
assert(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assert(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
assert(C) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert'(C,Mod,last,_,assert(C)).
|
|
|
|
|
|
|
|
'$assert'(V,Mod,_,_,_) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assert(Mod:V))).
|
|
|
|
'$assert'(M:C,_,Where,R,P) :- !,
|
|
|
|
'$assert'(C,M,Where,R,P).
|
|
|
|
'$assert'((H:-G),M1,Where,R,P) :-
|
|
|
|
(var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
( M1 = M ->
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert'((C:-G),M1,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert'(C1,M,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert'(CI,Mod,Where,R,P) :-
|
|
|
|
'$expand_clause'(CI,C0,C,Mod),
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_head_and_body'(C,H,B,P),
|
2001-11-15 00:01:43 +00:00
|
|
|
( '$is_dynamic'(H, Mod) ->
|
|
|
|
'$assertat_d'(Where, H, B, C0, Mod, R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
2001-11-15 00:01:43 +00:00
|
|
|
'$undefined'(H,Mod) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(H, Na, Ar),
|
2001-11-15 19:01:41 +00:00
|
|
|
'$dynamic'(Na/Ar, Mod),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(Where,H,B,C0,Mod,R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert1'(Where,C,C0,Mod,H)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
functor(H, Na, Ar),
|
|
|
|
throw(error(permission_error(modify,static_procedure,Na/Ar),P))
|
|
|
|
).
|
|
|
|
|
2001-05-21 21:00:05 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_dynamic'(V,Mod,_,_,_) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assert(Mod:V))).
|
|
|
|
'$assert_dynamic'(M:C,_,Where,R,P) :- !,
|
2001-12-12 20:08:12 +00:00
|
|
|
'$assert_dynamic'(C,M,Where,R,P).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_dynamic'((H:-G),M1,Where,R,P) :-
|
|
|
|
(var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
( M1 = M ->
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_dynamic'((C:-G),M1,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_dynamic'(C1,M,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_dynamic'(CI,Mod,Where,R,P) :-
|
|
|
|
'$expand_clause'(CI,C0,C,Mod),
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_head_and_body'(C,H,B,P),
|
2001-11-15 00:01:43 +00:00
|
|
|
( '$is_dynamic'(H, Mod) ->
|
|
|
|
'$assertat_d'(Where,H,B,C0,Mod,R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
2001-11-15 00:01:43 +00:00
|
|
|
'$undefined'(H, Mod) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(H, Na, Ar),
|
2001-11-15 19:01:41 +00:00
|
|
|
'$dynamic'(Na/Ar, Mod),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(Where,H,B,C0,Mod,R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
functor(H,Na,Ar),
|
|
|
|
throw(error(permission_error(modify,static_procedure,Na/Ar),P))
|
|
|
|
).
|
|
|
|
|
|
|
|
assert_static(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assert_static(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
assert_static(C) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert_static'(C,Mod,last,_,assert_static(C)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
asserta_static(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,asserta_static(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
asserta_static(C) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert_static'(C,Mod,first,_,asserta_static(C)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
assertz_static(V) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assertz_static(V))).
|
|
|
|
assertz_static(C) :-
|
2001-11-15 00:01:43 +00:00
|
|
|
'$current_module'(Mod),
|
|
|
|
'$assert_static'(C,Mod,last,_,assertz_static(C)).
|
|
|
|
|
|
|
|
'$assert_static'(V,M,_,_,_) :- var(V), !,
|
|
|
|
throw(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) -> throw(error(instantiation_error,P)) ; H=M:C), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
( M1 = M ->
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_static'((C:-G),M1,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_static'(C1,M,Where,R,P)
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert_static'(CI,Mod,Where,R,P) :-
|
|
|
|
'$expand_clause'(CI,C0,C,Mod),
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_head_and_body'(C,H,B,P),
|
2001-11-15 00:01:43 +00:00
|
|
|
( '$is_dynamic'(H, Mod) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
throw(error(permission_error(modify,dynamic_procedure,Na/Ar),P))
|
|
|
|
;
|
2001-11-15 00:01:43 +00:00
|
|
|
'$undefined'(H,Mod), '$get_value'('$full_iso',true) ->
|
2001-11-15 19:01:41 +00:00
|
|
|
functor(H,Na,Ar), '$dynamic'(Na/Ar, Mod), '$assertat_d'(Where,H,B,C0,Mod,R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert1'(Where,C,C0,Mod,H)
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
|
|
|
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(first,Head,Body,C0,Mod,R) :- !,
|
|
|
|
'$compile_dynamic'((Head:-Body), 2, Mod, CR),
|
2001-04-09 20:54:03 +01:00
|
|
|
( '$get_value'('$abol',true)
|
|
|
|
->
|
2001-11-15 00:01:43 +00:00
|
|
|
'$flags'(H,Mod,Fl,Fl),
|
|
|
|
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ),
|
|
|
|
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
true
|
|
|
|
),
|
|
|
|
'$head_and_body'(C0, H0, B0),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$recordap'(Mod:Head,(H0 :- B0),R,CR),
|
|
|
|
( '$is_multifile'(Head, Mod) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
'$get_value'('$consulting_file',F),
|
2001-11-15 00:01:43 +00:00
|
|
|
functor(H0, Na, Ar),
|
|
|
|
'$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
true
|
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(last,Head,Body,C0,Mod,R) :-
|
|
|
|
'$compile_dynamic'((Head:-Body), 0, Mod, CR),
|
2001-04-09 20:54:03 +01:00
|
|
|
( '$get_value'('$abol',true)
|
|
|
|
->
|
2001-11-15 00:01:43 +00:00
|
|
|
'$flags'(H,Mod,Fl,Fl),
|
|
|
|
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ),
|
|
|
|
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
true
|
|
|
|
),
|
|
|
|
'$head_and_body'(C0, H0, B0),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$recordzp'(Mod:Head,(H0 :- B0),R,CR),
|
|
|
|
( '$is_multifile'(H0, Mod) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
'$get_value'('$consulting_file',F),
|
2001-11-15 00:01:43 +00:00
|
|
|
functor(H0, Na, Ar),
|
|
|
|
'$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
|
|
|
true
|
|
|
|
).
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assert1'(last,C,C0,Mod,H) :- '$$compile_stat'(C,C0,0,H,Mod).
|
|
|
|
'$assert1'(first,C,C0,Mod,H) :- '$$compile_stat'(C,C0,2,H,Mod).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertz_dynamic'(X, C, C0, Mod) :- (X/\4)=:=0, !,
|
2001-04-09 20:54:03 +01:00
|
|
|
'$head_and_body'(C,H,B),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(last,H,B,C0,Mod,_).
|
|
|
|
'$assertz_dynamic'(X,C,C0,Mod) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$head_and_body'(C,H,B), functor(H,N,A),
|
2001-09-27 15:01:16 +01:00
|
|
|
('$check_if_reconsulted'(N,A) ->
|
2001-04-09 20:54:03 +01:00
|
|
|
true
|
|
|
|
;
|
2001-09-27 15:01:16 +01:00
|
|
|
(X/\8)=:=0 ->
|
2001-04-09 20:54:03 +01:00
|
|
|
'$inform_as_reconsulted'(N,A),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$remove_all_d_clauses'(H,Mod)
|
2001-09-27 15:01:16 +01:00
|
|
|
;
|
|
|
|
true
|
2001-04-09 20:54:03 +01:00
|
|
|
),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$assertat_d'(last,H,B,C0,Mod,_).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$remove_all_d_clauses'(H,M) :-
|
|
|
|
'$is_multifile'(H, M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(H, Na, A),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$erase_all_mf_dynamic'(Na,A,M).
|
|
|
|
'$remove_all_d_clauses'(H,M) :-
|
|
|
|
'$recordedp'(M:H,_,R), erase(R), fail.
|
|
|
|
'$remove_all_d_clauses'(_,_).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$erase_all_mf_dynamic'(Na,A,M) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$get_value'('$consulting_file',F),
|
|
|
|
'$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
|
|
|
|
erase(R1),
|
|
|
|
erase(R),
|
|
|
|
fail.
|
2001-11-15 00:01:43 +00:00
|
|
|
'$erase_all_mf_dynamic'(_,_,_).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
asserta(V,R) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,asserta(V,R))).
|
2001-11-15 00:01:43 +00:00
|
|
|
asserta(C,R) :-
|
|
|
|
'$current_module'(M),
|
|
|
|
'$assert_dynamic'(C,M,first,R,asserta(C,R)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
assertz(V,R) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assertz(V,R))).
|
2001-11-15 00:01:43 +00:00
|
|
|
assertz(C,R) :-
|
|
|
|
'$current_module'(M),
|
|
|
|
'$assert_dynamic'(C,M,last,R,assertz(C,R)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
assert(V,R) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,assert(V,R))).
|
2001-11-15 00:01:43 +00:00
|
|
|
assert(C,R) :-
|
|
|
|
'$current_module'(M),
|
|
|
|
'$assert_dynamic'(C,M,last,R,assert(C,R)).
|
|
|
|
|
|
|
|
clause(V,Q) :-
|
|
|
|
'$current_module'(M),
|
|
|
|
'$clause'(V,M,Q).
|
|
|
|
|
|
|
|
'$clause'(V,M,Q) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,M:clause(V,Q))).
|
|
|
|
'$clause'(C,M,Q) :- number(C), !,
|
|
|
|
throw(error(type_error(callable,C),M:clause(C,Q))).
|
2002-01-02 16:55:24 +00:00
|
|
|
'$clause'(R,M,Q) :- db_reference(R), !,
|
2001-11-15 00:01:43 +00:00
|
|
|
throw(error(type_error(callable,R),M:clause(R,Q))).
|
|
|
|
'$clause'(M:P,_,Q) :- !,
|
|
|
|
'$clause'(P,M,Q).
|
|
|
|
'$clause'(P,Mod,Q) :- '$is_dynamic'(P, Mod), !,
|
|
|
|
'$recordedp'(Mod:P,(P:-Q),_).
|
|
|
|
'$clause'(P,M,Q) :-
|
|
|
|
'$some_recordedp'(M:P), !,
|
|
|
|
'$recordedp'(M:P,(P:-Q),_).
|
|
|
|
'$clause'(P,M,Q) :-
|
2002-01-08 05:22:40 +00:00
|
|
|
( '$system_predicate'(P,M) -> true ;
|
2001-11-15 00:01:43 +00:00
|
|
|
'$number_of_clauses'(P,M,N), N > 0 ),
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(P,Name,Arity),
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(access,private_procedure,Name/Arity),
|
|
|
|
clause(M:P,Q))).
|
2001-11-15 00:01:43 +00:00
|
|
|
|
|
|
|
clause(V,Q,R) :-
|
|
|
|
'$current_module'(V,M,Q,R),
|
|
|
|
'$clause'(V,M,Q,R).
|
|
|
|
|
|
|
|
'$clause'(V,M,Q,R) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,M:clause(V,Q,R))).
|
|
|
|
'$clause'(C,M,Q,R) :- number(C), !,
|
|
|
|
throw(error(type_error(callable,C),clause(C,M:Q,R))).
|
|
|
|
'$clause'(R,M,Q,R1) :- db_reference(R), !,
|
2002-01-02 16:55:24 +00:00
|
|
|
throw(error(type_error(callable,R),clause(R,M:Q,R1))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$clause'(M:P,_,Q,R) :- !,
|
|
|
|
'$clause'(P,M,Q,R).
|
|
|
|
'$clause'(P,Mod,Q,R) :-
|
|
|
|
( '$is_dynamic'(P, Mod) ->
|
|
|
|
'$recordedp'(Mod:P,(P:-Q),R)
|
2001-04-09 20:54:03 +01:00
|
|
|
;
|
2001-10-30 16:42:05 +00:00
|
|
|
functor(P,N,A),
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(access,private_procedure,N/A),
|
|
|
|
clause(Mod:P,Q,R)))
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
retract(C) :-
|
|
|
|
'$current_module'(M),
|
|
|
|
'$retract'(C,M).
|
|
|
|
|
|
|
|
|
|
|
|
'$retract'(V,_) :- var(V), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
throw(error(instantiation_error,retract(V))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$retract'(M:C,_) :- !,
|
|
|
|
'$retract'(C,M).
|
|
|
|
'$retract'(C,M) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_head_and_body'(C,H,B,retract(C)),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$is_dynamic'(H, M), !,
|
|
|
|
'$recordedp'(M:H,(H:-B),R), erase(R).
|
|
|
|
'$retract'(C,M) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$fetch_predicate_indicator_from_clause'(C, PI),
|
2001-11-15 00:01:43 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,PI),retract(M:C))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
retract(C,R) :- !,
|
|
|
|
'$current_module'(M),
|
|
|
|
'$retract'(C,M,R).
|
|
|
|
|
|
|
|
|
|
|
|
'$retract'(V,M,R) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,retract(M:V,R))).
|
|
|
|
'$retract'(M:C,_,R) :- !,
|
|
|
|
'$retract'(C,M,R).
|
|
|
|
'$retract'(C, M, R) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_head_and_body'(C,H,B,retract(C,R)),
|
2001-11-15 00:01:43 +00:00
|
|
|
db_reference(R), '$is_dynamic'(H,M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
instance(R,(H:-B)), erase(R).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$retract'(C,M,R) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$head_and_body'(C,H,B,retract(C,R)),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$is_dynamic'(H,M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
var(R),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$recordedp'(M:H,(H:-B),R),
|
2001-04-09 20:54:03 +01:00
|
|
|
erase(R).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$retract'(C,M,_) :-
|
2001-10-30 16:42:05 +00:00
|
|
|
'$fetch_predicate_indicator_from_clause'(C, PI),
|
2001-11-15 00:01:43 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,PI),retract(M:C))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
'$fetch_predicate_indicator_from_clause'((C :- _), Na/Ar) :- !,
|
|
|
|
functor(C, Na, Ar).
|
|
|
|
'$fetch_predicate_indicator_from_clause'(C, Na/Ar) :-
|
|
|
|
functor(C, Na, Ar).
|
|
|
|
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
retractall(V) :- !,
|
|
|
|
'$current_module'(M),
|
|
|
|
'$retractall'(V,M).
|
|
|
|
|
|
|
|
'$retractall'(V,M) :- var(V), !,
|
|
|
|
throw(error(instantiation_error,retract(M:V))).
|
|
|
|
'$retractall'(M:V,_) :- !,
|
|
|
|
'$retractall'(V,M).
|
|
|
|
'$retractall'(T,M) :-
|
|
|
|
'$undefined'(T,M),
|
|
|
|
functor(T,Na,Ar),
|
2001-12-02 16:46:50 +00:00
|
|
|
'$dynamic'(Na/Ar,M), !.
|
2001-11-15 00:01:43 +00:00
|
|
|
'$retractall'(T,M) :-
|
|
|
|
\+ '$is_dynamic'(T,M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(T,Na,Ar),
|
|
|
|
throw(error(permission_error(modify,static_procedure,Na/Ar),retractall(T))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$retractall'(T,M) :-
|
|
|
|
'$erase_all_clauses_for_dynamic'(T, M).
|
|
|
|
|
|
|
|
'$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'(_,_).
|
|
|
|
|
|
|
|
abolish(N,A) :-
|
|
|
|
'$current_module'(Mod),
|
|
|
|
'$abolish'(N,A,Mod).
|
|
|
|
|
|
|
|
'$abolish'(N,A,M) :- var(N), !,
|
|
|
|
throw(error(instantiation_error,abolish(M:N,A))).
|
|
|
|
'$abolish'(N,A,M) :- var(A), !,
|
|
|
|
throw(error(instantiation_error,abolish(M:N,A))).
|
|
|
|
'$abolish'(N,A,M) :-
|
2002-01-02 16:55:24 +00:00
|
|
|
( '$recorded'('$predicate_defs','$predicate_defs'(N,A,M,_),R) -> erase(R) ),
|
2001-04-09 20:54:03 +01:00
|
|
|
fail.
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish'(N,A,M) :- functor(T,N,A),
|
2001-11-16 20:27:06 +00:00
|
|
|
( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ;
|
2001-11-15 00:01:43 +00:00
|
|
|
/* else */ '$abolishs'(T,M) ).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
abolish(X) :-
|
|
|
|
'$access_yap_flags'(8, 2), !,
|
2001-11-15 00:01:43 +00:00
|
|
|
'$current_module'(M),
|
|
|
|
'$new_abolish'(X,M).
|
2001-11-16 20:27:06 +00:00
|
|
|
abolish(X) :-
|
|
|
|
'$current_module'(M),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$old_abolish'(X,M).
|
|
|
|
|
2001-12-11 15:39:28 +00:00
|
|
|
'$new_abolish'(V,M) :- var(V), !,
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish_all'(M).
|
2001-12-11 19:53:07 +00:00
|
|
|
'$new_abolish'(A,M) :- var(A), !,
|
|
|
|
'$abolish_all_atoms'(A,M).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$new_abolish'(M:PS,_) :- !,
|
|
|
|
'$new_abolish'(PS,M).
|
|
|
|
'$new_abolish'(Na/Ar, M) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(H, Na, Ar),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$is_dynamic'(H, M), !,
|
|
|
|
'$abolishd'(H, M).
|
|
|
|
'$new_abolish'(Na/Ar, M) :- % succeed for undefined procedures.
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(T, Na, Ar),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$undefined'(T, M), !.
|
|
|
|
'$new_abolish'(Na/Ar, M) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
throw(error(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar))).
|
2001-11-19 17:56:07 +00:00
|
|
|
'$new_abolish'(T, M) :-
|
|
|
|
throw(error(type_error(predicate_indicator,T),abolish(M:T))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish_all'(M) :-
|
2001-12-11 19:53:07 +00:00
|
|
|
'$current_predicate'(M,Na,Ar),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$new_abolish'(Na/Ar, M),
|
2001-05-28 20:54:53 +01:00
|
|
|
fail.
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish_all'(_).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-12-11 19:53:07 +00:00
|
|
|
'$abolish_all_atoms'(Na, M) :-
|
|
|
|
'$current_predicate'(M,Na,Ar),
|
|
|
|
'$new_abolish'(Na/Ar, M),
|
|
|
|
fail.
|
|
|
|
'$abolish_all_atoms'(_,_).
|
|
|
|
|
2001-04-09 20:54:03 +01:00
|
|
|
'$check_error_in_predicate_indicator'(V, Msg) :-
|
|
|
|
var(V), !,
|
|
|
|
throw(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 \= _/_, !,
|
|
|
|
throw(error(type_error(predicate_indicator,S), Msg)).
|
2001-10-30 16:42:05 +00:00
|
|
|
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
var(Na), !,
|
|
|
|
throw(error(instantiation_error, Msg)).
|
2001-10-30 16:42:05 +00:00
|
|
|
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
\+ atom(Na), !,
|
|
|
|
throw(error(type_error(atom,Na), Msg)).
|
2001-10-30 16:42:05 +00:00
|
|
|
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
var(Ar), !,
|
|
|
|
throw(error(instantiation_error, Msg)).
|
2001-10-30 16:42:05 +00:00
|
|
|
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
\+ integer(Ar), !,
|
|
|
|
throw(error(type_error(integer,Ar), Msg)).
|
2001-10-30 16:42:05 +00:00
|
|
|
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
Ar < 0, !,
|
|
|
|
throw(error(domain_error(not_less_than_zero,Ar), Msg)).
|
|
|
|
% not yet implemented!
|
|
|
|
%'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
|
|
|
|
% Ar < maxarity, !,
|
|
|
|
% throw(error(type_error(representation_error(max_arity),Ar), Msg)).
|
|
|
|
|
|
|
|
'$check_error_in_module'(M, Msg) :-
|
|
|
|
var(M), !,
|
|
|
|
throw(error(instantiation_error, Msg)).
|
|
|
|
'$check_error_in_module'(M, Msg) :-
|
|
|
|
\+ atom(M), !,
|
2001-10-30 16:42:05 +00:00
|
|
|
throw(error(type_error(atom,M), Msg)).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$old_abolish'(V,M) :- var(V), !,
|
2002-01-30 04:56:43 +00:00
|
|
|
( '$access_yap_flags'(8, 1) ->
|
|
|
|
throw(error(instantiation_error,abolish(M:V)))
|
|
|
|
;
|
|
|
|
'$abolish_all_old'(M)
|
|
|
|
).
|
2001-12-11 19:53:07 +00:00
|
|
|
'$old_abolish'(A,M) :- atom(A), !,
|
2002-01-30 04:56:43 +00:00
|
|
|
( '$access_yap_flags'(8, 1) ->
|
|
|
|
throw(error(type_error(predicate_indicator,A),abolish(M:A)))
|
|
|
|
;
|
|
|
|
'$abolish_all_atoms_old'(A,M)
|
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$old_abolish'(M:N,_) :- !,
|
|
|
|
'$old_abolish'(N,M).
|
|
|
|
'$old_abolish'([], _) :- !.
|
|
|
|
'$old_abolish'([H|T], M) :- !, '$old_abolish'(H, M), '$old_abolish'(T, M).
|
2002-01-16 20:31:00 +00:00
|
|
|
'$old_abolish'(N/A, M) :- !,
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish'(N, A, M).
|
2001-11-19 17:56:07 +00:00
|
|
|
'$old_abolish'(T, M) :-
|
|
|
|
throw(error(type_error(predicate_indicator,T),abolish(M:T))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolish_all_old'(M) :-
|
2001-12-28 16:42:18 +00:00
|
|
|
'$current_predicate'(M, Na, Ar),
|
|
|
|
'$abolish'(Na, Ar, M),
|
2001-06-12 17:15:58 +01:00
|
|
|
fail.
|
2001-12-28 16:42:18 +00:00
|
|
|
'$abolish_all_old'(_).
|
2001-06-12 17:15:58 +01:00
|
|
|
|
2001-12-11 19:53:07 +00:00
|
|
|
'$abolish_all_atoms_old'(Na, M) :-
|
2001-12-28 16:42:18 +00:00
|
|
|
'$current_predicate'(M, Na, Ar),
|
2001-12-11 19:53:07 +00:00
|
|
|
'$abolish'(Na, Ar, M),
|
|
|
|
fail.
|
|
|
|
'$abolish_all_atoms_old'(_,_).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolishd'(T, M) :- '$recordedp'(M:T,_,R), erase(R), fail.
|
|
|
|
'$abolishd'(T, M) :- '$kill_dynamic'(T,M), fail.
|
|
|
|
'$abolishd'(_, _).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolishs'(G, M) :- '$in_use'(G, M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(G,Name,Arity),
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure_in_use,Name/Arity),abolish(M:G))).
|
2002-01-08 05:22:40 +00:00
|
|
|
'$abolishs'(G, M) :- '$system_predicate'(G,M), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(G,Name,Arity),
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,Name/Arity),abolish(M:G))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolishs'(G, Module) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$access_yap_flags'(8, 2), % only do this in sicstus mode
|
2001-11-15 00:01:43 +00:00
|
|
|
'$undefined'(G, Module),
|
2001-04-09 20:54:03 +01:00
|
|
|
functor(G,Name,Arity),
|
2002-01-07 06:28:04 +00:00
|
|
|
'$format'(user_error,"[ Warning: abolishing undefined predicate (~w:~w/~w) ]~n",[Module,Name,Arity]),
|
2001-04-09 20:54:03 +01:00
|
|
|
fail.
|
|
|
|
% I cannot allow modifying static procedures in YAPOR
|
|
|
|
% this code has to be here because of abolish/2
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolishs'(G, Module) :-
|
2001-04-09 20:54:03 +01:00
|
|
|
'$has_yap_or', !,
|
2001-10-30 16:42:05 +00:00
|
|
|
functor(G,A,N),
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,A/N),abolish(Module:G))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$abolishs'(G, M) :-
|
|
|
|
'$purge_clauses'(G, M),
|
|
|
|
'$recordedp'(M:G,_,R), erase(R), fail.
|
|
|
|
'$abolishs'(_, _).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
%
|
|
|
|
% can only do as goal in YAP mode.
|
|
|
|
%
|
|
|
|
dynamic(X) :- '$access_yap_flags'(8, 0), !,
|
2001-11-15 00:01:43 +00:00
|
|
|
'$current_module'(M),
|
|
|
|
'$dynamic'(X, M).
|
2001-04-09 20:54:03 +01:00
|
|
|
dynamic(X) :-
|
|
|
|
throw(error(context_error(dynamic(X),declaration),query)).
|
|
|
|
|
2002-01-02 16:55:24 +00:00
|
|
|
'$dynamic'(X,M) :- var(X), !,
|
2001-11-15 00:01:43 +00:00
|
|
|
throw(error(instantiation_error,dynamic(M:X))).
|
|
|
|
'$dynamic'(Mod:Spec,_) :- !,
|
|
|
|
'$dynamic'(Spec,Mod).
|
|
|
|
'$dynamic'([], _) :- !.
|
|
|
|
'$dynamic'([H|L], M) :- !, '$dynamic'(H, M), '$dynamic'(L, M).
|
|
|
|
'$dynamic'((A,B),M) :- !, '$dynamic'(A,M), '$dynamic'(B,M).
|
|
|
|
'$dynamic'(X,M) :- !,
|
|
|
|
'$dynamic2'(X,M).
|
|
|
|
|
|
|
|
'$dynamic2'(X, Mod) :- '$log_upd'(Stat), Stat\=0, !,
|
|
|
|
'$logical_updatable'(X, Mod).
|
|
|
|
'$dynamic2'(A/N, Mod) :- integer(N), atom(A), !,
|
|
|
|
functor(T,A,N), '$flags'(T,Mod,F,F),
|
|
|
|
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'2000, '$flags'(T, Mod, F, NF);
|
|
|
|
'$is_dynamic'(T,Mod) -> true;
|
|
|
|
F /\ 16'400 =:= 16'400, '$undefined'(T,Mod) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,Mod,F,NF);
|
2001-04-09 20:54:03 +01:00
|
|
|
F/\16'8 =:= 16'8 -> true ;
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,A/N),dynamic(Mod:A/N)))
|
2001-11-15 00:01:43 +00:00
|
|
|
).
|
|
|
|
'$dynamic2'(X,Mod) :-
|
|
|
|
throw(error(type_error(callable,X),dynamic(Mod:X))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$logical_updatable'(A/N,Mod) :- integer(N), atom(A), !,
|
|
|
|
functor(T,A,N), '$flags'(T,Mod,F,F),
|
|
|
|
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,Mod,F,NF);
|
|
|
|
'$is_dynamic'(T,Mod) -> true;
|
|
|
|
F /\ 16'400 =:= 16'400 , '$undefined'(T,Mod) -> NF is F \/ 0x8, '$flags'(T,Mod,F,NF);
|
2001-04-09 20:54:03 +01:00
|
|
|
F /\ 16'8=:= 16'8 -> true ;
|
2001-11-19 17:56:07 +00:00
|
|
|
throw(error(permission_error(modify,static_procedure,A/N),dynamic(Mod:A/N)))
|
2001-04-09 20:54:03 +01:00
|
|
|
).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$logical_updatable'(X,Mod) :-
|
|
|
|
throw(error(type_error(callable,X),dynamic(Mod:X))).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
|
|
|
|
|
|
|
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) ),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$current_module'(M),
|
|
|
|
'$dynamic'(P, M),
|
2001-04-09 20:54:03 +01:00
|
|
|
'$switch_log_upd'(OldSem).
|
|
|
|
|
|
|
|
'$bad_if_is_semantics'(Sem, Goal) :-
|
|
|
|
var(Sem), !,
|
|
|
|
throw(error(instantiation_error,Goal)).
|
|
|
|
'$bad_if_is_semantics'(Sem, Goal) :-
|
|
|
|
Sem \= immediate, Sem \= logical, !,
|
|
|
|
throw(error(domain_error(semantics_indicator,Sem),Goal)).
|
|
|
|
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$expand_clause'(C0,C1,C2,Mod) :-
|
|
|
|
'$expand_term_modules'(C0, C1, C2, Mod),
|
2001-04-09 20:54:03 +01:00
|
|
|
( '$get_value'('$strict_iso',on) ->
|
|
|
|
'$check_iso_strict_clause'(C1)
|
|
|
|
;
|
|
|
|
true
|
|
|
|
).
|
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$public'(X, _) :- var(X), !,
|
2001-04-09 20:54:03 +01:00
|
|
|
throw(error(instantiation_error,public(X))).
|
2001-11-15 00:01:43 +00:00
|
|
|
'$public'(Mod:Spec, _) :- !,
|
|
|
|
'$public'(Spec,Mod).
|
|
|
|
'$public'((A,B), M) :- !, '$public'(A,M), '$public'(B,M).
|
|
|
|
'$public'([],_) :- !.
|
|
|
|
'$public'([H|L], M) :- !, '$public'(H, M), '$public'(L, M).
|
|
|
|
'$public'(A/N, Mod) :- integer(N), atom(A), !,
|
2002-01-02 16:55:24 +00:00
|
|
|
functor(T,A,N),
|
2001-11-15 00:01:43 +00:00
|
|
|
'$do_make_public'(T, Mod).
|
|
|
|
'$public'(X, Mod) :-
|
|
|
|
throw(error(type_error(callable,X),dynamic(Mod:X))).
|
|
|
|
|
|
|
|
'$do_make_public'(T, Mod) :-
|
|
|
|
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
|
|
|
|
'$do_make_public'(T, Mod) :-
|
|
|
|
'$flags'(T,Mod,F,F),
|
2001-04-09 20:54:03 +01:00
|
|
|
NF is F\/16'400000,
|
2001-11-15 00:01:43 +00:00
|
|
|
'$flags'(T,Mod,F,NF).
|
2001-04-09 20:54:03 +01:00
|
|
|
|
2001-11-15 00:01:43 +00:00
|
|
|
'$is_public'(T, Mod) :-
|
|
|
|
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
|
|
|
|
'$is_public'(T, Mod) :-
|
|
|
|
'$flags'(T,Mod,F,F),
|
2001-04-09 20:54:03 +01:00
|
|
|
F\/16'400000 \== 0.
|
|
|
|
|