yap-6.3/pl/attributes.yap

/*************************************************************************
*									 *
*	 YAP Prolog 							 *
*									 *
*	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
*									 *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
*									 *
**************************************************************************
*									 *
* File:		atts.yap						 *
* Last rev:	8/2/88							 *
* mods:									 *
* comments:	attribute support for Prolog				 *
*									 *
*************************************************************************/

:- module('$attributes', [
			  project_delayed_goals/2
			  ]).

prolog:get_attr(Var, Mod, Att) :-
	functor(AttTerm, Mod, 2),
	arg(2, AttTerm, Att),
	attributes:get_module_atts(Var, AttTerm).

prolog:put_attr(Var, Mod, Att) :-
	functor(AttTerm, Mod, 2),
	arg(2, AttTerm, Att),
	attributes:put_module_atts(Var, AttTerm).

prolog:del_attr(Var, Mod) :-
	functor(AttTerm, Mod, 2),
	attributes:del_all_module_atts(Var, AttTerm).

prolog:del_attrs(Var) :-
	attributes:del_all_atts(Var).

prolog:get_attrs(AttVar, SWIAtts) :-
	attributes:get_all_swi_atts(AttVar,SWIAtts).

prolog:put_attrs(_, []).
prolog:put_attrs(V, Atts) :-
	cvt_to_swi_atts(Atts, YapAtts),
	attributes:put_att_term(V, YapAtts).

cvt_to_swi_atts([], _).
cvt_to_swi_atts(att(Mod,Attribute,Atts), ModAttribute) :-
	ModAttribute =.. [Mod, YapAtts, Attribute],
	cvt_to_swi_atts(Atts, YapAtts).

%
% wake_up_goal is called by the system whenever a suspended goal
% resumes.
%

/* The first case may happen if this variable was used for dif.
   In this case, we need a way to keep the original
   suspended goal around
*/
%'$wake_up_goal'([Module1|Continuation],G) :-
%	'$write'(4,vsc_woke:G+[Module1|Continuation]:'
%'), fail.
prolog:'$wake_up_goal'([Module1|Continuation], LG) :-
	execute_woken_system_goals(LG),
	do_continuation(Continuation, Module1).


%
% in the first two cases restore register  immediately and proceed
% to continuation. In the last case take care with modules, but do
% not act as if a meta-call.
% 
%
do_continuation('$cut_by'(X), _) :- !,
	'$$cut_by'(X).
do_continuation('$restore_regs'(X), _) :- !,
	'$restore_regs'(X).
do_continuation('$restore_regs'(X,Y), _) :- !,
	'$restore_regs'(X,Y).
do_continuation(Continuation, Module1) :-
	execute_continuation(Continuation,Module1).

execute_continuation(Continuation, Module1) :-
	'$undefined'(Continuation, Module1), !,
        '$undefp'([Module1|Continuation]).
execute_continuation(Continuation, Mod) :-
         % do not do meta-expansion nor any fancy stuff.
	'$execute0'(Continuation, Mod).


execute_woken_system_goals([]).
execute_woken_system_goals([G|LG]) :-
	execute_woken_system_goals(LG),
	execute_woken_system_goal(G).

%
% X surely was bound, otherwise we would not be awaken.
%
execute_woken_system_goal('$att_do'(V,New)) :-
	call_atts(V,New).

%
% what to do when an attribute gets bound
%
call_atts(V,_) :-
	nonvar(V), !.
call_atts(V,_) :-
	'$att_bound'(V), !.
call_atts(V,New) :-
	attributes:get_all_swi_atts(V,SWIAtts),
	(
	 '$undefined'(woken_att_do(V, New, LGoals, DoNotBind), attributes)
	->
	 LGoals = [],
	 DoNotBind = false
	;
	 attributes:woken_att_do(V, New, LGoals, DoNotBind)
	),
	( DoNotBind == true
	->
	  attributes:unbind_attvar(V)
	;
	  attributes:bind_attvar(V)
	),
	do_hook_attributes(SWIAtts, New),
	lcall(LGoals).

do_hook_attributes([], _).
do_hook_attributes(att(Mod,Att,Atts), Binding) :-
	('$undefined'(attr_unify_hook(Att,Binding), Mod)
	->
	 true
	;
	 Mod:attr_unify_hook(Att, Binding)
	),
	do_hook_attributes(Atts, Binding).


lcall([]).
lcall([Mod:Gls|Goals]) :-
	lcall2(Gls,Mod),
	lcall(Goals).

lcall2([], _).
lcall2([Goal|Goals], Mod) :-
	call(Mod:Goal),
	lcall2(Goals, Mod).



prolog:call_residue_vars(Goal,Residue) :-
	attributes:all_attvars(Vs0),
	call(Goal),
	attributes:all_attvars(Vs),
	% this should not be actually strictly necessary right now.
	% but it makes it a safe bet.
	sort(Vs, Vss),
	sort(Vs0, Vs0s),
	'$ord_remove'(Vss, Vs0s, Residue).

'$ord_remove'([], _, []).
'$ord_remove'([V|Vs], [], [V|Vs]).
'$ord_remove'([V1|Vss], [V2|Vs0s], Residue) :-
	( V1 == V2 ->
	  '$ord_remove'(Vss, Vs0s, Residue)
	;
	  V1 @< V2 ->
	  Residue = [V1|ResidueF],
	  '$ord_remove'(Vss, [V2|Vs0s], ResidueF)
	;
	  '$ord_remove'([V1|Vss], Vs0s, Residue)
	).

prolog:copy_term(Term, Copy, Goals) :-
	term_variables(Term, TVars),
	'$get_goalist_from_attvars'(TVars, Goals0),
	copy_term_nat([Term|Goals0], [Copy|Goals]).

prolog:call_residue(Goal,Residue) :-
	var(Goal), !,
	'$do_error'(instantiation_error,call_residue(Goal,Residue)).
prolog:call_residue(Module:Goal,Residue) :-
	atom(Module), !,
	call_residue(Goal,Module,Residue).
prolog:call_residue(Goal,Residue) :-
	'$current_module'(Module),
	call_residue(Goal,Module,Residue).

call_residue(Goal,Module,Residue) :-
	call(Module:Goal).

% called by top_level to find out about delayed goals
project_delayed_goals(G,LGs) :-
	% SICStus compatible step,
	% just try to simplify store  by projecting constraints
	% over query variables.
	(
	 current_predicate(attributes:modules_with_attributes/1), false
	->
	 attributes:all_attvars(LAV),
	 LAV = [_|_],
	 !,
	 project_attributes(LAV, G),
	% now get a list of frozen goals.
	 attributes:all_attvars(NLAV)
	;
	 attributed(G, NLAV),
	 NLAV = [_|_]
	),
	!,
	get_goalist_from_attvars(NLAV, LGs).
project_delayed_goals(_,[]).


attributed(G, Vs) :-
	term_variables(G, LAV),
	att_vars(LAV, Vs).

att_vars([], []).
att_vars([V|LGs], [V|AttVars]) :- attvar(V), !,
	att_vars(LGs, AttVars).
att_vars([_|LGs], AttVars) :-
	att_vars(LGs, AttVars).

% make sure we set the suspended goal list to its previous state!
% make sure we have installed a SICStus like constraint solver.
project_attributes(_, _) :-
	'$undefined'(modules_with_attributes(_),attributes), !.
project_attributes(AllVs, G) :-
	attributes:modules_with_attributes(LMods),
	term_variables(G, InputVs),
	pick_att_vars(InputVs, AttIVs),
	project_module(LMods, AttIVs, AllVs).

pick_att_vars([],[]).
pick_att_vars([V|L],[V|NL]) :- attvar(V), !,
	pick_att_vars(L,NL).
pick_att_vars([_|L],NL) :-
	pick_att_vars(L,NL).

project_module([], _, _).
project_module([Mod|LMods], LIV, LAV) :-
	'$pred_exists'(project_attributes(LIV, LAV),Mod),
	'$notrace'(Mod:project_attributes(LIV, LAV)), !,
	attributes:all_attvars(NLAV),
	project_module(LMods,LIV,NLAV).
project_module([_|LMods], LIV, LAV) :-
	project_module(LMods,LIV,LAV).

% given a list of attributed variables, generate a conjunction of goals.
%
get_conj_from_attvars(TVars, Goals) :-
	get_goalist_from_attvars(TVars, [], GoalList, []),
	list_to_conjunction(GoalList, Goals).

%
% same, but generate list
%
get_goalist_from_attvars(TVars, GoalList) :-
	get_goalist_from_attvars(TVars, GoalList, []).

get_goalist_from_attvars([]) --> [].
get_goalist_from_attvars([V|TVars]) -->
	get_goalist_from_attvar(V),
	get_goalist_from_attvars(TVars).

get_goalist_from_attvar(V) --> { attvar(V) }, !,
	{ attributes:get_all_atts(V, AllAtts) },
	all_atts_to_goals(AllAtts, V).
get_goalist_from_attvar(_) --> [].

all_atts_to_goals(AllAtts, _) --> { var(AllAtts) }, !.
all_atts_to_goals(AllAtts, V) --> 
	{
	 functor(AllAtts, Mod, _),
	 arg(1, AllAtts, MoreAtts)
	},
	attgoals_for_module(Mod, V, AllAtts),
	all_atts_to_goals(MoreAtts, V).

%
% check constraints for variable
%
attgoals_for_module(Mod, V, _Gs, GoalListF, GoalList0) :-
	 % SWI, HProlog
	'$pred_exists'(attribute_goals(V,GoalListF,GoalList0), Mod), !,
	(
	 '$notrace'(Mod:attribute_goals(V,GoalListF,GoalList0))
	->
	 true
	;
	 GoalListF = GoalList0
	).
attgoals_for_module(Mod, V, _, GoalListF, GoalList0) :-
	 % SICStus
	'$pred_exists'(attribute_goal(V,G),Mod), !,
	(
	 '$notrace'(Mod:attribute_goal(V,G))
	->
	 GoalListF = [G|GoalList0]
	;
	 GoalListF = GoalList0
	).
attgoals_for_module(Mod, V, _, GoalList, GoalList).

list_to_conjunction([], true).
list_to_conjunction([G], G)  :- !.
list_to_conjunction([G|GoalList], (G,Goals0))  :-
	list_to_conjunction(GoalList, Goals0).