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