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