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