yap-6.3/pl/meta.yap

/**

  @file meta.yap

  @defgroup YAPMetaPredicates Using Meta-Calls with Modules
 @ingroup YAPModules
 @{

  @pred meta_predicate(_G1_,...., _Gn) is directive

Declares that this predicate manipulates references to predicates.
Each _Gi_ is a mode specification.

If the argument is `:`, it does not refer directly to a predicate
but must be module expanded. If the argument is an integer, the argument
is a goal or a closure and must be expanded. Otherwise, the argument is
not expanded. Note that the system already includes declarations for all
built-ins.

For example, the declaration for call/1 and setof/3 are:

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:- meta_predicate call(0), setof(?,0,?).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

meta_predicate declaration
 implemented by asserting $meta_predicate(SourceModule,Functor,Arity,Declaration)

*/

% directive now meta_predicate Ps :- $meta_predicate(Ps).

:- dynamic prolog:'$meta_predicate'/4.

:- multifile prolog:'$meta_predicate'/4,
      '$inline'/2,
      '$full_clause_optimisation'/4.


'$meta_predicate'(M:P) :-
	var(P),
	'$do_error'(instantiation_error,meta_predicate(M:P)).
'$meta_predicate'(M:P) :-
	var(M),
	'$do_error'(instantiation_error,meta_predicate(M:P)).
'$meta_predicate'(M:(P,Ps)) :- !,
	'$meta_predicate'(M:P),
	'$meta_predicate'(M:Ps).
'$meta_predicate'( M:D ) :-
    '$yap_strip_module'( M:D, M1, P),
	'$install_meta_predicate'(M1:P).

'$install_meta_predicate'(M1:P) :-
	functor(P,F,N),
	( M1 = prolog -> M = _ ; M1 = M),
	( retractall(prolog:'$meta_predicate'(F,M,N,_)), fail ; true),
	asserta(prolog:'$meta_predicate'(F,M,N,P)),
	'$predicate_flags'(P, M1, Fl, Fl),
	NFlags is Fl \/ 0x200000,
	'$predicate_flags'(P, M1, Fl, NFlags).

                                % comma has its own problems.

:- '$install_meta_predicate'(prolog:','(0,0)).

%% handle module transparent predicates by defining a
%% new context module.
'$is_mt'(H, B, HM, _SM, M, (context_module(CM),B), CM) :-
    '$yap_strip_module'(HM:H, M, NH),
	'$module_transparent'(_, M, _, NH), !.
'$is_mt'(_H, B, _HM, _SM, BM, B, BM).



% I assume the clause has been processed, so the
% var case is long gone! Yes :)
'$clean_cuts'(G,('$current_choicepoint'(DCP),NG)) :-
	'$conj_has_cuts'(G,DCP,NG,OK), OK == ok, !.
'$clean_cuts'(G,G).

'$clean_cuts'(G,DCP,NG) :-
	'$conj_has_cuts'(G,DCP,NG,OK), OK == ok, !.
'$clean_cuts'(G,_,G).

'$conj_has_cuts'(V,_,V, _) :- var(V), !.
'$conj_has_cuts'(!,DCP,'$$cut_by'(DCP), ok) :- !.
'$conj_has_cuts'((G1,G2),DCP,(NG1,NG2), OK) :- !,
	'$conj_has_cuts'(G1, DCP, NG1, OK),
	'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1;G2),DCP,(NG1;NG2), OK) :- !,
	'$conj_has_cuts'(G1, DCP, NG1, OK),
	'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1->G2),DCP,(G1;NG2), OK) :- !,
	% G1: the system must have done it already
	'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1*->G2),DCP,(G1;NG2), OK) :- !,
	% G1: the system must have done it already
	'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'(if(G1,G2,G3),DCP,if(G1,NG2,NG3), OK) :- !,
	% G1: the system must have done it already
	'$conj_has_cuts'(G2, DCP, NG2, OK),
	'$conj_has_cuts'(G3, DCP, NG3, OK).
'$conj_has_cuts'(G,_,G, _).

% return list of vars in expanded positions on the head of a clause.
%
% these variables should not be expanded by meta-calls in the body of the goal.
%
%  should be defined before caller.
%
'$module_u_vars'(M, H, UVars) :-
    '$do_module_u_vars'(M:H,UVars).

'$do_module_u_vars'(M:H,UVars) :-
	functor(H,F,N),
	'$meta_predicate'(F,M,N,D), !,
	'$do_module_u_vars'(N,D,H,UVars).
'$do_module_u_vars'(_,[]).

'$do_module_u_vars'(0,_,_,[]) :- !.
'$do_module_u_vars'(I,D,H,LF) :-
	arg(I,D,X), ( X=':' -> true ; integer(X)),
	arg(I,H,A), '$uvar'(A, LF, L), !,
	I1 is I-1,
	'$do_module_u_vars'(I1,D,H,L).
'$do_module_u_vars'(I,D,H,L) :-
	I1 is I-1,
	'$do_module_u_vars'(I1,D,H,L).

'$uvar'(Y, [Y|L], L)  :- var(Y), !.
% support all/3
'$uvar'(same( G, _), LF, L)  :-
    '$uvar'(G, LF, L).
'$uvar'('^'( _, G), LF, L)  :-
    '$uvar'(G, LF, L).

/**
 * @pred '$meta_expand'( _Input_, _HeadModule_, _BodyModule_, _SourceModule_, _HVars_-_Head_, _OutGoal_)
 *
 * expand Input if a metapredicate, otherwF,MI,Arity,PredDefise ignore
 *
 * @return
*/
'$meta_expand'(G, _, CM, HVars, OG) :-
    var(G),
    !,
	(
     lists:identical_member(G, HVars)
    ->
     OG = G
    ;
     OG = CM:G
    ).
% nothing I can do here:
'$meta_expand'(G0, PredDef, CM, HVars, NG) :-
	G0 =.. [Name|GArgs],
	PredDef =.. [Name|GDefs],
	functor(PredDef, Name, Arity ),
	length(NGArgs, Arity),
	NG =.. [Name|NGArgs],
	'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).

'$expand_args'([],  _, [], _, []).
'$expand_args'([A|GArgs], CM,   [M|GDefs], HVars, [NA|NGArgs]) :-
	( M == ':' -> true ; number(M) ),
    !,
	'$expand_arg'(A, CM, HVars, NA),
	'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).
'$expand_args'([A|GArgs],  CM, [_|GDefs], HVars, [A|NGArgs]) :-
	'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).


% check if an argument should be expanded
'$expand_arg'(G,  CM, HVars, OG) :-
    var(G),
    !,
    ( lists:identical_member(G, HVars) -> OG = G; OG = CM:G).
'$expand_arg'(G,  CM, _HVars, NCM:NG) :-
    '$yap_strip_module'(CM:G, NCM, NG).

% expand module names in a body
% args are:
%       goals to expand
%       code to pass to listing
%       code to pass to compiler
%       head module   HM
%       source module  SM
%       current module for looking up preds  M
%
% to understand the differences, you can consider:
%
%  a:(d:b(X)) :- g:c(X), d(X), user:hello(X)).
%
% when we process meta-predicate c, HM=d, DM=a, BM=a, M=g and we should get:
%
%  d:b(X) :- g:c(g:X), a:d(X), user:hello(X).
%
% on the other hand,
%
%  a:(d:b(X) :- c(X), d(X), d:e(X)).
%
% will give
%
%  d:b(X) :- a:c(a:X), a:d(X), e(X).
%
%
%       head variab'$expand_goals'(M:G,G1,GO,HM,SM,,_M,HVars)les.
%       goals or arguments/sub-arguments?
% I cannot use call here because of format/3
% modules:
% A4: module for body of clause (this is the one used in looking up predicates)
% A5: context module (this is the current context
				% A6: head module (this is the one used in compiling and accessing).
%
%
%'$expand_goals'(V,NG,NG,HM,SM,BM,HVars):- writeln(V), fail.
'$expand_goals'(V,NG,NGO,HM,SM,BM,HVars-H) :-
	var(V),
    !,
	( lists:identical_member(V, HVars)
	->
      '$expand_goals'(call(V),NG,NGO,HM,SM,BM,HVars-H)
	;
	  ( atom(BM)
      ->
        NG = call(BM:V),
        NGO = '$execute_in_mod'(V,BM)
   ;
        '$expand_goals'(call(BM:V),NG,NGO,HM,SM,BM,HVars-H)
      )
   ).
'$expand_goals'(BM:V,NG,NGO,HM,SM,_BM,HVarsH) :-
	    '$yap_strip_module'( BM:V, CM, G),
	     nonvar(CM),
	     !,
	     '$expand_goals'(G,NG,NGO,HM,SM,CM,HVarsH).

'$expand_goals'(CM0:V,NG,NGO,HM,SM,BM,HVarsH) :-
	  strip_module( CM0:V, CM, G),
	  !,
	  '$expand_goals'(call(CM:G),NG,NGO,HM,SM,BM,HVarsH).
% if I don't know what the module is, I cannot do anything to the goal,
% so I just put a call for later on.
'$expand_goals'(V,NG,NGO,_HM,_SM,BM,_HVarsH) :-
	var(BM),
	!,
    NG = call(BM:V),
    NGO = '$execute_wo_mod'(V,BM).
'$expand_goals'(depth_bound_call(G,D),
                  depth_bound_call(G1,D),
                  ('$set_depth_limit_for_next_call'(D),GO),
                  HM,SM,BM,HVars) :-
    '$expand_goals'(G,G1,GO,HM,SM,BM,HVars),
    '$composed_built_in'(GO), !.
'$expand_goals'((A,B),(A1,B1),(AO,BO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A;B),(A1;B1),(AO;BO),HM,SM,BM,HVars) :- var(A), !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A*->B;C),(A1*->B1;C1),
        (
          yap_hacks:current_choicepoint(DCP),
          AO,
          yap_hacks:cut_at(DCP),BO
          ;
          CO
        ),
        HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AOO,HM,SM,BM,HVars),
	'$clean_cuts'(AOO, AO),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
	'$expand_goals'(C,C1,CO,HM,SM,BM,HVars).
'$expand_goals'((A;B),(A1;B1),(AO;BO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A|B),(A1|B1),(AO|BO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A->B),(A1->B1),(AO->BO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AOO,HM,SM,BM,HVars),
	'$clean_cuts'(AOO, AO),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'(\+G,\+G,A\=B,_HM,_BM,_SM,_HVars) :-
    nonvar(G),
    G = (A = B),
    !.
'$expand_goals'(\+A,\+A1,('$current_choice_point'(CP),AO,'$$cut_by'(CP)-> false;true),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars).
'$expand_goals'(once(A),once(A1),
	('$current_choice_point'(CP),AO,'$$cut_by'(CP)),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
        '$clean_cuts'(AO0, CP, AO).
'$expand_goals'(ignore(A),ignore(A1),
	('$current_choice_point'(CP),AO,'$$cut_by'(CP)-> true ; true),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
    '$clean_cuts'(AO0, AO).
'$expand_goals'(forall(A,B),forall(A1,B1),
		  ((AO, ( BO-> false ; true)) -> false ; true),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
        '$clean_cuts'(AO0, AO).
'$expand_goals'(not(A),not(A1),('$current_choice_point'(CP),AO,'$$cut_by'(CP) -> fail; true),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO,HM,SM,BM,HVars).
'$expand_goals'(if(A,B,C),if(A1,B1,C1),
	('$current_choicepoint'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
	'$expand_goals'(C,C1,CO,HM,SM,BM,HVars),
        '$clean_cuts'(AO0, DCP, AO).
'$expand_goals'((A*->B;C),(A1*->B1;C1),
	('$current_choicepoint'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
	'$expand_goals'(C,C1,CO,HM,SM,BM,HVars),
    '$clean_cuts'(AO0, DCP, AO).
'$expand_goals'((A*->B),(A1*->B1),
	('$current_choicepoint'(DCP),AO,BO),HM,SM,BM,HVars) :- !,
	'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
	'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
    '$clean_cuts'(AO0, DCP, AO).
'$expand_goals'(true,true,true,_,_,_,_) :- !.
'$expand_goals'(fail,fail,fail,_,_,_,_) :- !.
'$expand_goals'(false,false,false,_,_,_,_) :- !.
'$expand_goals'(G, G1, GO, HM, SM, BM, HVars) :-
    '$yap_strip_module'(BM:G,  NBM, GM),
    '$expand_goal'(GM, G1, GO, HM, SM, NBM, HVars).


'$import_expansion'(M:G, M1:G1) :-
    '$imported_predicate'(G, M, G1, M1),
     !.
'$import_expansion'(MG, MG).

'$meta_expansion'(GMG, BM, HVars, GM:GF) :-
	'$yap_strip_module'(GMG, GM, G ),
	 functor(G, F, Arity ),
	 '$meta_predicate'(F, GM, Arity, PredDef),
	 !,
	 '$meta_expand'(G, PredDef, BM, HVars, GF).
'$meta_expansion'(GMG, _BM, _HVars, GM:G) :-
	'$yap_strip_module'(GMG, GM, G ).

 /**
 * @brief Perform meta-variable and user expansion on a goal _G_
 *
 * given the example
~~~~~
:- module(m, []).

o:p(B) :- n:g, X is 2+3, call(B).
~~~~~
 *
 * @param G input goal, without module quantification.
 * @param G1F output, non-optimised for debugging
 * @param GOF output, optimised, ie, `n:g`, `prolog:(X is 2+3)`, `call(m:B)`, where `prolog` does not  need to be explicit
 * @param GOF output, optimised, `n:g`, `prolog:(X=5)`,  `call(m:B)`
 * @param HM head module, input, o
 * @param HM source module, input, m
 * @param M current module, input, `n`, `m`, `m`
 * @param HVars-H, list of meta-variables and initial head, `[]` and `p(B)`
 *
 *
 */
'$expand_goal'(G0, G1F, GOF, HM, SM, BM, HVars-H) :-
    '$yap_strip_module'( BM:G0, M0N, G0N),
    '$user_expansion'(M0N:G0N, M1:G1),
    '$import_expansion'(M1:G1, M2:G2),
    '$meta_expansion'(M2:G2, M1, HVars, M2:B1F),
    '$end_goal_expansion'(B1F, G1F, GOF, HM, SM, M2, H).

'$end_goal_expansion'(G, G1F, GOF, HM, SM, BM, H) :-
    '$match_mod'(G, HM, SM, BM, G1F),
    '$c_built_in'(G1F, BM, H, GO),
    '$yap_strip_module'(BM:GO, MO, IGO),
    '$match_mod'(IGO, HM, SM, MO, GOF).

'$user_expansion'(M0N:G0N, M1:G1) :-
    '_user_expand_goal'(M0N:G0N, M:G),
    !,
    ( M:G == M0N:G0N
    ->
      M1:G1 = M:G
    ;
      '$user_expansion'(M:G, M1:G1)
    ).
'$user_expansion'(MG, MG).

  '$match_mod'(G, HMod, SMod, M, O) :-
    (
     % \+ '$is_multifile'(G1,M),
     %->
      '$is_system_predicate'(G,prolog)
     ->
      O = G
    ;
      M == HMod, M == SMod
    ->
     O = G
    ;
     O = M:G
    ).

'$build_up'(HM, NH, SM, true, NH, true, NH) :- HM == SM, !.
'$build_up'(HM, NH, _SM, true, HM:NH, true, HM:NH) :- !.
'$build_up'(HM, NH, SM, B1, (NH :- B1), BO, ( NH :- BO)) :- HM == SM, !.
'$build_up'(HM, NH, _SM, B1, (NH :- B1), BO, ( HM:NH :- BO)) :- !.

'$expand_clause_body'(V, _NH1, _HM1, _SM, M, call(M:V), call(M:V) ) :-
    var(V), !.
'$expand_clause_body'(true, _NH1, _HM1, _SM, _M, true, true ) :- !.
'$expand_clause_body'(B, H, HM, SM, M, B1, BO ) :-
	'$module_u_vars'(HM , H, UVars),	 % collect head variables in
                                % expanded positions
                                % support for SWI's meta primitive.
    '$is_mt'(H, B, HM, SM, M, IB, BM),
	'$expand_goals'(IB, B1, BO1, HM, SM, BM, UVars-H),
    (
     '$full_clause_optimisation'(H, BM, BO1, BO)
    ->
     true
    ;
     BO = BO1
	).

%
% check if current module redefines an imported predicate.
% and remove import.
%
'$not_imported'(H, Mod) :-
	recorded('$import','$import'(NM,Mod,NH,H,_,_),R),
	NM \= Mod,
	functor(NH,N,Ar),
	print_message(warning,redefine_imported(Mod,NM,N/Ar)),
	erase(R),
	fail.
'$not_imported'(_, _).


'$verify_import'(_M:G, prolog:G) :-
    '$is_system_predicate'(G, prolog).
'$verify_import'(M:G, NM:NG) :-
    '$get_undefined_pred'(G, M, NG, NM),
    !.
'$verify_import'(MG, MG).



% expand arguments of a meta-predicate
% $meta_expansion(ModuleWhereDefined,CurrentModule,Goal,ExpandedGoal,MetaVariables)


% expand module names in a clause (interface predicate).
% A1: Input Clause
% A2: Output Class to Compiler (lives in module HM)
% A3: Output Class to clause/2 and listing (lives in module HM)
%
% modules:
% A6: head module (this is the one used in compiling and accessing).
% A5: context module (this is the current context
% A4: module for body of clause (this is the one used in looking up predicates)
%
                             % has to be last!!!
'$expand_a_clause'(MHB, SM0, Cl1, ClO) :- % MHB is the original clause, SM0 the current source, Cl1 and ClO output clauses
    '$yap_strip_module'(SM0:MHB, SM, HB),  % remove layers of modules over the clause. SM is the source module.
    '$head_and_body'(HB, H, B),           % HB is H :- B.
    '$yap_strip_module'(SM:H, HM, NH), % further module expansion
    '$not_imported'(NH, HM),
    '$yap_strip_module'(SM:B, BM, B0), % further module expansion
    '$expand_clause_body'(B0, NH, HM, SM0, BM, B1, BO),
    '$build_up'(HM, NH, SM0, B1, Cl1, BO, ClO).



expand_goal(Input, Output) :-
    '$expand_meta_call'(Input, [], Output ).

'$expand_meta_call'(G, HVars, MF:GF ) :-
    source_module(SM),
    '$yap_strip_module'(SM:G, M, IG),
    '$expand_goals'(IG, _, GF0, M, SM, M, HVars-G),
    '$yap_strip_module'(M:GF0, MF, GF).

:- '$meta_predicate'(prolog:(
	abolish(:),
	abolish(:,+),
	all(?,0,-),
	assert(:),
	assert(:,+),
	assert_static(:),
	asserta(:),
	asserta(:,+),
	asserta_static(:),
	assertz(:),
	assertz(:,+),
	assertz_static(:),
	at_halt(0),
	bagof(?,0,-),
	bb_get(:,-),
	bb_put(:,+),
	bb_delete(:,?),
	bb_update(:,?,?),
	call(0),
	call(1,?),
	call(2,?,?),
	call(3,?,?,?),
	call_with_args(0),
	call_with_args(1,?),
	call_with_args(2,?,?),
	call_with_args(3,?,?,?),
	call_with_args(4,?,?,?,?),
	call_with_args(5,?,?,?,?,?),
	call_with_args(6,?,?,?,?,?,?),
	call_with_args(7,?,?,?,?,?,?,?),
	call_with_args(8,?,?,?,?,?,?,?,?),
	call_with_args(9,?,?,?,?,?,?,?,?,?),
	call_cleanup(0,0),
	call_cleanup(0,?,0),
	call_residue(0,?),
	call_residue_vars(0,?),
	call_shared_object_function(:,+),
	catch(0,?,0),
	clause(:,?),
	clause(:,?,?),
	compile(:),
	consult(:),
	current_predicate(:),
	current_predicate(?,:),
	db_files(:),
			     depth_bound_call(0,+),
	discontiguous(:),
	ensure_loaded(:),
	exo_files(:),
	findall(?,0,-),
	findall(?,0,-,?),
	forall(0,0),
	format(+,:),
	format(+,+,:),
	freeze(?,0),
	hide_predicate(:),
	if(0,0,0),
	ignore(0),
	incore(0),
	multifile(:),
	nospy(:),
        not(0),
        notrace(0),
        once(0),
        phrase(2,?),
        phrase(2,?,+),
	predicate_property(:,?),
	predicate_statistics(:,-,-,-),
	on_exception(+,0,0),
	qsave_program(+,:),
	reconsult(:),
	retract(:),
	retract(:,?),
	retractall(:),
	reconsult(:),
	setof(?,0,-),
	setup_call_cleanup(0,0,0),
	setup_call_catcher_cleanup(0,0,?,0),
	spy(:),
	stash_predicate(:),
	use_module(:),
	use_module(:,?),
	use_module(?,:,?),
	when(+,0),
	with_mutex(+,0),
	with_output_to(?,0),
	'->'(0 , 0),
	'*->'(0 , 0),
	';'(0 , 0),
%	','(0 , 0),
	^(+,0),
	{}(0,?,?),
	','(2,2,?,?),
	;(2,2,?,?),
	'|'(2,2,?,?),
	->(2,2,?,?),
	\+(2,?,?),
	\+( 0 )
            )).