init.pl

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