1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 2010-2024, University of Amsterdam 7 SWI-Prolog Solutions b.v. 8 All rights reserved. 9 10 Redistribution and use in source and binary forms, with or without 11 modification, are permitted provided that the following conditions 12 are met: 13 14 1. Redistributions of source code must retain the above copyright 15 notice, this list of conditions and the following disclaimer. 16 17 2. Redistributions in binary form must reproduce the above copyright 18 notice, this list of conditions and the following disclaimer in 19 the documentation and/or other materials provided with the 20 distribution. 21 22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 POSSIBILITY OF SUCH DAMAGE. 34*/ 35 36:- module(block_directive, 37 [ (block)/1, % +Heads 38 op(1150, fx, (block)) 39 ]). 40:- use_module(library(prolog_wrap), []). % make sure it is loaded 41:- autoload(library(error), [instantiation_error/1, domain_error/2]). 42:- autoload(swi(library/lists), [append/3]). 43 44/** <module> Block: declare suspending predicates 45 46This module provides SICStus Prolog-compatible ``:- block BlockSpec, 47...`` declarations for delaying predicate calls if certain arguments are 48unbound. 49 50@see https://sicstus.sics.se/sicstus/docs/3.12.11/html/sicstus/Block-Declarations.html 51*/ 52 53:- op(1150, fx, user:(block)). 54 55:- multifile 56 user:term_expansion/2, 57 block_declaration/2. % Head, Module 58 59head(Var, _) :- 60 var(Var), !, fail. 61head((H:-_B), Head) :- 62 !, 63 head(H, Head). 64head(H, Head) :- 65 ( H = _:_ 66 -> Head = H 67 ; prolog_load_context(module, M), 68 Head = M:H 69 ). 70 71 72%! block(+Heads). 73% 74% Declare predicates to suspend on certain modes. The argument is, 75% like meta_predicate/1, a comma-separated list of modes 76% (_BlockSpecs_). Calls to the predicate is suspended if at least one 77% of the conditions implies by a blockspec evaluated to `true`. A 78% blockspec evaluated to `true` iff all arguments specified as `-' are 79% unbound. 80% 81% Multiple BlockSpecs for a single predicate can appear in one or more 82% `:- block` declarations. The predicate is suspended untill all mode 83% patterns that apply to it are satisfied. 84% 85% The implementation is realised by creating a wrapper that checks the 86% block conditions and either calls the original predicate immediately 87% (if none of the block conditions were true) or uses attributed 88% variables to delay re-evaluating the block condition until any of 89% the arguments in question are bound. 90% 91% @compat SICStus Prolog 92 93block(Spec) :- 94 throw(error(context_error(nodirective, block(Spec)), _)). 95 96expand_block_declaration(Spec, Clauses) :- 97 prolog_load_context(module, Module), 98 phrase(expand_specs(Spec, Module), Clauses). 99 100expand_specs(Var, _) --> 101 { var(Var), 102 !, 103 instantiation_error(Var) 104 }. 105expand_specs(M:Spec, _) --> 106 !, 107 expand_specs(Spec, M). 108expand_specs((A,B), Module) --> 109 !, 110 expand_specs(A, Module), 111 expand_specs(B, Module). 112expand_specs(Head, Module) --> 113 { valid_head(Head), 114 functor(Head, Name, Arity), 115 functor(GenHead, Name, Arity), 116 Clause = '$block_pred'(Head) 117 }, 118 ( { current_predicate(Module:'$block_pred'/1) } 119 -> [] 120 ; [ (:- discontiguous('$block_pred'/1)), 121 (:- public('$block_pred'/1)) 122 ] 123 ), 124 ( { prolog_load_context(module, Module) } 125 -> [ Clause ] 126 ; [ Module:Clause ] 127 ), 128 [ block_directive:block_declaration(GenHead, Module) ]. 129 130valid_head(Head) :- 131 callable(Head), 132 forall(arg(_, Head, A), block_arg(A)). 133 134block_arg(A) :- 135 var(A), 136 !, 137 instantiation_error(A). 138block_arg(-) :- !. 139block_arg(+) :- !. 140block_arg(?) :- !. 141block_arg(A) :- 142 domain_error(block_argument, A). 143 144%! block_wrapper_clauses(+Module, +Head, -Clauses) is det. 145% 146% Build a list of clauses that define a block wrapper around predicate 147% Head in Module. If a wrapper for this predicate has already been 148% defined, Clauses is an empty list. 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, 157 block_wrapper_clause(Module, Name, HelperHead, Wrapper), 158 Clauses) 159 ). 160 161%! block_wrapper_clause(+Module, +Name, +HelperHead, -Clause) is nondet. 162% 163% Generate the clauses for the wrapper. The blockspecs are translated 164% into a helper predicate, where each clause checks one block 165% condition. If a block condition is true, attributes are added to all 166% arguments marked as `-`, so that once any of them are bound, the 167% predicate is called again and the block conditions are re-evaluated. 168% If no block condition was true, the helper predicate fails. 169% 170% Finally, an initialization clause is generated that sets up the 171% actual wrapper. This wrapper first calls the helper predicate to 172% check all block conditions and delay the call if necessary. If the 173% helper predicate fails (i. e. no block condition was true), the 174% wrapped predicate is called immediately. 175% 176% The wrapper must be set up in an initialization clause and not as 177% part of the term expansion, because wrap_predicate/4 wrappers are 178% not retained in saved states, which would cause block declarations 179% to break when loading a saved state. 180 181block_wrapper_clause(Module, Name, HelperHead, (HelperHead :- GenBody)) :- 182 HelperHead =.. [_|HelperArgs], 183 length(HelperArgs, Arity), 184 functor(BlockHead, Name, Arity), 185 Module:'$block_pred'(BlockHead), 186 BlockHead =.. [_|BlockArgs], 187 find_args_to_block_on(BlockArgs, HelperArgs, ToBlockOn), 188 args_to_var_conditions(ToBlockOn, GenBody, GenBody1), 189 GenBody1 = (!, GenBody2), 190 MainHead =.. [Name|HelperArgs], 191 args_to_suspend_calls(ToBlockOn, _IsAlreadyUnblocked, Module:MainHead, GenBody2, true). 192block_wrapper_clause(Module, Name, HelperHead, (:- initialization WrapCall)) :- 193 HelperHead =.. [_|HelperArgs], 194 ToWrapHead =.. [Name|HelperArgs], 195 atom_concat('$block_wrapper$', Name, WrapperName), 196 WrapCall = @(prolog_wrap:wrap_predicate(ToWrapHead, WrapperName, Wrapped, 197 (HelperHead -> true ; Wrapped)), 198 Module). 199 200%! find_args_to_block_on(+BlockArgs, +HeadArgs, -ArgsToBlockOn) is semidet. 201% 202% Collect into ArgsToBlockOn all arguments from HeadArgs for which 203% the corresponding argument in BlockArgs is `-`, indicating that 204% the argument is part of the block condition. 205 206find_args_to_block_on([], [], []) :- !. 207find_args_to_block_on([-|MoreBlockArgs], [Arg|MoreHeadArgs], [Arg|MoreToBlockOn]) :- 208 !, 209 find_args_to_block_on(MoreBlockArgs, MoreHeadArgs, MoreToBlockOn). 210find_args_to_block_on([_|MoreBlockArgs], [_|MoreHeadArgs], ToBlockOn) :- 211 find_args_to_block_on(MoreBlockArgs, MoreHeadArgs, ToBlockOn). 212 213%! args_to_var_conditions(+ArgsToBlockOn, -Conditions, ?ConditionsTail) is semidet. 214% 215% Convert a list of arguments into a conjunction of var/1 checks that 216% succeeds if all arguments are unbound variables. 217% 218% This effectively generates an unrolled version of `maplist(var, 219% ArgsToBlockOn), ConditionsTail`. 220 221args_to_var_conditions([], Tail, Tail) :- !. 222args_to_var_conditions([Arg|MoreArgs], Conditions, Tail) :- 223 Conditions = (var(Arg), MoreConditions), 224 args_to_var_conditions(MoreArgs, MoreConditions, Tail). 225 226%! args_to_suspend_calls(+ArgsToBlockOn, -IsAlreadyUnblocked, +BlockedGoal, -SuspendCalls, +Tail) is semidet. 227% 228% Build a sequence of calls that delays BlockedGoal until any variable 229% in ArgsToBlockOn is bound. IsAlreadyUnblocked should be an unbound 230% fresh variable - it is passed directly to unblock/2, which will bind 231% the variable so that the same blocked goal is not called again by 232% another unblock/2 call from the same group. 233 234args_to_suspend_calls([], _, _, Tail, Tail) :- !. 235args_to_suspend_calls([Arg|MoreArgs], IsAlreadyUnblocked, BlockedGoal, SuspendCalls, Tail) :- 236 SuspendCalls = ('$suspend'(Arg, block_directive, block_directive:unblock(IsAlreadyUnblocked, BlockedGoal)), MoreSuspendCalls), 237 args_to_suspend_calls(MoreArgs, IsAlreadyUnblocked, BlockedGoal, MoreSuspendCalls, Tail). 238 239 240attr_unify_hook(call(ThisGoals), NewVar) :- 241 var(NewVar), 242 !, 243 ( get_attr(NewVar, block_directive, call(OtherGoals)) 244 -> put_attr(NewVar, block_directive, call((ThisGoals, OtherGoals))) 245 ; put_attr(NewVar, block_directive, call(ThisGoals)) 246 ). 247attr_unify_hook(call(Goals), _) :- . 248 249:- public unblock/2. 250unblock(IsAlreadyUnblocked, _) :- IsAlreadyUnblocked == (-), !. 251unblock(-, BlockedGoal) :- . 252 253attribute_goals(Var) --> 254 {get_attr(Var, block_directive, call(Goals))}, 255 !, 256 render_block_goals(Goals). 257 258render_block_goals((Left, Right)) --> 259 render_block_goals(Left), 260 render_block_goals(Right). 261render_block_goals(block_directive:unblock(IsAlreadyUnblocked, BlockedGoal)) --> 262 ( {IsAlreadyUnblocked == (-)} 263 -> [] 264 ; [BlockedGoal] 265 ). 266 267 /******************************* 268 * EXPANSION HOOKS * 269 *******************************/ 270 271systemterm_expansion((:- block(Spec)), Clauses) :- 272 expand_block_declaration(Spec, Clauses). 273systemterm_expansion(Term, Clauses) :- 274 head(Term, Module:Head), 275 block_declaration(Head, Module), 276 block_wrapper_clauses(Module, Head, WrapperClauses), 277 append(WrapperClauses, [Term], Clauses)