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