init.pl

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        ;   '$option'(access(none), Options, none)
 1223        )
 1224    ->  Options2 = Options1
 1225    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
 1226    ),
 1227                    % Det or nondet?
 1228    (   '$select_option'(solutions(Sols), Options2, Options3)
 1229    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
 1230    ;   Sols = first,
 1231        Options3 = Options2
 1232    ),
 1233                    % Errors or not?
 1234    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
 1235    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
 1236    ;   FileErrors = error,
 1237        Options4 = Options3
 1238    ),
 1239                    % Expand shell patterns?
 1240    (   atomic(Spec),
 1241        '$select_option'(expand(Expand), Options4, Options5),
 1242        '$must_be'(boolean, Expand)
 1243    ->  expand_file_name(Spec, List),
 1244        '$member'(Spec1, List)
 1245    ;   Spec1 = Spec,
 1246        Options5 = Options4
 1247    ),
 1248                    % Search for files
 1249    (   Sols == first
 1250    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
 1251        ->  !       % also kill choice point of expand_file_name/2
 1252        ;   (   FileErrors == fail
 1253            ->  fail
 1254            ;   '$current_module'('$bags', _File),
 1255                findall(P,
 1256                        '$chk_file'(Spec1, Extensions, [access(exist)],
 1257                                    false, P),
 1258                        Candidates),
 1259                '$abs_file_error'(Spec, Candidates, Options5)
 1260            )
 1261        )
 1262    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 1263    ).
 1264
 1265'$abs_file_error'(Spec, Candidates, Conditions) :-
 1266    '$member'(F, Candidates),
 1267    '$member'(C, Conditions),
 1268    '$file_condition'(C),
 1269    '$file_error'(C, Spec, F, E, Comment),
 1270    !,
 1271    throw(error(E, context(_, Comment))).
 1272'$abs_file_error'(Spec, _, _) :-
 1273    '$existence_error'(source_sink, Spec).
 1274
 1275'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 1276    \+ exists_directory(File),
 1277    !,
 1278    Error = existence_error(directory, Spec),
 1279    Comment = not_a_directory(File).
 1280'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 1281    exists_directory(File),
 1282    !,
 1283    Error = existence_error(file, Spec),
 1284    Comment = directory(File).
 1285'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 1286    '$one_or_member'(Access, OneOrList),
 1287    \+ access_file(File, Access),
 1288    Error = permission_error(Access, source_sink, Spec).
 1289
 1290'$one_or_member'(Elem, List) :-
 1291    is_list(List),
 1292    !,
 1293    '$member'(Elem, List).
 1294'$one_or_member'(Elem, Elem).
 1295
 1296
 1297'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 1298    !,
 1299    '$file_type_extensions'(prolog, Exts).
 1300'$file_type_extensions'(Type, Exts) :-
 1301    '$current_module'('$bags', _File),
 1302    !,
 1303    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 1304    (   Exts0 == [],
 1305        \+ '$ft_no_ext'(Type)
 1306    ->  '$domain_error'(file_type, Type)
 1307    ;   true
 1308    ),
 1309    '$append'(Exts0, [''], Exts).
 1310'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 1311
 1312'$ft_no_ext'(txt).
 1313'$ft_no_ext'(executable).
 1314'$ft_no_ext'(directory).
 1315'$ft_no_ext'(regular).
 1316
 1317%!  user:prolog_file_type(?Extension, ?Type)
 1318%
 1319%   Define type of file based on the extension.  This is used by
 1320%   absolute_file_name/3 and may be used to extend the list of
 1321%   extensions used for some type.
 1322%
 1323%   Note that =qlf= must be last   when  searching for Prolog files.
 1324%   Otherwise use_module/1 will consider  the   file  as  not-loaded
 1325%   because the .qlf file is not  the   loaded  file.  Must be fixed
 1326%   elsewhere.
 1327
 1328:- multifile(user:prolog_file_type/2). 1329:- dynamic(user:prolog_file_type/2). 1330
 1331user:prolog_file_type(pl,       prolog).
 1332user:prolog_file_type(prolog,   prolog).
 1333user:prolog_file_type(qlf,      prolog).
 1334user:prolog_file_type(qlf,      qlf).
 1335user:prolog_file_type(Ext,      executable) :-
 1336    current_prolog_flag(shared_object_extension, Ext).
 1337user:prolog_file_type(dylib,    executable) :-
 1338    current_prolog_flag(apple,  true).
 1339
 1340%!  '$chk_file'(+Spec, +Extensions, +Cond, +UseCache, -FullName)
 1341%
 1342%   File is a specification of a Prolog source file. Return the full
 1343%   path of the file.
 1344
 1345'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1346    \+ ground(Spec),
 1347    !,
 1348    '$instantiation_error'(Spec).
 1349'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1350    compound(Spec),
 1351    functor(Spec, _, 1),
 1352    !,
 1353    '$relative_to'(Cond, cwd, CWD),
 1354    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1355'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1356    \+ atomic(Segments),
 1357    !,
 1358    '$segments_to_atom'(Segments, Atom),
 1359    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1360'$chk_file'(File, Exts, Cond, _, FullName) :-
 1361    is_absolute_file_name(File),
 1362    !,
 1363    '$extend_file'(File, Exts, Extended),
 1364    '$file_conditions'(Cond, Extended),
 1365    '$absolute_file_name'(Extended, FullName).
 1366'$chk_file'(File, Exts, Cond, _, FullName) :-
 1367    '$relative_to'(Cond, source, Dir),
 1368    atomic_list_concat([Dir, /, File], AbsFile),
 1369    '$extend_file'(AbsFile, Exts, Extended),
 1370    '$file_conditions'(Cond, Extended),
 1371    !,
 1372    '$absolute_file_name'(Extended, FullName).
 1373'$chk_file'(File, Exts, Cond, _, FullName) :-
 1374    '$extend_file'(File, Exts, Extended),
 1375    '$file_conditions'(Cond, Extended),
 1376    '$absolute_file_name'(Extended, FullName).
 1377
 1378'$segments_to_atom'(Atom, Atom) :-
 1379    atomic(Atom),
 1380    !.
 1381'$segments_to_atom'(Segments, Atom) :-
 1382    '$segments_to_list'(Segments, List, []),
 1383    !,
 1384    atomic_list_concat(List, /, Atom).
 1385
 1386'$segments_to_list'(A/B, H, T) :-
 1387    '$segments_to_list'(A, H, T0),
 1388    '$segments_to_list'(B, T0, T).
 1389'$segments_to_list'(A, [A|T], T) :-
 1390    atomic(A).
 1391
 1392
 1393%!  '$relative_to'(+Condition, +Default, -Dir)
 1394%
 1395%   Determine the directory to work from.  This can be specified
 1396%   explicitely using one or more relative_to(FileOrDir) options
 1397%   or implicitely relative to the working directory or current
 1398%   source-file.
 1399
 1400'$relative_to'(Conditions, Default, Dir) :-
 1401    (   '$option'(relative_to(FileOrDir), Conditions)
 1402    *-> (   exists_directory(FileOrDir)
 1403        ->  Dir = FileOrDir
 1404        ;   atom_concat(Dir, /, FileOrDir)
 1405        ->  true
 1406        ;   file_directory_name(FileOrDir, Dir)
 1407        )
 1408    ;   Default == cwd
 1409    ->  '$cwd'(Dir)
 1410    ;   Default == source
 1411    ->  source_location(ContextFile, _Line),
 1412        file_directory_name(ContextFile, Dir)
 1413    ).
 1414
 1415%!  '$chk_alias_file'(+Spec, +Exts, +Cond, +Cache, +CWD,
 1416%!                    -FullFile) is nondet.
 1417
 1418:- dynamic
 1419    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1420    '$search_path_gc_time'/1.       % Time
 1421:- volatile
 1422    '$search_path_file_cache'/3,
 1423    '$search_path_gc_time'/1. 1424
 1425:- create_prolog_flag(file_search_cache_time, 10, []). 1426
 1427'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1428    !,
 1429    findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
 1430    current_prolog_flag(emulated_dialect, Dialect),
 1431    Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
 1432    variant_sha1(Spec+Cache, SHA1),
 1433    get_time(Now),
 1434    current_prolog_flag(file_search_cache_time, TimeOut),
 1435    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1436        CachedTime > Now - TimeOut,
 1437        '$file_conditions'(Cond, FullFile)
 1438    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1439    ;   '$member'(Expanded, Expansions),
 1440        '$extend_file'(Expanded, Exts, LibFile),
 1441        (   '$file_conditions'(Cond, LibFile),
 1442            '$absolute_file_name'(LibFile, FullFile),
 1443            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1444        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1445        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1446            fail
 1447        )
 1448    ).
 1449'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1450    '$expand_file_search_path'(Spec, Expanded, Cond),
 1451    '$extend_file'(Expanded, Exts, LibFile),
 1452    '$file_conditions'(Cond, LibFile),
 1453    '$absolute_file_name'(LibFile, FullFile).
 1454
 1455'$cache_file_found'(_, _, TimeOut, _) :-
 1456    TimeOut =:= 0,
 1457    !.
 1458'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1459    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1460    !,
 1461    (   Now - Saved < TimeOut/2
 1462    ->  true
 1463    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1464        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1465    ).
 1466'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1467    'gc_file_search_cache'(TimeOut),
 1468    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1469
 1470'gc_file_search_cache'(TimeOut) :-
 1471    get_time(Now),
 1472    '$search_path_gc_time'(Last),
 1473    Now-Last < TimeOut/2,
 1474    !.
 1475'gc_file_search_cache'(TimeOut) :-
 1476    get_time(Now),
 1477    retractall('$search_path_gc_time'(_)),
 1478    assertz('$search_path_gc_time'(Now)),
 1479    Before is Now - TimeOut,
 1480    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1481        Cached < Before,
 1482        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1483        fail
 1484    ;   true
 1485    ).
 1486
 1487
 1488'$search_message'(Term) :-
 1489    current_prolog_flag(verbose_file_search, true),
 1490    !,
 1491    print_message(informational, Term).
 1492'$search_message'(_).
 1493
 1494
 1495%!  '$file_conditions'(+Condition, +Path)
 1496%
 1497%   Verify Path satisfies Condition.
 1498
 1499'$file_conditions'(List, File) :-
 1500    is_list(List),
 1501    !,
 1502    \+ ( '$member'(C, List),
 1503         '$file_condition'(C),
 1504         \+ '$file_condition'(C, File)
 1505       ).
 1506'$file_conditions'(Map, File) :-
 1507    \+ (  get_dict(Key, Map, Value),
 1508          C =.. [Key,Value],
 1509          '$file_condition'(C),
 1510         \+ '$file_condition'(C, File)
 1511       ).
 1512
 1513'$file_condition'(file_type(directory), File) :-
 1514    !,
 1515    exists_directory(File).
 1516'$file_condition'(file_type(_), File) :-
 1517    !,
 1518    \+ exists_directory(File).
 1519'$file_condition'(access(Accesses), File) :-
 1520    !,
 1521    \+ (  '$one_or_member'(Access, Accesses),
 1522          \+ access_file(File, Access)
 1523       ).
 1524
 1525'$file_condition'(exists).
 1526'$file_condition'(file_type(_)).
 1527'$file_condition'(access(_)).
 1528
 1529'$extend_file'(File, Exts, FileEx) :-
 1530    '$ensure_extensions'(Exts, File, Fs),
 1531    '$list_to_set'(Fs, FsSet),
 1532    '$member'(FileEx, FsSet).
 1533
 1534'$ensure_extensions'([], _, []).
 1535'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1536    file_name_extension(F, E, FE),
 1537    '$ensure_extensions'(E0, F, E1).
 1538
 1539%!  '$list_to_set'(+List, -Set) is det.
 1540%
 1541%   Turn list into a set, keeping   the  left-most copy of duplicate
 1542%   elements.  Copied from library(lists).
 1543
 1544'$list_to_set'(List, Set) :-
 1545    '$number_list'(List, 1, Numbered),
 1546    sort(1, @=<, Numbered, ONum),
 1547    '$remove_dup_keys'(ONum, NumSet),
 1548    sort(2, @=<, NumSet, ONumSet),
 1549    '$pairs_keys'(ONumSet, Set).
 1550
 1551'$number_list'([], _, []).
 1552'$number_list'([H|T0], N, [H-N|T]) :-
 1553    N1 is N+1,
 1554    '$number_list'(T0, N1, T).
 1555
 1556'$remove_dup_keys'([], []).
 1557'$remove_dup_keys'([H|T0], [H|T]) :-
 1558    H = V-_,
 1559    '$remove_same_key'(T0, V, T1),
 1560    '$remove_dup_keys'(T1, T).
 1561
 1562'$remove_same_key'([V1-_|T0], V, T) :-
 1563    V1 == V,
 1564    !,
 1565    '$remove_same_key'(T0, V, T).
 1566'$remove_same_key'(L, _, L).
 1567
 1568'$pairs_keys'([], []).
 1569'$pairs_keys'([K-_|T0], [K|T]) :-
 1570    '$pairs_keys'(T0, T).
 1571
 1572
 1573/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 1574Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
 1575the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
 1576extensions to .ext
 1577- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 1578
 1579'$canonicalise_extensions'([], []) :- !.
 1580'$canonicalise_extensions'([H|T], [CH|CT]) :-
 1581    !,
 1582    '$must_be'(atom, H),
 1583    '$canonicalise_extension'(H, CH),
 1584    '$canonicalise_extensions'(T, CT).
 1585'$canonicalise_extensions'(E, [CE]) :-
 1586    '$canonicalise_extension'(E, CE).
 1587
 1588'$canonicalise_extension'('', '') :- !.
 1589'$canonicalise_extension'(DotAtom, DotAtom) :-
 1590    sub_atom(DotAtom, 0, _, _, '.'),
 1591    !.
 1592'$canonicalise_extension'(Atom, DotAtom) :-
 1593    atom_concat('.', Atom, DotAtom).
 1594
 1595
 1596                /********************************
 1597                *            CONSULT            *
 1598                *********************************/
 1599
 1600:- dynamic
 1601    user:library_directory/1,
 1602    user:prolog_load_file/2. 1603:- multifile
 1604    user:library_directory/1,
 1605    user:prolog_load_file/2. 1606
 1607:- prompt(_, '|: '). 1608
 1609:- thread_local
 1610    '$compilation_mode_store'/1,    % database, wic, qlf
 1611    '$directive_mode_store'/1.      % database, wic, qlf
 1612:- volatile
 1613    '$compilation_mode_store'/1,
 1614    '$directive_mode_store'/1. 1615
 1616'$compilation_mode'(Mode) :-
 1617    (   '$compilation_mode_store'(Val)
 1618    ->  Mode = Val
 1619    ;   Mode = database
 1620    ).
 1621
 1622'$set_compilation_mode'(Mode) :-
 1623    retractall('$compilation_mode_store'(_)),
 1624    assertz('$compilation_mode_store'(Mode)).
 1625
 1626'$compilation_mode'(Old, New) :-
 1627    '$compilation_mode'(Old),
 1628    (   New == Old
 1629    ->  true
 1630    ;   '$set_compilation_mode'(New)
 1631    ).
 1632
 1633'$directive_mode'(Mode) :-
 1634    (   '$directive_mode_store'(Val)
 1635    ->  Mode = Val
 1636    ;   Mode = database
 1637    ).
 1638
 1639'$directive_mode'(Old, New) :-
 1640    '$directive_mode'(Old),
 1641    (   New == Old
 1642    ->  true
 1643    ;   '$set_directive_mode'(New)
 1644    ).
 1645
 1646'$set_directive_mode'(Mode) :-
 1647    retractall('$directive_mode_store'(_)),
 1648    assertz('$directive_mode_store'(Mode)).
 1649
 1650
 1651%!  '$compilation_level'(-Level) is det.
 1652%
 1653%   True when Level reflects the nesting   in  files compiling other
 1654%   files. 0 if no files are being loaded.
 1655
 1656'$compilation_level'(Level) :-
 1657    '$input_context'(Stack),
 1658    '$compilation_level'(Stack, Level).
 1659
 1660'$compilation_level'([], 0).
 1661'$compilation_level'([Input|T], Level) :-
 1662    (   arg(1, Input, see)
 1663    ->  '$compilation_level'(T, Level)
 1664    ;   '$compilation_level'(T, Level0),
 1665        Level is Level0+1
 1666    ).
 1667
 1668
 1669%!  compiling
 1670%
 1671%   Is true if SWI-Prolog is generating a state or qlf file or
 1672%   executes a `call' directive while doing this.
 1673
 1674compiling :-
 1675    \+ (   '$compilation_mode'(database),
 1676           '$directive_mode'(database)
 1677       ).
 1678
 1679:- meta_predicate
 1680    '$ifcompiling'(0). 1681
 1682'$ifcompiling'(G) :-
 1683    (   '$compilation_mode'(database)
 1684    ->  true
 1685    ;   call(G)
 1686    ).
 1687
 1688                /********************************
 1689                *         READ SOURCE           *
 1690                *********************************/
 1691
 1692%!  '$load_msg_level'(+Action, +NestingLevel, -StartVerbose, -EndVerbose)
 1693
 1694'$load_msg_level'(Action, Nesting, Start, Done) :-
 1695    '$update_autoload_level'([], 0),
 1696    !,
 1697    current_prolog_flag(verbose_load, Type0),
 1698    '$load_msg_compat'(Type0, Type),
 1699    (   '$load_msg_level'(Action, Nesting, Type, Start, Done)
 1700    ->  true
 1701    ).
 1702'$load_msg_level'(_, _, silent, silent).
 1703
 1704'$load_msg_compat'(true, normal) :- !.
 1705'$load_msg_compat'(false, silent) :- !.
 1706'$load_msg_compat'(X, X).
 1707
 1708'$load_msg_level'(load_file,    _, full,   informational, informational).
 1709'$load_msg_level'(include_file, _, full,   informational, informational).
 1710'$load_msg_level'(load_file,    _, normal, silent,        informational).
 1711'$load_msg_level'(include_file, _, normal, silent,        silent).
 1712'$load_msg_level'(load_file,    0, brief,  silent,        informational).
 1713'$load_msg_level'(load_file,    _, brief,  silent,        silent).
 1714'$load_msg_level'(include_file, _, brief,  silent,        silent).
 1715'$load_msg_level'(load_file,    _, silent, silent,        silent).
 1716'$load_msg_level'(include_file, _, silent, silent,        silent).
 1717
 1718%!  '$source_term'(+From, -Read, -RLayout, -Term, -TLayout,
 1719%!                 -Stream, +Options) is nondet.
 1720%
 1721%   Read Prolog terms from the  input   From.  Terms are returned on
 1722%   backtracking. Associated resources (i.e.,   streams)  are closed
 1723%   due to setup_call_cleanup/3.
 1724%
 1725%   @param From is either a term stream(Id, Stream) or a file
 1726%          specification.
 1727%   @param Read is the raw term as read from the input.
 1728%   @param Term is the term after term-expansion.  If a term is
 1729%          expanded into the empty list, this is returned too.  This
 1730%          is required to be able to return the raw term in Read
 1731%   @param Stream is the stream from which Read is read
 1732%   @param Options provides additional options:
 1733%           * encoding(Enc)
 1734%           Encoding used to open From
 1735%           * syntax_errors(+ErrorMode)
 1736%           * process_comments(+Boolean)
 1737%           * term_position(-Pos)
 1738
 1739'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
 1740    '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
 1741    (   Term == end_of_file
 1742    ->  !, fail
 1743    ;   Term \== begin_of_file
 1744    ).
 1745
 1746'$source_term'(Input, _,_,_,_,_,_,_) :-
 1747    \+ ground(Input),
 1748    !,
 1749    '$instantiation_error'(Input).
 1750'$source_term'(stream(Id, In, Opts),
 1751               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1752    !,
 1753    '$record_included'(Parents, Id, Id, 0.0, Message),
 1754    setup_call_cleanup(
 1755        '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
 1756        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1757                        [Id|Parents], Options),
 1758        '$close_source'(State, Message)).
 1759'$source_term'(File,
 1760               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1761    absolute_file_name(File, Path,
 1762                       [ file_type(prolog),
 1763                         access(read)
 1764                       ]),
 1765    time_file(Path, Time),
 1766    '$record_included'(Parents, File, Path, Time, Message),
 1767    setup_call_cleanup(
 1768        '$open_source'(Path, In, State, Parents, Options),
 1769        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1770                        [Path|Parents], Options),
 1771        '$close_source'(State, Message)).
 1772
 1773:- thread_local
 1774    '$load_input'/2. 1775:- volatile
 1776    '$load_input'/2. 1777
 1778'$open_source'(stream(Id, In, Opts), In,
 1779               restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :-
 1780    !,
 1781    '$context_type'(Parents, ContextType),
 1782    '$push_input_context'(ContextType),
 1783    '$prepare_load_stream'(In, Id, StreamState),
 1784    asserta('$load_input'(stream(Id), In), Ref).
 1785'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
 1786    '$context_type'(Parents, ContextType),
 1787    '$push_input_context'(ContextType),
 1788    '$open_source'(Path, In, Options),
 1789    '$set_encoding'(In, Options),
 1790    asserta('$load_input'(Path, In), Ref).
 1791
 1792'$context_type'([], load_file) :- !.
 1793'$context_type'(_, include).
 1794
 1795:- multifile prolog:open_source_hook/3. 1796
 1797'$open_source'(Path, In, Options) :-
 1798    prolog:open_source_hook(Path, In, Options),
 1799    !.
 1800'$open_source'(Path, In, _Options) :-
 1801    open(Path, read, In).
 1802
 1803'$close_source'(close(In, _Id, Ref), Message) :-
 1804    erase(Ref),
 1805    call_cleanup(
 1806        close(In),
 1807        '$pop_input_context'),
 1808    '$close_message'(Message).
 1809'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :-
 1810    erase(Ref),
 1811    call_cleanup(
 1812        '$restore_load_stream'(In, StreamState, Opts),
 1813        '$pop_input_context'),
 1814    '$close_message'(Message).
 1815
 1816'$close_message'(message(Level, Msg)) :-
 1817    !,
 1818    '$print_message'(Level, Msg).
 1819'$close_message'(_).
 1820
 1821
 1822%!  '$term_in_file'(+In, -Read, -RLayout, -Term, -TLayout,
 1823%!                  -Stream, +Parents, +Options) is multi.
 1824%
 1825%   True when Term is an expanded term from   In. Read is a raw term
 1826%   (before term-expansion). Stream is  the   actual  stream,  which
 1827%   starts at In, but may change due to processing included files.
 1828%
 1829%   @see '$source_term'/8 for details.
 1830
 1831'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1832    Parents \= [_,_|_],
 1833    (   '$load_input'(_, Input)
 1834    ->  stream_property(Input, file_name(File))
 1835    ),
 1836    '$set_source_location'(File, 0),
 1837    '$expanded_term'(In,
 1838                     begin_of_file, 0-0, Read, RLayout, Term, TLayout,
 1839                     Stream, Parents, Options).
 1840'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1841    '$skip_script_line'(In, Options),
 1842    '$read_clause_options'(Options, ReadOptions),
 1843    repeat,
 1844      read_clause(In, Raw,
 1845                  [ variable_names(Bindings),
 1846                    term_position(Pos),
 1847                    subterm_positions(RawLayout)
 1848                  | ReadOptions
 1849                  ]),
 1850      b_setval('$term_position', Pos),
 1851      b_setval('$variable_names', Bindings),
 1852      (   Raw == end_of_file
 1853      ->  !,
 1854          (   Parents = [_,_|_]     % Included file
 1855          ->  fail
 1856          ;   '$expanded_term'(In,
 1857                               Raw, RawLayout, Read, RLayout, Term, TLayout,
 1858                               Stream, Parents, Options)
 1859          )
 1860      ;   '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1861                           Stream, Parents, Options)
 1862      ).
 1863
 1864'$read_clause_options'([], []).
 1865'$read_clause_options'([H|T0], List) :-
 1866    (   '$read_clause_option'(H)
 1867    ->  List = [H|T]
 1868    ;   List = T
 1869    ),
 1870    '$read_clause_options'(T0, T).
 1871
 1872'$read_clause_option'(syntax_errors(_)).
 1873'$read_clause_option'(term_position(_)).
 1874'$read_clause_option'(process_comment(_)).
 1875
 1876'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1877                 Stream, Parents, Options) :-
 1878    E = error(_,_),
 1879    catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
 1880          '$print_message_fail'(E)),
 1881    (   Expanded \== []
 1882    ->  '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
 1883    ;   Term1 = Expanded,
 1884        Layout1 = ExpandedLayout
 1885    ),
 1886    (   nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
 1887    ->  (   Directive = include(File),
 1888            '$current_source_module'(Module),
 1889            '$valid_directive'(Module:include(File))
 1890        ->  stream_property(In, encoding(Enc)),
 1891            '$add_encoding'(Enc, Options, Options1),
 1892            '$source_term'(File, Read, RLayout, Term, TLayout,
 1893                           Stream, Parents, Options1)
 1894        ;   Directive = encoding(Enc)
 1895        ->  set_stream(In, encoding(Enc)),
 1896            fail
 1897        ;   Term = Term1,
 1898            Stream = In,
 1899            Read = Raw
 1900        )
 1901    ;   Term = Term1,
 1902        TLayout = Layout1,
 1903        Stream = In,
 1904        Read = Raw,
 1905        RLayout = RawLayout
 1906    ).
 1907
 1908'$expansion_member'(Var, Layout, Var, Layout) :-
 1909    var(Var),
 1910    !.
 1911'$expansion_member'([], _, _, _) :- !, fail.
 1912'$expansion_member'(List, ListLayout, Term, Layout) :-
 1913    is_list(List),
 1914    !,
 1915    (   var(ListLayout)
 1916    ->  '$member'(Term, List)
 1917    ;   is_list(ListLayout)
 1918    ->  '$member_rep2'(Term, Layout, List, ListLayout)
 1919    ;   Layout = ListLayout,
 1920        '$member'(Term, List)
 1921    ).
 1922'$expansion_member'(X, Layout, X, Layout).
 1923
 1924% pairwise member, repeating last element of the second
 1925% list.
 1926
 1927'$member_rep2'(H1, H2, [H1|_], [H2|_]).
 1928'$member_rep2'(H1, H2, [_|T1], [T2]) :-
 1929    !,
 1930    '$member_rep2'(H1, H2, T1, [T2]).
 1931'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
 1932    '$member_rep2'(H1, H2, T1, T2).
 1933
 1934%!  '$add_encoding'(+Enc, +Options0, -Options)
 1935
 1936'$add_encoding'(Enc, Options0, Options) :-
 1937    (   Options0 = [encoding(Enc)|_]
 1938    ->  Options = Options0
 1939    ;   Options = [encoding(Enc)|Options0]
 1940    ).
 1941
 1942
 1943:- multifile
 1944    '$included'/4.                  % Into, Line, File, LastModified
 1945:- dynamic
 1946    '$included'/4. 1947
 1948%!  '$record_included'(+Parents, +File, +Path, +Time, -Message) is det.
 1949%
 1950%   Record that we included File into the   head of Parents. This is
 1951%   troublesome when creating a QLF  file   because  this may happen
 1952%   before we opened the QLF file (and  we   do  not yet know how to
 1953%   open the file because we  do  not   yet  know  whether this is a
 1954%   module file or not).
 1955%
 1956%   I think that the only sensible  solution   is  to have a special
 1957%   statement for this, that may appear  both inside and outside QLF
 1958%   `parts'.
 1959
 1960'$record_included'([Parent|Parents], File, Path, Time,
 1961                   message(DoneMsgLevel,
 1962                           include_file(done(Level, file(File, Path))))) :-
 1963    source_location(SrcFile, Line),
 1964    !,
 1965    '$compilation_level'(Level),
 1966    '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
 1967    '$print_message'(StartMsgLevel,
 1968                     include_file(start(Level,
 1969                                        file(File, Path)))),
 1970    '$last'([Parent|Parents], Owner),
 1971    (   (   '$compilation_mode'(database)
 1972        ;   '$qlf_current_source'(Owner)
 1973        )
 1974    ->  '$store_admin_clause'(
 1975            system:'$included'(Parent, Line, Path, Time),
 1976            _, Owner, SrcFile:Line)
 1977    ;   '$qlf_include'(Owner, Parent, Line, Path, Time)
 1978    ).
 1979'$record_included'(_, _, _, _, true).
 1980
 1981%!  '$master_file'(+File, -MasterFile)
 1982%
 1983%   Find the primary load file from included files.
 1984
 1985'$master_file'(File, MasterFile) :-
 1986    '$included'(MasterFile0, _Line, File, _Time),
 1987    !,
 1988    '$master_file'(MasterFile0, MasterFile).
 1989'$master_file'(File, File).
 1990
 1991
 1992'$skip_script_line'(_In, Options) :-
 1993    '$option'(check_script(false), Options),
 1994    !.
 1995'$skip_script_line'(In, _Options) :-
 1996    (   peek_char(In, #)
 1997    ->  skip(In, 10)
 1998    ;   true
 1999    ).
 2000
 2001'$set_encoding'(Stream, Options) :-
 2002    '$option'(encoding(Enc), Options),
 2003    !,
 2004    Enc \== default,
 2005    set_stream(Stream, encoding(Enc)).
 2006'$set_encoding'(_, _).
 2007
 2008
 2009'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
 2010    (   stream_property(In, file_name(_))
 2011    ->  HasName = true,
 2012        (   stream_property(In, position(_))
 2013        ->  HasPos = true
 2014        ;   HasPos = false,
 2015            set_stream(In, record_position(true))
 2016        )
 2017    ;   HasName = false,
 2018        set_stream(In, file_name(Id)),
 2019        (   stream_property(In, position(_))
 2020        ->  HasPos = true
 2021        ;   HasPos = false,
 2022            set_stream(In, record_position(true))
 2023        )
 2024    ).
 2025
 2026'$restore_load_stream'(In, _State, Options) :-
 2027    memberchk(close(true), Options),
 2028    !,
 2029    close(In).
 2030'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
 2031    (   HasName == false
 2032    ->  set_stream(In, file_name(''))
 2033    ;   true
 2034    ),
 2035    (   HasPos == false
 2036    ->  set_stream(In, record_position(false))
 2037    ;   true
 2038    ).
 2039
 2040
 2041                 /*******************************
 2042                 *          DERIVED FILES       *
 2043                 *******************************/
 2044
 2045:- dynamic
 2046    '$derived_source_db'/3.         % Loaded, DerivedFrom, Time
 2047
 2048'$register_derived_source'(_, '-') :- !.
 2049'$register_derived_source'(Loaded, DerivedFrom) :-
 2050    retractall('$derived_source_db'(Loaded, _, _)),
 2051    time_file(DerivedFrom, Time),
 2052    assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
 2053
 2054%       Auto-importing dynamic predicates is not very elegant and
 2055%       leads to problems with qsave_program/[1,2]
 2056
 2057'$derived_source'(Loaded, DerivedFrom, Time) :-
 2058    '$derived_source_db'(Loaded, DerivedFrom, Time).
 2059
 2060
 2061                /********************************
 2062                *       LOAD PREDICATES         *
 2063                *********************************/
 2064
 2065:- meta_predicate
 2066    ensure_loaded(:),
 2067    [:|+],
 2068    consult(:),
 2069    use_module(:),
 2070    use_module(:, +),
 2071    reexport(:),
 2072    reexport(:, +),
 2073    load_files(:),
 2074    load_files(:, +). 2075
 2076%!  ensure_loaded(+FileOrListOfFiles)
 2077%
 2078%   Load specified files, provided they where not loaded before. If the
 2079%   file is a module file import the public predicates into the context
 2080%   module.
 2081
 2082ensure_loaded(Files) :-
 2083    load_files(Files, [if(not_loaded)]).
 2084
 2085%!  use_module(+FileOrListOfFiles)
 2086%
 2087%   Very similar to ensure_loaded/1, but insists on the loaded file to
 2088%   be a module file. If the file is already imported, but the public
 2089%   predicates are not yet imported into the context module, then do
 2090%   so.
 2091
 2092use_module(Files) :-
 2093    load_files(Files, [ if(not_loaded),
 2094                        must_be_module(true)
 2095                      ]).
 2096
 2097%!  use_module(+File, +ImportList)
 2098%
 2099%   As use_module/1, but takes only one file argument and imports only
 2100%   the specified predicates rather than all public predicates.
 2101
 2102use_module(File, Import) :-
 2103    load_files(File, [ if(not_loaded),
 2104                       must_be_module(true),
 2105                       imports(Import)
 2106                     ]).
 2107
 2108%!  reexport(+Files)
 2109%
 2110%   As use_module/1, exporting all imported predicates.
 2111
 2112reexport(Files) :-
 2113    load_files(Files, [ if(not_loaded),
 2114                        must_be_module(true),
 2115                        reexport(true)
 2116                      ]).
 2117
 2118%!  reexport(+File, +ImportList)
 2119%
 2120%   As use_module/1, re-exporting all imported predicates.
 2121
 2122reexport(File, Import) :-
 2123    load_files(File, [ if(not_loaded),
 2124                       must_be_module(true),
 2125                       imports(Import),
 2126                       reexport(true)
 2127                     ]).
 2128
 2129
 2130[X] :-
 2131    !,
 2132    consult(X).
 2133[M:F|R] :-
 2134    consult(M:[F|R]).
 2135
 2136consult(M:X) :-
 2137    X == user,
 2138    !,
 2139    flag('$user_consult', N, N+1),
 2140    NN is N + 1,
 2141    atom_concat('user://', NN, Id),
 2142    load_files(M:Id, [stream(user_input), check_script(false), silent(false)]).
 2143consult(List) :-
 2144    load_files(List, [expand(true)]).
 2145
 2146%!  load_files(:File, +Options)
 2147%
 2148%   Common entry for all the consult derivates.  File is the raw user
 2149%   specified file specification, possibly tagged with the module.
 2150
 2151load_files(Files) :-
 2152    load_files(Files, []).
 2153load_files(Module:Files, Options) :-
 2154    '$must_be'(list, Options),
 2155    '$load_files'(Files, Module, Options).
 2156
 2157'$load_files'(X, _, _) :-
 2158    var(X),
 2159    !,
 2160    '$instantiation_error'(X).
 2161'$load_files'([], _, _) :- !.
 2162'$load_files'(Id, Module, Options) :-   % load_files(foo, [stream(In)])
 2163    '$option'(stream(_), Options),
 2164    !,
 2165    (   atom(Id)
 2166    ->  '$load_file'(Id, Module, Options)
 2167    ;   throw(error(type_error(atom, Id), _))
 2168    ).
 2169'$load_files'(List, Module, Options) :-
 2170    List = [_|_],
 2171    !,
 2172    '$must_be'(list, List),
 2173    '$load_file_list'(List, Module, Options).
 2174'$load_files'(File, Module, Options) :-
 2175    '$load_one_file'(File, Module, Options).
 2176
 2177'$load_file_list'([], _, _).
 2178'$load_file_list'([File|Rest], Module, Options) :-
 2179    E = error(_,_),
 2180    catch('$load_one_file'(File, Module, Options), E,
 2181          '$print_message'(error, E)),
 2182    '$load_file_list'(Rest, Module, Options).
 2183
 2184
 2185'$load_one_file'(Spec, Module, Options) :-
 2186    atomic(Spec),
 2187    '$option'(expand(Expand), Options, false),
 2188    Expand == true,
 2189    !,
 2190    expand_file_name(Spec, Expanded),
 2191    (   Expanded = [Load]
 2192    ->  true
 2193    ;   Load = Expanded
 2194    ),
 2195    '$load_files'(Load, Module, [expand(false)|Options]).
 2196'$load_one_file'(File, Module, Options) :-
 2197    strip_module(Module:File, Into, PlainFile),
 2198    '$load_file'(PlainFile, Into, Options).
 2199
 2200
 2201%!  '$noload'(+Condition, +FullFile, +Options) is semidet.
 2202%
 2203%   True of FullFile should _not_ be loaded.
 2204
 2205'$noload'(true, _, _) :-
 2206    !,
 2207    fail.
 2208'$noload'(_, FullFile, _Options) :-
 2209    '$time_source_file'(FullFile, Time, system),
 2210    Time > 0.0,
 2211    !.
 2212'$noload'(not_loaded, FullFile, _) :-
 2213    source_file(FullFile),
 2214    !.
 2215'$noload'(changed, Derived, _) :-
 2216    '$derived_source'(_FullFile, Derived, LoadTime),
 2217    time_file(Derived, Modified),
 2218    Modified @=< LoadTime,
 2219    !.
 2220'$noload'(changed, FullFile, Options) :-
 2221    '$time_source_file'(FullFile, LoadTime, user),
 2222    '$modified_id'(FullFile, Modified, Options),
 2223    Modified @=< LoadTime,
 2224    !.
 2225
 2226%!  '$qlf_file'(+Spec, +PlFile, -LoadFile, -Mode, +Options) is det.
 2227%
 2228%   Determine how to load the source. LoadFile is the file to be loaded,
 2229%   Mode is how to load it. Mode is one of
 2230%
 2231%     - compile
 2232%     Normal source compilation
 2233%     - qcompile
 2234%     Compile from source, creating a QLF file in the process
 2235%     - qload
 2236%     Load from QLF file.
 2237%     - stream
 2238%     Load from a stream.  Content can be a source or QLF file.
 2239%
 2240%   @arg Spec is the original search specification
 2241%   @arg PlFile is the resolved absolute path to the Prolog file.
 2242
 2243'$qlf_file'(Spec, _, Spec, stream, Options) :-
 2244    '$option'(stream(_), Options),      % stream: no choice
 2245    !.
 2246'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
 2247    '$spec_extension'(Spec, Ext),       % user explicitly specified
 2248    user:prolog_file_type(Ext, prolog),
 2249    !.
 2250'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :-
 2251    '$compilation_mode'(database),
 2252    file_name_extension(Base, PlExt, FullFile),
 2253    user:prolog_file_type(PlExt, prolog),
 2254    user:prolog_file_type(QlfExt, qlf),
 2255    file_name_extension(Base, QlfExt, QlfFile),
 2256    (   access_file(QlfFile, read),
 2257        (   '$qlf_out_of_date'(FullFile, QlfFile, Why)
 2258        ->  (   access_file(QlfFile, write)
 2259            ->  print_message(informational,
 2260                              qlf(recompile(Spec, FullFile, QlfFile, Why))),
 2261                Mode = qcompile,
 2262                LoadFile = FullFile
 2263            ;   Why == old,
 2264                current_prolog_flag(home, PlHome),
 2265                sub_atom(FullFile, 0, _, _, PlHome)
 2266            ->  print_message(silent,
 2267                              qlf(system_lib_out_of_date(Spec, QlfFile))),
 2268                Mode = qload,
 2269                LoadFile = QlfFile
 2270            ;   print_message(warning,
 2271                              qlf(can_not_recompile(Spec, QlfFile, Why))),
 2272                Mode = compile,
 2273                LoadFile = FullFile
 2274            )
 2275        ;   Mode = qload,
 2276            LoadFile = QlfFile
 2277        )
 2278    ->  !
 2279    ;   '$qlf_auto'(FullFile, QlfFile, Options)
 2280    ->  !, Mode = qcompile,
 2281        LoadFile = FullFile
 2282    ).
 2283'$qlf_file'(_, FullFile, FullFile, compile, _).
 2284
 2285
 2286%!  '$qlf_out_of_date'(+PlFile, +QlfFile, -Why) is semidet.
 2287%
 2288%   True if the  QlfFile  file  is   out-of-date  because  of  Why. This
 2289%   predicate is the negation such that we can return the reason.
 2290
 2291'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
 2292    (   access_file(PlFile, read)
 2293    ->  time_file(PlFile, PlTime),
 2294        time_file(QlfFile, QlfTime),
 2295        (   PlTime > QlfTime
 2296        ->  Why = old                   % PlFile is newer
 2297        ;   Error = error(Formal,_),
 2298            catch('$qlf_sources'(QlfFile, _Files), Error, true),
 2299            nonvar(Formal)              % QlfFile is incompatible
 2300        ->  Why = Error
 2301        ;   fail                        % QlfFile is up-to-date and ok
 2302        )
 2303    ;   fail                            % can not read .pl; try .qlf
 2304    ).
 2305
 2306%!  '$qlf_auto'(+PlFile, +QlfFile, +Options) is semidet.
 2307%
 2308%   True if we create QlfFile using   qcompile/2. This is determined
 2309%   by the option qcompile(QlfMode) or, if   this is not present, by
 2310%   the prolog_flag qcompile.
 2311
 2312:- create_prolog_flag(qcompile, false, [type(atom)]). 2313
 2314'$qlf_auto'(PlFile, QlfFile, Options) :-
 2315    (   memberchk(qcompile(QlfMode), Options)
 2316    ->  true
 2317    ;   current_prolog_flag(qcompile, QlfMode),
 2318        \+ '$in_system_dir'(PlFile)
 2319    ),
 2320    (   QlfMode == auto
 2321    ->  true
 2322    ;   QlfMode == large,
 2323        size_file(PlFile, Size),
 2324        Size > 100000
 2325    ),
 2326    access_file(QlfFile, write).
 2327
 2328'$in_system_dir'(PlFile) :-
 2329    current_prolog_flag(home, Home),
 2330    sub_atom(PlFile, 0, _, _, Home).
 2331
 2332'$spec_extension'(File, Ext) :-
 2333    atom(File),
 2334    file_name_extension(_, Ext, File).
 2335'$spec_extension'(Spec, Ext) :-
 2336    compound(Spec),
 2337    arg(1, Spec, Arg),
 2338    '$spec_extension'(Arg, Ext).
 2339
 2340
 2341%!  '$load_file'(+Spec, +ContextModule, +Options) is det.
 2342%
 2343%   Load the file Spec  into   ContextModule  controlled by Options.
 2344%   This wrapper deals with two cases  before proceeding to the real
 2345%   loader:
 2346%
 2347%       * User hooks based on prolog_load_file/2
 2348%       * The file is already loaded.
 2349
 2350:- dynamic
 2351    '$resolved_source_path_db'/3.                % ?Spec, ?Dialect, ?Path
 2352
 2353'$load_file'(File, Module, Options) :-
 2354    '$error_count'(E0, W0),
 2355    '$load_file_e'(File, Module, Options),
 2356    '$error_count'(E1, W1),
 2357    Errors is E1-E0,
 2358    Warnings is W1-W0,
 2359    (   Errors+Warnings =:= 0
 2360    ->  true
 2361    ;   '$print_message'(silent, load_file_errors(File, Errors, Warnings))
 2362    ).
 2363
 2364'$error_count'(Errors, Warnings) :-
 2365    current_prolog_flag(threads, true),
 2366    !,
 2367    thread_self(Me),
 2368    thread_statistics(Me, errors, Errors),
 2369    thread_statistics(Me, warnings, Warnings).
 2370'$error_count'(Errors, Warnings) :-
 2371    statistics(errors, Errors),
 2372    statistics(warnings, Warnings).
 2373
 2374'$load_file_e'(File, Module, Options) :-
 2375    \+ memberchk(stream(_), Options),
 2376    user:prolog_load_file(Module:File, Options),
 2377    !.
 2378'$load_file_e'(File, Module, Options) :-
 2379    memberchk(stream(_), Options),
 2380    !,
 2381    '$assert_load_context_module'(File, Module, Options),
 2382    '$qdo_load_file'(File, File, Module, Options).
 2383'$load_file_e'(File, Module, Options) :-
 2384    (   '$resolved_source_path'(File, FullFile, Options)
 2385    ->  true
 2386    ;   '$resolve_source_path'(File, FullFile, Options)
 2387    ),
 2388    '$mt_load_file'(File, FullFile, Module, Options).
 2389
 2390%!  '$resolved_source_path'(+File, -FullFile, +Options) is semidet.
 2391%
 2392%   True when File has already been resolved to an absolute path.
 2393
 2394'$resolved_source_path'(File, FullFile, Options) :-
 2395    current_prolog_flag(emulated_dialect, Dialect),
 2396    '$resolved_source_path_db'(File, Dialect, FullFile),
 2397    (   '$source_file_property'(FullFile, from_state, true)
 2398    ;   '$source_file_property'(FullFile, resource, true)
 2399    ;   '$option'(if(If), Options, true),
 2400        '$noload'(If, FullFile, Options)
 2401    ),
 2402    !.
 2403
 2404%!  '$resolve_source_path'(+File, -FullFile, Options) is det.
 2405%
 2406%   Resolve a source file specification to   an absolute path. May throw
 2407%   existence and other errors.
 2408
 2409'$resolve_source_path'(File, FullFile, _Options) :-
 2410    absolute_file_name(File, FullFile,
 2411                       [ file_type(prolog),
 2412                         access(read)
 2413                       ]),
 2414    '$register_resolved_source_path'(File, FullFile).
 2415
 2416
 2417'$register_resolved_source_path'(File, FullFile) :-
 2418    (   compound(File)
 2419    ->  current_prolog_flag(emulated_dialect, Dialect),
 2420        (   '$resolved_source_path_db'(File, Dialect, FullFile)
 2421        ->  true
 2422        ;   asserta('$resolved_source_path_db'(File, Dialect, FullFile))
 2423        )
 2424    ;   true
 2425    ).
 2426
 2427%!  '$translated_source'(+Old, +New) is det.
 2428%
 2429%   Called from loading a QLF state when source files are being renamed.
 2430
 2431:- public '$translated_source'/2. 2432'$translated_source'(Old, New) :-
 2433    forall(retract('$resolved_source_path_db'(File, Dialect, Old)),
 2434           assertz('$resolved_source_path_db'(File, Dialect, New))).
 2435
 2436%!  '$register_resource_file'(+FullFile) is det.
 2437%
 2438%   If we load a file from a resource we   lock  it, so we never have to
 2439%   check the modification again.
 2440
 2441'$register_resource_file'(FullFile) :-
 2442    (   sub_atom(FullFile, 0, _, _, 'res://')
 2443    ->  '$set_source_file'(FullFile, resource, true)
 2444    ;   true
 2445    ).
 2446
 2447%!  '$already_loaded'(+File, +FullFile, +Module, +Options) is det.
 2448%
 2449%   Called if File is already loaded. If  this is a module-file, the
 2450%   module must be imported into the context  Module. If it is not a
 2451%   module file, it must be reloaded.
 2452%
 2453%   @bug    A file may be associated with multiple modules.  How
 2454%           do we find the `main export module'?  Currently there
 2455%           is no good way to find out which module is associated
 2456%           to the file as a result of the first :- module/2 term.
 2457
 2458'$already_loaded'(_File, FullFile, Module, Options) :-
 2459    '$assert_load_context_module'(FullFile, Module, Options),
 2460    '$current_module'(LoadModules, FullFile),
 2461    !,
 2462    (   atom(LoadModules)
 2463    ->  LoadModule = LoadModules
 2464    ;   LoadModules = [LoadModule|_]
 2465    ),
 2466    '$import_from_loaded_module'(LoadModule, Module, Options).
 2467'$already_loaded'(_, _, user, _) :- !.
 2468'$already_loaded'(File, FullFile, Module, Options) :-
 2469    (   '$load_context_module'(FullFile, Module, CtxOptions),
 2470        '$load_ctx_options'(Options, CtxOptions)
 2471    ->  true
 2472    ;   '$load_file'(File, Module, [if(true)|Options])
 2473    ).
 2474
 2475%!  '$mt_load_file'(+File, +FullFile, +Module, +Options) is det.
 2476%
 2477%   Deal with multi-threaded  loading  of   files.  The  thread that
 2478%   wishes to load the thread first will  do so, while other threads
 2479%   will wait until the leader finished and  than act as if the file
 2480%   is already loaded.
 2481%
 2482%   Synchronisation is handled using  a   message  queue that exists
 2483%   while the file is being loaded.   This synchronisation relies on
 2484%   the fact that thread_get_message/1 throws  an existence_error if
 2485%   the message queue  is  destroyed.  This   is  hacky.  Events  or
 2486%   condition variables would have made a cleaner design.
 2487
 2488:- dynamic
 2489    '$loading_file'/3.              % File, Queue, Thread
 2490:- volatile
 2491    '$loading_file'/3. 2492
 2493'$mt_load_file'(File, FullFile, Module, Options) :-
 2494    current_prolog_flag(threads, true),
 2495    !,
 2496    sig_atomic(setup_call_cleanup(
 2497                   with_mutex('$load_file',
 2498                              '$mt_start_load'(FullFile, Loading, Options)),
 2499                   '$mt_do_load'(Loading, File, FullFile, Module, Options),
 2500                   '$mt_end_load'(Loading))).
 2501'$mt_load_file'(File, FullFile, Module, Options) :-
 2502    '$option'(if(If), Options, true),
 2503    '$noload'(If, FullFile, Options),
 2504    !,
 2505    '$already_loaded'(File, FullFile, Module, Options).
 2506'$mt_load_file'(File, FullFile, Module, Options) :-
 2507    sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)).
 2508
 2509'$mt_start_load'(FullFile, queue(Queue), _) :-
 2510    '$loading_file'(FullFile, Queue, LoadThread),
 2511    \+ thread_self(LoadThread),
 2512    !.
 2513'$mt_start_load'(FullFile, already_loaded, Options) :-
 2514    '$option'(if(If), Options, true),
 2515    '$noload'(If, FullFile, Options),
 2516    !.
 2517'$mt_start_load'(FullFile, Ref, _) :-
 2518    thread_self(Me),
 2519    message_queue_create(Queue),
 2520    assertz('$loading_file'(FullFile, Queue, Me), Ref).
 2521
 2522'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
 2523    !,
 2524    catch(thread_get_message(Queue, _), error(_,_), true),
 2525    '$already_loaded'(File, FullFile, Module, Options).
 2526'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
 2527    !,
 2528    '$already_loaded'(File, FullFile, Module, Options).
 2529'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
 2530    '$assert_load_context_module'(FullFile, Module, Options),
 2531    '$qdo_load_file'(File, FullFile, Module, Options).
 2532
 2533'$mt_end_load'(queue(_)) :- !.
 2534'$mt_end_load'(already_loaded) :- !.
 2535'$mt_end_load'(Ref) :-
 2536    clause('$loading_file'(_, Queue, _), _, Ref),
 2537    erase(Ref),
 2538    thread_send_message(Queue, done),
 2539    message_queue_destroy(Queue).
 2540
 2541
 2542%!  '$qdo_load_file'(+Spec, +FullFile, +ContextModule, +Options) is det.
 2543%
 2544%   Switch to qcompile mode if requested by the option '$qlf'(+Out)
 2545
 2546'$qdo_load_file'(File, FullFile, Module, Options) :-
 2547    '$qdo_load_file2'(File, FullFile, Module, Action, Options),
 2548    '$register_resource_file'(FullFile),
 2549    '$run_initialization'(FullFile, Action, Options).
 2550
 2551'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
 2552    memberchk('$qlf'(QlfOut), Options),
 2553    '$stage_file'(QlfOut, StageQlf),
 2554    !,
 2555    setup_call_catcher_cleanup(
 2556        '$qstart'(StageQlf, Module, State),
 2557        '$do_load_file'(File, FullFile, Module, Action, Options),
 2558        Catcher,
 2559        '$qend'(State, Catcher, StageQlf, QlfOut)).
 2560'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
 2561    '$do_load_file'(File, FullFile, Module, Action, Options).
 2562
 2563'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
 2564    '$qlf_open'(Qlf),
 2565    '$compilation_mode'(OldMode, qlf),
 2566    '$set_source_module'(OldModule, Module).
 2567
 2568'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :-
 2569    '$set_source_module'(_, OldModule),
 2570    '$set_compilation_mode'(OldMode),
 2571    '$qlf_close',
 2572    '$install_staged_file'(Catcher, StageQlf, QlfOut, warn).
 2573
 2574'$set_source_module'(OldModule, Module) :-
 2575    '$current_source_module'(OldModule),
 2576    '$set_source_module'(Module).
 2577
 2578%!  '$do_load_file'(+Spec, +FullFile, +ContextModule,
 2579%!                  -Action, +Options) is det.
 2580%
 2581%   Perform the actual loading.
 2582
 2583'$do_load_file'(File, FullFile, Module, Action, Options) :-
 2584    '$option'(derived_from(DerivedFrom), Options, -),
 2585    '$register_derived_source'(FullFile, DerivedFrom),
 2586    '$qlf_file'(File, FullFile, Absolute, Mode, Options),
 2587    (   Mode == qcompile
 2588    ->  qcompile(Module:File, Options)
 2589    ;   '$do_load_file_2'(File, Absolute, Module, Action, Options)
 2590    ).
 2591
 2592'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
 2593    '$source_file_property'(Absolute, number_of_clauses, OldClauses),
 2594    statistics(cputime, OldTime),
 2595
 2596    '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
 2597                  Options),
 2598
 2599    '$compilation_level'(Level),
 2600    '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
 2601    '$print_message'(StartMsgLevel,
 2602                     load_file(start(Level,
 2603                                     file(File, Absolute)))),
 2604
 2605    (   memberchk(stream(FromStream), Options)
 2606    ->  Input = stream
 2607    ;   Input = source
 2608    ),
 2609
 2610    (   Input == stream,
 2611        (   '$option'(format(qlf), Options, source)
 2612        ->  set_stream(FromStream, file_name(Absolute)),
 2613            '$qload_stream'(FromStream, Module, Action, LM, Options)
 2614        ;   '$consult_file'(stream(Absolute, FromStream, []),
 2615                            Module, Action, LM, Options)
 2616        )
 2617    ->  true
 2618    ;   Input == source,
 2619        file_name_extension(_, Ext, Absolute),
 2620        (   user:prolog_file_type(Ext, qlf),
 2621            E = error(_,_),
 2622            catch('$qload_file'(Absolute, Module, Action, LM, Options),
 2623                  E,
 2624                  print_message(warning, E))
 2625        ->  true
 2626        ;   '$consult_file'(Absolute, Module, Action, LM, Options)
 2627        )
 2628    ->  true
 2629    ;   '$print_message'(error, load_file(failed(File))),
 2630        fail
 2631    ),
 2632
 2633    '$import_from_loaded_module'(LM, Module, Options),
 2634
 2635    '$source_file_property'(Absolute, number_of_clauses, NewClauses),
 2636    statistics(cputime, Time),
 2637    ClausesCreated is NewClauses - OldClauses,
 2638    TimeUsed is Time - OldTime,
 2639
 2640    '$print_message'(DoneMsgLevel,
 2641                     load_file(done(Level,
 2642                                    file(File, Absolute),
 2643                                    Action,
 2644                                    LM,
 2645                                    TimeUsed,
 2646                                    ClausesCreated))),
 2647
 2648    '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef).
 2649
 2650'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
 2651              Options) :-
 2652    '$save_file_scoped_flags'(ScopedFlags),
 2653    '$set_sandboxed_load'(Options, OldSandBoxed),
 2654    '$set_verbose_load'(Options, OldVerbose),
 2655    '$set_optimise_load'(Options),
 2656    '$update_autoload_level'(Options, OldAutoLevel),
 2657    '$set_no_xref'(OldXRef).
 2658
 2659'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :-
 2660    '$set_autoload_level'(OldAutoLevel),
 2661    set_prolog_flag(xref, OldXRef),
 2662    set_prolog_flag(verbose_load, OldVerbose),
 2663    set_prolog_flag(sandboxed_load, OldSandBoxed),
 2664    '$restore_file_scoped_flags'(ScopedFlags).
 2665
 2666
 2667%!  '$save_file_scoped_flags'(-State) is det.
 2668%!  '$restore_file_scoped_flags'(-State) is det.
 2669%
 2670%   Save/restore flags that are scoped to a compilation unit.
 2671
 2672'$save_file_scoped_flags'(State) :-
 2673    current_predicate(findall/3),          % Not when doing boot compile
 2674    !,
 2675    findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
 2676'$save_file_scoped_flags'([]).
 2677
 2678'$save_file_scoped_flag'(Flag-Value) :-
 2679    '$file_scoped_flag'(Flag, Default),
 2680    (   current_prolog_flag(Flag, Value)
 2681    ->  true
 2682    ;   Value = Default
 2683    ).
 2684
 2685'$file_scoped_flag'(generate_debug_info, true).
 2686'$file_scoped_flag'(optimise,            false).
 2687'$file_scoped_flag'(xref,                false).
 2688
 2689'$restore_file_scoped_flags'([]).
 2690'$restore_file_scoped_flags'([Flag-Value|T]) :-
 2691    set_prolog_flag(Flag, Value),
 2692    '$restore_file_scoped_flags'(T).
 2693
 2694
 2695%!  '$import_from_loaded_module'(LoadedModule, Module, Options) is det.
 2696%
 2697%   Import public predicates from LoadedModule into Module
 2698
 2699'$import_from_loaded_module'(LoadedModule, Module, Options) :-
 2700    LoadedModule \== Module,
 2701    atom(LoadedModule),
 2702    !,
 2703    '$option'(imports(Import), Options, all),
 2704    '$option'(reexport(Reexport), Options, false),
 2705    '$import_list'(Module, LoadedModule, Import, Reexport).
 2706'$import_from_loaded_module'(_, _, _).
 2707
 2708
 2709%!  '$set_verbose_load'(+Options, -Old) is det.
 2710%
 2711%   Set the =verbose_load= flag according to   Options and unify Old
 2712%   with the old value.
 2713
 2714'$set_verbose_load'(Options, Old) :-
 2715    current_prolog_flag(verbose_load, Old),
 2716    (   memberchk(silent(Silent), Options)
 2717    ->  (   '$negate'(Silent, Level0)
 2718        ->  '$load_msg_compat'(Level0, Level)
 2719        ;   Level = Silent
 2720        ),
 2721        set_prolog_flag(verbose_load, Level)
 2722    ;   true
 2723    ).
 2724
 2725'$negate'(true, false).
 2726'$negate'(false, true).
 2727
 2728%!  '$set_sandboxed_load'(+Options, -Old) is det.
 2729%
 2730%   Update the Prolog flag  =sandboxed_load=   from  Options. Old is
 2731%   unified with the old flag.
 2732%
 2733%   @error permission_error(leave, sandbox, -)
 2734
 2735'$set_sandboxed_load'(Options, Old) :-
 2736    current_prolog_flag(sandboxed_load, Old),
 2737    (   memberchk(sandboxed(SandBoxed), Options),
 2738        '$enter_sandboxed'(Old, SandBoxed, New),
 2739        New \== Old
 2740    ->  set_prolog_flag(sandboxed_load, New)
 2741    ;   true
 2742    ).
 2743
 2744'$enter_sandboxed'(Old, New, SandBoxed) :-
 2745    (   Old == false, New == true
 2746    ->  SandBoxed = true,
 2747        '$ensure_loaded_library_sandbox'
 2748    ;   Old == true, New == false
 2749    ->  throw(error(permission_error(leave, sandbox, -), _))
 2750    ;   SandBoxed = Old
 2751    ).
 2752'$enter_sandboxed'(false, true, true).
 2753
 2754'$ensure_loaded_library_sandbox' :-
 2755    source_file_property(library(sandbox), module(sandbox)),
 2756    !.
 2757'$ensure_loaded_library_sandbox' :-
 2758    load_files(library(sandbox), [if(not_loaded), silent(true)]).
 2759
 2760'$set_optimise_load'(Options) :-
 2761    (   '$option'(optimise(Optimise), Options)
 2762    ->  set_prolog_flag(optimise, Optimise)
 2763    ;   true
 2764    ).
 2765
 2766'$set_no_xref'(OldXRef) :-
 2767    (   current_prolog_flag(xref, OldXRef)
 2768    ->  true
 2769    ;   OldXRef = false
 2770    ),
 2771    set_prolog_flag(xref, false).
 2772
 2773
 2774%!  '$update_autoload_level'(+Options, -OldLevel)
 2775%
 2776%   Update the '$autoload_nesting' and return the old value.
 2777
 2778:- thread_local
 2779    '$autoload_nesting'/1. 2780
 2781'$update_autoload_level'(Options, AutoLevel) :-
 2782    '$option'(autoload(Autoload), Options, false),
 2783    (   '$autoload_nesting'(CurrentLevel)
 2784    ->  AutoLevel = CurrentLevel
 2785    ;   AutoLevel = 0
 2786    ),
 2787    (   Autoload == false
 2788    ->  true
 2789    ;   NewLevel is AutoLevel + 1,
 2790        '$set_autoload_level'(NewLevel)
 2791    ).
 2792
 2793'$set_autoload_level'(New) :-
 2794    retractall('$autoload_nesting'(_)),
 2795    asserta('$autoload_nesting'(New)).
 2796
 2797
 2798%!  '$print_message'(+Level, +Term) is det.
 2799%
 2800%   As print_message/2, but deal with  the   fact  that  the message
 2801%   system might not yet be loaded.
 2802
 2803'$print_message'(Level, Term) :-
 2804    current_predicate(system:print_message/2),
 2805    !,
 2806    print_message(Level, Term).
 2807'$print_message'(warning, Term) :-
 2808    source_location(File, Line),
 2809    !,
 2810    format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
 2811'$print_message'(error, Term) :-
 2812    !,
 2813    source_location(File, Line),
 2814    !,
 2815    format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
 2816'$print_message'(_Level, _Term).
 2817
 2818'$print_message_fail'(E) :-
 2819    '$print_message'(error, E),
 2820    fail.
 2821
 2822%!  '$consult_file'(+Path, +Module, -Action, -LoadedIn, +Options)
 2823%
 2824%   Called  from  '$do_load_file'/4  using  the   goal  returned  by
 2825%   '$consult_goal'/2. This means that the  calling conventions must
 2826%   be kept synchronous with '$qload_file'/6.
 2827
 2828'$consult_file'(Absolute, Module, What, LM, Options) :-
 2829    '$current_source_module'(Module),   % same module
 2830    !,
 2831    '$consult_file_2'(Absolute, Module, What, LM, Options).
 2832'$consult_file'(Absolute, Module, What, LM, Options) :-
 2833    '$set_source_module'(OldModule, Module),
 2834    '$ifcompiling'('$qlf_start_sub_module'(Module)),
 2835    '$consult_file_2'(Absolute, Module, What, LM, Options),
 2836    '$ifcompiling'('$qlf_end_part'),
 2837    '$set_source_module'(OldModule).
 2838
 2839'$consult_file_2'(Absolute, Module, What, LM, Options) :-
 2840    '$set_source_module'(OldModule, Module),
 2841    '$load_id'(Absolute, Id, Modified, Options),
 2842    '$compile_type'(What),
 2843    '$save_lex_state'(LexState, Options),
 2844    '$set_dialect'(Options),
 2845    setup_call_cleanup(
 2846        '$start_consult'(Id, Modified),
 2847        '$load_file'(Absolute, Id, LM, Options),
 2848        '$end_consult'(Id, LexState, OldModule)).
 2849
 2850'$end_consult'(Id, LexState, OldModule) :-
 2851    '$end_consult'(Id),
 2852    '$restore_lex_state'(LexState),
 2853    '$set_source_module'(OldModule).
 2854
 2855
 2856:- create_prolog_flag(emulated_dialect, swi, [type(atom)]). 2857
 2858%!  '$save_lex_state'(-LexState, +Options) is det.
 2859
 2860'$save_lex_state'(State, Options) :-
 2861    memberchk(scope_settings(false), Options),
 2862    !,
 2863    State = (-).
 2864'$save_lex_state'(lexstate(Style, Dialect), _) :-
 2865    '$style_check'(Style, Style),
 2866    current_prolog_flag(emulated_dialect, Dialect).
 2867
 2868'$restore_lex_state'(-) :- !.
 2869'$restore_lex_state'(lexstate(Style, Dialect)) :-
 2870    '$style_check'(_, Style),
 2871    set_prolog_flag(emulated_dialect, Dialect).
 2872
 2873'$set_dialect'(Options) :-
 2874    memberchk(dialect(Dialect), Options),
 2875    !,
 2876    '$expects_dialect'(Dialect).
 2877'$set_dialect'(_).
 2878
 2879'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
 2880    !,
 2881    '$modified_id'(Id, Modified, Options).
 2882'$load_id'(Id, Id, Modified, Options) :-
 2883    '$modified_id'(Id, Modified, Options).
 2884
 2885'$modified_id'(_, Modified, Options) :-
 2886    '$option'(modified(Stamp), Options, Def),
 2887    Stamp \== Def,
 2888    !,
 2889    Modified = Stamp.
 2890'$modified_id'(Id, Modified, _) :-
 2891    catch(time_file(Id, Modified),
 2892          error(_, _),
 2893          fail),
 2894    !.
 2895'$modified_id'(_, 0.0, _).
 2896
 2897
 2898'$compile_type'(What) :-
 2899    '$compilation_mode'(How),
 2900    (   How == database
 2901    ->  What = compiled
 2902    ;   How == qlf
 2903    ->  What = '*qcompiled*'
 2904    ;   What = 'boot compiled'
 2905    ).
 2906
 2907%!  '$assert_load_context_module'(+File, -Module, -Options)
 2908%
 2909%   Record the module a file was loaded from (see make/0). The first
 2910%   clause deals with loading from  another   file.  On reload, this
 2911%   clause will be discarded by  $start_consult/1. The second clause
 2912%   deals with reload from the toplevel.   Here  we avoid creating a
 2913%   duplicate dynamic (i.e., not related to a source) clause.
 2914
 2915:- dynamic
 2916    '$load_context_module'/3. 2917:- multifile
 2918    '$load_context_module'/3. 2919
 2920'$assert_load_context_module'(_, _, Options) :-
 2921    memberchk(register(false), Options),
 2922    !.
 2923'$assert_load_context_module'(File, Module, Options) :-
 2924    source_location(FromFile, Line),
 2925    !,
 2926    '$master_file'(FromFile, MasterFile),
 2927    '$check_load_non_module'(File, Module),
 2928    '$add_dialect'(Options, Options1),
 2929    '$load_ctx_options'(Options1, Options2),
 2930    '$store_admin_clause'(
 2931        system:'$load_context_module'(File, Module, Options2),
 2932        _Layout, MasterFile, FromFile:Line).
 2933'$assert_load_context_module'(File, Module, Options) :-
 2934    '$check_load_non_module'(File, Module),
 2935    '$add_dialect'(Options, Options1),
 2936    '$load_ctx_options'(Options1, Options2),
 2937    (   clause('$load_context_module'(File, Module, _), true, Ref),
 2938        \+ clause_property(Ref, file(_)),
 2939        erase(Ref)
 2940    ->  true
 2941    ;   true
 2942    ),
 2943    assertz('$load_context_module'(File, Module, Options2)).
 2944
 2945'$add_dialect'(Options0, Options) :-
 2946    current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
 2947    !,
 2948    Options = [dialect(Dialect)|Options0].
 2949'$add_dialect'(Options, Options).
 2950
 2951%!  '$load_ctx_options'(+Options, -CtxOptions) is det.
 2952%
 2953%   Select the load options that  determine   the  load semantics to
 2954%   perform a proper reload. Delete the others.
 2955
 2956'$load_ctx_options'(Options, CtxOptions) :-
 2957    '$load_ctx_options2'(Options, CtxOptions0),
 2958    sort(CtxOptions0, CtxOptions).
 2959
 2960'$load_ctx_options2'([], []).
 2961'$load_ctx_options2'([H|T0], [H|T]) :-
 2962    '$load_ctx_option'(H),
 2963    !,
 2964    '$load_ctx_options2'(T0, T).
 2965'$load_ctx_options2'([_|T0], T) :-
 2966    '$load_ctx_options2'(T0, T).
 2967
 2968'$load_ctx_option'(derived_from(_)).
 2969'$load_ctx_option'(dialect(_)).
 2970'$load_ctx_option'(encoding(_)).
 2971'$load_ctx_option'(imports(_)).
 2972'$load_ctx_option'(reexport(_)).
 2973
 2974
 2975%!  '$check_load_non_module'(+File) is det.
 2976%
 2977%   Test  that  a  non-module  file  is  not  loaded  into  multiple
 2978%   contexts.
 2979
 2980'$check_load_non_module'(File, _) :-
 2981    '$current_module'(_, File),
 2982    !.          % File is a module file
 2983'$check_load_non_module'(File, Module) :-
 2984    '$load_context_module'(File, OldModule, _),
 2985    Module \== OldModule,
 2986    !,
 2987    format(atom(Msg),
 2988           'Non-module file already loaded into module ~w; \c
 2989               trying to load into ~w',
 2990           [OldModule, Module]),
 2991    throw(error(permission_error(load, source, File),
 2992                context(load_files/2, Msg))).
 2993'$check_load_non_module'(_, _).
 2994
 2995%!  '$load_file'(+Path, +Id, -Module, +Options)
 2996%
 2997%   '$load_file'/4 does the actual loading.
 2998%
 2999%   state(FirstTerm:boolean,
 3000%         Module:atom,
 3001%         AtEnd:atom,
 3002%         Stop:boolean,
 3003%         Id:atom,
 3004%         Dialect:atom)
 3005
 3006'$load_file'(Path, Id, Module, Options) :-
 3007    State = state(true, _, true, false, Id, -),
 3008    (   '$source_term'(Path, _Read, _Layout, Term, Layout,
 3009                       _Stream, Options),
 3010        '$valid_term'(Term),
 3011        (   arg(1, State, true)
 3012        ->  '$first_term'(Term, Layout, Id, State, Options),
 3013            nb_setarg(1, State, false)
 3014        ;   '$compile_term'(Term, Layout, Id)
 3015        ),
 3016        arg(4, State, true)
 3017    ;   '$fixup_reconsult'(Id),
 3018        '$end_load_file'(State)
 3019    ),
 3020    !,
 3021    arg(2, State, Module).
 3022
 3023'$valid_term'(Var) :-
 3024    var(Var),
 3025    !,
 3026    print_message(error, error(instantiation_error, _)).
 3027'$valid_term'(Term) :-
 3028    Term \== [].
 3029
 3030'$end_load_file'(State) :-
 3031    arg(1, State, true),           % empty file
 3032    !,
 3033    nb_setarg(2, State, Module),
 3034    arg(5, State, Id),
 3035    '$current_source_module'(Module),
 3036    '$ifcompiling'('$qlf_start_file'(Id)),
 3037    '$ifcompiling'('$qlf_end_part').
 3038'$end_load_file'(State) :-
 3039    arg(3, State, End),
 3040    '$end_load_file'(End, State).
 3041
 3042'$end_load_file'(true, _).
 3043'$end_load_file'(end_module, State) :-
 3044    arg(2, State, Module),
 3045    '$check_export'(Module),
 3046    '$ifcompiling'('$qlf_end_part').
 3047'$end_load_file'(end_non_module, _State) :-
 3048    '$ifcompiling'('$qlf_end_part').
 3049
 3050
 3051'$first_term'(?-(Directive), Layout, Id, State, Options) :-
 3052    !,
 3053    '$first_term'(:-(Directive), Layout, Id, State, Options).
 3054'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
 3055    nonvar(Directive),
 3056    (   (   Directive = module(Name, Public)
 3057        ->  Imports = []
 3058        ;   Directive = module(Name, Public, Imports)
 3059        )
 3060    ->  !,
 3061        '$module_name'(Name, Id, Module, Options),
 3062        '$start_module'(Module, Public, State, Options),
 3063        '$module3'(Imports)
 3064    ;   Directive = expects_dialect(Dialect)
 3065    ->  !,
 3066        '$set_dialect'(Dialect, State),
 3067        fail                        % Still consider next term as first
 3068    ).
 3069'$first_term'(Term, Layout, Id, State, Options) :-
 3070    '$start_non_module'(Id, Term, State, Options),
 3071    '$compile_term'(Term, Layout, Id).
 3072
 3073'$compile_term'(Term, Layout, Id) :-
 3074    '$compile_term'(Term, Layout, Id, -).
 3075
 3076'$compile_term'(Var, _Layout, _Id, _Src) :-
 3077    var(Var),
 3078    !,
 3079    '$instantiation_error'(Var).
 3080'$compile_term'((?-Directive), _Layout, Id, _) :-
 3081    !,
 3082    '$execute_directive'(Directive, Id).
 3083'$compile_term'((:-Directive), _Layout, Id, _) :-
 3084    !,
 3085    '$execute_directive'(Directive, Id).
 3086'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :-
 3087    !,
 3088    '$compile_term'(Term, Layout, Id, File:Line).
 3089'$compile_term'(Clause, Layout, Id, SrcLoc) :-
 3090    E = error(_,_),
 3091    catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
 3092          '$print_message'(error, E)).
 3093
 3094'$start_non_module'(_Id, Term, _State, Options) :-
 3095    '$option'(must_be_module(true), Options, false),
 3096    !,
 3097    '$domain_error'(module_header, Term).
 3098'$start_non_module'(Id, _Term, State, _Options) :-
 3099    '$current_source_module'(Module),
 3100    '$ifcompiling'('$qlf_start_file'(Id)),
 3101    '$qset_dialect'(State),
 3102    nb_setarg(2, State, Module),
 3103    nb_setarg(3, State, end_non_module).
 3104
 3105%!  '$set_dialect'(+Dialect, +State)
 3106%
 3107%   Sets the expected dialect. This is difficult if we are compiling
 3108%   a .qlf file using qcompile/1 because   the file is already open,
 3109%   while we are looking for the first term to decide wether this is
 3110%   a module or not. We save the   dialect  and set it after opening
 3111%   the file or module.
 3112%
 3113%   Note that expects_dialect/1 itself may   be  autoloaded from the
 3114%   library.
 3115
 3116'$set_dialect'(Dialect, State) :-
 3117    '$compilation_mode'(qlf, database),
 3118    !,
 3119    '$expects_dialect'(Dialect),
 3120    '$compilation_mode'(_, qlf),
 3121    nb_setarg(6, State, Dialect).
 3122'$set_dialect'(Dialect, _) :-
 3123    '$expects_dialect'(Dialect).
 3124
 3125'$qset_dialect'(State) :-
 3126    '$compilation_mode'(qlf),
 3127    arg(6, State, Dialect), Dialect \== (-),
 3128    !,
 3129    '$add_directive_wic'('$expects_dialect'(Dialect)).
 3130'$qset_dialect'(_).
 3131
 3132'$expects_dialect'(Dialect) :-
 3133    Dialect == swi,
 3134    !,
 3135    set_prolog_flag(emulated_dialect, Dialect).
 3136'$expects_dialect'(Dialect) :-
 3137    current_predicate(expects_dialect/1),
 3138    !,
 3139    expects_dialect(Dialect).
 3140'$expects_dialect'(Dialect) :-
 3141    use_module(library(dialect), [expects_dialect/1]),
 3142    expects_dialect(Dialect).
 3143
 3144
 3145                 /*******************************
 3146                 *           MODULES            *
 3147                 *******************************/
 3148
 3149'$start_module'(Module, _Public, State, _Options) :-
 3150    '$current_module'(Module, OldFile),
 3151    source_location(File, _Line),
 3152    OldFile \== File, OldFile \== [],
 3153    same_file(OldFile, File),
 3154    !,
 3155    nb_setarg(2, State, Module),
 3156    nb_setarg(4, State, true).      % Stop processing
 3157'$start_module'(Module, Public, State, Options) :-
 3158    arg(5, State, File),
 3159    nb_setarg(2, State, Module),
 3160    source_location(_File, Line),
 3161    '$option'(redefine_module(Action), Options, false),
 3162    '$module_class'(File, Class, Super),
 3163    '$reset_dialect'(File, Class),
 3164    '$redefine_module'(Module, File, Action),
 3165    '$declare_module'(Module, Class, Super, File, Line, false),
 3166    '$export_list'(Public, Module, Ops),
 3167    '$ifcompiling'('$qlf_start_module'(Module)),
 3168    '$export_ops'(Ops, Module, File),
 3169    '$qset_dialect'(State),
 3170    nb_setarg(3, State, end_module).
 3171
 3172%!  '$reset_dialect'(+File, +Class) is det.
 3173%
 3174%   Load .pl files from the SWI-Prolog distribution _always_ in
 3175%   `swi` dialect.
 3176
 3177'$reset_dialect'(File, library) :-
 3178    file_name_extension(_, pl, File),
 3179    !,
 3180    set_prolog_flag(emulated_dialect, swi).
 3181'$reset_dialect'(_, _).
 3182
 3183
 3184%!  '$module3'(+Spec) is det.
 3185%
 3186%   Handle the 3th argument of a module declartion.
 3187
 3188'$module3'(Var) :-
 3189    var(Var),
 3190    !,
 3191    '$instantiation_error'(Var).
 3192'$module3'([]) :- !.
 3193'$module3'([H|T]) :-
 3194    !,
 3195    '$module3'(H),
 3196    '$module3'(T).
 3197'$module3'(Id) :-
 3198    use_module(library(dialect/Id)).
 3199
 3200%!  '$module_name'(?Name, +Id, -Module, +Options) is semidet.
 3201%
 3202%   Determine the module name.  There are some cases:
 3203%
 3204%     - Option module(Module) is given.  In that case, use this
 3205%       module and if Module is the load context, ignore the module
 3206%       header.
 3207%     - The initial name is unbound.  Use the base name of the
 3208%       source identifier (normally the file name).  Compatibility
 3209%       to Ciao.  This might change; I think it is wiser to use
 3210%       the full unique source identifier.
 3211
 3212'$module_name'(_, _, Module, Options) :-
 3213    '$option'(module(Module), Options),
 3214    !,
 3215    '$current_source_module'(Context),
 3216    Context \== Module.                     % cause '$first_term'/5 to fail.
 3217'$module_name'(Var, Id, Module, Options) :-
 3218    var(Var),
 3219    !,
 3220    file_base_name(Id, File),
 3221    file_name_extension(Var, _, File),
 3222    '$module_name'(Var, Id, Module, Options).
 3223'$module_name'(Reserved, _, _, _) :-
 3224    '$reserved_module'(Reserved),
 3225    !,
 3226    throw(error(permission_error(load, module, Reserved), _)).
 3227'$module_name'(Module, _Id, Module, _).
 3228
 3229
 3230'$reserved_module'(system).
 3231'$reserved_module'(user).
 3232
 3233
 3234%!  '$redefine_module'(+Module, +File, -Redefine)
 3235
 3236'$redefine_module'(_Module, _, false) :- !.
 3237'$redefine_module'(Module, File, true) :-
 3238    !,
 3239    (   module_property(Module, file(OldFile)),
 3240        File \== OldFile
 3241    ->  unload_file(OldFile)
 3242    ;   true
 3243    ).
 3244'$redefine_module'(Module, File, ask) :-
 3245    (   stream_property(user_input, tty(true)),
 3246        module_property(Module, file(OldFile)),
 3247        File \== OldFile,
 3248        '$rdef_response'(Module, OldFile, File, true)
 3249    ->  '$redefine_module'(Module, File, true)
 3250    ;   true
 3251    ).
 3252
 3253'$rdef_response'(Module, OldFile, File, Ok) :-
 3254    repeat,
 3255    print_message(query, redefine_module(Module, OldFile, File)),
 3256    get_single_char(Char),
 3257    '$rdef_response'(Char, Ok0),
 3258    !,
 3259    Ok = Ok0.
 3260
 3261'$rdef_response'(Char, true) :-
 3262    memberchk(Char, `yY`),
 3263    format(user_error, 'yes~n', []).
 3264'$rdef_response'(Char, false) :-
 3265    memberchk(Char, `nN`),
 3266    format(user_error, 'no~n', []).
 3267'$rdef_response'(Char, _) :-
 3268    memberchk(Char, `a`),
 3269    format(user_error, 'abort~n', []),
 3270    abort.
 3271'$rdef_response'(_, _) :-
 3272    print_message(help, redefine_module_reply),
 3273    fail.
 3274
 3275
 3276%!  '$module_class'(+File, -Class, -Super) is det.
 3277%
 3278%   Determine  the  file  class  and  initial  module  from  which  File
 3279%   inherits. All boot and library modules  as   well  as  the -F script
 3280%   files inherit from `system`, while all   normal user modules inherit
 3281%   from `user`.
 3282
 3283'$module_class'(File, Class, system) :-
 3284    current_prolog_flag(home, Home),
 3285    sub_atom(File, 0, Len, _, Home),
 3286    (   sub_atom(File, Len, _, _, '/boot/')
 3287    ->  Class = system
 3288    ;   '$lib_prefix'(Prefix),
 3289        sub_atom(File, Len, _, _, Prefix)
 3290    ->  Class = library
 3291    ;   file_directory_name(File, Home),
 3292        file_name_extension(_, rc, File)
 3293    ->  Class = library
 3294    ),
 3295    !.
 3296'$module_class'(_, user, user).
 3297
 3298'$lib_prefix'('/library').
 3299'$lib_prefix'('/xpce/prolog/').
 3300
 3301'$check_export'(Module) :-
 3302    '$undefined_export'(Module, UndefList),
 3303    (   '$member'(Undef, UndefList),
 3304        strip_module(Undef, _, Local),
 3305        print_message(error,
 3306                      undefined_export(Module, Local)),
 3307        fail
 3308    ;   true
 3309    ).
 3310
 3311
 3312%!  '$import_list'(+TargetModule, +FromModule, +Import, +Reexport) is det.
 3313%
 3314%   Import from FromModule to TargetModule. Import  is one of =all=,
 3315%   a list of optionally  mapped  predicate   indicators  or  a term
 3316%   except(Import).
 3317
 3318'$import_list'(_, _, Var, _) :-
 3319    var(Var),
 3320    !,
 3321    throw(error(instantitation_error, _)).
 3322'$import_list'(Target, Source, all, Reexport) :-
 3323    !,
 3324    '$exported_ops'(Source, Import, Predicates),
 3325    '$module_property'(Source, exports(Predicates)),
 3326    '$import_all'(Import, Target, Source, Reexport, weak).
 3327'$import_list'(Target, Source, except(Spec), Reexport) :-
 3328    !,
 3329    '$exported_ops'(Source, Export, Predicates),
 3330    '$module_property'(Source, exports(Predicates)),
 3331    (   is_list(Spec)
 3332    ->  true
 3333    ;   throw(error(type_error(list, Spec), _))
 3334    ),
 3335    '$import_except'(Spec, Export, Import),
 3336    '$import_all'(Import, Target, Source, Reexport, weak).
 3337'$import_list'(Target, Source, Import, Reexport) :-
 3338    !,
 3339    is_list(Import),
 3340    !,
 3341    '$import_all'(Import, Target, Source, Reexport, strong).
 3342'$import_list'(_, _, Import, _) :-
 3343    throw(error(type_error(import_specifier, Import))).
 3344
 3345
 3346'$import_except'([], List, List).
 3347'$import_except'([H|T], List0, List) :-
 3348    '$import_except_1'(H, List0, List1),
 3349    '$import_except'(T, List1, List).
 3350
 3351'$import_except_1'(Var, _, _) :-
 3352    var(Var),
 3353    !,
 3354    throw(error(instantitation_error, _)).
 3355'$import_except_1'(PI as N, List0, List) :-
 3356    '$pi'(PI), atom(N),
 3357    !,
 3358    '$canonical_pi'(PI, CPI),
 3359    '$import_as'(CPI, N, List0, List).
 3360'$import_except_1'(op(P,A,N), List0, List) :-
 3361    !,
 3362    '$remove_ops'(List0, op(P,A,N), List).
 3363'$import_except_1'(PI, List0, List) :-
 3364    '$pi'(PI),
 3365    !,
 3366    '$canonical_pi'(PI, CPI),
 3367    '$select'(P, List0, List),
 3368    '$canonical_pi'(CPI, P),
 3369    !.
 3370'$import_except_1'(Except, _, _) :-
 3371    throw(error(type_error(import_specifier, Except), _)).
 3372
 3373'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
 3374    '$canonical_pi'(PI2, CPI),
 3375    !.
 3376'$import_as'(PI, N, [H|T0], [H|T]) :-
 3377    !,
 3378    '$import_as'(PI, N, T0, T).
 3379'$import_as'(PI, _, _, _) :-
 3380    throw(error(existence_error(export, PI), _)).
 3381
 3382'$pi'(N/A) :- atom(N), integer(A), !.
 3383'$pi'(N//A) :- atom(N), integer(A).
 3384
 3385'$canonical_pi'(N//A0, N/A) :-
 3386    A is A0 + 2.
 3387'$canonical_pi'(PI, PI).
 3388
 3389'$remove_ops'([], _, []).
 3390'$remove_ops'([Op|T0], Pattern, T) :-
 3391    subsumes_term(Pattern, Op),
 3392    !,
 3393    '$remove_ops'(T0, Pattern, T).
 3394'$remove_ops'([H|T0], Pattern, [H|T]) :-
 3395    '$remove_ops'(T0, Pattern, T).
 3396
 3397
 3398%!  '$import_all'(+Import, +Context, +Source, +Reexport, +Strength)
 3399
 3400'$import_all'(Import, Context, Source, Reexport, Strength) :-
 3401    '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
 3402    (   Reexport == true,
 3403        (   '$list_to_conj'(Imported, Conj)
 3404        ->  export(Context:Conj),
 3405            '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
 3406        ;   true
 3407        ),
 3408        source_location(File, _Line),
 3409        '$export_ops'(ImpOps, Context, File)
 3410    ;   true
 3411    ).
 3412
 3413%!  '$import_all2'(+Imports, +Context, +Source, -Imported, -ImpOps, +Strength)
 3414
 3415'$import_all2'([], _, _, [], [], _).
 3416'$import_all2'([PI as NewName|Rest], Context, Source,
 3417               [NewName/Arity|Imported], ImpOps, Strength) :-
 3418    !,
 3419    '$canonical_pi'(PI, Name/Arity),
 3420    length(Args, Arity),
 3421    Head =.. [Name|Args],
 3422    NewHead =.. [NewName|Args],
 3423    (   '$get_predicate_attribute'(Source:Head, transparent, 1)
 3424    ->  '$set_predicate_attribute'(Context:NewHead, transparent, true)
 3425    ;   true
 3426    ),
 3427    (   source_location(File, Line)
 3428    ->  E = error(_,_),
 3429        catch('$store_admin_clause'((NewHead :- Source:Head),
 3430                                    _Layout, File, File:Line),
 3431              E, '$print_message'(error, E))
 3432    ;   assertz((NewHead :- !, Source:Head)) % ! avoids problems with
 3433    ),                                       % duplicate load
 3434    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3435'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
 3436               [op(P,A,N)|ImpOps], Strength) :-
 3437    !,
 3438    '$import_ops'(Context, Source, op(P,A,N)),
 3439    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3440'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
 3441    Error = error(_,_),
 3442    catch(Context:'$import'(Source:Pred, Strength), Error,
 3443          print_message(error, Error)),
 3444    '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
 3445    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 3446
 3447
 3448'$list_to_conj'([One], One) :- !.
 3449'$list_to_conj'([H|T], (H,Rest)) :-
 3450    '$list_to_conj'(T, Rest).
 3451
 3452%!  '$exported_ops'(+Module, -Ops, ?Tail) is det.
 3453%
 3454%   Ops is a list of op(P,A,N) terms representing the operators
 3455%   exported from Module.
 3456
 3457'$exported_ops'(Module, Ops, Tail) :-
 3458    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 3459    !,
 3460    findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
 3461'$exported_ops'(_, Ops, Ops).
 3462
 3463'$exported_op'(Module, P, A, N) :-
 3464    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 3465    Module:'$exported_op'(P, A, N).
 3466
 3467%!  '$import_ops'(+Target, +Source, +Pattern)
 3468%
 3469%   Import the operators export from Source into the module table of
 3470%   Target.  We only import operators that unify with Pattern.
 3471
 3472'$import_ops'(To, From, Pattern) :-
 3473    ground(Pattern),
 3474    !,
 3475    Pattern = op(P,A,N),
 3476    op(P,A,To:N),
 3477    (   '$exported_op'(From, P, A, N)
 3478    ->  true
 3479    ;   print_message(warning, no_exported_op(From, Pattern))
 3480    ).
 3481'$import_ops'(To, From, Pattern) :-
 3482    (   '$exported_op'(From, Pri, Assoc, Name),
 3483        Pattern = op(Pri, Assoc, Name),
 3484        op(Pri, Assoc, To:Name),
 3485        fail
 3486    ;   true
 3487    ).
 3488
 3489
 3490%!  '$export_list'(+Declarations, +Module, -Ops)
 3491%
 3492%   Handle the export list of the module declaration for Module
 3493%   associated to File.
 3494
 3495'$export_list'(Decls, Module, Ops) :-
 3496    is_list(Decls),
 3497    !,
 3498    '$do_export_list'(Decls, Module, Ops).
 3499'$export_list'(Decls, _, _) :-
 3500    var(Decls),
 3501    throw(error(instantiation_error, _)).
 3502'$export_list'(Decls, _, _) :-
 3503    throw(error(type_error(list, Decls), _)).
 3504
 3505'$do_export_list'([], _, []) :- !.
 3506'$do_export_list'([H|T], Module, Ops) :-
 3507    !,
 3508    E = error(_,_),
 3509    catch('$export1'(H, Module, Ops, Ops1),
 3510          E, ('$print_message'(error, E), Ops = Ops1)),
 3511    '$do_export_list'(T, Module, Ops1).
 3512
 3513'$export1'(Var, _, _, _) :-
 3514    var(Var),
 3515    !,
 3516    throw(error(instantiation_error, _)).
 3517'$export1'(Op, _, [Op|T], T) :-
 3518    Op = op(_,_,_),
 3519    !.
 3520'$export1'(PI0, Module, Ops, Ops) :-
 3521    strip_module(Module:PI0, M, PI),
 3522    (   PI = (_//_)
 3523    ->  non_terminal(M:PI)
 3524    ;   true
 3525    ),
 3526    export(M:PI).
 3527
 3528'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
 3529    E = error(_,_),
 3530    catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File),
 3531            '$export_op'(Pri, Assoc, Name, Module, File)
 3532          ),
 3533          E, '$print_message'(error, E)),
 3534    '$export_ops'(T, Module, File).
 3535'$export_ops'([], _, _).
 3536
 3537'$export_op'(Pri, Assoc, Name, Module, File) :-
 3538    (   '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
 3539    ->  true
 3540    ;   '$execute_directive'(discontiguous(Module:'$exported_op'/3), File)
 3541    ),
 3542    '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
 3543
 3544%!  '$execute_directive'(:Goal, +File) is det.
 3545%
 3546%   Execute the argument of :- or ?- while loading a file.
 3547
 3548'$execute_directive'(Goal, F) :-
 3549    '$execute_directive_2'(Goal, F).
 3550
 3551'$execute_directive_2'(encoding(Encoding), _F) :-
 3552    !,
 3553    (   '$load_input'(_F, S)
 3554    ->  set_stream(S, encoding(Encoding))
 3555    ).
 3556'$execute_directive_2'(Goal, _) :-
 3557    \+ '$compilation_mode'(database),
 3558    !,
 3559    '$add_directive_wic2'(Goal, Type),
 3560    (   Type == call                % suspend compiling into .qlf file
 3561    ->  '$compilation_mode'(Old, database),
 3562        setup_call_cleanup(
 3563            '$directive_mode'(OldDir, Old),
 3564            '$execute_directive_3'(Goal),
 3565            ( '$set_compilation_mode'(Old),
 3566              '$set_directive_mode'(OldDir)
 3567            ))
 3568    ;   '$execute_directive_3'(Goal)
 3569    ).
 3570'$execute_directive_2'(Goal, _) :-
 3571    '$execute_directive_3'(Goal).
 3572
 3573'$execute_directive_3'(Goal) :-
 3574    '$current_source_module'(Module),
 3575    '$valid_directive'(Module:Goal),
 3576    !,
 3577    (   '$pattr_directive'(Goal, Module)
 3578    ->  true
 3579    ;   Term = error(_,_),
 3580        catch(Module:Goal, Term, '$exception_in_directive'(Term))
 3581    ->  true
 3582    ;   '$print_message'(warning, goal_failed(directive, Module:Goal)),
 3583        fail
 3584    ).
 3585'$execute_directive_3'(_).
 3586
 3587
 3588%!  '$valid_directive'(:Directive) is det.
 3589%
 3590%   If   the   flag   =sandboxed_load=   is   =true=,   this   calls
 3591%   prolog:sandbox_allowed_directive/1. This call can deny execution
 3592%   of the directive by throwing an exception.
 3593
 3594:- multifile prolog:sandbox_allowed_directive/1. 3595:- multifile prolog:sandbox_allowed_clause/1. 3596:- meta_predicate '$valid_directive'(:). 3597
 3598'$valid_directive'(_) :-
 3599    current_prolog_flag(sandboxed_load, false),
 3600    !.
 3601'$valid_directive'(Goal) :-
 3602    Error = error(Formal, _),
 3603    catch(prolog:sandbox_allowed_directive(Goal), Error, true),
 3604    !,
 3605    (   var(Formal)
 3606    ->  true
 3607    ;   print_message(error, Error),
 3608        fail
 3609    ).
 3610'$valid_directive'(Goal) :-
 3611    print_message(error,
 3612                  error(permission_error(execute,
 3613                                         sandboxed_directive,
 3614                                         Goal), _)),
 3615    fail.
 3616
 3617'$exception_in_directive'(Term) :-
 3618    '$print_message'(error, Term),
 3619    fail.
 3620
 3621%       Note that the list, consult and ensure_loaded directives are already
 3622%       handled at compile time and therefore should not go into the
 3623%       intermediate code file.
 3624
 3625'$add_directive_wic2'(Goal, Type) :-
 3626    '$common_goal_type'(Goal, Type),
 3627    !,
 3628    (   Type == load
 3629    ->  true
 3630    ;   '$current_source_module'(Module),
 3631        '$add_directive_wic'(Module:Goal)
 3632    ).
 3633'$add_directive_wic2'(Goal, _) :-
 3634    (   '$compilation_mode'(qlf)    % no problem for qlf files
 3635    ->  true
 3636    ;   print_message(error, mixed_directive(Goal))
 3637    ).
 3638
 3639'$common_goal_type'((A,B), Type) :-
 3640    !,
 3641    '$common_goal_type'(A, Type),
 3642    '$common_goal_type'(B, Type).
 3643'$common_goal_type'((A;B), Type) :-
 3644    !,
 3645    '$common_goal_type'(A, Type),
 3646    '$common_goal_type'(B, Type).
 3647'$common_goal_type'((A->B), Type) :-
 3648    !,
 3649    '$common_goal_type'(A, Type),
 3650    '$common_goal_type'(B, Type).
 3651'$common_goal_type'(Goal, Type) :-
 3652    '$goal_type'(Goal, Type).
 3653
 3654'$goal_type'(Goal, Type) :-
 3655    (   '$load_goal'(Goal)
 3656    ->  Type = load
 3657    ;   Type = call
 3658    ).
 3659
 3660'$load_goal'([_|_]).
 3661'$load_goal'(consult(_)).
 3662'$load_goal'(load_files(_)).
 3663'$load_goal'(load_files(_,Options)) :-
 3664    memberchk(qcompile(QlfMode), Options),
 3665    '$qlf_part_mode'(QlfMode).
 3666'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic).
 3667'$load_goal'(use_module(_))    :- '$compilation_mode'(wic).
 3668'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic).
 3669
 3670'$qlf_part_mode'(part).
 3671'$qlf_part_mode'(true).                 % compatibility
 3672
 3673
 3674                /********************************
 3675                *        COMPILE A CLAUSE       *
 3676                *********************************/
 3677
 3678%!  '$store_admin_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3679%
 3680%   Store a clause into the   database  for administrative purposes.
 3681%   This bypasses sanity checking.
 3682
 3683'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :-
 3684    Owner \== (-),
 3685    !,
 3686    setup_call_cleanup(
 3687        '$start_aux'(Owner, Context),
 3688        '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc),
 3689        '$end_aux'(Owner, Context)).
 3690'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
 3691    '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
 3692
 3693'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
 3694    (   '$compilation_mode'(database)
 3695    ->  '$record_clause'(Clause, File, SrcLoc)
 3696    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3697        '$qlf_assert_clause'(Ref, development)
 3698    ).
 3699
 3700%!  '$store_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3701%
 3702%   Store a clause into the database.
 3703%
 3704%   @arg    Owner is the file-id that owns the clause
 3705%   @arg    SrcLoc is the file:line term where the clause
 3706%           originates from.
 3707
 3708'$store_clause'((_, _), _, _, _) :-
 3709    !,
 3710    print_message(error, cannot_redefine_comma),
 3711    fail.
 3712'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :-
 3713    nonvar(Pre),
 3714    Pre = (Head,Cond),
 3715    !,
 3716    (   '$is_true'(Cond), current_prolog_flag(optimise, true)
 3717    ->  '$store_clause'((Head=>Body), _Layout, File, SrcLoc)
 3718    ;   '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc)
 3719    ).
 3720'$store_clause'(Clause, _Layout, File, SrcLoc) :-
 3721    '$valid_clause'(Clause),
 3722    !,
 3723    (   '$compilation_mode'(database)
 3724    ->  '$record_clause'(Clause, File, SrcLoc)
 3725    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3726        '$qlf_assert_clause'(Ref, development)
 3727    ).
 3728
 3729'$is_true'(true)  => true.
 3730'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B).
 3731'$is_true'(_)     => fail.
 3732
 3733'$valid_clause'(_) :-
 3734    current_prolog_flag(sandboxed_load, false),
 3735    !.
 3736'$valid_clause'(Clause) :-
 3737    \+ '$cross_module_clause'(Clause),
 3738    !.
 3739'$valid_clause'(Clause) :-
 3740    Error = error(Formal, _),
 3741    catch(prolog:sandbox_allowed_clause(Clause), Error, true),
 3742    !,
 3743    (   var(Formal)
 3744    ->  true
 3745    ;   print_message(error, Error),
 3746        fail
 3747    ).
 3748'$valid_clause'(Clause) :-
 3749    print_message(error,
 3750                  error(permission_error(assert,
 3751                                         sandboxed_clause,
 3752                                         Clause), _)),
 3753    fail.
 3754
 3755'$cross_module_clause'(Clause) :-
 3756    '$head_module'(Clause, Module),
 3757    \+ '$current_source_module'(Module).
 3758
 3759'$head_module'(Var, _) :-
 3760    var(Var), !, fail.
 3761'$head_module'((Head :- _), Module) :-
 3762    '$head_module'(Head, Module).
 3763'$head_module'(Module:_, Module).
 3764
 3765'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
 3766'$clause_source'(Clause, Clause, -).
 3767
 3768%!  '$store_clause'(+Term, +Id) is det.
 3769%
 3770%   This interface is used by PlDoc (and who knows).  Kept for to avoid
 3771%   compatibility issues.
 3772
 3773:- public
 3774    '$store_clause'/2. 3775
 3776'$store_clause'(Term, Id) :-
 3777    '$clause_source'(Term, Clause, SrcLoc),
 3778    '$store_clause'(Clause, _, Id, SrcLoc).
 3779
 3780%!  compile_aux_clauses(+Clauses) is det.
 3781%
 3782%   Compile clauses given the current  source   location  but do not
 3783%   change  the  notion  of   the    current   procedure  such  that
 3784%   discontiguous  warnings  are  not  issued.    The   clauses  are
 3785%   associated with the current file and  therefore wiped out if the
 3786%   file is reloaded.
 3787%
 3788%   If the cross-referencer is active, we should not (re-)assert the
 3789%   clauses.  Actually,  we  should   make    them   known   to  the
 3790%   cross-referencer. How do we do that?   Maybe we need a different
 3791%   API, such as in:
 3792%
 3793%     ==
 3794%     expand_term_aux(Goal, NewGoal, Clauses)
 3795%     ==
 3796%
 3797%   @tbd    Deal with source code layout?
 3798
 3799compile_aux_clauses(_Clauses) :-
 3800    current_prolog_flag(xref, true),
 3801    !.
 3802compile_aux_clauses(Clauses) :-
 3803    source_location(File, _Line),
 3804    '$compile_aux_clauses'(Clauses, File).
 3805
 3806'$compile_aux_clauses'(Clauses, File) :-
 3807    setup_call_cleanup(
 3808        '$start_aux'(File, Context),
 3809        '$store_aux_clauses'(Clauses, File),
 3810        '$end_aux'(File, Context)).
 3811
 3812'$store_aux_clauses'(Clauses, File) :-
 3813    is_list(Clauses),
 3814    !,
 3815    forall('$member'(C,Clauses),
 3816           '$compile_term'(C, _Layout, File)).
 3817'$store_aux_clauses'(Clause, File) :-
 3818    '$compile_term'(Clause, _Layout, File).
 3819
 3820
 3821		 /*******************************
 3822		 *            STAGING		*
 3823		 *******************************/
 3824
 3825%!  '$stage_file'(+Target, -Stage) is det.
 3826%!  '$install_staged_file'(+Catcher, +Staged, +Target, +OnError).
 3827%
 3828%   Create files using _staging_, where we  first write a temporary file
 3829%   and move it to Target if  the   file  was created successfully. This
 3830%   provides an atomic transition, preventing  customers from reading an
 3831%   incomplete file.
 3832
 3833'$stage_file'(Target, Stage) :-
 3834    file_directory_name(Target, Dir),
 3835    file_base_name(Target, File),
 3836    current_prolog_flag(pid, Pid),
 3837    format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]).
 3838
 3839'$install_staged_file'(exit, Staged, Target, error) :-
 3840    !,
 3841    rename_file(Staged, Target).
 3842'$install_staged_file'(exit, Staged, Target, OnError) :-
 3843    !,
 3844    InstallError = error(_,_),
 3845    catch(rename_file(Staged, Target),
 3846          InstallError,
 3847          '$install_staged_error'(OnError, InstallError, Staged, Target)).
 3848'$install_staged_file'(_, Staged, _, _OnError) :-
 3849    E = error(_,_),
 3850    catch(delete_file(Staged), E, true).
 3851
 3852'$install_staged_error'(OnError, Error, Staged, _Target) :-
 3853    E = error(_,_),
 3854    catch(delete_file(Staged), E, true),
 3855    (   OnError = silent
 3856    ->  true
 3857    ;   OnError = fail
 3858    ->  fail
 3859    ;   print_message(warning, Error)
 3860    ).
 3861
 3862
 3863                 /*******************************
 3864                 *             READING          *
 3865                 *******************************/
 3866
 3867:- multifile
 3868    prolog:comment_hook/3.                  % hook for read_clause/3
 3869
 3870
 3871                 /*******************************
 3872                 *       FOREIGN INTERFACE      *
 3873                 *******************************/
 3874
 3875%       call-back from PL_register_foreign().  First argument is the module
 3876%       into which the foreign predicate is loaded and second is a term
 3877%       describing the arguments.
 3878
 3879:- dynamic
 3880    '$foreign_registered'/2. 3881
 3882                 /*******************************
 3883                 *   TEMPORARY TERM EXPANSION   *
 3884                 *******************************/
 3885
 3886% Provide temporary definitions for the boot-loader.  These are replaced
 3887% by the real thing in load.pl
 3888
 3889:- dynamic
 3890    '$expand_goal'/2,
 3891    '$expand_term'/4. 3892
 3893'$expand_goal'(In, In).
 3894'$expand_term'(In, Layout, In, Layout).
 3895
 3896
 3897                 /*******************************
 3898                 *         TYPE SUPPORT         *
 3899                 *******************************/
 3900
 3901'$type_error'(Type, Value) :-
 3902    (   var(Value)
 3903    ->  throw(error(instantiation_error, _))
 3904    ;   throw(error(type_error(Type, Value), _))
 3905    ).
 3906
 3907'$domain_error'(Type, Value) :-
 3908    throw(error(domain_error(Type, Value), _)).
 3909
 3910'$existence_error'(Type, Object) :-
 3911    throw(error(existence_error(Type, Object), _)).
 3912
 3913'$permission_error'(Action, Type, Term) :-
 3914    throw(error(permission_error(Action, Type, Term), _)).
 3915
 3916'$instantiation_error'(_Var) :-
 3917    throw(error(instantiation_error, _)).
 3918
 3919'$uninstantiation_error'(NonVar) :-
 3920    throw(error(uninstantiation_error(NonVar), _)).
 3921
 3922'$must_be'(list, X) :- !,
 3923    '$skip_list'(_, X, Tail),
 3924    (   Tail == []
 3925    ->  true
 3926    ;   '$type_error'(list, Tail)
 3927    ).
 3928'$must_be'(options, X) :- !,
 3929    (   '$is_options'(X)
 3930    ->  true
 3931    ;   '$type_error'(options, X)
 3932    ).
 3933'$must_be'(atom, X) :- !,
 3934    (   atom(X)
 3935    ->  true
 3936    ;   '$type_error'(atom, X)
 3937    ).
 3938'$must_be'(integer, X) :- !,
 3939    (   integer(X)
 3940    ->  true
 3941    ;   '$type_error'(integer, X)
 3942    ).
 3943'$must_be'(between(Low,High), X) :- !,
 3944    (   integer(X)
 3945    ->  (   between(Low, High, X)
 3946        ->  true
 3947        ;   '$domain_error'(between(Low,High), X)
 3948        )
 3949    ;   '$type_error'(integer, X)
 3950    ).
 3951'$must_be'(callable, X) :- !,
 3952    (   callable(X)
 3953    ->  true
 3954    ;   '$type_error'(callable, X)
 3955    ).
 3956'$must_be'(acyclic, X) :- !,
 3957    (   acyclic_term(X)
 3958    ->  true
 3959    ;   '$domain_error'(acyclic_term, X)
 3960    ).
 3961'$must_be'(oneof(Type, Domain, List), X) :- !,
 3962    '$must_be'(Type, X),
 3963    (   memberchk(X, List)
 3964    ->  true
 3965    ;   '$domain_error'(Domain, X)
 3966    ).
 3967'$must_be'(boolean, X) :- !,
 3968    (   (X == true ; X == false)
 3969    ->  true
 3970    ;   '$type_error'(boolean, X)
 3971    ).
 3972'$must_be'(ground, X) :- !,
 3973    (   ground(X)
 3974    ->  true
 3975    ;   '$instantiation_error'(X)
 3976    ).
 3977'$must_be'(filespec, X) :- !,
 3978    (   (   atom(X)
 3979        ;   string(X)
 3980        ;   compound(X),
 3981            compound_name_arity(X, _, 1)
 3982        )
 3983    ->  true
 3984    ;   '$type_error'(filespec, X)
 3985    ).
 3986
 3987% Use for debugging
 3988%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]).
 3989
 3990
 3991                /********************************
 3992                *       LIST PROCESSING         *
 3993                *********************************/
 3994
 3995'$member'(El, [H|T]) :-
 3996    '$member_'(T, El, H).
 3997
 3998'$member_'(_, El, El).
 3999'$member_'([H|T], El, _) :-
 4000    '$member_'(T, El, H).
 4001
 4002
 4003'$append'([], L, L).
 4004'$append'([H|T], L, [H|R]) :-
 4005    '$append'(T, L, R).
 4006
 4007'$select'(X, [X|Tail], Tail).
 4008'$select'(Elem, [Head|Tail], [Head|Rest]) :-
 4009    '$select'(Elem, Tail, Rest).
 4010
 4011'$reverse'(L1, L2) :-
 4012    '$reverse'(L1, [], L2).
 4013
 4014'$reverse'([], List, List).
 4015'$reverse'([Head|List1], List2, List3) :-
 4016    '$reverse'(List1, [Head|List2], List3).
 4017
 4018'$delete'([], _, []) :- !.
 4019'$delete'([Elem|Tail], Elem, Result) :-
 4020    !,
 4021    '$delete'(Tail, Elem, Result).
 4022'$delete'([Head|Tail], Elem, [Head|Rest]) :-
 4023    '$delete'(Tail, Elem, Rest).
 4024
 4025'$last'([H|T], Last) :-
 4026    '$last'(T, H, Last).
 4027
 4028'$last'([], Last, Last).
 4029'$last'([H|T], _, Last) :-
 4030    '$last'(T, H, Last).
 4031
 4032
 4033%!  length(?List, ?N)
 4034%
 4035%   Is true when N is the length of List.
 4036
 4037:- '$iso'((length/2)). 4038
 4039length(List, Length) :-
 4040    var(Length),
 4041    !,
 4042    '$skip_list'(Length0, List, Tail),
 4043    (   Tail == []
 4044    ->  Length = Length0                    % +,-
 4045    ;   var(Tail)
 4046    ->  Tail \== Length,                    % avoid length(L,L)
 4047        '$length3'(Tail, Length, Length0)   % -,-
 4048    ;   throw(error(type_error(list, List),
 4049                    context(length/2, _)))
 4050    ).
 4051length(List, Length) :-
 4052    integer(Length),
 4053    Length >= 0,
 4054    !,
 4055    '$skip_list'(Length0, List, Tail),
 4056    (   Tail == []                          % proper list
 4057    ->  Length = Length0
 4058    ;   var(Tail)
 4059    ->  Extra is Length-Length0,
 4060        '$length'(Tail, Extra)
 4061    ;   throw(error(type_error(list, List),
 4062                    context(length/2, _)))
 4063    ).
 4064length(_, Length) :-
 4065    integer(Length),
 4066    !,
 4067    throw(error(domain_error(not_less_than_zero, Length),
 4068                context(length/2, _))).
 4069length(_, Length) :-
 4070    throw(error(type_error(integer, Length),
 4071                context(length/2, _))).
 4072
 4073'$length3'([], N, N).
 4074'$length3'([_|List], N, N0) :-
 4075    N1 is N0+1,
 4076    '$length3'(List, N, N1).
 4077
 4078
 4079                 /*******************************
 4080                 *       OPTION PROCESSING      *
 4081                 *******************************/
 4082
 4083%!  '$is_options'(@Term) is semidet.
 4084%
 4085%   True if Term looks like it provides options.
 4086
 4087'$is_options'(Map) :-
 4088    is_dict(Map, _),
 4089    !.
 4090'$is_options'(List) :-
 4091    is_list(List),
 4092    (   List == []
 4093    ->  true
 4094    ;   List = [H|_],
 4095        '$is_option'(H, _, _)
 4096    ).
 4097
 4098'$is_option'(Var, _, _) :-
 4099    var(Var), !, fail.
 4100'$is_option'(F, Name, Value) :-
 4101    functor(F, _, 1),
 4102    !,
 4103    F =.. [Name,Value].
 4104'$is_option'(Name=Value, Name, Value).
 4105
 4106%!  '$option'(?Opt, +Options) is semidet.
 4107
 4108'$option'(Opt, Options) :-
 4109    is_dict(Options),
 4110    !,
 4111    [Opt] :< Options.
 4112'$option'(Opt, Options) :-
 4113    memberchk(Opt, Options).
 4114
 4115%!  '$option'(?Opt, +Options, +Default) is det.
 4116
 4117'$option'(Term, Options, Default) :-
 4118    arg(1, Term, Value),
 4119    functor(Term, Name, 1),
 4120    (   is_dict(Options)
 4121    ->  (   get_dict(Name, Options, GVal)
 4122        ->  Value = GVal
 4123        ;   Value = Default
 4124        )
 4125    ;   functor(Gen, Name, 1),
 4126        arg(1, Gen, GVal),
 4127        (   memberchk(Gen, Options)
 4128        ->  Value = GVal
 4129        ;   Value = Default
 4130        )
 4131    ).
 4132
 4133%!  '$select_option'(?Opt, +Options, -Rest) is semidet.
 4134%
 4135%   Select an option from Options.
 4136%
 4137%   @arg Rest is always a map.
 4138
 4139'$select_option'(Opt, Options, Rest) :-
 4140    select_dict([Opt], Options, Rest).
 4141
 4142%!  '$merge_options'(+New, +Default, -Merged) is det.
 4143%
 4144%   Add/replace options specified in New.
 4145%
 4146%   @arg Merged is always a map.
 4147
 4148'$merge_options'(New, Old, Merged) :-
 4149    put_dict(New, Old, Merged).
 4150
 4151
 4152                 /*******************************
 4153                 *   HANDLE TRACER 'L'-COMMAND  *
 4154                 *******************************/
 4155
 4156:- public '$prolog_list_goal'/1. 4157
 4158:- multifile
 4159    user:prolog_list_goal/1. 4160
 4161'$prolog_list_goal'(Goal) :-
 4162    user:prolog_list_goal(Goal),
 4163    !.
 4164'$prolog_list_goal'(Goal) :-
 4165    use_module(library(listing), [listing/1]),
 4166    @(listing(Goal), user).
 4167
 4168
 4169                 /*******************************
 4170                 *             HALT             *
 4171                 *******************************/
 4172
 4173:- '$iso'((halt/0)). 4174
 4175halt :-
 4176    '$exit_code'(Code),
 4177    (   Code == 0
 4178    ->  true
 4179    ;   print_message(warning, on_error(halt(1)))
 4180    ),
 4181    halt(Code).
 4182
 4183%!  '$exit_code'(Code)
 4184%
 4185%   Determine the exit code baed on the `on_error` and `on_warning`
 4186%   flags.  Also used by qsave_toplevel/0.
 4187
 4188'$exit_code'(Code) :-
 4189    (   (   current_prolog_flag(on_error, status),
 4190            statistics(errors, Count),
 4191            Count > 0
 4192        ;   current_prolog_flag(on_warning, status),
 4193            statistics(warnings, Count),
 4194            Count > 0
 4195        )
 4196    ->  Code = 1
 4197    ;   Code = 0
 4198    ).
 4199
 4200
 4201%!  at_halt(:Goal)
 4202%
 4203%   Register Goal to be called if the system halts.
 4204%
 4205%   @tbd: get location into the error message
 4206
 4207:- meta_predicate at_halt(0). 4208:- dynamic        system:term_expansion/2, '$at_halt'/2. 4209:- multifile      system:term_expansion/2, '$at_halt'/2. 4210
 4211system:term_expansion((:- at_halt(Goal)),
 4212                      system:'$at_halt'(Module:Goal, File:Line)) :-
 4213    \+ current_prolog_flag(xref, true),
 4214    source_location(File, Line),
 4215    '$current_source_module'(Module).
 4216
 4217at_halt(Goal) :-
 4218    asserta('$at_halt'(Goal, (-):0)).
 4219
 4220:- public '$run_at_halt'/0. 4221
 4222'$run_at_halt' :-
 4223    forall(clause('$at_halt'(Goal, Src), true, Ref),
 4224           ( '$call_at_halt'(Goal, Src),
 4225             erase(Ref)
 4226           )).
 4227
 4228'$call_at_halt'(Goal, _Src) :-
 4229    catch(Goal, E, true),
 4230    !,
 4231    (   var(E)
 4232    ->  true
 4233    ;   subsumes_term(cancel_halt(_), E)
 4234    ->  '$print_message'(informational, E),
 4235        fail
 4236    ;   '$print_message'(error, E)
 4237    ).
 4238'$call_at_halt'(Goal, _Src) :-
 4239    '$print_message'(warning, goal_failed(at_halt, Goal)).
 4240
 4241%!  cancel_halt(+Reason)
 4242%
 4243%   This predicate may be called from   at_halt/1 handlers to cancel
 4244%   halting the program. If  causes  halt/0   to  fail  rather  than
 4245%   terminating the process.
 4246
 4247cancel_halt(Reason) :-
 4248    throw(cancel_halt(Reason)).
 4249
 4250
 4251                /********************************
 4252                *      LOAD OTHER MODULES       *
 4253                *********************************/
 4254
 4255:- meta_predicate
 4256    '$load_wic_files'(:). 4257
 4258'$load_wic_files'(Files) :-
 4259    Files = Module:_,
 4260    '$execute_directive'('$set_source_module'(OldM, Module), []),
 4261    '$save_lex_state'(LexState, []),
 4262    '$style_check'(_, 0xC7),                % see style_name/2 in syspred.pl
 4263    '$compilation_mode'(OldC, wic),
 4264    consult(Files),
 4265    '$execute_directive'('$set_source_module'(OldM), []),
 4266    '$execute_directive'('$restore_lex_state'(LexState), []),
 4267    '$set_compilation_mode'(OldC).
 4268
 4269
 4270%!  '$load_additional_boot_files' is det.
 4271%
 4272%   Called from compileFileList() in pl-wic.c.   Gets the files from
 4273%   "-c file ..." and loads them into the module user.
 4274
 4275:- public '$load_additional_boot_files'/0. 4276
 4277'$load_additional_boot_files' :-
 4278    current_prolog_flag(argv, Argv),
 4279    '$get_files_argv'(Argv, Files),
 4280    (   Files \== []
 4281    ->  format('Loading additional boot files~n'),
 4282        '$load_wic_files'(user:Files),
 4283        format('additional boot files loaded~n')
 4284    ;   true
 4285    ).
 4286
 4287'$get_files_argv'([], []) :- !.
 4288'$get_files_argv'(['-c'|Files], Files) :- !.
 4289'$get_files_argv'([_|Rest], Files) :-
 4290    '$get_files_argv'(Rest, Files).
 4291
 4292'$:-'(('$boot_message'('Loading Prolog startup files~n', []),
 4293       source_location(File, _Line),
 4294       file_directory_name(File, Dir),
 4295       atom_concat(Dir, '/load.pl', LoadFile),
 4296       '$load_wic_files'(system:[LoadFile]),
 4297       (   current_prolog_flag(windows, true)
 4298       ->  atom_concat(Dir, '/menu.pl', MenuFile),
 4299           '$load_wic_files'(system:[MenuFile])
 4300       ;   true
 4301       ),
 4302       '$boot_message'('SWI-Prolog boot files loaded~n', []),
 4303       '$compilation_mode'(OldC, wic),
 4304       '$execute_directive'('$set_source_module'(user), []),
 4305       '$set_compilation_mode'(OldC)
 4306      ))