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