34
35:- module(each_call_cleanup,
36 [
37 each_call_cleanup/3, 38 each_call_catcher_cleanup/4, 39 redo_call_cleanup/3, 40 trusted_redo_call_cleanup/3 41 ]).
56:- set_module(class(library)). 57
58:- meta_predicate
59 redo_call_cleanup(0,0,0),
60 call_then_cut(0),
61 each_call_catcher_cleanup(0,0,?,0),
62 each_call_cleanup(0,0,0),
63 trusted_redo_call_cleanup(0,0,0). 64
65
66
68
69call_then_cut(G):-
70 prolog_current_choice(CP),
71 prolog_choice_attribute(CP,parent,PC),
72 prolog_choice_attribute(PC,frame,Frame),prolog_frame_attribute(Frame,goal,PG),
73 prolog_choice_attribute(CP,frame,CFrame),prolog_frame_attribute(CFrame,goal,CG),nop(dmsg(call_then_cut(PG,CG))),
74 call((G,(deterministic(true)->prolog_cut_to(PC);true))).
75
76
77
78:- module_transparent(pt1/1). 79:- module_transparent(pt2/1). 80
81
112redo_call_cleanup(Setup,Goal,Cleanup):-
113 assertion(each_call_cleanup:unshared_vars(Setup,Goal,Cleanup)),
114 trusted_redo_call_cleanup(Setup,Goal,Cleanup).
115
116trusted_redo_call_cleanup(Setup,Goal,Cleanup):-
117 HdnCleanup = mquietly(Cleanup),
118 setup_call_cleanup(Setup,
119 ((Goal,deterministic(DET)),
120 (notrace(DET == true) -> ! ;
121 ((HdnCleanup,notrace(nb_setarg(1,HdnCleanup,true)));
122 (Setup,notrace(nb_setarg(1,HdnCleanup,Cleanup)),notrace(fail))))),
123 HdnCleanup).
124
125:- '$hide'(trusted_redo_call_cleanup/3).
134each_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup):-
135 setup_call_catcher_cleanup(true,
136 each_call_cleanup(Setup, Goal, Cleanup), Catcher, true).
137
138:- thread_local(ecc:'$each_call_cleanup'/2). 139:- thread_local(ecc:'$each_call_undo'/2).
147each_call_cleanup(Setup,Goal,Cleanup):-
148 ((ground(Setup);ground(Cleanup)) ->
149 trusted_redo_call_cleanup(Setup,Goal,Cleanup);
150 setup_call_cleanup(
151 asserta((ecc:'$each_call_cleanup'(Setup,Cleanup)),HND),
152 trusted_redo_call_cleanup(pt1(HND),Goal,pt2(HND)),
153 (pt2(HND),erase(HND)))).
154
155 158
159:- public(ecc_throw_failure/1). 160
161ecc_throw_failure(Why):- throw(error(assertion_error(Why),_)).
162
163pt1(HND) :-
164 clause(ecc:'$each_call_cleanup'(Setup,Cleanup),true,HND)
165 ->
166 ('$sig_atomic'(Setup) ->
167 asserta(ecc:'$each_call_undo'(HND,Cleanup)) ;
168 ecc_throw_failure(failed_setup(Setup)))
169 ;
170 ecc_throw_failure(pt1(HND)).
171
172pt2(HND) :-
173 retract(ecc:'$each_call_undo'(HND,Cleanup)) ->
174 ('$sig_atomic'(Cleanup)->true ;ecc_throw_failure(failed_cleanup(Cleanup)));
175 ecc_throw_failure(failed('$each_call_undo'(HND))).
176
177:- if(true). 178:- system:import(each_call_cleanup/3). 179:- system:import(each_call_catcher_cleanup/4). 180:- system:import(redo_call_cleanup/3). 181:- system:import(pt1/1). 182:- system:import(pt2/1). 183:- endif. 184
187unshared_vars(Setup,_,_):- ground(Setup),!.
188unshared_vars(Setup,Goal,Cleanup):-
189 term_variables(Setup,SVs),
190 term_variables(Cleanup,CVs),
191 ( CVs==[] -> true; unshared_set(SVs,CVs)),
192 term_variables(Goal,GVs),
193 ( GVs==[] -> true;
194 (unshared_set(SVs,GVs),
195 unshared_set(CVs,GVs))).
196
197unshared_set([],_).
198unshared_set([E1|Set1],Set2):-
199 not_in_identical(E1,Set2),
200 unshared_set(Set1,Set2).
201
202not_in_identical(X, [Y|Ys]) :- X \== Y, not_in_identical(X, Ys)
Utility LOGICMOO EACH CALL
Before a clause does a redo it allows code to be called. To execute between calls during backtracking. Allows us to put code before and after a clause.
Utility LOGICMOO_EACH_CALL_CLEANUP Works together with Each Call to allow code before and after a clause for backtracking.
*/