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, G1P, ArgPos),
  778    expand_meta(1, Arity, Spec,
  779                G0, ArgPos0, Eval, EvalPos,
  780                G1,  ArgPos,
  781                M, MList, Term, Done),
  782    conj(Eval, EvalPos, G1, G1P, G, P).
  783
  784expand_meta(I, Arity, Spec, G0, ArgPos0, Eval, EvalPos, G, [P|PT],
  785            M, MList, Term, Done) :-
  786    I =< Arity,
  787    !,
  788    arg_pos(ArgPos0, P0, PT0),
  789    arg(I, Spec, Meta),
  790    arg(I, G0, A0),
  791    arg(I, G, A),
  792    expand_meta_arg(Meta, A0, P0, EvalA, EPA, A, P, M, MList, Term, Done),
  793    I2 is I + 1,
  794    expand_meta(I2, Arity, Spec, G0, PT0, EvalB,EPB, G, PT, M, MList, Term, Done),
  795    conj(EvalA, EPA, EvalB, EPB, Eval, EvalPos).
  796expand_meta(_, _, _, _, _, true, _, _, [], _, _, _, _).
  797
  798arg_pos(List, _, _) :- var(List), !.    % no position info
  799arg_pos([H|T], H, T) :- !.              % argument list
  800arg_pos([], _, []).                     % new has more
  801
  802mapex([], _).
  803mapex([E|L], E) :- mapex(L, E).
  804
  805%!  extended_pos(+Pos0, +N, -Pos) is det.
  806%!  extended_pos(-Pos0, +N, +Pos) is det.
  807%
  808%   Pos is the result of adding N extra positions to Pos0.
  809
  810extended_pos(Var, _, Var) :-
  811    var(Var),
  812    !.
  813extended_pos(parentheses_term_position(O,C,Pos0),
  814             N,
  815             parentheses_term_position(O,C,Pos)) :-
  816    !,
  817    extended_pos(Pos0, N, Pos).
  818extended_pos(term_position(F,T,FF,FT,Args),
  819             _,
  820             term_position(F,T,FF,FT,Args)) :-
  821    var(Args),
  822    !.
  823extended_pos(term_position(F,T,FF,FT,Args0),
  824             N,
  825             term_position(F,T,FF,FT,Args)) :-
  826    length(Ex, N),
  827    mapex(Ex, T-T),
  828    '$append'(Args0, Ex, Args),
  829    !.
  830extended_pos(F-T,
  831             N,
  832             term_position(F,T,F,T,Ex)) :-
  833    !,
  834    length(Ex, N),
  835    mapex(Ex, T-T).
  836extended_pos(Pos, N, Pos) :-
  837    '$print_message'(warning, extended_pos(Pos, N)).
  838
  839%!  expand_meta_arg(+MetaSpec, +Arg0, +ArgPos0, -Eval, -EvalPos,
  840%!                  -Arg, -ArgPos, +ModuleList, +Term, +Done) is det.
  841%
  842%   Goal expansion for a meta-argument.
  843%
  844%   @arg    Eval is always `true`.  Future versions should allow for
  845%           functions on such positions.  This requires proper
  846%           position management for function expansion.
  847
  848expand_meta_arg(0, A0, PA0, true, _, A, PA, M, MList, Term, Done) :-
  849    !,
  850    expand_goal(A0, PA0, A1, PA, M, MList, Term, Done),
  851    compile_meta_call(A1, A, M, Term).
  852expand_meta_arg(N, A0, P0, true, _, A, P, M, MList, Term, Done) :-
  853    integer(N), callable(A0),
  854    replace_functions(A0, true, _, M),
  855    !,
  856    length(Ex, N),
  857    mark_vars_non_fresh(Ex),
  858    extend_arg_pos(A0, P0, Ex, A1, PA1),
  859    expand_goal(A1, PA1, A2, PA2, M, MList, Term, Done),
  860    compile_meta_call(A2, A3, M, Term),
  861    term_variables(A0, VL),
  862    remove_arg_pos(A3, PA2, M, VL, Ex, A, P).
  863expand_meta_arg(^, A0, PA0, true, _, A, PA, M, MList, Term, Done) :-
  864    !,
  865    expand_setof_goal(A0, PA0, A, PA, M, MList, Term, Done).
  866expand_meta_arg(S, A0, PA0, Eval, EPA, A, PA, M, _MList, _Term, _Done) :-
  867    replace_functions(A0, PA0, Eval, EPA, A, PA, M),
  868    (   Eval == true
  869    ->  true
  870    ;   same_functor(A0, A)
  871    ->  true
  872    ;   meta_arg(S)
  873    ->  throw(error(context_error(function, meta_arg(S)), _))
  874    ;   true
  875    ).
  876
  877same_functor(T1, T2) :-
  878    compound(T1),
  879    !,
  880    compound(T2),
  881    compound_name_arity(T1, N, A),
  882    compound_name_arity(T2, N, A).
  883same_functor(T1, T2) :-
  884    atom(T1),
  885    T1 == T2.
  886
  887variant_sha1_nat(Term, Hash) :-
  888    copy_term_nat(Term, TNat),
  889    variant_sha1(TNat, Hash).
  890
  891wrap_meta_arguments(A0, M, VL, Ex, A) :-
  892    '$append'(VL, Ex, AV),
  893    variant_sha1_nat(A0+AV, Hash),
  894    atom_concat('__aux_wrapper_', Hash, AuxName),
  895    H =.. [AuxName|AV],
  896    compile_auxiliary_clause(M, (H :- A0)),
  897    A =.. [AuxName|VL].
  898
  899%!  extend_arg_pos(+A0, +P0, +Ex, -A, -P) is det.
  900%
  901%   Adds extra arguments Ex to A0, and  extra subterm positions to P
  902%   for such arguments.
  903
  904extend_arg_pos(A, P, _, A, P) :-
  905    var(A),
  906    !.
  907extend_arg_pos(M:A0, P0, Ex, M:A, P) :-
  908    !,
  909    f2_pos(P0, PM, PA0, P, PM, PA),
  910    extend_arg_pos(A0, PA0, Ex, A, PA).
  911extend_arg_pos(A0, P0, Ex, A, P) :-
  912    callable(A0),
  913    !,
  914    extend_term(A0, Ex, A),
  915    length(Ex, N),
  916    extended_pos(P0, N, P).
  917extend_arg_pos(A, P, _, A, P).
  918
  919extend_term(Atom, Extra, Term) :-
  920    atom(Atom),
  921    !,
  922    Term =.. [Atom|Extra].
  923extend_term(Term0, Extra, Term) :-
  924    compound_name_arguments(Term0, Name, Args0),
  925    '$append'(Args0, Extra, Args),
  926    compound_name_arguments(Term, Name, Args).
  927
  928%!  remove_arg_pos(+A0, +P0, +M, +Ex, +VL, -A, -P) is det.
  929%
  930%   Removes the Ex arguments  from  A0   and  the  respective  extra
  931%   positions from P0. Note that  if  they   are  not  at the end, a
  932%   wrapper with the elements of VL as arguments is generated to put
  933%   them in order.
  934%
  935%   @see wrap_meta_arguments/5
  936
  937remove_arg_pos(A, P, _, _, _, A, P) :-
  938    var(A),
  939    !.
  940remove_arg_pos(M:A0, P0, _, VL, Ex, M:A, P) :-
  941    !,
  942    f2_pos(P, PM, PA0, P0, PM, PA),
  943    remove_arg_pos(A0, PA, M, VL, Ex, A, PA0).
  944remove_arg_pos(A0, P0, M, VL, Ex0, A, P) :-
  945    callable(A0),
  946    !,
  947    length(Ex0, N),
  948    (   A0 =.. [F|Args],
  949        length(Ex, N),
  950        '$append'(Args0, Ex, Args),
  951        Ex==Ex0
  952    ->  extended_pos(P, N, P0),
  953        A =.. [F|Args0]
  954    ;   M \== [],
  955        wrap_meta_arguments(A0, M, VL, Ex0, A),
  956        wrap_meta_pos(P0, P)
  957    ).
  958remove_arg_pos(A, P, _, _, _, A, P).
  959
  960wrap_meta_pos(P0, P) :-
  961    (   nonvar(P0)
  962    ->  P = term_position(F,T,_,_,_),
  963        atomic_pos(P0, F-T)
  964    ;   true
  965    ).
  966
  967has_meta_arg(Head) :-
  968    arg(_, Head, Arg),
  969    direct_call_meta_arg(Arg),
  970    !.
  971
  972direct_call_meta_arg(I) :- integer(I).
  973direct_call_meta_arg(^).
  974
  975meta_arg(:).
  976meta_arg(//).
  977meta_arg(I) :- integer(I).
  978
  979expand_setof_goal(Var, Pos, Var, Pos, _, _, _, _) :-
  980    var(Var),
  981    !.
  982expand_setof_goal(V^G, P0, V^EG, P, M, MList, Term, Done) :-
  983    !,
  984    f2_pos(P0, PA0, PB, P, PA, PB),
  985    expand_setof_goal(G, PA0, EG, PA, M, MList, Term, Done).
  986expand_setof_goal(M0:G, P0, M0:EG, P, M, MList, Term, Done) :-
  987    !,
  988    f2_pos(P0, PA0, PB, P, PA, PB),
  989    expand_setof_goal(G, PA0, EG, PA, M, MList, Term, Done).
  990expand_setof_goal(G, P0, EG, P, M, MList, Term, Done) :-
  991    !,
  992    expand_goal(G, P0, EG0, P, M, MList, Term, Done),
  993    compile_meta_call(EG0, EG1, M, Term),
  994    (   extend_existential(G, EG1, V)
  995    ->  EG = V^EG1
  996    ;   EG = EG1
  997    ).
  998
  999%!  extend_existential(+G0, +G1, -V) is semidet.
 1000%
 1001%   Extend  the  variable  template  to    compensate  for  intermediate
 1002%   variables introduced during goal expansion   (notably for functional
 1003%   notation).
 1004
 1005extend_existential(G0, G1, V) :-
 1006    term_variables(G0, GV0), sort(GV0, SV0),
 1007    term_variables(G1, GV1), sort(GV1, SV1),
 1008    ord_subtract(SV1, SV0, New),
 1009    New \== [],
 1010    V =.. [v|New].
 1011
 1012%!  call_goal_expansion(+ExpandModules,
 1013%!                      +Goal0, ?Pos0, -Goal, -Pos, +Done) is semidet.
 1014%
 1015%   Succeeds  if  the   context   has    a   module   that   defines
 1016%   goal_expansion/2 this rule succeeds and  Goal   is  not equal to
 1017%   Goal0. Note that the translator is   called  recursively until a
 1018%   fixed-point is reached.
 1019
 1020call_goal_expansion(MList, G0, P0, G, P) :-
 1021    current_prolog_flag(sandboxed_load, false),
 1022    !,
 1023    (   '$member'(M-Preds, MList),
 1024        '$member'(Pred, Preds),
 1025        (   Pred == goal_expansion/4
 1026        ->  M:goal_expansion(G0, P0, G, P)
 1027        ;   M:goal_expansion(G0, G),
 1028            P = P0
 1029        ),
 1030        G0 \== G
 1031    ->  true
 1032    ).
 1033call_goal_expansion(MList, G0, P0, G, P) :-
 1034    (   '$member'(M-Preds, MList),
 1035        '$member'(Pred, Preds),
 1036        (   Pred == goal_expansion/4
 1037        ->  Expand = M:goal_expansion(G0, P0, G, P)
 1038        ;   Expand = M:goal_expansion(G0, G)
 1039        ),
 1040        allowed_expansion(Expand),
 1041        call(Expand),
 1042        G0 \== G
 1043    ->  true
 1044    ).
 1045
 1046%!  allowed_expansion(:Goal) is semidet.
 1047%
 1048%   Calls prolog:sandbox_allowed_expansion(:Goal) prior   to calling
 1049%   Goal for the purpose of term or   goal  expansion. This hook can
 1050%   prevent the expansion to take place by raising an exception.
 1051%
 1052%   @throws exceptions from prolog:sandbox_allowed_expansion/1.
 1053
 1054:- multifile
 1055    prolog:sandbox_allowed_expansion/1. 1056
 1057allowed_expansion(QGoal) :-
 1058    strip_module(QGoal, M, Goal),
 1059    E = error(Formal,_),
 1060    catch(prolog:sandbox_allowed_expansion(M:Goal), E, true),
 1061    (   var(Formal)
 1062    ->  fail
 1063    ;   !,
 1064        print_message(error, E),
 1065        fail
 1066    ).
 1067allowed_expansion(_).
 1068
 1069
 1070                 /*******************************
 1071                 *      FUNCTIONAL NOTATION     *
 1072                 *******************************/
 1073
 1074%!  expand_functions(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
 1075%
 1076%   Expand functional notation and arithmetic functions.
 1077%
 1078%   @arg MList is the list of modules defining goal_expansion/2 in
 1079%   the expansion context.
 1080
 1081expand_functions(G0, P0, G, P, M, MList, Term) :-
 1082    expand_functional_notation(G0, P0, G1, P1, M, MList, Term),
 1083    (   expand_arithmetic(G1, P1, G, P, Term)
 1084    ->  true
 1085    ;   G = G1,
 1086        P = P1
 1087    ).
 1088
 1089%!  expand_functional_notation(+G0, +P0, -G, -P, +M, +MList, +Term) is det.
 1090%
 1091%   @tbd: position logic
 1092%   @tbd: make functions module-local
 1093
 1094expand_functional_notation(G0, P0, G, P, M, _MList, _Term) :-
 1095    contains_functions(G0),
 1096    replace_functions(G0, P0, Eval, EvalPos, G1, G1Pos, M),
 1097    Eval \== true,
 1098    !,
 1099    wrap_var(G1, G1Pos, G2, G2Pos),
 1100    conj(Eval, EvalPos, G2, G2Pos, G, P).
 1101expand_functional_notation(G, P, G, P, _, _, _).
 1102
 1103wrap_var(G, P, G, P) :-
 1104    nonvar(G),
 1105    !.
 1106wrap_var(G, P0, call(G), P) :-
 1107    (   nonvar(P0)
 1108    ->  P = term_position(F,T,F,T,[P0]),
 1109        atomic_pos(P0, F-T)
 1110    ;   true
 1111    ).
 1112
 1113%!  contains_functions(@Term) is semidet.
 1114%
 1115%   True when Term contains a function reference.
 1116
 1117contains_functions(Term) :-
 1118    \+ \+ ( '$factorize_term'(Term, Skeleton, Assignments),
 1119            (   contains_functions2(Skeleton)
 1120            ;   contains_functions2(Assignments)
 1121            )).
 1122
 1123contains_functions2(Term) :-
 1124    compound(Term),
 1125    (   function(Term, _)
 1126    ->  true
 1127    ;   arg(_, Term, Arg),
 1128        contains_functions2(Arg)
 1129    ->  true
 1130    ).
 1131
 1132%!  replace_functions(+GoalIn, +PosIn,
 1133%!                    -Eval, -EvalPos,
 1134%!                    -GoalOut, -PosOut,
 1135%!                    +ContextTerm) is det.
 1136%
 1137%   @tbd    Proper propagation of list, dict and brace term positions.
 1138
 1139:- public
 1140    replace_functions/4.            % used in dicts.pl
 1141
 1142replace_functions(GoalIn, Eval, GoalOut, Context) :-
 1143    replace_functions(GoalIn, _, Eval, _, GoalOut, _, Context).
 1144
 1145replace_functions(Var, Pos, true, _, Var, Pos, _Ctx) :-
 1146    var(Var),
 1147    !.
 1148replace_functions(F, FPos, Eval, EvalPos, Var, VarPos, Ctx) :-
 1149    function(F, Ctx),
 1150    !,
 1151    compound_name_arity(F, Name, Arity),
 1152    PredArity is Arity+1,
 1153    compound_name_arity(G, Name, PredArity),
 1154    arg(PredArity, G, Var),
 1155    extend_1_pos(FPos, FArgPos, GPos, GArgPos, VarPos),
 1156    map_functions(0, Arity, F, FArgPos, G, GArgPos, Eval0, EP0, Ctx),
 1157    conj(Eval0, EP0, G, GPos, Eval, EvalPos).
 1158replace_functions(Term0, Term0Pos, Eval, EvalPos, Term, TermPos, Ctx) :-
 1159    compound(Term0),
 1160    !,
 1161    compound_name_arity(Term0, Name, Arity),
 1162    compound_name_arity(Term, Name, Arity),
 1163    f_pos(Term0Pos, Args0Pos, TermPos, ArgsPos),
 1164    map_functions(0, Arity,
 1165                  Term0, Args0Pos, Term, ArgsPos, Eval, EvalPos, Ctx).
 1166replace_functions(Term, Pos, true, _, Term, Pos, _).
 1167
 1168
 1169%!  map_functions(+Arg, +Arity,
 1170%!                +TermIn, +ArgInPos, -Term, -ArgPos, -Eval, -EvalPos,
 1171%!                +Context)
 1172
 1173map_functions(Arity, Arity, _, LPos0, _, LPos, true, _, _) :-
 1174    !,
 1175    pos_nil(LPos0, LPos).
 1176map_functions(I0, Arity, Term0, LPos0, Term, LPos, Eval, EP, Ctx) :-
 1177    pos_list(LPos0, AP0, APT0, LPos, AP, APT),
 1178    I is I0+1,
 1179    arg(I, Term0, Arg0),
 1180    arg(I, Term, Arg),
 1181    replace_functions(Arg0, AP0, Eval0, EP0, Arg, AP, Ctx),
 1182    map_functions(I, Arity, Term0, APT0, Term, APT, Eval1, EP1, Ctx),
 1183    conj(Eval0, EP0, Eval1, EP1, Eval, EP).
 1184
 1185%!  conj(+G1, +P1, +G2, +P2, -G, -P)
 1186
 1187conj(true, _, X, P, X, P) :- !.
 1188conj(X, P, true, _, X, P) :- !.
 1189conj(X, PX, Y, PY, (X,Y), _) :-
 1190    var(PX), var(PY),
 1191    !.
 1192conj(X, PX, Y, PY, (X,Y), P) :-
 1193    P = term_position(F,T,FF,FT,[PX,PY]),
 1194    atomic_pos(PX, F-FF),
 1195    atomic_pos(PY, FT-T).
 1196
 1197%!  function(?Term, +Context)
 1198%
 1199%   True if function expansion needs to be applied for the given
 1200%   term.
 1201
 1202:- multifile
 1203    function/2. 1204
 1205function(.(_,_), _) :- \+ functor([_|_], ., _).
 1206
 1207
 1208                 /*******************************
 1209                 *          ARITHMETIC          *
 1210                 *******************************/
 1211
 1212%!  expand_arithmetic(+G0, +P0, -G, -P, +Term) is semidet.
 1213%
 1214%   Expand arithmetic expressions  in  is/2,   (>)/2,  etc.  This is
 1215%   currently a dummy.  The  idea  is   to  call  rules  similar  to
 1216%   goal_expansion/2,4  that  allow  for   rewriting  an  arithmetic
 1217%   expression. The system rules will perform evaluation of constant
 1218%   expressions.
 1219
 1220expand_arithmetic(_G0, _P0, _G, _P, _Term) :- fail.
 1221
 1222
 1223                 /*******************************
 1224                 *        POSITION LOGIC        *
 1225                 *******************************/
 1226
 1227%!  f2_pos(?TermPos0, ?PosArg10, ?PosArg20,
 1228%!         ?TermPos,  ?PosArg1,  ?PosArg2) is det.
 1229%!  f1_pos(?TermPos0, ?PosArg10, ?TermPos,  ?PosArg1) is det.
 1230%!  f_pos(?TermPos0, ?PosArgs0, ?TermPos,  ?PosArgs) is det.
 1231%!  atomic_pos(?TermPos0, -AtomicPos) is det.
 1232%
 1233%   Position progapation routines.
 1234
 1235f2_pos(Var, _, _, _, _, _) :-
 1236    var(Var),
 1237    !.
 1238f2_pos(term_position(F,T,FF,FT,[A10,A20]), A10, A20,
 1239       term_position(F,T,FF,FT,[A1, A2 ]), A1,  A2) :- !.
 1240f2_pos(parentheses_term_position(O,C,Pos0), A10, A20,
 1241       parentheses_term_position(O,C,Pos),  A1,  A2) :-
 1242    !,
 1243    f2_pos(Pos0, A10, A20, Pos, A1, A2).
 1244f2_pos(Pos, _, _, _, _, _) :-
 1245    expected_layout(f2, Pos).
 1246
 1247f1_pos(Var, _, _, _) :-
 1248    var(Var),
 1249    !.
 1250f1_pos(term_position(F,T,FF,FT,[A10]), A10,
 1251       term_position(F,T,FF,FT,[A1 ]),  A1) :- !.
 1252f1_pos(parentheses_term_position(O,C,Pos0), A10,
 1253       parentheses_term_position(O,C,Pos),  A1) :-
 1254    !,
 1255    f1_pos(Pos0, A10, Pos, A1).
 1256f1_pos(Pos, _, _, _) :-
 1257    expected_layout(f1, Pos).
 1258
 1259f_pos(Var, _, _, _) :-
 1260    var(Var),
 1261    !.
 1262f_pos(term_position(F,T,FF,FT,ArgPos0), ArgPos0,
 1263      term_position(F,T,FF,FT,ArgPos),  ArgPos) :- !.
 1264f_pos(parentheses_term_position(O,C,Pos0), A10,
 1265      parentheses_term_position(O,C,Pos),  A1) :-
 1266    !,
 1267    f_pos(Pos0, A10, Pos, A1).
 1268f_pos(Pos, _, _, _) :-
 1269    expected_layout(compound, Pos).
 1270
 1271atomic_pos(Pos, _) :-
 1272    var(Pos),
 1273    !.
 1274atomic_pos(Pos, F-T) :-
 1275    arg(1, Pos, F),
 1276    arg(2, Pos, T).
 1277
 1278%!  pos_nil(+Nil, -Nil) is det.
 1279%!  pos_list(+List0, -H0, -T0, -List, -H, -T) is det.
 1280%
 1281%   Position propagation for lists.
 1282
 1283pos_nil(Var, _) :- var(Var), !.
 1284pos_nil([], []) :- !.
 1285pos_nil(Pos, _) :-
 1286    expected_layout(nil, Pos).
 1287
 1288pos_list(Var, _, _, _, _, _) :- var(Var), !.
 1289pos_list([H0|T0], H0, T0, [H|T], H, T) :- !.
 1290pos_list(Pos, _, _, _, _, _) :-
 1291    expected_layout(list, Pos).
 1292
 1293%!  extend_1_pos(+FunctionPos, -FArgPos, -EvalPos, -EArgPos, -VarPos)
 1294%
 1295%   Deal with extending a function to include the return value.
 1296
 1297extend_1_pos(Pos, _, _, _, _) :-
 1298    var(Pos),
 1299    !.
 1300extend_1_pos(term_position(F,T,FF,FT,FArgPos), FArgPos,
 1301             term_position(F,T,FF,FT,GArgPos), GArgPos0,
 1302             FT-FT1) :-
 1303    integer(FT),
 1304    !,
 1305    FT1 is FT+1,
 1306    '$same_length'(FArgPos, GArgPos0),
 1307    '$append'(GArgPos0, [FT-FT1], GArgPos).
 1308extend_1_pos(F-T, [],
 1309             term_position(F,T,F,T,[T-T1]), [],
 1310             T-T1) :-
 1311    integer(T),
 1312    !,
 1313    T1 is T+1.
 1314extend_1_pos(Pos, _, _, _, _) :-
 1315    expected_layout(callable, Pos).
 1316
 1317'$same_length'(List, List) :-
 1318    var(List),
 1319    !.
 1320'$same_length'([], []).
 1321'$same_length'([_|T0], [_|T]) :-
 1322    '$same_length'(T0, T).
 1323
 1324
 1325%!  expected_layout(+Expected, +Found)
 1326%
 1327%   Print a message  if  the  layout   term  does  not  satisfy  our
 1328%   expectations.  This  means  that   the  transformation  requires
 1329%   support from term_expansion/4 and/or goal_expansion/4 to achieve
 1330%   proper source location information.
 1331
 1332:- create_prolog_flag(debug_term_position, false, []). 1333
 1334expected_layout(Expected, Pos) :-
 1335    current_prolog_flag(debug_term_position, true),
 1336    !,
 1337    '$print_message'(warning, expected_layout(Expected, Pos)).
 1338expected_layout(_, _).
 1339
 1340
 1341                 /*******************************
 1342                 *    SIMPLIFICATION ROUTINES   *
 1343                 *******************************/
 1344
 1345%!  simplify(+ControlIn, +Pos0, -ControlOut, -Pos) is det.
 1346%
 1347%   Simplify control structures
 1348%
 1349%   @tbd    Much more analysis
 1350%   @tbd    Turn this into a separate module
 1351
 1352simplify(Control, P, Control, P) :-
 1353    current_prolog_flag(optimise, false),
 1354    !.
 1355simplify(Control, P0, Simple, P) :-
 1356    simple(Control, P0, Simple, P),
 1357    !.
 1358simplify(Control, P, Control, P).
 1359
 1360%!  simple(+Goal, +GoalPos, -Simple, -SimplePos)
 1361%
 1362%   Simplify a control structure.  Note  that   we  do  not simplify
 1363%   (A;fail). Logically, this is the  same  as   `A`  if  `A` is not
 1364%   `_->_` or `_*->_`, but  the  choice   point  may  be  created on
 1365%   purpose.
 1366
 1367simple((X,Y), P0, Conj, P) :-
 1368    (   true(X)
 1369    ->  Conj = Y,
 1370        f2_pos(P0, _, P, _, _, _)
 1371    ;   false(X)
 1372    ->  Conj = fail,
 1373        f2_pos(P0, P1, _, _, _, _),
 1374        atomic_pos(P1, P)
 1375    ;   true(Y)
 1376    ->  Conj = X,
 1377        f2_pos(P0, P, _, _, _, _)
 1378    ).
 1379simple((I->T;E), P0, ITE, P) :-         % unification with _->_ is fine
 1380    (   true(I)                     % because nothing happens if I and T
 1381    ->  ITE = T,                    % are unbound.
 1382        f2_pos(P0, P1, _, _, _, _),
 1383        f2_pos(P1, _, P, _, _, _)
 1384    ;   false(I)
 1385    ->  ITE = E,
 1386        f2_pos(P0, _, P, _, _, _)
 1387    ).
 1388simple((X;Y), P0, Or, P) :-
 1389    false(X),
 1390    Or = Y,
 1391    f2_pos(P0, _, P, _, _, _).
 1392
 1393true(X) :-
 1394    nonvar(X),
 1395    eval_true(X).
 1396
 1397false(X) :-
 1398    nonvar(X),
 1399    eval_false(X).
 1400
 1401
 1402%!  eval_true(+Goal) is semidet.
 1403%!  eval_false(+Goal) is semidet.
 1404
 1405eval_true(true).
 1406eval_true(otherwise).
 1407
 1408eval_false(fail).
 1409eval_false(false).
 1410
 1411
 1412                 /*******************************
 1413                 *         META CALLING         *
 1414                 *******************************/
 1415
 1416:- create_prolog_flag(compile_meta_arguments, false, [type(atom)]). 1417
 1418%!  compile_meta_call(+CallIn, -CallOut, +Module, +Term) is det.
 1419%
 1420%   Compile (complex) meta-calls into a clause.
 1421
 1422compile_meta_call(CallIn, CallIn, _, Term) :-
 1423    var(Term),
 1424    !.                   % explicit call; no context
 1425compile_meta_call(CallIn, CallIn, _, _) :-
 1426    var(CallIn),
 1427    !.
 1428compile_meta_call(CallIn, CallIn, _, _) :-
 1429    (   current_prolog_flag(compile_meta_arguments, false)
 1430    ;   current_prolog_flag(xref, true)
 1431    ),
 1432    !.
 1433compile_meta_call(CallIn, CallIn, _, _) :-
 1434    strip_module(CallIn, _, Call),
 1435    (   is_aux_meta(Call)
 1436    ;   \+ control(Call),
 1437        (   '$c_current_predicate'(_, system:Call),
 1438            \+ current_prolog_flag(compile_meta_arguments, always)
 1439        ;   current_prolog_flag(compile_meta_arguments, control)
 1440        )
 1441    ),
 1442    !.
 1443compile_meta_call(M:CallIn, CallOut, _, Term) :-
 1444    !,
 1445    (   atom(M), callable(CallIn)
 1446    ->  compile_meta_call(CallIn, CallOut, M, Term)
 1447    ;   CallOut = M:CallIn
 1448    ).
 1449compile_meta_call(CallIn, CallOut, Module, Term) :-
 1450    compile_meta(CallIn, CallOut, Module, Term, Clause),
 1451    compile_auxiliary_clause(Module, Clause).
 1452
 1453compile_auxiliary_clause(Module, Clause) :-
 1454    Clause = (Head:-Body),
 1455    '$current_source_module'(SM),
 1456    (   predicate_property(SM:Head, defined)
 1457    ->  true
 1458    ;   SM == Module
 1459    ->  compile_aux_clauses([Clause])
 1460    ;   compile_aux_clauses([Head:-Module:Body])
 1461    ).
 1462
 1463control((_,_)).
 1464control((_;_)).
 1465control((_->_)).
 1466control((_*->_)).
 1467control(\+(_)).
 1468control($(_)).
 1469
 1470is_aux_meta(Term) :-
 1471    callable(Term),
 1472    functor(Term, Name, _),
 1473    sub_atom(Name, 0, _, _, '__aux_meta_call_').
 1474
 1475compile_meta(CallIn, CallOut, M, Term, (CallOut :- Body)) :-
 1476    replace_subterm(CallIn, true, Term, Term2),
 1477    term_variables(Term2, AllVars),
 1478    term_variables(CallIn, InVars),
 1479    intersection_eq(InVars, AllVars, HeadVars),
 1480    copy_term_nat(CallIn+HeadVars, NAT),
 1481    variant_sha1(NAT, Hash),
 1482    atom_concat('__aux_meta_call_', Hash, AuxName),
 1483    expand_goal(CallIn, _Pos0, Body, _Pos, M, [], (CallOut:-CallIn), []),
 1484    length(HeadVars, Arity),
 1485    (   Arity > 256                 % avoid 1024 arity limit
 1486    ->  HeadArgs = [v(HeadVars)]
 1487    ;   HeadArgs = HeadVars
 1488    ),
 1489    CallOut =.. [AuxName|HeadArgs].
 1490
 1491%!  replace_subterm(From, To, TermIn, TermOut)
 1492%
 1493%   Replace instances (==/2) of From inside TermIn by To.
 1494
 1495replace_subterm(From, To, TermIn, TermOut) :-
 1496    From == TermIn,
 1497    !,
 1498    TermOut = To.
 1499replace_subterm(From, To, TermIn, TermOut) :-
 1500    compound(TermIn),
 1501    compound_name_arity(TermIn, Name, Arity),
 1502    Arity > 0,
 1503    !,
 1504    compound_name_arity(TermOut, Name, Arity),
 1505    replace_subterm_compound(1, Arity, From, To, TermIn, TermOut).
 1506replace_subterm(_, _, Term, Term).
 1507
 1508replace_subterm_compound(I, Arity, From, To, TermIn, TermOut) :-
 1509    I =< Arity,
 1510    !,
 1511    arg(I, TermIn, A1),
 1512    arg(I, TermOut, A2),
 1513    replace_subterm(From, To, A1, A2),
 1514    I2 is I+1,
 1515    replace_subterm_compound(I2, Arity, From, To, TermIn, TermOut).
 1516replace_subterm_compound(_I, _Arity, _From, _To, _TermIn, _TermOut).
 1517
 1518
 1519%!  intersection_eq(+Small, +Big, -Shared) is det.
 1520%
 1521%   Shared are the variables in Small that   also appear in Big. The
 1522%   variables in Shared are in the same order as Small.
 1523
 1524intersection_eq([], _, []).
 1525intersection_eq([H|T0], L, List) :-
 1526    (   member_eq(H, L)
 1527    ->  List = [H|T],
 1528        intersection_eq(T0, L, T)
 1529    ;   intersection_eq(T0, L, List)
 1530    ).
 1531
 1532member_eq(E, [H|T]) :-
 1533    (   E == H
 1534    ->  true
 1535    ;   member_eq(E, T)
 1536    ).
 1537
 1538                 /*******************************
 1539                 *      :- IF ... :- ENDIF      *
 1540                 *******************************/
 1541
 1542:- thread_local
 1543    '$include_code'/3. 1544
 1545'$including' :-
 1546    '$include_code'(X, _, _),
 1547    !,
 1548    X == true.
 1549'$including'.
 1550
 1551cond_compilation((:- if(G)), []) :-
 1552    source_location(File, Line),
 1553    (   '$including'
 1554    ->  (   catch('$eval_if'(G), E, (print_message(error, E), fail))
 1555        ->  asserta('$include_code'(true, File, Line))
 1556        ;   asserta('$include_code'(false, File, Line))
 1557        )
 1558    ;   asserta('$include_code'(else_false, File, Line))
 1559    ).
 1560cond_compilation((:- elif(G)), []) :-
 1561    source_location(File, Line),
 1562    (   clause('$include_code'(Old, File, _), _, Ref)
 1563    ->  erase(Ref),
 1564        (   Old == true
 1565        ->  asserta('$include_code'(else_false, File, Line))
 1566        ;   Old == false,
 1567            catch('$eval_if'(G), E, (print_message(error, E), fail))
 1568        ->  asserta('$include_code'(true, File, Line))
 1569        ;   asserta('$include_code'(Old, File, Line))
 1570        )
 1571    ;   throw(error(conditional_compilation_error(no_if, elif), _))
 1572    ).
 1573cond_compilation((:- else), []) :-
 1574    source_location(File, Line),
 1575    (   clause('$include_code'(X, File, _), _, Ref)
 1576    ->  erase(Ref),
 1577        (   X == true
 1578        ->  X2 = false
 1579        ;   X == false
 1580        ->  X2 = true
 1581        ;   X2 = X
 1582        ),
 1583        asserta('$include_code'(X2, File, Line))
 1584    ;   throw(error(conditional_compilation_error(no_if, else), _))
 1585    ).
 1586cond_compilation(end_of_file, end_of_file) :-   % TBD: Check completeness
 1587    !,
 1588    source_location(File, _),
 1589    (   clause('$include_code'(_, OF, OL), _)
 1590    ->  (   File == OF
 1591        ->  throw(error(conditional_compilation_error(
 1592                            unterminated,OF:OL), _))
 1593        ;   true
 1594        )
 1595    ;   true
 1596    ).
 1597cond_compilation((:- endif), []) :-
 1598    !,
 1599    source_location(File, _),
 1600    (   (   clause('$include_code'(_, File, _), _, Ref)
 1601        ->  erase(Ref)
 1602        )
 1603    ->  true
 1604    ;   throw(error(conditional_compilation_error(no_if, endif), _))
 1605    ).
 1606cond_compilation(_, []) :-
 1607    \+ '$including'.
 1608
 1609'$eval_if'(G) :-
 1610    expand_goal(G, G2),
 1611    '$current_source_module'(Module),
 1612    Module:G2