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