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