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