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