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).

See also
- https://sicstus.sics.se/sicstus/docs/3.12.11/html/sicstus/Block-Declarations.html */
To be done
- This emulation is barely tested.
   51:- op(1150, fx, user:(block)).   52
   53:- multifile
   54	user:term_expansion/2,
   55	block_declaration/2.		% Head, Module
   56
   57head(Var, _) :-
   58	var(Var), !, fail.
   59head((H:-_B), Head) :- !,
   60	head(H, Head).
   61head(H, Head) :-
   62	(   H = _:_
   63	->  Head = H
   64	;   prolog_load_context(module, M),
   65	    Head = M:H
   66	).
 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.
   95block(Spec) :-
   96	throw(error(context_error(nodirective, block(Spec)), _)).
   97
   98expand_block_declaration(Spec, Clauses) :-
   99	prolog_load_context(module, Module),
  100	phrase(expand_specs(Spec, Module), Clauses).
  101
  102expand_specs(Var, _) -->
  103	{ var(Var), !,
  104	  instantiation_error(Var)
  105	}.
  106expand_specs(M:Spec, _) --> !,
  107	expand_specs(Spec, M).
  108expand_specs((A,B), Module) --> !,
  109	expand_specs(A, Module),
  110	expand_specs(B, Module).
  111expand_specs(Head, Module) -->
  112	{ valid_head(Head),
  113	  check_dynamic(Module: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
  134check_dynamic(Head) :-
  135	(   predicate_property(Head, dynamic)
  136	;   predicate_property(Head, foreign)
  137	),
  138	permission_error(block, predicate, Head).
  139check_dynamic(_).
  140
  141block_arg(A) :-
  142	var(A), !,
  143	instantiation_error(A).
  144block_arg(-) :- !.
  145block_arg(+) :- !.
  146block_arg(?) :- !.
  147block_arg(A) :-
  148	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.
  156wrap_block(Pred, Term, Clause) :-
  157	current_predicate(_, Pred), !,
  158	rename_clause(Term, 'block ', Clause).
  159wrap_block(Pred, Term, [Wrapper,FirstClause]) :-
  160	block_declarations(Pred, Modes),
  161	Pred = _:Head,
  162	functor(Head, Name, Arity),
  163	length(Args, Arity),
  164	GenHead =.. [Name|Args],
  165	atom_concat('block ', Name, WrappedName),
  166	WrappedHead =.. [WrappedName|Args],
  167	when_cond(Modes, Args, Cond),
  168	simplify_coroute(when(Cond, WrappedHead), Coroute),
  169	Wrapper = (GenHead :- Coroute),
  170	rename_clause(Term, 'block ', FirstClause).
  171
  172block_wrapper((_Head :- Coroute)) :-
  173	simplify_coroute(when(_,Wrapped), Coroute),
  174	compound(Wrapped),
  175	functor(Wrapped, Name, _),
  176	sub_atom(Name, 0, _, _, 'block ').
  177
  178block_declarations(M:P, Modes) :-
  179	functor(P, Name, Arity),
  180	functor(H, Name, Arity),
  181	findall(H, M:'$block_pred'(H), Modes).
  182
  183when_cond([Head], Args, Cond) :- !,
  184	one_cond(Args, Head, Cond).
  185when_cond([H|T], Args, (C1,C2)) :-
  186	one_cond(Args, H, C1),
  187	when_cond(T, Args, C2).
  188
  189one_cond(Vars, Spec, Cond) :-
  190	cond_vars(Vars, 1, Spec, CondVars),
  191	nonvar_or(CondVars, Cond).
  192
  193cond_vars([], _, _, []).
  194cond_vars([H|T0], I, Spec, L) :-
  195	(   arg(I, Spec, -)
  196	->  L = [H|T]
  197	;   L = T
  198	),
  199	I2 is I + 1,
  200	cond_vars(T0, I2, Spec, T).
  201
  202nonvar_or([V], nonvar(V)).
  203nonvar_or([V|T], (nonvar(V);C)) :-
  204	nonvar_or(T, C).
  205
  206simplify_coroute(when(nonvar(X), C), freeze(X, C)).
  207simplify_coroute(Coroute, Coroute).
 rename_clause(+Clause, +Prefix, -Renamed) is det
Rename a clause by prefixing its old name wit h Prefix.
  214rename_clause((Head :- Body), Prefix, (NewHead :- Body)) :- !,
  215        rename_clause(Head, Prefix, NewHead).
  216rename_clause(M:Head, Prefix, M:NewHead) :-
  217	rename_clause(Head, Prefix, NewHead).
  218rename_clause(Head, Prefix, NewHead) :-
  219        Head =.. [Name|Args],
  220        atom_concat(Prefix, Name, WrapName),
  221        NewHead =.. [WrapName|Args].
  222
  223
  224		 /*******************************
  225		 *	  EXPANSION HOOKS	*
  226		 *******************************/
  227
  228system:term_expansion((:- block(Spec)), Clauses) :-
  229	expand_block_declaration(Spec, Clauses).
  230system:term_expansion(Term, Wrapper) :-
  231	head(Term, Module:Head),
  232	block_declaration(Head, Module),
  233	\+ block_wrapper(Term),		% avoid recursion
  234	wrap_block(Module:Head, Term, Wrapper)