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