1:- module(lockable_vars,[
2 lock_vars/1,
3 unlock_vars/1,
4 with_vars_unlocked/1,
5 with_vars_relocked/1,
6 with_vars_locked/1,
7 with_vars_locked/2,
8 with_some_vars_locked/2,
9 with_vars_locked/3,
10 with_vars_locked_old/2,
11 with_vars_locked_old/3,
12 with_vars_locked_trusted/3,
13 with_quiet_vars_lock/1,
14 with_vars_lock_else/2,
15 skip_varlocks/0]).
23:- set_module(class(library)). 24
33lock_vars(Term):-lock_vars(lockable_vars:just_fail,Term).
34
35just_fail(_):- notrace( \+ skip_varlocks),!.
36just_fail(_).
38skip_varlocks:- current_prolog_flag(skip_varlocks , TF),!,TF==true.
39skip_varlocks:- current_prolog_flag(unsafe_speedups , true) ,!.
40
41:- set_prolog_flag(skip_varlocks,false). 42
43:- meta_predicate(lock_vars(1,+)). 44lock_vars(_Notify,Var):- notrace(skip_varlocks; Var==[]),!.
46lock_vars(Notify,[Var|Vars]):- !, PVs=..[vv|[Var|Vars]],
47 lock_these_vars_now(Notify,1,[Var|Vars],PVs),!.
48
49lock_vars(Notify,Term):- term_variables(Term,Vs),lock_vars(Notify,Vs).
50
51lock_these_vars_now(Notify,N0,[Var|Vars],PVs):-!,
52 ignore((var(Var),
53 put_attr(Var,vl,when_rest(Notify,N0,Var,PVs)))),
54 N is N0+1,
55 lock_these_vars_now(Notify,N,Vars,PVs).
56lock_these_vars_now(_,_,[],_).
57
58vl:attr_unify_hook(InSLock,Value):-
59 current_prolog_flag(skip_varlocks,true)-> true;
60 with_vars_unlocked(vl_attr_unify_hook(InSLock,Value)).
61
62vl_attr_unify_hook(InSLock,Value):- compound(InSLock), InSLock = slock(InLock,Else,Sorted),!,
63 check_slock(InLock,Else,InSLock,Sorted,Value).
64vl_attr_unify_hook(A,B):- vlauh(A,B),!.
65
66vlauh(when_rest(Notify,N,_Var,VVs),VarValue):-
67 arg(NN,VVs,Was),Was==VarValue,
68 NN\==N,!,
69 dmsg(collide_locked_var(Notify,VarValue)),
70 call(Notify,VarValue).
71
74
75vlauh(_,_):- current_prolog_flag(skip_varlocks,true),!.
76
77vlauh(_,_):- on_x_fail(( \+ thread_self_main)),!,fail.
79vlauh(when_rest(Notify,N,Var,VVs),VarValue):-
80 \+ (var(VarValue);locking_verbatum_var(VarValue)),!,
81 dmsg(error_locked_var1(when_rest(Notify,N,Var,VVs),VarValue)),
82 (current_prolog_flag(debugg,true)->((dumpST,
83 dmsg(error_locked_var2(when_rest(Notify,N,Var,VVs),VarValue))));true),
84 (current_prolog_flag(debugg,true)->break;true),
85 call(Notify,VarValue),!.
86
87vlauh(when_rest(Notify,N,Var,VVs),VarValue):- var(VarValue),!,
88 (get_attr(VarValue,vl,when_rest(Notify,N,Var,VVs))
89 -> fail ;
90 put_attr(VarValue,vl,when_rest(Notify,N,Var,VVs))).
91
92vlauh(_,VarValue):- locking_verbatum_var(VarValue),!,variable_name_or_ref(VarValue,_),!.
93
94
96locking_verbatum_var(Var):-var(Var),!,fail.
97locking_verbatum_var('$VAR'(_)).
98locking_verbatum_var('aVar'(_)).
99locking_verbatum_var('aVar'(_,_)).
100
101:- thread_local(t_l:varname_lock/1). 102
103unify_name_based0(Var1, Var2):- \+ atom(Var1),variable_name_or_ref(Var1,Name),!,unify_name_based0(Name, Var2).
104unify_name_based0(Name1, Var):- if_defined(t_l:var_locked(What),fail),!,((get_var_name(Var,Name2),Name1==Name2)->true;call(What,Var)).
105unify_name_based0(_Form, _OtherValue):- local_override(no_kif_var_coroutines,G),!,call(G).
106unify_name_based0(Name1, Var):- get_var_name(Var,Name2),!,Name1=Name2,!.
107unify_name_based0(Name1, Var):- get_attr(Var, vn, Name2),!,combine_varnames(Name1,Name2,Name),(Name2==Name->true;put_attr(Var,vn,Name)).
108unify_name_based0(Name1, Var):- var(Var),!,put_attr(Var, vn, Name1).
109unify_name_based0(_, Var):- nonvar(Var),!.
113unify_name_based0(_Form, _OtherValue):-!.
114
115combine_varnames(Name1,Name2,Name1):-Name1==Name2,!.
116combine_varnames(Name1,Name2,Name):-
117 ((atom_concat(_,Name1,Name2);atom_concat(Name1,_,Name2)) -> Name=Name2 ; (
118 ((atom_concat(Name2,_,Name1);atom_concat(_,Name2,Name1)) -> Name=Name1 ; (
119 (atomic_list_concat([Name2,'_',Name1],Name)))))).
128unlock_vars(Term):- must(quietly((term_attvars(Term,Vs),maplist(delete_vl,Vs)))).
129
130delete_vl( Var):- var(Var),!, del_attr(Var,vl).
131delete_vl( Term):- term_attvars(Term,Vs),maplist(delete_vl,Vs).
132
134
135:- meta_predicate(with_vars_locked_old(1,:)). 136with_vars_locked_old(Notify,Goal):- term_variables(Goal,Vs),with_vars_locked_old(Notify,Vs,Goal).
137
138:- meta_predicate(with_vars_locked_old(1,?,:)). 139with_vars_locked_old(_Notify,_Vs,Goal):- notrace(skip_varlocks),!,Goal.
140with_vars_locked_old(Notify,Vs0,Goal):- term_variables(Vs0,Vs),with_vars_locked_trusted(Notify,Vs,Goal).
141
142:- meta_predicate(with_vars_locked_trusted(1,?,:)). 143with_vars_locked_trusted(_Notify,_Vs,Goal):- notrace(skip_varlocks),!,Goal.
144with_vars_locked_trusted(Notify,Vs,Goal):- set_prolog_flag(access_level,system),
145 trusted_redo_call_cleanup(
146 lock_vars(Notify,Vs),
147 (nop(trace),Goal),
148 maplist(delete_vl,Vs)).
149
150
151:- thread_local(t_l:on_vars_lock_failed/1). 152
153:- meta_predicate(with_vars_locked(:)). 154with_vars_locked(Goal):- with_vars_locked(Goal,Goal).
155
156:- meta_predicate(with_some_vars_locked(+,:)). 157with_some_vars_locked(_Vars,Goal):-!, Goal.
158with_some_vars_locked(Vars,Goal):-
159 with_vars_locked(Vars,Goal) *-> true ; Goal.
160
161:- meta_predicate(with_vars_locked(+,:)). 162with_vars_locked(Vars,Goal):-
163 term_variables(Vars,Vs),sort(Vs,Sorted),!,
164 with_vars_slocked(lookup_how,Sorted,Goal).
165 166
167:- meta_predicate(with_vars_unlocked(:)). 168with_vars_unlocked(Goal):-
169 locally(current_prolog_flag(skip_varlocks,true), Goal).
170
171:- meta_predicate(with_vars_relocked(0)). 172with_vars_relocked(Goal):-
173 locally(current_prolog_flag(skip_varlocks,false), Goal).
174
175:- meta_predicate(with_vars_locked(1,+,:)). 176with_vars_locked(Else,Vars,Goal):-
177 term_variables(Vars,Vs),sort(Vs,Sorted),!,
178 with_vars_slocked(Else,Sorted,Goal).
179 180
181vl1:attr_unify_hook(InLock,Value):- with_vars_unlocked(vl1_attr_unify_hook(InLock,Value)).
182
183vl1_attr_unify_hook(InLock,Value):-
184 (var(Value)
185 -> put_attr(Value,vl1,InLock)
186 ; (InLock=vlock(YesNo,Else),
187 (YesNo==no->true;Else))).
188
189with_vars_slocked(_Else,Sorted,Goal):- notrace(skip_varlocks;Sorted==[]),!,call(Goal).
190with_vars_slocked(Else,[Var],Goal):- fail,!,
191 InLock = vlock(no,call(Else,Var)),
192 setup_call_cleanup(
193 put_attr(Var,vl1,InLock),
194 call_in_lock(InLock,Goal),
195 del_attr(Var,vl1)).
196
197with_vars_slocked(Else,Sorted,Goal):-
198 InLock = slock(no,Else,Sorted),
199 setup_call_cleanup(
200 maplist(lock_as_sorted(InLock),Sorted),
201 call_in_lock(InLock,Goal),
202 maplist(unlock_as_sorted(InLock),Sorted)).
203
204call_in_lock(InLock,Goal):-
205 206 trusted_redo_call_cleanup(
207 nb_setarg(1,InLock,yes),
208 Goal,
209 nb_setarg(1,InLock,no)).
210
211lock_as_sorted(InLock,Var):- put_attr(Var,vl,InLock).
212unlock_as_sorted(InLock,Var):- ignore((attvar(Var),get_attr(Var,vl,InLockW),InLock==InLockW,del_attr(Var,vl))).
213
214:- meta_predicate(check_slock(+,:,+,+,+)). 215check_slock(no,_Else,InSLock,_Sorted,Value):- !,
216 ((var(Value), \+ get_attr(Value,vl,_)) -> put_attr(Value,vl,InSLock); true).
217check_slock(yes,Else,InSLock,Sorted,Value):-
218 (test_slock(yes,Else,InSLock,Sorted,Value)-> true ;
219 failed_slock(yes,Else,InSLock,Sorted,Value)),!.
220
221:- meta_predicate(failed_slock(+,:,+,+,+)). 222failed_slock(yes,_:Else,_InSLock,_Sorted,_Value):- builtin_slock(Else),!,fail.
223failed_slock(yes,_:lookup_how,InSLock,Sorted,Value):-!,
224 (t_l:on_vars_lock_failed(Else)-> failed_slock(yes,Else,InSLock,Sorted,Value);fail).
225failed_slock(yes,Else,InSLock,_Sorted,_Value):- trace,call(Else,InSLock),fail.
226
227:- meta_predicate(builtin_slock(*)). 228builtin_slock(just_fail):- !.
229builtin_slock(fail):- !.
230builtin_slock(trace):- !,trace.
231builtin_slock(dbreak):- !,dbreak.
232
233:- meta_predicate(with_quiet_vars_lock(:)). 234with_quiet_vars_lock(M:G):- with_vars_lock_else(M:just_fail,M:G).
235
236:- meta_predicate(with_vars_lock_else(1,:)). 237with_vars_lock_else(Else,M:G):-
238 locally(t_l:on_vars_lock_failed(M:Else),M:G).
239
240
241test_slock(yes,_Else,InSLock,Sorted,Value):-
242 var(Value),
243 sort(Sorted,SortedW1),Sorted==SortedW1,
244 (get_attr(Value,vl,slock(_VYN,_VElse,VSorted))
245 -> VSorted \== Sorted ; put_attr(Value,vl,InSLock)).
246
247
248
Utility LOGICMOO LOCKABLE VARS
This module prevents bugs due accidental tampering, allows one to write code that keeps free variables from being accidently tampered with unification one way.