34
35:- module(rtchecks_utils,
36 [ handle_rtcheck/1,
37 intercept_rtc/1,
38 call_rtc/1,
39 save_rtchecks/1,
40 load_rtchecks/1,
41 assrchk_error/1
42 ]). 43
44:- use_module(library(assertions)). 45:- use_module(library(plprops)). 46:- use_module(library(prolog_codewalk), []). 47:- use_module(library(filtered_backtrace)). 48:- use_module(library(intercept)). 49:- use_module(library(rtchecks), [with_rtchecks/1]). 50:- init_expansors. 51
52:- multifile
53 prolog:message_location//1.
58filtered_backtrace:no_backtrace_clause_hook(_, ontrace).
59filtered_backtrace:no_backtrace_clause_hook(_, call_inoutex).
60filtered_backtrace:no_backtrace_clause_hook(_, rtchecks_utils).
61filtered_backtrace:no_backtrace_clause_hook(_, rtchecks_rt).
62filtered_backtrace:no_backtrace_clause_hook(_, rtchecks).
63filtered_backtrace:no_backtrace_clause_hook(_, ctrtchecks).
64filtered_backtrace:no_backtrace_clause_hook(_, intercept).
65filtered_backtrace:no_backtrace_clause_hook(_, globprops).
66filtered_backtrace:no_backtrace_clause_hook(_, typeprops).
67filtered_backtrace:no_backtrace_clause_hook(_, metaprops).
68filtered_backtrace:no_backtrace_clause_hook(_, send_check).
69filtered_backtrace:no_backtrace_clause_hook(_, plprops).
70filtered_backtrace:no_backtrace_clause_hook(_, context_values).
71
72:- type location_t/1.
73location_t(Loc) :-
74 ( clause('$messages':swi_location(Term, _, _), _)
75 ; clause(prolog:message_location(Term, _, _), _)
76 ; Term = []
77 ),
78 nonvar(Term),
79 Term = Loc.
80
81:- type assrchk_error/1 #
82 "Specifies the format of an assertion check error.".
83
84assrchk_error(assrchk(error(Type, _Pred, PropValues, PLoc, ALoc))) :-
85 rtcheck_type(Type),
86 keylist(PropValues),
87 location_t(PLoc),
88 location_t(ALoc).
89
90:- type rtcheck_type/1 # "Specifies the type of run-time errors.".
91
92rtcheck_type(comp).
93rtcheck_type(pp_check).
94rtcheck_type(success).
95rtcheck_type(compat).
96rtcheck_type(compatpos).
97rtcheck_type(calls).
103handle_rtcheck(RTCheck) :-
104 \+ ( copy_term_nat(RTCheck, Term),
105 numbervars(Term, 0, _,
106 [ singletons(true)
107 ]),
108 print_message(error, Term),
109 fail
110 ).
111
112:- multifile
113 prolog:error_message_signal//1,
114 prolog:error_message//1,
115 prolog:message//1. 116
117prolog:error_message_signal(RTCheck) -->
118 prolog:message(RTCheck).
119
120prolog:error_message(unintercepted_signal(Signal)) -->
121 ( prolog:error_message_signal(Signal) -> []
122 ; ['unintercepted signal: ~p'-[Signal]]
123 ).
124
127
128:- meta_predicate '$foldl'(3,+,?,?). 129
130'$foldl'(Goal, List, V1, V) :-
131 '$foldl_'(List, Goal, V1, V).
132
133'$foldl_'([], _, V, V).
134'$foldl_'([H|T], Goal, V1, V) :-
135 call(Goal, H, V1, V2),
136 '$foldl_'(T, Goal, V2, V).
137
138rt_translate_message(Msg) -->
139 '$messages':translate_message(Msg),
140 [nl].
141
142prolog:message(acheck(checks, RTChecks)) -->
143 '$foldl'(rt_translate_message, RTChecks).
144
145prolog:message(assrchk(Error)) -->
146 assr_error_message(Error),
147 !.
148
149assr_error_message(error(Type, Pred, PropValues, PLoc, ALoc)) -->
150 '$messages':swi_location(PLoc),
151 ['Assertion failure for ~q.'-[Pred], nl],
152 '$messages':swi_location(ALoc),
153 [' In *~w*, unsatisfied properties: '-[Type], nl],
154 '$foldl'(prop_values, PropValues).
155
156prop_values(From/Prop-Values) -->
157 [' '],
158 '$messages':swi_location(From),
159 ['~q'-[Prop]],
160 ( {Values = []}
161 ->['.']
162 ; [', because: ~q.'-[Values]]
163 ),
164 [nl].
165
166:- thread_local rtcheck_db/1. 167
168:- meta_predicate
169 call_rtc(0 ),
170 intercept_rtc(0 ). 171
172:- true pred call_rtc/1 : callable # "This predicate calls a goal and if an
173 rtcheck signal is intercepted, an error message is shown and
174 the execution continues. Alternatively, it is re-raised as an
175 exception depending on the flag rtchecks_abort_on_error
176 value.".
177
178call_rtc(Goal) :- intercept_rtc(with_rtchecks(Goal)).
179
180intercept_rtc(Goal) :-
181 Error = assrchk(_),
182 ( current_prolog_flag(rtchecks_abort_on_error, yes)
183 ->intercept(Goal, Error, throw(Error)) 184 ; intercept(Goal, Error,
185 notrace(( handle_rtcheck(Error),
186 filtered_backtrace(100)
187 )))
188 ).
189
190:- meta_predicate save_rtchecks(0). 191
192:- pred save_rtchecks/1 : callable # "Asserts in rtcheck_db/1 all the
193 run-time check exceptions thrown by the goal.".
194
195save_rtchecks(Goal) :-
196 RTError = assrchk(_),
197 intercept(Goal, RTError, assertz(rtcheck_db(RTError))).
198
199:- pred load_rtchecks/1 => list(assrchk_error) # "retract the
200 rtcheck_db/1 facts and return them in a list.".
201
202load_rtchecks(RTChecks) :-
203 findall(RTCheck, retract(rtcheck_db(RTCheck)), RTChecks)
Useful predicates to facilitate work with run-time checks.
*/