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