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