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    E = error(Formal,_),
  909    catch(prolog:sandbox_allowed_expansion(M:Goal), E, true),
  910    (   var(Formal)
  911    ->  fail
  912    ;   !,
  913        print_message(error, E),
  914        fail
  915    ).
  916allowed_expansion(_).
  917
  918
  919                 /*******************************
  920                 *      FUNCTIONAL NOTATION     *
  921                 *******************************/
  922
  923%!  expand_functions(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
  924%
  925%   Expand functional notation and arithmetic functions.
  926%
  927%   @arg MList is the list of modules defining goal_expansion/2 in
  928%   the expansion context.
  929
  930expand_functions(G0, P0, G, P, M, MList, Term) :-
  931    expand_functional_notation(G0, P0, G1, P1, M, MList, Term),
  932    (   expand_arithmetic(G1, P1, G, P, Term)
  933    ->  true
  934    ;   G = G1,
  935        P = P1
  936    ).
  937
  938%!  expand_functional_notation(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
  939%
  940%   @tbd: position logic
  941%   @tbd: make functions module-local
  942
  943expand_functional_notation(G0, P0, G, P, M, _MList, _Term) :-
  944    contains_functions(G0),
  945    replace_functions(G0, P0, Eval, EvalPos, G1, G1Pos, M),
  946    Eval \== true,
  947    !,
  948    wrap_var(G1, G1Pos, G2, G2Pos),
  949    conj(Eval, EvalPos, G2, G2Pos, G, P).
  950expand_functional_notation(G, P, G, P, _, _, _).
  951
  952wrap_var(G, P, G, P) :-
  953    nonvar(G),
  954    !.
  955wrap_var(G, P0, call(G), P) :-
  956    (   nonvar(P0)
  957    ->  P = term_position(F,T,F,T,[P0]),
  958        atomic_pos(P0, F-T)
  959    ;   true
  960    ).
  961
  962%!  contains_functions(@Term) is semidet.
  963%
  964%   True when Term contains a function reference.
  965
  966contains_functions(Term) :-
  967    \+ \+ ( '$factorize_term'(Term, Skeleton, Assignments),
  968            (   contains_functions2(Skeleton)
  969            ;   contains_functions2(Assignments)
  970            )).
  971
  972contains_functions2(Term) :-
  973    compound(Term),
  974    (   function(Term, _)
  975    ->  true
  976    ;   arg(_, Term, Arg),
  977        contains_functions2(Arg)
  978    ->  true
  979    ).
  980
  981%!  replace_functions(+GoalIn, +PosIn,
  982%!                    -Eval, -EvalPos,
  983%!                    -GoalOut, -PosOut,
  984%!                    +ContextTerm) is det.
  985%
  986%   @tbd    Proper propagation of list, dict and brace term positions.
  987
  988:- public
  989    replace_functions/4.            % used in dicts.pl
  990
  991replace_functions(GoalIn, Eval, GoalOut, Context) :-
  992    replace_functions(GoalIn, _, Eval, _, GoalOut, _, Context).
  993
  994replace_functions(Var, Pos, true, _, Var, Pos, _Ctx) :-
  995    var(Var),
  996    !.
  997replace_functions(F, FPos, Eval, EvalPos, Var, VarPos, Ctx) :-
  998    function(F, Ctx),
  999    !,
 1000    compound_name_arity(F, Name, Arity),
 1001    PredArity is Arity+1,
 1002    compound_name_arity(G, Name, PredArity),
 1003    arg(PredArity, G, Var),
 1004    extend_1_pos(FPos, FArgPos, GPos, GArgPos, VarPos),
 1005    map_functions(0, Arity, F, FArgPos, G, GArgPos, Eval0, EP0, Ctx),
 1006    conj(Eval0, EP0, G, GPos, Eval, EvalPos).
 1007replace_functions(Term0, Term0Pos, Eval, EvalPos, Term, TermPos, Ctx) :-
 1008    compound(Term0),
 1009    !,
 1010    compound_name_arity(Term0, Name, Arity),
 1011    compound_name_arity(Term, Name, Arity),
 1012    f_pos(Term0Pos, Args0Pos, TermPos, ArgsPos),
 1013    map_functions(0, Arity,
 1014                  Term0, Args0Pos, Term, ArgsPos, Eval, EvalPos, Ctx).
 1015replace_functions(Term, Pos, true, _, Term, Pos, _).
 1016
 1017
 1018%!  map_functions(+Arg, +Arity,
 1019%!                +TermIn, +ArgInPos, -Term, -ArgPos, -Eval, -EvalPos,
 1020%!                +Context)
 1021
 1022map_functions(Arity, Arity, _, LPos0, _, LPos, true, _, _) :-
 1023    !,
 1024    pos_nil(LPos0, LPos).
 1025map_functions(I0, Arity, Term0, LPos0, Term, LPos, Eval, EP, Ctx) :-
 1026    pos_list(LPos0, AP0, APT0, LPos, AP, APT),
 1027    I is I0+1,
 1028    arg(I, Term0, Arg0),
 1029    arg(I, Term, Arg),
 1030    replace_functions(Arg0, AP0, Eval0, EP0, Arg, AP, Ctx),
 1031    map_functions(I, Arity, Term0, APT0, Term, APT, Eval1, EP1, Ctx),
 1032    conj(Eval0, EP0, Eval1, EP1, Eval, EP).
 1033
 1034conj(true, X, X) :- !.
 1035conj(X, true, X) :- !.
 1036conj(X, Y, (X,Y)).
 1037
 1038conj(true, _, X, P, X, P) :- !.
 1039conj(X, P, true, _, X, P) :- !.
 1040conj(X, PX, Y, PY, (X,Y), _) :-
 1041    var(PX), var(PY),
 1042    !.
 1043conj(X, PX, Y, PY, (X,Y), P) :-
 1044    P = term_position(F,T,FF,FT,[PX,PY]),
 1045    atomic_pos(PX, F-FF),
 1046    atomic_pos(PY, FT-T).
 1047
 1048%!  function(?Term, +Context)
 1049%
 1050%   True if function expansion needs to be applied for the given
 1051%   term.
 1052
 1053function(.(_,_), _) :- \+ functor([_|_], ., _).
 1054
 1055
 1056                 /*******************************
 1057                 *          ARITHMETIC          *
 1058                 *******************************/
 1059
 1060%!  expand_arithmetic(+G0, +P0, -G, -P, +Term) is semidet.
 1061%
 1062%   Expand arithmetic expressions  in  is/2,   (>)/2,  etc.  This is
 1063%   currently a dummy.  The  idea  is   to  call  rules  similar  to
 1064%   goal_expansion/2,4  that  allow  for   rewriting  an  arithmetic
 1065%   expression. The system rules will perform evaluation of constant
 1066%   expressions.
 1067
 1068expand_arithmetic(_G0, _P0, _G, _P, _Term) :- fail.
 1069
 1070
 1071                 /*******************************
 1072                 *        POSITION LOGIC        *
 1073                 *******************************/
 1074
 1075%!  f2_pos(?TermPos0, ?PosArg10, ?PosArg20,
 1076%!         ?TermPos,  ?PosArg1,  ?PosArg2) is det.
 1077%!  f1_pos(?TermPos0, ?PosArg10, ?TermPos,  ?PosArg1) is det.
 1078%!  f_pos(?TermPos0, ?PosArgs0, ?TermPos,  ?PosArgs) is det.
 1079%!  atomic_pos(?TermPos0, -AtomicPos) is det.
 1080%
 1081%   Position progapation routines.
 1082
 1083f2_pos(Var, _, _, _, _, _) :-
 1084    var(Var),
 1085    !.
 1086f2_pos(term_position(F,T,FF,FT,[A10,A20]), A10, A20,
 1087       term_position(F,T,FF,FT,[A1, A2 ]), A1,  A2) :- !.
 1088f2_pos(parentheses_term_position(O,C,Pos0), A10, A20,
 1089       parentheses_term_position(O,C,Pos),  A1,  A2) :-
 1090    !,
 1091    f2_pos(Pos0, A10, A20, Pos, A1, A2).
 1092f2_pos(Pos, _, _, _, _, _) :-
 1093    expected_layout(f2, Pos).
 1094
 1095f1_pos(Var, _, _, _) :-
 1096    var(Var),
 1097    !.
 1098f1_pos(term_position(F,T,FF,FT,[A10]), A10,
 1099       term_position(F,T,FF,FT,[A1 ]),  A1) :- !.
 1100f1_pos(parentheses_term_position(O,C,Pos0), A10,
 1101       parentheses_term_position(O,C,Pos),  A1) :-
 1102    !,
 1103    f1_pos(Pos0, A10, Pos, A1).
 1104f1_pos(Pos, _, _, _) :-
 1105    expected_layout(f1, Pos).
 1106
 1107f_pos(Var, _, _, _) :-
 1108    var(Var),
 1109    !.
 1110f_pos(term_position(F,T,FF,FT,ArgPos0), ArgPos0,
 1111      term_position(F,T,FF,FT,ArgPos),  ArgPos) :- !.
 1112f_pos(parentheses_term_position(O,C,Pos0), A10,
 1113      parentheses_term_position(O,C,Pos),  A1) :-
 1114    !,
 1115    f_pos(Pos0, A10, Pos, A1).
 1116f_pos(Pos, _, _, _) :-
 1117    expected_layout(compound, Pos).
 1118
 1119atomic_pos(Pos, _) :-
 1120    var(Pos),
 1121    !.
 1122atomic_pos(Pos, F-T) :-
 1123    arg(1, Pos, F),
 1124    arg(2, Pos, T).
 1125
 1126%!  pos_nil(+Nil, -Nil) is det.
 1127%!  pos_list(+List0, -H0, -T0, -List, -H, -T) is det.
 1128%
 1129%   Position propagation for lists.
 1130
 1131pos_nil(Var, _) :- var(Var), !.
 1132pos_nil([], []) :- !.
 1133pos_nil(Pos, _) :-
 1134    expected_layout(nil, Pos).
 1135
 1136pos_list(Var, _, _, _, _, _) :- var(Var), !.
 1137pos_list([H0|T0], H0, T0, [H|T], H, T) :- !.
 1138pos_list(Pos, _, _, _, _, _) :-
 1139    expected_layout(list, Pos).
 1140
 1141%!  extend_1_pos(+FunctionPos, -FArgPos, -EvalPos, -EArgPos, -VarPos)
 1142%
 1143%   Deal with extending a function to include the return value.
 1144
 1145extend_1_pos(Pos, _, _, _, _) :-
 1146    var(Pos),
 1147    !.
 1148extend_1_pos(term_position(F,T,FF,FT,FArgPos), FArgPos,
 1149             term_position(F,T,FF,FT,GArgPos), GArgPos0,
 1150             FT-FT1) :-
 1151    integer(FT),
 1152    !,
 1153    FT1 is FT+1,
 1154    '$same_length'(FArgPos, GArgPos0),
 1155    '$append'(GArgPos0, [FT-FT1], GArgPos).
 1156extend_1_pos(F-T, [],
 1157             term_position(F,T,F,T,[T-T1]), [],
 1158             T-T1) :-
 1159    integer(T),
 1160    !,
 1161    T1 is T+1.
 1162extend_1_pos(Pos, _, _, _, _) :-
 1163    expected_layout(callable, Pos).
 1164
 1165'$same_length'(List, List) :-
 1166    var(List),
 1167    !.
 1168'$same_length'([], []).
 1169'$same_length'([_|T0], [_|T]) :-
 1170    '$same_length'(T0, T).
 1171
 1172
 1173%!  expected_layout(+Expected, +Found)
 1174%
 1175%   Print a message  if  the  layout   term  does  not  satisfy  our
 1176%   expectations.  This  means  that   the  transformation  requires
 1177%   support from term_expansion/4 and/or goal_expansion/4 to achieve
 1178%   proper source location information.
 1179
 1180:- create_prolog_flag(debug_term_position, false, []). 1181
 1182expected_layout(Expected, Pos) :-
 1183    current_prolog_flag(debug_term_position, true),
 1184    !,
 1185    '$print_message'(warning, expected_layout(Expected, Pos)).
 1186expected_layout(_, _).
 1187
 1188
 1189                 /*******************************
 1190                 *    SIMPLIFICATION ROUTINES   *
 1191                 *******************************/
 1192
 1193%!  simplify(+ControlIn, +Pos0, -ControlOut, -Pos) is det.
 1194%
 1195%   Simplify control structures
 1196%
 1197%   @tbd    Much more analysis
 1198%   @tbd    Turn this into a separate module
 1199
 1200simplify(Control, P, Control, P) :-
 1201    current_prolog_flag(optimise, false),
 1202    !.
 1203simplify(Control, P0, Simple, P) :-
 1204    simple(Control, P0, Simple, P),
 1205    !.
 1206simplify(Control, P, Control, P).
 1207
 1208%!  simple(+Goal, +GoalPos, -Simple, -SimplePos)
 1209%
 1210%   Simplify a control structure.  Note  that   we  do  not simplify
 1211%   (A;fail). Logically, this is the  same  as   `A`  if  `A` is not
 1212%   `_->_` or `_*->_`, but  the  choice   point  may  be  created on
 1213%   purpose.
 1214
 1215simple((X,Y), P0, Conj, P) :-
 1216    (   true(X)
 1217    ->  Conj = Y,
 1218        f2_pos(P0, _, P, _, _, _)
 1219    ;   false(X)
 1220    ->  Conj = fail,
 1221        f2_pos(P0, P1, _, _, _, _),
 1222        atomic_pos(P1, P)
 1223    ;   true(Y)
 1224    ->  Conj = X,
 1225        f2_pos(P0, P, _, _, _, _)
 1226    ).
 1227simple((I->T;E), P0, ITE, P) :-         % unification with _->_ is fine
 1228    (   true(I)                     % because nothing happens if I and T
 1229    ->  ITE = T,                    % are unbound.
 1230        f2_pos(P0, P1, _, _, _, _),
 1231        f2_pos(P1, _, P, _, _, _)
 1232    ;   false(I)
 1233    ->  ITE = E,
 1234        f2_pos(P0, _, P, _, _, _)
 1235    ).
 1236simple((X;Y), P0, Or, P) :-
 1237    false(X),
 1238    Or = Y,
 1239    f2_pos(P0, _, P, _, _, _).
 1240
 1241true(X) :-
 1242    nonvar(X),
 1243    eval_true(X).
 1244
 1245false(X) :-
 1246    nonvar(X),
 1247    eval_false(X).
 1248
 1249
 1250%!  eval_true(+Goal) is semidet.
 1251%!  eval_false(+Goal) is semidet.
 1252
 1253eval_true(true).
 1254eval_true(otherwise).
 1255
 1256eval_false(fail).
 1257eval_false(false).
 1258
 1259
 1260                 /*******************************
 1261                 *         META CALLING         *
 1262                 *******************************/
 1263
 1264:- create_prolog_flag(compile_meta_arguments, false, [type(atom)]). 1265
 1266%!  compile_meta_call(+CallIn, -CallOut, +Module, +Term) is det.
 1267%
 1268%   Compile (complex) meta-calls into a clause.
 1269
 1270compile_meta_call(CallIn, CallIn, _, Term) :-
 1271    var(Term),
 1272    !.                   % explicit call; no context
 1273compile_meta_call(CallIn, CallIn, _, _) :-
 1274    var(CallIn),
 1275    !.
 1276compile_meta_call(CallIn, CallIn, _, _) :-
 1277    (   current_prolog_flag(compile_meta_arguments, false)
 1278    ;   current_prolog_flag(xref, true)
 1279    ),
 1280    !.
 1281compile_meta_call(CallIn, CallIn, _, _) :-
 1282    strip_module(CallIn, _, Call),
 1283    (   is_aux_meta(Call)
 1284    ;   \+ control(Call),
 1285        (   '$c_current_predicate'(_, system:Call),
 1286            \+ current_prolog_flag(compile_meta_arguments, always)
 1287        ;   current_prolog_flag(compile_meta_arguments, control)
 1288        )
 1289    ),
 1290    !.
 1291compile_meta_call(M:CallIn, CallOut, _, Term) :-
 1292    !,
 1293    (   atom(M), callable(CallIn)
 1294    ->  compile_meta_call(CallIn, CallOut, M, Term)
 1295    ;   CallOut = M:CallIn
 1296    ).
 1297compile_meta_call(CallIn, CallOut, Module, Term) :-
 1298    compile_meta(CallIn, CallOut, Module, Term, Clause),
 1299    compile_auxiliary_clause(Module, Clause).
 1300
 1301compile_auxiliary_clause(Module, Clause) :-
 1302    Clause = (Head:-Body),
 1303    '$current_source_module'(SM),
 1304    (   predicate_property(SM:Head, defined)
 1305    ->  true
 1306    ;   SM == Module
 1307    ->  compile_aux_clauses([Clause])
 1308    ;   compile_aux_clauses([Head:-Module:Body])
 1309    ).
 1310
 1311control((_,_)).
 1312control((_;_)).
 1313control((_->_)).
 1314control((_*->_)).
 1315control(\+(_)).
 1316
 1317is_aux_meta(Term) :-
 1318    callable(Term),
 1319    functor(Term, Name, _),
 1320    sub_atom(Name, 0, _, _, '__aux_meta_call_').
 1321
 1322compile_meta(CallIn, CallOut, M, Term, (CallOut :- Body)) :-
 1323    term_variables(Term, AllVars),
 1324    term_variables(CallIn, InVars),
 1325    intersection_eq(InVars, AllVars, HeadVars),
 1326    variant_sha1(CallIn+HeadVars, Hash),
 1327    atom_concat('__aux_meta_call_', Hash, AuxName),
 1328    expand_goal(CallIn, _Pos0, Body, _Pos, M, [], (CallOut:-CallIn), []),
 1329    length(HeadVars, Arity),
 1330    (   Arity > 256                 % avoid 1024 arity limit
 1331    ->  HeadArgs = [v(HeadVars)]
 1332    ;   HeadArgs = HeadVars
 1333    ),
 1334    CallOut =.. [AuxName|HeadArgs].
 1335
 1336%!  intersection_eq(+Small, +Big, -Shared) is det.
 1337%
 1338%   Shared are the variables in Small that   also appear in Big. The
 1339%   variables in Shared are in the same order as Small.
 1340
 1341intersection_eq([], _, []).
 1342intersection_eq([H|T0], L, List) :-
 1343    (   member_eq(H, L)
 1344    ->  List = [H|T],
 1345        intersection_eq(T0, L, T)
 1346    ;   intersection_eq(T0, L, List)
 1347    ).
 1348
 1349member_eq(E, [H|T]) :-
 1350    (   E == H
 1351    ->  true
 1352    ;   member_eq(E, T)
 1353    ).
 1354
 1355                 /*******************************
 1356                 *            RENAMING          *
 1357                 *******************************/
 1358
 1359:- multifile
 1360    prolog:rename_predicate/2. 1361
 1362rename(Var, Var) :-
 1363    var(Var),
 1364    !.
 1365rename(end_of_file, end_of_file) :- !.
 1366rename(Terms0, Terms) :-
 1367    is_list(Terms0),
 1368    !,
 1369    '$current_source_module'(M),
 1370    rename_preds(Terms0, Terms, M).
 1371rename(Term0, Term) :-
 1372    '$current_source_module'(M),
 1373    rename(Term0, Term, M),
 1374    !.
 1375rename(Term, Term).
 1376
 1377rename_preds([], [], _).
 1378rename_preds([H0|T0], [H|T], M) :-
 1379    (   rename(H0, H, M)
 1380    ->  true
 1381    ;   H = H0
 1382    ),
 1383    rename_preds(T0, T, M).
 1384
 1385rename(Var, Var, _) :-
 1386    var(Var),
 1387    !.
 1388rename(M:Term0, M:Term, M0) :-
 1389    !,
 1390    (   M = '$source_location'(_File, _Line)
 1391    ->  rename(Term0, Term, M0)
 1392    ;   rename(Term0, Term, M)
 1393    ).
 1394rename((Head0 :- Body), (Head :- Body), M) :-
 1395    !,
 1396    rename_head(Head0, Head, M).
 1397rename((:-_), _, _) :-
 1398    !,
 1399    fail.
 1400rename(Head0, Head, M) :-
 1401    rename_head(Head0, Head, M).
 1402
 1403rename_head(Var, Var, _) :-
 1404    var(Var),
 1405    !.
 1406rename_head(M:Term0, M:Term, _) :-
 1407    !,
 1408    rename_head(Term0, Term, M).
 1409rename_head(Head0, Head, M) :-
 1410    prolog:rename_predicate(M:Head0, M:Head).
 1411
 1412
 1413                 /*******************************
 1414                 *      :- IF ... :- ENDIF      *
 1415                 *******************************/
 1416
 1417:- thread_local
 1418    '$include_code'/3. 1419
 1420'$including' :-
 1421    '$include_code'(X, _, _),
 1422    !,
 1423    X == true.
 1424'$including'.
 1425
 1426cond_compilation((:- if(G)), []) :-
 1427    source_location(File, Line),
 1428    (   '$including'
 1429    ->  (   catch('$eval_if'(G), E, (print_message(error, E), fail))
 1430        ->  asserta('$include_code'(true, File, Line))
 1431        ;   asserta('$include_code'(false, File, Line))
 1432        )
 1433    ;   asserta('$include_code'(else_false, File, Line))
 1434    ).
 1435cond_compilation((:- elif(G)), []) :-
 1436    source_location(File, Line),
 1437    (   clause('$include_code'(Old, OF, _), _, Ref)
 1438    ->  same_source(File, OF, elif),
 1439        erase(Ref),
 1440        (   Old == true
 1441        ->  asserta('$include_code'(else_false, File, Line))
 1442        ;   Old == false,
 1443            catch('$eval_if'(G), E, (print_message(error, E), fail))
 1444        ->  asserta('$include_code'(true, File, Line))
 1445        ;   asserta('$include_code'(Old, File, Line))
 1446        )
 1447    ;   throw(error(conditional_compilation_error(no_if, elif), _))
 1448    ).
 1449cond_compilation((:- else), []) :-
 1450    source_location(File, Line),
 1451    (   clause('$include_code'(X, OF, _), _, Ref)
 1452    ->  same_source(File, OF, else),
 1453        erase(Ref),
 1454        (   X == true
 1455        ->  X2 = false
 1456        ;   X == false
 1457        ->  X2 = true
 1458        ;   X2 = X
 1459        ),
 1460        asserta('$include_code'(X2, File, Line))
 1461    ;   throw(error(conditional_compilation_error(no_if, else), _))
 1462    ).
 1463cond_compilation(end_of_file, end_of_file) :-   % TBD: Check completeness
 1464    !,
 1465    source_location(File, _),
 1466    (   clause('$include_code'(_, OF, OL), _)
 1467    ->  (   File == OF
 1468        ->  throw(error(conditional_compilation_error(
 1469                            unterminated,OF:OL), _))
 1470        ;   true
 1471        )
 1472    ;   true
 1473    ).
 1474cond_compilation((:- endif), []) :-
 1475    !,
 1476    source_location(File, _),
 1477    (   (   clause('$include_code'(_, OF, _), _, Ref)
 1478        ->  same_source(File, OF, endif),
 1479            erase(Ref)
 1480        )
 1481    ->  true
 1482    ;   throw(error(conditional_compilation_error(no_if, endif), _))
 1483    ).
 1484cond_compilation(_, []) :-
 1485    \+ '$including'.
 1486
 1487same_source(File, File, _) :- !.
 1488same_source(_,    _,    Op) :-
 1489    throw(error(conditional_compilation_error(no_if, Op), _)).
 1490
 1491
 1492'$eval_if'(G) :-
 1493    expand_goal(G, G2),
 1494    '$current_source_module'(Module),
 1495    Module:G2