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