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-2016, University of Amsterdam
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module('$expand',
   37          [ expand_term/2,              % +Term0, -Term
   38            expand_goal/2,              % +Goal0, -Goal
   39            expand_term/4,              % +Term0, ?Pos0, -Term, -Pos
   40            expand_goal/4,              % +Goal0, ?Pos0, -Goal, -Pos
   41            var_property/2,             % +Var, ?Property
   42
   43            '$expand_closure'/3         % +GoalIn, +Extra, -GoalOut
   44          ]).

   69:- dynamic
   70    system:term_expansion/2,
   71    system:goal_expansion/2,
   72    user:term_expansion/2,
   73    user:goal_expansion/2,
   74    system:term_expansion/4,
   75    system:goal_expansion/4,
   76    user:term_expansion/4,
   77    user:goal_expansion/4.   78:- multifile
   79    system:term_expansion/2,
   80    system:goal_expansion/2,
   81    user:term_expansion/2,
   82    user:goal_expansion/2,
   83    system:term_expansion/4,
   84    system:goal_expansion/4,
   85    user:term_expansion/4,
   86    user:goal_expansion/4.   87
   88:- meta_predicate
   89    expand_terms(4, +, ?, -, -).

 expand_term(+Input, -Output) is det

 expand_term(+Input, +Pos0, -Output, -Pos) is det

This predicate is used to translate terms as they are read from a source-file before they are added to the Prolog database.

   97expand_term(Term0, Term) :-
   98    expand_term(Term0, _, Term, _).
   99
  100expand_term(Var, Pos, Expanded, Pos) :-
  101    var(Var),
  102    !,
  103    Expanded = Var.
  104expand_term(Term, Pos0, [], Pos) :-
  105    cond_compilation(Term, X),
  106    X == [],
  107    !,
  108    atomic_pos(Pos0, Pos).
  109expand_term(Term, Pos0, Expanded, Pos) :-
  110    b_setval('$term', Term),
  111    '$def_modules'([term_expansion/4,term_expansion/2], MList),
  112    call_term_expansion(MList, Term, Pos0, Term1, Pos1),
  113    expand_terms(expand_term_2, Term1, Pos1, Term2, Pos),
  114    rename(Term2, Expanded),
  115    b_setval('$term', []).
  116
  117call_term_expansion([], Term, Pos, Term, Pos).
  118call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
  119    current_prolog_flag(sandboxed_load, false),
  120    !,
  121    (   '$member'(Pred, Preds),
  122        (   Pred == term_expansion/2
  123        ->  M:term_expansion(Term0, Term1),
  124            Pos1 = Pos0
  125        ;   M:term_expansion(Term0, Pos0, Term1, Pos1)
  126        )
  127    ->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
  128    ;   call_term_expansion(T, Term0, Pos0, Term, Pos)
  129    ).
  130call_term_expansion([M-Preds|T], Term0, Pos0, Term, Pos) :-
  131    (   '$member'(Pred, Preds),
  132        (   Pred == term_expansion/2
  133        ->  allowed_expansion(M:term_expansion(Term0, Term1)),
  134            call(M:term_expansion(Term0, Term1)),
  135            Pos1 = Pos
  136        ;   allowed_expansion(M:term_expansion(Term0, Pos0, Term1, Pos1)),
  137            call(M:term_expansion(Term0, Pos0, Term1, Pos1))
  138        )
  139    ->  expand_terms(call_term_expansion(T), Term1, Pos1, Term, Pos)
  140    ;   call_term_expansion(T, Term0, Pos0, Term, Pos)
  141    ).
  142
  143expand_term_2((Head --> Body), Pos0, Expanded, Pos) :-
  144    dcg_translate_rule((Head --> Body), Pos0, Expanded0, Pos1),
  145    !,
  146    expand_bodies(Expanded0, Pos1, Expanded, Pos).
  147expand_term_2(Term0, Pos0, Term, Pos) :-
  148    nonvar(Term0),
  149    !,
  150    expand_bodies(Term0, Pos0, Term, Pos).
  151expand_term_2(Term, Pos, Term, Pos).

 expand_bodies(+Term, +Pos0, -Out, -Pos) is det

Find the body terms in Term and give them to expand_goal/2 for further processing. Note that we maintain status information about variables. Currently we only detect whether variables are fresh or not. See var_info/3.

  160expand_bodies(Terms, Pos0, Out, Pos) :-
  161    '$def_modules'([goal_expansion/4,goal_expansion/2], MList),
  162    expand_terms(expand_body(MList), Terms, Pos0, Out, Pos),
  163    remove_attributes(Out, '$var_info').
  164
  165expand_body(MList, (Head0 :- Body), Pos0, (Head :- ExpandedBody), Pos) :-
  166    !,
  167    term_variables(Head0, HVars),
  168    mark_vars_non_fresh(HVars),
  169    f2_pos(Pos0, HPos, BPos0, Pos, HPos, BPos),
  170    expand_goal(Body, BPos0, ExpandedBody0, BPos, MList, (Head0 :- Body)),
  171    (   compound(Head0),
  172        '$current_source_module'(M),
  173        replace_functions(Head0, Eval, Head, M),
  174        Eval \== true
  175    ->  ExpandedBody = (Eval,ExpandedBody0)
  176    ;   Head = Head0,
  177        ExpandedBody = ExpandedBody0
  178    ).
  179expand_body(MList, (:- Body), Pos0, (:- ExpandedBody), Pos) :-
  180    !,
  181    f1_pos(Pos0, BPos0, Pos, BPos),
  182    expand_goal(Body, BPos0, ExpandedBody, BPos, MList, (:- Body)).
  183
  184expand_body(_MList, Head0, Pos, Clause, Pos) :- % TBD: Position handling
  185    compound(Head0),
  186    '$current_source_module'(M),
  187    replace_functions(Head0, Eval, Head, M),
  188    Eval \== true,
  189    !,
  190    Clause = (Head :- Eval).
  191expand_body(_, Head, Pos, Head, Pos).

 expand_terms(:Closure, +In, +Pos0, -Out, -Pos)

Loop over two constructs that can be added by term-expansion rules in order to run the next phase: calling term_expansion/2 can return a list and terms may be preceeded with a source-location.

  201expand_terms(_, X, P, X, P) :-
  202    var(X),
  203    !.
  204expand_terms(C, List0, Pos0, List, Pos) :-
  205    nonvar(List0),
  206    List0 = [_|_],
  207    !,
  208    (   is_list(List0)
  209    ->  list_pos(Pos0, Elems0, Pos, Elems),
  210        expand_term_list(C, List0, Elems0, List, Elems)
  211    ;   '$type_error'(list, List0)
  212    ).
  213expand_terms(C, '$source_location'(File, Line):Clause0, Pos0, Clause, Pos) :-
  214    !,
  215    expand_terms(C, Clause0, Pos0, Clause1, Pos),
  216    add_source_location(Clause1, '$source_location'(File, Line), Clause).
  217expand_terms(C, Term0, Pos0, Term, Pos) :-
  218    call(C, Term0, Pos0, Term, Pos).

 add_source_location(+Term, +SrcLoc, -SrcTerm)

Re-apply source location after term expansion. If the result is a list, claim all terms to originate from this location.

  225add_source_location(Clauses0, SrcLoc, Clauses) :-
  226    (   is_list(Clauses0)
  227    ->  add_source_location_list(Clauses0, SrcLoc, Clauses)
  228    ;   Clauses = SrcLoc:Clauses0
  229    ).
  230
  231add_source_location_list([], _, []).
  232add_source_location_list([Clause|Clauses0], SrcLoc, [SrcLoc:Clause|Clauses]) :-
  233    add_source_location_list(Clauses0, SrcLoc, Clauses).

 expand_term_list(:Expander, +TermList, +Pos, -NewTermList, -PosList)

  237expand_term_list(_, [], _, [], []) :- !.
  238expand_term_list(C, [H0|T0], [PH0], Terms, PosL) :-
  239    !,
  240    expand_terms(C, H0, PH0, H, PH),
  241    add_term(H, PH, Terms, TT, PosL, PT),
  242    expand_term_list(C, T0, [PH0], TT, PT).
  243expand_term_list(C, [H0|T0], [PH0|PT0], Terms, PosL) :-
  244    !,
  245    expand_terms(C, H0, PH0, H, PH),
  246    add_term(H, PH, Terms, TT, PosL, PT),
  247    expand_term_list(C, T0, PT0, TT, PT).
  248expand_term_list(C, [H0|T0], PH0, Terms, PosL) :-
  249    expected_layout(list, PH0),
  250    expand_terms(C, H0, PH0, H, PH),
  251    add_term(H, PH, Terms, TT, PosL, PT),
  252    expand_term_list(C, T0, [PH0], TT, PT).

 add_term(+ExpandOut, ?ExpandPosOut, -Terms, ?TermsT, -PosL, ?PosLT)

  256add_term(List, Pos, Terms, TermT, PosL, PosT) :-
  257    nonvar(List), List = [_|_],
  258    !,
  259    (   is_list(List)
  260    ->  append_tp(List, Terms, TermT, Pos, PosL, PosT)
  261    ;   '$type_error'(list, List)
  262    ).
  263add_term(Term, Pos, [Term|Terms], Terms, [Pos|PosT], PosT).
  264
  265append_tp([], Terms, Terms, _, PosL, PosL).
  266append_tp([H|T0], [H|T1], Terms, [HP], [HP|TP1], PosL) :-
  267    !,
  268    append_tp(T0, T1, Terms, [HP], TP1, PosL).
  269append_tp([H|T0], [H|T1], Terms, [HP0|TP0], [HP0|TP1], PosL) :-
  270    !,
  271    append_tp(T0, T1, Terms, TP0, TP1, PosL).
  272append_tp([H|T0], [H|T1], Terms, Pos, [Pos|TP1], PosL) :-
  273    expected_layout(list, Pos),
  274    append_tp(T0, T1, Terms, [Pos], TP1, PosL).
  275
  276
  277list_pos(Var, _, _, _) :-
  278    var(Var),
  279    !.
  280list_pos(list_position(F,T,Elems0,none), Elems0,
  281         list_position(F,T,Elems,none),  Elems).
  282list_pos(Pos, [Pos], Elems, Elems).
  283
  284
  285                 /*******************************
  286                 *      VAR_INFO/3 SUPPORT      *
  287                 *******************************/

 var_intersection(+List1, +List2, -Shared) is det

Shared is the ordered intersection of List1 and List2.

  293var_intersection(List1, List2, Intersection) :-
  294    sort(List1, Set1),
  295    sort(List2, Set2),
  296    ord_intersection(Set1, Set2, Intersection).

 ord_intersection(+OSet1, +OSet2, -Int)

Ordered list intersection. Copied from the library.

  302ord_intersection([], _Int, []).
  303ord_intersection([H1|T1], L2, Int) :-
  304    isect2(L2, H1, T1, Int).
  305
  306isect2([], _H1, _T1, []).
  307isect2([H2|T2], H1, T1, Int) :-
  308    compare(Order, H1, H2),
  309    isect3(Order, H1, T1, H2, T2, Int).
  310
  311isect3(<, _H1, T1,  H2, T2, Int) :-
  312    isect2(T1, H2, T2, Int).
  313isect3(=, H1, T1, _H2, T2, [H1|Int]) :-
  314    ord_intersection(T1, T2, Int).
  315isect3(>, H1, T1,  _H2, T2, Int) :-
  316    isect2(T2, H1, T1, Int).

 merge_variable_info(+Saved)

Merge info from two branches. The info in Saved is the saved info from the first branch, while the info in the actual variables is the info in the second branch. Only if both branches claim the variable to be fresh, we can consider it fresh.

  327merge_variable_info([]).
  328merge_variable_info([Var=State|States]) :-
  329    (   get_attr(Var, '$var_info', CurrentState)
  330    ->  true
  331    ;   CurrentState = (-)
  332    ),
  333    merge_states(Var, State, CurrentState),
  334    merge_variable_info(States).
  335
  336merge_states(_Var, State, State) :- !.
  337merge_states(_Var, -, _) :- !.
  338merge_states(Var, State, -) :-
  339    !,
  340    put_attr(Var, '$var_info', State).
  341merge_states(Var, Left, Right) :-
  342    (   get_dict(fresh, Left, false)
  343    ->  put_dict(fresh, Right, false)
  344    ;   get_dict(fresh, Right, false)
  345    ->  put_dict(fresh, Left, false)
  346    ),
  347    !,
  348    (   Left >:< Right
  349    ->  put_dict(Left, Right, State),
  350        put_attr(Var, '$var_info', State)
  351    ;   print_message(warning,
  352                      inconsistent_variable_properties(Left, Right)),
  353        put_dict(Left, Right, State),
  354        put_attr(Var, '$var_info', State)
  355    ).
  356
  357
  358save_variable_info([], []).
  359save_variable_info([Var|Vars], [Var=State|States]):-
  360    (   get_attr(Var, '$var_info', State)
  361    ->  true
  362    ;   State = (-)
  363    ),
  364    save_variable_info(Vars, States).
  365
  366restore_variable_info([]).
  367restore_variable_info([Var=State|States]) :-
  368    (   State == (-)
  369    ->  del_attr(Var, '$var_info')
  370    ;   put_attr(Var, '$var_info', State)
  371    ),
  372    restore_variable_info(States).

 var_property(+Var, ?Property)

True when Var has a property Key with Value. Defined properties are:

fresh(Fresh)

Variable is first introduced in this goal and thus guaranteed to be unbound. This property is always present.

singleton(Bool)

It true indicate that the variable appears once in the source. Note this doesn't mean it is a semantic singleton.

name(-Name)

True when Name is the name of the variable.

  388var_property(Var, Property) :-
  389    prop_var(Property, Var).
  390
  391prop_var(fresh(Fresh), Var) :-
  392    (   get_attr(Var, '$var_info', Info),
  393        get_dict(fresh, Info, Fresh0)
  394    ->  Fresh = Fresh0
  395    ;   Fresh = true
  396    ).
  397prop_var(singleton(Singleton), Var) :-
  398    get_attr(Var, '$var_info', Info),
  399    get_dict(singleton, Info, Singleton).
  400prop_var(name(Name), Var) :-
  401    (   nb_current('$variable_names', Bindings),
  402        '$member'(Name0=Var0, Bindings),
  403        Var0 == Var
  404    ->  Name = Name0
  405    ).
  406
  407
  408mark_vars_non_fresh([]) :- !.
  409mark_vars_non_fresh([Var|Vars]) :-
  410    (   get_attr(Var, '$var_info', Info)
  411    ->  (   get_dict(fresh, Info, false)
  412        ->  true
  413        ;   put_dict(fresh, Info, false, Info1),
  414            put_attr(Var, '$var_info', Info1)
  415        )
  416    ;   put_attr(Var, '$var_info', '$var_info'{fresh:false})
  417    ),
  418    mark_vars_non_fresh(Vars).

 remove_attributes(+Term, +Attribute) is det

Remove all variable attributes Attribute from Term. This is used to make term_expansion end with a clean term. This is currently required for saving directives in QLF files. The compiler ignores attributes, but I think it is cleaner to remove them anyway.

  429remove_attributes(Term, Attr) :-
  430    term_variables(Term, Vars),
  431    remove_var_attr(Vars, Attr).
  432
  433remove_var_attr([], _):- !.
  434remove_var_attr([Var|Vars], Attr):-
  435    del_attr(Var, Attr),
  436    remove_var_attr(Vars, Attr).

 $var_info:attr_unify_hook(_, _) is det

Dummy unification hook for attributed variables. Just succeeds.

  442'$var_info':attr_unify_hook(_, _).
  443
  444
  445                 /*******************************
  446                 *   GOAL_EXPANSION/2 SUPPORT   *
  447                 *******************************/

 expand_goal(+BodyTerm, +Pos0, -Out, -Pos) is det

 expand_goal(+BodyTerm, -Out) is det

Perform macro-expansion on body terms by calling goal_expansion/2.

  455expand_goal(A, B) :-
  456    expand_goal(A, _, B, _).
  457
  458expand_goal(A, P0, B, P) :-
  459    '$def_modules'([goal_expansion/4, goal_expansion/2], MList),
  460    (   expand_goal(A, P0, B, P, MList, _)
  461    ->  remove_attributes(B, '$var_info'), A \== B
  462    ),
  463    !.
  464expand_goal(A, P, A, P).

 $expand_closure(+BodyIn, +ExtraArgs, -BodyOut) is semidet

 $expand_closure(+BodyIn, +PIn, +ExtraArgs, -BodyOut, -POut) is semidet

Expand a closure using goal expansion for some extra arguments. Note that the extra argument must remain at the end. If this is not the case, '$expand_closure'/3,5 fail.

  473'$expand_closure'(G0, N, G) :-
  474    '$expand_closure'(G0, _, N, G, _).
  475
  476'$expand_closure'(G0, P0, N, G, P) :-
  477    length(Ex, N),
  478    mark_vars_non_fresh(Ex),
  479    extend_arg_pos(G0, P0, Ex, G1, P1),
  480    expand_goal(G1, P1, G2, P2),
  481    term_variables(G0, VL),
  482    remove_arg_pos(G2, P2, [], VL, Ex, G, P).
  483
  484
  485expand_goal(G0, P0, G, P, MList, Term) :-
  486    '$current_source_module'(M),
  487    expand_goal(G0, P0, G, P, M, MList, Term).

 expand_goal(+GoalIn, ?PosIn, -GoalOut, -PosOut, +Module, -ModuleList, +Term) is det

Arguments:

Module	- is the current module to consider
ModuleList	- are the other expansion modules
Term	- is the overall term that is being translated

  496% (*)   This is needed because call_goal_expansion may introduce extra
  497%       context variables.  Consider the code below, where the variable
  498%       E is introduced.  Is there a better representation for the
  499%       context?
  500%
  501%         ==
  502%         goal_expansion(catch_and_print(Goal), catch(Goal, E, print(E))).
  503%
  504%         test :-
  505%               catch_and_print(true).
  506%         ==
  507
  508expand_goal(G, P, G, P, _, _, _) :-
  509    var(G),
  510    !.
  511expand_goal(M:G, P, M:G, P, _M, _MList, _Term) :-
  512    var(M), var(G),
  513    !.
  514expand_goal(M:G, P0, M:EG, P, _M, _MList, Term) :-
  515    atom(M),
  516    !,
  517    f2_pos(P0, PA, PB0, P, PA, PB),
  518    '$def_modules'(M:[goal_expansion/4,goal_expansion/2], MList),
  519    setup_call_cleanup(
  520        '$set_source_module'(Old, M),
  521        '$expand':expand_goal(G, PB0, EG, PB, M, MList, Term),
  522        '$set_source_module'(Old)).
  523expand_goal(G0, P0, G, P, M, MList, Term) :-
  524    call_goal_expansion(MList, G0, P0, G1, P1),
  525    !,
  526    expand_goal(G1, P1, G, P, M, MList, Term/G1).           % (*)
  527expand_goal((A,B), P0, Conj, P, M, MList, Term) :-
  528    !,
  529    f2_pos(P0, PA0, PB0, P1, PA, PB),
  530    expand_goal(A, PA0, EA, PA, M, MList, Term),
  531    expand_goal(B, PB0, EB, PB, M, MList, Term),
  532    simplify((EA,EB), P1, Conj, P).
  533expand_goal((A;B), P0, Or, P, M, MList, Term) :-
  534    !,
  535    f2_pos(P0, PA0, PB0, P1, PA1, PB),
  536    term_variables(A, AVars),
  537    term_variables(B, BVars),
  538    var_intersection(AVars, BVars, SharedVars),
  539    save_variable_info(SharedVars, SavedState),
  540    expand_goal(A, PA0, EA, PA, M, MList, Term),
  541    save_variable_info(SharedVars, SavedState2),
  542    restore_variable_info(SavedState),
  543    expand_goal(B, PB0, EB, PB, M, MList, Term),
  544    merge_variable_info(SavedState2),
  545    fixup_or_lhs(A, EA, PA, EA1, PA1),
  546    simplify((EA1;EB), P1, Or, P).
  547expand_goal((A->B), P0, Goal, P, M, MList, Term) :-
  548    !,
  549    f2_pos(P0, PA0, PB0, P1, PA, PB),
  550    expand_goal(A, PA0, EA, PA, M, MList, Term),
  551    expand_goal(B, PB0, EB, PB, M, MList, Term),
  552    simplify((EA->EB), P1, Goal, P).
  553expand_goal((A*->B), P0, Goal, P, M, MList, Term) :-
  554    !,
  555    f2_pos(P0, PA0, PB0, P1, PA, PB),
  556    expand_goal(A, PA0, EA, PA, M, MList, Term),
  557    expand_goal(B, PB0, EB, PB, M, MList, Term),
  558    simplify((EA*->EB), P1, Goal, P).
  559expand_goal((\+A), P0, Goal, P, M, MList, Term) :-
  560    !,
  561    f1_pos(P0, PA0, P1, PA),
  562    term_variables(A, AVars),
  563    save_variable_info(AVars, SavedState),
  564    expand_goal(A, PA0, EA, PA, M, MList, Term),
  565    restore_variable_info(SavedState),
  566    simplify(\+(EA), P1, Goal, P).
  567expand_goal(call(A), P0, call(EA), P, M, MList, Term) :-
  568    !,
  569    f1_pos(P0, PA0, P, PA),
  570    expand_goal(A, PA0, EA, PA, M, MList, Term).
  571expand_goal(G0, P0, G, P, M, MList, Term) :-
  572    is_meta_call(G0, M, Head),
  573    !,
  574    term_variables(G0, Vars),
  575    mark_vars_non_fresh(Vars),
  576    expand_meta(Head, G0, P0, G, P, M, MList, Term).
  577expand_goal(G0, P0, G, P, M, MList, Term) :-
  578    term_variables(G0, Vars),
  579    mark_vars_non_fresh(Vars),
  580    expand_functions(G0, P0, G, P, M, MList, Term).

 fixup_or_lhs(+OldLeft, -ExpandedLeft, +ExpPos, -Fixed, -FixedPos) is det

The semantics of (A;B) is different if A is (If->Then). We need to keep the same semantics if -> is introduced or removed by the expansion. If -> is introduced, we make sure that the whole thing remains a disjunction by creating ((EA,true);B)

  589fixup_or_lhs(Old, New, PNew, Fix, PFixed) :-
  590    nonvar(Old),
  591    nonvar(New),
  592    (   Old = (_ -> _)
  593    ->  New \= (_ -> _),
  594        Fix = (New -> true)
  595    ;   New = (_ -> _),
  596        Fix = (New, true)
  597    ),
  598    !,
  599    lhs_pos(PNew, PFixed).
  600fixup_or_lhs(_Old, New, P, New, P).
  601
  602lhs_pos(P0, _) :-
  603    var(P0),
  604    !.
  605lhs_pos(P0, term_position(F,T,T,T,[P0,T-T])) :-
  606    arg(1, P0, F),
  607    arg(2, P0, T).

 is_meta_call(+G0, +M, +Head) is semidet

True if M:G0 resolves to a real meta-goal as specified by Head.

  614is_meta_call(G0, M, Head) :-
  615    compound(G0),
  616    default_module(M, M2),
  617    '$c_current_predicate'(_, M2:G0),
  618    !,
  619    '$get_predicate_attribute'(M2:G0, meta_predicate, Head),
  620    has_meta_arg(Head).

 expand_meta(+MetaSpec, +G0, ?P0, -G, -P, +M, +Mlist, +Term)

  625expand_meta(Spec, G0, P0, G, P, M, MList, Term) :-
  626    functor(Spec, _, Arity),
  627    functor(G0, Name, Arity),
  628    functor(G1, Name, Arity),
  629    f_pos(P0, ArgPos0, P, ArgPos),
  630    expand_meta(1, Arity, Spec,
  631                G0, ArgPos0, Eval,
  632                G1,  ArgPos,
  633                M, MList, Term),
  634    conj(Eval, G1, G).
  635
  636expand_meta(I, Arity, Spec, G0, ArgPos0, Eval, G, [P|PT], M, MList, Term) :-
  637    I =< Arity,
  638    !,
  639    arg_pos(ArgPos0, P0, PT0),
  640    arg(I, Spec, Meta),
  641    arg(I, G0, A0),
  642    arg(I, G, A),
  643    expand_meta_arg(Meta, A0, P0, EvalA, A, P, M, MList, Term),
  644    I2 is I + 1,
  645    expand_meta(I2, Arity, Spec, G0, PT0, EvalB, G, PT, M, MList, Term),
  646    conj(EvalA, EvalB, Eval).
  647expand_meta(_, _, _, _, _, true, _, [], _, _, _).
  648
  649arg_pos(List, _, _) :- var(List), !.    % no position info
  650arg_pos([H|T], H, T) :- !.              % argument list
  651arg_pos([], _, []).                     % new has more
  652
  653mapex([], _).
  654mapex([E|L], E) :- mapex(L, E).

 extended_pos(+Pos0, +N, -Pos) is det

extended_pos(-Pos0, +N, +Pos) is det

Pos is the result of adding N extra positions to Pos0.

  661extended_pos(Var, _, Var) :-
  662    var(Var),
  663    !.
  664extended_pos(parentheses_term_position(O,C,Pos0),
  665             N,
  666             parentheses_term_position(O,C,Pos)) :-
  667    !,
  668    extended_pos(Pos0, N, Pos).
  669extended_pos(term_position(F,T,FF,FT,Args),
  670             _,
  671             term_position(F,T,FF,FT,Args)) :-
  672    var(Args),
  673    !.
  674extended_pos(term_position(F,T,FF,FT,Args0),
  675             N,
  676             term_position(F,T,FF,FT,Args)) :-
  677    length(Ex, N),
  678    mapex(Ex, T-T),
  679    '$append'(Args0, Ex, Args),
  680    !.
  681extended_pos(F-T,
  682             N,
  683             term_position(F,T,F,T,Ex)) :-
  684    !,
  685    length(Ex, N),
  686    mapex(Ex, T-T).
  687extended_pos(Pos, N, Pos) :-
  688    '$print_message'(warning, extended_pos(Pos, N)).

 expand_meta_arg(+MetaSpec, +Arg0, +ArgPos0, -Eval, -Arg, -ArgPos, +ModuleList, +Term) is det

Goal expansion for a meta-argument.

Arguments:

Eval	- is always true. Future versions should allow for functions on such positions. This requires proper position management for function expansion.

  699expand_meta_arg(0, A0, PA0, true, A, PA, M, MList, Term) :-
  700    !,
  701    expand_goal(A0, PA0, A1, PA, M, MList, Term),
  702    compile_meta_call(A1, A, M, Term).
  703expand_meta_arg(N, A0, P0, true, A, P, M, MList, Term) :-
  704    integer(N), callable(A0),
  705    replace_functions(A0, true, _, M),
  706    !,
  707    length(Ex, N),
  708    mark_vars_non_fresh(Ex),
  709    extend_arg_pos(A0, P0, Ex, A1, PA1),
  710    expand_goal(A1, PA1, A2, PA2, M, MList, Term),
  711    compile_meta_call(A2, A3, M, Term),
  712    term_variables(A0, VL),
  713    remove_arg_pos(A3, PA2, M, VL, Ex, A, P).
  714expand_meta_arg(^, A0, PA0, true, A, PA, M, MList, Term) :-
  715    replace_functions(A0, true, _, M),
  716    !,
  717    expand_setof_goal(A0, PA0, A, PA, M, MList, Term).
  718expand_meta_arg(S, A0, _PA0, Eval, A, _PA, M, _MList, _Term) :-
  719    replace_functions(A0, Eval, A, M), % TBD: pass positions
  720    (   Eval == true
  721    ->  true
  722    ;   same_functor(A0, A)
  723    ->  true
  724    ;   meta_arg(S)
  725    ->  throw(error(context_error(function, meta_arg(S)), _))
  726    ;   true
  727    ).
  728
  729same_functor(T1, T2) :-
  730    compound(T1),
  731    !,
  732    compound(T2),
  733    compound_name_arity(T1, N, A),
  734    compound_name_arity(T2, N, A).
  735same_functor(T1, T2) :-
  736    atom(T1),
  737    T1 == T2.
  738
  739variant_sha1_nat(Term, Hash) :-
  740    copy_term_nat(Term, TNat),
  741    variant_sha1(TNat, Hash).
  742
  743wrap_meta_arguments(A0, M, VL, Ex, A) :-
  744    '$append'(VL, Ex, AV),
  745    variant_sha1_nat(A0+AV, Hash),
  746    atom_concat('__aux_wrapper_', Hash, AuxName),
  747    H =.. [AuxName|AV],
  748    compile_auxiliary_clause(M, (H :- A0)),
  749    A =.. [AuxName|VL].

 extend_arg_pos(+A0, +P0, +Ex, -A, -P) is det

Adds extra arguments Ex to A0, and extra subterm positions to P for such arguments.

  756extend_arg_pos(A, P, _, A, P) :-
  757    var(A),
  758    !.
  759extend_arg_pos(M:A0, P0, Ex, M:A, P) :-
  760    !,
  761    f2_pos(P0, PM, PA0, P, PM, PA),
  762    extend_arg_pos(A0, PA0, Ex, A, PA).
  763extend_arg_pos(A0, P0, Ex, A, P) :-
  764    callable(A0),
  765    !,
  766    extend_term(A0, Ex, A),
  767    length(Ex, N),
  768    extended_pos(P0, N, P).
  769extend_arg_pos(A, P, _, A, P).
  770
  771extend_term(Atom, Extra, Term) :-
  772    atom(Atom),
  773    !,
  774    Term =.. [Atom|Extra].
  775extend_term(Term0, Extra, Term) :-
  776    compound_name_arguments(Term0, Name, Args0),
  777    '$append'(Args0, Extra, Args),
  778    compound_name_arguments(Term, Name, Args).

 remove_arg_pos(+A0, +P0, +M, +Ex, +VL, -A, -P) is det

Removes the Ex arguments from A0 and the respective extra positions from P0. Note that if they are not at the end, a wrapper with the elements of VL as arguments is generated to put them in order.

See also

- wrap_meta_arguments/5

  789remove_arg_pos(A, P, _, _, _, A, P) :-
  790    var(A),
  791    !.
  792remove_arg_pos(M:A0, P0, _, VL, Ex, M:A, P) :-
  793    !,
  794    f2_pos(P, PM, PA0, P0, PM, PA),
  795    remove_arg_pos(A0, PA, M, VL, Ex, A, PA0).
  796remove_arg_pos(A0, P0, M, VL, Ex0, A, P) :-
  797    callable(A0),
  798    !,
  799    length(Ex0, N),
  800    (   A0 =.. [F|Args],
  801        length(Ex, N),
  802        '$append'(Args0, Ex, Args),
  803        Ex==Ex0
  804    ->  extended_pos(P, N, P0),
  805        A =.. [F|Args0]
  806    ;   M \== [],
  807        wrap_meta_arguments(A0, M, VL, Ex0, A),
  808        wrap_meta_pos(P0, P)
  809    ).
  810remove_arg_pos(A, P, _, _, _, A, P).
  811
  812wrap_meta_pos(P0, P) :-
  813    (   nonvar(P0)
  814    ->  P = term_position(F,T,_,_,_),
  815        atomic_pos(P0, F-T)
  816    ;   true
  817    ).
  818
  819has_meta_arg(Head) :-
  820    arg(_, Head, Arg),
  821    direct_call_meta_arg(Arg),
  822    !.
  823
  824direct_call_meta_arg(I) :- integer(I).
  825direct_call_meta_arg(^).
  826
  827meta_arg(:).
  828meta_arg(//).
  829meta_arg(I) :- integer(I).
  830
  831expand_setof_goal(Var, Pos, Var, Pos, _, _, _) :-
  832    var(Var),
  833    !.
  834expand_setof_goal(V^G, P0, V^EG, P, M, MList, Term) :-
  835    !,
  836    f2_pos(P0, PA0, PB, P, PA, PB),
  837    expand_setof_goal(G, PA0, EG, PA, M, MList, Term).
  838expand_setof_goal(M0:G, P0, M0:EG, P, M, MList, Term) :-
  839    !,
  840    f2_pos(P0, PA0, PB, P, PA, PB),
  841    expand_setof_goal(G, PA0, EG, PA, M, MList, Term).
  842expand_setof_goal(G, P0, EG, P, M, MList, Term) :-
  843    !,
  844    expand_goal(G, P0, EG0, P, M, MList, Term),
  845    compile_meta_call(EG0, EG, M, Term).            % TBD: Pos?

 call_goal_expansion(+ExpandModules, +Goal0, ?Pos0, -Goal, -Pos) is semidet

Succeeds if the context has a module that defines goal_expansion/2 this rule succeeds and Goal is not equal to Goal0. Note that the translator is called recursively until a fixed-point is reached.

  856call_goal_expansion(MList, G0, P0, G, P) :-
  857    current_prolog_flag(sandboxed_load, false),
  858    !,
  859    (   '$member'(M-Preds, MList),
  860        '$member'(Pred, Preds),
  861        (   Pred == goal_expansion/4
  862        ->  M:goal_expansion(G0, P0, G, P)
  863        ;   M:goal_expansion(G0, G),
  864            P = P0
  865        ),
  866        G0 \== G
  867    ->  true
  868    ).
  869call_goal_expansion(MList, G0, P0, G, P) :-
  870    (   '$member'(M-Preds, MList),
  871        '$member'(Pred, Preds),
  872        (   Pred == goal_expansion/4
  873        ->  Expand = M:goal_expansion(G0, P0, G, P)
  874        ;   Expand = M:goal_expansion(G0, G)
  875        ),
  876        allowed_expansion(Expand),
  877        call(Expand),
  878        G0 \== G
  879    ->  true
  880    ).

 allowed_expansion(:Goal) is semidet

Calls prolog:sandbox_allowed_expansion(:Goal) prior to calling Goal for the purpose of term or goal expansion. This hook can prevent the expansion to take place by raising an exception.

throws

- exceptions from prolog:sandbox_allowed_expansion/1.

  890:- multifile
  891    prolog:sandbox_allowed_expansion/1.  892
  893allowed_expansion(QGoal) :-
  894    strip_module(QGoal, M, Goal),
  895    catch(prolog:sandbox_allowed_expansion(M:Goal), E, true),
  896    (   var(E)
  897    ->  fail
  898    ;   !,
  899        print_message(error, E),
  900        fail
  901    ).
  902allowed_expansion(_).
  903
  904
  905                 /*******************************
  906                 *      FUNCTIONAL NOTATION     *
  907                 *******************************/

 expand_functions(+G0, +P0, -G, -P, +M, +MList, +Term) is det

Expand functional notation and arithmetic functions.

Arguments:

MList

- is the list of modules defining goal_expansion/2 in the expansion context.

  916expand_functions(G0, P0, G, P, M, MList, Term) :-
  917    expand_functional_notation(G0, P0, G1, P1, M, MList, Term),
  918    (   expand_arithmetic(G1, P1, G, P, Term)
  919    ->  true
  920    ;   G = G1,
  921        P = P1
  922    ).

 expand_functional_notation(+G0, +P0, -G, -P, +M, +MList, +Term) is det

To be done

- : position logic

- : make functions module-local

  929expand_functional_notation(G0, P0, G, P, M, _MList, _Term) :-
  930    contains_functions(G0),
  931    replace_functions(G0, P0, Eval, EvalPos, G1, G1Pos, M),
  932    Eval \== true,
  933    !,
  934    wrap_var(G1, G1Pos, G2, G2Pos),
  935    conj(Eval, EvalPos, G2, G2Pos, G, P).
  936expand_functional_notation(G, P, G, P, _, _, _).
  937
  938wrap_var(G, P, G, P) :-
  939    nonvar(G),
  940    !.
  941wrap_var(G, P0, call(G), P) :-
  942    (   nonvar(P0)
  943    ->  P = term_position(F,T,F,T,[P0]),
  944        atomic_pos(P0, F-T)
  945    ;   true
  946    ).

 contains_functions(@Term) is semidet

True when Term contains a function reference.

  952contains_functions(Term) :-
  953    \+ \+ ( '$factorize_term'(Term, Skeleton, Assignments),
  954            (   contains_functions2(Skeleton)
  955            ;   contains_functions2(Assignments)
  956            )).
  957
  958contains_functions2(Term) :-
  959    compound(Term),
  960    (   function(Term, _)
  961    ->  true
  962    ;   arg(_, Term, Arg),
  963        contains_functions2(Arg)
  964    ->  true
  965    ).

 replace_functions(+GoalIn, +PosIn, -Eval, -EvalPos, -GoalOut, -PosOut, +ContextTerm) is det

To be done

- Proper propagation of list, dict and brace term positions.

  974:- public
  975    replace_functions/4.            % used in dicts.pl
  976
  977replace_functions(GoalIn, Eval, GoalOut, Context) :-
  978    replace_functions(GoalIn, _, Eval, _, GoalOut, _, Context).
  979
  980replace_functions(Var, Pos, true, _, Var, Pos, _Ctx) :-
  981    var(Var),
  982    !.
  983replace_functions(F, FPos, Eval, EvalPos, Var, VarPos, Ctx) :-
  984    function(F, Ctx),
  985    !,
  986    compound_name_arity(F, Name, Arity),
  987    PredArity is Arity+1,
  988    compound_name_arity(G, Name, PredArity),
  989    arg(PredArity, G, Var),
  990    extend_1_pos(FPos, FArgPos, GPos, GArgPos, VarPos),
  991    map_functions(0, Arity, F, FArgPos, G, GArgPos, Eval0, EP0, Ctx),
  992    conj(Eval0, EP0, G, GPos, Eval, EvalPos).
  993replace_functions(Term0, Term0Pos, Eval, EvalPos, Term, TermPos, Ctx) :-
  994    compound(Term0),
  995    !,
  996    compound_name_arity(Term0, Name, Arity),
  997    compound_name_arity(Term, Name, Arity),
  998    f_pos(Term0Pos, Args0Pos, TermPos, ArgsPos),
  999    map_functions(0, Arity,
 1000                  Term0, Args0Pos, Term, ArgsPos, Eval, EvalPos, Ctx).
 1001replace_functions(Term, Pos, true, _, Term, Pos, _).

 map_functions(+Arg, +Arity, +TermIn, +ArgInPos, -Term, -ArgPos, -Eval, -EvalPos, +Context)

 1008map_functions(Arity, Arity, _, LPos0, _, LPos, true, _, _) :-
 1009    !,
 1010    pos_nil(LPos0, LPos).
 1011map_functions(I0, Arity, Term0, LPos0, Term, LPos, Eval, EP, Ctx) :-
 1012    pos_list(LPos0, AP0, APT0, LPos, AP, APT),
 1013    I is I0+1,
 1014    arg(I, Term0, Arg0),
 1015    arg(I, Term, Arg),
 1016    replace_functions(Arg0, AP0, Eval0, EP0, Arg, AP, Ctx),
 1017    map_functions(I, Arity, Term0, APT0, Term, APT, Eval1, EP1, Ctx),
 1018    conj(Eval0, EP0, Eval1, EP1, Eval, EP).
 1019
 1020conj(true, X, X) :- !.
 1021conj(X, true, X) :- !.
 1022conj(X, Y, (X,Y)).
 1023
 1024conj(true, _, X, P, X, P) :- !.
 1025conj(X, P, true, _, X, P) :- !.
 1026conj(X, PX, Y, PY, (X,Y), _) :-
 1027    var(PX), var(PY),
 1028    !.
 1029conj(X, PX, Y, PY, (X,Y), P) :-
 1030    P = term_position(F,T,FF,FT,[PX,PY]),
 1031    atomic_pos(PX, F-FF),
 1032    atomic_pos(PY, FT-T).

 function(?Term, +Context)

True if function expansion needs to be applied for the given term.

 1039function(.(_,_), _) :- \+ functor([_|_], ., _).
 1040
 1041
 1042                 /*******************************
 1043                 *          ARITHMETIC          *
 1044                 *******************************/

 expand_arithmetic(+G0, +P0, -G, -P, +Term) is semidet

Expand arithmetic expressions in is/2, (>)/2, etc. This is currently a dummy. The idea is to call rules similar to goal_expansion/2,4 that allow for rewriting an arithmetic expression. The system rules will perform evaluation of constant expressions.

 1054expand_arithmetic(_G0, _P0, _G, _P, _Term) :- fail.
 1055
 1056
 1057                 /*******************************
 1058                 *        POSITION LOGIC        *
 1059                 *******************************/

 f2_pos(?TermPos0, ?PosArg10, ?PosArg20, ?TermPos, ?PosArg1, ?PosArg2) is det

 f1_pos(?TermPos0, ?PosArg10, ?TermPos, ?PosArg1) is det

 f_pos(?TermPos0, ?PosArgs0, ?TermPos, ?PosArgs) is det

 atomic_pos(?TermPos0, -AtomicPos) is det

Position progapation routines.

 1069f2_pos(Var, _, _, _, _, _) :-
 1070    var(Var),
 1071    !.
 1072f2_pos(term_position(F,T,FF,FT,[A10,A20]), A10, A20,
 1073       term_position(F,T,FF,FT,[A1, A2 ]), A1,  A2) :- !.
 1074f2_pos(parentheses_term_position(O,C,Pos0), A10, A20,
 1075       parentheses_term_position(O,C,Pos),  A1,  A2) :-
 1076    !,
 1077    f2_pos(Pos0, A10, A20, Pos, A1, A2).
 1078f2_pos(Pos, _, _, _, _, _) :-
 1079    expected_layout(f2, Pos).
 1080
 1081f1_pos(Var, _, _, _) :-
 1082    var(Var),
 1083    !.
 1084f1_pos(term_position(F,T,FF,FT,[A10]), A10,
 1085       term_position(F,T,FF,FT,[A1 ]),  A1) :- !.
 1086f1_pos(parentheses_term_position(O,C,Pos0), A10,
 1087       parentheses_term_position(O,C,Pos),  A1) :-
 1088    !,
 1089    f1_pos(Pos0, A10, Pos, A1).
 1090f1_pos(Pos, _, _, _) :-
 1091    expected_layout(f1, Pos).
 1092
 1093f_pos(Var, _, _, _) :-
 1094    var(Var),
 1095    !.
 1096f_pos(term_position(F,T,FF,FT,ArgPos0), ArgPos0,
 1097      term_position(F,T,FF,FT,ArgPos),  ArgPos) :- !.
 1098f_pos(parentheses_term_position(O,C,Pos0), A10,
 1099      parentheses_term_position(O,C,Pos),  A1) :-
 1100    !,
 1101    f_pos(Pos0, A10, Pos, A1).
 1102f_pos(Pos, _, _, _) :-
 1103    expected_layout(compound, Pos).
 1104
 1105atomic_pos(Pos, _) :-
 1106    var(Pos),
 1107    !.
 1108atomic_pos(Pos, F-T) :-
 1109    arg(1, Pos, F),
 1110    arg(2, Pos, T).

 pos_nil(+Nil, -Nil) is det

 pos_list(+List0, -H0, -T0, -List, -H, -T) is det

Position propagation for lists.

 1117pos_nil(Var, _) :- var(Var), !.
 1118pos_nil([], []) :- !.
 1119pos_nil(Pos, _) :-
 1120    expected_layout(nil, Pos).
 1121
 1122pos_list(Var, _, _, _, _, _) :- var(Var), !.
 1123pos_list([H0|T0], H0, T0, [H|T], H, T) :- !.
 1124pos_list(Pos, _, _, _, _, _) :-
 1125    expected_layout(list, Pos).

 extend_1_pos(+FunctionPos, -FArgPos, -EvalPos, -EArgPos, -VarPos)

Deal with extending a function to include the return value.

 1131extend_1_pos(Pos, _, _, _, _) :-
 1132    var(Pos),
 1133    !.
 1134extend_1_pos(term_position(F,T,FF,FT,FArgPos), FArgPos,
 1135             term_position(F,T,FF,FT,GArgPos), GArgPos0,
 1136             FT-FT1) :-
 1137    integer(FT),
 1138    !,
 1139    FT1 is FT+1,
 1140    '$same_length'(FArgPos, GArgPos0),
 1141    '$append'(GArgPos0, [FT-FT1], GArgPos).
 1142extend_1_pos(F-T, [],
 1143             term_position(F,T,F,T,[T-T1]), [],
 1144             T-T1) :-
 1145    integer(T),
 1146    !,
 1147    T1 is T+1.
 1148extend_1_pos(Pos, _, _, _, _) :-
 1149    expected_layout(callable, Pos).
 1150
 1151'$same_length'(List, List) :-
 1152    var(List),
 1153    !.
 1154'$same_length'([], []).
 1155'$same_length'([_|T0], [_|T]) :-
 1156    '$same_length'(T0, T).

 expected_layout(+Expected, +Found)

Print a message if the layout term does not satisfy our expectations. This means that the transformation requires support from term_expansion/4 and/or goal_expansion/4 to achieve proper source location information.

 1166:- create_prolog_flag(debug_term_position, false, []). 1167
 1168expected_layout(Expected, Pos) :-
 1169    current_prolog_flag(debug_term_position, true),
 1170    !,
 1171    '$print_message'(warning, expected_layout(Expected, Pos)).
 1172expected_layout(_, _).
 1173
 1174
 1175                 /*******************************
 1176                 *    SIMPLIFICATION ROUTINES   *
 1177                 *******************************/

 simplify(+ControlIn, +Pos0, -ControlOut, -Pos) is det

Simplify control structures

To be done

- Much more analysis

- Turn this into a separate module

 1186simplify(Control, P, Control, P) :-
 1187    current_prolog_flag(optimise, false),
 1188    !.
 1189simplify(Control, P0, Simple, P) :-
 1190    simple(Control, P0, Simple, P),
 1191    !.
 1192simplify(Control, P, Control, P).

 simple(+Goal, +GoalPos, -Simple, -SimplePos)

Simplify a control structure. Note that we do not simplify (A;fail). Logically, this is the same as A if A is not _->_ or _*->_, but the choice point may be created on purpose.

 1201simple((X,Y), P0, Conj, P) :-
 1202    (   true(X)
 1203    ->  Conj = Y,
 1204        f2_pos(P0, _, P, _, _, _)
 1205    ;   false(X)
 1206    ->  Conj = fail,
 1207        f2_pos(P0, P1, _, _, _, _),
 1208        atomic_pos(P1, P)
 1209    ;   true(Y)
 1210    ->  Conj = X,
 1211        f2_pos(P0, P, _, _, _, _)
 1212    ).
 1213simple((I->T;E), P0, ITE, P) :-         % unification with _->_ is fine
 1214    (   true(I)                     % because nothing happens if I and T
 1215    ->  ITE = T,                    % are unbound.
 1216        f2_pos(P0, P1, _, _, _, _),
 1217        f2_pos(P1, _, P, _, _, _)
 1218    ;   false(I)
 1219    ->  ITE = E,
 1220        f2_pos(P0, _, P, _, _, _)
 1221    ).
 1222simple((X;Y), P0, Or, P) :-
 1223    false(X),
 1224    Or = Y,
 1225    f2_pos(P0, _, P, _, _, _).
 1226
 1227true(X) :-
 1228    nonvar(X),
 1229    eval_true(X).
 1230
 1231false(X) :-
 1232    nonvar(X),
 1233    eval_false(X).

 eval_true(+Goal) is semidet

 eval_false(+Goal) is semidet

 1239eval_true(true).
 1240eval_true(otherwise).
 1241
 1242eval_false(fail).
 1243eval_false(false).
 1244
 1245
 1246                 /*******************************
 1247                 *         META CALLING         *
 1248                 *******************************/
 1249
 1250:- create_prolog_flag(compile_meta_arguments, false, [type(atom)]).

 compile_meta_call(+CallIn, -CallOut, +Module, +Term) is det

Compile (complex) meta-calls into a clause.

 1256compile_meta_call(CallIn, CallIn, _, Term) :-
 1257    var(Term),
 1258    !.                   % explicit call; no context
 1259compile_meta_call(CallIn, CallIn, _, _) :-
 1260    var(CallIn),
 1261    !.
 1262compile_meta_call(CallIn, CallIn, _, _) :-
 1263    (   current_prolog_flag(compile_meta_arguments, false)
 1264    ;   current_prolog_flag(xref, true)
 1265    ),
 1266    !.
 1267compile_meta_call(CallIn, CallIn, _, _) :-
 1268    strip_module(CallIn, _, Call),
 1269    (   is_aux_meta(Call)
 1270    ;   \+ control(Call),
 1271        (   '$c_current_predicate'(_, system:Call),
 1272            \+ current_prolog_flag(compile_meta_arguments, always)
 1273        ;   current_prolog_flag(compile_meta_arguments, control)
 1274        )
 1275    ),
 1276    !.
 1277compile_meta_call(M:CallIn, CallOut, _, Term) :-
 1278    !,
 1279    (   atom(M), callable(CallIn)
 1280    ->  compile_meta_call(CallIn, CallOut, M, Term)
 1281    ;   CallOut = M:CallIn
 1282    ).
 1283compile_meta_call(CallIn, CallOut, Module, Term) :-
 1284    compile_meta(CallIn, CallOut, Module, Term, Clause),
 1285    compile_auxiliary_clause(Module, Clause).
 1286
 1287compile_auxiliary_clause(Module, Clause) :-
 1288    Clause = (Head:-Body),
 1289    '$current_source_module'(SM),
 1290    (   predicate_property(SM:Head, defined)
 1291    ->  true
 1292    ;   SM == Module
 1293    ->  compile_aux_clauses([Clause])
 1294    ;   compile_aux_clauses([Head:-Module:Body])
 1295    ).
 1296
 1297control((_,_)).
 1298control((_;_)).
 1299control((_->_)).
 1300control((_*->_)).
 1301control(\+(_)).
 1302
 1303is_aux_meta(Term) :-
 1304    callable(Term),
 1305    functor(Term, Name, _),
 1306    sub_atom(Name, 0, _, _, '__aux_meta_call_').
 1307
 1308compile_meta(CallIn, CallOut, M, Term, (CallOut :- Body)) :-
 1309    term_variables(Term, AllVars),
 1310    term_variables(CallIn, InVars),
 1311    intersection_eq(InVars, AllVars, HeadVars),
 1312    variant_sha1(CallIn+HeadVars, Hash),
 1313    atom_concat('__aux_meta_call_', Hash, AuxName),
 1314    expand_goal(CallIn, _Pos0, Body, _Pos, M, [], (CallOut:-CallIn)),
 1315    length(HeadVars, Arity),
 1316    (   Arity > 256                 % avoid 1024 arity limit
 1317    ->  HeadArgs = [v(HeadVars)]
 1318    ;   HeadArgs = HeadVars
 1319    ),
 1320    CallOut =.. [AuxName|HeadArgs].

 intersection_eq(+Small, +Big, -Shared) is det

Shared are the variables in Small that also appear in Big. The variables in Shared are in the same order as Small.

 1327intersection_eq([], _, []).
 1328intersection_eq([H|T0], L, List) :-
 1329    (   member_eq(H, L)
 1330    ->  List = [H|T],
 1331        intersection_eq(T0, L, T)
 1332    ;   intersection_eq(T0, L, List)
 1333    ).
 1334
 1335member_eq(E, [H|T]) :-
 1336    (   E == H
 1337    ->  true
 1338    ;   member_eq(E, T)
 1339    ).
 1340
 1341                 /*******************************
 1342                 *            RENAMING          *
 1343                 *******************************/
 1344
 1345:- multifile
 1346    prolog:rename_predicate/2. 1347
 1348rename(Var, Var) :-
 1349    var(Var),
 1350    !.
 1351rename(end_of_file, end_of_file) :- !.
 1352rename(Terms0, Terms) :-
 1353    is_list(Terms0),
 1354    !,
 1355    '$current_source_module'(M),
 1356    rename_preds(Terms0, Terms, M).
 1357rename(Term0, Term) :-
 1358    '$current_source_module'(M),
 1359    rename(Term0, Term, M),
 1360    !.
 1361rename(Term, Term).
 1362
 1363rename_preds([], [], _).
 1364rename_preds([H0|T0], [H|T], M) :-
 1365    (   rename(H0, H, M)
 1366    ->  true
 1367    ;   H = H0
 1368    ),
 1369    rename_preds(T0, T, M).
 1370
 1371rename(Var, Var, _) :-
 1372    var(Var),
 1373    !.
 1374rename(M:Term0, M:Term, M0) :-
 1375    !,
 1376    (   M = '$source_location'(_File, _Line)
 1377    ->  rename(Term0, Term, M0)
 1378    ;   rename(Term0, Term, M)
 1379    ).
 1380rename((Head0 :- Body), (Head :- Body), M) :-
 1381    !,
 1382    rename_head(Head0, Head, M).
 1383rename((:-_), _, _) :-
 1384    !,
 1385    fail.
 1386rename(Head0, Head, M) :-
 1387    rename_head(Head0, Head, M).
 1388
 1389rename_head(Var, Var, _) :-
 1390    var(Var),
 1391    !.
 1392rename_head(M:Term0, M:Term, _) :-
 1393    !,
 1394    rename_head(Term0, Term, M).
 1395rename_head(Head0, Head, M) :-
 1396    prolog:rename_predicate(M:Head0, M:Head).
 1397
 1398
 1399                 /*******************************
 1400                 *      :- IF ... :- ENDIF      *
 1401                 *******************************/
 1402
 1403:- thread_local
 1404    '$include_code'/3. 1405
 1406'$including' :-
 1407    '$include_code'(X, _, _),
 1408    !,
 1409    X == true.
 1410'$including'.
 1411
 1412cond_compilation((:- if(G)), []) :-
 1413    source_location(File, Line),
 1414    (   '$including'
 1415    ->  (   catch('$eval_if'(G), E, (print_message(error, E), fail))
 1416        ->  asserta('$include_code'(true, File, Line))
 1417        ;   asserta('$include_code'(false, File, Line))
 1418        )
 1419    ;   asserta('$include_code'(else_false, File, Line))
 1420    ).
 1421cond_compilation((:- elif(G)), []) :-
 1422    source_location(File, Line),
 1423    (   clause('$include_code'(Old, OF, _), _, Ref)
 1424    ->  same_source(File, OF, elif),
 1425        erase(Ref),
 1426        (   Old == true
 1427        ->  asserta('$include_code'(else_false, File, Line))
 1428        ;   Old == false,
 1429            catch('$eval_if'(G), E, (print_message(error, E), fail))
 1430        ->  asserta('$include_code'(true, File, Line))
 1431        ;   asserta('$include_code'(Old, File, Line))
 1432        )
 1433    ;   throw(error(conditional_compilation_error(no_if, elif), _))
 1434    ).
 1435cond_compilation((:- else), []) :-
 1436    source_location(File, Line),
 1437    (   clause('$include_code'(X, OF, _), _, Ref)
 1438    ->  same_source(File, OF, else),
 1439        erase(Ref),
 1440        (   X == true
 1441        ->  X2 = false
 1442        ;   X == false
 1443        ->  X2 = true
 1444        ;   X2 = X
 1445        ),
 1446        asserta('$include_code'(X2, File, Line))
 1447    ;   throw(error(conditional_compilation_error(no_if, else), _))
 1448    ).
 1449cond_compilation(end_of_file, end_of_file) :-   % TBD: Check completeness
 1450    !,
 1451    source_location(File, _),
 1452    (   clause('$include_code'(_, OF, OL), _)
 1453    ->  (   File == OF
 1454        ->  throw(error(conditional_compilation_error(
 1455                            unterminated,OF:OL), _))
 1456        ;   true
 1457        )
 1458    ;   true
 1459    ).
 1460cond_compilation((:- endif), []) :-
 1461    !,
 1462    source_location(File, _),
 1463    (   (   clause('$include_code'(_, OF, _), _, Ref)
 1464        ->  same_source(File, OF, endif),
 1465            erase(Ref)
 1466        )
 1467    ->  true
 1468    ;   throw(error(conditional_compilation_error(no_if, endif), _))
 1469    ).
 1470cond_compilation(_, []) :-
 1471    \+ '$including'.
 1472
 1473same_source(File, File, _) :- !.
 1474same_source(_,    _,    Op) :-
 1475    throw(error(conditional_compilation_error(no_if, Op), _)).
 1476
 1477
 1478'$eval_if'(G) :-
 1479    expand_goal(G, G2),
 1480    '$current_source_module'(Module),
 1481    Module:G2