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