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