View source with formatted comments or as raw
    1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  1985-2021, 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/*
   39Consult, derivates and basic things.   This  module  is  loaded  by  the
   40C-written  bootstrap  compiler.
   41
   42The $:- directive  is  executed  by  the  bootstrap  compiler,  but  not
   43inserted  in  the  intermediate  code  file.   Used  to print diagnostic
   44messages and start the Prolog defined compiler for  the  remaining  boot
   45modules.
   46
   47If you want  to  debug  this  module,  put  a  '$:-'(trace).   directive
   48somewhere.   The  tracer will work properly under boot compilation as it
   49will use the C defined write predicate  to  print  goals  and  does  not
   50attempt to call the Prolog defined trace interceptor.
   51*/
   52
   53                /********************************
   54                *    LOAD INTO MODULE SYSTEM    *
   55                ********************************/
   56
   57:- '$set_source_module'(system).   58
   59'$boot_message'(_Format, _Args) :-
   60    current_prolog_flag(verbose, silent),
   61    !.
   62'$boot_message'(Format, Args) :-
   63    format(Format, Args),
   64    !.
   65
   66'$:-'('$boot_message'('Loading boot file ...~n', [])).
   67
   68
   69                /********************************
   70                *          DIRECTIVES           *
   71                *********************************/
   72
   73:- meta_predicate
   74    dynamic(:),
   75    multifile(:),
   76    public(:),
   77    module_transparent(:),
   78    discontiguous(:),
   79    volatile(:),
   80    thread_local(:),
   81    noprofile(:),
   82    non_terminal(:),
   83    '$clausable'(:),
   84    '$iso'(:),
   85    '$hide'(:).   86
   87%!  dynamic(+Spec) is det.
   88%!  multifile(+Spec) is det.
   89%!  module_transparent(+Spec) is det.
   90%!  discontiguous(+Spec) is det.
   91%!  volatile(+Spec) is det.
   92%!  thread_local(+Spec) is det.
   93%!  noprofile(+Spec) is det.
   94%!  public(+Spec) is det.
   95%!  non_terminal(+Spec) is det.
   96%
   97%   Predicate versions of standard  directives   that  set predicate
   98%   attributes. These predicates bail out with an error on the first
   99%   failure (typically permission errors).
  100
  101%!  '$iso'(+Spec) is det.
  102%
  103%   Set the ISO  flag.  This  defines   that  the  predicate  cannot  be
  104%   redefined inside a module.
  105
  106%!  '$clausable'(+Spec) is det.
  107%
  108%   Specify that we can run  clause/2  on   a  predicate,  even if it is
  109%   static. ISO specifies that `public` also   plays  this role. in SWI,
  110%   `public` means that the predicate can be   called, even if we cannot
  111%   find a reference to it.
  112
  113%!  '$hide'(+Spec) is det.
  114%
  115%   Specify that the predicate cannot be seen in the debugger.
  116
  117dynamic(Spec)            :- '$set_pattr'(Spec, pred, dynamic(true)).
  118multifile(Spec)          :- '$set_pattr'(Spec, pred, multifile(true)).
  119module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)).
  120discontiguous(Spec)      :- '$set_pattr'(Spec, pred, discontiguous(true)).
  121volatile(Spec)           :- '$set_pattr'(Spec, pred, volatile(true)).
  122thread_local(Spec)       :- '$set_pattr'(Spec, pred, thread_local(true)).
  123noprofile(Spec)          :- '$set_pattr'(Spec, pred, noprofile(true)).
  124public(Spec)             :- '$set_pattr'(Spec, pred, public(true)).
  125non_terminal(Spec)       :- '$set_pattr'(Spec, pred, non_terminal(true)).
  126det(Spec)                :- '$set_pattr'(Spec, pred, det(true)).
  127'$iso'(Spec)             :- '$set_pattr'(Spec, pred, iso(true)).
  128'$clausable'(Spec)       :- '$set_pattr'(Spec, pred, clausable(true)).
  129'$hide'(Spec)            :- '$set_pattr'(Spec, pred, trace(false)).
  130
  131'$set_pattr'(M:Pred, How, Attr) :-
  132    '$set_pattr'(Pred, M, How, Attr).
  133
  134%!  '$set_pattr'(+Spec, +Module, +From, +Attr)
  135%
  136%   Set predicate attributes. From is one of `pred` or `directive`.
  137
  138'$set_pattr'(X, _, _, _) :-
  139    var(X),
  140    '$uninstantiation_error'(X).
  141'$set_pattr'(as(Spec,Options), M, How, Attr0) :-
  142    !,
  143    '$attr_options'(Options, Attr0, Attr),
  144    '$set_pattr'(Spec, M, How, Attr).
  145'$set_pattr'([], _, _, _) :- !.
  146'$set_pattr'([H|T], M, How, Attr) :-           % ISO
  147    !,
  148    '$set_pattr'(H, M, How, Attr),
  149    '$set_pattr'(T, M, How, Attr).
  150'$set_pattr'((A,B), M, How, Attr) :-           % ISO and traditional
  151    !,
  152    '$set_pattr'(A, M, How, Attr),
  153    '$set_pattr'(B, M, How, Attr).
  154'$set_pattr'(M:T, _, How, Attr) :-
  155    !,
  156    '$set_pattr'(T, M, How, Attr).
  157'$set_pattr'(PI, M, _, []) :-
  158    !,
  159    '$pi_head'(M:PI, Pred),
  160    '$set_table_wrappers'(Pred).
  161'$set_pattr'(A, M, How, [O|OT]) :-
  162    !,
  163    '$set_pattr'(A, M, How, O),
  164    '$set_pattr'(A, M, How, OT).
  165'$set_pattr'(A, M, pred, Attr) :-
  166    !,
  167    Attr =.. [Name,Val],
  168    '$set_pi_attr'(M:A, Name, Val).
  169'$set_pattr'(A, M, directive, Attr) :-
  170    !,
  171    Attr =.. [Name,Val],
  172    catch('$set_pi_attr'(M:A, Name, Val),
  173          error(E, _),
  174          print_message(error, error(E, context((Name)/1,_)))).
  175
  176'$set_pi_attr'(PI, Name, Val) :-
  177    '$pi_head'(PI, Head),
  178    '$set_predicate_attribute'(Head, Name, Val).
  179
  180'$attr_options'(Var, _, _) :-
  181    var(Var),
  182    !,
  183    '$uninstantiation_error'(Var).
  184'$attr_options'((A,B), Attr0, Attr) :-
  185    !,
  186    '$attr_options'(A, Attr0, Attr1),
  187    '$attr_options'(B, Attr1, Attr).
  188'$attr_options'(Opt, Attr0, Attrs) :-
  189    '$must_be'(ground, Opt),
  190    (   '$attr_option'(Opt, AttrX)
  191    ->  (   is_list(Attr0)
  192        ->  '$join_attrs'(AttrX, Attr0, Attrs)
  193        ;   '$join_attrs'(AttrX, [Attr0], Attrs)
  194        )
  195    ;   '$domain_error'(predicate_option, Opt)
  196    ).
  197
  198'$join_attrs'([], Attrs, Attrs) :-
  199    !.
  200'$join_attrs'([H|T], Attrs0, Attrs) :-
  201    !,
  202    '$join_attrs'(H, Attrs0, Attrs1),
  203    '$join_attrs'(T, Attrs1, Attrs).
  204'$join_attrs'(Attr, Attrs, Attrs) :-
  205    memberchk(Attr, Attrs),
  206    !.
  207'$join_attrs'(Attr, Attrs, Attrs) :-
  208    Attr =.. [Name,Value],
  209    Gen =.. [Name,Existing],
  210    memberchk(Gen, Attrs),
  211    !,
  212    throw(error(conflict_error(Name, Value, Existing), _)).
  213'$join_attrs'(Attr, Attrs0, Attrs) :-
  214    '$append'(Attrs0, [Attr], Attrs).
  215
  216'$attr_option'(incremental, [incremental(true),opaque(false)]).
  217'$attr_option'(monotonic, monotonic(true)).
  218'$attr_option'(lazy, lazy(true)).
  219'$attr_option'(opaque, [incremental(false),opaque(true)]).
  220'$attr_option'(abstract(Level0), abstract(Level)) :-
  221    '$table_option'(Level0, Level).
  222'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :-
  223    '$table_option'(Level0, Level).
  224'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :-
  225    '$table_option'(Level0, Level).
  226'$attr_option'(max_answers(Level0), max_answers(Level)) :-
  227    '$table_option'(Level0, Level).
  228'$attr_option'(volatile, volatile(true)).
  229'$attr_option'(multifile, multifile(true)).
  230'$attr_option'(discontiguous, discontiguous(true)).
  231'$attr_option'(shared, thread_local(false)).
  232'$attr_option'(local, thread_local(true)).
  233'$attr_option'(private, thread_local(true)).
  234
  235'$table_option'(Value0, _Value) :-
  236    var(Value0),
  237    !,
  238    '$instantiation_error'(Value0).
  239'$table_option'(Value0, Value) :-
  240    integer(Value0),
  241    Value0 >= 0,
  242    !,
  243    Value = Value0.
  244'$table_option'(off, -1) :-
  245    !.
  246'$table_option'(false, -1) :-
  247    !.
  248'$table_option'(infinite, -1) :-
  249    !.
  250'$table_option'(Value, _) :-
  251    '$domain_error'(nonneg_or_false, Value).
  252
  253
  254%!  '$pattr_directive'(+Spec, +Module) is det.
  255%
  256%   This implements the directive version of dynamic/1, multifile/1,
  257%   etc. This version catches and prints   errors.  If the directive
  258%   specifies  multiple  predicates,  processing    after  an  error
  259%   continues with the remaining predicates.
  260
  261'$pattr_directive'(dynamic(Spec), M) :-
  262    '$set_pattr'(Spec, M, directive, dynamic(true)).
  263'$pattr_directive'(multifile(Spec), M) :-
  264    '$set_pattr'(Spec, M, directive, multifile(true)).
  265'$pattr_directive'(module_transparent(Spec), M) :-
  266    '$set_pattr'(Spec, M, directive, transparent(true)).
  267'$pattr_directive'(discontiguous(Spec), M) :-
  268    '$set_pattr'(Spec, M, directive, discontiguous(true)).
  269'$pattr_directive'(volatile(Spec), M) :-
  270    '$set_pattr'(Spec, M, directive, volatile(true)).
  271'$pattr_directive'(thread_local(Spec), M) :-
  272    '$set_pattr'(Spec, M, directive, thread_local(true)).
  273'$pattr_directive'(noprofile(Spec), M) :-
  274    '$set_pattr'(Spec, M, directive, noprofile(true)).
  275'$pattr_directive'(public(Spec), M) :-
  276    '$set_pattr'(Spec, M, directive, public(true)).
  277'$pattr_directive'(det(Spec), M) :-
  278    '$set_pattr'(Spec, M, directive, det(true)).
  279
  280%!  '$pi_head'(?PI, ?Head)
  281
  282'$pi_head'(PI, Head) :-
  283    var(PI),
  284    var(Head),
  285    '$instantiation_error'([PI,Head]).
  286'$pi_head'(M:PI, M:Head) :-
  287    !,
  288    '$pi_head'(PI, Head).
  289'$pi_head'(Name/Arity, Head) :-
  290    !,
  291    '$head_name_arity'(Head, Name, Arity).
  292'$pi_head'(Name//DCGArity, Head) :-
  293    !,
  294    (   nonvar(DCGArity)
  295    ->  Arity is DCGArity+2,
  296        '$head_name_arity'(Head, Name, Arity)
  297    ;   '$head_name_arity'(Head, Name, Arity),
  298        DCGArity is Arity - 2
  299    ).
  300'$pi_head'(PI, _) :-
  301    '$type_error'(predicate_indicator, PI).
  302
  303%!  '$head_name_arity'(+Goal, -Name, -Arity).
  304%!  '$head_name_arity'(-Goal, +Name, +Arity).
  305
  306'$head_name_arity'(Goal, Name, Arity) :-
  307    (   atom(Goal)
  308    ->  Name = Goal, Arity = 0
  309    ;   compound(Goal)
  310    ->  compound_name_arity(Goal, Name, Arity)
  311    ;   var(Goal)
  312    ->  (   Arity == 0
  313        ->  (   atom(Name)
  314            ->  Goal = Name
  315            ;   Name == []
  316            ->  Goal = Name
  317            ;   blob(Name, closure)
  318            ->  Goal = Name
  319            ;   '$type_error'(atom, Name)
  320            )
  321        ;   compound_name_arity(Goal, Name, Arity)
  322        )
  323    ;   '$type_error'(callable, Goal)
  324    ).
  325
  326:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)).  327
  328
  329                /********************************
  330                *       CALLING, CONTROL        *
  331                *********************************/
  332
  333:- noprofile((call/1,
  334              catch/3,
  335              once/1,
  336              ignore/1,
  337              call_cleanup/2,
  338              call_cleanup/3,
  339              setup_call_cleanup/3,
  340              setup_call_catcher_cleanup/4)).  341
  342:- meta_predicate
  343    ';'(0,0),
  344    ','(0,0),
  345    @(0,+),
  346    call(0),
  347    call(1,?),
  348    call(2,?,?),
  349    call(3,?,?,?),
  350    call(4,?,?,?,?),
  351    call(5,?,?,?,?,?),
  352    call(6,?,?,?,?,?,?),
  353    call(7,?,?,?,?,?,?,?),
  354    not(0),
  355    \+(0),
  356    $(0),
  357    '->'(0,0),
  358    '*->'(0,0),
  359    once(0),
  360    ignore(0),
  361    catch(0,?,0),
  362    reset(0,?,-),
  363    setup_call_cleanup(0,0,0),
  364    setup_call_catcher_cleanup(0,0,?,0),
  365    call_cleanup(0,0),
  366    call_cleanup(0,?,0),
  367    catch_with_backtrace(0,?,0),
  368    '$meta_call'(0).  369
  370:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)).  371
  372% The control structures are always compiled, both   if they appear in a
  373% clause body and if they are handed  to   call/1.  The only way to call
  374% these predicates is by means of  call/2..   In  that case, we call the
  375% hole control structure again to get it compiled by call/1 and properly
  376% deal  with  !,  etc.  Another  reason  for  having  these  things   as
  377% predicates is to be able to define   properties for them, helping code
  378% analyzers.
  379
  380(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
  381(M1:If ; M2:Then) :-    call(M1:(If ; M2:Then)).
  382(G1   , G2)       :-    call((G1   , G2)).
  383(If  -> Then)     :-    call((If  -> Then)).
  384(If *-> Then)     :-    call((If *-> Then)).
  385@(Goal,Module)    :-    @(Goal,Module).
  386
  387%!  '$meta_call'(:Goal)
  388%
  389%   Interpreted  meta-call  implementation.  By    default,   call/1
  390%   compiles its argument into  a   temporary  clause. This realises
  391%   better  performance  if  the  (complex)  goal   does  a  lot  of
  392%   backtracking  because  this   interpreted    version   needs  to
  393%   re-interpret the remainder of the goal after backtracking.
  394%
  395%   This implementation is used by  reset/3 because the continuation
  396%   cannot be captured if it contains   a  such a compiled temporary
  397%   clause.
  398
  399'$meta_call'(M:G) :-
  400    prolog_current_choice(Ch),
  401    '$meta_call'(G, M, Ch).
  402
  403'$meta_call'(Var, _, _) :-
  404    var(Var),
  405    !,
  406    '$instantiation_error'(Var).
  407'$meta_call'((A,B), M, Ch) :-
  408    !,
  409    '$meta_call'(A, M, Ch),
  410    '$meta_call'(B, M, Ch).
  411'$meta_call'((I->T;E), M, Ch) :-
  412    !,
  413    (   prolog_current_choice(Ch2),
  414        '$meta_call'(I, M, Ch2)
  415    ->  '$meta_call'(T, M, Ch)
  416    ;   '$meta_call'(E, M, Ch)
  417    ).
  418'$meta_call'((I*->T;E), M, Ch) :-
  419    !,
  420    (   prolog_current_choice(Ch2),
  421        '$meta_call'(I, M, Ch2)
  422    *-> '$meta_call'(T, M, Ch)
  423    ;   '$meta_call'(E, M, Ch)
  424    ).
  425'$meta_call'((I->T), M, Ch) :-
  426    !,
  427    (   prolog_current_choice(Ch2),
  428        '$meta_call'(I, M, Ch2)
  429    ->  '$meta_call'(T, M, Ch)
  430    ).
  431'$meta_call'((I*->T), M, Ch) :-
  432    !,
  433    prolog_current_choice(Ch2),
  434    '$meta_call'(I, M, Ch2),
  435    '$meta_call'(T, M, Ch).
  436'$meta_call'((A;B), M, Ch) :-
  437    !,
  438    (   '$meta_call'(A, M, Ch)
  439    ;   '$meta_call'(B, M, Ch)
  440    ).
  441'$meta_call'(\+(G), M, _) :-
  442    !,
  443    prolog_current_choice(Ch),
  444    \+ '$meta_call'(G, M, Ch).
  445'$meta_call'($(G), M, _) :-
  446    !,
  447    prolog_current_choice(Ch),
  448    $('$meta_call'(G, M, Ch)).
  449'$meta_call'(call(G), M, _) :-
  450    !,
  451    prolog_current_choice(Ch),
  452    '$meta_call'(G, M, Ch).
  453'$meta_call'(M:G, _, Ch) :-
  454    !,
  455    '$meta_call'(G, M, Ch).
  456'$meta_call'(!, _, Ch) :-
  457    prolog_cut_to(Ch).
  458'$meta_call'(G, M, _Ch) :-
  459    call(M:G).
  460
  461%!  call(:Closure, ?A).
  462%!  call(:Closure, ?A1, ?A2).
  463%!  call(:Closure, ?A1, ?A2, ?A3).
  464%!  call(:Closure, ?A1, ?A2, ?A3, ?A4).
  465%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5).
  466%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6).
  467%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6, ?A7).
  468%
  469%   Arity 2..8 is demanded by the   ISO standard. Higher arities are
  470%   supported, but handled by the compiler.   This  implies they are
  471%   not backed up by predicates and   analyzers  thus cannot ask for
  472%   their  properties.  Analyzers  should    hard-code  handling  of
  473%   call/2..
  474
  475:- '$iso'((call/2,
  476           call/3,
  477           call/4,
  478           call/5,
  479           call/6,
  480           call/7,
  481           call/8)).  482
  483call(Goal) :-                           % make these available as predicates
  484    Goal.
  485call(Goal, A) :-
  486    call(Goal, A).
  487call(Goal, A, B) :-
  488    call(Goal, A, B).
  489call(Goal, A, B, C) :-
  490    call(Goal, A, B, C).
  491call(Goal, A, B, C, D) :-
  492    call(Goal, A, B, C, D).
  493call(Goal, A, B, C, D, E) :-
  494    call(Goal, A, B, C, D, E).
  495call(Goal, A, B, C, D, E, F) :-
  496    call(Goal, A, B, C, D, E, F).
  497call(Goal, A, B, C, D, E, F, G) :-
  498    call(Goal, A, B, C, D, E, F, G).
  499
  500%!  not(:Goal) is semidet.
  501%
  502%   Pre-ISO version of \+/1. Note that  some systems define not/1 as
  503%   a logically more sound version of \+/1.
  504
  505not(Goal) :-
  506    \+ Goal.
  507
  508%!  \+(:Goal) is semidet.
  509%
  510%   Predicate version that allows for meta-calling.
  511
  512\+ Goal :-
  513    \+ Goal.
  514
  515%!  once(:Goal) is semidet.
  516%
  517%   ISO predicate, acting as call((Goal, !)).
  518
  519once(Goal) :-
  520    Goal,
  521    !.
  522
  523%!  ignore(:Goal) is det.
  524%
  525%   Call Goal, cut choice-points on success  and succeed on failure.
  526%   intended for calling side-effects and proceed on failure.
  527
  528ignore(Goal) :-
  529    Goal,
  530    !.
  531ignore(_Goal).
  532
  533:- '$iso'((false/0)).  534
  535%!  false.
  536%
  537%   Synonym for fail/0, providing a declarative reading.
  538
  539false :-
  540    fail.
  541
  542%!  catch(:Goal, +Catcher, :Recover)
  543%
  544%   ISO compliant exception handling.
  545
  546catch(_Goal, _Catcher, _Recover) :-
  547    '$catch'.                       % Maps to I_CATCH, I_EXITCATCH
  548
  549%!  prolog_cut_to(+Choice)
  550%
  551%   Cut all choice points after Choice
  552
  553prolog_cut_to(_Choice) :-
  554    '$cut'.                         % Maps to I_CUTCHP
  555
  556%!  $ is det.
  557%
  558%   Declare that from now on this predicate succeeds deterministically.
  559
  560'$' :- '$'.
  561
  562%!  $(:Goal) is det.
  563%
  564%   Declare that Goal must succeed deterministically.
  565
  566$(Goal) :- $(Goal).
  567
  568%!  reset(:Goal, ?Ball, -Continue)
  569%
  570%   Delimited continuation support.
  571
  572reset(_Goal, _Ball, _Cont) :-
  573    '$reset'.
  574
  575%!  shift(+Ball).
  576%!  shift_for_copy(+Ball).
  577%
  578%   Shift control back to the  enclosing   reset/3.  The  second version
  579%   assumes the continuation will be saved to   be reused in a different
  580%   context.
  581
  582shift(Ball) :-
  583    '$shift'(Ball).
  584
  585shift_for_copy(Ball) :-
  586    '$shift_for_copy'(Ball).
  587
  588%!  call_continuation(+Continuation:list)
  589%
  590%   Call a continuation as created  by   shift/1.  The continuation is a
  591%   list of '$cont$'(Clause, PC, EnvironmentArg,   ...)  structures. The
  592%   predicate  '$call_one_tail_body'/1  creates   a    frame   from  the
  593%   continuation and calls this.
  594%
  595%   Note that we can technically also  push the entire continuation onto
  596%   the environment and  call  it.  Doing   it  incrementally  as  below
  597%   exploits last-call optimization  and   therefore  possible quadratic
  598%   expansion of the continuation.
  599
  600call_continuation([]).
  601call_continuation([TB|Rest]) :-
  602    (   Rest == []
  603    ->  '$call_continuation'(TB)
  604    ;   '$call_continuation'(TB),
  605        call_continuation(Rest)
  606    ).
  607
  608%!  catch_with_backtrace(:Goal, ?Ball, :Recover)
  609%
  610%   As catch/3, but tell library(prolog_stack) to  record a backtrace in
  611%   case of an exception.
  612
  613catch_with_backtrace(Goal, Ball, Recover) :-
  614    catch(Goal, Ball, Recover),
  615    '$no_lco'.
  616
  617'$no_lco'.
  618
  619%!  '$recover_and_rethrow'(:Goal, +Term)
  620%
  621%   This goal is used to wrap  the   catch/3  recover handler if the
  622%   exception is not supposed to be   `catchable'.  An example of an
  623%   uncachable exception is '$aborted', used   by abort/0. Note that
  624%   we cut to ensure  that  the   exception  is  not delayed forever
  625%   because the recover handler leaves a choicepoint.
  626
  627:- public '$recover_and_rethrow'/2.  628
  629'$recover_and_rethrow'(Goal, Exception) :-
  630    call_cleanup(Goal, throw(Exception)),
  631    !.
  632
  633
  634%!  setup_call_cleanup(:Setup, :Goal, :Cleanup).
  635%!  setup_call_catcher_cleanup(:Setup, :Goal, +Catcher, :Cleanup).
  636%!  call_cleanup(:Goal, :Cleanup).
  637%!  call_cleanup(:Goal, +Catcher, :Cleanup).
  638%
  639%   Call Cleanup once after Goal is finished (deterministic success,
  640%   failure, exception or  cut).  The   call  to  '$call_cleanup' is
  641%   translated to I_CALLCLEANUP. This  instruction   relies  on  the
  642%   exact stack layout left   by  setup_call_catcher_cleanup/4. Also
  643%   the predicate name is used by   the kernel cleanup mechanism and
  644%   can only be changed together with the kernel.
  645
  646setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
  647    '$sig_atomic'(Setup),
  648    '$call_cleanup'.
  649
  650setup_call_cleanup(Setup, Goal, Cleanup) :-
  651    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
  652
  653call_cleanup(Goal, Cleanup) :-
  654    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
  655
  656call_cleanup(Goal, Catcher, Cleanup) :-
  657    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
  658
  659                 /*******************************
  660                 *       INITIALIZATION         *
  661                 *******************************/
  662
  663:- meta_predicate
  664    initialization(0, +).  665
  666:- multifile '$init_goal'/3.  667:- dynamic   '$init_goal'/3.  668
  669%!  initialization(:Goal, +When)
  670%
  671%   Register Goal to be executed if a saved state is restored. In
  672%   addition, the goal is executed depending on When:
  673%
  674%       * now
  675%       Execute immediately
  676%       * after_load
  677%       Execute after loading the file in which it appears.  This
  678%       is initialization/1.
  679%       * restore_state
  680%       Do not execute immediately, but only when restoring the
  681%       state.  Not allowed in a sandboxed environment.
  682%       * prepare_state
  683%       Called before saving a state.  Can be used to clean the
  684%       environment (see also volatile/1) or eagerly execute
  685%       goals that are normally executed lazily.
  686%       * program
  687%       Works as =|-g goal|= goals.
  688%       * main
  689%       Starts the application.  Only last declaration is used.
  690%
  691%   Note that all goals are executed when a program is restored.
  692
  693initialization(Goal, When) :-
  694    '$must_be'(oneof(atom, initialization_type,
  695                     [ now,
  696                       after_load,
  697                       restore,
  698                       restore_state,
  699                       prepare_state,
  700                       program,
  701                       main
  702                     ]), When),
  703    '$initialization_context'(Source, Ctx),
  704    '$initialization'(When, Goal, Source, Ctx).
  705
  706'$initialization'(now, Goal, _Source, Ctx) :-
  707    '$run_init_goal'(Goal, Ctx),
  708    '$compile_init_goal'(-, Goal, Ctx).
  709'$initialization'(after_load, Goal, Source, Ctx) :-
  710    (   Source \== (-)
  711    ->  '$compile_init_goal'(Source, Goal, Ctx)
  712    ;   throw(error(context_error(nodirective,
  713                                  initialization(Goal, after_load)),
  714                    _))
  715    ).
  716'$initialization'(restore, Goal, Source, Ctx) :- % deprecated
  717    '$initialization'(restore_state, Goal, Source, Ctx).
  718'$initialization'(restore_state, Goal, _Source, Ctx) :-
  719    (   \+ current_prolog_flag(sandboxed_load, true)
  720    ->  '$compile_init_goal'(-, Goal, Ctx)
  721    ;   '$permission_error'(register, initialization(restore), Goal)
  722    ).
  723'$initialization'(prepare_state, Goal, _Source, Ctx) :-
  724    (   \+ current_prolog_flag(sandboxed_load, true)
  725    ->  '$compile_init_goal'(when(prepare_state), Goal, Ctx)
  726    ;   '$permission_error'(register, initialization(restore), Goal)
  727    ).
  728'$initialization'(program, Goal, _Source, Ctx) :-
  729    (   \+ current_prolog_flag(sandboxed_load, true)
  730    ->  '$compile_init_goal'(when(program), Goal, Ctx)
  731    ;   '$permission_error'(register, initialization(restore), Goal)
  732    ).
  733'$initialization'(main, Goal, _Source, Ctx) :-
  734    (   \+ current_prolog_flag(sandboxed_load, true)
  735    ->  '$compile_init_goal'(when(main), Goal, Ctx)
  736    ;   '$permission_error'(register, initialization(restore), Goal)
  737    ).
  738
  739
  740'$compile_init_goal'(Source, Goal, Ctx) :-
  741    atom(Source),
  742    Source \== (-),
  743    !,
  744    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
  745                          _Layout, Source, Ctx).
  746'$compile_init_goal'(Source, Goal, Ctx) :-
  747    assertz('$init_goal'(Source, Goal, Ctx)).
  748
  749
  750%!  '$run_initialization'(?File, +Options) is det.
  751%!  '$run_initialization'(?File, +Action, +Options) is det.
  752%
  753%   Run initialization directives for all files  if File is unbound,
  754%   or for a specified file.   Note  that '$run_initialization'/2 is
  755%   called from runInitialization() in pl-wic.c  for .qlf files. The
  756%   '$run_initialization'/3 is called with Action   set  to `loaded`
  757%   when called for a QLF file.
  758
  759'$run_initialization'(_, loaded, _) :- !.
  760'$run_initialization'(File, _Action, Options) :-
  761    '$run_initialization'(File, Options).
  762
  763'$run_initialization'(File, Options) :-
  764    setup_call_cleanup(
  765        '$start_run_initialization'(Options, Restore),
  766        '$run_initialization_2'(File),
  767        '$end_run_initialization'(Restore)).
  768
  769'$start_run_initialization'(Options, OldSandBoxed) :-
  770    '$push_input_context'(initialization),
  771    '$set_sandboxed_load'(Options, OldSandBoxed).
  772'$end_run_initialization'(OldSandBoxed) :-
  773    set_prolog_flag(sandboxed_load, OldSandBoxed),
  774    '$pop_input_context'.
  775
  776'$run_initialization_2'(File) :-
  777    (   '$init_goal'(File, Goal, Ctx),
  778        File \= when(_),
  779        '$run_init_goal'(Goal, Ctx),
  780        fail
  781    ;   true
  782    ).
  783
  784'$run_init_goal'(Goal, Ctx) :-
  785    (   catch_with_backtrace('$run_init_goal'(Goal), E,
  786                             '$initialization_error'(E, Goal, Ctx))
  787    ->  true
  788    ;   '$initialization_failure'(Goal, Ctx)
  789    ).
  790
  791:- multifile prolog:sandbox_allowed_goal/1.  792
  793'$run_init_goal'(Goal) :-
  794    current_prolog_flag(sandboxed_load, false),
  795    !,
  796    call(Goal).
  797'$run_init_goal'(Goal) :-
  798    prolog:sandbox_allowed_goal(Goal),
  799    call(Goal).
  800
  801'$initialization_context'(Source, Ctx) :-
  802    (   source_location(File, Line)
  803    ->  Ctx = File:Line,
  804        '$input_context'(Context),
  805        '$top_file'(Context, File, Source)
  806    ;   Ctx = (-),
  807        File = (-)
  808    ).
  809
  810'$top_file'([input(include, F1, _, _)|T], _, F) :-
  811    !,
  812    '$top_file'(T, F1, F).
  813'$top_file'(_, F, F).
  814
  815
  816'$initialization_error'(E, Goal, Ctx) :-
  817    print_message(error, initialization_error(Goal, E, Ctx)).
  818
  819'$initialization_failure'(Goal, Ctx) :-
  820    print_message(warning, initialization_failure(Goal, Ctx)).
  821
  822%!  '$clear_source_admin'(+File) is det.
  823%
  824%   Removes source adminstration related to File
  825%
  826%   @see Called from destroySourceFile() in pl-proc.c
  827
  828:- public '$clear_source_admin'/1.  829
  830'$clear_source_admin'(File) :-
  831    retractall('$init_goal'(_, _, File:_)),
  832    retractall('$load_context_module'(File, _, _)),
  833    retractall('$resolved_source_path_db'(_, _, File)).
  834
  835
  836                 /*******************************
  837                 *            STREAM            *
  838                 *******************************/
  839
  840:- '$iso'(stream_property/2).  841stream_property(Stream, Property) :-
  842    nonvar(Stream),
  843    nonvar(Property),
  844    !,
  845    '$stream_property'(Stream, Property).
  846stream_property(Stream, Property) :-
  847    nonvar(Stream),
  848    !,
  849    '$stream_properties'(Stream, Properties),
  850    '$member'(Property, Properties).
  851stream_property(Stream, Property) :-
  852    nonvar(Property),
  853    !,
  854    (   Property = alias(Alias),
  855        atom(Alias)
  856    ->  '$alias_stream'(Alias, Stream)
  857    ;   '$streams_properties'(Property, Pairs),
  858        '$member'(Stream-Property, Pairs)
  859    ).
  860stream_property(Stream, Property) :-
  861    '$streams_properties'(Property, Pairs),
  862    '$member'(Stream-Properties, Pairs),
  863    '$member'(Property, Properties).
  864
  865
  866                /********************************
  867                *            MODULES            *
  868                *********************************/
  869
  870%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
  871%       Tags `Term' with `Module:' if `Module' is not the context module.
  872
  873'$prefix_module'(Module, Module, Head, Head) :- !.
  874'$prefix_module'(Module, _, Head, Module:Head).
  875
  876%!  default_module(+Me, -Super) is multi.
  877%
  878%   Is true if `Super' is `Me' or a super (auto import) module of `Me'.
  879
  880default_module(Me, Super) :-
  881    (   atom(Me)
  882    ->  (   var(Super)
  883        ->  '$default_module'(Me, Super)
  884        ;   '$default_module'(Me, Super), !
  885        )
  886    ;   '$type_error'(module, Me)
  887    ).
  888
  889'$default_module'(Me, Me).
  890'$default_module'(Me, Super) :-
  891    import_module(Me, S),
  892    '$default_module'(S, Super).
  893
  894
  895                /********************************
  896                *      TRACE AND EXCEPTIONS     *
  897                *********************************/
  898
  899:- dynamic   user:exception/3.  900:- multifile user:exception/3.  901:- '$hide'(user:exception/3).  902
  903%!  '$undefined_procedure'(+Module, +Name, +Arity, -Action) is det.
  904%
  905%   This predicate is called from C   on undefined predicates. First
  906%   allows the user to take care of   it using exception/3. Else try
  907%   to give a DWIM warning. Otherwise fail.   C  will print an error
  908%   message.
  909
  910:- public
  911    '$undefined_procedure'/4.  912
  913'$undefined_procedure'(Module, Name, Arity, Action) :-
  914    '$prefix_module'(Module, user, Name/Arity, Pred),
  915    user:exception(undefined_predicate, Pred, Action0),
  916    !,
  917    Action = Action0.
  918'$undefined_procedure'(Module, Name, Arity, Action) :-
  919    \+ current_prolog_flag(autoload, false),
  920    '$autoload'(Module:Name/Arity),
  921    !,
  922    Action = retry.
  923'$undefined_procedure'(_, _, _, error).
  924
  925
  926%!  '$loading'(+Library)
  927%
  928%   True if the library  is  being   loaded.  Just  testing that the
  929%   predicate is defined is not  good  enough   as  the  file may be
  930%   partly  loaded.  Calling  use_module/2  at   any  time  has  two
  931%   drawbacks: it queries the filesystem,   causing  slowdown and it
  932%   stops libraries being autoloaded from a   saved  state where the
  933%   library is already loaded, but the source may not be accessible.
  934
  935'$loading'(Library) :-
  936    current_prolog_flag(threads, true),
  937    (   '$loading_file'(Library, _Queue, _LoadThread)
  938    ->  true
  939    ;   '$loading_file'(FullFile, _Queue, _LoadThread),
  940        file_name_extension(Library, _, FullFile)
  941    ->  true
  942    ).
  943
  944%        handle debugger 'w', 'p' and <N> depth options.
  945
  946'$set_debugger_write_options'(write) :-
  947    !,
  948    create_prolog_flag(debugger_write_options,
  949                       [ quoted(true),
  950                         attributes(dots),
  951                         spacing(next_argument)
  952                       ], []).
  953'$set_debugger_write_options'(print) :-
  954    !,
  955    create_prolog_flag(debugger_write_options,
  956                       [ quoted(true),
  957                         portray(true),
  958                         max_depth(10),
  959                         attributes(portray),
  960                         spacing(next_argument)
  961                       ], []).
  962'$set_debugger_write_options'(Depth) :-
  963    current_prolog_flag(debugger_write_options, Options0),
  964    (   '$select'(max_depth(_), Options0, Options)
  965    ->  true
  966    ;   Options = Options0
  967    ),
  968    create_prolog_flag(debugger_write_options,
  969                       [max_depth(Depth)|Options], []).
  970
  971
  972                /********************************
  973                *        SYSTEM MESSAGES        *
  974                *********************************/
  975
  976%!  '$confirm'(Spec)
  977%
  978%   Ask the user to confirm a question.  Spec is a term as used for
  979%   print_message/2.
  980
  981'$confirm'(Spec) :-
  982    print_message(query, Spec),
  983    between(0, 5, _),
  984        get_single_char(Answer),
  985        (   '$in_reply'(Answer, 'yYjJ \n')
  986        ->  !,
  987            print_message(query, if_tty([yes-[]]))
  988        ;   '$in_reply'(Answer, 'nN')
  989        ->  !,
  990            print_message(query, if_tty([no-[]])),
  991            fail
  992        ;   print_message(help, query(confirm)),
  993            fail
  994        ).
  995
  996'$in_reply'(Code, Atom) :-
  997    char_code(Char, Code),
  998    sub_atom(Atom, _, _, _, Char),
  999    !.
 1000
 1001:- dynamic
 1002    user:portray/1. 1003:- multifile
 1004    user:portray/1. 1005
 1006
 1007                 /*******************************
 1008                 *       FILE_SEARCH_PATH       *
 1009                 *******************************/
 1010
 1011:- dynamic
 1012    user:file_search_path/2,
 1013    user:library_directory/1. 1014:- multifile
 1015    user:file_search_path/2,
 1016    user:library_directory/1. 1017
 1018user:(file_search_path(library, Dir) :-
 1019        library_directory(Dir)).
 1020user:file_search_path(swi, Home) :-
 1021    current_prolog_flag(home, Home).
 1022user:file_search_path(swi, Home) :-
 1023    current_prolog_flag(shared_home, Home).
 1024user:file_search_path(library, app_config(lib)).
 1025user:file_search_path(library, swi(library)).
 1026user:file_search_path(library, swi(library/clp)).
 1027user:file_search_path(foreign, swi(ArchLib)) :-
 1028    \+ current_prolog_flag(windows, true),
 1029    current_prolog_flag(arch, Arch),
 1030    atom_concat('lib/', Arch, ArchLib).
 1031user:file_search_path(foreign, swi(SoLib)) :-
 1032    (   current_prolog_flag(windows, true)
 1033    ->  SoLib = bin
 1034    ;   SoLib = lib
 1035    ).
 1036user:file_search_path(path, Dir) :-
 1037    getenv('PATH', Path),
 1038    (   current_prolog_flag(windows, true)
 1039    ->  atomic_list_concat(Dirs, (;), Path)
 1040    ;   atomic_list_concat(Dirs, :, Path)
 1041    ),
 1042    '$member'(Dir, Dirs).
 1043user:file_search_path(user_app_data, Dir) :-
 1044    '$xdg_prolog_directory'(data, Dir).
 1045user:file_search_path(common_app_data, Dir) :-
 1046    '$xdg_prolog_directory'(common_data, Dir).
 1047user:file_search_path(user_app_config, Dir) :-
 1048    '$xdg_prolog_directory'(config, Dir).
 1049user:file_search_path(common_app_config, Dir) :-
 1050    '$xdg_prolog_directory'(common_config, Dir).
 1051user:file_search_path(app_data, user_app_data('.')).
 1052user:file_search_path(app_data, common_app_data('.')).
 1053user:file_search_path(app_config, user_app_config('.')).
 1054user:file_search_path(app_config, common_app_config('.')).
 1055% backward compatibility
 1056user:file_search_path(app_preferences, user_app_config('.')).
 1057user:file_search_path(user_profile, app_preferences('.')).
 1058
 1059'$xdg_prolog_directory'(Which, Dir) :-
 1060    '$xdg_directory'(Which, XDGDir),
 1061    '$make_config_dir'(XDGDir),
 1062    '$ensure_slash'(XDGDir, XDGDirS),
 1063    atom_concat(XDGDirS, 'swi-prolog', Dir),
 1064    '$make_config_dir'(Dir).
 1065
 1066% config
 1067'$xdg_directory'(config, Home) :-
 1068    current_prolog_flag(windows, true),
 1069    catch(win_folder(appdata, Home), _, fail),
 1070    !.
 1071'$xdg_directory'(config, Home) :-
 1072    getenv('XDG_CONFIG_HOME', Home).
 1073'$xdg_directory'(config, Home) :-
 1074    expand_file_name('~/.config', [Home]).
 1075% data
 1076'$xdg_directory'(data, Home) :-
 1077    current_prolog_flag(windows, true),
 1078    catch(win_folder(local_appdata, Home), _, fail),
 1079    !.
 1080'$xdg_directory'(data, Home) :-
 1081    getenv('XDG_DATA_HOME', Home).
 1082'$xdg_directory'(data, Home) :-
 1083    expand_file_name('~/.local', [Local]),
 1084    '$make_config_dir'(Local),
 1085    atom_concat(Local, '/share', Home),
 1086    '$make_config_dir'(Home).
 1087% common data
 1088'$xdg_directory'(common_data, Dir) :-
 1089    current_prolog_flag(windows, true),
 1090    catch(win_folder(common_appdata, Dir), _, fail),
 1091    !.
 1092'$xdg_directory'(common_data, Dir) :-
 1093    '$existing_dir_from_env_path'('XDG_DATA_DIRS',
 1094                                  [ '/usr/local/share',
 1095                                    '/usr/share'
 1096                                  ],
 1097                                  Dir).
 1098% common config
 1099'$xdg_directory'(common_config, Dir) :-
 1100    current_prolog_flag(windows, true),
 1101    catch(win_folder(common_appdata, Dir), _, fail),
 1102    !.
 1103'$xdg_directory'(common_config, Dir) :-
 1104    '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir).
 1105
 1106'$existing_dir_from_env_path'(Env, Defaults, Dir) :-
 1107    (   getenv(Env, Path)
 1108    ->  '$path_sep'(Sep),
 1109        atomic_list_concat(Dirs, Sep, Path)
 1110    ;   Dirs = Defaults
 1111    ),
 1112    '$member'(Dir, Dirs),
 1113    Dir \== '',
 1114    exists_directory(Dir).
 1115
 1116'$path_sep'(Char) :-
 1117    (   current_prolog_flag(windows, true)
 1118    ->  Char = ';'
 1119    ;   Char = ':'
 1120    ).
 1121
 1122'$make_config_dir'(Dir) :-
 1123    exists_directory(Dir),
 1124    !.
 1125'$make_config_dir'(Dir) :-
 1126    nb_current('$create_search_directories', true),
 1127    file_directory_name(Dir, Parent),
 1128    '$my_file'(Parent),
 1129    catch(make_directory(Dir), _, fail).
 1130
 1131'$ensure_slash'(Dir, DirS) :-
 1132    (   sub_atom(Dir, _, _, 0, /)
 1133    ->  DirS = Dir
 1134    ;   atom_concat(Dir, /, DirS)
 1135    ).
 1136
 1137
 1138%!  '$expand_file_search_path'(+Spec, -Expanded, +Cond) is nondet.
 1139
 1140'$expand_file_search_path'(Spec, Expanded, Cond) :-
 1141    '$option'(access(Access), Cond),
 1142    memberchk(Access, [write,append]),
 1143    !,
 1144    setup_call_cleanup(
 1145        nb_setval('$create_search_directories', true),
 1146        expand_file_search_path(Spec, Expanded),
 1147        nb_delete('$create_search_directories')).
 1148'$expand_file_search_path'(Spec, Expanded, _Cond) :-
 1149    expand_file_search_path(Spec, Expanded).
 1150
 1151%!  expand_file_search_path(+Spec, -Expanded) is nondet.
 1152%
 1153%   Expand a search path.  The system uses depth-first search upto a
 1154%   specified depth.  If this depth is exceeded an exception is raised.
 1155%   TBD: bread-first search?
 1156
 1157expand_file_search_path(Spec, Expanded) :-
 1158    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
 1159          loop(Used),
 1160          throw(error(loop_error(Spec), file_search(Used)))).
 1161
 1162'$expand_file_search_path'(Spec, Expanded, N, Used) :-
 1163    functor(Spec, Alias, 1),
 1164    !,
 1165    user:file_search_path(Alias, Exp0),
 1166    NN is N + 1,
 1167    (   NN > 16
 1168    ->  throw(loop(Used))
 1169    ;   true
 1170    ),
 1171    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
 1172    arg(1, Spec, Segments),
 1173    '$segments_to_atom'(Segments, File),
 1174    '$make_path'(Exp1, File, Expanded).
 1175'$expand_file_search_path'(Spec, Path, _, _) :-
 1176    '$segments_to_atom'(Spec, Path).
 1177
 1178'$make_path'(Dir, '.', Path) :-
 1179    !,
 1180    Path = Dir.
 1181'$make_path'(Dir, File, Path) :-
 1182    sub_atom(Dir, _, _, 0, /),
 1183    !,
 1184    atom_concat(Dir, File, Path).
 1185'$make_path'(Dir, File, Path) :-
 1186    atomic_list_concat([Dir, /, File], Path).
 1187
 1188
 1189                /********************************
 1190                *         FILE CHECKING         *
 1191                *********************************/
 1192
 1193%!  absolute_file_name(+Term, -AbsoluteFile, +Options) is nondet.
 1194%
 1195%   Translate path-specifier into a full   path-name. This predicate
 1196%   originates from Quintus was introduced  in SWI-Prolog very early
 1197%   and  has  re-appeared  in  SICStus  3.9.0,  where  they  changed
 1198%   argument order and added some options.   We addopted the SICStus
 1199%   argument order, but still accept the original argument order for
 1200%   compatibility reasons.
 1201
 1202absolute_file_name(Spec, Options, Path) :-
 1203    '$is_options'(Options),
 1204    \+ '$is_options'(Path),
 1205    !,
 1206    absolute_file_name(Spec, Path, Options).
 1207absolute_file_name(Spec, Path, Options) :-
 1208    '$must_be'(options, Options),
 1209                    % get the valid extensions
 1210    (   '$select_option'(extensions(Exts), Options, Options1)
 1211    ->  '$must_be'(list, Exts)
 1212    ;   '$option'(file_type(Type), Options)
 1213    ->  '$must_be'(atom, Type),
 1214        '$file_type_extensions'(Type, Exts),
 1215        Options1 = Options
 1216    ;   Options1 = Options,
 1217        Exts = ['']
 1218    ),
 1219    '$canonicalise_extensions'(Exts, Extensions),
 1220                    % unless specified otherwise, ask regular file
 1221    (   nonvar(Type)
 1222    ->  Options2 = Options1
 1223    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
 1224    ),
 1225                    % Det or nondet?
 1226    (   '$select_option'(solutions(Sols), Options2, Options3)
 1227    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
 1228    ;   Sols = first,
 1229        Options3 = Options2
 1230    ),
 1231                    % Errors or not?
 1232    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
 1233    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
 1234    ;   FileErrors = error,
 1235        Options4 = Options3
 1236    ),
 1237                    % Expand shell patterns?
 1238    (   atomic(Spec),
 1239        '$select_option'(expand(Expand), Options4, Options5),
 1240        '$must_be'(boolean, Expand)
 1241    ->  expand_file_name(Spec, List),
 1242        '$member'(Spec1, List)
 1243    ;   Spec1 = Spec,
 1244        Options5 = Options4
 1245    ),
 1246                    % Search for files
 1247    (   Sols == first
 1248    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
 1249        ->  !       % also kill choice point of expand_file_name/2
 1250        ;   (   FileErrors == fail
 1251            ->  fail
 1252            ;   '$current_module'('$bags', _File),
 1253                findall(P,
 1254                        '$chk_file'(Spec1, Extensions, [access(exist)],
 1255                                    false, P),
 1256                        Candidates),
 1257                '$abs_file_error'(Spec, Candidates, Options5)
 1258            )
 1259        )
 1260    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 1261    ).
 1262
 1263'$abs_file_error'(Spec, Candidates, Conditions) :-
 1264    '$member'(F, Candidates),
 1265    '$member'(C, Conditions),
 1266    '$file_condition'(C),
 1267    '$file_error'(C, Spec, F, E, Comment),
 1268    !,
 1269    throw(error(E, context(_, Comment))).
 1270'$abs_file_error'(Spec, _, _) :-
 1271    '$existence_error'(source_sink, Spec).
 1272
 1273'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 1274    \+ exists_directory(File),
 1275    !,
 1276    Error = existence_error(directory, Spec),
 1277    Comment = not_a_directory(File).
 1278'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 1279    exists_directory(File),
 1280    !,
 1281    Error = existence_error(file, Spec),
 1282    Comment = directory(File).
 1283'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 1284    '$one_or_member'(Access, OneOrList),
 1285    \+ access_file(File, Access),
 1286    Error = permission_error(Access, source_sink, Spec).
 1287
 1288'$one_or_member'(Elem, List) :-
 1289    is_list(List),
 1290    !,
 1291    '$member'(Elem, List).
 1292'$one_or_member'(Elem, Elem).
 1293
 1294
 1295'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 1296    !,
 1297    '$file_type_extensions'(prolog, Exts).
 1298'$file_type_extensions'(Type, Exts) :-
 1299    '$current_module'('$bags', _File),
 1300    !,
 1301    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 1302    (   Exts0 == [],
 1303        \+ '$ft_no_ext'(Type)
 1304    ->  '$domain_error'(file_type, Type)
 1305    ;   true
 1306    ),
 1307    '$append'(Exts0, [''], Exts).
 1308'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 1309
 1310'$ft_no_ext'(txt).
 1311'$ft_no_ext'(executable).
 1312'$ft_no_ext'(directory).
 1313
 1314%!  user:prolog_file_type(?Extension, ?Type)
 1315%
 1316%   Define type of file based on the extension.  This is used by
 1317%   absolute_file_name/3 and may be used to extend the list of
 1318%   extensions used for some type.
 1319%
 1320%   Note that =qlf= must be last   when  searching for Prolog files.
 1321%   Otherwise use_module/1 will consider  the   file  as  not-loaded
 1322%   because the .qlf file is not  the   loaded  file.  Must be fixed
 1323%   elsewhere.
 1324
 1325:- multifile(user:prolog_file_type/2). 1326:- dynamic(user:prolog_file_type/2). 1327
 1328user:prolog_file_type(pl,       prolog).
 1329user:prolog_file_type(prolog,   prolog).
 1330user:prolog_file_type(qlf,      prolog).
 1331user:prolog_file_type(qlf,      qlf).
 1332user:prolog_file_type(Ext,      executable) :-
 1333    current_prolog_flag(shared_object_extension, Ext).
 1334user:prolog_file_type(dylib,    executable) :-
 1335    current_prolog_flag(apple,  true).
 1336
 1337%!  '$chk_file'(+Spec, +Extensions, +Cond, +UseCache, -FullName)
 1338%
 1339%   File is a specification of a Prolog source file. Return the full
 1340%   path of the file.
 1341
 1342'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1343    \+ ground(Spec),
 1344    !,
 1345    '$instantiation_error'(Spec).
 1346'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1347    compound(Spec),
 1348    functor(Spec, _, 1),
 1349    !,
 1350    '$relative_to'(Cond, cwd, CWD),
 1351    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1352'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1353    \+ atomic(Segments),
 1354    !,
 1355    '$segments_to_atom'(Segments, Atom),
 1356    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1357'$chk_file'(File, Exts, Cond, _, FullName) :-
 1358    is_absolute_file_name(File),
 1359    !,
 1360    '$extend_file'(File, Exts, Extended),
 1361    '$file_conditions'(Cond, Extended),
 1362    '$absolute_file_name'(Extended, FullName).
 1363'$chk_file'(File, Exts, Cond, _, FullName) :-
 1364    '$relative_to'(Cond, source, Dir),
 1365    atomic_list_concat([Dir, /, File], AbsFile),
 1366    '$extend_file'(AbsFile, Exts, Extended),
 1367    '$file_conditions'(Cond, Extended),
 1368    !,
 1369    '$absolute_file_name'(Extended, FullName).
 1370'$chk_file'(File, Exts, Cond, _, FullName) :-
 1371    '$extend_file'(File, Exts, Extended),
 1372    '$file_conditions'(Cond, Extended),
 1373    '$absolute_file_name'(Extended, FullName).
 1374
 1375'$segments_to_atom'(Atom, Atom) :-
 1376    atomic(Atom),
 1377    !.
 1378'$segments_to_atom'(Segments, Atom) :-
 1379    '$segments_to_list'(Segments, List, []),
 1380    !,
 1381    atomic_list_concat(List, /, Atom).
 1382
 1383'$segments_to_list'(A/B, H, T) :-
 1384    '$segments_to_list'(A, H, T0),
 1385    '$segments_to_list'(B, T0, T).
 1386'$segments_to_list'(A, [A|T], T) :-
 1387    atomic(A).
 1388
 1389
 1390%!  '$relative_to'(+Condition, +Default, -Dir)
 1391%
 1392%   Determine the directory to work from.  This can be specified
 1393%   explicitely using one or more relative_to(FileOrDir) options
 1394%   or implicitely relative to the working directory or current
 1395%   source-file.
 1396
 1397'$relative_to'(Conditions, Default, Dir) :-
 1398    (   '$option'(relative_to(FileOrDir), Conditions)
 1399    *-> (   exists_directory(FileOrDir)
 1400        ->  Dir = FileOrDir
 1401        ;   atom_concat(Dir, /, FileOrDir)
 1402        ->  true
 1403        ;   file_directory_name(FileOrDir, Dir)
 1404        )
 1405    ;   Default == cwd
 1406    ->  '$cwd'(Dir)
 1407    ;   Default == source
 1408    ->  source_location(ContextFile, _Line),
 1409        file_directory_name(ContextFile, Dir)
 1410    ).
 1411
 1412%!  '$chk_alias_file'(+Spec, +Exts, +Cond, +Cache, +CWD,
 1413%!                    -FullFile) is nondet.
 1414
 1415:- dynamic
 1416    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1417    '$search_path_gc_time'/1.       % Time
 1418:- volatile
 1419    '$search_path_file_cache'/3,
 1420    '$search_path_gc_time'/1. 1421
 1422:- create_prolog_flag(file_search_cache_time, 10, []). 1423
 1424'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1425    !,
 1426    findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
 1427    current_prolog_flag(emulated_dialect, Dialect),
 1428    Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
 1429    variant_sha1(Spec+Cache, SHA1),
 1430    get_time(Now),
 1431    current_prolog_flag(file_search_cache_time, TimeOut),
 1432    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1433        CachedTime > Now - TimeOut,
 1434        '$file_conditions'(Cond, FullFile)
 1435    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1436    ;   '$member'(Expanded, Expansions),
 1437        '$extend_file'(Expanded, Exts, LibFile),
 1438        (   '$file_conditions'(Cond, LibFile),
 1439            '$absolute_file_name'(LibFile, FullFile),
 1440            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1441        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1442        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1443            fail
 1444        )
 1445    ).
 1446'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1447    '$expand_file_search_path'(Spec, Expanded, Cond),
 1448    '$extend_file'(Expanded, Exts, LibFile),
 1449    '$file_conditions'(Cond, LibFile),
 1450    '$absolute_file_name'(LibFile, FullFile).
 1451
 1452'$cache_file_found'(_, _, TimeOut, _) :-
 1453    TimeOut =:= 0,
 1454    !.
 1455'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1456    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1457    !,
 1458    (   Now - Saved < TimeOut/2
 1459    ->  true
 1460    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1461        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1462    ).
 1463'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1464    'gc_file_search_cache'(TimeOut),
 1465    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1466
 1467'gc_file_search_cache'(TimeOut) :-
 1468    get_time(Now),
 1469    '$search_path_gc_time'(Last),
 1470    Now-Last < TimeOut/2,
 1471    !.
 1472'gc_file_search_cache'(TimeOut) :-
 1473    get_time(Now),
 1474    retractall('$search_path_gc_time'(_)),
 1475    assertz('$search_path_gc_time'(Now)),
 1476    Before is Now - TimeOut,
 1477    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1478        Cached < Before,
 1479        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1480        fail
 1481    ;   true
 1482    ).
 1483
 1484
 1485'$search_message'(Term) :-
 1486    current_prolog_flag(verbose_file_search, true),
 1487    !,
 1488    print_message(informational, Term).
 1489'$search_message'(_).
 1490
 1491
 1492%!  '$file_conditions'(+Condition, +Path)
 1493%
 1494%   Verify Path satisfies Condition.
 1495
 1496'$file_conditions'(List, File) :-
 1497    is_list(List),
 1498    !,
 1499    \+ ( '$member'(C, List),
 1500         '$file_condition'(C),
 1501         \+ '$file_condition'(C, File)
 1502       ).
 1503'$file_conditions'(Map, File) :-
 1504    \+ (  get_dict(Key, Map, Value),
 1505          C =.. [Key,Value],
 1506          '$file_condition'(C),
 1507         \+ '$file_condition'(C, File)
 1508       ).
 1509
 1510'$file_condition'(file_type(directory), File) :-
 1511    !,
 1512    exists_directory(File).
 1513'$file_condition'(file_type(_), File) :-
 1514    !,
 1515    \+ exists_directory(File).
 1516'$file_condition'(access(Accesses), File) :-
 1517    !,
 1518    \+ (  '$one_or_member'(Access, Accesses),
 1519          \+ access_file(File, Access)
 1520       ).
 1521
 1522'$file_condition'(exists).
 1523'$file_condition'(file_type(_)).
 1524'$file_condition'(access(_)).
 1525
 1526'$extend_file'(File, Exts, FileEx) :-
 1527    '$ensure_extensions'(Exts, File, Fs),
 1528    '$list_to_set'(Fs, FsSet),
 1529    '$member'(FileEx, FsSet).
 1530
 1531'$ensure_extensions'([], _, []).
 1532'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1533    file_name_extension(F, E, FE),
 1534    '$ensure_extensions'(E0, F, E1).
 1535
 1536%!  '$list_to_set'(+List, -Set) is det.
 1537%
 1538%   Turn list into a set, keeping   the  left-most copy of duplicate
 1539%   elements.  Copied from library(lists).
 1540
 1541'$list_to_set'(List, Set) :-
 1542    '$number_list'(List, 1, Numbered),
 1543    sort(1, @=<, Numbered, ONum),
 1544    '$remove_dup_keys'(ONum, NumSet),
 1545    sort(2, @=<, NumSet, ONumSet),
 1546    '$pairs_keys'(ONumSet, Set).
 1547
 1548'$number_list'([], _, []).
 1549'$number_list'([H|T0], N, [H-N|T]) :-
 1550    N1 is N+1,
 1551    '$number_list'(T0, N1, T).
 1552
 1553'$remove_dup_keys'([], []).
 1554'$remove_dup_keys'([H|T0], [H|T]) :-
 1555    H = V-_,
 1556    '$remove_same_key'(T0, V, T1),
 1557    '$remove_dup_keys'(T1, T).
 1558
 1559'$remove_same_key'([V1-_|T0], V, T) :-
 1560    V1 == V,
 1561    !,
 1562    '$remove_same_key'(T0, V, T).
 1563'$remove_same_key'(L, _, L).
 1564
 1565'$pairs_keys'([], []).
 1566'$pairs_keys'([K-_|T0], [K|T]) :-
 1567    '$pairs_keys'(T0, T).
 1568
 1569
 1570/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 1571Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
 1572the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
 1573extensions to .ext
 1574- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 1575
 1576'$canonicalise_extensions'([], []) :- !.
 1577'$canonicalise_extensions'([H|T], [CH|CT]) :-
 1578    !,
 1579    '$must_be'(atom, H),
 1580    '$canonicalise_extension'(H, CH),
 1581    '$canonicalise_extensions'(T, CT).
 1582'$canonicalise_extensions'(E, [CE]) :-
 1583    '$canonicalise_extension'(E, CE).
 1584
 1585'$canonicalise_extension'('', '') :- !.
 1586'$canonicalise_extension'(DotAtom, DotAtom) :-
 1587    sub_atom(DotAtom, 0, _, _, '.'),
 1588    !.
 1589'$canonicalise_extension'(Atom, DotAtom) :-
 1590    atom_concat('.', Atom, DotAtom).
 1591
 1592
 1593                /********************************
 1594                *            CONSULT            *
 1595                *********************************/
 1596
 1597:- dynamic
 1598    user:library_directory/1,
 1599    user:prolog_load_file/2. 1600:- multifile
 1601    user:library_directory/1,
 1602    user:prolog_load_file/2. 1603
 1604:- prompt(_, '|: '). 1605
 1606:- thread_local
 1607    '$compilation_mode_store'/1,    % database, wic, qlf
 1608    '$directive_mode_store'/1.      % database, wic, qlf
 1609:- volatile
 1610    '$compilation_mode_store'/1,
 1611    '$directive_mode_store'/1. 1612
 1613'$compilation_mode'(Mode) :-
 1614    (   '$compilation_mode_store'(Val)
 1615    ->  Mode = Val
 1616    ;   Mode = database
 1617    ).
 1618
 1619'$set_compilation_mode'(Mode) :-
 1620    retractall('$compilation_mode_store'(_)),
 1621    assertz('$compilation_mode_store'(Mode)).
 1622
 1623'$compilation_mode'(Old, New) :-
 1624    '$compilation_mode'(Old),
 1625    (   New == Old
 1626    ->  true
 1627    ;   '$set_compilation_mode'(New)
 1628    ).
 1629
 1630'$directive_mode'(Mode) :-
 1631    (   '$directive_mode_store'(Val)
 1632    ->  Mode = Val
 1633    ;   Mode = database
 1634    ).
 1635
 1636'$directive_mode'(Old, New) :-
 1637    '$directive_mode'(Old),
 1638    (   New == Old
 1639    ->  true
 1640    ;   '$set_directive_mode'(New)
 1641    ).
 1642
 1643'$set_directive_mode'(Mode) :-
 1644    retractall('$directive_mode_store'(_)),
 1645    assertz('$directive_mode_store'(Mode)).
 1646
 1647
 1648%!  '$compilation_level'(-Level) is det.
 1649%
 1650%   True when Level reflects the nesting   in  files compiling other
 1651%   files. 0 if no files are being loaded.
 1652
 1653'$compilation_level'(Level) :-
 1654    '$input_context'(Stack),
 1655    '$compilation_level'(Stack, Level).
 1656
 1657'$compilation_level'([], 0).
 1658'$compilation_level'([Input|T], Level) :-
 1659    (   arg(1, Input, see)
 1660    ->  '$compilation_level'(T, Level)
 1661    ;   '$compilation_level'(T, Level0),
 1662        Level is Level0+1
 1663    ).
 1664
 1665
 1666%!  compiling
 1667%
 1668%   Is true if SWI-Prolog is generating a state or qlf file or
 1669%   executes a `call' directive while doing this.
 1670
 1671compiling :-
 1672    \+ (   '$compilation_mode'(database),
 1673           '$directive_mode'(database)
 1674       ).
 1675
 1676:- meta_predicate
 1677    '$ifcompiling'(0). 1678
 1679'$ifcompiling'(G) :-
 1680    (   '$compilation_mode'(database)
 1681    ->  true
 1682    ;   call(G)
 1683    ).
 1684
 1685                /********************************
 1686                *         READ SOURCE           *
 1687                *********************************/
 1688
 1689%!  '$load_msg_level'(+Action, +NestingLevel, -StartVerbose, -EndVerbose)
 1690
 1691'$load_msg_level'(Action, Nesting, Start, Done) :-
 1692    '$update_autoload_level'([], 0),
 1693    !,
 1694    current_prolog_flag(verbose_load, Type0),
 1695    '$load_msg_compat'(Type0, Type),
 1696    (   '$load_msg_level'(Action, Nesting, Type, Start, Done)
 1697    ->  true
 1698    ).
 1699'$load_msg_level'(_, _, silent, silent).
 1700
 1701'$load_msg_compat'(true, normal) :- !.
 1702'$load_msg_compat'(false, silent) :- !.
 1703'$load_msg_compat'(X, X).
 1704
 1705'$load_msg_level'(load_file,    _, full,   informational, informational).
 1706'$load_msg_level'(include_file, _, full,   informational, informational).
 1707'$load_msg_level'(load_file,    _, normal, silent,        informational).
 1708'$load_msg_level'(include_file, _, normal, silent,        silent).
 1709'$load_msg_level'(load_file,    0, brief,  silent,        informational).
 1710'$load_msg_level'(load_file,    _, brief,  silent,        silent).
 1711'$load_msg_level'(include_file, _, brief,  silent,        silent).
 1712'$load_msg_level'(load_file,    _, silent, silent,        silent).
 1713'$load_msg_level'(include_file, _, silent, silent,        silent).
 1714
 1715%!  '$source_term'(+From, -Read, -RLayout, -Term, -TLayout,
 1716%!                 -Stream, +Options) is nondet.
 1717%
 1718%   Read Prolog terms from the  input   From.  Terms are returned on
 1719%   backtracking. Associated resources (i.e.,   streams)  are closed
 1720%   due to setup_call_cleanup/3.
 1721%
 1722%   @param From is either a term stream(Id, Stream) or a file
 1723%          specification.
 1724%   @param Read is the raw term as read from the input.
 1725%   @param Term is the term after term-expansion.  If a term is
 1726%          expanded into the empty list, this is returned too.  This
 1727%          is required to be able to return the raw term in Read
 1728%   @param Stream is the stream from which Read is read
 1729%   @param Options provides additional options:
 1730%           * encoding(Enc)
 1731%           Encoding used to open From
 1732%           * syntax_errors(+ErrorMode)
 1733%           * process_comments(+Boolean)
 1734%           * term_position(-Pos)
 1735
 1736'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
 1737    '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
 1738    (   Term == end_of_file
 1739    ->  !, fail
 1740    ;   Term \== begin_of_file
 1741    ).
 1742
 1743'$source_term'(Input, _,_,_,_,_,_,_) :-
 1744    \+ ground(Input),
 1745    !,
 1746    '$instantiation_error'(Input).
 1747'$source_term'(stream(Id, In, Opts),
 1748               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1749    !,
 1750    '$record_included'(Parents, Id, Id, 0.0, Message),
 1751    setup_call_cleanup(
 1752        '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
 1753        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1754                        [Id|Parents], Options),
 1755        '$close_source'(State, Message)).
 1756'$source_term'(File,
 1757               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1758    absolute_file_name(File, Path,
 1759                       [ file_type(prolog),
 1760                         access(read)
 1761                       ]),
 1762    time_file(Path, Time),
 1763    '$record_included'(Parents, File, Path, Time, Message),
 1764    setup_call_cleanup(
 1765        '$open_source'(Path, In, State, Parents, Options),
 1766        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1767                        [Path|Parents], Options),
 1768        '$close_source'(State, Message)).
 1769
 1770:- thread_local
 1771    '$load_input'/2. 1772:- volatile
 1773    '$load_input'/2. 1774
 1775'$open_source'(stream(Id, In, Opts), In,
 1776               restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :-
 1777    !,
 1778    '$context_type'(Parents, ContextType),
 1779    '$push_input_context'(ContextType),
 1780    '$prepare_load_stream'(In, Id, StreamState),
 1781    asserta('$load_input'(stream(Id), In), Ref).
 1782'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
 1783    '$context_type'(Parents, ContextType),
 1784    '$push_input_context'(ContextType),
 1785    '$open_source'(Path, In, Options),
 1786    '$set_encoding'(In, Options),
 1787    asserta('$load_input'(Path, In), Ref).
 1788
 1789'$context_type'([], load_file) :- !.
 1790'$context_type'(_, include).
 1791
 1792:- multifile prolog:open_source_hook/3. 1793
 1794'$open_source'(Path, In, Options) :-
 1795    prolog:open_source_hook(Path, In, Options),
 1796    !.
 1797'$open_source'(Path, In, _Options) :-
 1798    open(Path, read, In).
 1799
 1800'$close_source'(close(In, _Id, Ref), Message) :-
 1801    erase(Ref),
 1802    call_cleanup(
 1803        close(In),
 1804        '$pop_input_context'),
 1805    '$close_message'(Message).
 1806'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :-
 1807    erase(Ref),
 1808    call_cleanup(
 1809        '$restore_load_stream'(In, StreamState, Opts),
 1810        '$pop_input_context'),
 1811    '$close_message'(Message).
 1812
 1813'$close_message'(message(Level, Msg)) :-
 1814    !,
 1815    '$print_message'(Level, Msg).
 1816'$close_message'(_).
 1817
 1818
 1819%!  '$term_in_file'(+In, -Read, -RLayout, -Term, -TLayout,
 1820%!                  -Stream, +Parents, +Options) is multi.
 1821%
 1822%   True when Term is an expanded term from   In. Read is a raw term
 1823%   (before term-expansion). Stream is  the   actual  stream,  which
 1824%   starts at In, but may change due to processing included files.
 1825%
 1826%   @see '$source_term'/8 for details.
 1827
 1828'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1829    Parents \= [_,_|_],
 1830    (   '$load_input'(_, Input)
 1831    ->  stream_property(Input, file_name(File))
 1832    ),
 1833    '$set_source_location'(File, 0),
 1834    '$expanded_term'(In,
 1835                     begin_of_file, 0-0, Read, RLayout, Term, TLayout,
 1836                     Stream, Parents, Options).
 1837'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1838    '$skip_script_line'(In, Options),
 1839    '$read_clause_options'(Options, ReadOptions),
 1840    repeat,
 1841      read_clause(In, Raw,
 1842                  [ variable_names(Bindings),
 1843                    term_position(Pos),
 1844                    subterm_positions(RawLayout)
 1845                  | ReadOptions
 1846                  ]),
 1847      b_setval('$term_position', Pos),
 1848      b_setval('$variable_names', Bindings),
 1849      (   Raw == end_of_file
 1850      ->  !,
 1851          (   Parents = [_,_|_]     % Included file
 1852          ->  fail
 1853          ;   '$expanded_term'(In,
 1854                               Raw, RawLayout, Read, RLayout, Term, TLayout,
 1855                               Stream, Parents, Options)
 1856          )
 1857      ;   '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1858                           Stream, Parents, Options)
 1859      ).
 1860
 1861'$read_clause_options'([], []).
 1862'$read_clause_options'([H|T0], List) :-
 1863    (   '$read_clause_option'(H)
 1864    ->  List = [H|T]
 1865    ;   List = T
 1866    ),
 1867    '$read_clause_options'(T0, T).
 1868
 1869'$read_clause_option'(syntax_errors(_)).
 1870'$read_clause_option'(term_position(_)).
 1871'$read_clause_option'(process_comment(_)).
 1872
 1873'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1874                 Stream, Parents, Options) :-
 1875    E = error(_,_),
 1876    catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
 1877          '$print_message_fail'(E)),
 1878    (   Expanded \== []
 1879    ->  '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
 1880    ;   Term1 = Expanded,
 1881        Layout1 = ExpandedLayout
 1882    ),
 1883    (   nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
 1884    ->  (   Directive = include(File),
 1885            '$current_source_module'(Module),
 1886            '$valid_directive'(Module:include(File))
 1887        ->  stream_property(In, encoding(Enc)),
 1888            '$add_encoding'(Enc, Options, Options1),
 1889            '$source_term'(File, Read, RLayout, Term, TLayout,
 1890                           Stream, Parents, Options1)
 1891        ;   Directive = encoding(Enc)
 1892        ->  set_stream(In, encoding(Enc)),
 1893            fail
 1894        ;   Term = Term1,
 1895            Stream = In,
 1896            Read = Raw
 1897        )
 1898    ;   Term = Term1,
 1899        TLayout = Layout1,
 1900        Stream = In,
 1901        Read = Raw,
 1902        RLayout = RawLayout
 1903    ).
 1904
 1905'$expansion_member'(Var, Layout, Var, Layout) :-
 1906    var(Var),
 1907    !.
 1908'$expansion_member'([], _, _, _) :- !, fail.
 1909'$expansion_member'(List, ListLayout, Term, Layout) :-
 1910    is_list(List),
 1911    !,
 1912    (   var(ListLayout)
 1913    ->  '$member'(Term, List)
 1914    ;   is_list(ListLayout)
 1915    ->  '$member_rep2'(Term, Layout, List, ListLayout)
 1916    ;   Layout = ListLayout,
 1917        '$member'(Term, List)
 1918    ).
 1919'$expansion_member'(X, Layout, X, Layout).
 1920
 1921% pairwise member, repeating last element of the second
 1922% list.
 1923
 1924'$member_rep2'(H1, H2, [H1|_], [H2|_]).
 1925'$member_rep2'(H1, H2, [_|T1], [T2]) :-
 1926    !,
 1927    '$member_rep2'(H1, H2, T1, [T2]).
 1928'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
 1929    '$member_rep2'(H1, H2, T1, T2).
 1930
 1931%!  '$add_encoding'(+Enc, +Options0, -Options)
 1932
 1933'$add_encoding'(Enc, Options0, Options) :-
 1934    (   Options0 = [encoding(Enc)|_]
 1935    ->  Options = Options0
 1936    ;   Options = [encoding(Enc)|Options0]
 1937    ).
 1938
 1939
 1940:- multifile
 1941    '$included'/4.                  % Into, Line, File, LastModified
 1942:- dynamic
 1943    '$included'/4. 1944
 1945%!  '$record_included'(+Parents, +File, +Path, +Time, -Message) is det.
 1946%
 1947%   Record that we included File into the   head of Parents. This is
 1948%   troublesome when creating a QLF  file   because  this may happen
 1949%   before we opened the QLF file (and  we   do  not yet know how to
 1950%   open the file because we  do  not   yet  know  whether this is a
 1951%   module file or not).
 1952%
 1953%   I think that the only sensible  solution   is  to have a special
 1954%   statement for this, that may appear  both inside and outside QLF
 1955%   `parts'.
 1956
 1957'$record_included'([Parent|Parents], File, Path, Time,
 1958                   message(DoneMsgLevel,
 1959                           include_file(done(Level, file(File, Path))))) :-
 1960    source_location(SrcFile, Line),
 1961    !,
 1962    '$compilation_level'(Level),
 1963    '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
 1964    '$print_message'(StartMsgLevel,
 1965                     include_file(start(Level,
 1966                                        file(File, Path)))),
 1967    '$last'([Parent|Parents], Owner),
 1968    (   (   '$compilation_mode'(database)
 1969        ;   '$qlf_current_source'(Owner)
 1970        )
 1971    ->  '$store_admin_clause'(
 1972            system:'$included'(Parent, Line, Path, Time),
 1973            _, Owner, SrcFile:Line)
 1974    ;   '$qlf_include'(Owner, Parent, Line, Path, Time)
 1975    ).
 1976'$record_included'(_, _, _, _, true).
 1977
 1978%!  '$master_file'(+File, -MasterFile)
 1979%
 1980%   Find the primary load file from included files.
 1981
 1982'$master_file'(File, MasterFile) :-
 1983    '$included'(MasterFile0, _Line, File, _Time),
 1984    !,
 1985    '$master_file'(MasterFile0, MasterFile).
 1986'$master_file'(File, File).
 1987
 1988
 1989'$skip_script_line'(_In, Options) :-
 1990    '$option'(check_script(false), Options),
 1991    !.
 1992'$skip_script_line'(In, _Options) :-
 1993    (   peek_char(In, #)
 1994    ->  skip(In, 10)
 1995    ;   true
 1996    ).
 1997
 1998'$set_encoding'(Stream, Options) :-
 1999    '$option'(encoding(Enc), Options),
 2000    !,
 2001    Enc \== default,
 2002    set_stream(Stream, encoding(Enc)).
 2003'$set_encoding'(_, _).
 2004
 2005
 2006'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
 2007    (   stream_property(In, file_name(_))
 2008    ->  HasName = true,
 2009        (   stream_property(In, position(_))
 2010        ->  HasPos = true
 2011        ;   HasPos = false,
 2012            set_stream(In, record_position(true))
 2013        )
 2014    ;   HasName = false,
 2015        set_stream(In, file_name(Id)),
 2016        (   stream_property(In, position(_))
 2017        ->  HasPos = true
 2018        ;   HasPos = false,
 2019            set_stream(In, record_position(true))
 2020        )
 2021    ).
 2022
 2023'$restore_load_stream'(In, _State, Options) :-
 2024    memberchk(close(true), Options),
 2025    !,
 2026    close(In).
 2027'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
 2028    (   HasName == false
 2029    ->  set_stream(In, file_name(''))
 2030    ;   true
 2031    ),
 2032    (   HasPos == false
 2033    ->  set_stream(In, record_position(false))
 2034    ;   true
 2035    ).
 2036
 2037
 2038                 /*******************************
 2039                 *          DERIVED FILES       *
 2040                 *******************************/
 2041
 2042:- dynamic
 2043    '$derived_source_db'/3.         % Loaded, DerivedFrom, Time
 2044
 2045'$register_derived_source'(_, '-') :- !.
 2046'$register_derived_source'(Loaded, DerivedFrom) :-
 2047    retractall('$derived_source_db'(Loaded, _, _)),
 2048    time_file(DerivedFrom, Time),
 2049    assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
 2050
 2051%       Auto-importing dynamic predicates is not very elegant and
 2052%       leads to problems with qsave_program/[1,2]
 2053
 2054'$derived_source'(Loaded, DerivedFrom, Time) :-
 2055    '$derived_source_db'(Loaded, DerivedFrom, Time).
 2056
 2057
 2058                /********************************
 2059                *       LOAD PREDICATES         *
 2060                *********************************/
 2061
 2062:- meta_predicate
 2063    ensure_loaded(:),
 2064    [:|+],
 2065    consult(:),
 2066    use_module(:),
 2067    use_module(:, +),
 2068    reexport(:),
 2069    reexport(:, +),
 2070    load_files(:),
 2071    load_files(:, +). 2072
 2073%!  ensure_loaded(+FileOrListOfFiles)
 2074%
 2075%   Load specified files, provided they where not loaded before. If the
 2076%   file is a module file import the public predicates into the context
 2077%   module.
 2078
 2079ensure_loaded(Files) :-
 2080    load_files(Files, [if(not_loaded)]).
 2081
 2082%!  use_module(+FileOrListOfFiles)
 2083%
 2084%   Very similar to ensure_loaded/1, but insists on the loaded file to
 2085%   be a module file. If the file is already imported, but the public
 2086%   predicates are not yet imported into the context module, then do
 2087%   so.
 2088
 2089use_module(Files) :-
 2090    load_files(Files, [ if(not_loaded),
 2091                        must_be_module(true)
 2092                      ]).
 2093
 2094%!  use_module(+File, +ImportList)
 2095%
 2096%   As use_module/1, but takes only one file argument and imports only
 2097%   the specified predicates rather than all public predicates.
 2098
 2099use_module(File, Import) :-
 2100    load_files(File, [ if(not_loaded),
 2101                       must_be_module(true),
 2102                       imports(Import)
 2103                     ]).
 2104
 2105%!  reexport(+Files)
 2106%
 2107%   As use_module/1, exporting all imported predicates.
 2108
 2109reexport(Files) :-
 2110    load_files(Files, [ if(not_loaded),
 2111                        must_be_module(true),
 2112                        reexport(true)
 2113                      ]).
 2114
 2115%!  reexport(+File, +ImportList)
 2116%
 2117%   As use_module/1, re-exporting all imported predicates.
 2118
 2119reexport(File, Import) :-
 2120    load_files(File, [ if(not_loaded),
 2121                       must_be_module(true),
 2122                       imports(Import),
 2123                       reexport(true)
 2124                     ]).
 2125
 2126
 2127[X] :-
 2128    !,
 2129    consult(X).
 2130[M:F|R] :-
 2131    consult(M:[F|R]).
 2132
 2133consult(M:X) :-
 2134    X == user,
 2135    !,
 2136    flag('$user_consult', N, N+1),
 2137    NN is N + 1,
 2138    atom_concat('user://', NN, Id),
 2139    load_files(M:Id, [stream(user_input), check_script(false), silent(false)]).
 2140consult(List) :-
 2141    load_files(List, [expand(true)]).
 2142
 2143%!  load_files(:File, +Options)
 2144%
 2145%   Common entry for all the consult derivates.  File is the raw user
 2146%   specified file specification, possibly tagged with the module.
 2147
 2148load_files(Files) :-
 2149    load_files(Files, []).
 2150load_files(Module:Files, Options) :-
 2151    '$must_be'(list, Options),
 2152    '$load_files'(Files, Module, Options).
 2153
 2154'$load_files'(X, _, _) :-
 2155    var(X),
 2156    !,
 2157    '$instantiation_error'(X).
 2158'$load_files'([], _, _) :- !.
 2159'$load_files'(Id, Module, Options) :-   % load_files(foo, [stream(In)])
 2160    '$option'(stream(_), Options),
 2161    !,
 2162    (   atom(Id)
 2163    ->  '$load_file'(Id, Module, Options)
 2164    ;   throw(error(type_error(atom, Id), _))
 2165    ).
 2166'$load_files'(List, Module, Options) :-
 2167    List = [_|_],
 2168    !,
 2169    '$must_be'(list, List),
 2170    '$load_file_list'(List, Module, Options).
 2171'$load_files'(File, Module, Options) :-
 2172    '$load_one_file'(File, Module, Options).
 2173
 2174'$load_file_list'([], _, _).
 2175'$load_file_list'([File|Rest], Module, Options) :-
 2176    E = error(_,_),
 2177    catch('$load_one_file'(File, Module, Options), E,
 2178          '$print_message'(error, E)),
 2179    '$load_file_list'(Rest, Module, Options).
 2180
 2181
 2182'$load_one_file'(Spec, Module, Options) :-
 2183    atomic(Spec),
 2184    '$option'(expand(Expand), Options, false),
 2185    Expand == true,
 2186    !,
 2187    expand_file_name(Spec, Expanded),
 2188    (   Expanded = [Load]
 2189    ->  true
 2190    ;   Load = Expanded
 2191    ),
 2192    '$load_files'(Load, Module, [expand(false)|Options]).
 2193'$load_one_file'(File, Module, Options) :-
 2194    strip_module(Module:File, Into, PlainFile),
 2195    '$load_file'(PlainFile, Into, Options).
 2196
 2197
 2198%!  '$noload'(+Condition, +FullFile, +Options) is semidet.
 2199%
 2200%   True of FullFile should _not_ be loaded.
 2201
 2202'$noload'(true, _, _) :-
 2203    !,
 2204    fail.
 2205'$noload'(_, FullFile, _Options) :-
 2206    '$time_source_file'(FullFile, Time, system),
 2207    Time > 0.0,
 2208    !.
 2209'$noload'(not_loaded, FullFile, _) :-
 2210    source_file(FullFile),
 2211    !.
 2212'$noload'(changed, Derived, _) :-
 2213    '$derived_source'(_FullFile, Derived, LoadTime),
 2214    time_file(Derived, Modified),
 2215    Modified @=< LoadTime,
 2216    !.
 2217'$noload'(changed, FullFile, Options) :-
 2218    '$time_source_file'(FullFile, LoadTime, user),
 2219    '$modified_id'(FullFile, Modified, Options),
 2220    Modified @=< LoadTime,
 2221    !.
 2222
 2223%!  '$qlf_file'(+Spec, +PlFile, -LoadFile, -Mode, +Options) is det.
 2224%
 2225%   Determine how to load the source. LoadFile is the file to be loaded,
 2226%   Mode is how to load it. Mode is one of
 2227%
 2228%     - compile
 2229%     Normal source compilation
 2230%     - qcompile
 2231%     Compile from source, creating a QLF file in the process
 2232%     - qload
 2233%     Load from QLF file.
 2234%     - stream
 2235%     Load from a stream.  Content can be a source or QLF file.
 2236%
 2237%   @arg Spec is the original search specification
 2238%   @arg PlFile is the resolved absolute path to the Prolog file.
 2239
 2240'$qlf_file'(Spec, _, Spec, stream, Options) :-
 2241    '$option'(stream(_), Options),      % stream: no choice
 2242    !.
 2243'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
 2244    '$spec_extension'(Spec, Ext),       % user explicitly specified
 2245    user:prolog_file_type(Ext, prolog),
 2246    !.
 2247'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :-
 2248    '$compilation_mode'(database),
 2249    file_name_extension(Base, PlExt, FullFile),
 2250    user:prolog_file_type(PlExt, prolog),
 2251    user:prolog_file_type(QlfExt, qlf),
 2252    file_name_extension(Base, QlfExt, QlfFile),
 2253    (   access_file(QlfFile, read),
 2254        (   '$qlf_out_of_date'(FullFile, QlfFile, Why)
 2255        ->  (   access_file(QlfFile, write)
 2256            ->  print_message(informational,
 2257                              qlf(recompile(Spec, FullFile, QlfFile, Why))),
 2258                Mode = qcompile,
 2259                LoadFile = FullFile
 2260            ;   Why == old,
 2261                current_prolog_flag(home, PlHome),
 2262                sub_atom(FullFile, 0, _, _, PlHome)
 2263            ->  print_message(silent,
 2264                              qlf(system_lib_out_of_date(Spec, QlfFile))),
 2265                Mode = qload,
 2266                LoadFile = QlfFile
 2267            ;   print_message(warning,
 2268                              qlf(can_not_recompile(Spec, QlfFile, Why))),
 2269                Mode = compile,
 2270                LoadFile = FullFile
 2271            )
 2272        ;   Mode = qload,
 2273            LoadFile = QlfFile
 2274        )
 2275    ->  !
 2276    ;   '$qlf_auto'(FullFile, QlfFile, Options)
 2277    ->  !, Mode = qcompile,
 2278        LoadFile = FullFile
 2279    ).
 2280'$qlf_file'(_, FullFile, FullFile, compile, _).
 2281
 2282
 2283%!  '$qlf_out_of_date'(+PlFile, +QlfFile, -Why) is semidet.
 2284%
 2285%   True if the  QlfFile  file  is   out-of-date  because  of  Why. This
 2286%   predicate is the negation such that we can return the reason.
 2287
 2288'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
 2289    (   access_file(PlFile, read)
 2290    ->  time_file(PlFile, PlTime),
 2291        time_file(QlfFile, QlfTime),
 2292        (   PlTime > QlfTime
 2293        ->  Why = old                   % PlFile is newer
 2294        ;   Error = error(Formal,_),
 2295            catch('$qlf_sources'(QlfFile, _Files), Error, true),
 2296            nonvar(Formal)              % QlfFile is incompatible
 2297        ->  Why = Error
 2298        ;   fail                        % QlfFile is up-to-date and ok
 2299        )
 2300    ;   fail                            % can not read .pl; try .qlf
 2301    ).
 2302
 2303%!  '$qlf_auto'(+PlFile, +QlfFile, +Options) is semidet.
 2304%
 2305%   True if we create QlfFile using   qcompile/2. This is determined
 2306%   by the option qcompile(QlfMode) or, if   this is not present, by
 2307%   the prolog_flag qcompile.
 2308
 2309:- create_prolog_flag(qcompile, false, [type(atom)]). 2310
 2311'$qlf_auto'(PlFile, QlfFile, Options) :-
 2312    (   memberchk(qcompile(QlfMode), Options)
 2313    ->  true
 2314    ;   current_prolog_flag(qcompile, QlfMode),
 2315        \+ '$in_system_dir'(PlFile)
 2316    ),
 2317    (   QlfMode == auto
 2318    ->  true
 2319    ;   QlfMode == large,
 2320        size_file(PlFile, Size),
 2321        Size > 100000
 2322    ),
 2323    access_file(QlfFile, write).
 2324
 2325'$in_system_dir'(PlFile) :-
 2326    current_prolog_flag(home, Home),
 2327    sub_atom(PlFile, 0, _, _, Home).
 2328
 2329'$spec_extension'(File, Ext) :-
 2330    atom(File),
 2331    file_name_extension(_, Ext, File).
 2332'$spec_extension'(Spec, Ext) :-
 2333    compound(Spec),
 2334    arg(1, Spec, Arg),
 2335    '$spec_extension'(Arg, Ext).
 2336
 2337
 2338%!  '$load_file'(+Spec, +ContextModule, +Options) is det.
 2339%
 2340%   Load the file Spec  into   ContextModule  controlled by Options.
 2341%   This wrapper deals with two cases  before proceeding to the real
 2342%   loader:
 2343%
 2344%       * User hooks based on prolog_load_file/2
 2345%       * The file is already loaded.
 2346
 2347:- dynamic
 2348    '$resolved_source_path_db'/3.                % ?Spec, ?Dialect, ?Path
 2349
 2350'$load_file'(File, Module, Options) :-
 2351    '$error_count'(E0, W0),
 2352    '$load_file_e'(File, Module, Options),
 2353    '$error_count'(E1, W1),
 2354    Errors is E1-E0,
 2355    Warnings is W1-W0,
 2356    (   Errors+Warnings =:= 0
 2357    ->  true
 2358    ;   '$print_message'(silent, load_file_errors(File, Errors, Warnings))
 2359    ).
 2360
 2361'$error_count'(Errors, Warnings) :-
 2362    current_prolog_flag(threads, true),
 2363    !,
 2364    thread_self(Me),
 2365    thread_statistics(Me, errors, Errors),
 2366    thread_statistics(Me, warnings, Warnings).
 2367'$error_count'(Errors, Warnings) :-
 2368    statistics(errors, Errors),
 2369    statistics(warnings, Warnings).
 2370
 2371'$load_file_e'(File, Module, Options) :-
 2372    \+ memberchk(stream(_), Options),
 2373    user:prolog_load_file(Module:File, Options),
 2374    !.
 2375'$load_file_e'(File, Module, Options) :-
 2376    memberchk(stream(_), Options),
 2377    !,
 2378    '$assert_load_context_module'(File, Module, Options),
 2379    '$qdo_load_file'(File, File, Module, Options).
 2380'$load_file_e'(File, Module, Options) :-
 2381    (   '$resolved_source_path'(File, FullFile, Options)
 2382    ->  true
 2383    ;   '$resolve_source_path'(File, FullFile, Options)
 2384    ),
 2385    '$mt_load_file'(File, FullFile, Module, Options).
 2386
 2387%!  '$resolved_source_path'(+File, -FullFile, +Options) is semidet.
 2388%
 2389%   True when File has already been resolved to an absolute path.
 2390
 2391'$resolved_source_path'(File, FullFile, Options) :-
 2392    current_prolog_flag(emulated_dialect, Dialect),
 2393    '$resolved_source_path_db'(File, Dialect, FullFile),
 2394    (   '$source_file_property'(FullFile, from_state, true)
 2395    ;   '$source_file_property'(FullFile, resource, true)
 2396    ;   '$option'(if(If), Options, true),
 2397        '$noload'(If, FullFile, Options)
 2398    ),
 2399    !.
 2400
 2401%!  '$resolve_source_path'(+File, -FullFile, Options) is det.
 2402%
 2403%   Resolve a source file specification to   an absolute path. May throw
 2404%   existence and other errors.
 2405
 2406'$resolve_source_path'(File, FullFile, _Options) :-
 2407    absolute_file_name(File, FullFile,
 2408                       [ file_type(prolog),
 2409                         access(read)
 2410                       ]),
 2411    '$register_resolved_source_path'(File, FullFile).
 2412
 2413
 2414'$register_resolved_source_path'(File, FullFile) :-
 2415    (   compound(File)
 2416    ->  current_prolog_flag(emulated_dialect, Dialect),
 2417        (   '$resolved_source_path_db'(File, Dialect, FullFile)
 2418        ->  true
 2419        ;   asserta('$resolved_source_path_db'(File, Dialect, FullFile))
 2420        )
 2421    ;   true
 2422    ).
 2423
 2424%!  '$translated_source'(+Old, +New) is det.
 2425%
 2426%   Called from loading a QLF state when source files are being renamed.
 2427
 2428:- public '$translated_source'/2. 2429'$translated_source'(Old, New) :-
 2430    forall(retract('$resolved_source_path_db'(File, Dialect, Old)),
 2431           assertz('$resolved_source_path_db'(File, Dialect, New))).
 2432
 2433%!  '$register_resource_file'(+FullFile) is det.
 2434%
 2435%   If we load a file from a resource we   lock  it, so we never have to
 2436%   check the modification again.
 2437
 2438'$register_resource_file'(FullFile) :-
 2439    (   sub_atom(FullFile, 0, _, _, 'res://')
 2440    ->  '$set_source_file'(FullFile, resource, true)
 2441    ;   true
 2442    ).
 2443
 2444%!  '$already_loaded'(+File, +FullFile, +Module, +Options) is det.
 2445%
 2446%   Called if File is already loaded. If  this is a module-file, the
 2447%   module must be imported into the context  Module. If it is not a
 2448%   module file, it must be reloaded.
 2449%
 2450%   @bug    A file may be associated with multiple modules.  How
 2451%           do we find the `main export module'?  Currently there
 2452%           is no good way to find out which module is associated
 2453%           to the file as a result of the first :- module/2 term.
 2454
 2455'$already_loaded'(_File, FullFile, Module, Options) :-
 2456    '$assert_load_context_module'(FullFile, Module, Options),
 2457    '$current_module'(LoadModules, FullFile),
 2458    !,
 2459    (   atom(LoadModules)
 2460    ->  LoadModule = LoadModules
 2461    ;   LoadModules = [LoadModule|_]
 2462    ),
 2463    '$import_from_loaded_module'(LoadModule, Module, Options).
 2464'$already_loaded'(_, _, user, _) :- !.
 2465'$already_loaded'(File, FullFile, Module, Options) :-
 2466    (   '$load_context_module'(FullFile, Module, CtxOptions),
 2467        '$load_ctx_options'(Options, CtxOptions)
 2468    ->  true
 2469    ;   '$load_file'(File, Module, [if(true)|Options])
 2470    ).
 2471
 2472%!  '$mt_load_file'(+File, +FullFile, +Module, +Options) is det.
 2473%
 2474%   Deal with multi-threaded  loading  of   files.  The  thread that
 2475%   wishes to load the thread first will  do so, while other threads
 2476%   will wait until the leader finished and  than act as if the file
 2477%   is already loaded.
 2478%
 2479%   Synchronisation is handled using  a   message  queue that exists
 2480%   while the file is being loaded.   This synchronisation relies on
 2481%   the fact that thread_get_message/1 throws  an existence_error if
 2482%   the message queue  is  destroyed.  This   is  hacky.  Events  or
 2483%   condition variables would have made a cleaner design.
 2484
 2485:- dynamic
 2486    '$loading_file'/3.              % File, Queue, Thread
 2487:- volatile
 2488    '$loading_file'/3. 2489
 2490'$mt_load_file'(File, FullFile, Module, Options) :-
 2491    current_prolog_flag(threads, true),
 2492    !,
 2493    '$sig_atomic'(setup_call_cleanup(
 2494                      with_mutex('$load_file',
 2495                                 '$mt_start_load'(FullFile, Loading, Options)),
 2496                      '$mt_do_load'(Loading, File, FullFile, Module, Options),
 2497                      '$mt_end_load'(Loading))).
 2498'$mt_load_file'(File, FullFile, Module, Options) :-
 2499    '$option'(if(If), Options, true),
 2500    '$noload'(If, FullFile, Options),
 2501    !,
 2502    '$already_loaded'(File, FullFile, Module, Options).
 2503'$mt_load_file'(File, FullFile, Module, Options) :-
 2504    '$sig_atomic'('$qdo_load_file'(File, FullFile, Module, Options)).
 2505
 2506'$mt_start_load'(FullFile, queue(Queue), _) :-
 2507    '$loading_file'(FullFile, Queue, LoadThread),
 2508    \+ thread_self(LoadThread),
 2509    !.
 2510'$mt_start_load'(FullFile, already_loaded, Options) :-
 2511    '$option'(if(If), Options, true),
 2512    '$noload'(If, FullFile, Options),
 2513    !.
 2514'$mt_start_load'(FullFile, Ref, _) :-
 2515    thread_self(Me),
 2516    message_queue_create(Queue),
 2517    assertz('$loading_file'(FullFile, Queue, Me), Ref).
 2518
 2519'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
 2520    !,
 2521    catch(thread_get_message(Queue, _), error(_,_), true),
 2522    '$already_loaded'(File, FullFile, Module, Options).
 2523'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
 2524    !,
 2525    '$already_loaded'(File, FullFile, Module, Options).
 2526'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
 2527    '$assert_load_context_module'(FullFile, Module, Options),
 2528    '$qdo_load_file'(File, FullFile, Module, Options).
 2529
 2530'$mt_end_load'(queue(_)) :- !.
 2531'$mt_end_load'(already_loaded) :- !.
 2532'$mt_end_load'(Ref) :-
 2533    clause('$loading_file'(_, Queue, _), _, Ref),
 2534    erase(Ref),
 2535    thread_send_message(Queue, done),
 2536    message_queue_destroy(Queue).
 2537
 2538
 2539%!  '$qdo_load_file'(+Spec, +FullFile, +ContextModule, +Options) is det.
 2540%
 2541%   Switch to qcompile mode if requested by the option '$qlf'(+Out)
 2542
 2543'$qdo_load_file'(File, FullFile, Module, Options) :-
 2544    '$qdo_load_file2'(File, FullFile, Module, Action, Options),
 2545    '$register_resource_file'(FullFile),
 2546    '$run_initialization'(FullFile, Action, Options).
 2547
 2548'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
 2549    memberchk('$qlf'(QlfOut), Options),
 2550    '$stage_file'(QlfOut, StageQlf),
 2551    !,
 2552    setup_call_catcher_cleanup(
 2553        '$qstart'(StageQlf, Module, State),
 2554        '$do_load_file'(File, FullFile, Module, Action, Options),
 2555        Catcher,
 2556        '$qend'(State, Catcher, StageQlf, QlfOut)).
 2557'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
 2558    '$do_load_file'(File, FullFile, Module, Action, Options).
 2559
 2560'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
 2561    '$qlf_open'(Qlf),
 2562    '$compilation_mode'(OldMode, qlf),
 2563    '$set_source_module'(OldModule, Module).
 2564
 2565'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :-
 2566    '$set_source_module'(_, OldModule),
 2567    '$set_compilation_mode'(OldMode),
 2568    '$qlf_close',
 2569    '$install_staged_file'(Catcher, StageQlf, QlfOut, warn).
 2570
 2571'$set_source_module'(OldModule, Module) :-
 2572    '$current_source_module'(OldModule),
 2573    '$set_source_module'(Module).
 2574
 2575%!  '$do_load_file'(+Spec, +FullFile, +ContextModule,
 2576%!                  -Action, +Options) is det.
 2577%
 2578%   Perform the actual loading.
 2579
 2580'$do_load_file'(File, FullFile, Module, Action, Options) :-
 2581    '$option'(derived_from(DerivedFrom), Options, -),
 2582    '$register_derived_source'(FullFile, DerivedFrom),
 2583    '$qlf_file'(File, FullFile, Absolute, Mode, Options),
 2584    (   Mode == qcompile
 2585    ->  qcompile(Module:File, Options)
 2586    ;   '$do_load_file_2'(File, Absolute, Module, Action, Options)
 2587    ).
 2588
 2589'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
 2590    '$source_file_property'(Absolute, number_of_clauses, OldClauses),
 2591    statistics(cputime, OldTime),
 2592
 2593    '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
 2594                  Options),
 2595
 2596    '$compilation_level'(Level),
 2597    '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
 2598    '$print_message'(StartMsgLevel,
 2599                     load_file(start(Level,
 2600                                     file(File, Absolute)))),
 2601
 2602    (   memberchk(stream(FromStream), Options)
 2603    ->  Input = stream
 2604    ;   Input = source
 2605    ),
 2606
 2607    (   Input == stream,
 2608        (   '$option'(format(qlf), Options, source)
 2609        ->  set_stream(FromStream, file_name(Absolute)),
 2610            '$qload_stream'(FromStream, Module, Action, LM, Options)
 2611        ;   '$consult_file'(stream(Absolute, FromStream, []),
 2612                            Module, Action, LM, Options)
 2613        )
 2614    ->  true
 2615    ;   Input == source,
 2616        file_name_extension(_, Ext, Absolute),
 2617        (   user:prolog_file_type(Ext, qlf),
 2618            E = error(_,_),
 2619            catch('$qload_file'(Absolute, Module, Action, LM, Options),
 2620                  E,
 2621                  print_message(warning, E))
 2622        ->  true
 2623        ;   '$consult_file'(Absolute, Module, Action, LM, Options)
 2624        )
 2625    ->  true
 2626    ;   '$print_message'(error, load_file(failed(File))),
 2627        fail
 2628    ),
 2629
 2630    '$import_from_loaded_module'(LM, Module, Options),
 2631
 2632    '$source_file_property'(Absolute, number_of_clauses, NewClauses),
 2633    statistics(cputime, Time),
 2634    ClausesCreated is NewClauses - OldClauses,
 2635    TimeUsed is Time - OldTime,
 2636
 2637    '$print_message'(DoneMsgLevel,
 2638                     load_file(done(Level,
 2639                                    file(File, Absolute),
 2640                                    Action,
 2641                                    LM,
 2642                                    TimeUsed,
 2643                                    ClausesCreated))),
 2644
 2645    '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef).
 2646
 2647'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
 2648              Options) :-
 2649    '$save_file_scoped_flags'(ScopedFlags),
 2650    '$set_sandboxed_load'(Options, OldSandBoxed),
 2651    '$set_verbose_load'(Options, OldVerbose),
 2652    '$set_optimise_load'(Options),
 2653    '$update_autoload_level'(Options, OldAutoLevel),
 2654    '$set_no_xref'(OldXRef).
 2655
 2656'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :-
 2657    '$set_autoload_level'(OldAutoLevel),
 2658    set_prolog_flag(xref, OldXRef),
 2659    set_prolog_flag(verbose_load, OldVerbose),
 2660    set_prolog_flag(sandboxed_load, OldSandBoxed),
 2661    '$restore_file_scoped_flags'(ScopedFlags).
 2662
 2663
 2664%!  '$save_file_scoped_flags'(-State) is det.
 2665%!  '$restore_file_scoped_flags'(-State) is det.
 2666%
 2667%   Save/restore flags that are scoped to a compilation unit.
 2668
 2669'$save_file_scoped_flags'(State) :-
 2670    current_predicate(findall/3),          % Not when doing boot compile
 2671    !,
 2672    findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
 2673'$save_file_scoped_flags'([]).
 2674
 2675'$save_file_scoped_flag'(Flag-Value) :-
 2676    '$file_scoped_flag'(Flag, Default),
 2677    (   current_prolog_flag(Flag, Value)
 2678    ->  true
 2679    ;   Value = Default
 2680    ).
 2681
 2682'$file_scoped_flag'(generate_debug_info, true).
 2683'$file_scoped_flag'(optimise,            false).
 2684'$file_scoped_flag'(xref,                false).
 2685
 2686'$restore_file_scoped_flags'([]).
 2687'$restore_file_scoped_flags'([Flag-Value|T]) :-
 2688    set_prolog_flag(Flag, Value),
 2689    '$restore_file_scoped_flags'(T).
 2690
 2691
 2692%!  '$import_from_loaded_module'(LoadedModule, Module, Options) is det.
 2693%
 2694%   Import public predicates from LoadedModule into Module
 2695
 2696'$import_from_loaded_module'(LoadedModule, Module, Options) :-
 2697    LoadedModule \== Module,
 2698    atom(LoadedModule),
 2699    !,
 2700    '$option'(imports(Import), Options, all),
 2701    '$option'(reexport(Reexport), Options, false),
 2702    '$import_list'(Module, LoadedModule, Import, Reexport).
 2703'$import_from_loaded_module'(_, _, _).
 2704
 2705
 2706%!  '$set_verbose_load'(+Options, -Old) is det.
 2707%
 2708%   Set the =verbose_load= flag according to   Options and unify Old
 2709%   with the old value.
 2710
 2711'$set_verbose_load'(Options, Old) :-
 2712    current_prolog_flag(verbose_load, Old),
 2713    (   memberchk(silent(Silent), Options)
 2714    ->  (   '$negate'(Silent, Level0)
 2715        ->  '$load_msg_compat'(Level0, Level)
 2716        ;   Level = Silent
 2717        ),
 2718        set_prolog_flag(verbose_load, Level)
 2719    ;   true
 2720    ).
 2721
 2722'$negate'(true, false).
 2723'$negate'(false, true).
 2724
 2725%!  '$set_sandboxed_load'(+Options, -Old) is det.
 2726%
 2727%   Update the Prolog flag  =sandboxed_load=   from  Options. Old is
 2728%   unified with the old flag.
 2729%
 2730%   @error permission_error(leave, sandbox, -)
 2731
 2732'$set_sandboxed_load'(Options, Old) :-
 2733    current_prolog_flag(sandboxed_load, Old),
 2734    (   memberchk(sandboxed(SandBoxed), Options),
 2735        '$enter_sandboxed'(Old, SandBoxed, New),
 2736        New \== Old
 2737    ->  set_prolog_flag(sandboxed_load, New)
 2738    ;   true
 2739    ).
 2740
 2741'$enter_sandboxed'(Old, New, SandBoxed) :-
 2742    (   Old == false, New == true
 2743    ->  SandBoxed = true,
 2744        '$ensure_loaded_library_sandbox'
 2745    ;   Old == true, New == false
 2746    ->  throw(error(permission_error(leave, sandbox, -), _))
 2747    ;   SandBoxed = Old
 2748    ).
 2749'$enter_sandboxed'(false, true, true).
 2750
 2751'$ensure_loaded_library_sandbox' :-
 2752    source_file_property(library(sandbox), module(sandbox)),
 2753    !.
 2754'$ensure_loaded_library_sandbox' :-
 2755    load_files(library(sandbox), [if(not_loaded), silent(true)]).
 2756
 2757'$set_optimise_load'(Options) :-
 2758    (   '$option'(optimise(Optimise), Options)
 2759    ->  set_prolog_flag(optimise, Optimise)
 2760    ;   true
 2761    ).
 2762
 2763'$set_no_xref'(OldXRef) :-
 2764    (   current_prolog_flag(xref, OldXRef)
 2765    ->  true
 2766    ;   OldXRef = false
 2767    ),
 2768    set_prolog_flag(xref, false).
 2769
 2770
 2771%!  '$update_autoload_level'(+Options, -OldLevel)
 2772%
 2773%   Update the '$autoload_nesting' and return the old value.
 2774
 2775:- thread_local
 2776    '$autoload_nesting'/1. 2777
 2778'$update_autoload_level'(Options, AutoLevel) :-
 2779    '$option'(autoload(Autoload), Options, false),
 2780    (   '$autoload_nesting'(CurrentLevel)
 2781    ->  AutoLevel = CurrentLevel
 2782    ;   AutoLevel = 0
 2783    ),
 2784    (   Autoload == false
 2785    ->  true
 2786    ;   NewLevel is AutoLevel + 1,
 2787        '$set_autoload_level'(NewLevel)
 2788    ).
 2789
 2790'$set_autoload_level'(New) :-
 2791    retractall('$autoload_nesting'(_)),
 2792    asserta('$autoload_nesting'(New)).
 2793
 2794
 2795%!  '$print_message'(+Level, +Term) is det.
 2796%
 2797%   As print_message/2, but deal with  the   fact  that  the message
 2798%   system might not yet be loaded.
 2799
 2800'$print_message'(Level, Term) :-
 2801    current_predicate(system:print_message/2),
 2802    !,
 2803    print_message(Level, Term).
 2804'$print_message'(warning, Term) :-
 2805    source_location(File, Line),
 2806    !,
 2807    format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
 2808'$print_message'(error, Term) :-
 2809    !,
 2810    source_location(File, Line),
 2811    !,
 2812    format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
 2813'$print_message'(_Level, _Term).
 2814
 2815'$print_message_fail'(E) :-
 2816    '$print_message'(error, E),
 2817    fail.
 2818
 2819%!  '$consult_file'(+Path, +Module, -Action, -LoadedIn, +Options)
 2820%
 2821%   Called  from  '$do_load_file'/4  using  the   goal  returned  by
 2822%   '$consult_goal'/2. This means that the  calling conventions must
 2823%   be kept synchronous with '$qload_file'/6.
 2824
 2825'$consult_file'(Absolute, Module, What, LM, Options) :-
 2826    '$current_source_module'(Module),   % same module
 2827    !,
 2828    '$consult_file_2'(Absolute, Module, What, LM, Options).
 2829'$consult_file'(Absolute, Module, What, LM, Options) :-
 2830    '$set_source_module'(OldModule, Module),
 2831    '$ifcompiling'('$qlf_start_sub_module'(Module)),
 2832    '$consult_file_2'(Absolute, Module, What, LM, Options),
 2833    '$ifcompiling'('$qlf_end_part'),
 2834    '$set_source_module'(OldModule).
 2835
 2836'$consult_file_2'(Absolute, Module, What, LM, Options) :-
 2837    '$set_source_module'(OldModule, Module),
 2838    '$load_id'(Absolute, Id, Modified, Options),
 2839    '$compile_type'(What),
 2840    '$save_lex_state'(LexState, Options),
 2841    '$set_dialect'(Options),
 2842    setup_call_cleanup(
 2843        '$start_consult'(Id, Modified),
 2844        '$load_file'(Absolute, Id, LM, Options),
 2845        '$end_consult'(Id, LexState, OldModule)).
 2846
 2847'$end_consult'(Id, LexState, OldModule) :-
 2848    '$end_consult'(Id),
 2849    '$restore_lex_state'(LexState),
 2850    '$set_source_module'(OldModule).
 2851
 2852
 2853:- create_prolog_flag(emulated_dialect, swi, [type(atom)]). 2854
 2855%!  '$save_lex_state'(-LexState, +Options) is det.
 2856
 2857'$save_lex_state'(State, Options) :-
 2858    memberchk(scope_settings(false), Options),
 2859    !,
 2860    State = (-).
 2861'$save_lex_state'(lexstate(Style, Dialect), _) :-
 2862    '$style_check'(Style, Style),
 2863    current_prolog_flag(emulated_dialect, Dialect).
 2864
 2865'$restore_lex_state'(-) :- !.
 2866'$restore_lex_state'(lexstate(Style, Dialect)) :-
 2867    '$style_check'(_, Style),
 2868    set_prolog_flag(emulated_dialect, Dialect).
 2869
 2870'$set_dialect'(Options) :-
 2871    memberchk(dialect(Dialect), Options),
 2872    !,
 2873    '$expects_dialect'(Dialect).
 2874'$set_dialect'(_).
 2875
 2876'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
 2877    !,
 2878    '$modified_id'(Id, Modified, Options).
 2879'$load_id'(Id, Id, Modified, Options) :-
 2880    '$modified_id'(Id, Modified, Options).
 2881
 2882'$modified_id'(_, Modified, Options) :-
 2883    '$option'(modified(Stamp), Options, Def),
 2884    Stamp \== Def,
 2885    !,
 2886    Modified = Stamp.
 2887'$modified_id'(Id, Modified, _) :-
 2888    catch(time_file(Id, Modified),
 2889          error(_, _),
 2890          fail),
 2891    !.
 2892'$modified_id'(_, 0.0, _).
 2893
 2894
 2895'$compile_type'(What) :-
 2896    '$compilation_mode'(How),
 2897    (   How == database
 2898    ->  What = compiled
 2899    ;   How == qlf
 2900    ->  What = '*qcompiled*'
 2901    ;   What = 'boot compiled'
 2902    ).
 2903
 2904%!  '$assert_load_context_module'(+File, -Module, -Options)
 2905%
 2906%   Record the module a file was loaded from (see make/0). The first
 2907%   clause deals with loading from  another   file.  On reload, this
 2908%   clause will be discarded by  $start_consult/1. The second clause
 2909%   deals with reload from the toplevel.   Here  we avoid creating a
 2910%   duplicate dynamic (i.e., not related to a source) clause.
 2911
 2912:- dynamic
 2913    '$load_context_module'/3. 2914:- multifile
 2915    '$load_context_module'/3. 2916
 2917'$assert_load_context_module'(_, _, Options) :-
 2918    memberchk(register(false), Options),
 2919    !.
 2920'$assert_load_context_module'(File, Module, Options) :-
 2921    source_location(FromFile, Line),
 2922    !,
 2923    '$master_file'(FromFile, MasterFile),
 2924    '$check_load_non_module'(File, Module),
 2925    '$add_dialect'(Options, Options1),
 2926    '$load_ctx_options'(Options1, Options2),
 2927    '$store_admin_clause'(
 2928        system:'$load_context_module'(File, Module, Options2),
 2929        _Layout, MasterFile, FromFile:Line).
 2930'$assert_load_context_module'(File, Module, Options) :-
 2931    '$check_load_non_module'(File, Module),
 2932    '$add_dialect'(Options, Options1),
 2933    '$load_ctx_options'(Options1, Options2),
 2934    (   clause('$load_context_module'(File, Module, _), true, Ref),
 2935        \+ clause_property(Ref, file(_)),
 2936        erase(Ref)
 2937    ->  true
 2938    ;   true
 2939    ),
 2940    assertz('$load_context_module'(File, Module, Options2)).
 2941
 2942'$add_dialect'(Options0, Options) :-
 2943    current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
 2944    !,
 2945    Options = [dialect(Dialect)|Options0].
 2946'$add_dialect'(Options, Options).
 2947
 2948%!  '$load_ctx_options'(+Options, -CtxOptions) is det.
 2949%
 2950%   Select the load options that  determine   the  load semantics to
 2951%   perform a proper reload. Delete the others.
 2952
 2953'$load_ctx_options'(Options, CtxOptions) :-
 2954    '$load_ctx_options2'(Options, CtxOptions0),
 2955    sort(CtxOptions0, CtxOptions).
 2956
 2957'$load_ctx_options2'([], []).
 2958'$load_ctx_options2'([H|T0], [H|T]) :-
 2959    '$load_ctx_option'(H),
 2960    !,
 2961    '$load_ctx_options2'(T0, T).
 2962'$load_ctx_options2'([_|T0], T) :-
 2963    '$load_ctx_options2'(T0, T).
 2964
 2965'$load_ctx_option'(derived_from(_)).
 2966'$load_ctx_option'(dialect(_)).
 2967'$load_ctx_option'(encoding(_)).
 2968'$load_ctx_option'(imports(_)).
 2969'$load_ctx_option'(reexport(_)).
 2970
 2971
 2972%!  '$check_load_non_module'(+File) is det.
 2973%
 2974%   Test  that  a  non-module  file  is  not  loaded  into  multiple
 2975%   contexts.
 2976
 2977'$check_load_non_module'(File, _) :-
 2978    '$current_module'(_, File),
 2979    !.          % File is a module file
 2980'$check_load_non_module'(File, Module) :-
 2981    '$load_context_module'(File, OldModule, _),
 2982    Module \== OldModule,
 2983    !,
 2984    format(atom(Msg),
 2985           'Non-module file already loaded into module ~w; \c
 2986               trying to load into ~w',
 2987           [OldModule, Module]),
 2988    throw(error(permission_error(load, source, File),
 2989                context(load_files/2, Msg))).
 2990'$check_load_non_module'(_, _).
 2991
 2992%!  '$load_file'(+Path, +Id, -Module, +Options)
 2993%
 2994%   '$load_file'/4 does the actual loading.
 2995%
 2996%   state(FirstTerm:boolean,
 2997%         Module:atom,
 2998%         AtEnd:atom,
 2999%         Stop:boolean,
 3000%         Id:atom,
 3001%         Dialect:atom)
 3002
 3003'$load_file'(Path, Id, Module, Options) :-
 3004    State = state(true, _, true, false, Id, -),
 3005    (   '$source_term'(Path, _Read, _Layout, Term, Layout,
 3006                       _Stream, Options),
 3007        '$valid_term'(Term),
 3008        (   arg(1, State, true)
 3009        ->  '$first_term'(Term, Layout, Id, State, Options),
 3010            nb_setarg(1, State, false)
 3011        ;   '$compile_term'(Term, Layout, Id)
 3012        ),
 3013        arg(4, State, true)
 3014    ;   '$fixup_reconsult'(Id),
 3015        '$end_load_file'(State)
 3016    ),
 3017    !,
 3018    arg(2, State, Module).
 3019
 3020'$valid_term'(Var) :-
 3021    var(Var),
 3022    !,
 3023    print_message(error, error(instantiation_error, _)).
 3024'$valid_term'(Term) :-
 3025    Term \== [].
 3026
 3027'$end_load_file'(State) :-
 3028    arg(1, State, true),           % empty file
 3029    !,
 3030    nb_setarg(2, State, Module),
 3031    arg(5, State, Id),
 3032    '$current_source_module'(Module),
 3033    '$ifcompiling'('$qlf_start_file'(Id)),
 3034    '$ifcompiling'('$qlf_end_part').
 3035'$end_load_file'(State) :-
 3036    arg(3, State, End),
 3037    '$end_load_file'(End, State).
 3038
 3039'$end_load_file'(true, _).
 3040'$end_load_file'(end_module, State) :-
 3041    arg(2, State, Module),
 3042    '$check_export'(Module),
 3043    '$ifcompiling'('$qlf_end_part').
 3044'$end_load_file'(end_non_module, _State) :-
 3045    '$ifcompiling'('$qlf_end_part').
 3046
 3047
 3048'$first_term'(?-(Directive), Layout, Id, State, Options) :-
 3049    !,
 3050    '$first_term'(:-(Directive), Layout, Id, State, Options).
 3051'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
 3052    nonvar(Directive),
 3053    (   (   Directive = module(Name, Public)
 3054        ->  Imports = []
 3055        ;   Directive = module(Name, Public, Imports)
 3056        )
 3057    ->  !,
 3058        '$module_name'(Name, Id, Module, Options),
 3059        '$start_module'(Module, Public, State, Options),
 3060        '$module3'(Imports)
 3061    ;   Directive = expects_dialect(Dialect)
 3062    ->  !,
 3063        '$set_dialect'(Dialect, State),
 3064        fail                        % Still consider next term as first
 3065    ).
 3066'$first_term'(Term, Layout, Id, State, Options) :-
 3067    '$start_non_module'(Id, Term, State, Options),
 3068    '$compile_term'(Term, Layout, Id).
 3069
 3070'$compile_term'(Term, Layout, Id) :-
 3071    '$compile_term'(Term, Layout, Id, -).
 3072
 3073'$compile_term'(Var, _Layout, _Id, _Src) :-
 3074    var(Var),
 3075    !,
 3076    '$instantiation_error'(Var).
 3077'$compile_term'((?-Directive), _Layout, Id, _) :-
 3078    !,
 3079    '$execute_directive'(Directive, Id).
 3080'$compile_term'((:-Directive), _Layout, Id, _) :-
 3081    !,
 3082    '$execute_directive'(Directive, Id).
 3083'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :-
 3084    !,
 3085    '$compile_term'(Term, Layout, Id, File:Line).
 3086'$compile_term'(Clause, Layout, Id, SrcLoc) :-
 3087    E = error(_,_),
 3088    catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
 3089          '$print_message'(error, E)).
 3090
 3091'$start_non_module'(_Id, Term, _State, Options) :-
 3092    '$option'(must_be_module(true), Options, false),
 3093    !,
 3094    '$domain_error'(module_header, Term).
 3095'$start_non_module'(Id, _Term, State, _Options) :-
 3096    '$current_source_module'(Module),
 3097    '$ifcompiling'('$qlf_start_file'(Id)),
 3098    '$qset_dialect'(State),
 3099    nb_setarg(2, State, Module),
 3100    nb_setarg(3, State, end_non_module).
 3101
 3102%!  '$set_dialect'(+Dialect, +State)
 3103%
 3104%   Sets the expected dialect. This is difficult if we are compiling
 3105%   a .qlf file using qcompile/1 because   the file is already open,
 3106%   while we are looking for the first term to decide wether this is
 3107%   a module or not. We save the   dialect  and set it after opening
 3108%   the file or module.
 3109%
 3110%   Note that expects_dialect/1 itself may   be  autoloaded from the
 3111%   library.
 3112
 3113'$set_dialect'(Dialect, State) :-
 3114    '$compilation_mode'(qlf, database),
 3115    !,
 3116    '$expects_dialect'(Dialect),
 3117    '$compilation_mode'(_, qlf),
 3118    nb_setarg(6, State, Dialect).
 3119'$set_dialect'(Dialect, _) :-
 3120    '$expects_dialect'(Dialect).
 3121
 3122'$qset_dialect'(State) :-
 3123    '$compilation_mode'(qlf),
 3124    arg(6, State, Dialect), Dialect \== (-),
 3125    !,
 3126    '$add_directive_wic'('$expects_dialect'(Dialect)).
 3127'$qset_dialect'(_).
 3128
 3129'$expects_dialect'(Dialect) :-
 3130    Dialect == swi,
 3131    !,
 3132    set_prolog_flag(emulated_dialect, Dialect).
 3133'$expects_dialect'(Dialect) :-
 3134    current_predicate(expects_dialect/1),
 3135    !,
 3136    expects_dialect(Dialect).
 3137'$expects_dialect'(Dialect) :-
 3138    use_module(library(dialect), [expects_dialect/1]),
 3139    expects_dialect(Dialect).
 3140
 3141
 3142                 /*******************************
 3143                 *           MODULES            *
 3144                 *******************************/
 3145
 3146'$start_module'(Module, _Public, State, _Options) :-
 3147    '$current_module'(Module, OldFile),
 3148    source_location(File, _Line),
 3149    OldFile \== File, OldFile \== [],
 3150    same_file(OldFile, File),
 3151    !,
 3152    nb_setarg(2, State, Module),
 3153    nb_setarg(4, State, true).      % Stop processing
 3154'$start_module'(Module, Public, State, Options) :-
 3155    arg(5, State, File),
 3156    nb_setarg(2, State, Module),
 3157    source_location(_File, Line),
 3158    '$option'(redefine_module(Action), Options, false),
 3159    '$module_class'(File, Class, Super),
 3160    '$reset_dialect'(File, Class),
 3161    '$redefine_module'(Module, File, Action),
 3162    '$declare_module'(Module, Class, Super, File, Line, false),
 3163    '$export_list'(Public, Module, Ops),
 3164    '$ifcompiling'('$qlf_start_module'(Module)),
 3165    '$export_ops'(Ops, Module, File),
 3166    '$qset_dialect'(State),
 3167    nb_setarg(3, State, end_module).
 3168
 3169%!  '$reset_dialect'(+File, +Class) is det.
 3170%
 3171%   Load .pl files from the SWI-Prolog distribution _always_ in
 3172%   `swi` dialect.
 3173
 3174'$reset_dialect'(File, library) :-
 3175    file_name_extension(_, pl, File),
 3176    !,
 3177    set_prolog_flag(emulated_dialect, swi).
 3178'$reset_dialect'(_, _).
 3179
 3180
 3181%!  '$module3'(+Spec) is det.
 3182%
 3183%   Handle the 3th argument of a module declartion.
 3184
 3185'$module3'(Var) :-
 3186    var(Var),
 3187    !,
 3188    '$instantiation_error'(Var).
 3189'$module3'([]) :- !.
 3190'$module3'([H|T]) :-
 3191    !,
 3192    '$module3'(H),
 3193    '$module3'(T).
 3194'$module3'(Id) :-
 3195    use_module(library(dialect/Id)).
 3196
 3197%!  '$module_name'(?Name, +Id, -Module, +Options) is semidet.
 3198%
 3199%   Determine the module name.  There are some cases:
 3200%
 3201%     - Option module(Module) is given.  In that case, use this
 3202%       module and if Module is the load context, ignore the module
 3203%       header.
 3204%     - The initial name is unbound.  Use the base name of the
 3205%       source identifier (normally the file name).  Compatibility
 3206%       to Ciao.  This might change; I think it is wiser to use
 3207%       the full unique source identifier.
 3208
 3209'$module_name'(_, _, Module, Options) :-
 3210    '$option'(module(Module), Options),
 3211    !,
 3212    '$current_source_module'(Context),
 3213    Context \== Module.                     % cause '$first_term'/5 to fail.
 3214'$module_name'(Var, Id, Module, Options) :-
 3215    var(Var),
 3216    !,
 3217    file_base_name(Id, File),
 3218    file_name_extension(Var, _, File),
 3219    '$module_name'(Var, Id, Module, Options).
 3220'$module_name'(Reserved, _, _, _) :-
 3221    '$reserved_module'(Reserved),
 3222    !,
 3223    throw(error(permission_error(load, module, Reserved), _)).
 3224'$module_name'(Module, _Id, Module, _).
 3225
 3226
 3227'$reserved_module'(system).
 3228'$reserved_module'(user).
 3229
 3230
 3231%!  '$redefine_module'(+Module, +File, -Redefine)
 3232
 3233'$redefine_module'(_Module, _, false) :- !.
 3234'$redefine_module'(Module, File, true) :-
 3235    !,
 3236    (   module_property(Module, file(OldFile)),
 3237        File \== OldFile
 3238    ->  unload_file(OldFile)
 3239    ;   true
 3240    ).
 3241'$redefine_module'(Module, File, ask) :-
 3242    (   stream_property(user_input, tty(true)),
 3243        module_property(Module, file(OldFile)),
 3244        File \== OldFile,
 3245        '$rdef_response'(Module, OldFile, File, true)
 3246    ->  '$redefine_module'(Module, File, true)
 3247    ;   true
 3248    ).
 3249
 3250'$rdef_response'(Module, OldFile, File, Ok) :-
 3251    repeat,
 3252    print_message(query, redefine_module(Module, OldFile, File)),
 3253    get_single_char(Char),
 3254    '$rdef_response'(Char, Ok0),
 3255    !,
 3256    Ok = Ok0.
 3257
 3258'$rdef_response'(Char, true) :-
 3259    memberchk(Char, `yY`),
 3260    format(user_error, 'yes~n', []).
 3261'$rdef_response'(Char, false) :-
 3262    memberchk(Char, `nN`),
 3263    format(user_error, 'no~n', []).
 3264'$rdef_response'(Char, _) :-
 3265    memberchk(Char, `a`),
 3266    format(user_error, 'abort~n', []),
 3267    abort.
 3268'$rdef_response'(_, _) :-
 3269    print_message(help, redefine_module_reply),
 3270    fail.
 3271
 3272
 3273%!  '$module_class'(+File, -Class, -Super) is det.
 3274%
 3275%   Determine  the  file  class  and  initial  module  from  which  File
 3276%   inherits. All boot and library modules  as   well  as  the -F script
 3277%   files inherit from `system`, while all   normal user modules inherit
 3278%   from `user`.
 3279
 3280'$module_class'(File, Class, system) :-
 3281    current_prolog_flag(home, Home),
 3282    sub_atom(File, 0, Len, _, Home),
 3283    (   sub_atom(File, Len, _, _, '/boot/')
 3284    ->  Class = system
 3285    ;   '$lib_prefix'(Prefix),
 3286        sub_atom(File, Len, _, _, Prefix)
 3287    ->  Class = library
 3288    ;   file_directory_name(File, Home),
 3289        file_name_extension(_, rc, File)
 3290    ->  Class = library
 3291    ),
 3292    !.
 3293'$module_class'(_, user, user).
 3294
 3295'$lib_prefix'('/library').
 3296'$lib_prefix'('/xpce/prolog/').
 3297
 3298'$check_export'(Module) :-
 3299    '$undefined_export'(Module, UndefList),
 3300    (   '$member'(Undef, UndefList),
 3301        strip_module(Undef, _, Local),
 3302        print_message(error,
 3303                      undefined_export(Module, Local)),
 3304        fail
 3305    ;   true
 3306    ).
 3307
 3308
 3309%!  '$import_list'(+TargetModule, +FromModule, +Import, +Reexport) is det.
 3310%
 3311%   Import from FromModule to TargetModule. Import  is one of =all=,
 3312%   a list of optionally  mapped  predicate   indicators  or  a term
 3313%   except(Import).
 3314
 3315'$import_list'(_, _, Var, _) :-
 3316    var(Var),
 3317    !,
 3318    throw(error(instantitation_error, _)).
 3319'$import_list'(Target, Source, all, Reexport) :-
 3320    !,
 3321    '$exported_ops'(Source, Import, Predicates),
 3322    '$module_property'(Source, exports(Predicates)),
 3323    '$import_all'(Import, Target, Source, Reexport, weak).
 3324'$import_list'(Target, Source, except(Spec), Reexport) :-
 3325    !,
 3326    '$exported_ops'(Source, Export, Predicates),
 3327    '$module_property'(Source, exports(Predicates)),
 3328    (   is_list(Spec)
 3329    ->  true
 3330    ;   throw(error(type_error(list, Spec), _))
 3331    ),
 3332    '$import_except'(Spec, Export, Import),
 3333    '$import_all'(Import, Target, Source, Reexport, weak).
 3334'$import_list'(Target, Source, Import, Reexport) :-
 3335    !,
 3336    is_list(Import),
 3337    !,
 3338    '$import_all'(Import, Target, Source, Reexport, strong).
 3339'$import_list'(_, _, Import, _) :-
 3340    throw(error(type_error(import_specifier, Import))).
 3341
 3342
 3343'$import_except'([], List, List).
 3344'$import_except'([H|T], List0, List) :-
 3345    '$import_except_1'(H, List0, List1),
 3346    '$import_except'(T, List1, List).
 3347
 3348'$import_except_1'(Var, _, _) :-
 3349    var(Var),
 3350    !,
 3351    throw(error(instantitation_error, _)).
 3352'$import_except_1'(PI as N, List0, List) :-
 3353    '$pi'(PI), atom(N),
 3354    !,
 3355    '$canonical_pi'(PI, CPI),
 3356    '$import_as'(CPI, N, List0, List).
 3357'$import_except_1'(op(P,A,N), List0, List) :-
 3358    !,
 3359    '$remove_ops'(List0, op(P,A,N), List).
 3360'$import_except_1'(PI, List0, List) :-
 3361    '$pi'(PI),
 3362    !,
 3363    '$canonical_pi'(PI, CPI),
 3364    '$select'(P, List0, List),
 3365    '$canonical_pi'(CPI, P),
 3366    !.
 3367'$import_except_1'(Except, _, _) :-
 3368    throw(error(type_error(import_specifier, Except), _)).
 3369
 3370'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
 3371    '$canonical_pi'(PI2, CPI),
 3372    !.
 3373'$import_as'(PI, N, [H|T0], [H|T]) :-
 3374    !,
 3375    '$import_as'(PI, N, T0, T).
 3376'$import_as'(PI, _, _, _) :-
 3377    throw(error(existence_error(export, PI), _)).
 3378
 3379'$pi'(N/A) :- atom(N), integer(A), !.
 3380'$pi'(N//A) :- atom(N), integer(A).
 3381
 3382'$canonical_pi'(N//A0, N/A) :-
 3383    A is A0 + 2.
 3384'$canonical_pi'(PI, PI).
 3385
 3386'$remove_ops'([], _, []).
 3387'$remove_ops'([Op|T0], Pattern, T) :-
 3388    subsumes_term(Pattern, Op),
 3389    !,
 3390    '$remove_ops'(T0, Pattern, T).
 3391'$remove_ops'([H|T0], Pattern, [H|T]) :-
 3392    '$remove_ops'(T0, Pattern, T).
 3393
 3394
 3395%!  '$import_all'(+Import, +Context, +Source, +Reexport, +Strength)
 3396
 3397'$import_all'(Import, Context, Source, Reexport, Strength) :-
 3398    '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
 3399    (   Reexport == true,
 3400        (   '$list_to_conj'(Imported, Conj)
 3401        ->  export(Context:Conj),
 3402            '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
 3403        ;   true
 3404        ),
 3405        source_location(File, _Line),
 3406        '$export_ops'(ImpOps, Context, File)
 3407    ;   true
 3408    ).
 3409
 3410%!  '$import_all2'(+Imports, +Context, +Source, -Imported, -ImpOps, +Strength)
 3411
 3412'$import_all2'([], _, _, [], [], _).
 3413'$import_all2'([PI as NewName|Rest], Context, Source,
 3414               [NewName/Arity|Imported], ImpOps, Strength) :-
 3415    !,
 3416    '$canonical_pi'(PI, Name/Arity),
 3417    length(Args, Arity),
 3418    Head =.. [Name|Args],
 3419    NewHead =.. [NewName|Args],
 3420    (   '$get_predicate_attribute'(Source:Head, transparent, 1)
 3421    ->  '$set_predicate_attribute'(Context:NewHead, transparent, true)
 3422    ;   true
 3423    ),
 3424    (   source_location(File, Line)
 3425    ->  E = error(_,_),
 3426        catch('$store_admin_clause'((NewHead :- Source:Head),
 3427                                    _Layout, File, File:Line),
 3428              E, '$print_message'(error, E))
 3429    ;   assertz((NewHead :- !, Source:Head)) % ! avoids problems with
 3430    ),                                       % duplicate load
 3431    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3432'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
 3433               [op(P,A,N)|ImpOps], Strength) :-
 3434    !,
 3435    '$import_ops'(Context, Source, op(P,A,N)),
 3436    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3437'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
 3438    Error = error(_,_),
 3439    catch(Context:'$import'(Source:Pred, Strength), Error,
 3440          print_message(error, Error)),
 3441    '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
 3442    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3443
 3444
 3445'$list_to_conj'([One], One) :- !.
 3446'$list_to_conj'([H|T], (H,Rest)) :-
 3447    '$list_to_conj'(T, Rest).
 3448
 3449%!  '$exported_ops'(+Module, -Ops, ?Tail) is det.
 3450%
 3451%   Ops is a list of op(P,A,N) terms representing the operators
 3452%   exported from Module.
 3453
 3454'$exported_ops'(Module, Ops, Tail) :-
 3455    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 3456    !,
 3457    findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
 3458'$exported_ops'(_, Ops, Ops).
 3459
 3460'$exported_op'(Module, P, A, N) :-
 3461    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 3462    Module:'$exported_op'(P, A, N).
 3463
 3464%!  '$import_ops'(+Target, +Source, +Pattern)
 3465%
 3466%   Import the operators export from Source into the module table of
 3467%   Target.  We only import operators that unify with Pattern.
 3468
 3469'$import_ops'(To, From, Pattern) :-
 3470    ground(Pattern),
 3471    !,
 3472    Pattern = op(P,A,N),
 3473    op(P,A,To:N),
 3474    (   '$exported_op'(From, P, A, N)
 3475    ->  true
 3476    ;   print_message(warning, no_exported_op(From, Pattern))
 3477    ).
 3478'$import_ops'(To, From, Pattern) :-
 3479    (   '$exported_op'(From, Pri, Assoc, Name),
 3480        Pattern = op(Pri, Assoc, Name),
 3481        op(Pri, Assoc, To:Name),
 3482        fail
 3483    ;   true
 3484    ).
 3485
 3486
 3487%!  '$export_list'(+Declarations, +Module, -Ops)
 3488%
 3489%   Handle the export list of the module declaration for Module
 3490%   associated to File.
 3491
 3492'$export_list'(Decls, Module, Ops) :-
 3493    is_list(Decls),
 3494    !,
 3495    '$do_export_list'(Decls, Module, Ops).
 3496'$export_list'(Decls, _, _) :-
 3497    var(Decls),
 3498    throw(error(instantiation_error, _)).
 3499'$export_list'(Decls, _, _) :-
 3500    throw(error(type_error(list, Decls), _)).
 3501
 3502'$do_export_list'([], _, []) :- !.
 3503'$do_export_list'([H|T], Module, Ops) :-
 3504    !,
 3505    E = error(_,_),
 3506    catch('$export1'(H, Module, Ops, Ops1),
 3507          E, ('$print_message'(error, E), Ops = Ops1)),
 3508    '$do_export_list'(T, Module, Ops1).
 3509
 3510'$export1'(Var, _, _, _) :-
 3511    var(Var),
 3512    !,
 3513    throw(error(instantiation_error, _)).
 3514'$export1'(Op, _, [Op|T], T) :-
 3515    Op = op(_,_,_),
 3516    !.
 3517'$export1'(PI0, Module, Ops, Ops) :-
 3518    strip_module(Module:PI0, M, PI),
 3519    (   PI = (_//_)
 3520    ->  non_terminal(M:PI)
 3521    ;   true
 3522    ),
 3523    export(M:PI).
 3524
 3525'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
 3526    E = error(_,_),
 3527    catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File),
 3528            '$export_op'(Pri, Assoc, Name, Module, File)
 3529          ),
 3530          E, '$print_message'(error, E)),
 3531    '$export_ops'(T, Module, File).
 3532'$export_ops'([], _, _).
 3533
 3534'$export_op'(Pri, Assoc, Name, Module, File) :-
 3535    (   '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
 3536    ->  true
 3537    ;   '$execute_directive'(discontiguous(Module:'$exported_op'/3), File)
 3538    ),
 3539    '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
 3540
 3541%!  '$execute_directive'(:Goal, +File) is det.
 3542%
 3543%   Execute the argument of :- or ?- while loading a file.
 3544
 3545'$execute_directive'(Goal, F) :-
 3546    '$execute_directive_2'(Goal, F).
 3547
 3548'$execute_directive_2'(encoding(Encoding), _F) :-
 3549    !,
 3550    (   '$load_input'(_F, S)
 3551    ->  set_stream(S, encoding(Encoding))
 3552    ).
 3553'$execute_directive_2'(Goal, _) :-
 3554    \+ '$compilation_mode'(database),
 3555    !,
 3556    '$add_directive_wic2'(Goal, Type),
 3557    (   Type == call                % suspend compiling into .qlf file
 3558    ->  '$compilation_mode'(Old, database),
 3559        setup_call_cleanup(
 3560            '$directive_mode'(OldDir, Old),
 3561            '$execute_directive_3'(Goal),
 3562            ( '$set_compilation_mode'(Old),
 3563              '$set_directive_mode'(OldDir)
 3564            ))
 3565    ;   '$execute_directive_3'(Goal)
 3566    ).
 3567'$execute_directive_2'(Goal, _) :-
 3568    '$execute_directive_3'(Goal).
 3569
 3570'$execute_directive_3'(Goal) :-
 3571    '$current_source_module'(Module),
 3572    '$valid_directive'(Module:Goal),
 3573    !,
 3574    (   '$pattr_directive'(Goal, Module)
 3575    ->  true
 3576    ;   Term = error(_,_),
 3577        catch(Module:Goal, Term, '$exception_in_directive'(Term))
 3578    ->  true
 3579    ;   '$print_message'(warning, goal_failed(directive, Module:Goal)),
 3580        fail
 3581    ).
 3582'$execute_directive_3'(_).
 3583
 3584
 3585%!  '$valid_directive'(:Directive) is det.
 3586%
 3587%   If   the   flag   =sandboxed_load=   is   =true=,   this   calls
 3588%   prolog:sandbox_allowed_directive/1. This call can deny execution
 3589%   of the directive by throwing an exception.
 3590
 3591:- multifile prolog:sandbox_allowed_directive/1. 3592:- multifile prolog:sandbox_allowed_clause/1. 3593:- meta_predicate '$valid_directive'(:). 3594
 3595'$valid_directive'(_) :-
 3596    current_prolog_flag(sandboxed_load, false),
 3597    !.
 3598'$valid_directive'(Goal) :-
 3599    Error = error(Formal, _),
 3600    catch(prolog:sandbox_allowed_directive(Goal), Error, true),
 3601    !,
 3602    (   var(Formal)
 3603    ->  true
 3604    ;   print_message(error, Error),
 3605        fail
 3606    ).
 3607'$valid_directive'(Goal) :-
 3608    print_message(error,
 3609                  error(permission_error(execute,
 3610                                         sandboxed_directive,
 3611                                         Goal), _)),
 3612    fail.
 3613
 3614'$exception_in_directive'(Term) :-
 3615    '$print_message'(error, Term),
 3616    fail.
 3617
 3618%       Note that the list, consult and ensure_loaded directives are already
 3619%       handled at compile time and therefore should not go into the
 3620%       intermediate code file.
 3621
 3622'$add_directive_wic2'(Goal, Type) :-
 3623    '$common_goal_type'(Goal, Type),
 3624    !,
 3625    (   Type == load
 3626    ->  true
 3627    ;   '$current_source_module'(Module),
 3628        '$add_directive_wic'(Module:Goal)
 3629    ).
 3630'$add_directive_wic2'(Goal, _) :-
 3631    (   '$compilation_mode'(qlf)    % no problem for qlf files
 3632    ->  true
 3633    ;   print_message(error, mixed_directive(Goal))
 3634    ).
 3635
 3636'$common_goal_type'((A,B), Type) :-
 3637    !,
 3638    '$common_goal_type'(A, Type),
 3639    '$common_goal_type'(B, Type).
 3640'$common_goal_type'((A;B), Type) :-
 3641    !,
 3642    '$common_goal_type'(A, Type),
 3643    '$common_goal_type'(B, Type).
 3644'$common_goal_type'((A->B), Type) :-
 3645    !,
 3646    '$common_goal_type'(A, Type),
 3647    '$common_goal_type'(B, Type).
 3648'$common_goal_type'(Goal, Type) :-
 3649    '$goal_type'(Goal, Type).
 3650
 3651'$goal_type'(Goal, Type) :-
 3652    (   '$load_goal'(Goal)
 3653    ->  Type = load
 3654    ;   Type = call
 3655    ).
 3656
 3657'$load_goal'([_|_]).
 3658'$load_goal'(consult(_)).
 3659'$load_goal'(load_files(_)).
 3660'$load_goal'(load_files(_,Options)) :-
 3661    memberchk(qcompile(QlfMode), Options),
 3662    '$qlf_part_mode'(QlfMode).
 3663'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic).
 3664'$load_goal'(use_module(_))    :- '$compilation_mode'(wic).
 3665'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic).
 3666
 3667'$qlf_part_mode'(part).
 3668'$qlf_part_mode'(true).                 % compatibility
 3669
 3670
 3671                /********************************
 3672                *        COMPILE A CLAUSE       *
 3673                *********************************/
 3674
 3675%!  '$store_admin_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3676%
 3677%   Store a clause into the   database  for administrative purposes.
 3678%   This bypasses sanity checking.
 3679
 3680'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :-
 3681    Owner \== (-),
 3682    !,
 3683    setup_call_cleanup(
 3684        '$start_aux'(Owner, Context),
 3685        '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc),
 3686        '$end_aux'(Owner, Context)).
 3687'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
 3688    '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
 3689
 3690'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
 3691    (   '$compilation_mode'(database)
 3692    ->  '$record_clause'(Clause, File, SrcLoc)
 3693    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3694        '$qlf_assert_clause'(Ref, development)
 3695    ).
 3696
 3697%!  '$store_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3698%
 3699%   Store a clause into the database.
 3700%
 3701%   @arg    Owner is the file-id that owns the clause
 3702%   @arg    SrcLoc is the file:line term where the clause
 3703%           originates from.
 3704
 3705'$store_clause'((_, _), _, _, _) :-
 3706    !,
 3707    print_message(error, cannot_redefine_comma),
 3708    fail.
 3709'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :-
 3710    nonvar(Pre),
 3711    Pre = (Head,Cond),
 3712    !,
 3713    (   '$is_true'(Cond), current_prolog_flag(optimise, true)
 3714    ->  '$store_clause'((Head=>Body), _Layout, File, SrcLoc)
 3715    ;   '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc)
 3716    ).
 3717'$store_clause'(Clause, _Layout, File, SrcLoc) :-
 3718    '$valid_clause'(Clause),
 3719    !,
 3720    (   '$compilation_mode'(database)
 3721    ->  '$record_clause'(Clause, File, SrcLoc)
 3722    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3723        '$qlf_assert_clause'(Ref, development)
 3724    ).
 3725
 3726'$is_true'(true)  => true.
 3727'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B).
 3728'$is_true'(_)     => fail.
 3729
 3730'$valid_clause'(_) :-
 3731    current_prolog_flag(sandboxed_load, false),
 3732    !.
 3733'$valid_clause'(Clause) :-
 3734    \+ '$cross_module_clause'(Clause),
 3735    !.
 3736'$valid_clause'(Clause) :-
 3737    Error = error(Formal, _),
 3738    catch(prolog:sandbox_allowed_clause(Clause), Error, true),
 3739    !,
 3740    (   var(Formal)
 3741    ->  true
 3742    ;   print_message(error, Error),
 3743        fail
 3744    ).
 3745'$valid_clause'(Clause) :-
 3746    print_message(error,
 3747                  error(permission_error(assert,
 3748                                         sandboxed_clause,
 3749                                         Clause), _)),
 3750    fail.
 3751
 3752'$cross_module_clause'(Clause) :-
 3753    '$head_module'(Clause, Module),
 3754    \+ '$current_source_module'(Module).
 3755
 3756'$head_module'(Var, _) :-
 3757    var(Var), !, fail.
 3758'$head_module'((Head :- _), Module) :-
 3759    '$head_module'(Head, Module).
 3760'$head_module'(Module:_, Module).
 3761
 3762'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
 3763'$clause_source'(Clause, Clause, -).
 3764
 3765%!  '$store_clause'(+Term, +Id) is det.
 3766%
 3767%   This interface is used by PlDoc (and who knows).  Kept for to avoid
 3768%   compatibility issues.
 3769
 3770:- public
 3771    '$store_clause'/2. 3772
 3773'$store_clause'(Term, Id) :-
 3774    '$clause_source'(Term, Clause, SrcLoc),
 3775    '$store_clause'(Clause, _, Id, SrcLoc).
 3776
 3777%!  compile_aux_clauses(+Clauses) is det.
 3778%
 3779%   Compile clauses given the current  source   location  but do not
 3780%   change  the  notion  of   the    current   procedure  such  that
 3781%   discontiguous  warnings  are  not  issued.    The   clauses  are
 3782%   associated with the current file and  therefore wiped out if the
 3783%   file is reloaded.
 3784%
 3785%   If the cross-referencer is active, we should not (re-)assert the
 3786%   clauses.  Actually,  we  should   make    them   known   to  the
 3787%   cross-referencer. How do we do that?   Maybe we need a different
 3788%   API, such as in:
 3789%
 3790%     ==
 3791%     expand_term_aux(Goal, NewGoal, Clauses)
 3792%     ==
 3793%
 3794%   @tbd    Deal with source code layout?
 3795
 3796compile_aux_clauses(_Clauses) :-
 3797    current_prolog_flag(xref, true),
 3798    !.
 3799compile_aux_clauses(Clauses) :-
 3800    source_location(File, _Line),
 3801    '$compile_aux_clauses'(Clauses, File).
 3802
 3803'$compile_aux_clauses'(Clauses, File) :-
 3804    setup_call_cleanup(
 3805        '$start_aux'(File, Context),
 3806        '$store_aux_clauses'(Clauses, File),
 3807        '$end_aux'(File, Context)).
 3808
 3809'$store_aux_clauses'(Clauses, File) :-
 3810    is_list(Clauses),
 3811    !,
 3812    forall('$member'(C,Clauses),
 3813           '$compile_term'(C, _Layout, File)).
 3814'$store_aux_clauses'(Clause, File) :-
 3815    '$compile_term'(Clause, _Layout, File).
 3816
 3817
 3818		 /*******************************
 3819		 *            STAGING		*
 3820		 *******************************/
 3821
 3822%!  '$stage_file'(+Target, -Stage) is det.
 3823%!  '$install_staged_file'(+Catcher, +Staged, +Target, +OnError).
 3824%
 3825%   Create files using _staging_, where we  first write a temporary file
 3826%   and move it to Target if  the   file  was created successfully. This
 3827%   provides an atomic transition, preventing  customers from reading an
 3828%   incomplete file.
 3829
 3830'$stage_file'(Target, Stage) :-
 3831    file_directory_name(Target, Dir),
 3832    file_base_name(Target, File),
 3833    current_prolog_flag(pid, Pid),
 3834    format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]).
 3835
 3836'$install_staged_file'(exit, Staged, Target, error) :-
 3837    !,
 3838    rename_file(Staged, Target).
 3839'$install_staged_file'(exit, Staged, Target, OnError) :-
 3840    !,
 3841    InstallError = error(_,_),
 3842    catch(rename_file(Staged, Target),
 3843          InstallError,
 3844          '$install_staged_error'(OnError, InstallError, Staged, Target)).
 3845'$install_staged_file'(_, Staged, _, _OnError) :-
 3846    E = error(_,_),
 3847    catch(delete_file(Staged), E, true).
 3848
 3849'$install_staged_error'(OnError, Error, Staged, _Target) :-
 3850    E = error(_,_),
 3851    catch(delete_file(Staged), E, true),
 3852    (   OnError = silent
 3853    ->  true
 3854    ;   OnError = fail
 3855    ->  fail
 3856    ;   print_message(warning, Error)
 3857    ).
 3858
 3859
 3860                 /*******************************
 3861                 *             READING          *
 3862                 *******************************/
 3863
 3864:- multifile
 3865    prolog:comment_hook/3.                  % hook for read_clause/3
 3866
 3867
 3868                 /*******************************
 3869                 *       FOREIGN INTERFACE      *
 3870                 *******************************/
 3871
 3872%       call-back from PL_register_foreign().  First argument is the module
 3873%       into which the foreign predicate is loaded and second is a term
 3874%       describing the arguments.
 3875
 3876:- dynamic
 3877    '$foreign_registered'/2. 3878
 3879                 /*******************************
 3880                 *   TEMPORARY TERM EXPANSION   *
 3881                 *******************************/
 3882
 3883% Provide temporary definitions for the boot-loader.  These are replaced
 3884% by the real thing in load.pl
 3885
 3886:- dynamic
 3887    '$expand_goal'/2,
 3888    '$expand_term'/4. 3889
 3890'$expand_goal'(In, In).
 3891'$expand_term'(In, Layout, In, Layout).
 3892
 3893
 3894                 /*******************************
 3895                 *         TYPE SUPPORT         *
 3896                 *******************************/
 3897
 3898'$type_error'(Type, Value) :-
 3899    (   var(Value)
 3900    ->  throw(error(instantiation_error, _))
 3901    ;   throw(error(type_error(Type, Value), _))
 3902    ).
 3903
 3904'$domain_error'(Type, Value) :-
 3905    throw(error(domain_error(Type, Value), _)).
 3906
 3907'$existence_error'(Type, Object) :-
 3908    throw(error(existence_error(Type, Object), _)).
 3909
 3910'$permission_error'(Action, Type, Term) :-
 3911    throw(error(permission_error(Action, Type, Term), _)).
 3912
 3913'$instantiation_error'(_Var) :-
 3914    throw(error(instantiation_error, _)).
 3915
 3916'$uninstantiation_error'(NonVar) :-
 3917    throw(error(uninstantiation_error(NonVar), _)).
 3918
 3919'$must_be'(list, X) :- !,
 3920    '$skip_list'(_, X, Tail),
 3921    (   Tail == []
 3922    ->  true
 3923    ;   '$type_error'(list, Tail)
 3924    ).
 3925'$must_be'(options, X) :- !,
 3926    (   '$is_options'(X)
 3927    ->  true
 3928    ;   '$type_error'(options, X)
 3929    ).
 3930'$must_be'(atom, X) :- !,
 3931    (   atom(X)
 3932    ->  true
 3933    ;   '$type_error'(atom, X)
 3934    ).
 3935'$must_be'(integer, X) :- !,
 3936    (   integer(X)
 3937    ->  true
 3938    ;   '$type_error'(integer, X)
 3939    ).
 3940'$must_be'(between(Low,High), X) :- !,
 3941    (   integer(X)
 3942    ->  (   between(Low, High, X)
 3943        ->  true
 3944        ;   '$domain_error'(between(Low,High), X)
 3945        )
 3946    ;   '$type_error'(integer, X)
 3947    ).
 3948'$must_be'(callable, X) :- !,
 3949    (   callable(X)
 3950    ->  true
 3951    ;   '$type_error'(callable, X)
 3952    ).
 3953'$must_be'(acyclic, X) :- !,
 3954    (   acyclic_term(X)
 3955    ->  true
 3956    ;   '$domain_error'(acyclic_term, X)
 3957    ).
 3958'$must_be'(oneof(Type, Domain, List), X) :- !,
 3959    '$must_be'(Type, X),
 3960    (   memberchk(X, List)
 3961    ->  true
 3962    ;   '$domain_error'(Domain, X)
 3963    ).
 3964'$must_be'(boolean, X) :- !,
 3965    (   (X == true ; X == false)
 3966    ->  true
 3967    ;   '$type_error'(boolean, X)
 3968    ).
 3969'$must_be'(ground, X) :- !,
 3970    (   ground(X)
 3971    ->  true
 3972    ;   '$instantiation_error'(X)
 3973    ).
 3974'$must_be'(filespec, X) :- !,
 3975    (   (   atom(X)
 3976        ;   string(X)
 3977        ;   compound(X),
 3978            compound_name_arity(X, _, 1)
 3979        )
 3980    ->  true
 3981    ;   '$type_error'(filespec, X)
 3982    ).
 3983
 3984% Use for debugging
 3985%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]).
 3986
 3987
 3988                /********************************
 3989                *       LIST PROCESSING         *
 3990                *********************************/
 3991
 3992'$member'(El, [H|T]) :-
 3993    '$member_'(T, El, H).
 3994
 3995'$member_'(_, El, El).
 3996'$member_'([H|T], El, _) :-
 3997    '$member_'(T, El, H).
 3998
 3999
 4000'$append'([], L, L).
 4001'$append'([H|T], L, [H|R]) :-
 4002    '$append'(T, L, R).
 4003
 4004'$select'(X, [X|Tail], Tail).
 4005'$select'(Elem, [Head|Tail], [Head|Rest]) :-
 4006    '$select'(Elem, Tail, Rest).
 4007
 4008'$reverse'(L1, L2) :-
 4009    '$reverse'(L1, [], L2).
 4010
 4011'$reverse'([], List, List).
 4012'$reverse'([Head|List1], List2, List3) :-
 4013    '$reverse'(List1, [Head|List2], List3).
 4014
 4015'$delete'([], _, []) :- !.
 4016'$delete'([Elem|Tail], Elem, Result) :-
 4017    !,
 4018    '$delete'(Tail, Elem, Result).
 4019'$delete'([Head|Tail], Elem, [Head|Rest]) :-
 4020    '$delete'(Tail, Elem, Rest).
 4021
 4022'$last'([H|T], Last) :-
 4023    '$last'(T, H, Last).
 4024
 4025'$last'([], Last, Last).
 4026'$last'([H|T], _, Last) :-
 4027    '$last'(T, H, Last).
 4028
 4029
 4030%!  length(?List, ?N)
 4031%
 4032%   Is true when N is the length of List.
 4033
 4034:- '$iso'((length/2)). 4035
 4036length(List, Length) :-
 4037    var(Length),
 4038    !,
 4039    '$skip_list'(Length0, List, Tail),
 4040    (   Tail == []
 4041    ->  Length = Length0                    % +,-
 4042    ;   var(Tail)
 4043    ->  Tail \== Length,                    % avoid length(L,L)
 4044        '$length3'(Tail, Length, Length0)   % -,-
 4045    ;   throw(error(type_error(list, List),
 4046                    context(length/2, _)))
 4047    ).
 4048length(List, Length) :-
 4049    integer(Length),
 4050    Length >= 0,
 4051    !,
 4052    '$skip_list'(Length0, List, Tail),
 4053    (   Tail == []                          % proper list
 4054    ->  Length = Length0
 4055    ;   var(Tail)
 4056    ->  Extra is Length-Length0,
 4057        '$length'(Tail, Extra)
 4058    ;   throw(error(type_error(list, List),
 4059                    context(length/2, _)))
 4060    ).
 4061length(_, Length) :-
 4062    integer(Length),
 4063    !,
 4064    throw(error(domain_error(not_less_than_zero, Length),
 4065                context(length/2, _))).
 4066length(_, Length) :-
 4067    throw(error(type_error(integer, Length),
 4068                context(length/2, _))).
 4069
 4070'$length3'([], N, N).
 4071'$length3'([_|List], N, N0) :-
 4072    N1 is N0+1,
 4073    '$length3'(List, N, N1).
 4074
 4075
 4076                 /*******************************
 4077                 *       OPTION PROCESSING      *
 4078                 *******************************/
 4079
 4080%!  '$is_options'(@Term) is semidet.
 4081%
 4082%   True if Term looks like it provides options.
 4083
 4084'$is_options'(Map) :-
 4085    is_dict(Map, _),
 4086    !.
 4087'$is_options'(List) :-
 4088    is_list(List),
 4089    (   List == []
 4090    ->  true
 4091    ;   List = [H|_],
 4092        '$is_option'(H, _, _)
 4093    ).
 4094
 4095'$is_option'(Var, _, _) :-
 4096    var(Var), !, fail.
 4097'$is_option'(F, Name, Value) :-
 4098    functor(F, _, 1),
 4099    !,
 4100    F =.. [Name,Value].
 4101'$is_option'(Name=Value, Name, Value).
 4102
 4103%!  '$option'(?Opt, +Options) is semidet.
 4104
 4105'$option'(Opt, Options) :-
 4106    is_dict(Options),
 4107    !,
 4108    [Opt] :< Options.
 4109'$option'(Opt, Options) :-
 4110    memberchk(Opt, Options).
 4111
 4112%!  '$option'(?Opt, +Options, +Default) is det.
 4113
 4114'$option'(Term, Options, Default) :-
 4115    arg(1, Term, Value),
 4116    functor(Term, Name, 1),
 4117    (   is_dict(Options)
 4118    ->  (   get_dict(Name, Options, GVal)
 4119        ->  Value = GVal
 4120        ;   Value = Default
 4121        )
 4122    ;   functor(Gen, Name, 1),
 4123        arg(1, Gen, GVal),
 4124        (   memberchk(Gen, Options)
 4125        ->  Value = GVal
 4126        ;   Value = Default
 4127        )
 4128    ).
 4129
 4130%!  '$select_option'(?Opt, +Options, -Rest) is semidet.
 4131%
 4132%   Select an option from Options.
 4133%
 4134%   @arg Rest is always a map.
 4135
 4136'$select_option'(Opt, Options, Rest) :-
 4137    select_dict([Opt], Options, Rest).
 4138
 4139%!  '$merge_options'(+New, +Default, -Merged) is det.
 4140%
 4141%   Add/replace options specified in New.
 4142%
 4143%   @arg Merged is always a map.
 4144
 4145'$merge_options'(New, Old, Merged) :-
 4146    put_dict(New, Old, Merged).
 4147
 4148
 4149                 /*******************************
 4150                 *   HANDLE TRACER 'L'-COMMAND  *
 4151                 *******************************/
 4152
 4153:- public '$prolog_list_goal'/1. 4154
 4155:- multifile
 4156    user:prolog_list_goal/1. 4157
 4158'$prolog_list_goal'(Goal) :-
 4159    user:prolog_list_goal(Goal),
 4160    !.
 4161'$prolog_list_goal'(Goal) :-
 4162    use_module(library(listing), [listing/1]),
 4163    @(listing(Goal), user).
 4164
 4165
 4166                 /*******************************
 4167                 *             HALT             *
 4168                 *******************************/
 4169
 4170:- '$iso'((halt/0)). 4171
 4172halt :-
 4173    '$exit_code'(Code),
 4174    (   Code == 0
 4175    ->  true
 4176    ;   print_message(warning, on_error(halt(1)))
 4177    ),
 4178    halt(Code).
 4179
 4180%!  '$exit_code'(Code)
 4181%
 4182%   Determine the exit code baed on the `on_error` and `on_warning`
 4183%   flags.  Also used by qsave_toplevel/0.
 4184
 4185'$exit_code'(Code) :-
 4186    (   (   current_prolog_flag(on_error, status),
 4187            statistics(errors, Count),
 4188            Count > 0
 4189        ;   current_prolog_flag(on_warning, status),
 4190            statistics(warnings, Count),
 4191            Count > 0
 4192        )
 4193    ->  Code = 1
 4194    ;   Code = 0
 4195    ).
 4196
 4197
 4198%!  at_halt(:Goal)
 4199%
 4200%   Register Goal to be called if the system halts.
 4201%
 4202%   @tbd: get location into the error message
 4203
 4204:- meta_predicate at_halt(0). 4205:- dynamic        system:term_expansion/2, '$at_halt'/2. 4206:- multifile      system:term_expansion/2, '$at_halt'/2. 4207
 4208system:term_expansion((:- at_halt(Goal)),
 4209                      system:'$at_halt'(Module:Goal, File:Line)) :-
 4210    \+ current_prolog_flag(xref, true),
 4211    source_location(File, Line),
 4212    '$current_source_module'(Module).
 4213
 4214at_halt(Goal) :-
 4215    asserta('$at_halt'(Goal, (-):0)).
 4216
 4217:- public '$run_at_halt'/0. 4218
 4219'$run_at_halt' :-
 4220    forall(clause('$at_halt'(Goal, Src), true, Ref),
 4221           ( '$call_at_halt'(Goal, Src),
 4222             erase(Ref)
 4223           )).
 4224
 4225'$call_at_halt'(Goal, _Src) :-
 4226    catch(Goal, E, true),
 4227    !,
 4228    (   var(E)
 4229    ->  true
 4230    ;   subsumes_term(cancel_halt(_), E)
 4231    ->  '$print_message'(informational, E),
 4232        fail
 4233    ;   '$print_message'(error, E)
 4234    ).
 4235'$call_at_halt'(Goal, _Src) :-
 4236    '$print_message'(warning, goal_failed(at_halt, Goal)).
 4237
 4238%!  cancel_halt(+Reason)
 4239%
 4240%   This predicate may be called from   at_halt/1 handlers to cancel
 4241%   halting the program. If  causes  halt/0   to  fail  rather  than
 4242%   terminating the process.
 4243
 4244cancel_halt(Reason) :-
 4245    throw(cancel_halt(Reason)).
 4246
 4247
 4248                /********************************
 4249                *      LOAD OTHER MODULES       *
 4250                *********************************/
 4251
 4252:- meta_predicate
 4253    '$load_wic_files'(:). 4254
 4255'$load_wic_files'(Files) :-
 4256    Files = Module:_,
 4257    '$execute_directive'('$set_source_module'(OldM, Module), []),
 4258    '$save_lex_state'(LexState, []),
 4259    '$style_check'(_, 0xC7),                % see style_name/2 in syspred.pl
 4260    '$compilation_mode'(OldC, wic),
 4261    consult(Files),
 4262    '$execute_directive'('$set_source_module'(OldM), []),
 4263    '$execute_directive'('$restore_lex_state'(LexState), []),
 4264    '$set_compilation_mode'(OldC).
 4265
 4266
 4267%!  '$load_additional_boot_files' is det.
 4268%
 4269%   Called from compileFileList() in pl-wic.c.   Gets the files from
 4270%   "-c file ..." and loads them into the module user.
 4271
 4272:- public '$load_additional_boot_files'/0. 4273
 4274'$load_additional_boot_files' :-
 4275    current_prolog_flag(argv, Argv),
 4276    '$get_files_argv'(Argv, Files),
 4277    (   Files \== []
 4278    ->  format('Loading additional boot files~n'),
 4279        '$load_wic_files'(user:Files),
 4280        format('additional boot files loaded~n')
 4281    ;   true
 4282    ).
 4283
 4284'$get_files_argv'([], []) :- !.
 4285'$get_files_argv'(['-c'|Files], Files) :- !.
 4286'$get_files_argv'([_|Rest], Files) :-
 4287    '$get_files_argv'(Rest, Files).
 4288
 4289'$:-'(('$boot_message'('Loading Prolog startup files~n', []),
 4290       source_location(File, _Line),
 4291       file_directory_name(File, Dir),
 4292       atom_concat(Dir, '/load.pl', LoadFile),
 4293       '$load_wic_files'(system:[LoadFile]),
 4294       (   current_prolog_flag(windows, true)
 4295       ->  atom_concat(Dir, '/menu.pl', MenuFile),
 4296           '$load_wic_files'(system:[MenuFile])
 4297       ;   true
 4298       ),
 4299       '$boot_message'('SWI-Prolog boot files loaded~n', []),
 4300       '$compilation_mode'(OldC, wic),
 4301       '$execute_directive'('$set_source_module'(user), []),
 4302       '$set_compilation_mode'(OldC)
 4303      ))