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