View source with raw comments or as raw
    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-2012, University of Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(block_directive,
   36	  [ (block)/1,			% +Heads
   37	    op(1150, fx, (block))
   38	  ]).

Block: declare suspending predicates

This module realises SICStus Prolog :- block BlockSpec, ... declarations using a wrapper predicate that calls the real implementation through a coroutining primitive (typically when/2, but freeze/2 for simple cases).

To be done
- This emulation is barely tested. */
   50:- multifile
   51	user:term_expansion/2,
   52	block_declaration/2.		% Head, Module
   53
   54head(Var, _) :-
   55	var(Var), !, fail.
   56head((H:-_B), Head) :- !,
   57	head(H, Head).
   58head(H, Head) :-
   59	(   H = _:_
   60	->  Head = H
   61	;   prolog_load_context(module, M),
   62	    Head = M:H
   63	).
 block(+Heads)
Declare predicates to suspend on certain modes. The argument is, like meta_predicate/1, a comma-separated list of modes (BlockSpecs). Calls to the predicate is suspended if at least one of the conditions implies by a blockspec evaluated to true. A blockspec evaluated to true iff all arguments specified as `-' are unbound.

Multiple BlockSpecs for a single predicate can appear in one or more :- block declarations. The predicate is suspended untill all mode patterns that apply to it are satisfied.

The implementation is realised by creating a wrapper that uses when/2 to realize suspension of the renamed predicate.

Compatibility
- SICStus Prolog
- If the predicate is blocked on multiple conditions, it will not unblock before all conditions are satisfied. SICStus unblocks when one arbitrary condition is satisfied.
bug
- It is not possible to block on a dynamic predicate because we cannot wrap assert/1. Likewise, we cannot block foreign predicates, although it would be easier to support this.
   92block(Spec) :-
   93	throw(error(context_error(nodirective, block(Spec)), _)).
   94
   95expand_block_declaration(Spec, Clauses) :-
   96	prolog_load_context(module, Module),
   97	phrase(expand_specs(Spec, Module), Clauses).
   98
   99expand_specs(Var, _) -->
  100	{ var(Var), !,
  101	  instantiation_error(Var)
  102	}.
  103expand_specs(M:Spec, _) --> !,
  104	expand_specs(Spec, M).
  105expand_specs((A,B), Module) --> !,
  106	expand_specs(A, Module),
  107	expand_specs(B, Module).
  108expand_specs(Head, Module) -->
  109	{ valid_head(Head),
  110	  check_dynamic(Module:Head),
  111	  functor(Head, Name, Arity),
  112	  functor(GenHead, Name, Arity),
  113	  Clause = '$block_pred'(Head)
  114	},
  115	(   { current_predicate(Module:'$block_pred'/1) }
  116	->  []
  117	;   [ (:- discontiguous('$block_pred'/1)),
  118	      (:- public('$block_pred'/1))
  119	    ]
  120	),
  121	(   { prolog_load_context(module, Module) }
  122	->  [ Clause ]
  123	;   [ Module:Clause ]
  124	),
  125	[ block_directive:block_declaration(GenHead, Module) ].
  126
  127valid_head(Head) :-
  128	callable(Head),
  129	forall(arg(_, Head, A), block_arg(A)).
  130
  131check_dynamic(Head) :-
  132	(   predicate_property(Head, dynamic)
  133	;   predicate_property(Head, foreign)
  134	),
  135	permission_error(block, predicate, Head).
  136check_dynamic(_).
  137
  138block_arg(A) :-
  139	var(A), !,
  140	instantiation_error(A).
  141block_arg(-) :- !.
  142block_arg(+) :- !.
  143block_arg(?) :- !.
  144block_arg(A) :-
  145	domain_error(block_argument, A).
 wrap_block(+Head, +Term, -Clauses) is det
Create a wrapper. The first clause deal with the case where we already created the wrapper. The second creates the wrapper and the first clause.
  153wrap_block(Pred, Term, Clause) :-
  154	current_predicate(_, Pred), !,
  155	rename_clause(Term, 'block ', Clause).
  156wrap_block(Pred, Term, [Wrapper,FirstClause]) :-
  157	block_declarations(Pred, Modes),
  158	Pred = _:Head,
  159	functor(Head, Name, Arity),
  160	length(Args, Arity),
  161	GenHead =.. [Name|Args],
  162	atom_concat('block ', Name, WrappedName),
  163	WrappedHead =.. [WrappedName|Args],
  164	when_cond(Modes, Args, Cond),
  165	simplify_coroute(when(Cond, WrappedHead), Coroute),
  166	Wrapper = (GenHead :- Coroute),
  167	rename_clause(Term, 'block ', FirstClause).
  168
  169block_wrapper((_Head :- Coroute)) :-
  170	simplify_coroute(when(_,Wrapped), Coroute),
  171	compound(Wrapped),
  172	functor(Wrapped, Name, _),
  173	sub_atom(Name, 0, _, _, 'block ').
  174
  175block_declarations(M:P, Modes) :-
  176	functor(P, Name, Arity),
  177	functor(H, Name, Arity),
  178	findall(H, M:'$block_pred'(H), Modes).
  179
  180when_cond([Head], Args, Cond) :- !,
  181	one_cond(Args, Head, Cond).
  182when_cond([H|T], Args, (C1,C2)) :-
  183	one_cond(Args, H, C1),
  184	when_cond(T, Args, C2).
  185
  186one_cond(Vars, Spec, Cond) :-
  187	cond_vars(Vars, 1, Spec, CondVars),
  188	nonvar_or(CondVars, Cond).
  189
  190cond_vars([], _, _, []).
  191cond_vars([H|T0], I, Spec, L) :-
  192	(   arg(I, Spec, -)
  193	->  L = [H|T]
  194	;   L = T
  195	),
  196	I2 is I + 1,
  197	cond_vars(T0, I2, Spec, T).
  198
  199nonvar_or([V], nonvar(V)).
  200nonvar_or([V|T], (nonvar(V);C)) :-
  201	nonvar_or(T, C).
  202
  203simplify_coroute(when(nonvar(X), C), freeze(X, C)).
  204simplify_coroute(Coroute, Coroute).
 rename_clause(+Clause, +Prefix, -Renamed) is det
Rename a clause by prefixing its old name wit h Prefix.
  211rename_clause((Head :- Body), Prefix, (NewHead :- Body)) :- !,
  212        rename_clause(Head, Prefix, NewHead).
  213rename_clause(M:Head, Prefix, M:NewHead) :-
  214	rename_clause(Head, Prefix, NewHead).
  215rename_clause(Head, Prefix, NewHead) :-
  216        Head =.. [Name|Args],
  217        atom_concat(Prefix, Name, WrapName),
  218        NewHead =.. [WrapName|Args].
  219
  220
  221		 /*******************************
  222		 *	  EXPANSION HOOKS	*
  223		 *******************************/
  224
  225system:term_expansion((:- block(Spec)), Clauses) :-
  226	expand_block_declaration(Spec, Clauses).
  227system:term_expansion(Term, Wrapper) :-
  228	head(Term, Module:Head),
  229	block_declaration(Head, Module),
  230	\+ block_wrapper(Term),		% avoid recursion
  231	wrap_block(Module:Head, Term, Wrapper)