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