34
35:- module(block_directive,
36 [ (block)/1, 37 op(1150, fx, (block))
38 ]). 39:- use_module(library(prolog_wrap), [wrap_predicate/4]). 40
49
50:- op(1150, fx, user:(block)). 51
52:- multifile
53 user:term_expansion/2,
54 block_declaration/2. 55
56head(Var, _) :-
57 var(Var), !, fail.
58head((H:-_B), Head) :- !,
59 head(H, Head).
60head(H, Head) :-
61 ( H = _:_
62 -> Head = H
63 ; prolog_load_context(module, M),
64 Head = M:H
65 ).
66
67
88
89block(Spec) :-
90 throw(error(context_error(nodirective, block(Spec)), _)).
91
92expand_block_declaration(Spec, Clauses) :-
93 prolog_load_context(module, Module),
94 phrase(expand_specs(Spec, Module), Clauses).
95
96expand_specs(Var, _) -->
97 { var(Var), !,
98 instantiation_error(Var)
99 }.
100expand_specs(M:Spec, _) --> !,
101 expand_specs(Spec, M).
102expand_specs((A,B), Module) --> !,
103 expand_specs(A, Module),
104 expand_specs(B, Module).
105expand_specs(Head, Module) -->
106 { valid_head(Head),
107 check_dynamic(Module:Head),
108 functor(Head, Name, Arity),
109 functor(GenHead, Name, Arity),
110 Clause = '$block_pred'(Head)
111 },
112 ( { current_predicate(Module:'$block_pred'/1) }
113 -> []
114 ; [ (:- discontiguous('$block_pred'/1)),
115 (:- public('$block_pred'/1))
116 ]
117 ),
118 ( { prolog_load_context(module, Module) }
119 -> [ Clause ]
120 ; [ Module:Clause ]
121 ),
122 [ block_directive:block_declaration(GenHead, Module) ].
123
124valid_head(Head) :-
125 callable(Head),
126 forall(arg(_, Head, A), block_arg(A)).
127
128check_dynamic(Head) :-
129 ( predicate_property(Head, dynamic)
130 ; predicate_property(Head, foreign)
131 ),
132 permission_error(block, predicate, Head).
133check_dynamic(_).
134
135block_arg(A) :-
136 var(A), !,
137 instantiation_error(A).
138block_arg(-) :- !.
139block_arg(+) :- !.
140block_arg(?) :- !.
141block_arg(A) :-
142 domain_error(block_argument, A).
143
149
150block_wrapper_clauses(Module, Head, Clauses) :-
151 functor(Head, Name, Arity),
152 atom_concat('$block_helper$', Name, HelperName),
153 functor(HelperHead, HelperName, Arity),
154 ( current_predicate(_, Module:HelperHead)
155 -> Clauses = []
156 ; findall(Wrapper, block_wrapper_clause(Module, Name, HelperHead, Wrapper), Clauses)
157 ).
158
179
180block_wrapper_clause(Module, Name, HelperHead, (HelperHead :- GenBody)) :-
181 HelperHead =.. [_|HelperArgs],
182 length(HelperArgs, Arity),
183 functor(BlockHead, Name, Arity),
184 Module:'$block_pred'(BlockHead),
185 BlockHead =.. [_|BlockArgs],
186 find_args_to_block_on(BlockArgs, HelperArgs, ToBlockOn),
187 args_to_var_conditions(ToBlockOn, GenBody, GenBody1),
188 GenBody1 = (!, GenBody2),
189 MainHead =.. [Name|HelperArgs],
190 args_to_suspend_calls(ToBlockOn, _IsAlreadyUnblocked, Module:MainHead, GenBody2, true).
191block_wrapper_clause(Module, Name, HelperHead, (:- initialization WrapCall)) :-
192 HelperHead =.. [_|HelperArgs],
193 ToWrapHead =.. [Name|HelperArgs],
194 atom_concat('$block_wrapper$', Name, WrapperName),
195 WrapCall = prolog_wrap:wrap_predicate(Module:ToWrapHead, WrapperName, Wrapped, (HelperHead -> true ; Wrapped)).
196
202
203find_args_to_block_on([], [], []) :- !.
204find_args_to_block_on([-|MoreBlockArgs], [Arg|MoreHeadArgs], [Arg|MoreToBlockOn]) :-
205 !,
206 find_args_to_block_on(MoreBlockArgs, MoreHeadArgs, MoreToBlockOn).
207find_args_to_block_on([_|MoreBlockArgs], [_|MoreHeadArgs], ToBlockOn) :-
208 find_args_to_block_on(MoreBlockArgs, MoreHeadArgs, ToBlockOn).
209
217
218args_to_var_conditions([], Tail, Tail) :- !.
219args_to_var_conditions([Arg|MoreArgs], Conditions, Tail) :-
220 Conditions = (var(Arg), MoreConditions),
221 args_to_var_conditions(MoreArgs, MoreConditions, Tail).
222
230
231args_to_suspend_calls([], _, _, Tail, Tail) :- !.
232args_to_suspend_calls([Arg|MoreArgs], IsAlreadyUnblocked, BlockedGoal, SuspendCalls, Tail) :-
233 SuspendCalls = ('$suspend'(Arg, block_directive, block_directive:unblock(IsAlreadyUnblocked, BlockedGoal)), MoreSuspendCalls),
234 args_to_suspend_calls(MoreArgs, IsAlreadyUnblocked, BlockedGoal, MoreSuspendCalls, Tail).
235
236
237attr_unify_hook(call(ThisGoals), NewVar) :-
238 var(NewVar),
239 !,
240 ( get_attr(NewVar, block_directive, call(OtherGoals))
241 -> put_attr(NewVar, block_directive, call((ThisGoals, OtherGoals)))
242 ; put_attr(NewVar, block_directive, call(ThisGoals))
243 ).
244attr_unify_hook(call(Goals), _) :- Goals.
245
246:- public unblock/2. 247unblock(IsAlreadyUnblocked, _) :- IsAlreadyUnblocked == (-), !.
248unblock(-, BlockedGoal) :- BlockedGoal.
249
250attribute_goals(Var) -->
251 {get_attr(Var, block_directive, call(Goals))},
252 !,
253 render_block_goals(Goals).
254
255render_block_goals((Left, Right)) -->
256 render_block_goals(Left),
257 render_block_goals(Right).
258render_block_goals(block_directive:unblock(IsAlreadyUnblocked, BlockedGoal)) -->
259 ( {IsAlreadyUnblocked == (-)}
260 -> []
261 ; [BlockedGoal]
262 ).
263
264
268
269rename_clause((Head :- Body), Prefix, (NewHead :- Body)) :- !,
270 rename_clause(Head, Prefix, NewHead).
271rename_clause(M:Head, Prefix, M:NewHead) :-
272 rename_clause(Head, Prefix, NewHead).
273rename_clause(Head, Prefix, NewHead) :-
274 Head =.. [Name|Args],
275 atom_concat(Prefix, Name, WrapName),
276 NewHead =.. [WrapName|Args].
277
278
279 282
283system:term_expansion((:- block(Spec)), Clauses) :-
284 expand_block_declaration(Spec, Clauses).
285system:term_expansion(Term, Clauses) :-
286 head(Term, Module:Head),
287 block_declaration(Head, Module),
288 block_wrapper_clauses(Module, Head, WrapperClauses),
289 append(WrapperClauses, [Term], Clauses)