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.
yap-6.3/pl/attributes.yap
2014-05-25 21:44:32 +01:00

347 lines
8.8 KiB
Prolog

/*************************************************************************
* *
* 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', [
delayed_goals/4
]).
:- use_system_module( '$_boot', ['$undefp'/1]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$coroutining', [attr_unify_hook/2]).
:- use_system_module( attributes, [all_attvars/1,
attributed_module/3,
bind_attvar/1,
del_all_atts/1,
del_all_module_atts/2,
get_all_swi_atts/2,
get_module_atts/2,
modules_with_attributes/1,
put_att_term/2,
put_module_atts/2,
unbind_attvar/1,
woken_att_do/4]).
:- dynamic attributes:attributed_module/3, attributes:modules_with_attributes/1.
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) :-
% writeln( [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), _) :- !,
% yap_flag(gc_trace,verbose),
% garbage_collect,
'$restore_regs'(X).
do_continuation('$restore_regs'(X,Y), _) :- !,
% yap_flag(gc_trace,verbose),
% garbage_collect,
'$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(['$att_do'(V,New)|LG]) :-
execute_woken_system_goals(LG),
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)
).
%% from SWI
%% copy_term(+Term, -Copy, -Gs) is det.
%
% Creates a regular term Copy as a copy of Term (without any
% attributes), and a list Gs of goals that when executed reinstate
% all attributes onto Copy. The nonterminal attribute_goals//1, as
% defined in the modules the attributes stem from, is used to
% convert attributes to lists of goals.
prolog:copy_term(Term, Copy, Gs) :-
term_attvars(Term, Vs),
( Vs == []
-> Gs = [],
copy_term(Term, Copy)
; findall(Term-Gs,
'$attributes':residuals_and_delete_attributes(Vs, Gs, Term),
[Copy-Gs])
).
residuals_and_delete_attributes(Vs, Gs, Term) :-
attvars_residuals(Vs, Gs, []),
delete_attributes(Term).
attvars_residuals([]) --> [].
attvars_residuals([V|Vs]) -->
( { get_attrs(V, As) }
-> attvar_residuals(As, V)
; []
),
attvars_residuals(Vs).
attvar_residuals([], _) --> [].
attvar_residuals(att(Module,Value,As), V) -->
( { nonvar(V) }
-> % a previous projection predicate could have instantiated
% this variable, for example, to avoid redundant goals
[]
; { attributes:attributed_module(Module, _, _) } ->
% SICStus like run, put attributes back first
{ Value =.. [Name,_|Vs],
NValue =.. [Name,_|Vs],
attributes:put_module_atts(V,NValue)
},
attvar_residuals(As, V),
( { '$undefined'(attribute_goal(V, Goal), Module) }
->
[]
;
{ call(Module:attribute_goal(V, Goal)) },
dot_list(Goal)
)
; ( { current_predicate(Module:attribute_goals/3) }
-> { call(Module:attribute_goals(V, Goals, [])) },
list(Goals)
; { current_predicate(Module:attribute_goal/2) }
-> { call(Module:attribute_goal(V, Goal)) },
dot_list(Goal)
; [put_attr(V, Module, Value)]
),
attvar_residuals(As, V)
).
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
dot_list((A,B)) --> !, dot_list(A), dot_list(B).
dot_list(A) --> [A].
delete_attributes(Term) :-
term_attvars(Term, Vs),
delete_attributes_(Vs).
delete_attributes_([]).
delete_attributes_([V|Vs]) :-
del_attrs(V),
delete_attributes_(Vs).
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) :-
prolog:call_residue_vars(Module:Goal,NewAttVars),
(
attributes:modules_with_attributes([_|_])
->
project_attributes(NewAttVars, Module:Goal)
;
true
),
copy_term(Goal, Goal, Residue).
delayed_goals(G, Vs, NVs, Gs) :-
project_delayed_goals(G),
% term_factorized([G|Vs], [_|NVs], Gs).
copy_term([G|Vs], [_|NVs], Gs).
project_delayed_goals(G) :-
% SICStus compatible step,
% just try to simplify store by projecting constraints
% over query variables.
% called by top_level to find out about delayed goals
attributes:modules_with_attributes([_|_]), !,
attributes:all_attvars(LAV),
LAV = [_|_],
project_attributes(LAV, G), !.
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(AllVs, G) :-
attributes:modules_with_attributes(LMods),
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),
call(Mod:project_attributes(LIV, LAV)), !,
attributes:all_attvars(NLAV),
project_module(LMods,LIV,NLAV).
project_module([_|LMods], LIV, LAV) :-
project_module(LMods,LIV,LAV).