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