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)  2009-2019, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module('$expand',
   38          [ expand_term/2,              % +Term0, -Term
   39            expand_goal/2,              % +Goal0, -Goal
   40            expand_term/4,              % +Term0, ?Pos0, -Term, -Pos
   41            expand_goal/4,              % +Goal0, ?Pos0, -Goal, -Pos
   42            var_property/2,             % +Var, ?Property
   43
   44            '$expand_closure'/3         % +GoalIn, +Extra, -GoalOut
   45          ]).   46
   47/** <module> Prolog source-code transformation
   48
   49This module specifies, together with dcg.pl, the transformation of terms
   50as they are read from a file before they are processed by the compiler.
   51
   52The toplevel is expand_term/2.  This uses three other translators:
   53
   54        * Conditional compilation
   55        * term_expansion/2 rules provided by the user
   56        * DCG expansion
   57
   58Note that this ordering implies  that conditional compilation directives
   59cannot be generated  by  term_expansion/2   rules:  they  must literally
   60appear in the source-code.
   61
   62Term-expansion may choose to overrule DCG   expansion.  If the result of
   63term-expansion is a DCG rule, the rule  is subject to translation into a
   64predicate.
   65
   66Next, the result is  passed  to   expand_bodies/2,  which  performs goal
   67expansion.
   68*/
   69
   70:- dynamic
   71    system:term_expansion/2,
   72    system:goal_expansion/2,
   73    user:term_expansion/2,
   74    user:goal_expansion/2,
   75    system:term_expansion/4,
   76    system:goal_expansion/4,
   77    user:term_expansion/4,
   78    user:goal_expansion/4.   79:- multifile
   80    system:term_expansion/2,
   81    system:goal_expansion/2,
   82    user:term_expansion/2,
   83    user:goal_expansion/2,
   84    system:term_expansion/4,
   85    system:goal_expansion/4,
   86    user:term_expansion/4,
   87    user:goal_expansion/4.   88
   89:- meta_predicate
   90    expand_terms(4, +, ?, -, -).   91
   92%!  expand_term(+Input, -Output) is det.
   93%!  expand_term(+Input, +Pos0, -Output, -Pos) is det.
   94%
   95%   This predicate is used to translate terms  as they are read from
   96%   a source-file before they are added to the Prolog database.
   97
   98expand_term(Term0, Term) :-
   99    expand_term(Term0, _, Term, _).
  100
  101expand_term(Var, Pos, Expanded, Pos) :-
  102    var(Var),
  103    !,
  104    Expanded = Var.
  105expand_term(Term, Pos0, [], Pos) :-
  106    cond_compilation(Term, X),
  107    X == [],
  108    !,
  109    atomic_pos(Pos0, Pos).
  110expand_term(Term, Pos0, Expanded, Pos) :-
  111    b_setval('$term', Term),
  112    prepare_directive(Term),
  113    '$def_modules'([term_expansion/4,term_expansion/2], MList),
  114    call_term_expansion(MList, Term, Pos0, Term1, Pos1),
  115    expand_terms(expand_term_2, Term1, Pos1, Term2, Pos),
  116    rename(Term2, Expanded),
  117    b_setval('$term', []).
  118
  119%!  prepare_directive(+Directive) is det.
  120%
  121%   Try to autoload goals associated with a   directive such that we can
  122%   allow for term expansion of autoloaded directives such as setting/4.
  123%   Trying to do so shall raise no errors  nor fail as the directive may
  124%   be further expanded.
  125
  126prepare_directive((:- Directive)) :-
  127    '$current_source_module'(M),
  128    prepare_directive(Directive, M),
  129    !.
  130prepare_directive(_).
  131
  132prepare_directive(Goal, _) :-
  133    \+ callable(Goal),
  134    !.
  135prepare_directive((A,B), Module) :-
  136    !,
  137    prepare_directive(A, Module),
  138    prepare_directive(B, Module).
  139prepare_directive(module(_,_), _) :- !.
  140prepare_directive(Goal, Module) :-
  141    '$get_predicate_attribute'(Module:Goal, defined, 1),
  142    !.
  143prepare_directive(Goal, Module) :-
  144    \+ current_prolog_flag(autoload, false),
  145    (   compound(Goal)
  146    ->  compound_name_arity(Goal, Name, Arity)
  147    ;   Name = Goal, Arity = 0
  148    ),
  149    '$autoload'(Module:Name/Arity),
  150    !.
  151prepare_directive(_, _).
  152
  153
  154call_term_expansion([], Term, Pos, Term, Pos).
  155call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
  156    current_prolog_flag(sandboxed_load, false),
  157    !,
  158    (   '$member'(Pred, Preds),
  159        (   Pred == term_expansion/2
  160        ->  M:term_expansion(Term0, Term1),
  161            Pos1 = Pos0
  162        ;   M:term_expansion(Term0, Pos0, Term1, Pos1)
  163        )
  164    ->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
  165    ;   call_term_expansion(T, Term0, Pos0, Term, Pos)
  166    ).
  167call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
  168    (   '$member'(Pred, Preds),
  169        (   Pred == term_expansion/2
  170        ->  allowed_expansion(M:term_expansion(Term0, Term1)),
  171            call(M:term_expansion(Term0, Term1)),
  172            Pos1 = Pos
  173        ;   allowed_expansion(M:term_expansion(Term0, Pos0, Term1, Pos1)),
  174            call(M:term_expansion(Term0, Pos0, Term1, Pos1))
  175        )
  176    ->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
  177    ;   call_term_expansion(T, Term0, Pos0, Term, Pos)
  178    ).
  179
  180expand_term_2((Head --> Body), Pos0, Expanded, Pos) :-
  181    dcg_translate_rule((Head --> Body), Pos0, Expanded0, Pos1),
  182    !,
  183    expand_bodies(Expanded0, Pos1, Expanded1, Pos),
  184    non_terminal_decl(Expanded1, Expanded).
  185expand_term_2(Term0, Pos0, Term, Pos) :-
  186    nonvar(Term0),
  187    !,
  188    expand_bodies(Term0, Pos0, Term, Pos).
  189expand_term_2(Term, Pos, Term, Pos).
  190
  191non_terminal_decl(Clause, Decl) :-
  192    \+ current_prolog_flag(xref, true),
  193    clause_head(Clause, Head),
  194    '$current_source_module'(M),
  195    (   '$get_predicate_attribute'(M:Head, non_terminal, NT)
  196    ->  NT == 0
  197    ;   true
  198    ),
  199    !,
  200    '$pi_head'(PI, Head),
  201    Decl = [:-(non_terminal(M:PI)), Clause].
  202non_terminal_decl(Clause, Clause).
  203
  204clause_head(Head:-_, Head) :- !.
  205clause_head(Head, Head).
  206
  207
  208
  209%!  expand_bodies(+Term, +Pos0, -Out, -Pos) is det.
  210%
  211%   Find the body terms in Term and   give them to expand_goal/2 for
  212%   further processing. Note that  we   maintain  status information
  213%   about variables. Currently we only  detect whether variables are
  214%   _fresh_ or not. See var_info/3.
  215
  216expand_bodies(Terms, Pos0, Out, Pos) :-
  217    '$def_modules'([goal_expansion/4,goal_expansion/2], MList),
  218    expand_terms(expand_body(MList), Terms, Pos0, Out, Pos),
  219    remove_attributes(Out, '$var_info').
  220
  221expand_body(MList, Clause0, Pos0, Clause, Pos) :-
  222    clause_head_body(Clause0, Left0, Neck, Body0),
  223    !,
  224    clause_head_body(Clause, Left, Neck, Body),
  225    f2_pos(Pos0, LPos0, BPos0, Pos, LPos, BPos),
  226    (   head_guard(Left0, Neck, Head0, Guard0)
  227    ->  f2_pos(LPos0, HPos, GPos0, LPos, HPos, GPos),
  228        mark_head_variables(Head0),
  229        expand_goal(Guard0, GPos0, Guard, GPos, MList, Clause0),
  230        Left = (Head,Guard)
  231    ;   LPos = LPos0,
  232        Head0 = Left0,
  233        Left = Head,
  234        mark_head_variables(Head0)
  235    ),
  236    expand_goal(Body0, BPos0, Body1, BPos, MList, Clause0),
  237    expand_head_functions(Head0, Head, Body1, Body).
  238expand_body(MList, (:- Body), Pos0, (:- ExpandedBody), Pos) :-
  239    !,
  240    f1_pos(Pos0, BPos0, Pos, BPos),
  241    expand_goal(Body, BPos0, ExpandedBody, BPos, MList, (:- Body)).
  242
  243clause_head_body((Head :- Body), Head, :-, Body).
  244clause_head_body((Head => Body), Head, =>, Body).
  245clause_head_body(?=>(Head, Body), Head, ?=>, Body).
  246
  247head_guard(Left, Neck, Head, Guard) :-
  248    nonvar(Left),
  249    Left = (Head,Guard),
  250    (   Neck == (=>)
  251    ->  true
  252    ;   Neck == (?=>)
  253    ).
  254
  255mark_head_variables(Head) :-
  256    term_variables(Head, HVars),
  257    mark_vars_non_fresh(HVars).
  258
  259expand_head_functions(Head0, Head, Body0, Body) :-
  260    compound(Head0),
  261    '$current_source_module'(M),
  262    replace_functions(Head0, Eval, Head, M),
  263    Eval \== true,
  264    !,
  265    Body = (Eval,Body0).
  266expand_head_functions(Head, Head, Body, Body).
  267
  268expand_body(_MList, Head0, Pos, Clause, Pos) :- % TBD: Position handling
  269    compound(Head0),
  270    '$current_source_module'(M),
  271    replace_functions(Head0, Eval, Head, M),
  272    Eval \== true,
  273    !,
  274    Clause = (Head :- Eval).
  275expand_body(_, Head, Pos, Head, Pos).
  276
  277
  278%!  expand_terms(:Closure, +In, +Pos0, -Out, -Pos)
  279%
  280%   Loop over two constructs that  can   be  added by term-expansion
  281%   rules in order to run the   next phase: calling term_expansion/2
  282%   can  return  a  list  and  terms    may   be  preceded  with   a
  283%   source-location.
  284
  285expand_terms(_, X, P, X, P) :-
  286    var(X),
  287    !.
  288expand_terms(C, List0, Pos0, List, Pos) :-
  289    nonvar(List0),
  290    List0 = [_|_],
  291    !,
  292    (   is_list(List0)
  293    ->  list_pos(Pos0, Elems0, Pos, Elems),
  294        expand_term_list(C, List0, Elems0, List, Elems)
  295    ;   '$type_error'(list, List0)
  296    ).
  297expand_terms(C, '$source_location'(File, Line):Clause0, Pos0, Clause, Pos) :-
  298    !,
  299    expand_terms(C, Clause0, Pos0, Clause1, Pos),
  300    add_source_location(Clause1, '$source_location'(File, Line), Clause).
  301expand_terms(C, Term0, Pos0, Term, Pos) :-
  302    call(C, Term0, Pos0, Term, Pos).
  303
  304%!  add_source_location(+Term, +SrcLoc, -SrcTerm)
  305%
  306%   Re-apply source location after term expansion.  If the result is
  307%   a list, claim all terms to originate from this location.
  308
  309add_source_location(Clauses0, SrcLoc, Clauses) :-
  310    (   is_list(Clauses0)
  311    ->  add_source_location_list(Clauses0, SrcLoc, Clauses)
  312    ;   Clauses = SrcLoc:Clauses0
  313    ).
  314
  315add_source_location_list([], _, []).
  316add_source_location_list([Clause|Clauses0], SrcLoc, [SrcLoc:Clause|Clauses]) :-
  317    add_source_location_list(Clauses0, SrcLoc, Clauses).
  318
  319%!  expand_term_list(:Expander, +TermList, +Pos, -NewTermList, -PosList)
  320
  321expand_term_list(_, [], _, [], []) :- !.
  322expand_term_list(C, [H0|T0], [PH0], Terms, PosL) :-
  323    !,
  324    expand_terms(C, H0, PH0, H, PH),
  325    add_term(H, PH, Terms, TT, PosL, PT),
  326    expand_term_list(C, T0, [PH0], TT, PT).
  327expand_term_list(C, [H0|T0], [PH0|PT0], Terms, PosL) :-
  328    !,
  329    expand_terms(C, H0, PH0, H, PH),
  330    add_term(H, PH, Terms, TT, PosL, PT),
  331    expand_term_list(C, T0, PT0, TT, PT).
  332expand_term_list(C, [H0|T0], PH0, Terms, PosL) :-
  333    expected_layout(list, PH0),
  334    expand_terms(C, H0, PH0, H, PH),
  335    add_term(H, PH, Terms, TT, PosL, PT),
  336    expand_term_list(C, T0, [PH0], TT, PT).
  337
  338%!  add_term(+ExpandOut, ?ExpandPosOut, -Terms, ?TermsT, -PosL, ?PosLT)
  339
  340add_term(List, Pos, Terms, TermT, PosL, PosT) :-
  341    nonvar(List), List = [_|_],
  342    !,
  343    (   is_list(List)
  344    ->  append_tp(List, Terms, TermT, Pos, PosL, PosT)
  345    ;   '$type_error'(list, List)
  346    ).
  347add_term(Term, Pos, [Term|Terms], Terms, [Pos|PosT], PosT).
  348
  349append_tp([], Terms, Terms, _, PosL, PosL).
  350append_tp([H|T0], [H|T1], Terms, [HP], [HP|TP1], PosL) :-
  351    !,
  352    append_tp(T0, T1, Terms, [HP], TP1, PosL).
  353append_tp([H|T0], [H|T1], Terms, [HP0|TP0], [HP0|TP1], PosL) :-
  354    !,
  355    append_tp(T0, T1, Terms, TP0, TP1, PosL).
  356append_tp([H|T0], [H|T1], Terms, Pos, [Pos|TP1], PosL) :-
  357    expected_layout(list, Pos),
  358    append_tp(T0, T1, Terms, [Pos], TP1, PosL).
  359
  360
  361list_pos(Var, _, _, _) :-
  362    var(Var),
  363    !.
  364list_pos(list_position(F,T,Elems0,none), Elems0,
  365         list_position(F,T,Elems,none),  Elems).
  366list_pos(Pos, [Pos], Elems, Elems).
  367
  368
  369                 /*******************************
  370                 *      VAR_INFO/3 SUPPORT      *
  371                 *******************************/
  372
  373%!  var_intersection(+List1, +List2, -Shared) is det.
  374%
  375%   Shared is the ordered intersection of List1 and List2.
  376
  377var_intersection(List1, List2, Intersection) :-
  378    sort(List1, Set1),
  379    sort(List2, Set2),
  380    ord_intersection(Set1, Set2, Intersection).
  381
  382%!  ord_intersection(+OSet1, +OSet2, -Int)
  383%
  384%   Ordered list intersection.  Copied from the library.
  385
  386ord_intersection([], _Int, []).
  387ord_intersection([H1|T1], L2, Int) :-
  388    isect2(L2, H1, T1, Int).
  389
  390isect2([], _H1, _T1, []).
  391isect2([H2|T2], H1, T1, Int) :-
  392    compare(Order, H1, H2),
  393    isect3(Order, H1, T1, H2, T2, Int).
  394
  395isect3(<, _H1, T1,  H2, T2, Int) :-
  396    isect2(T1, H2, T2, Int).
  397isect3(=, H1, T1, _H2, T2, [H1|Int]) :-
  398    ord_intersection(T1, T2, Int).
  399isect3(>, H1, T1,  _H2, T2, Int) :-
  400    isect2(T2, H1, T1, Int).
  401
  402%!  ord_subtract(+Set, +Subtract, -Diff)
  403
  404ord_subtract([], _Not, []).
  405ord_subtract(S1, S2, Diff) :-
  406    S1 == S2,
  407    !,
  408    Diff = [].
  409ord_subtract([H1|T1], L2, Diff) :-
  410    diff21(L2, H1, T1, Diff).
  411
  412diff21([], H1, T1, [H1|T1]).
  413diff21([H2|T2], H1, T1, Diff) :-
  414    compare(Order, H1, H2),
  415    diff3(Order, H1, T1, H2, T2, Diff).
  416
  417diff12([], _H2, _T2, []).
  418diff12([H1|T1], H2, T2, Diff) :-
  419    compare(Order, H1, H2),
  420    diff3(Order, H1, T1, H2, T2, Diff).
  421
  422diff3(<,  H1, T1,  H2, T2, [H1|Diff]) :-
  423    diff12(T1, H2, T2, Diff).
  424diff3(=, _H1, T1, _H2, T2, Diff) :-
  425    ord_subtract(T1, T2, Diff).
  426diff3(>,  H1, T1, _H2, T2, Diff) :-
  427    diff21(T2, H1, T1, Diff).
  428
  429%!  merge_variable_info(+Saved)
  430%
  431%   Merge info from two branches. The  info   in  Saved is the saved
  432%   info from the  first  branch,  while   the  info  in  the actual
  433%   variables is the  info  in  the   second  branch.  Only  if both
  434%   branches claim the variable to  be   fresh,  we  can consider it
  435%   fresh.
  436
  437merge_variable_info(State) :-
  438    catch(merge_variable_info_(State),
  439          error(uninstantiation_error(Term),_),
  440          throw(error(goal_expansion_error(bound, Term), _))).
  441
  442merge_variable_info_([]).
  443merge_variable_info_([Var=State|States]) :-
  444    (   get_attr(Var, '$var_info', CurrentState)
  445    ->  true
  446    ;   CurrentState = (-)
  447    ),
  448    merge_states(Var, State, CurrentState),
  449    merge_variable_info_(States).
  450
  451merge_states(_Var, State, State) :- !.
  452merge_states(_Var, -, _) :- !.
  453merge_states(Var, State, -) :-
  454    !,
  455    put_attr(Var, '$var_info', State).
  456merge_states(Var, Left, Right) :-
  457    (   get_dict(fresh, Left, false)
  458    ->  put_dict(fresh, Right, false)
  459    ;   get_dict(fresh, Right, false)
  460    ->  put_dict(fresh, Left, false)
  461    ),
  462    !,
  463    (   Left >:< Right
  464    ->  put_dict(Left, Right, State),
  465        put_attr(Var, '$var_info', State)
  466    ;   print_message(warning,
  467                      inconsistent_variable_properties(Left, Right)),
  468        put_dict(Left, Right, State),
  469        put_attr(Var, '$var_info', State)
  470    ).
  471
  472
  473save_variable_info([], []).
  474save_variable_info([Var|Vars], [Var=State|States]):-
  475    (   get_attr(Var, '$var_info', State)
  476    ->  true
  477    ;   State = (-)
  478    ),
  479    save_variable_info(Vars, States).
  480
  481restore_variable_info(State) :-
  482    catch(restore_variable_info_(State),
  483          error(uninstantiation_error(Term),_),
  484          throw(error(goal_expansion_error(bound, Term), _))).
  485
  486restore_variable_info_([]).
  487restore_variable_info_([Var=State|States]) :-
  488    (   State == (-)
  489    ->  del_attr(Var, '$var_info')
  490    ;   put_attr(Var, '$var_info', State)
  491    ),
  492    restore_variable_info_(States).
  493
  494%!  var_property(+Var, ?Property)
  495%
  496%   True when Var has a property  Key with Value. Defined properties
  497%   are:
  498%
  499%     - fresh(Fresh)
  500%     Variable is first introduced in this goal and thus guaranteed
  501%     to be unbound.  This property is always present.
  502%     - singleton(Bool)
  503%     It `true` indicate that the variable appears once in the source.
  504%     Note this doesn't mean it is a semantic singleton.
  505%     - name(-Name)
  506%     True when Name is the name of the variable.
  507
  508var_property(Var, Property) :-
  509    prop_var(Property, Var).
  510
  511prop_var(fresh(Fresh), Var) :-
  512    (   get_attr(Var, '$var_info', Info),
  513        get_dict(fresh, Info, Fresh0)
  514    ->  Fresh = Fresh0
  515    ;   Fresh = true
  516    ).
  517prop_var(singleton(Singleton), Var) :-
  518    nb_current('$term', Term),
  519    term_singletons(Term, Singletons),
  520    (   '$member'(V, Singletons),
  521        V == Var
  522    ->  Singleton = true
  523    ;   Singleton = false
  524    ).
  525prop_var(name(Name), Var) :-
  526    (   nb_current('$variable_names', Bindings),
  527        '$member'(Name0=Var0, Bindings),
  528        Var0 == Var
  529    ->  Name = Name0
  530    ).
  531
  532
  533mark_vars_non_fresh([]) :- !.
  534mark_vars_non_fresh([Var|Vars]) :-
  535    (   get_attr(Var, '$var_info', Info)
  536    ->  (   get_dict(fresh, Info, false)
  537        ->  true
  538        ;   put_dict(fresh, Info, false, Info1),
  539            put_attr(Var, '$var_info', Info1)
  540        )
  541    ;   put_attr(Var, '$var_info', '$var_info'{fresh:false})
  542    ),
  543    mark_vars_non_fresh(Vars).
  544
  545
  546%!  remove_attributes(+Term, +Attribute) is det.
  547%
  548%   Remove all variable attributes Attribute from Term. This is used
  549%   to make term_expansion end with a  clean term. This is currently
  550%   _required_ for saving directives  in   QLF  files.  The compiler
  551%   ignores attributes, but I think  it   is  cleaner to remove them
  552%   anyway.
  553
  554remove_attributes(Term, Attr) :-
  555    term_variables(Term, Vars),
  556    remove_var_attr(Vars, Attr).
  557
  558remove_var_attr([], _):- !.
  559remove_var_attr([Var|Vars], Attr):-
  560    del_attr(Var, Attr),
  561    remove_var_attr(Vars, Attr).
  562
  563%!  '$var_info':attr_unify_hook(_,_) is det.
  564%
  565%   Dummy unification hook for attributed variables.  Just succeeds.
  566
  567'$var_info':attr_unify_hook(_, _).
  568
  569
  570                 /*******************************
  571                 *   GOAL_EXPANSION/2 SUPPORT   *
  572                 *******************************/
  573
  574%!  expand_goal(+BodyTerm, +Pos0, -Out, -Pos) is det.
  575%!  expand_goal(+BodyTerm, -Out) is det.
  576%
  577%   Perform   macro-expansion   on    body     terms    by   calling
  578%   goal_expansion/2.
  579
  580expand_goal(A, B) :-
  581    expand_goal(A, _, B, _).
  582
  583expand_goal(A, P0, B, P) :-
  584    '$def_modules'([goal_expansion/4, goal_expansion/2], MList),
  585    (   expand_goal(A, P0, B, P, MList, _)
  586    ->  remove_attributes(B, '$var_info'), A \== B
  587    ),
  588    !.
  589expand_goal(A, P, A, P).
  590
  591%!  '$expand_closure'(+BodyIn, +ExtraArgs, -BodyOut) is semidet.
  592%!  '$expand_closure'(+BodyIn, +PIn, +ExtraArgs, -BodyOut, -POut) is semidet.
  593%
  594%   Expand a closure using goal expansion  for some extra arguments.
  595%   Note that the extra argument must remain  at the end. If this is
  596%   not the case, '$expand_closure'/3,5 fail.
  597
  598'$expand_closure'(G0, N, G) :-
  599    '$expand_closure'(G0, _, N, G, _).
  600
  601'$expand_closure'(G0, P0, N, G, P) :-
  602    length(Ex, N),
  603    mark_vars_non_fresh(Ex),
  604    extend_arg_pos(G0, P0, Ex, G1, P1),
  605    expand_goal(G1, P1, G2, P2),
  606    term_variables(G0, VL),
  607    remove_arg_pos(G2, P2, [], VL, Ex, G, P).
  608
  609
  610expand_goal(G0, P0, G, P, MList, Term) :-
  611    '$current_source_module'(M),
  612    expand_goal(G0, P0, G, P, M, MList, Term, []).
  613
  614%!  expand_goal(+GoalIn, ?PosIn, -GoalOut, -PosOut,
  615%!              +Module, -ModuleList, +Term, +Done) is det.
  616%
  617%   @arg Module is the current module to consider
  618%   @arg ModuleList are the other expansion modules
  619%   @arg Term is the overall term that is being translated
  620%   @arg Done is a list of terms that have already been expanded
  621
  622% (*)   This is needed because call_goal_expansion may introduce extra
  623%       context variables.  Consider the code below, where the variable
  624%       E is introduced.  Is there a better representation for the
  625%       context?
  626%
  627%         ==
  628%         goal_expansion(catch_and_print(Goal), catch(Goal, E, print(E))).
  629%
  630%         test :-
  631%               catch_and_print(true).
  632%         ==
  633
  634expand_goal(G, P, G, P, _, _, _, _) :-
  635    var(G),
  636    !.
  637expand_goal(M:G, P, M:G, P, _M, _MList, _Term, _) :-
  638    var(M), var(G),
  639    !.
  640expand_goal(M:G, P0, M:EG, P, _M, _MList, Term, Done) :-
  641    atom(M),
  642    !,
  643    f2_pos(P0, PA, PB0, P, PA, PB),
  644    '$def_modules'(M:[goal_expansion/4,goal_expansion/2], MList),
  645    setup_call_cleanup(
  646        '$set_source_module'(Old, M),
  647        '$expand':expand_goal(G, PB0, EG, PB, M, MList, Term, Done),
  648        '$set_source_module'(Old)).
  649expand_goal(G0, P0, G, P, M, MList, Term, Done) :-
  650    (   already_expanded(G0, Done, Done1)
  651    ->  expand_control(G0, P0, G, P, M, MList, Term, Done1)
  652    ;   call_goal_expansion(MList, G0, P0, G1, P1)
  653    ->  expand_goal(G1, P1, G, P, M, MList, Term/G1, [G0|Done])      % (*)
  654    ;   expand_control(G0, P0, G, P, M, MList, Term, Done)
  655    ).
  656
  657expand_control((A,B), P0, Conj, P, M, MList, Term, Done) :-
  658    !,
  659    f2_pos(P0, PA0, PB0, P1, PA, PB),
  660    expand_goal(A, PA0, EA, PA, M, MList, Term, Done),
  661    expand_goal(B, PB0, EB, PB, M, MList, Term, Done),
  662    simplify((EA,EB), P1, Conj, P).
  663expand_control((A;B), P0, Or, P, M, MList, Term, Done) :-
  664    !,
  665    f2_pos(P0, PA0, PB0, P1, PA1, PB),
  666    term_variables(A, AVars),
  667    term_variables(B, BVars),
  668    var_intersection(AVars, BVars, SharedVars),
  669    save_variable_info(SharedVars, SavedState),
  670    expand_goal(A, PA0, EA, PA, M, MList, Term, Done),
  671    save_variable_info(SharedVars, SavedState2),
  672    restore_variable_info(SavedState),
  673    expand_goal(B, PB0, EB, PB, M, MList, Term, Done),
  674    merge_variable_info(SavedState2),
  675    fixup_or_lhs(A, EA, PA, EA1, PA1),
  676    simplify((EA1;EB), P1, Or, P).
  677expand_control((A->B), P0, Goal, P, M, MList, Term, Done) :-
  678    !,
  679    f2_pos(P0, PA0, PB0, P1, PA, PB),
  680    expand_goal(A, PA0, EA, PA, M, MList, Term, Done),
  681    expand_goal(B, PB0, EB, PB, M, MList, Term, Done),
  682    simplify((EA->EB), P1, Goal, P).
  683expand_control((A*->B), P0, Goal, P, M, MList, Term, Done) :-
  684    !,
  685    f2_pos(P0, PA0, PB0, P1, PA, PB),
  686    expand_goal(A, PA0, EA, PA, M, MList, Term, Done),
  687    expand_goal(B, PB0, EB, PB, M, MList, Term, Done),
  688    simplify((EA*->EB), P1, Goal, P).
  689expand_control((\+A), P0, Goal, P, M, MList, Term, Done) :-
  690    !,
  691    f1_pos(P0, PA0, P1, PA),
  692    term_variables(A, AVars),
  693    save_variable_info(AVars, SavedState),
  694    expand_goal(A, PA0, EA, PA, M, MList, Term, Done),
  695    restore_variable_info(SavedState),
  696    simplify(\+(EA), P1, Goal, P).
  697expand_control(call(A), P0, call(EA), P, M, MList, Term, Done) :-
  698    !,
  699    f1_pos(P0, PA0, P, PA),
  700    expand_goal(A, PA0, EA, PA, M, MList, Term, Done).
  701expand_control($(A), P0, $(EA), P, M, MList, Term, Done) :-
  702    !,
  703    f1_pos(P0, PA0, P, PA),
  704    expand_goal(A, PA0, EA, PA, M, MList, Term, Done).
  705expand_control(G0, P0, G, P, M, MList, Term, Done) :-
  706    is_meta_call(G0, M, Head),
  707    !,
  708    term_variables(G0, Vars),
  709    mark_vars_non_fresh(Vars),
  710    expand_meta(Head, G0, P0, G, P, M, MList, Term, Done).
  711expand_control(G0, P0, G, P, M, MList, Term, _Done) :-
  712    term_variables(G0, Vars),
  713    mark_vars_non_fresh(Vars),
  714    expand_functions(G0, P0, G, P, M, MList, Term).
  715
  716%!  already_expanded(+Goal, +Done, -RestDone) is semidet.
  717
  718already_expanded(Goal, Done, Done1) :-
  719    '$select'(G, Done, Done1),
  720    G == Goal,
  721    !.
  722
  723%!  fixup_or_lhs(+OldLeft, -ExpandedLeft, +ExpPos, -Fixed, -FixedPos) is det.
  724%
  725%   The semantics of (A;B) is different if  A is (If->Then). We need
  726%   to keep the same semantics if -> is introduced or removed by the
  727%   expansion. If -> is introduced, we make sure that the whole
  728%   thing remains a disjunction by creating ((EA,true);B)
  729
  730fixup_or_lhs(Old, New, PNew, Fix, PFixed) :-
  731    nonvar(Old),
  732    nonvar(New),
  733    (   Old = (_ -> _)
  734    ->  New \= (_ -> _),
  735        Fix = (New -> true)
  736    ;   New = (_ -> _),
  737        Fix = (New, true)
  738    ),
  739    !,
  740    lhs_pos(PNew, PFixed).
  741fixup_or_lhs(_Old, New, P, New, P).
  742
  743lhs_pos(P0, _) :-
  744    var(P0),
  745    !.
  746lhs_pos(P0, term_position(F,T,T,T,[P0,T-T])) :-
  747    arg(1, P0, F),
  748    arg(2, P0, T).
  749
  750
  751%!  is_meta_call(+G0, +M, -Head) is semidet.
  752%
  753%   True if M:G0 resolves to a real meta-goal as specified by Head.
  754
  755is_meta_call(G0, M, Head) :-
  756    compound(G0),
  757    default_module(M, M2),
  758    '$c_current_predicate'(_, M2:G0),
  759    !,
  760    '$get_predicate_attribute'(M2:G0, meta_predicate, Head),
  761    has_meta_arg(Head).
  762
  763
  764%!  expand_meta(+MetaSpec, +G0, ?P0, -G, -P, +M, +Mlist, +Term, +Done)
  765
  766expand_meta(Spec, G0, P0, G, P, M, MList, Term, Done) :-
  767    functor(Spec, _, Arity),
  768    functor(G0, Name, Arity),
  769    functor(G1, Name, Arity),
  770    f_pos(P0, ArgPos0, P, ArgPos),
  771    expand_meta(1, Arity, Spec,
  772                G0, ArgPos0, Eval,
  773                G1,  ArgPos,
  774                M, MList, Term, Done),
  775    conj(Eval, G1, G).
  776
  777expand_meta(I, Arity, Spec, G0, ArgPos0, Eval, G, [P|PT], M, MList, Term, Done) :-
  778    I =< Arity,
  779    !,
  780    arg_pos(ArgPos0, P0, PT0),
  781    arg(I, Spec, Meta),
  782    arg(I, G0, A0),
  783    arg(I, G, A),
  784    expand_meta_arg(Meta, A0, P0, EvalA, A, P, M, MList, Term, Done),
  785    I2 is I + 1,
  786    expand_meta(I2, Arity, Spec, G0, PT0, EvalB, G, PT, M, MList, Term, Done),
  787    conj(EvalA, EvalB, Eval).
  788expand_meta(_, _, _, _, _, true, _, [], _, _, _, _).
  789
  790arg_pos(List, _, _) :- var(List), !.    % no position info
  791arg_pos([H|T], H, T) :- !.              % argument list
  792arg_pos([], _, []).                     % new has more
  793
  794mapex([], _).
  795mapex([E|L], E) :- mapex(L, E).
  796
  797%!  extended_pos(+Pos0, +N, -Pos) is det.
  798%!  extended_pos(-Pos0, +N, +Pos) is det.
  799%
  800%   Pos is the result of adding N extra positions to Pos0.
  801
  802extended_pos(Var, _, Var) :-
  803    var(Var),
  804    !.
  805extended_pos(parentheses_term_position(O,C,Pos0),
  806             N,
  807             parentheses_term_position(O,C,Pos)) :-
  808    !,
  809    extended_pos(Pos0, N, Pos).
  810extended_pos(term_position(F,T,FF,FT,Args),
  811             _,
  812             term_position(F,T,FF,FT,Args)) :-
  813    var(Args),
  814    !.
  815extended_pos(term_position(F,T,FF,FT,Args0),
  816             N,
  817             term_position(F,T,FF,FT,Args)) :-
  818    length(Ex, N),
  819    mapex(Ex, T-T),
  820    '$append'(Args0, Ex, Args),
  821    !.
  822extended_pos(F-T,
  823             N,
  824             term_position(F,T,F,T,Ex)) :-
  825    !,
  826    length(Ex, N),
  827    mapex(Ex, T-T).
  828extended_pos(Pos, N, Pos) :-
  829    '$print_message'(warning, extended_pos(Pos, N)).
  830
  831%!  expand_meta_arg(+MetaSpec, +Arg0, +ArgPos0, -Eval,
  832%!                  -Arg, -ArgPos, +ModuleList, +Term, +Done) is det.
  833%
  834%   Goal expansion for a meta-argument.
  835%
  836%   @arg    Eval is always `true`.  Future versions should allow for
  837%           functions on such positions.  This requires proper
  838%           position management for function expansion.
  839
  840expand_meta_arg(0, A0, PA0, true, A, PA, M, MList, Term, Done) :-
  841    !,
  842    expand_goal(A0, PA0, A1, PA, M, MList, Term, Done),
  843    compile_meta_call(A1, A, M, Term).
  844expand_meta_arg(N, A0, P0, true, A, P, M, MList, Term, Done) :-
  845    integer(N), callable(A0),
  846    replace_functions(A0, true, _, M),
  847    !,
  848    length(Ex, N),
  849    mark_vars_non_fresh(Ex),
  850    extend_arg_pos(A0, P0, Ex, A1, PA1),
  851    expand_goal(A1, PA1, A2, PA2, M, MList, Term, Done),
  852    compile_meta_call(A2, A3, M, Term),
  853    term_variables(A0, VL),
  854    remove_arg_pos(A3, PA2, M, VL, Ex, A, P).
  855expand_meta_arg(^, A0, PA0, true, A, PA, M, MList, Term, Done) :-
  856    !,
  857    expand_setof_goal(A0, PA0, A, PA, M, MList, Term, Done).
  858expand_meta_arg(S, A0, _PA0, Eval, A, _PA, M, _MList, _Term, _Done) :-
  859    replace_functions(A0, Eval, A, M), % TBD: pass positions
  860    (   Eval == true
  861    ->  true
  862    ;   same_functor(A0, A)
  863    ->  true
  864    ;   meta_arg(S)
  865    ->  throw(error(context_error(function, meta_arg(S)), _))
  866    ;   true
  867    ).
  868
  869same_functor(T1, T2) :-
  870    compound(T1),
  871    !,
  872    compound(T2),
  873    compound_name_arity(T1, N, A),
  874    compound_name_arity(T2, N, A).
  875same_functor(T1, T2) :-
  876    atom(T1),
  877    T1 == T2.
  878
  879variant_sha1_nat(Term, Hash) :-
  880    copy_term_nat(Term, TNat),
  881    variant_sha1(TNat, Hash).
  882
  883wrap_meta_arguments(A0, M, VL, Ex, A) :-
  884    '$append'(VL, Ex, AV),
  885    variant_sha1_nat(A0+AV, Hash),
  886    atom_concat('__aux_wrapper_', Hash, AuxName),
  887    H =.. [AuxName|AV],
  888    compile_auxiliary_clause(M, (H :- A0)),
  889    A =.. [AuxName|VL].
  890
  891%!  extend_arg_pos(+A0, +P0, +Ex, -A, -P) is det.
  892%
  893%   Adds extra arguments Ex to A0, and  extra subterm positions to P
  894%   for such arguments.
  895
  896extend_arg_pos(A, P, _, A, P) :-
  897    var(A),
  898    !.
  899extend_arg_pos(M:A0, P0, Ex, M:A, P) :-
  900    !,
  901    f2_pos(P0, PM, PA0, P, PM, PA),
  902    extend_arg_pos(A0, PA0, Ex, A, PA).
  903extend_arg_pos(A0, P0, Ex, A, P) :-
  904    callable(A0),
  905    !,
  906    extend_term(A0, Ex, A),
  907    length(Ex, N),
  908    extended_pos(P0, N, P).
  909extend_arg_pos(A, P, _, A, P).
  910
  911extend_term(Atom, Extra, Term) :-
  912    atom(Atom),
  913    !,
  914    Term =.. [Atom|Extra].
  915extend_term(Term0, Extra, Term) :-
  916    compound_name_arguments(Term0, Name, Args0),
  917    '$append'(Args0, Extra, Args),
  918    compound_name_arguments(Term, Name, Args).
  919
  920%!  remove_arg_pos(+A0, +P0, +M, +Ex, +VL, -A, -P) is det.
  921%
  922%   Removes the Ex arguments  from  A0   and  the  respective  extra
  923%   positions from P0. Note that  if  they   are  not  at the end, a
  924%   wrapper with the elements of VL as arguments is generated to put
  925%   them in order.
  926%
  927%   @see wrap_meta_arguments/5
  928
  929remove_arg_pos(A, P, _, _, _, A, P) :-
  930    var(A),
  931    !.
  932remove_arg_pos(M:A0, P0, _, VL, Ex, M:A, P) :-
  933    !,
  934    f2_pos(P, PM, PA0, P0, PM, PA),
  935    remove_arg_pos(A0, PA, M, VL, Ex, A, PA0).
  936remove_arg_pos(A0, P0, M, VL, Ex0, A, P) :-
  937    callable(A0),
  938    !,
  939    length(Ex0, N),
  940    (   A0 =.. [F|Args],
  941        length(Ex, N),
  942        '$append'(Args0, Ex, Args),
  943        Ex==Ex0
  944    ->  extended_pos(P, N, P0),
  945        A =.. [F|Args0]
  946    ;   M \== [],
  947        wrap_meta_arguments(A0, M, VL, Ex0, A),
  948        wrap_meta_pos(P0, P)
  949    ).
  950remove_arg_pos(A, P, _, _, _, A, P).
  951
  952wrap_meta_pos(P0, P) :-
  953    (   nonvar(P0)
  954    ->  P = term_position(F,T,_,_,_),
  955        atomic_pos(P0, F-T)
  956    ;   true
  957    ).
  958
  959has_meta_arg(Head) :-
  960    arg(_, Head, Arg),
  961    direct_call_meta_arg(Arg),
  962    !.
  963
  964direct_call_meta_arg(I) :- integer(I).
  965direct_call_meta_arg(^).
  966
  967meta_arg(:).
  968meta_arg(//).
  969meta_arg(I) :- integer(I).
  970
  971expand_setof_goal(Var, Pos, Var, Pos, _, _, _, _) :-
  972    var(Var),
  973    !.
  974expand_setof_goal(V^G, P0, V^EG, P, M, MList, Term, Done) :-
  975    !,
  976    f2_pos(P0, PA0, PB, P, PA, PB),
  977    expand_setof_goal(G, PA0, EG, PA, M, MList, Term, Done).
  978expand_setof_goal(M0:G, P0, M0:EG, P, M, MList, Term, Done) :-
  979    !,
  980    f2_pos(P0, PA0, PB, P, PA, PB),
  981    expand_setof_goal(G, PA0, EG, PA, M, MList, Term, Done).
  982expand_setof_goal(G, P0, EG, P, M, MList, Term, Done) :-
  983    !,
  984    expand_goal(G, P0, EG0, P, M, MList, Term, Done),
  985    compile_meta_call(EG0, EG1, M, Term),
  986    (   extend_existential(G, EG1, V)
  987    ->  EG = V^EG1
  988    ;   EG = EG1
  989    ).
  990
  991%!  extend_existential(+G0, +G1, -V) is semidet.
  992%
  993%   Extend  the  variable  template  to    compensate  for  intermediate
  994%   variables introduced during goal expansion   (notably for functional
  995%   notation).
  996
  997extend_existential(G0, G1, V) :-
  998    term_variables(G0, GV0), sort(GV0, SV0),
  999    term_variables(G1, GV1), sort(GV1, SV1),
 1000    ord_subtract(SV1, SV0, New),
 1001    New \== [],
 1002    V =.. [v|New].
 1003
 1004%!  call_goal_expansion(+ExpandModules,
 1005%!                      +Goal0, ?Pos0, -Goal, -Pos, +Done) is semidet.
 1006%
 1007%   Succeeds  if  the   context   has    a   module   that   defines
 1008%   goal_expansion/2 this rule succeeds and  Goal   is  not equal to
 1009%   Goal0. Note that the translator is   called  recursively until a
 1010%   fixed-point is reached.
 1011
 1012call_goal_expansion(MList, G0, P0, G, P) :-
 1013    current_prolog_flag(sandboxed_load, false),
 1014    !,
 1015    (   '$member'(M-Preds, MList),
 1016        '$member'(Pred, Preds),
 1017        (   Pred == goal_expansion/4
 1018        ->  M:goal_expansion(G0, P0, G, P)
 1019        ;   M:goal_expansion(G0, G),
 1020            P = P0
 1021        ),
 1022        G0 \== G
 1023    ->  true
 1024    ).
 1025call_goal_expansion(MList, G0, P0, G, P) :-
 1026    (   '$member'(M-Preds, MList),
 1027        '$member'(Pred, Preds),
 1028        (   Pred == goal_expansion/4
 1029        ->  Expand = M:goal_expansion(G0, P0, G, P)
 1030        ;   Expand = M:goal_expansion(G0, G)
 1031        ),
 1032        allowed_expansion(Expand),
 1033        call(Expand),
 1034        G0 \== G
 1035    ->  true
 1036    ).
 1037
 1038%!  allowed_expansion(:Goal) is semidet.
 1039%
 1040%   Calls prolog:sandbox_allowed_expansion(:Goal) prior   to calling
 1041%   Goal for the purpose of term or   goal  expansion. This hook can
 1042%   prevent the expansion to take place by raising an exception.
 1043%
 1044%   @throws exceptions from prolog:sandbox_allowed_expansion/1.
 1045
 1046:- multifile
 1047    prolog:sandbox_allowed_expansion/1. 1048
 1049allowed_expansion(QGoal) :-
 1050    strip_module(QGoal, M, Goal),
 1051    E = error(Formal,_),
 1052    catch(prolog:sandbox_allowed_expansion(M:Goal), E, true),
 1053    (   var(Formal)
 1054    ->  fail
 1055    ;   !,
 1056        print_message(error, E),
 1057        fail
 1058    ).
 1059allowed_expansion(_).
 1060
 1061
 1062                 /*******************************
 1063                 *      FUNCTIONAL NOTATION     *
 1064                 *******************************/
 1065
 1066%!  expand_functions(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
 1067%
 1068%   Expand functional notation and arithmetic functions.
 1069%
 1070%   @arg MList is the list of modules defining goal_expansion/2 in
 1071%   the expansion context.
 1072
 1073expand_functions(G0, P0, G, P, M, MList, Term) :-
 1074    expand_functional_notation(G0, P0, G1, P1, M, MList, Term),
 1075    (   expand_arithmetic(G1, P1, G, P, Term)
 1076    ->  true
 1077    ;   G = G1,
 1078        P = P1
 1079    ).
 1080
 1081%!  expand_functional_notation(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
 1082%
 1083%   @tbd: position logic
 1084%   @tbd: make functions module-local
 1085
 1086expand_functional_notation(G0, P0, G, P, M, _MList, _Term) :-
 1087    contains_functions(G0),
 1088    replace_functions(G0, P0, Eval, EvalPos, G1, G1Pos, M),
 1089    Eval \== true,
 1090    !,
 1091    wrap_var(G1, G1Pos, G2, G2Pos),
 1092    conj(Eval, EvalPos, G2, G2Pos, G, P).
 1093expand_functional_notation(G, P, G, P, _, _, _).
 1094
 1095wrap_var(G, P, G, P) :-
 1096    nonvar(G),
 1097    !.
 1098wrap_var(G, P0, call(G), P) :-
 1099    (   nonvar(P0)
 1100    ->  P = term_position(F,T,F,T,[P0]),
 1101        atomic_pos(P0, F-T)
 1102    ;   true
 1103    ).
 1104
 1105%!  contains_functions(@Term) is semidet.
 1106%
 1107%   True when Term contains a function reference.
 1108
 1109contains_functions(Term) :-
 1110    \+ \+ ( '$factorize_term'(Term, Skeleton, Assignments),
 1111            (   contains_functions2(Skeleton)
 1112            ;   contains_functions2(Assignments)
 1113            )).
 1114
 1115contains_functions2(Term) :-
 1116    compound(Term),
 1117    (   function(Term, _)
 1118    ->  true
 1119    ;   arg(_, Term, Arg),
 1120        contains_functions2(Arg)
 1121    ->  true
 1122    ).
 1123
 1124%!  replace_functions(+GoalIn, +PosIn,
 1125%!                    -Eval, -EvalPos,
 1126%!                    -GoalOut, -PosOut,
 1127%!                    +ContextTerm) is det.
 1128%
 1129%   @tbd    Proper propagation of list, dict and brace term positions.
 1130
 1131:- public
 1132    replace_functions/4.            % used in dicts.pl
 1133
 1134replace_functions(GoalIn, Eval, GoalOut, Context) :-
 1135    replace_functions(GoalIn, _, Eval, _, GoalOut, _, Context).
 1136
 1137replace_functions(Var, Pos, true, _, Var, Pos, _Ctx) :-
 1138    var(Var),
 1139    !.
 1140replace_functions(F, FPos, Eval, EvalPos, Var, VarPos, Ctx) :-
 1141    function(F, Ctx),
 1142    !,
 1143    compound_name_arity(F, Name, Arity),
 1144    PredArity is Arity+1,
 1145    compound_name_arity(G, Name, PredArity),
 1146    arg(PredArity, G, Var),
 1147    extend_1_pos(FPos, FArgPos, GPos, GArgPos, VarPos),
 1148    map_functions(0, Arity, F, FArgPos, G, GArgPos, Eval0, EP0, Ctx),
 1149    conj(Eval0, EP0, G, GPos, Eval, EvalPos).
 1150replace_functions(Term0, Term0Pos, Eval, EvalPos, Term, TermPos, Ctx) :-
 1151    compound(Term0),
 1152    !,
 1153    compound_name_arity(Term0, Name, Arity),
 1154    compound_name_arity(Term, Name, Arity),
 1155    f_pos(Term0Pos, Args0Pos, TermPos, ArgsPos),
 1156    map_functions(0, Arity,
 1157                  Term0, Args0Pos, Term, ArgsPos, Eval, EvalPos, Ctx).
 1158replace_functions(Term, Pos, true, _, Term, Pos, _).
 1159
 1160
 1161%!  map_functions(+Arg, +Arity,
 1162%!                +TermIn, +ArgInPos, -Term, -ArgPos, -Eval, -EvalPos,
 1163%!                +Context)
 1164
 1165map_functions(Arity, Arity, _, LPos0, _, LPos, true, _, _) :-
 1166    !,
 1167    pos_nil(LPos0, LPos).
 1168map_functions(I0, Arity, Term0, LPos0, Term, LPos, Eval, EP, Ctx) :-
 1169    pos_list(LPos0, AP0, APT0, LPos, AP, APT),
 1170    I is I0+1,
 1171    arg(I, Term0, Arg0),
 1172    arg(I, Term, Arg),
 1173    replace_functions(Arg0, AP0, Eval0, EP0, Arg, AP, Ctx),
 1174    map_functions(I, Arity, Term0, APT0, Term, APT, Eval1, EP1, Ctx),
 1175    conj(Eval0, EP0, Eval1, EP1, Eval, EP).
 1176
 1177conj(true, X, X) :- !.
 1178conj(X, true, X) :- !.
 1179conj(X, Y, (X,Y)).
 1180
 1181conj(true, _, X, P, X, P) :- !.
 1182conj(X, P, true, _, X, P) :- !.
 1183conj(X, PX, Y, PY, (X,Y), _) :-
 1184    var(PX), var(PY),
 1185    !.
 1186conj(X, PX, Y, PY, (X,Y), P) :-
 1187    P = term_position(F,T,FF,FT,[PX,PY]),
 1188    atomic_pos(PX, F-FF),
 1189    atomic_pos(PY, FT-T).
 1190
 1191%!  function(?Term, +Context)
 1192%
 1193%   True if function expansion needs to be applied for the given
 1194%   term.
 1195
 1196:- multifile
 1197    function/2. 1198
 1199function(.(_,_), _) :- \+ functor([_|_], ., _).
 1200
 1201
 1202                 /*******************************
 1203                 *          ARITHMETIC          *
 1204                 *******************************/
 1205
 1206%!  expand_arithmetic(+G0, +P0, -G, -P, +Term) is semidet.
 1207%
 1208%   Expand arithmetic expressions  in  is/2,   (>)/2,  etc.  This is
 1209%   currently a dummy.  The  idea  is   to  call  rules  similar  to
 1210%   goal_expansion/2,4  that  allow  for   rewriting  an  arithmetic
 1211%   expression. The system rules will perform evaluation of constant
 1212%   expressions.
 1213
 1214expand_arithmetic(_G0, _P0, _G, _P, _Term) :- fail.
 1215
 1216
 1217                 /*******************************
 1218                 *        POSITION LOGIC        *
 1219                 *******************************/
 1220
 1221%!  f2_pos(?TermPos0, ?PosArg10, ?PosArg20,
 1222%!         ?TermPos,  ?PosArg1,  ?PosArg2) is det.
 1223%!  f1_pos(?TermPos0, ?PosArg10, ?TermPos,  ?PosArg1) is det.
 1224%!  f_pos(?TermPos0, ?PosArgs0, ?TermPos,  ?PosArgs) is det.
 1225%!  atomic_pos(?TermPos0, -AtomicPos) is det.
 1226%
 1227%   Position progapation routines.
 1228
 1229f2_pos(Var, _, _, _, _, _) :-
 1230    var(Var),
 1231    !.
 1232f2_pos(term_position(F,T,FF,FT,[A10,A20]), A10, A20,
 1233       term_position(F,T,FF,FT,[A1, A2 ]), A1,  A2) :- !.
 1234f2_pos(parentheses_term_position(O,C,Pos0), A10, A20,
 1235       parentheses_term_position(O,C,Pos),  A1,  A2) :-
 1236    !,
 1237    f2_pos(Pos0, A10, A20, Pos, A1, A2).
 1238f2_pos(Pos, _, _, _, _, _) :-
 1239    expected_layout(f2, Pos).
 1240
 1241f1_pos(Var, _, _, _) :-
 1242    var(Var),
 1243    !.
 1244f1_pos(term_position(F,T,FF,FT,[A10]), A10,
 1245       term_position(F,T,FF,FT,[A1 ]),  A1) :- !.
 1246f1_pos(parentheses_term_position(O,C,Pos0), A10,
 1247       parentheses_term_position(O,C,Pos),  A1) :-
 1248    !,
 1249    f1_pos(Pos0, A10, Pos, A1).
 1250f1_pos(Pos, _, _, _) :-
 1251    expected_layout(f1, Pos).
 1252
 1253f_pos(Var, _, _, _) :-
 1254    var(Var),
 1255    !.
 1256f_pos(term_position(F,T,FF,FT,ArgPos0), ArgPos0,
 1257      term_position(F,T,FF,FT,ArgPos),  ArgPos) :- !.
 1258f_pos(parentheses_term_position(O,C,Pos0), A10,
 1259      parentheses_term_position(O,C,Pos),  A1) :-
 1260    !,
 1261    f_pos(Pos0, A10, Pos, A1).
 1262f_pos(Pos, _, _, _) :-
 1263    expected_layout(compound, Pos).
 1264
 1265atomic_pos(Pos, _) :-
 1266    var(Pos),
 1267    !.
 1268atomic_pos(Pos, F-T) :-
 1269    arg(1, Pos, F),
 1270    arg(2, Pos, T).
 1271
 1272%!  pos_nil(+Nil, -Nil) is det.
 1273%!  pos_list(+List0, -H0, -T0, -List, -H, -T) is det.
 1274%
 1275%   Position propagation for lists.
 1276
 1277pos_nil(Var, _) :- var(Var), !.
 1278pos_nil([], []) :- !.
 1279pos_nil(Pos, _) :-
 1280    expected_layout(nil, Pos).
 1281
 1282pos_list(Var, _, _, _, _, _) :- var(Var), !.
 1283pos_list([H0|T0], H0, T0, [H|T], H, T) :- !.
 1284pos_list(Pos, _, _, _, _, _) :-
 1285    expected_layout(list, Pos).
 1286
 1287%!  extend_1_pos(+FunctionPos, -FArgPos, -EvalPos, -EArgPos, -VarPos)
 1288%
 1289%   Deal with extending a function to include the return value.
 1290
 1291extend_1_pos(Pos, _, _, _, _) :-
 1292    var(Pos),
 1293    !.
 1294extend_1_pos(term_position(F,T,FF,FT,FArgPos), FArgPos,
 1295             term_position(F,T,FF,FT,GArgPos), GArgPos0,
 1296             FT-FT1) :-
 1297    integer(FT),
 1298    !,
 1299    FT1 is FT+1,
 1300    '$same_length'(FArgPos, GArgPos0),
 1301    '$append'(GArgPos0, [FT-FT1], GArgPos).
 1302extend_1_pos(F-T, [],
 1303             term_position(F,T,F,T,[T-T1]), [],
 1304             T-T1) :-
 1305    integer(T),
 1306    !,
 1307    T1 is T+1.
 1308extend_1_pos(Pos, _, _, _, _) :-
 1309    expected_layout(callable, Pos).
 1310
 1311'$same_length'(List, List) :-
 1312    var(List),
 1313    !.
 1314'$same_length'([], []).
 1315'$same_length'([_|T0], [_|T]) :-
 1316    '$same_length'(T0, T).
 1317
 1318
 1319%!  expected_layout(+Expected, +Found)
 1320%
 1321%   Print a message  if  the  layout   term  does  not  satisfy  our
 1322%   expectations.  This  means  that   the  transformation  requires
 1323%   support from term_expansion/4 and/or goal_expansion/4 to achieve
 1324%   proper source location information.
 1325
 1326:- create_prolog_flag(debug_term_position, false, []). 1327
 1328expected_layout(Expected, Pos) :-
 1329    current_prolog_flag(debug_term_position, true),
 1330    !,
 1331    '$print_message'(warning, expected_layout(Expected, Pos)).
 1332expected_layout(_, _).
 1333
 1334
 1335                 /*******************************
 1336                 *    SIMPLIFICATION ROUTINES   *
 1337                 *******************************/
 1338
 1339%!  simplify(+ControlIn, +Pos0, -ControlOut, -Pos) is det.
 1340%
 1341%   Simplify control structures
 1342%
 1343%   @tbd    Much more analysis
 1344%   @tbd    Turn this into a separate module
 1345
 1346simplify(Control, P, Control, P) :-
 1347    current_prolog_flag(optimise, false),
 1348    !.
 1349simplify(Control, P0, Simple, P) :-
 1350    simple(Control, P0, Simple, P),
 1351    !.
 1352simplify(Control, P, Control, P).
 1353
 1354%!  simple(+Goal, +GoalPos, -Simple, -SimplePos)
 1355%
 1356%   Simplify a control structure.  Note  that   we  do  not simplify
 1357%   (A;fail). Logically, this is the  same  as   `A`  if  `A` is not
 1358%   `_->_` or `_*->_`, but  the  choice   point  may  be  created on
 1359%   purpose.
 1360
 1361simple((X,Y), P0, Conj, P) :-
 1362    (   true(X)
 1363    ->  Conj = Y,
 1364        f2_pos(P0, _, P, _, _, _)
 1365    ;   false(X)
 1366    ->  Conj = fail,
 1367        f2_pos(P0, P1, _, _, _, _),
 1368        atomic_pos(P1, P)
 1369    ;   true(Y)
 1370    ->  Conj = X,
 1371        f2_pos(P0, P, _, _, _, _)
 1372    ).
 1373simple((I->T;E), P0, ITE, P) :-         % unification with _->_ is fine
 1374    (   true(I)                     % because nothing happens if I and T
 1375    ->  ITE = T,                    % are unbound.
 1376        f2_pos(P0, P1, _, _, _, _),
 1377        f2_pos(P1, _, P, _, _, _)
 1378    ;   false(I)
 1379    ->  ITE = E,
 1380        f2_pos(P0, _, P, _, _, _)
 1381    ).
 1382simple((X;Y), P0, Or, P) :-
 1383    false(X),
 1384    Or = Y,
 1385    f2_pos(P0, _, P, _, _, _).
 1386
 1387true(X) :-
 1388    nonvar(X),
 1389    eval_true(X).
 1390
 1391false(X) :-
 1392    nonvar(X),
 1393    eval_false(X).
 1394
 1395
 1396%!  eval_true(+Goal) is semidet.
 1397%!  eval_false(+Goal) is semidet.
 1398
 1399eval_true(true).
 1400eval_true(otherwise).
 1401
 1402eval_false(fail).
 1403eval_false(false).
 1404
 1405
 1406                 /*******************************
 1407                 *         META CALLING         *
 1408                 *******************************/
 1409
 1410:- create_prolog_flag(compile_meta_arguments, false, [type(atom)]). 1411
 1412%!  compile_meta_call(+CallIn, -CallOut, +Module, +Term) is det.
 1413%
 1414%   Compile (complex) meta-calls into a clause.
 1415
 1416compile_meta_call(CallIn, CallIn, _, Term) :-
 1417    var(Term),
 1418    !.                   % explicit call; no context
 1419compile_meta_call(CallIn, CallIn, _, _) :-
 1420    var(CallIn),
 1421    !.
 1422compile_meta_call(CallIn, CallIn, _, _) :-
 1423    (   current_prolog_flag(compile_meta_arguments, false)
 1424    ;   current_prolog_flag(xref, true)
 1425    ),
 1426    !.
 1427compile_meta_call(CallIn, CallIn, _, _) :-
 1428    strip_module(CallIn, _, Call),
 1429    (   is_aux_meta(Call)
 1430    ;   \+ control(Call),
 1431        (   '$c_current_predicate'(_, system:Call),
 1432            \+ current_prolog_flag(compile_meta_arguments, always)
 1433        ;   current_prolog_flag(compile_meta_arguments, control)
 1434        )
 1435    ),
 1436    !.
 1437compile_meta_call(M:CallIn, CallOut, _, Term) :-
 1438    !,
 1439    (   atom(M), callable(CallIn)
 1440    ->  compile_meta_call(CallIn, CallOut, M, Term)
 1441    ;   CallOut = M:CallIn
 1442    ).
 1443compile_meta_call(CallIn, CallOut, Module, Term) :-
 1444    compile_meta(CallIn, CallOut, Module, Term, Clause),
 1445    compile_auxiliary_clause(Module, Clause).
 1446
 1447compile_auxiliary_clause(Module, Clause) :-
 1448    Clause = (Head:-Body),
 1449    '$current_source_module'(SM),
 1450    (   predicate_property(SM:Head, defined)
 1451    ->  true
 1452    ;   SM == Module
 1453    ->  compile_aux_clauses([Clause])
 1454    ;   compile_aux_clauses([Head:-Module:Body])
 1455    ).
 1456
 1457control((_,_)).
 1458control((_;_)).
 1459control((_->_)).
 1460control((_*->_)).
 1461control(\+(_)).
 1462control($(_)).
 1463
 1464is_aux_meta(Term) :-
 1465    callable(Term),
 1466    functor(Term, Name, _),
 1467    sub_atom(Name, 0, _, _, '__aux_meta_call_').
 1468
 1469compile_meta(CallIn, CallOut, M, Term, (CallOut :- Body)) :-
 1470    replace_subterm(CallIn, true, Term, Term2),
 1471    term_variables(Term2, AllVars),
 1472    term_variables(CallIn, InVars),
 1473    intersection_eq(InVars, AllVars, HeadVars),
 1474    copy_term_nat(CallIn+HeadVars, NAT),
 1475    variant_sha1(NAT, Hash),
 1476    atom_concat('__aux_meta_call_', Hash, AuxName),
 1477    expand_goal(CallIn, _Pos0, Body, _Pos, M, [], (CallOut:-CallIn), []),
 1478    length(HeadVars, Arity),
 1479    (   Arity > 256                 % avoid 1024 arity limit
 1480    ->  HeadArgs = [v(HeadVars)]
 1481    ;   HeadArgs = HeadVars
 1482    ),
 1483    CallOut =.. [AuxName|HeadArgs].
 1484
 1485%!  replace_subterm(From, To, TermIn, TermOut)
 1486%
 1487%   Replace instances (==/2) of From inside TermIn by To.
 1488
 1489replace_subterm(From, To, TermIn, TermOut) :-
 1490    From == TermIn,
 1491    !,
 1492    TermOut = To.
 1493replace_subterm(From, To, TermIn, TermOut) :-
 1494    compound(TermIn),
 1495    compound_name_arity(TermIn, Name, Arity),
 1496    Arity > 0,
 1497    !,
 1498    compound_name_arity(TermOut, Name, Arity),
 1499    replace_subterm_compound(1, Arity, From, To, TermIn, TermOut).
 1500replace_subterm(_, _, Term, Term).
 1501
 1502replace_subterm_compound(I, Arity, From, To, TermIn, TermOut) :-
 1503    I =< Arity,
 1504    !,
 1505    arg(I, TermIn, A1),
 1506    arg(I, TermOut, A2),
 1507    replace_subterm(From, To, A1, A2),
 1508    I2 is I+1,
 1509    replace_subterm_compound(I2, Arity, From, To, TermIn, TermOut).
 1510replace_subterm_compound(_I, _Arity, _From, _To, _TermIn, _TermOut).
 1511
 1512
 1513%!  intersection_eq(+Small, +Big, -Shared) is det.
 1514%
 1515%   Shared are the variables in Small that   also appear in Big. The
 1516%   variables in Shared are in the same order as Small.
 1517
 1518intersection_eq([], _, []).
 1519intersection_eq([H|T0], L, List) :-
 1520    (   member_eq(H, L)
 1521    ->  List = [H|T],
 1522        intersection_eq(T0, L, T)
 1523    ;   intersection_eq(T0, L, List)
 1524    ).
 1525
 1526member_eq(E, [H|T]) :-
 1527    (   E == H
 1528    ->  true
 1529    ;   member_eq(E, T)
 1530    ).
 1531
 1532                 /*******************************
 1533                 *            RENAMING          *
 1534                 *******************************/
 1535
 1536:- multifile
 1537    prolog:rename_predicate/2. 1538
 1539rename(Var, Var) :-
 1540    var(Var),
 1541    !.
 1542rename(end_of_file, end_of_file) :- !.
 1543rename(Terms0, Terms) :-
 1544    is_list(Terms0),
 1545    !,
 1546    '$current_source_module'(M),
 1547    rename_preds(Terms0, Terms, M).
 1548rename(Term0, Term) :-
 1549    '$current_source_module'(M),
 1550    rename(Term0, Term, M),
 1551    !.
 1552rename(Term, Term).
 1553
 1554rename_preds([], [], _).
 1555rename_preds([H0|T0], [H|T], M) :-
 1556    (   rename(H0, H, M)
 1557    ->  true
 1558    ;   H = H0
 1559    ),
 1560    rename_preds(T0, T, M).
 1561
 1562rename(Var, Var, _) :-
 1563    var(Var),
 1564    !.
 1565rename(M:Term0, M:Term, M0) :-
 1566    !,
 1567    (   M = '$source_location'(_File, _Line)
 1568    ->  rename(Term0, Term, M0)
 1569    ;   rename(Term0, Term, M)
 1570    ).
 1571rename((Head0 :- Body), (Head :- Body), M) :-
 1572    !,
 1573    rename_head(Head0, Head, M).
 1574rename((:-_), _, _) :-
 1575    !,
 1576    fail.
 1577rename(Head0, Head, M) :-
 1578    rename_head(Head0, Head, M).
 1579
 1580rename_head(Var, Var, _) :-
 1581    var(Var),
 1582    !.
 1583rename_head(M:Term0, M:Term, _) :-
 1584    !,
 1585    rename_head(Term0, Term, M).
 1586rename_head(Head0, Head, M) :-
 1587    prolog:rename_predicate(M:Head0, M:Head).
 1588
 1589
 1590                 /*******************************
 1591                 *      :- IF ... :- ENDIF      *
 1592                 *******************************/
 1593
 1594:- thread_local
 1595    '$include_code'/3. 1596
 1597'$including' :-
 1598    '$include_code'(X, _, _),
 1599    !,
 1600    X == true.
 1601'$including'.
 1602
 1603cond_compilation((:- if(G)), []) :-
 1604    source_location(File, Line),
 1605    (   '$including'
 1606    ->  (   catch('$eval_if'(G), E, (print_message(error, E), fail))
 1607        ->  asserta('$include_code'(true, File, Line))
 1608        ;   asserta('$include_code'(false, File, Line))
 1609        )
 1610    ;   asserta('$include_code'(else_false, File, Line))
 1611    ).
 1612cond_compilation((:- elif(G)), []) :-
 1613    source_location(File, Line),
 1614    (   clause('$include_code'(Old, OF, _), _, Ref)
 1615    ->  same_source(File, OF, elif),
 1616        erase(Ref),
 1617        (   Old == true
 1618        ->  asserta('$include_code'(else_false, File, Line))
 1619        ;   Old == false,
 1620            catch('$eval_if'(G), E, (print_message(error, E), fail))
 1621        ->  asserta('$include_code'(true, File, Line))
 1622        ;   asserta('$include_code'(Old, File, Line))
 1623        )
 1624    ;   throw(error(conditional_compilation_error(no_if, elif), _))
 1625    ).
 1626cond_compilation((:- else), []) :-
 1627    source_location(File, Line),
 1628    (   clause('$include_code'(X, OF, _), _, Ref)
 1629    ->  same_source(File, OF, else),
 1630        erase(Ref),
 1631        (   X == true
 1632        ->  X2 = false
 1633        ;   X == false
 1634        ->  X2 = true
 1635        ;   X2 = X
 1636        ),
 1637        asserta('$include_code'(X2, File, Line))
 1638    ;   throw(error(conditional_compilation_error(no_if, else), _))
 1639    ).
 1640cond_compilation(end_of_file, end_of_file) :-   % TBD: Check completeness
 1641    !,
 1642    source_location(File, _),
 1643    (   clause('$include_code'(_, OF, OL), _)
 1644    ->  (   File == OF
 1645        ->  throw(error(conditional_compilation_error(
 1646                            unterminated,OF:OL), _))
 1647        ;   true
 1648        )
 1649    ;   true
 1650    ).
 1651cond_compilation((:- endif), []) :-
 1652    !,
 1653    source_location(File, _),
 1654    (   (   clause('$include_code'(_, OF, _), _, Ref)
 1655        ->  same_source(File, OF, endif),
 1656            erase(Ref)
 1657        )
 1658    ->  true
 1659    ;   throw(error(conditional_compilation_error(no_if, endif), _))
 1660    ).
 1661cond_compilation(_, []) :-
 1662    \+ '$including'.
 1663
 1664same_source(File, File, _) :- !.
 1665same_source(_,    _,    Op) :-
 1666    throw(error(conditional_compilation_error(no_if, Op), _)).
 1667
 1668
 1669'$eval_if'(G) :-
 1670    expand_goal(G, G2),
 1671    '$current_source_module'(Module),
 1672    Module:G2