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