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