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