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