swi-prolog-nox 7.2.3+dfsg-6 / usr / lib / swi-prolog / boot / expand.pl

/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 1985-2014, University of Amsterdam
			      VU University Amsterdam

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.
*/

:- module('$expand',
	  [ expand_term/2,		% +Term0, -Term
	    expand_goal/2,		% +Goal0, -Goal
	    expand_term/4,		% +Term0, ?Pos0, -Term, -Pos
	    expand_goal/4,	        % +Goal0, ?Pos0, -Goal, -Pos
            var_property/2		% +Var, ?Property
	  ]).

/** <module> Prolog source-code transformation

This module specifies, together with dcg.pl, the transformation of terms
as they are read from a file before they are processed by the compiler.

The toplevel is expand_term/2.  This uses three other translators:

	* Conditional compilation
	* term_expansion/2 rules provided by the user
	* DCG expansion

Note that this ordering implies  that conditional compilation directives
cannot be generated  by  term_expansion/2   rules:  they  must literally
appear in the source-code.

Term-expansion may choose to overrule DCG   expansion.  If the result of
term-expansion is a DCG rule, the rule  is subject to translation into a
predicate.

Next, the result is  passed  to   expand_bodies/2,  which  performs goal
expansion.
*/

:- dynamic
	system:term_expansion/2,
	system:goal_expansion/2,
	user:term_expansion/2,
	user:goal_expansion/2,
	system:term_expansion/4,
	system:goal_expansion/4,
	user:term_expansion/4,
	user:goal_expansion/4.
:- multifile
	system:term_expansion/2,
	system:goal_expansion/2,
	user:term_expansion/2,
	user:goal_expansion/2,
	system:term_expansion/4,
	system:goal_expansion/4,
	user:term_expansion/4,
	user:goal_expansion/4.

:- meta_predicate
	expand_terms(4, +, ?, -, -).

%%	expand_term(+Input, -Output) is det.
%%	expand_term(+Input, +Pos0, -Output, -Pos) is det.
%
%	This predicate is used to translate terms  as they are read from
%	a source-file before they are added to the Prolog database.

expand_term(Term0, Term) :-
	expand_term(Term0, _, Term, _).

expand_term(Var, Pos, Expanded, Pos) :-
	var(Var), !,
	Expanded = Var.
expand_term(Term, Pos0, [], Pos) :-
	cond_compilation(Term, X),
	X == [], !,
	atomic_pos(Pos0, Pos).
expand_term(Term, Pos0, Expanded, Pos) :-
	'$def_modules'([term_expansion/4,term_expansion/2], MList),
	call_term_expansion(MList, Term, Pos0, Term2, Pos1),
	expand_term_2(Term2, Pos1, Expanded, Pos).

call_term_expansion([], Term, Pos, Term, Pos).
call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
	current_prolog_flag(sandboxed_load, false), !,
	(   '$member'(Pred, Preds),
	    (	Pred == term_expansion/2
	    ->	M:term_expansion(Term0, Term1),
		Pos1 = Pos0
	    ;	M:term_expansion(Term0, Pos0, Term1, Pos1)
	    )
	->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
	;   call_term_expansion(T, Term0, Pos0, Term, Pos)
	).
call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
	(   '$member'(Pred, Preds),
	    (	Pred == term_expansion/2
	    ->	allowed_expansion(M:term_expansion(Term0, Term1)),
		call(M:term_expansion(Term0, Term1)),
		Pos1 = Pos
	    ;	allowed_expansion(M:term_expansion(Term0, Pos0, Term1, Pos1)),
		call(M:term_expansion(Term0, Pos0, Term1, Pos1))
	    )
	->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
	;   call_term_expansion(T, Term0, Pos0, Term, Pos)
	).

expand_term_2((Head --> Body), Pos0, Expanded, Pos) :-
	dcg_translate_rule((Head --> Body), Pos0, Expanded0, Pos1), !,
	expand_bodies(Expanded0, Pos1, Expanded, Pos).
expand_term_2(Term0, Pos0, Term, Pos) :-
	nonvar(Term0), !,
	expand_bodies(Term0, Pos0, Term, Pos).
expand_term_2(Term, Pos, Term, Pos).

%%	expand_bodies(+Term, +Pos0, -Out, -Pos) is det.
%
%	Find the body terms in Term and   give them to expand_goal/2 for
%	further processing. Note that  we   maintain  status information
%	about variables. Currently we only  detect whether variables are
%	_fresh_ or not. See var_info/3.

expand_bodies(Terms, Pos0, Out, Pos) :-
	'$def_modules'([goal_expansion/4,goal_expansion/2], MList),
	expand_terms(expand_body(MList), Terms, Pos0, Out, Pos),
	remove_attributes(Out, '$var_info').

expand_body(MList, (Head0 :- Body), Pos0, (Head :- ExpandedBody), Pos) :- !,
        term_variables(Head0, HVars),
        mark_vars_non_fresh(HVars),
	f2_pos(Pos0, HPos, BPos0, Pos, HPos, BPos),
	expand_goal(Body, BPos0, ExpandedBody0, BPos, MList, (Head0 :- Body)),
	(   compound(Head0),
	    '$set_source_module'(M, M),
	    replace_functions(Head0, Eval, Head, M),
	    Eval \== true
	->  ExpandedBody = (Eval,ExpandedBody0)
	;   Head = Head0,
	    ExpandedBody = ExpandedBody0
	).
expand_body(MList, (:- Body), Pos0, (:- ExpandedBody), Pos) :- !,
	f1_pos(Pos0, BPos0, Pos, BPos),
	expand_goal(Body, BPos0, ExpandedBody, BPos, MList, (:- Body)).

expand_body(_MList, Head0, Pos, Clause, Pos) :- % TBD: Position handling
	compound(Head0),
	'$set_source_module'(M, M),
	replace_functions(Head0, Eval, Head, M),
	Eval \== true, !,
	Clause = (Head :- Eval).
expand_body(_, Head, Pos, Head, Pos).


%%	expand_terms(:Closure, +In, +Pos0, -Out, -Pos)
%
%	Loop over two constructs that  can   be  added by term-expansion
%	rules in order to run the   next phase: calling term_expansion/2
%	can  return  a  list  and  terms    may   be  preceeded  with  a
%	source-location.

expand_terms(_, X, P, X, P) :-
	var(X), !.
expand_terms(C, List0, Pos0, List, Pos) :-
	nonvar(List0),
	List0 = [_|_], !,
	(   is_list(List0)
	->  list_pos(Pos0, Elems0, Pos, Elems),
	    expand_term_list(C, List0, Elems0, List, Elems)
	;   '$type_error'(list, List0)
	).
expand_terms(C, '$source_location'(File, Line):Clause0, Pos0, Clause, Pos) :- !,
	expand_terms(C, Clause0, Pos0, Clause1, Pos),
	add_source_location(Clause1, '$source_location'(File, Line), Clause).
expand_terms(C, Term0, Pos0, Term, Pos) :-
	call(C, Term0, Pos0, Term, Pos).

%%	add_source_location(+Term, +SrcLoc, -SrcTerm)
%
%	Re-apply source location after term expansion.  If the result is
%	a list, claim all terms to originate from this location.

add_source_location(Clauses0, SrcLoc, Clauses) :-
	(   is_list(Clauses0)
	->  add_source_location_list(Clauses0, SrcLoc, Clauses)
	;   Clauses = SrcLoc:Clauses0
	).

add_source_location_list([], _, []).
add_source_location_list([Clause|Clauses0], SrcLoc, [SrcLoc:Clause|Clauses]) :-
	add_source_location_list(Clauses0, SrcLoc, Clauses).

%%	expand_term_list(:Expander, +TermList, +Pos, -NewTermList, -PosList)

expand_term_list(_, [], _, [], []) :- !.
expand_term_list(C, [H0|T0], [PH0], Terms, PosL) :- !,
	expand_terms(C, H0, PH0, H, PH),
	add_term(H, PH, Terms, TT, PosL, PT),
	expand_term_list(C, T0, [PH0], TT, PT).
expand_term_list(C, [H0|T0], [PH0|PT0], Terms, PosL) :- !,
	expand_terms(C, H0, PH0, H, PH),
	add_term(H, PH, Terms, TT, PosL, PT),
	expand_term_list(C, T0, PT0, TT, PT).
expand_term_list(C, [H0|T0], PH0, Terms, PosL) :-
	expected_layout(list, PH0),
	expand_terms(C, H0, PH0, H, PH),
	add_term(H, PH, Terms, TT, PosL, PT),
	expand_term_list(C, T0, [PH0], TT, PT).

%%	add_term(+ExpandOut, ?ExpandPosOut, -Terms, ?TermsT, -PosL, ?PosLT)

add_term(List, Pos, Terms, TermT, PosL, PosT) :-
	nonvar(List), List = [_|_], !,
	(   is_list(List)
	->  append_tp(List, Terms, TermT, Pos, PosL, PosT)
	;   '$type_error'(list, List)
	).
add_term(Term, Pos, [Term|Terms], Terms, [Pos|PosT], PosT).

append_tp([], Terms, Terms, _, PosL, PosL).
append_tp([H|T0], [H|T1], Terms, [HP], [HP|TP1], PosL) :- !,
	append_tp(T0, T1, Terms, [HP], TP1, PosL).
append_tp([H|T0], [H|T1], Terms, [HP0|TP0], [HP0|TP1], PosL) :- !,
	append_tp(T0, T1, Terms, TP0, TP1, PosL).
append_tp([H|T0], [H|T1], Terms, Pos, [Pos|TP1], PosL) :-
	expected_layout(list, Pos),
	append_tp(T0, T1, Terms, [Pos], TP1, PosL).


list_pos(Var, _, _, _) :-
	var(Var), !.
list_pos(list_position(F,T,Elems0,none), Elems0,
	 list_position(F,T,Elems,none),  Elems).
list_pos(Pos, [Pos], Elems, Elems).


		 /*******************************
		 *      VAR_INFO/3 SUPPORT	*
		 *******************************/

%%	var_intersection(+List1, +List2, -Shared) is det.
%
%	Shared is the ordered intersection of List1 and List2.

var_intersection(List1, List2, Intersection) :-
	sort(List1, Set1),
	sort(List2, Set2),
	ord_intersection(Set1, Set2, Intersection).

%%	ord_intersection(+OSet1, +OSet2, -Int)
%
%	Ordered list intersection.  Copied from the library.

ord_intersection([], _Int, []).
ord_intersection([H1|T1], L2, Int) :-
	isect2(L2, H1, T1, Int).

isect2([], _H1, _T1, []).
isect2([H2|T2], H1, T1, Int) :-
	compare(Order, H1, H2),
	isect3(Order, H1, T1, H2, T2, Int).

isect3(<, _H1, T1,  H2, T2, Int) :-
	isect2(T1, H2, T2, Int).
isect3(=, H1, T1, _H2, T2, [H1|Int]) :-
	ord_intersection(T1, T2, Int).
isect3(>, H1, T1,  _H2, T2, Int) :-
	isect2(T2, H1, T1, Int).


%%	merge_variable_info(+Saved)
%
%	Merge info from two branches. The  info   in  Saved is the saved
%	info from the  first  branch,  while   the  info  in  the actual
%	variables is the  info  in  the   second  branch.  Only  if both
%	branches claim the variable to  be   fresh,  we  can consider it
%	fresh.

merge_variable_info([]).
merge_variable_info([Var=State|States]) :-
        (   get_attr(Var, '$var_info', CurrentState)
	->  true
	;   CurrentState = (-)
	),
        merge_states(Var, State, CurrentState),
        merge_variable_info(States).

merge_states(_Var, State, State) :- !.
merge_states(_Var, -, _) :- !.
merge_states(Var, State, -) :- !,
	put_attr(Var, '$var_info', State).
merge_states(Var, Left, Right) :-
	(   get_dict(fresh, Left, false)
	->  put_dict(fresh, Right, false)
	;   get_dict(fresh, Right, false)
	->  put_dict(fresh, Left, false)
	), !,
	(   Left >:< Right
	->  put_dict(Left, Right, State),
	    put_attr(Var, '$var_info', State)
	;   print_message(warning,
			  inconsistent_variable_properties(Left, Right)),
	    put_dict(Left, Right, State),
	    put_attr(Var, '$var_info', State)
	).


save_variable_info([], []).
save_variable_info([Var|Vars], [Var=State|States]):-
        (   get_attr(Var, '$var_info', State)
	->  true
        ;   State = (-)
        ),
        save_variable_info(Vars, States).

restore_variable_info([]).
restore_variable_info([Var=State|States]) :-
	(   State == (-)
	->  del_attr(Var, '$var_info')
	;   put_attr(Var, '$var_info', State)
	),
        restore_variable_info(States).

%%	var_property(+Var, ?Property)
%
%	True when Var has a property  Key with Value. Defined properties
%	are:
%
%	  - fresh(Fresh)
%	  Variable is first introduced in this goal and thus guaranteed
%	  to be unbound.  This property is always present.
%	  - name(-Name)
%	  True when Name is the name of the variable.

var_property(Var, Property) :-
	prop_var(Property, Var).

prop_var(fresh(Fresh), Var) :-
	 (   get_attr(Var, '$var_info', Info),
	     get_dict(fresh, Info, Fresh0)
	 ->  Fresh = Fresh0
	 ;   Fresh = true
	 ).
prop_var(name(Name), Var) :-
	(   b_getval('$variable_names', Bindings),
	    '$member'(Name0=Var0, Bindings),
	    Var0 == Var
	->  Name = Name0
	).


mark_vars_non_fresh([]) :- !.
mark_vars_non_fresh([Var|Vars]) :-
        (   get_attr(Var, '$var_info', Info)
	->  (   get_dict(fresh, Info, false)
	    ->	true
	    ;	put_dict(fresh, Info, false, Info1),
		put_attr(Var, '$var_info', Info1)
	    )
        ;   put_attr(Var, '$var_info', '$var_info'{fresh:false})
        ),
        mark_vars_non_fresh(Vars).


%%	remove_attributes(+Term, +Attribute) is det.
%
%	Remove all variable attributes Attribute from Term. This is used
%	to make term_expansion end with a  clean term. This is currently
%	_required_ for saving directives  in   QLF  files.  The compiler
%	ignores attributes, but I think  it   is  cleaner to remove them
%	anyway.

remove_attributes(Term, Attr) :-
	term_variables(Term, Vars),
	remove_var_attr(Vars, Attr).

remove_var_attr([], _):- !.
remove_var_attr([Var|Vars], Attr):-
        del_attr(Var, Attr),
        remove_var_attr(Vars, Attr).

%%	'$var_info':attr_unify_hook(_,_) is det.
%
%	Dummy unification hook for attributed variables.  Just succeeds.

'$var_info':attr_unify_hook(_, _).


		 /*******************************
		 *   GOAL_EXPANSION/2 SUPPORT	*
		 *******************************/

%%	expand_goal(+BodyTerm, +Pos0, -Out, -Pos) is det.
%%	expand_goal(+BodyTerm, -Out) is det.
%
%	Perform   macro-expansion   on    body     terms    by   calling
%	goal_expansion/2.

expand_goal(A, B) :-
	expand_goal(A, _, B, _).

expand_goal(A, P0, B, P) :-
	'$def_modules'([goal_expansion/4, goal_expansion/2], MList),
	(   expand_goal(A, P0, B, P, MList, _)
	->  remove_attributes(B, '$var_info'), A \== B
	), !.
expand_goal(A, P, A, P).

expand_goal(G0, P0, G, P, MList, Term) :-
	'$set_source_module'(M, M),
	expand_goal(G0, P0, G, P, M, MList, Term).

%%	expand_goal(+GoalIn, ?PosIn, -GoalOut, -PosOut,
%%		    +Module, -ModuleList, +Term) is det.
%
%	@param Module is the current module to consider
%	@param ModuleList are the other expansion modules
%	@param Term is the overall term that is being translated

% (*)	This is needed because call_goal_expansion may introduce extra
%	context variables.  Consider the code below, where the variable
%	E is introduced.  Is there a better representation for the
%	context?
%
%	  ==
%	  goal_expansion(catch_and_print(Goal), catch(Goal, E, print(E))).
%
%	  test :-
%		catch_and_print(true).
%	  ==

expand_goal(G, P, G, P, _, _, _) :-
        var(G), !.
expand_goal(G0, P0, G, P, M, MList, Term) :-
	call_goal_expansion(MList, G0, P0, G1, P1), !,
	expand_goal(G1, P1, G, P, M, MList, Term/G1).		% (*)
expand_goal((A,B), P0, Conj, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB0, P1, PA, PB),
        expand_goal(A, PA0, EA, PA, M, MList, Term),
        expand_goal(B, PB0, EB, PB, M, MList, Term),
	simplify((EA,EB), P1, Conj, P).
expand_goal((A;B), P0, Or, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB0, P1, PA, PB),
        term_variables(A, AVars),
        term_variables(B, BVars),
        var_intersection(AVars, BVars, SharedVars),
        save_variable_info(SharedVars, SavedState),
        expand_goal(A, PA0, EA, PA, M, MList, Term),
        save_variable_info(SharedVars, SavedState2),
        restore_variable_info(SavedState),
        expand_goal(B, PB0, EB, PB, M, MList, Term),
        merge_variable_info(SavedState2),
	simplify((EA;EB), P1, Or, P).
expand_goal((A->B), P0, Goal, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB0, P1, PA, PB),
        expand_goal(A, PA0, EA, PA, M, MList, Term),
        expand_goal(B, PB0, EB, PB, M, MList, Term),
	simplify((EA->EB), P1, Goal, P).
expand_goal((A*->B), P0, Goal, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB0, P1, PA, PB),
        expand_goal(A, PA0, EA, PA, M, MList, Term),
        expand_goal(B, PB0, EB, PB, M, MList, Term),
	simplify((EA*->EB), P1, Goal, P).
expand_goal((\+A), P0, Goal, P, M, MList, Term) :- !,
	f1_pos(P0, PA0, P1, PA),
	term_variables(A, AVars),
	save_variable_info(AVars, SavedState),
        expand_goal(A, PA0, EA, PA, M, MList, Term),
	restore_variable_info(SavedState),
	simplify(\+(EA), P1, Goal, P).
expand_goal(call(A), P0, call(EA), P, M, MList, Term) :- !,
	f1_pos(P0, PA0, P, PA),
        expand_goal(A, PA0, EA, PA, M, MList, Term).
expand_goal(M:G, P0, M:EG, P, _M, _MList, Term) :-
	atom(M), !,
	f2_pos(P0, PA, PB0, P, PA, PB),
	'$def_modules'(M:[goal_expansion/4,goal_expansion/2], MList),
	setup_call_cleanup(
	    '$set_source_module'(Old, M),
	    '$expand':expand_goal(G, PB0, EG, PB, M, MList, Term),
	    '$set_source_module'(_, Old)).
expand_goal(G0, P0, G, P, M, MList, Term) :-
	is_meta_call(G0, M, Head), !,
	expand_meta(Head, G0, P0, G, P, M, MList, Term).
expand_goal(G0, P0, G, P, M, MList, Term) :-
        term_variables(G0, Vars),
        mark_vars_non_fresh(Vars),
	expand_functions(G0, P0, G, P, M, MList, Term).

%%	is_meta_call(+G0, +M, +Head) is semidet.
%
%	True if M:G0 resolves to a real meta-goal as specified by Head.

is_meta_call(G0, M, Head) :-
	compound(G0),
	default_module(M, M2),
	'$c_current_predicate'(_, M2:G0), !,
	'$get_predicate_attribute'(M2:G0, meta_predicate, Head),
	has_meta_arg(Head).


%%	expand_meta(+MetaSpec, +G0, ?P0, -G, -P, +M, +Mlist, +Term)

expand_meta(Spec, G0, P0, G, P, M, MList, Term) :-
	functor(Spec, _, Arity),
	functor(G0, Name, Arity),
	functor(G1, Name, Arity),
	f_pos(P0, ArgPos0, P, ArgPos),
	expand_meta(1, Arity, Spec,
		    G0, ArgPos0, Eval,
		    G1,  ArgPos,
		    M, MList, Term),
	conj(Eval, G1, G).

expand_meta(I, Arity, Spec, G0, ArgPos0, Eval, G, [P|PT], M, MList, Term) :-
	I =< Arity, !,
	arg_pos(ArgPos0, P0, PT0),
	arg(I, Spec, Meta),
	arg(I, G0, A0),
	arg(I, G, A),
	expand_meta_arg(Meta, A0, P0, EvalA, A, P, M, MList, Term),
	I2 is I + 1,
	expand_meta(I2, Arity, Spec, G0, PT0, EvalB, G, PT, M, MList, Term),
	conj(EvalA, EvalB, Eval).
expand_meta(_, _, _, _, _, true, _, [], _, _, _).

arg_pos(List, _, _) :- var(List), !.	% no position info
arg_pos([H|T], H, T) :- !.		% argument list
arg_pos([], _, []).			% new has more

mapex([], _).
mapex([E|L], E) :- mapex(L, E).

%%      extended_pos(+Pos0, +N, -Pos) is det.
%%      extended_pos(-Pos0, +N, +Pos) is det.
%
%       Pos is the result of adding N extra positions to Pos0.

extended_pos(Var, _, Var) :-
	var(Var), !.
extended_pos(term_position(F,T,FF,FT,Args),
	     _,
	     term_position(F,T,FF,FT,Args)) :-
	var(Args), !.
extended_pos(term_position(F,T,FF,FT,Args0),
	     N,
	     term_position(F,T,FF,FT,Args)) :-
	length(Ex, N),
	mapex(Ex, T-T),
	'$append'(Args0, Ex, Args), !.
extended_pos(F-T,
	     N,
	     term_position(F,T,F,T,Ex)) :- !,
	length(Ex, N),
	mapex(Ex, T-T).
extended_pos(Pos, N, Pos) :-
	'$print_message'(warning, extended_pos(Pos, N)).

%%	expand_meta_arg(+MetaSpec, +Arg0, +ArgPos0, -Eval,
%%			-Arg, -ArgPos, +ModuleList, +Term) is det.
%
%	Goal expansion for a meta-argument.
%
%	@arg	Eval is always `true`.  Future versions should allow for
%		functions on such positions.  This requires proper
%		position management for function expansion.

expand_meta_arg(0, A0, PA0, true, A, PA, M, MList, Term) :- !,
	expand_goal(A0, PA0, A1, PA, M, MList, Term),
	compile_meta_call(A1, A, M, Term).
expand_meta_arg(N, A0, P0, true, A, P, M, MList, Term) :-
	integer(N), callable(A0),
	replace_functions(A0, true, _, M), !,
	length(Ex, N),
	extend_arg_pos(A0, P0, M, Ex, A1, PA1),
	expand_goal(A1, PA1, A2, PA2, M, MList, Term),
	compile_meta_call(A2, A3, M, Term),
	term_variables(A0, VL),
	remove_arg_pos(A3, PA2, M, VL, Ex, A, P).
expand_meta_arg(^, A0, PA0, true, A, PA, M, MList, Term) :-
	replace_functions(A0, true, _, M), !,
	expand_setof_goal(A0, PA0, A, PA, M, MList, Term).
expand_meta_arg(S, A0, _PA0, Eval, A, _PA, M, _MList, _Term) :-
	replace_functions(A0, Eval, A, M), % TBD: pass positions
	(   Eval == true
	->  true
	;   same_functor(A0, A)
	->  true
	;   meta_arg(S)
	->  throw(error(context_error(function, meta_arg(S)), _))
	;   true
	).

same_functor(T1, T2) :-
	compound(T1), !,
	compound(T2),
	compound_name_arity(T1, N, A),
	compound_name_arity(T2, N, A).
same_functor(T1, T2) :-
	atom(T1),
	T1 == T2.

variant_sha1_nat(Term, Hash) :-
	copy_term_nat(Term, TNat),
	variant_sha1(TNat, Hash).

wrap_meta_arguments(A0, M, VL, Ex, A) :-
	'$append'(VL, Ex, AV),
	variant_sha1_nat(A0+AV, Hash),
	atom_concat('__aux_wrapper_', Hash, AuxName),
	H =.. [AuxName|AV],
	compile_auxiliary_clause(M, (H :- A0)),
	A =.. [AuxName|VL].

%%      extend_arg_pos(+A0, +P0, +M, +Ex, -A, -P) is det.
%
%	Adds extra arguments Ex to A0, and  extra subterm positions to P
%	for such arguments.

extend_arg_pos(A, P, _, _, A, P) :-
	var(A), !.
extend_arg_pos(M:A0, P0, _, Ex, M:A, P) :- !,
	f2_pos(P0, PM, PA0, P, PM, PA),
	extend_arg_pos(A0, PA0, M, Ex, A, PA).
extend_arg_pos(A0, P0, _, Ex, A, P) :-
	callable(A0), !,
	extend_term(A0, Ex, A),
	length(Ex, N),
	extended_pos(P0, N, P).
extend_arg_pos(A, P, _, _, A, P).

extend_term(Atom, Extra, Term) :-
	atom(Atom), !,
	Term =.. [Atom|Extra].
extend_term(Term0, Extra, Term) :-
	compound_name_arguments(Term0, Name, Args0),
	'$append'(Args0, Extra, Args),
	compound_name_arguments(Term, Name, Args).

%%      remove_arg_pos(+A0, +P0, +M, +Ex, +VL, -A, -P) is det.
%
%	Removes the Ex arguments  from  A0   and  the  respective  extra
%	positions from P0. Note that  if  they   are  not  at the end, a
%	wrapper with the elements of VL as arguments is generated to put
%	them in order.
%
%       @see wrap_meta_arguments/5

remove_arg_pos(A, P, _, _, _, A, P) :-
	var(A), !.
remove_arg_pos(M:A0, P0, _, VL, Ex, M:A, P) :- !,
	f2_pos(P, PM, PA0, P0, PM, PA),
	remove_arg_pos(A0, PA, M, VL, Ex, A, PA0).
remove_arg_pos(A0, P0, M, VL, Ex0, A, P) :-
	callable(A0), !,
	length(Ex0, N),
	(   A0 =.. [F|Args],
	    length(Ex, N),
	    '$append'(Args0, Ex, Args),
	    Ex==Ex0
	->  extended_pos(P, N, P0),
	    A =.. [F|Args0]
	;   wrap_meta_arguments(A0, M, VL, Ex0, A),
	    wrap_meta_pos(P0, P)
	).
remove_arg_pos(A, P, _, _, _, A, P).

wrap_meta_pos(P0, P) :-
	(   nonvar(P0)
	->  P = term_position(F,T,_,_,_),
	    atomic_pos(P0, F-T)
	;   true
	).

has_meta_arg(Head) :-
	arg(_, Head, Arg),
	direct_call_meta_arg(Arg), !.

direct_call_meta_arg(I) :- integer(I).
direct_call_meta_arg(^).

meta_arg(:).
meta_arg(//).
meta_arg(I) :- integer(I).


expand_setof_goal(Var, Pos, Var, Pos, _, _, _) :-
	var(Var), !.
expand_setof_goal(V^G, P0, V^EG, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB, P, PA, PB),
        expand_setof_goal(G, PA0, EG, PA, M, MList, Term).
expand_setof_goal(M0:G, P0, M0:EG, P, M, MList, Term) :- !,
	f2_pos(P0, PA0, PB, P, PA, PB),
        expand_setof_goal(G, PA0, EG, PA, M, MList, Term).
expand_setof_goal(G, P0, EG, P, M, MList, Term) :- !,
        expand_goal(G, P0, EG0, P, M, MList, Term),
	compile_meta_call(EG0, EG, M, Term).		% TBD: Pos?


%%	call_goal_expansion(+ExpandModules,
%%			    +Goal0, ?Pos0, -Goal, -Pos) is semidet.
%
%	Succeeds  if  the   context   has    a   module   that   defines
%	goal_expansion/2 this rule succeeds and  Goal   is  not equal to
%	Goal0. Note that the translator is   called  recursively until a
%	fixed-point is reached.

call_goal_expansion(MList, G0, P0, G, P) :-
	current_prolog_flag(sandboxed_load, false), !,
	(   '$member'(M-Preds, MList),
	    '$member'(Pred, Preds),
	    (	Pred == goal_expansion/4
	    ->	M:goal_expansion(G0, P0, G, P)
	    ;	M:goal_expansion(G0, G),
		P = P0
	    ),
	    G0 \== G
	->  true
	).
call_goal_expansion(MList, G0, P0, G, P) :-
	(   '$member'(M-Preds, MList),
	    '$member'(Pred, Preds),
	    (   Pred == goal_expansion/4
	    ->  Expand = M:goal_expansion(G0, P0, G, P)
	    ;	Expand = M:goal_expansion(G0, G)
	    ),
	    allowed_expansion(Expand),
	    call(Expand),
	    G0 \== G
	->  true
	).

%%	allowed_expansion(:Goal) is semidet.
%
%	Calls prolog:sandbox_allowed_expansion(:Goal) prior   to calling
%	Goal for the purpose of term or   goal  expansion. This hook can
%	prevent the expansion to take place by raising an exception.
%
%	@throws	exceptions from prolog:sandbox_allowed_expansion/1.

:- multifile
	prolog:sandbox_allowed_expansion/1.

allowed_expansion(QGoal) :-
	strip_module(QGoal, M, Goal),
	catch(prolog:sandbox_allowed_expansion(M:Goal), E, true),
	(   var(E)
	->  fail
	;   !,
	    print_message(error, E),
	    fail
	).
allowed_expansion(_).


		 /*******************************
		 *	FUNCTIONAL NOTATION	*
		 *******************************/

%%	expand_functions(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
%
%	Expand functional notation and arithmetic functions.
%
%	@arg MList is the list of modules defining goal_expansion/2 in
%	the expansion context.

expand_functions(G0, P0, G, P, M, MList, Term) :-
	expand_functional_notation(G0, P0, G1, P1, M, MList, Term),
	(   expand_arithmetic(G1, P1, G, P, Term)
	->  true
	;   G = G1,
	    P = P1
	).

%%	expand_functional_notation(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
%
%	@tbd: position logic
%	@tbd: make functions module-local

expand_functional_notation(G0, P0, G, P, M, _MList, _Term) :-
	contains_functions(G0),
	replace_functions(G0, P0, Eval, EvalPos, G1, G1Pos, M),
	Eval \== true, !,
	wrap_var(G1, G1Pos, G2, G2Pos),
	conj(Eval, EvalPos, G2, G2Pos, G, P).
expand_functional_notation(G, P, G, P, _, _, _).

wrap_var(G, P, G, P) :-
	nonvar(G), !.
wrap_var(G, P0, call(G), P) :-
	(   nonvar(P0)
	->  P = term_position(F,T,F,T,[P0]),
	    atomic_pos(P0, F-T)
	;   true
	).

%%	contains_functions(+Term) is semidet.
%
%	True when Term contains a function reference.

contains_functions(Term) :-
	compound(Term),
	(   function(Term, _)
	->  true
	;   arg(_, Term, Arg),
	    contains_functions(Arg)
	->  true
	).

%%	replace_functions(+GoalIn, +PosIn,
%%			  -Eval, -EvalPos,
%%			  -GoalOut, -PosOut,
%%			  +ContextTerm) is det.
%
%	@tbd	Proper propagation of list, dict and brace term positions.

:- public
	replace_functions/4.		% used in dicts.pl

replace_functions(GoalIn, Eval, GoalOut, Context) :-
	replace_functions(GoalIn, _, Eval, _, GoalOut, _, Context).

replace_functions(Var, Pos, true, _, Var, Pos, _Ctx) :-
	var(Var), !.
replace_functions(F, FPos, Eval, EvalPos, Var, VarPos, Ctx) :-
	function(F, Ctx), !,
	compound_name_arity(F, Name, Arity),
	PredArity is Arity+1,
	compound_name_arity(G, Name, PredArity),
	arg(PredArity, G, Var),
	extend_1_pos(FPos, FArgPos, GPos, GArgPos, VarPos),
	map_functions(0, Arity, F, FArgPos, G, GArgPos, Eval0, EP0, Ctx),
	conj(Eval0, EP0, G, GPos, Eval, EvalPos).
replace_functions(Term0, Term0Pos, Eval, EvalPos, Term, TermPos, Ctx) :-
	compound(Term0), !,
	compound_name_arity(Term0, Name, Arity),
	compound_name_arity(Term, Name, Arity),
	f_pos(Term0Pos, Args0Pos, TermPos, ArgsPos),
	map_functions(0, Arity,
		      Term0, Args0Pos, Term, ArgsPos, Eval, EvalPos, Ctx).
replace_functions(Term, Pos, true, _, Term, Pos, _).


%%	map_functions(+Arg, +Arity,
%%		      +TermIn, +ArgInPos, -Term, -ArgPos, -Eval, -EvalPos,
%%		      +Context)

map_functions(Arity, Arity, _, LPos0, _, LPos, true, _, _) :- !,
	pos_nil(LPos0, LPos).
map_functions(I0, Arity, Term0, LPos0, Term, LPos, Eval, EP, Ctx) :-
	pos_list(LPos0, AP0, APT0, LPos, AP, APT),
	I is I0+1,
	arg(I, Term0, Arg0),
	arg(I, Term, Arg),
	replace_functions(Arg0, AP0, Eval0, EP0, Arg, AP, Ctx),
	map_functions(I, Arity, Term0, APT0, Term, APT, Eval1, EP1, Ctx),
	conj(Eval0, EP0, Eval1, EP1, Eval, EP).

conj(true, X, X) :- !.
conj(X, true, X) :- !.
conj(X, Y, (X,Y)).

conj(true, _, X, P, X, P) :- !.
conj(X, P, true, _, X, P) :- !.
conj(X, PX, Y, PY, (X,Y), _) :-
	var(PX), var(PY), !.
conj(X, PX, Y, PY, (X,Y), P) :-
	P = term_position(F,T,FF,FT,[PX,PY]),
	atomic_pos(PX, F-FF),
	atomic_pos(PY, FT-T).

%%	function(?Term, +Context)
%
%	True if function expansion needs to be applied for the given
%	term.

function(.(_,_), _) :- \+ functor([_|_], ., _).


		 /*******************************
		 *	    ARITHMETIC		*
		 *******************************/

%%	expand_arithmetic(+G0, +P0, -G, -P, +Term) is semidet.
%
%	Expand arithmetic expressions  in  is/2,   (>)/2,  etc.  This is
%	currently a dummy.  The  idea  is   to  call  rules  similar  to
%	goal_expansion/2,4  that  allow  for   rewriting  an  arithmetic
%	expression. The system rules will perform evaluation of constant
%	expressions.

expand_arithmetic(_G0, _P0, _G, _P, _Term) :- fail.


		 /*******************************
		 *	  POSITION LOGIC	*
		 *******************************/

%%	f2_pos(?TermPos0, ?PosArg10, ?PosArg20,
%%	       ?TermPos,  ?PosArg1,  ?PosArg2) is det.
%%	f1_pos(?TermPos0, ?PosArg10, ?TermPos,  ?PosArg1) is det.
%%	f_pos(?TermPos0, ?PosArgs0, ?TermPos,  ?PosArgs) is det.
%%	atomic_pos(?TermPos0, -AtomicPos) is det.
%
%	Position progapation routines.

f2_pos(Var, _, _, _, _, _) :-
	var(Var), !.
f2_pos(term_position(F,T,FF,FT,[A10,A20]), A10, A20,
       term_position(F,T,FF,FT,[A1, A2 ]), A1,  A2) :- !.
f2_pos(Pos, _, _, _, _, _) :-
	expected_layout(f2, Pos).

f1_pos(Var, _, _, _) :-
	var(Var), !.
f1_pos(term_position(F,T,FF,FT,[A10]), A10,
       term_position(F,T,FF,FT,[A1 ]),  A1) :- !.
f1_pos(Pos, _, _, _) :-
	expected_layout(f1, Pos).

f_pos(Var, _, _, _) :-
	var(Var), !.
f_pos(term_position(F,T,FF,FT,ArgPos0), ArgPos0,
      term_position(F,T,FF,FT,ArgPos),  ArgPos) :- !.
f_pos(Pos, _, _, _) :-
	expected_layout(compound, Pos).

atomic_pos(Pos, _) :-
	var(Pos), !.
atomic_pos(Pos, F-T) :-
	arg(1, Pos, F),
	arg(2, Pos, T).

%%	pos_nil(+Nil, -Nil) is det.
%%	pos_list(+List0, -H0, -T0, -List, -H, -T) is det.
%
%	Position propagation for lists.

pos_nil(Var, _) :- var(Var), !.
pos_nil([], []) :- !.
pos_nil(Pos, _) :-
	expected_layout(nil, Pos).

pos_list(Var, _, _, _, _, _) :- var(Var), !.
pos_list([H0|T0], H0, T0, [H|T], H, T) :- !.
pos_list(Pos, _, _, _, _, _) :-
	expected_layout(list, Pos).

%%	extend_1_pos(+FunctionPos, -FArgPos, -EvalPos, -EArgPos, -VarPos)
%
%	Deal with extending a function to include the return value.

extend_1_pos(Pos, _, _, _, _) :-
	var(Pos), !.
extend_1_pos(term_position(F,T,FF,FT,FArgPos), FArgPos,
	     term_position(F,T,FF,FT,GArgPos), GArgPos0,
	     FT-FT1) :-
	integer(FT), !,
	FT1 is FT+1,
	'$same_length'(FArgPos, GArgPos0),
	'$append'(GArgPos0, [FT-FT1], GArgPos).
extend_1_pos(F-T, [],
	     term_position(F,T,F,T,[T-T1]), [],
	     T-T1) :-
	integer(T), !,
	T1 is T+1.
extend_1_pos(Pos, _, _, _, _) :-
	expected_layout(callable, Pos).

'$same_length'(List, List) :-
	var(List), !.
'$same_length'([], []).
'$same_length'([_|T0], [_|T]) :-
	'$same_length'(T0, T).


%%	expected_layout(+Expected, +Found)
%
%	Print a message  if  the  layout   term  does  not  satisfy  our
%	expectations.  This  means  that   the  transformation  requires
%	support from term_expansion/4 and/or goal_expansion/4 to achieve
%	proper source location information.

:- create_prolog_flag(debug_term_position, false, []).

expected_layout(Expected, Pos) :-
	current_prolog_flag(debug_term_position, true), !,
	'$print_message'(warning, expected_layout(Expected, Pos)).
expected_layout(_, _).


		 /*******************************
		 *    SIMPLIFICATION ROUTINES	*
		 *******************************/

%%	simplify(+ControlIn, +Pos0, -ControlOut, -Pos) is det.
%
%	Simplify control structures
%
%	@tbd	Much more analysis
%	@tbd	Turn this into a separate module

simplify(Control, P, Control, P) :-
	current_prolog_flag(optimise, false), !.
simplify(Control, P0, Simple, P) :-
	simple(Control, P0, Simple, P), !.
simplify(Control, P, Control, P).

simple((X,Y), P0, Conj, P) :-
	(   true(X)
	->  Conj = Y,
	    f2_pos(P0, _, P, _, _, _)
	;   false(X)
	->  Conj = fail,
	    f2_pos(P0, P1, _, _, _, _),
	    atomic_pos(P1, P)
	;   true(Y)
	->  Conj = X,
	    f2_pos(P0, P, _, _, _, _)
	).
simple((I->T;E), P0, ITE, P) :-
	(   true(I)
	->  ITE = T,
	    f2_pos(P0, P1, _, _, _, _),
	    f2_pos(P1, _, P, _, _, _)
	;   false(I)
	->  ITE = E,
	    f2_pos(P0, _, P, _, _, _)
	).
simple((X;Y), P0, Or, P) :-
	false(X),
	Or = Y,
	f2_pos(P0, _, P, _, _, _).

true(X) :-
	nonvar(X),
	eval_true(X).

false(X) :-
	nonvar(X),
	eval_false(X).

%%	eval_true(+Goal) is semidet.
%%	eval_false(+Goal) is semidet.

eval_true(true).
eval_true(otherwise).

eval_false(fail).
eval_false(false).


		 /*******************************
		 *	   META CALLING		*
		 *******************************/

:- create_prolog_flag(compile_meta_arguments, false, [type(atom)]).

%%	compile_meta_call(+CallIn, -CallOut, +Module, +Term) is det.
%
%	Compile (complex) meta-calls into a clause.

compile_meta_call(CallIn, CallIn, _, Term) :-
	var(Term), !.			% explicit call; no context
compile_meta_call(CallIn, CallIn, _, _) :-
	var(CallIn), !.
compile_meta_call(CallIn, CallIn, _, _) :-
	(   current_prolog_flag(compile_meta_arguments, false)
	;   current_prolog_flag(xref, true)
	), !.
compile_meta_call(CallIn, CallIn, _, _) :-
	strip_module(CallIn, _, Call),
	(   is_aux_meta(Call)
	;   \+ control(Call),
	    (	'$c_current_predicate'(_, system:Call),
		\+ current_prolog_flag(compile_meta_arguments, always)
	    ;   current_prolog_flag(compile_meta_arguments, control)
	    )
	), !.
compile_meta_call(M:CallIn, CallOut, _, Term) :- !,
	(   atom(M), callable(CallIn)
	->  compile_meta_call(CallIn, CallOut, M, Term)
	;   CallOut = M:CallIn
	).
compile_meta_call(CallIn, CallOut, Module, Term) :-
	compile_meta(CallIn, CallOut, Module, Term, Clause),
	compile_auxiliary_clause(Module, Clause).

compile_auxiliary_clause(Module, Clause) :-
	Clause = (Head:-Body),
	functor(Head, Name, Arity),
	'$set_source_module'(SM, SM),
	(   current_predicate(SM:Name/Arity)
	->  true
	;   SM == Module
	->  compile_aux_clauses([Clause])
	;   compile_aux_clauses([Head:-Module:Body])
	).

control((_,_)).
control((_;_)).
control((_->_)).
control((_*->_)).
control(\+(_)).

is_aux_meta(Term) :-
	callable(Term),
	functor(Term, Name, _),
	sub_atom(Name, 0, _, _, '__aux_meta_call_').

compile_meta(CallIn, CallOut, M, Term, (CallOut :- Body)) :-
	term_variables(Term, AllVars),
	term_variables(CallIn, InVars),
	intersection_eq(InVars, AllVars, HeadVars),
	variant_sha1(CallIn+HeadVars, Hash),
	atom_concat('__aux_meta_call_', Hash, AuxName),
	expand_goal(CallIn, _Pos0, Body, _Pos, M, [], (CallOut:-CallIn)),
	length(HeadVars, Arity),
	(   Arity > 256			% avoid 1024 arity limit
	->  HeadArgs = [v(HeadVars)]
	;   HeadArgs = HeadVars
	),
	CallOut =.. [AuxName|HeadArgs].

%%	intersection_eq(+Small, +Big, -Shared) is det.
%
%	Shared are the variables in Small that   also appear in Big. The
%	variables in Shared are in the same order as Small.

intersection_eq([], _, []).
intersection_eq([H|T0], L, List) :-
	(   member_eq(H, L)
	->  List = [H|T],
	    intersection_eq(T0, L, T)
	;   intersection_eq(T0, L, List)
	).

member_eq(E, [H|T]) :-
	(   E == H
	->  true
	;   member_eq(E, T)
	).


		 /*******************************
		 *	:- IF ... :- ENDIF	*
		 *******************************/

:- thread_local
	'$include_code'/3.

'$including' :-
	'$include_code'(X, _, _), !,
	X == true.
'$including'.

cond_compilation((:- if(G)), []) :-
	source_location(File, Line),
	(   '$including'
	->  (   catch('$eval_if'(G), E, (print_message(error, E), fail))
	    ->  asserta('$include_code'(true, File, Line))
	    ;   asserta('$include_code'(false, File, Line))
	    )
	;   asserta('$include_code'(else_false, File, Line))
	).
cond_compilation((:- elif(G)), []) :-
	source_location(File, Line),
	(   clause('$include_code'(Old, OF, _), _, Ref)
	->  same_source(File, OF, elif),
	    erase(Ref),
	    (   Old == true
	    ->  asserta('$include_code'(else_false, File, Line))
	    ;   Old == false,
		catch('$eval_if'(G), E, (print_message(error, E), fail))
	    ->  asserta('$include_code'(true, File, Line))
	    ;	asserta('$include_code'(Old, File, Line))
	    )
	;   throw(error(conditional_compilation_error(no_if, elif), _))
	).
cond_compilation((:- else), []) :-
	source_location(File, Line),
	(   clause('$include_code'(X, OF, _), _, Ref)
	->  same_source(File, OF, else),
	    erase(Ref),
	    (   X == true
	    ->  X2 = false
	    ;   X == false
	    ->	X2 = true
	    ;	X2 = X
	    ),
	    asserta('$include_code'(X2, File, Line))
	;   throw(error(conditional_compilation_error(no_if, else), _))
	).
cond_compilation(end_of_file, end_of_file) :- !, % TBD: Check completeness
	source_location(File, _),
	(   clause('$include_code'(_, OF, OL), _)
	->  (   File == OF
	    ->	throw(error(conditional_compilation_error(
				unterminated,OF:OL), _))
	    ;   true
	    )
	;   true
	).
cond_compilation((:- endif), []) :- !,
	source_location(File, _),
	(   (   clause('$include_code'(_, OF, _), _, Ref)
	    ->  same_source(File, OF, endif),
		erase(Ref)
	    )
	->  true
	;   throw(error(conditional_compilation_error(no_if, endif), _))
	).
cond_compilation(_, []) :-
	\+ '$including'.

same_source(File, File, _) :- !.
same_source(_,    _,    Op) :-
	throw(error(conditional_compilation_error(no_if, Op), _)).


'$eval_if'(G) :-
	expand_goal(G, G2),
	'$set_source_module'(Module, Module),
	Module:G2.