init.pl

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