34
35:- module(rtchecks,
36 [(rtcheck)/1,
37 unrtcheck/1,
38 rtcheck_wrap/2,
39 with_rtchecks/1,
40 op(1150, fx, rtcheck)
41 ]). 42
43:- discontiguous '$exported_op'/3. 44:- use_module(library(apply)). 45:- use_module(library(lists)). 46:- reexport(library(compound_expand)). 47:- use_module(library(error)). 48:- use_module(library(neck)). 49:- use_module(library(assertions)). 50:- use_module(library(metaprops)). 51:- use_module(library(ppntprops)). 52:- use_module(library(prolog_wrap)). 53:- use_module(library(rtcprops), []). 54:- use_module(library(ctrtchecks)). 55:- use_module(system:library(rtchecks_rt)). 56:- use_module(library(qualify_meta_goal)). 57:- use_module(library(group_pairs_or_sort)). 58:- after(assertions). 59:- init_expansors. 60
61:- multifile
62 prolog:rename_predicate/2. 63
64wrap_asr_rtcheck(Asr, rtcheck(Asr)).
65
66rtcheck_wrap(M, G, CM, RAsrL) :-
67 '$wrap_predicate'(M:G, rtchecks, _, W, rtcheck_pred(W, M, CM, RAsrL)).
68
69rtcheck_wrap_each(M, G, P, P-AsrL) :-
70 qualify_meta_goal(G, M, CM, P),
71 maplist(wrap_asr_rtcheck, AsrL, RAsrL),
72 rtcheck_wrap(M, G, CM, RAsrL).
73
74rtcheck_wrap(M, G) :-
75 functor(G, F, A),
76 functor(P, F, A),
77 collect_asrs(F/A, M, L, []),
78 79 maplist(rtcheck_wrap_each(M, G, P), L).
80
81wrappers(Var) -->
82 { var(Var),
83 !,
84 instantiation_error(Var)
85 }.
86wrappers((A,B)) -->
87 wrappers(A),
88 wrappers(B).
89wrappers(Name//Arity) -->
90 { atom(Name), integer(Arity), Arity >= 0,
91 Arity1 is Arity+2
92 },
93 wrappers(Name/Arity1).
94wrappers(Name/Arity) -->
95 { atom(Name), integer(Arity), Arity >= 0,
96 functor(Head, Name, Arity),
97 prolog_load_context(module, Module)
98 },
99 ['$rtchecked'(Head)],
100 [(:- initialization(rtcheck_wrap(Module, Head)))].
101
102collect_asrs(Var, _) -->
103 { var(Var),
104 !,
105 instantiation_error(Var)
106 }.
107collect_asrs((A,B), M) -->
108 !,
109 collect_asrs(A, M),
110 collect_asrs(B, M).
111collect_asrs(Name//Arity, M) -->
112 { atom(Name), integer(Arity), Arity >= 0,
113 !,
114 Arity1 is Arity+2
115 },
116 collect_asrs(Name/Arity1, M).
117collect_asrs(Name/Arity, M) -->
118 { atom(Name), integer(Arity), Arity >= 0,
119 functor(H, Name, Arity)
120 },
121 ( { findall(H-Asr, current_assertion(rt, H, M, Asr), PIAsrLL),
122 group_pairs_or_sort(PIAsrLL, [H-AsrL])
123 }
124 ->[H-AsrL]
125 ; []
126 ).
127
128:- meta_predicate
129 rtcheck(:),
130 unrtcheck(:). 131
132rtcheck(M:PIList) :-
133 collect_asrs(PIList, M, PIL, []),
134 rtcheck2(M-PIL).
135
136unrtcheck(M:PIList) :-
137 collect_asrs(PIList, M, PIL, []),
138 unrtcheck2(M-PIL).
139
140generate_rtchecks(Preds, Clauses) :-
141 phrase(( ( { '$current_source_module'(CM),
142 '$defined_predicate'(CM:'$rtchecked'(_))
143 }
144 ->[]
145 ; [(:- discontiguous('$rtchecked'/1)),
146 (:- public '$rtchecked'/1)]
147 ),
148 wrappers(Preds)
149 ), Clauses).
150
151term_expansion((:- rtcheck(Preds)), Clauses) :-
152 generate_rtchecks(Preds, Clauses).
153
154term_expansion(assertions:asr_head_prop(Asr, M, Pred, Status, Type, Dict, Ctx, From),
155 [assertions:asr_head_prop(Asr, M, Pred, Status, Type, Dict, Ctx, From)|Clauses]) :-
156 current_prolog_flag(rtchecks_static, StaticL),
157 memberchk(Status, StaticL),
158 Type \= (prop),
159 \+ prop_asr(Pred, M, _, (prop), _, _, _),
160 is_valid_status_type(Status, Type),
161 \+ ( '$current_source_module'(CM),
162 '$defined_predicate'(CM:'$rtchecked'(_)),
163 CM:'$rtchecked'(Pred)
164 ),
165 functor(Pred, Func, Arity),
166 generate_rtchecks(Func/Arity, Clauses).
167
168:- multifile
169 sandbox:safe_directive/1.
175sandbox:safe_directive(Dir) :-
176 ground(Dir),
177 local_rtchecks_dir(Dir).
178
179local_rtchecks_dir(rtcheck(Preds)) :-
180 local_preds(Preds).
181
182local_preds((A,B)) :-
183 local_preds(A),
184 local_preds(B).
185
186local_preds(Name/Arity) :-
187 atom(Name), integer(Arity).
188local_preds(Name//Arity) :-
189 atom(Name), integer(Arity).
190
191:- meta_predicate with_rtchecks(0 ). 192with_rtchecks(Goal) :-
193 collect_rtcheckable_preds(GLLL),
194 setup_call_cleanup(
195 ( rtchecks_disable,
196 wrap_ppcheck,
197 maplist(rtcheck2, GLLL),
198 rtchecks_enable
199 ),
200 Goal,
201 ( rtchecks_disable,
202 maplist(unrtcheck2, GLLL),
203 unwrap_ppcheck,
204 rtchecks_enable
205 )).
206
207rtcheck2(M-GLL) :-
208 discontiguous(M:'$rtchecked'/1),
209 dynamic(M:'$rtchecked'/1),
210 public(M:'$rtchecked'/1),
211 maplist(rtcheck2(M), GLL).
212
213rtcheck2(M, (CM:G)-AsrL) :-
214 maplist(wrap_asr_rtcheck, AsrL, RAsrL),
215 dyn_rtcheck_record(G, M),
216 rtcheck_wrap(M, G, CM, RAsrL).
217
218ppassertion_type_goal(Goal, Status, Call, Loc) :-
219 pp_status(Status),
220 ( Goal =.. [Status, Call],
221 Loc = []
222 ; Goal =.. [Status, Call, Loc]
223 ),
224 neck.
225
226wrap_ppcheck :-
227 forall(ppassertion_type_goal(Goal, Status, Call, Loc),
228 '$wrap_predicate'(ppntprops:Goal, rtchecks, _, _, rtcheck_call(Status, Call, Loc))).
229
230unwrap_ppcheck :-
231 forall(( pp_status(Status),
232 member(Arity, [1, 2])
233 ),
234 unwrap_predicate(ppntprops:Status/Arity, rtchecks)).
235
236dyn_rtcheck_record(Head, M) :-
237 ( M:'$rtchecked'(Head)
238 -> true
239 ; assertz(M:'$rtchecked'(Head))
240 ).
241
242unrtcheck2(M-GLL) :-
243 dynamic(M:'$rtchecked'/1),
244 maplist(unrtcheck2(M), GLL).
245
246unrtcheck2(M, H-_) :-
247 functor(H, F, A),
248 ( M:'$rtchecked'(H)
249 -> retractall(M:'$rtchecked'(H)),
250 unwrap_predicate(M:F/A, rtchecks)
251 ; true
252 ).
253
254collect_rtcheckable_preds(Groups) :-
255 findall(M-((CM:G)-Asr),
256 ( current_assertion(rt, H, M, Asr),
257 functor(H, F, A),
258 functor(G, F, A),
259 qualify_meta_goal(G, M, CM, H)
260 ), PIAsrLL),
261 group_pairs_or_sort(PIAsrLL, Groups)