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