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),
 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) :-
 1650    (   peek_char(In, #)
 1651    ->  skip(In, 10)
 1652    ;   true
 1653    ).
 1654
 1655'$set_encoding'(Stream, Options) :-
 1656    '$option'(encoding(Enc), Options),
 1657    !,
 1658    Enc \== default,
 1659    set_stream(Stream, encoding(Enc)).
 1660'$set_encoding'(_, _).
 1661
 1662
 1663'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
 1664    (   stream_property(In, file_name(_))
 1665    ->  HasName = true,
 1666        (   stream_property(In, position(_))
 1667        ->  HasPos = true
 1668        ;   HasPos = false,
 1669            set_stream(In, record_position(true))
 1670        )
 1671    ;   HasName = false,
 1672        set_stream(In, file_name(Id)),
 1673        (   stream_property(In, position(_))
 1674        ->  HasPos = true
 1675        ;   HasPos = false,
 1676            set_stream(In, record_position(true))
 1677        )
 1678    ).
 1679
 1680'$restore_load_stream'(In, _State, Options) :-
 1681    memberchk(close(true), Options),
 1682    !,
 1683    close(In).
 1684'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
 1685    (   HasName == false
 1686    ->  set_stream(In, file_name(''))
 1687    ;   true
 1688    ),
 1689    (   HasPos == false
 1690    ->  set_stream(In, record_position(false))
 1691    ;   true
 1692    ).
 1693
 1694
 1695                 /*******************************
 1696                 *          DERIVED FILES       *
 1697                 *******************************/
 1698
 1699:- dynamic
 1700    '$derived_source_db'/3.         % Loaded, DerivedFrom, Time
 1701
 1702'$register_derived_source'(_, '-') :- !.
 1703'$register_derived_source'(Loaded, DerivedFrom) :-
 1704    retractall('$derived_source_db'(Loaded, _, _)),
 1705    time_file(DerivedFrom, Time),
 1706    assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
 1707
 1708%       Auto-importing dynamic predicates is not very elegant and
 1709%       leads to problems with qsave_program/[1,2]
 1710
 1711'$derived_source'(Loaded, DerivedFrom, Time) :-
 1712    '$derived_source_db'(Loaded, DerivedFrom, Time).
 1713
 1714
 1715                /********************************
 1716                *       LOAD PREDICATES         *
 1717                *********************************/
 1718
 1719:- meta_predicate
 1720    ensure_loaded(:),
 1721    [:|+],
 1722    consult(:),
 1723    use_module(:),
 1724    use_module(:, +),
 1725    reexport(:),
 1726    reexport(:, +),
 1727    load_files(:),
 1728    load_files(:, +). 1729
 1730%!  ensure_loaded(+FileOrListOfFiles)
 1731%
 1732%   Load specified files, provided they where not loaded before. If the
 1733%   file is a module file import the public predicates into the context
 1734%   module.
 1735
 1736ensure_loaded(Files) :-
 1737    load_files(Files, [if(not_loaded)]).
 1738
 1739%!  use_module(+FileOrListOfFiles)
 1740%
 1741%   Very similar to ensure_loaded/1, but insists on the loaded file to
 1742%   be a module file. If the file is already imported, but the public
 1743%   predicates are not yet imported into the context module, then do
 1744%   so.
 1745
 1746use_module(Files) :-
 1747    load_files(Files, [ if(not_loaded),
 1748                        must_be_module(true)
 1749                      ]).
 1750
 1751%!  use_module(+File, +ImportList)
 1752%
 1753%   As use_module/1, but takes only one file argument and imports only
 1754%   the specified predicates rather than all public predicates.
 1755
 1756use_module(File, Import) :-
 1757    load_files(File, [ if(not_loaded),
 1758                       must_be_module(true),
 1759                       imports(Import)
 1760                     ]).
 1761
 1762%!  reexport(+Files)
 1763%
 1764%   As use_module/1, exporting all imported predicates.
 1765
 1766reexport(Files) :-
 1767    load_files(Files, [ if(not_loaded),
 1768                        must_be_module(true),
 1769                        reexport(true)
 1770                      ]).
 1771
 1772%!  reexport(+File, +ImportList)
 1773%
 1774%   As use_module/1, re-exporting all imported predicates.
 1775
 1776reexport(File, Import) :-
 1777    load_files(File, [ if(not_loaded),
 1778                       must_be_module(true),
 1779                       imports(Import),
 1780                       reexport(true)
 1781                     ]).
 1782
 1783
 1784[X] :-
 1785    !,
 1786    consult(X).
 1787[M:F|R] :-
 1788    consult(M:[F|R]).
 1789
 1790consult(M:X) :-
 1791    X == user,
 1792    !,
 1793    flag('$user_consult', N, N+1),
 1794    NN is N + 1,
 1795    atom_concat('user://', NN, Id),
 1796    load_files(M:Id, [stream(user_input)]).
 1797consult(List) :-
 1798    load_files(List, [expand(true)]).
 1799
 1800%!  load_files(:File, +Options)
 1801%
 1802%   Common entry for all the consult derivates.  File is the raw user
 1803%   specified file specification, possibly tagged with the module.
 1804
 1805load_files(Files) :-
 1806    load_files(Files, []).
 1807load_files(Module:Files, Options) :-
 1808    '$must_be'(list, Options),
 1809    '$load_files'(Files, Module, Options).
 1810
 1811'$load_files'(X, _, _) :-
 1812    var(X),
 1813    !,
 1814    '$instantiation_error'(X).
 1815'$load_files'([], _, _) :- !.
 1816'$load_files'(Id, Module, Options) :-   % load_files(foo, [stream(In)])
 1817    '$option'(stream(_), Options),
 1818    !,
 1819    (   atom(Id)
 1820    ->  '$load_file'(Id, Module, Options)
 1821    ;   throw(error(type_error(atom, Id), _))
 1822    ).
 1823'$load_files'(List, Module, Options) :-
 1824    List = [_|_],
 1825    !,
 1826    '$must_be'(list, List),
 1827    '$load_file_list'(List, Module, Options).
 1828'$load_files'(File, Module, Options) :-
 1829    '$load_one_file'(File, Module, Options).
 1830
 1831'$load_file_list'([], _, _).
 1832'$load_file_list'([File|Rest], Module, Options) :-
 1833    catch('$load_one_file'(File, Module, Options), E,
 1834          print_message(error, E)),
 1835    '$load_file_list'(Rest, Module, Options).
 1836
 1837
 1838'$load_one_file'(Spec, Module, Options) :-
 1839    atomic(Spec),
 1840    '$option'(expand(Expand), Options, false),
 1841    Expand == true,
 1842    !,
 1843    expand_file_name(Spec, Expanded),
 1844    (   Expanded = [Load]
 1845    ->  true
 1846    ;   Load = Expanded
 1847    ),
 1848    '$load_files'(Load, Module, [expand(false)|Options]).
 1849'$load_one_file'(File, Module, Options) :-
 1850    strip_module(Module:File, Into, PlainFile),
 1851    '$load_file'(PlainFile, Into, Options).
 1852
 1853
 1854%!  '$noload'(+Condition, +FullFile, +Options) is semidet.
 1855%
 1856%   True of FullFile should _not_ be loaded.
 1857
 1858'$noload'(true, _, _) :-
 1859    !,
 1860    fail.
 1861'$noload'(not_loaded, FullFile, _) :-
 1862    source_file(FullFile),
 1863    !.
 1864'$noload'(changed, Derived, _) :-
 1865    '$derived_source'(_FullFile, Derived, LoadTime),
 1866    time_file(Derived, Modified),
 1867    Modified @=< LoadTime,
 1868    !.
 1869'$noload'(changed, FullFile, Options) :-
 1870    '$time_source_file'(FullFile, LoadTime, user),
 1871    '$modified_id'(FullFile, Modified, Options),
 1872    Modified @=< LoadTime,
 1873    !.
 1874
 1875%!  '$qlf_file'(+Spec, +PlFile, -LoadFile, -Mode, +Options) is det.
 1876%
 1877%   Return the QLF file if it exists.  Might check for modification
 1878%   time, version, etc.
 1879%
 1880%   If the user-specification specified a prolog file, do not
 1881%   replace this with a .qlf file.
 1882
 1883'$qlf_file'(Spec, _, Spec, stream, Options) :-
 1884    '$option'(stream(_), Options),
 1885    !.
 1886'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
 1887    '$spec_extension'(Spec, Ext),
 1888    user:prolog_file_type(Ext, prolog),
 1889    !.
 1890'$qlf_file'(_, FullFile, QlfFile, Mode, Options) :-
 1891    '$compilation_mode'(database),
 1892    file_name_extension(Base, PlExt, FullFile),
 1893    user:prolog_file_type(PlExt, prolog),
 1894    user:prolog_file_type(QlfExt, qlf),
 1895    file_name_extension(Base, QlfExt, QlfFile),
 1896    (   access_file(QlfFile, read),
 1897        (   '$qlf_up_to_date'(FullFile, QlfFile)
 1898        ->  Mode = qload
 1899        ;   access_file(QlfFile, write)
 1900        ->  Mode = qcompile
 1901        )
 1902    ->  !
 1903    ;   '$qlf_auto'(FullFile, QlfFile, Options)
 1904    ->  !, Mode = qcompile
 1905    ).
 1906'$qlf_file'(_, FullFile, FullFile, compile, _).
 1907
 1908
 1909%!  '$qlf_up_to_date'(+PlFile, +QlfFile) is semidet.
 1910%
 1911%   True if the QlfFile file is  considered up-to-date. This implies
 1912%   that either the PlFile does not exist or that the QlfFile is not
 1913%   older than the PlFile.
 1914
 1915'$qlf_up_to_date'(PlFile, QlfFile) :-
 1916    (   exists_file(PlFile)
 1917    ->  time_file(PlFile, PlTime),
 1918        time_file(QlfFile, QlfTime),
 1919        QlfTime >= PlTime
 1920    ;   true
 1921    ).
 1922
 1923%!  '$qlf_auto'(+PlFile, +QlfFile, +Options) is semidet.
 1924%
 1925%   True if we create QlfFile using   qcompile/2. This is determined
 1926%   by the option qcompile(QlfMode) or, if   this is not present, by
 1927%   the prolog_flag qcompile.
 1928
 1929:- create_prolog_flag(qcompile, false, [type(atom)]). 1930
 1931'$qlf_auto'(PlFile, QlfFile, Options) :-
 1932    (   memberchk(qcompile(QlfMode), Options)
 1933    ->  true
 1934    ;   current_prolog_flag(qcompile, QlfMode),
 1935        \+ '$in_system_dir'(PlFile)
 1936    ),
 1937    (   QlfMode == auto
 1938    ->  true
 1939    ;   QlfMode == large,
 1940        size_file(PlFile, Size),
 1941        Size > 100000
 1942    ),
 1943    access_file(QlfFile, write).
 1944
 1945'$in_system_dir'(PlFile) :-
 1946    current_prolog_flag(home, Home),
 1947    sub_atom(PlFile, 0, _, _, Home).
 1948
 1949'$spec_extension'(File, Ext) :-
 1950    atom(File),
 1951    file_name_extension(_, Ext, File).
 1952'$spec_extension'(Spec, Ext) :-
 1953    compound(Spec),
 1954    arg(1, Spec, Arg),
 1955    '$spec_extension'(Arg, Ext).
 1956
 1957
 1958%!  '$load_file'(+Spec, +ContextModule, +Options) is det.
 1959%
 1960%   Load the file Spec  into   ContextModule  controlled by Options.
 1961%   This wrapper deals with two cases  before proceeding to the real
 1962%   loader:
 1963%
 1964%       * User hooks based on prolog_load_file/2
 1965%       * The file is already loaded.
 1966
 1967'$load_file'(File, Module, Options) :-
 1968    \+ memberchk(stream(_), Options),
 1969    user:prolog_load_file(Module:File, Options),
 1970    !.
 1971'$load_file'(File, Module, Options) :-
 1972    memberchk(stream(_), Options),
 1973    !,
 1974    '$assert_load_context_module'(File, Module, Options),
 1975    '$qdo_load_file'(File, File, Module, Action, Options),
 1976    '$run_initialization'(File, Action, Options).
 1977'$load_file'(File, Module, Options) :-
 1978    absolute_file_name(File,
 1979                       [ file_type(prolog),
 1980                         access(read)
 1981                       ],
 1982                       FullFile),
 1983    '$mt_load_file'(File, FullFile, Module, Options).
 1984
 1985
 1986%!  '$already_loaded'(+File, +FulleFile, +Module, +Options) is det.
 1987%
 1988%   Called if File is already loaded. If  this is a module-file, the
 1989%   module must be imported into the context  Module. If it is not a
 1990%   module file, it must be reloaded.
 1991%
 1992%   @bug    A file may be associated with multiple modules.  How
 1993%           do we find the `main export module'?  Currently there
 1994%           is no good way to find out which module is associated
 1995%           to the file as a result of the first :- module/2 term.
 1996
 1997'$already_loaded'(_File, FullFile, Module, Options) :-
 1998    '$assert_load_context_module'(FullFile, Module, Options),
 1999    '$current_module'(LoadModules, FullFile),
 2000    !,
 2001    (   atom(LoadModules)
 2002    ->  LoadModule = LoadModules
 2003    ;   LoadModules = [LoadModule|_]
 2004    ),
 2005    '$import_from_loaded_module'(LoadModule, Module, Options).
 2006'$already_loaded'(_, _, user, _) :- !.
 2007'$already_loaded'(File, _, Module, Options) :-
 2008    '$load_file'(File, Module, [if(true)|Options]).
 2009
 2010%!  '$mt_load_file'(+File, +FullFile, +Module, +Options) is det.
 2011%
 2012%   Deal with multi-threaded  loading  of   files.  The  thread that
 2013%   wishes to load the thread first will  do so, while other threads
 2014%   will wait until the leader finished and  than act as if the file
 2015%   is already loaded.
 2016%
 2017%   Synchronisation is handled using  a   message  queue that exists
 2018%   while the file is being loaded.   This synchronisation relies on
 2019%   the fact that thread_get_message/1 throws  an existence_error if
 2020%   the message queue  is  destroyed.  This   is  hacky.  Events  or
 2021%   condition variables would have made a cleaner design.
 2022
 2023:- dynamic
 2024    '$loading_file'/3.              % File, Queue, Thread
 2025:- volatile
 2026    '$loading_file'/3. 2027
 2028'$mt_load_file'(File, FullFile, Module, Options) :-
 2029    current_prolog_flag(threads, true),
 2030    !,
 2031    setup_call_cleanup(
 2032        with_mutex('$load_file',
 2033                   '$mt_start_load'(FullFile, Loading, Options)),
 2034        '$mt_do_load'(Loading, File, FullFile, Module, Options),
 2035        '$mt_end_load'(Loading)).
 2036'$mt_load_file'(File, FullFile, Module, Options) :-
 2037    '$option'(if(If), Options, true),
 2038    '$noload'(If, FullFile, Options),
 2039    !,
 2040    '$already_loaded'(File, FullFile, Module, Options).
 2041'$mt_load_file'(File, FullFile, Module, Options) :-
 2042    '$qdo_load_file'(File, FullFile, Module, Action, Options),
 2043    '$run_initialization'(FullFile, Action, Options).
 2044
 2045'$mt_start_load'(FullFile, queue(Queue), _) :-
 2046    '$loading_file'(FullFile, Queue, LoadThread),
 2047    \+ thread_self(LoadThread),
 2048    !.
 2049'$mt_start_load'(FullFile, already_loaded, Options) :-
 2050    '$option'(if(If), Options, true),
 2051    '$noload'(If, FullFile, Options),
 2052    !.
 2053'$mt_start_load'(FullFile, Ref, _) :-
 2054    thread_self(Me),
 2055    message_queue_create(Queue),
 2056    assertz('$loading_file'(FullFile, Queue, Me), Ref).
 2057
 2058'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
 2059    !,
 2060    catch(thread_get_message(Queue, _), _, true),
 2061    '$already_loaded'(File, FullFile, Module, Options).
 2062'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
 2063    !,
 2064    '$already_loaded'(File, FullFile, Module, Options).
 2065'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
 2066    '$assert_load_context_module'(FullFile, Module, Options),
 2067    '$qdo_load_file'(File, FullFile, Module, Action, Options),
 2068    '$run_initialization'(FullFile, Action, Options).
 2069
 2070'$mt_end_load'(queue(_)) :- !.
 2071'$mt_end_load'(already_loaded) :- !.
 2072'$mt_end_load'(Ref) :-
 2073    clause('$loading_file'(_, Queue, _), _, Ref),
 2074    erase(Ref),
 2075    thread_send_message(Queue, done),
 2076    message_queue_destroy(Queue).
 2077
 2078
 2079%!  '$qdo_load_file'(+Spec, +FullFile, +ContextModule, +Options) is det.
 2080%
 2081%   Switch to qcompile mode if requested by the option '$qlf'(+Out)
 2082
 2083'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
 2084    memberchk('$qlf'(QlfOut), Options),
 2085    !,
 2086    setup_call_cleanup(
 2087        '$qstart'(QlfOut, Module, State),
 2088        '$do_load_file'(File, FullFile, Module, Action, Options),
 2089        '$qend'(State)).
 2090'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
 2091    '$do_load_file'(File, FullFile, Module, Action, Options).
 2092
 2093'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
 2094    '$qlf_open'(Qlf),
 2095    '$compilation_mode'(OldMode, qlf),
 2096    '$set_source_module'(OldModule, Module).
 2097
 2098'$qend'(state(OldMode, OldModule)) :-
 2099    '$set_source_module'(_, OldModule),
 2100    '$set_compilation_mode'(OldMode),
 2101    '$qlf_close'.
 2102
 2103'$set_source_module'(OldModule, Module) :-
 2104    '$current_source_module'(OldModule),
 2105    '$set_source_module'(Module).
 2106
 2107%!  '$do_load_file'(+Spec, +FullFile, +ContextModule,
 2108%!                  -Action, +Options) is det.
 2109%
 2110%   Perform the actual loading.
 2111
 2112'$do_load_file'(File, FullFile, Module, Action, Options) :-
 2113    '$option'(derived_from(DerivedFrom), Options, -),
 2114    '$register_derived_source'(FullFile, DerivedFrom),
 2115    '$qlf_file'(File, FullFile, Absolute, Mode, Options),
 2116    (   Mode == qcompile
 2117    ->  qcompile(Module:File, Options)
 2118    ;   '$do_load_file_2'(File, Absolute, Module, Action, Options)
 2119    ).
 2120
 2121'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
 2122    '$source_file_property'(Absolute, number_of_clauses, OldClauses),
 2123    statistics(cputime, OldTime),
 2124
 2125    '$set_sandboxed_load'(Options, OldSandBoxed),
 2126    '$set_verbose_load'(Options, OldVerbose),
 2127    '$update_autoload_level'(Options, OldAutoLevel),
 2128    '$save_file_scoped_flags'(ScopedFlags),
 2129    set_prolog_flag(xref, false),
 2130
 2131    '$compilation_level'(Level),
 2132    '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
 2133    '$print_message'(StartMsgLevel,
 2134                     load_file(start(Level,
 2135                                     file(File, Absolute)))),
 2136
 2137    (   memberchk(stream(FromStream), Options)
 2138    ->  Input = stream
 2139    ;   Input = source
 2140    ),
 2141
 2142    (   Input == stream,
 2143        (   '$option'(format(qlf), Options, source)
 2144        ->  set_stream(FromStream, file_name(Absolute)),
 2145            '$qload_stream'(FromStream, Module, Action, LM, Options)
 2146        ;   '$consult_file'(stream(Absolute, FromStream, []),
 2147                            Module, Action, LM, Options)
 2148        )
 2149    ->  true
 2150    ;   Input == source,
 2151        file_name_extension(_, Ext, Absolute),
 2152        (   user:prolog_file_type(Ext, qlf)
 2153        ->  '$qload_file'(Absolute, Module, Action, LM, Options)
 2154        ;   '$consult_file'(Absolute, Module, Action, LM, Options)
 2155        )
 2156    ->  true
 2157    ;   print_message(error, load_file(failed(File))),
 2158        fail
 2159    ),
 2160
 2161    '$import_from_loaded_module'(LM, Module, Options),
 2162
 2163    '$source_file_property'(Absolute, number_of_clauses, NewClauses),
 2164    statistics(cputime, Time),
 2165    ClausesCreated is NewClauses - OldClauses,
 2166    TimeUsed is Time - OldTime,
 2167
 2168    '$print_message'(DoneMsgLevel,
 2169                     load_file(done(Level,
 2170                                    file(File, Absolute),
 2171                                    Action,
 2172                                    LM,
 2173                                    TimeUsed,
 2174                                    ClausesCreated))),
 2175    '$set_autoload_level'(OldAutoLevel),
 2176    set_prolog_flag(verbose_load, OldVerbose),
 2177    set_prolog_flag(sandboxed_load, OldSandBoxed),
 2178    '$restore_file_scoped_flags'(ScopedFlags).
 2179
 2180%!  '$save_file_scoped_flags'(-State) is det.
 2181%!  '$restore_file_scoped_flags'(-State) is det.
 2182%
 2183%   Save/restore flags that are scoped to a compilation unit.
 2184
 2185'$save_file_scoped_flags'(State) :-
 2186    current_predicate(findall/3),          % Not when doing boot compile
 2187    !,
 2188    findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
 2189'$save_file_scoped_flags'([]).
 2190
 2191'$save_file_scoped_flag'(Flag-Value) :-
 2192    '$file_scoped_flag'(Flag, Default),
 2193    (   current_prolog_flag(Flag, Value)
 2194    ->  true
 2195    ;   Value = Default
 2196    ).
 2197
 2198'$file_scoped_flag'(generate_debug_info, true).
 2199'$file_scoped_flag'(optimise,            false).
 2200'$file_scoped_flag'(xref,                false).
 2201
 2202'$restore_file_scoped_flags'([]).
 2203'$restore_file_scoped_flags'([Flag-Value|T]) :-
 2204    set_prolog_flag(Flag, Value),
 2205    '$restore_file_scoped_flags'(T).
 2206
 2207
 2208%!  '$import_from_loaded_module'(LoadedModule, Module, Options) is det.
 2209%
 2210%   Import public predicates from LoadedModule into Module
 2211
 2212'$import_from_loaded_module'(LoadedModule, Module, Options) :-
 2213    LoadedModule \== Module,
 2214    atom(LoadedModule),
 2215    !,
 2216    '$option'(imports(Import), Options, all),
 2217    '$option'(reexport(Reexport), Options, false),
 2218    '$import_list'(Module, LoadedModule, Import, Reexport).
 2219'$import_from_loaded_module'(_, _, _).
 2220
 2221
 2222%!  '$set_verbose_load'(+Options, -Old) is det.
 2223%
 2224%   Set the =verbose_load= flag according to   Options and unify Old
 2225%   with the old value.
 2226
 2227'$set_verbose_load'(Options, Old) :-
 2228    current_prolog_flag(verbose_load, Old),
 2229    (   memberchk(silent(Silent), Options)
 2230    ->  (   '$negate'(Silent, Level0)
 2231        ->  '$load_msg_compat'(Level0, Level)
 2232        ;   Level = Silent
 2233        ),
 2234        set_prolog_flag(verbose_load, Level)
 2235    ;   true
 2236    ).
 2237
 2238'$negate'(true, false).
 2239'$negate'(false, true).
 2240
 2241%!  '$set_sandboxed_load'(+Options, -Old) is det.
 2242%
 2243%   Update the Prolog flag  =sandboxed_load=   from  Options. Old is
 2244%   unified with the old flag.
 2245%
 2246%   @error permission_error(leave, sandbox, -)
 2247
 2248'$set_sandboxed_load'(Options, Old) :-
 2249    current_prolog_flag(sandboxed_load, Old),
 2250    (   memberchk(sandboxed(SandBoxed), Options),
 2251        '$enter_sandboxed'(Old, SandBoxed, New),
 2252        New \== Old
 2253    ->  set_prolog_flag(sandboxed_load, New)
 2254    ;   true
 2255    ).
 2256
 2257'$enter_sandboxed'(Old, New, SandBoxed) :-
 2258    (   Old == false, New == true
 2259    ->  SandBoxed = true,
 2260        '$ensure_loaded_library_sandbox'
 2261    ;   Old == true, New == false
 2262    ->  throw(error(permission_error(leave, sandbox, -), _))
 2263    ;   SandBoxed = Old
 2264    ).
 2265'$enter_sandboxed'(false, true, true).
 2266
 2267'$ensure_loaded_library_sandbox' :-
 2268    source_file_property(library(sandbox), module(sandbox)),
 2269    !.
 2270'$ensure_loaded_library_sandbox' :-
 2271    load_files(library(sandbox), [if(not_loaded), silent(true)]).
 2272
 2273
 2274%!  '$update_autoload_level'(+Options, -OldLevel)
 2275%
 2276%   Update the '$autoload_nesting' and return the old value.
 2277
 2278:- thread_local
 2279    '$autoload_nesting'/1. 2280
 2281'$update_autoload_level'(Options, AutoLevel) :-
 2282    '$option'(autoload(Autoload), Options, false),
 2283    (   '$autoload_nesting'(CurrentLevel)
 2284    ->  AutoLevel = CurrentLevel
 2285    ;   AutoLevel = 0
 2286    ),
 2287    (   Autoload == false
 2288    ->  true
 2289    ;   NewLevel is AutoLevel + 1,
 2290        '$set_autoload_level'(NewLevel)
 2291    ).
 2292
 2293'$set_autoload_level'(New) :-
 2294    retractall('$autoload_nesting'(_)),
 2295    asserta('$autoload_nesting'(New)).
 2296
 2297
 2298%!  '$print_message'(+Level, +Term) is det.
 2299%
 2300%   As print_message/2, but deal with  the   fact  that  the message
 2301%   system might not yet be loaded.
 2302
 2303'$print_message'(Level, Term) :-
 2304    current_predicate(system:print_message/2),
 2305    !,
 2306    print_message(Level, Term).
 2307'$print_message'(warning, Term) :-
 2308    source_location(File, Line),
 2309    !,
 2310    format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
 2311'$print_message'(error, Term) :-
 2312    !,
 2313    source_location(File, Line),
 2314    !,
 2315    format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
 2316'$print_message'(_Level, _Term).
 2317
 2318'$print_message_fail'(E) :-
 2319    '$print_message'(error, E),
 2320    fail.
 2321
 2322%!  '$consult_file'(+Path, +Module, -Action, -LoadedIn, +Options)
 2323%
 2324%   Called  from  '$do_load_file'/4  using  the   goal  returned  by
 2325%   '$consult_goal'/2. This means that the  calling conventions must
 2326%   be kept synchronous with '$qload_file'/6.
 2327
 2328'$consult_file'(Absolute, Module, What, LM, Options) :-
 2329    '$current_source_module'(Module),   % same module
 2330    !,
 2331    '$consult_file_2'(Absolute, Module, What, LM, Options).
 2332'$consult_file'(Absolute, Module, What, LM, Options) :-
 2333    '$set_source_module'(OldModule, Module),
 2334    '$ifcompiling'('$qlf_start_sub_module'(Module)),
 2335    '$consult_file_2'(Absolute, Module, What, LM, Options),
 2336    '$ifcompiling'('$qlf_end_part'),
 2337    '$set_source_module'(OldModule).
 2338
 2339'$consult_file_2'(Absolute, Module, What, LM, Options) :-
 2340    '$set_source_module'(OldModule, Module),
 2341    '$load_id'(Absolute, Id, Modified, Options),
 2342    '$start_consult'(Id, Modified),
 2343    (   '$derived_source'(Absolute, DerivedFrom, _)
 2344    ->  '$modified_id'(DerivedFrom, DerivedModified, Options),
 2345        '$start_consult'(DerivedFrom, DerivedModified)
 2346    ;   true
 2347    ),
 2348    '$compile_type'(What),
 2349    '$save_lex_state'(LexState, Options),
 2350    '$set_dialect'(Options),
 2351    call_cleanup('$load_file'(Absolute, Id, LM, Options),
 2352                 '$end_consult'(LexState, OldModule)).
 2353
 2354'$end_consult'(LexState, OldModule) :-
 2355    '$restore_lex_state'(LexState),
 2356    '$set_source_module'(OldModule).
 2357
 2358
 2359:- create_prolog_flag(emulated_dialect, swi, [type(atom)]). 2360
 2361%!  '$save_lex_state'(-LexState, +Options) is det.
 2362
 2363'$save_lex_state'(State, Options) :-
 2364    memberchk(scope_settings(false), Options),
 2365    !,
 2366    State = (-).
 2367'$save_lex_state'(lexstate(Style, Dialect), _) :-
 2368    '$style_check'(Style, Style),
 2369    current_prolog_flag(emulated_dialect, Dialect).
 2370
 2371'$restore_lex_state'(-) :- !.
 2372'$restore_lex_state'(lexstate(Style, Dialect)) :-
 2373    '$style_check'(_, Style),
 2374    set_prolog_flag(emulated_dialect, Dialect).
 2375
 2376'$set_dialect'(Options) :-
 2377    memberchk(dialect(Dialect), Options),
 2378    !,
 2379    expects_dialect(Dialect).               % Autoloaded from library
 2380'$set_dialect'(_).
 2381
 2382'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
 2383    !,
 2384    '$modified_id'(Id, Modified, Options).
 2385'$load_id'(Id, Id, Modified, Options) :-
 2386    '$modified_id'(Id, Modified, Options).
 2387
 2388'$modified_id'(_, Modified, Options) :-
 2389    '$option'(modified(Stamp), Options, Def),
 2390    Stamp \== Def,
 2391    !,
 2392    Modified = Stamp.
 2393'$modified_id'(Id, Modified, _) :-
 2394    exists_file(Id),
 2395    !,
 2396    time_file(Id, Modified).
 2397'$modified_id'(_, 0.0, _).
 2398
 2399
 2400'$compile_type'(What) :-
 2401    '$compilation_mode'(How),
 2402    (   How == database
 2403    ->  What = compiled
 2404    ;   How == qlf
 2405    ->  What = '*qcompiled*'
 2406    ;   What = 'boot compiled'
 2407    ).
 2408
 2409%!  '$assert_load_context_module'(+File, -Module, -Options)
 2410%
 2411%   Record the module a file was loaded from (see make/0). The first
 2412%   clause deals with loading from  another   file.  On reload, this
 2413%   clause will be discarded by  $start_consult/1. The second clause
 2414%   deals with reload from the toplevel.   Here  we avoid creating a
 2415%   duplicate dynamic (i.e., not related to a source) clause.
 2416
 2417:- dynamic
 2418    '$load_context_module'/3. 2419:- multifile
 2420    '$load_context_module'/3. 2421
 2422'$assert_load_context_module'(_, _, Options) :-
 2423    memberchk(register(false), Options),
 2424    !.
 2425'$assert_load_context_module'(File, Module, Options) :-
 2426    source_location(FromFile, Line),
 2427    !,
 2428    '$master_file'(FromFile, MasterFile),
 2429    '$check_load_non_module'(File, Module),
 2430    '$add_dialect'(Options, Options1),
 2431    '$load_ctx_options'(Options1, Options2),
 2432    '$store_admin_clause'(
 2433        system:'$load_context_module'(File, Module, Options2),
 2434        _Layout, MasterFile, FromFile:Line).
 2435'$assert_load_context_module'(File, Module, Options) :-
 2436    '$check_load_non_module'(File, Module),
 2437    '$add_dialect'(Options, Options1),
 2438    '$load_ctx_options'(Options1, Options2),
 2439    (   clause('$load_context_module'(File, Module, _), true, Ref),
 2440        \+ clause_property(Ref, file(_)),
 2441        erase(Ref)
 2442    ->  true
 2443    ;   true
 2444    ),
 2445    assertz('$load_context_module'(File, Module, Options2)).
 2446
 2447'$add_dialect'(Options0, Options) :-
 2448    current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
 2449    !,
 2450    Options = [dialect(Dialect)|Options0].
 2451'$add_dialect'(Options, Options).
 2452
 2453%!  '$load_ctx_options'(+Options, -CtxOptions) is det.
 2454%
 2455%   Select the load options that  determine   the  load semantics to
 2456%   perform a proper reload. Delete the others.
 2457
 2458'$load_ctx_options'([], []).
 2459'$load_ctx_options'([H|T0], [H|T]) :-
 2460    '$load_ctx_option'(H),
 2461    !,
 2462    '$load_ctx_options'(T0, T).
 2463'$load_ctx_options'([_|T0], T) :-
 2464    '$load_ctx_options'(T0, T).
 2465
 2466'$load_ctx_option'(derived_from(_)).
 2467'$load_ctx_option'(dialect(_)).
 2468'$load_ctx_option'(encoding(_)).
 2469'$load_ctx_option'(imports(_)).
 2470'$load_ctx_option'(reexport(_)).
 2471
 2472
 2473%!  '$check_load_non_module'(+File) is det.
 2474%
 2475%   Test  that  a  non-module  file  is  not  loaded  into  multiple
 2476%   contexts.
 2477
 2478'$check_load_non_module'(File, _) :-
 2479    '$current_module'(_, File),
 2480    !.          % File is a module file
 2481'$check_load_non_module'(File, Module) :-
 2482    '$load_context_module'(File, OldModule, _),
 2483    Module \== OldModule,
 2484    !,
 2485    format(atom(Msg),
 2486           'Non-module file already loaded into module ~w; \c
 2487               trying to load into ~w',
 2488           [OldModule, Module]),
 2489    throw(error(permission_error(load, source, File),
 2490                context(load_files/2, Msg))).
 2491'$check_load_non_module'(_, _).
 2492
 2493%!  '$load_file'(+Path, +Id, -Module, +Options)
 2494%
 2495%   '$load_file'/4 does the actual loading.
 2496%
 2497%   state(FirstTerm:boolean,
 2498%         Module:atom,
 2499%         AtEnd:atom,
 2500%         Stop:boolean,
 2501%         Id:atom,
 2502%         Dialect:atom)
 2503
 2504'$load_file'(Path, Id, Module, Options) :-
 2505    State = state(true, _, true, false, Id, -),
 2506    (   '$source_term'(Path, _Read, _Layout, Term, Layout,
 2507                       _Stream, Options),
 2508        '$valid_term'(Term),
 2509        (   arg(1, State, true)
 2510        ->  '$first_term'(Term, Layout, Id, State, Options),
 2511            nb_setarg(1, State, false)
 2512        ;   '$compile_term'(Term, Layout, Id)
 2513        ),
 2514        arg(4, State, true)
 2515    ;   '$end_load_file'(State)
 2516    ),
 2517    !,
 2518    arg(2, State, Module).
 2519
 2520'$valid_term'(Var) :-
 2521    var(Var),
 2522    !,
 2523    print_message(error, error(instantiation_error, _)).
 2524'$valid_term'(Term) :-
 2525    Term \== [].
 2526
 2527'$end_load_file'(State) :-
 2528    arg(1, State, true),           % empty file
 2529    !,
 2530    nb_setarg(2, State, Module),
 2531    arg(5, State, Id),
 2532    '$current_source_module'(Module),
 2533    '$ifcompiling'('$qlf_start_file'(Id)),
 2534    '$ifcompiling'('$qlf_end_part').
 2535'$end_load_file'(State) :-
 2536    arg(3, State, End),
 2537    '$end_load_file'(End, State).
 2538
 2539'$end_load_file'(true, _).
 2540'$end_load_file'(end_module, State) :-
 2541    arg(2, State, Module),
 2542    '$check_export'(Module),
 2543    '$ifcompiling'('$qlf_end_part').
 2544'$end_load_file'(end_non_module, _State) :-
 2545    '$ifcompiling'('$qlf_end_part').
 2546
 2547
 2548'$first_term'(?-(Directive), Layout, Id, State, Options) :-
 2549    !,
 2550    '$first_term'(:-(Directive), Layout, Id, State, Options).
 2551'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
 2552    nonvar(Directive),
 2553    (   (   Directive = module(Name, Public)
 2554        ->  Imports = []
 2555        ;   Directive = module(Name, Public, Imports)
 2556        )
 2557    ->  !,
 2558        '$module_name'(Name, Id, Module, Options),
 2559        '$start_module'(Module, Public, State, Options),
 2560        '$module3'(Imports)
 2561    ;   Directive = expects_dialect(Dialect)
 2562    ->  !,
 2563        '$set_dialect'(Dialect, State),
 2564        fail                        % Still consider next term as first
 2565    ).
 2566'$first_term'(Term, Layout, Id, State, Options) :-
 2567    '$start_non_module'(Id, State, Options),
 2568    '$compile_term'(Term, Layout, Id).
 2569
 2570'$compile_term'(Term, Layout, Id) :-
 2571    '$compile_term'(Term, Layout, Id, -).
 2572
 2573'$compile_term'(Var, _Layout, _Id, _Src) :-
 2574    var(Var),
 2575    !,
 2576    '$instantiation_error'(Var).
 2577'$compile_term'((?-Directive), _Layout, Id, _) :-
 2578    !,
 2579    '$execute_directive'(Directive, Id).
 2580'$compile_term'((:-Directive), _Layout, Id, _) :-
 2581    !,
 2582    '$execute_directive'(Directive, Id).
 2583'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :-
 2584    !,
 2585    '$compile_term'(Term, Layout, Id, File:Line).
 2586'$compile_term'(Clause, Layout, Id, SrcLoc) :-
 2587    catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
 2588          '$print_message'(error, E)).
 2589
 2590'$start_non_module'(Id, _State, Options) :-
 2591    '$option'(must_be_module(true), Options, false),
 2592    !,
 2593    throw(error(domain_error(module_file, Id), _)).
 2594'$start_non_module'(Id, State, _Options) :-
 2595    '$current_source_module'(Module),
 2596    '$ifcompiling'('$qlf_start_file'(Id)),
 2597    '$qset_dialect'(State),
 2598    nb_setarg(2, State, Module),
 2599    nb_setarg(3, State, end_non_module).
 2600
 2601%!  '$set_dialect'(+Dialect, +State)
 2602%
 2603%   Sets the expected dialect. This is difficult if we are compiling
 2604%   a .qlf file using qcompile/1 because   the file is already open,
 2605%   while we are looking for the first term to decide wether this is
 2606%   a module or not. We save the   dialect  and set it after opening
 2607%   the file or module.
 2608%
 2609%   Note that expects_dialect/1 itself may   be  autoloaded from the
 2610%   library.
 2611
 2612'$set_dialect'(Dialect, State) :-
 2613    '$compilation_mode'(qlf, database),
 2614    !,
 2615    expects_dialect(Dialect),
 2616    '$compilation_mode'(_, qlf),
 2617    nb_setarg(6, State, Dialect).
 2618'$set_dialect'(Dialect, _) :-
 2619    expects_dialect(Dialect).
 2620
 2621'$qset_dialect'(State) :-
 2622    '$compilation_mode'(qlf),
 2623    arg(6, State, Dialect), Dialect \== (-),
 2624    !,
 2625    '$add_directive_wic'(expects_dialect(Dialect)).
 2626'$qset_dialect'(_).
 2627
 2628
 2629                 /*******************************
 2630                 *           MODULES            *
 2631                 *******************************/
 2632
 2633'$start_module'(Module, _Public, State, _Options) :-
 2634    '$current_module'(Module, OldFile),
 2635    source_location(File, _Line),
 2636    OldFile \== File, OldFile \== [],
 2637    same_file(OldFile, File),
 2638    !,
 2639    nb_setarg(2, State, Module),
 2640    nb_setarg(4, State, true).      % Stop processing
 2641'$start_module'(Module, Public, State, Options) :-
 2642    arg(5, State, File),
 2643    nb_setarg(2, State, Module),
 2644    source_location(_File, Line),
 2645    '$option'(redefine_module(Action), Options, false),
 2646    '$module_class'(File, Class, Super),
 2647    '$redefine_module'(Module, File, Action),
 2648    '$declare_module'(Module, Class, Super, File, Line, false),
 2649    '$export_list'(Public, Module, Ops),
 2650    '$ifcompiling'('$qlf_start_module'(Module)),
 2651    '$export_ops'(Ops, Module, File),
 2652    '$qset_dialect'(State),
 2653    nb_setarg(3, State, end_module).
 2654
 2655
 2656%!  '$module3'(+Spec) is det.
 2657%
 2658%   Handle the 3th argument of a module declartion.
 2659
 2660'$module3'(Var) :-
 2661    var(Var),
 2662    !,
 2663    '$instantiation_error'(Var).
 2664'$module3'([]) :- !.
 2665'$module3'([H|T]) :-
 2666    !,
 2667    '$module3'(H),
 2668    '$module3'(T).
 2669'$module3'(Id) :-
 2670    use_module(library(dialect/Id)).
 2671
 2672%!  '$module_name'(?Name, +Id, -Module, +Options) is semidet.
 2673%
 2674%   Determine the module name.  There are some cases:
 2675%
 2676%     - Option module(Module) is given.  In that case, use this
 2677%       module and if Module is the load context, ignore the module
 2678%       header.
 2679%     - The initial name is unbound.  Use the base name of the
 2680%       source identifier (normally the file name).  Compatibility
 2681%       to Ciao.  This might change; I think it is wiser to use
 2682%       the full unique source identifier.
 2683
 2684'$module_name'(_, _, Module, Options) :-
 2685    '$option'(module(Module), Options),
 2686    !,
 2687    '$current_source_module'(Context),
 2688    Context \== Module.                     % cause '$first_term'/5 to fail.
 2689'$module_name'(Var, Id, Module, Options) :-
 2690    var(Var),
 2691    !,
 2692    file_base_name(Id, File),
 2693    file_name_extension(Var, _, File),
 2694    '$module_name'(Var, Id, Module, Options).
 2695'$module_name'(Reserved, _, _, _) :-
 2696    '$reserved_module'(Reserved),
 2697    !,
 2698    throw(error(permission_error(load, module, Reserved), _)).
 2699'$module_name'(Module, _Id, Module, _).
 2700
 2701
 2702'$reserved_module'(system).
 2703'$reserved_module'(user).
 2704
 2705
 2706%!  '$redefine_module'(+Module, +File, -Redefine)
 2707
 2708'$redefine_module'(_Module, _, false) :- !.
 2709'$redefine_module'(Module, File, true) :-
 2710    !,
 2711    (   module_property(Module, file(OldFile)),
 2712        File \== OldFile
 2713    ->  unload_file(OldFile)
 2714    ;   true
 2715    ).
 2716'$redefine_module'(Module, File, ask) :-
 2717    (   stream_property(user_input, tty(true)),
 2718        module_property(Module, file(OldFile)),
 2719        File \== OldFile,
 2720        '$rdef_response'(Module, OldFile, File, true)
 2721    ->  '$redefine_module'(Module, File, true)
 2722    ;   true
 2723    ).
 2724
 2725'$rdef_response'(Module, OldFile, File, Ok) :-
 2726    repeat,
 2727    print_message(query, redefine_module(Module, OldFile, File)),
 2728    get_single_char(Char),
 2729    '$rdef_response'(Char, Ok0),
 2730    !,
 2731    Ok = Ok0.
 2732
 2733'$rdef_response'(Char, true) :-
 2734    memberchk(Char, "yY"),
 2735    format(user_error, 'yes~n', []).
 2736'$rdef_response'(Char, false) :-
 2737    memberchk(Char, "nN"),
 2738    format(user_error, 'no~n', []).
 2739'$rdef_response'(Char, _) :-
 2740    memberchk(Char, "a"),
 2741    format(user_error, 'abort~n', []),
 2742    abort.
 2743'$rdef_response'(_, _) :-
 2744    print_message(help, redefine_module_reply),
 2745    fail.
 2746
 2747
 2748%!  '$module_class'(+File, -Class, -Super) is det.
 2749%
 2750%   Determine the initial module from which   I  inherit. All system
 2751%   and library modules inherit from =system=, while all normal user
 2752%   modules inherit from =user=.
 2753
 2754'$module_class'(File, Class, system) :-
 2755    current_prolog_flag(home, Home),
 2756    sub_atom(File, 0, Len, _, Home),
 2757    !,
 2758    (   sub_atom(File, Len, _, _, '/boot/')
 2759    ->  Class = system
 2760    ;   Class = library
 2761    ).
 2762'$module_class'(_, user, user).
 2763
 2764'$check_export'(Module) :-
 2765    '$undefined_export'(Module, UndefList),
 2766    (   '$member'(Undef, UndefList),
 2767        strip_module(Undef, _, Local),
 2768        print_message(error,
 2769                      undefined_export(Module, Local)),
 2770        fail
 2771    ;   true
 2772    ).
 2773
 2774
 2775%!  '$import_list'(+TargetModule, +FromModule, +Import, +Reexport) is det.
 2776%
 2777%   Import from FromModule to TargetModule. Import  is one of =all=,
 2778%   a list of optionally  mapped  predicate   indicators  or  a term
 2779%   except(Import).
 2780
 2781'$import_list'(_, _, Var, _) :-
 2782    var(Var),
 2783    !,
 2784    throw(error(instantitation_error, _)).
 2785'$import_list'(Target, Source, all, Reexport) :-
 2786    !,
 2787    '$exported_ops'(Source, Import, Predicates),
 2788    '$module_property'(Source, exports(Predicates)),
 2789    '$import_all'(Import, Target, Source, Reexport, weak).
 2790'$import_list'(Target, Source, except(Spec), Reexport) :-
 2791    !,
 2792    '$exported_ops'(Source, Export, Predicates),
 2793    '$module_property'(Source, exports(Predicates)),
 2794    (   is_list(Spec)
 2795    ->  true
 2796    ;   throw(error(type_error(list, Spec), _))
 2797    ),
 2798    '$import_except'(Spec, Export, Import),
 2799    '$import_all'(Import, Target, Source, Reexport, weak).
 2800'$import_list'(Target, Source, Import, Reexport) :-
 2801    !,
 2802    is_list(Import),
 2803    !,
 2804    '$import_all'(Import, Target, Source, Reexport, strong).
 2805'$import_list'(_, _, Import, _) :-
 2806    throw(error(type_error(import_specifier, Import))).
 2807
 2808
 2809'$import_except'([], List, List).
 2810'$import_except'([H|T], List0, List) :-
 2811    '$import_except_1'(H, List0, List1),
 2812    '$import_except'(T, List1, List).
 2813
 2814'$import_except_1'(Var, _, _) :-
 2815    var(Var),
 2816    !,
 2817    throw(error(instantitation_error, _)).
 2818'$import_except_1'(PI as N, List0, List) :-
 2819    '$pi'(PI), atom(N),
 2820    !,
 2821    '$canonical_pi'(PI, CPI),
 2822    '$import_as'(CPI, N, List0, List).
 2823'$import_except_1'(op(P,A,N), List0, List) :-
 2824    !,
 2825    '$remove_ops'(List0, op(P,A,N), List).
 2826'$import_except_1'(PI, List0, List) :-
 2827    '$pi'(PI),
 2828    !,
 2829    '$canonical_pi'(PI, CPI),
 2830    '$select'(P, List0, List),
 2831    '$canonical_pi'(CPI, P),
 2832    !.
 2833'$import_except_1'(Except, _, _) :-
 2834    throw(error(type_error(import_specifier, Except), _)).
 2835
 2836'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
 2837    '$canonical_pi'(PI2, CPI),
 2838    !.
 2839'$import_as'(PI, N, [H|T0], [H|T]) :-
 2840    !,
 2841    '$import_as'(PI, N, T0, T).
 2842'$import_as'(PI, _, _, _) :-
 2843    throw(error(existence_error(export, PI), _)).
 2844
 2845'$pi'(N/A) :- atom(N), integer(A), !.
 2846'$pi'(N//A) :- atom(N), integer(A).
 2847
 2848'$canonical_pi'(N//A0, N/A) :-
 2849    A is A0 + 2.
 2850'$canonical_pi'(PI, PI).
 2851
 2852'$remove_ops'([], _, []).
 2853'$remove_ops'([Op|T0], Pattern, T) :-
 2854    subsumes_term(Pattern, Op),
 2855    !,
 2856    '$remove_ops'(T0, Pattern, T).
 2857'$remove_ops'([H|T0], Pattern, [H|T]) :-
 2858    '$remove_ops'(T0, Pattern, T).
 2859
 2860
 2861%!  '$import_all'(+Import, +Context, +Source, +Reexport, +Strength)
 2862
 2863'$import_all'(Import, Context, Source, Reexport, Strength) :-
 2864    '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
 2865    (   Reexport == true,
 2866        (   '$list_to_conj'(Imported, Conj)
 2867        ->  export(Context:Conj),
 2868            '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
 2869        ;   true
 2870        ),
 2871        source_location(File, _Line),
 2872        '$export_ops'(ImpOps, Context, File)
 2873    ;   true
 2874    ).
 2875
 2876%!  '$import_all2'(+Imports, +Context, +Source, -Imported, -ImpOps, +Strength)
 2877
 2878'$import_all2'([], _, _, [], [], _).
 2879'$import_all2'([PI as NewName|Rest], Context, Source,
 2880               [NewName/Arity|Imported], ImpOps, Strength) :-
 2881    !,
 2882    '$canonical_pi'(PI, Name/Arity),
 2883    length(Args, Arity),
 2884    Head =.. [Name|Args],
 2885    NewHead =.. [NewName|Args],
 2886    (   '$get_predicate_attribute'(Source:Head, transparent, 1)
 2887    ->  '$set_predicate_attribute'(Context:NewHead, transparent, true)
 2888    ;   true
 2889    ),
 2890    (   source_location(File, Line)
 2891    ->  catch('$store_admin_clause'((NewHead :- Source:Head),
 2892                                    _Layout, File, File:Line),
 2893              E, '$print_message'(error, E))
 2894    ;   assertz((NewHead :- !, Source:Head)) % ! avoids problems with
 2895    ),                                       % duplicate load
 2896    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 2897'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
 2898               [op(P,A,N)|ImpOps], Strength) :-
 2899    !,
 2900    '$import_ops'(Context, Source, op(P,A,N)),
 2901    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 2902'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
 2903    catch(Context:'$import'(Source:Pred, Strength), Error,
 2904          print_message(error, Error)),
 2905    '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
 2906    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
 2907
 2908
 2909'$list_to_conj'([One], One) :- !.
 2910'$list_to_conj'([H|T], (H,Rest)) :-
 2911    '$list_to_conj'(T, Rest).
 2912
 2913%!  '$exported_ops'(+Module, -Ops, ?Tail) is det.
 2914%
 2915%   Ops is a list of op(P,A,N) terms representing the operators
 2916%   exported from Module.
 2917
 2918'$exported_ops'(Module, Ops, Tail) :-
 2919    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 2920    !,
 2921    findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
 2922'$exported_ops'(_, Ops, Ops).
 2923
 2924'$exported_op'(Module, P, A, N) :-
 2925    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
 2926    Module:'$exported_op'(P, A, N).
 2927
 2928%!  '$import_ops'(+Target, +Source, +Pattern)
 2929%
 2930%   Import the operators export from Source into the module table of
 2931%   Target.  We only import operators that unify with Pattern.
 2932
 2933'$import_ops'(To, From, Pattern) :-
 2934    ground(Pattern),
 2935    !,
 2936    Pattern = op(P,A,N),
 2937    op(P,A,To:N),
 2938    (   '$exported_op'(From, P, A, N)
 2939    ->  true
 2940    ;   print_message(warning, no_exported_op(From, Pattern))
 2941    ).
 2942'$import_ops'(To, From, Pattern) :-
 2943    (   '$exported_op'(From, Pri, Assoc, Name),
 2944        Pattern = op(Pri, Assoc, Name),
 2945        op(Pri, Assoc, To:Name),
 2946        fail
 2947    ;   true
 2948    ).
 2949
 2950
 2951%!  '$export_list'(+Declarations, +Module, -Ops)
 2952%
 2953%   Handle the export list of the module declaration for Module
 2954%   associated to File.
 2955
 2956'$export_list'(Decls, Module, Ops) :-
 2957    is_list(Decls),
 2958    !,
 2959    '$do_export_list'(Decls, Module, Ops).
 2960'$export_list'(Decls, _, _) :-
 2961    var(Decls),
 2962    throw(error(instantiation_error, _)).
 2963'$export_list'(Decls, _, _) :-
 2964    throw(error(type_error(list, Decls), _)).
 2965
 2966'$do_export_list'([], _, []) :- !.
 2967'$do_export_list'([H|T], Module, Ops) :-
 2968    !,
 2969    catch('$export1'(H, Module, Ops, Ops1),
 2970          E, ('$print_message'(error, E), Ops = Ops1)),
 2971    '$do_export_list'(T, Module, Ops1).
 2972
 2973'$export1'(Var, _, _, _) :-
 2974    var(Var),
 2975    !,
 2976    throw(error(instantiation_error, _)).
 2977'$export1'(Op, _, [Op|T], T) :-
 2978    Op = op(_,_,_),
 2979    !.
 2980'$export1'(PI, Module, Ops, Ops) :-
 2981    export(Module:PI).
 2982
 2983'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
 2984    catch(( op(Pri, Assoc, Module:Name),
 2985            '$export_op'(Pri, Assoc, Name, Module, File)
 2986          ),
 2987          E, '$print_message'(error, E)),
 2988    '$export_ops'(T, Module, File).
 2989'$export_ops'([], _, _).
 2990
 2991'$export_op'(Pri, Assoc, Name, Module, File) :-
 2992    (   '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
 2993    ->  true
 2994    ;   '$execute_directive'(discontiguous(Module:'$exported_op'/3), File)
 2995    ),
 2996    '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
 2997
 2998%!  '$execute_directive'(:Goal, +File) is det.
 2999%
 3000%   Execute the argument of :- or ?- while loading a file.
 3001
 3002'$execute_directive'(Goal, F) :-
 3003    '$execute_directive_2'(Goal, F).
 3004
 3005'$execute_directive_2'(encoding(Encoding), _F) :-
 3006    !,
 3007    (   '$load_input'(_F, S)
 3008    ->  set_stream(S, encoding(Encoding))
 3009    ).
 3010'$execute_directive_2'(ISO, F) :-
 3011    '$expand_directive'(ISO, Normal),
 3012    !,
 3013    '$execute_directive'(Normal, F).
 3014'$execute_directive_2'(Goal, _) :-
 3015    \+ '$compilation_mode'(database),
 3016    !,
 3017    '$add_directive_wic2'(Goal, Type),
 3018    (   Type == call                % suspend compiling into .qlf file
 3019    ->  '$compilation_mode'(Old, database),
 3020        setup_call_cleanup(
 3021            '$directive_mode'(OldDir, Old),
 3022            '$execute_directive_3'(Goal),
 3023            ( '$set_compilation_mode'(Old),
 3024              '$set_directive_mode'(OldDir)
 3025            ))
 3026    ;   '$execute_directive_3'(Goal)
 3027    ).
 3028'$execute_directive_2'(Goal, _) :-
 3029    '$execute_directive_3'(Goal).
 3030
 3031'$execute_directive_3'(Goal) :-
 3032    '$current_source_module'(Module),
 3033    '$valid_directive'(Module:Goal),
 3034    !,
 3035    (   '$pattr_directive'(Goal, Module)
 3036    ->  true
 3037    ;   catch(Module:Goal, Term, '$exception_in_directive'(Term))
 3038    ->  true
 3039    ;   print_message(warning, goal_failed(directive, Module:Goal)),
 3040        fail
 3041    ).
 3042'$execute_directive_3'(_).
 3043
 3044
 3045%!  '$valid_directive'(:Directive) is det.
 3046%
 3047%   If   the   flag   =sandboxed_load=   is   =true=,   this   calls
 3048%   prolog:sandbox_allowed_directive/1. This call can deny execution
 3049%   of the directive by throwing an exception.
 3050
 3051:- multifile prolog:sandbox_allowed_directive/1. 3052:- multifile prolog:sandbox_allowed_clause/1. 3053:- meta_predicate '$valid_directive'(:). 3054
 3055'$valid_directive'(_) :-
 3056    current_prolog_flag(sandboxed_load, false),
 3057    !.
 3058'$valid_directive'(Goal) :-
 3059    catch(prolog:sandbox_allowed_directive(Goal), Error, true),
 3060    !,
 3061    (   var(Error)
 3062    ->  true
 3063    ;   print_message(error, Error),
 3064        fail
 3065    ).
 3066'$valid_directive'(Goal) :-
 3067    print_message(error,
 3068                  error(permission_error(execute,
 3069                                         sandboxed_directive,
 3070                                         Goal), _)),
 3071    fail.
 3072
 3073'$exception_in_directive'(Term) :-
 3074    print_message(error, Term),
 3075    fail.
 3076
 3077%       This predicate deals with the very odd ISO requirement to allow
 3078%       for :- dynamic(a/2, b/3, c/4) instead of the normally used
 3079%       :- dynamic a/2, b/3, c/4 or, if operators are not desirable,
 3080%       :- dynamic((a/2, b/3, c/4)).
 3081
 3082'$expand_directive'(Directive, Expanded) :-
 3083    functor(Directive, Name, Arity),
 3084    Arity > 1,
 3085    '$iso_property_directive'(Name),
 3086    Directive =.. [Name|Args],
 3087    '$mk_normal_args'(Args, Normal),
 3088    Expanded =.. [Name, Normal].
 3089
 3090'$iso_property_directive'(dynamic).
 3091'$iso_property_directive'(multifile).
 3092'$iso_property_directive'(discontiguous).
 3093
 3094'$mk_normal_args'([One], One).
 3095'$mk_normal_args'([H|T0], (H,T)) :-
 3096    '$mk_normal_args'(T0, T).
 3097
 3098
 3099%       Note that the list, consult and ensure_loaded directives are already
 3100%       handled at compile time and therefore should not go into the
 3101%       intermediate code file.
 3102
 3103'$add_directive_wic2'(Goal, Type) :-
 3104    '$common_goal_type'(Goal, Type),
 3105    !,
 3106    (   Type == load
 3107    ->  true
 3108    ;   '$current_source_module'(Module),
 3109        '$add_directive_wic'(Module:Goal)
 3110    ).
 3111'$add_directive_wic2'(Goal, _) :-
 3112    (   '$compilation_mode'(qlf)    % no problem for qlf files
 3113    ->  true
 3114    ;   print_message(error, mixed_directive(Goal))
 3115    ).
 3116
 3117'$common_goal_type'((A,B), Type) :-
 3118    !,
 3119    '$common_goal_type'(A, Type),
 3120    '$common_goal_type'(B, Type).
 3121'$common_goal_type'((A;B), Type) :-
 3122    !,
 3123    '$common_goal_type'(A, Type),
 3124    '$common_goal_type'(B, Type).
 3125'$common_goal_type'((A->B), Type) :-
 3126    !,
 3127    '$common_goal_type'(A, Type),
 3128    '$common_goal_type'(B, Type).
 3129'$common_goal_type'(Goal, Type) :-
 3130    '$goal_type'(Goal, Type).
 3131
 3132'$goal_type'(Goal, Type) :-
 3133    (   '$load_goal'(Goal)
 3134    ->  Type = load
 3135    ;   Type = call
 3136    ).
 3137
 3138'$load_goal'([_|_]).
 3139'$load_goal'(consult(_)).
 3140'$load_goal'(load_files(_)).
 3141'$load_goal'(load_files(_,Options)) :-
 3142    memberchk(qcompile(QlfMode), Options),
 3143    '$qlf_part_mode'(QlfMode).
 3144'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic).
 3145'$load_goal'(use_module(_))    :- '$compilation_mode'(wic).
 3146'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic).
 3147
 3148'$qlf_part_mode'(part).
 3149'$qlf_part_mode'(true).                 % compatibility
 3150
 3151
 3152                /********************************
 3153                *        COMPILE A CLAUSE       *
 3154                *********************************/
 3155
 3156%!  '$store_admin_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3157%
 3158%   Store a clause into the   database  for administrative purposes.
 3159%   This bypasses sanity checking.
 3160
 3161'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :-
 3162    Owner \== (-),
 3163    !,
 3164    setup_call_cleanup(
 3165        '$start_aux'(Owner, Context),
 3166        '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc),
 3167        '$end_aux'(Owner, Context)).
 3168'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
 3169    '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
 3170
 3171'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
 3172    (   '$compilation_mode'(database)
 3173    ->  '$record_clause'(Clause, File, SrcLoc)
 3174    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3175        '$qlf_assert_clause'(Ref, development)
 3176    ).
 3177
 3178%!  '$store_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
 3179%
 3180%   Store a clause into the database.
 3181%
 3182%   @arg    Owner is the file-id that owns the clause
 3183%   @arg    SrcLoc is the file:line term where the clause
 3184%           originates from.
 3185
 3186'$store_clause'((_, _), _, _, _) :-
 3187    !,
 3188    print_message(error, cannot_redefine_comma),
 3189    fail.
 3190'$store_clause'(Clause, _Layout, File, SrcLoc) :-
 3191    '$valid_clause'(Clause),
 3192    !,
 3193    (   '$compilation_mode'(database)
 3194    ->  '$record_clause'(Clause, File, SrcLoc)
 3195    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
 3196        '$qlf_assert_clause'(Ref, development)
 3197    ).
 3198
 3199'$valid_clause'(_) :-
 3200    current_prolog_flag(sandboxed_load, false),
 3201    !.
 3202'$valid_clause'(Clause) :-
 3203    \+ '$cross_module_clause'(Clause),
 3204    !.
 3205'$valid_clause'(Clause) :-
 3206    catch(prolog:sandbox_allowed_clause(Clause), Error, true),
 3207    !,
 3208    (   var(Error)
 3209    ->  true
 3210    ;   print_message(error, Error),
 3211        fail
 3212    ).
 3213'$valid_clause'(Clause) :-
 3214    print_message(error,
 3215                  error(permission_error(assert,
 3216                                         sandboxed_clause,
 3217                                         Clause), _)),
 3218    fail.
 3219
 3220'$cross_module_clause'(Clause) :-
 3221    '$head_module'(Clause, Module),
 3222    \+ '$current_source_module'(Module).
 3223
 3224'$head_module'(Var, _) :-
 3225    var(Var), !, fail.
 3226'$head_module'((Head :- _), Module) :-
 3227    '$head_module'(Head, Module).
 3228'$head_module'(Module:_, Module).
 3229
 3230'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
 3231'$clause_source'(Clause, Clause, -).
 3232
 3233%!  '$store_clause'(+Term, +Id) is det.
 3234%
 3235%   This interface is used by PlDoc (and who knows).  Kept for to avoid
 3236%   compatibility issues.
 3237
 3238:- public
 3239    '$store_clause'/2. 3240
 3241'$store_clause'(Term, Id) :-
 3242    '$clause_source'(Term, Clause, SrcLoc),
 3243    '$store_clause'(Clause, _, Id, SrcLoc).
 3244
 3245%!  compile_aux_clauses(+Clauses) is det.
 3246%
 3247%   Compile clauses given the current  source   location  but do not
 3248%   change  the  notion  of   the    current   procedure  such  that
 3249%   discontiguous  warnings  are  not  issued.    The   clauses  are
 3250%   associated with the current file and  therefore wiped out if the
 3251%   file is reloaded.
 3252%
 3253%   If the cross-referencer is active, we should not (re-)assert the
 3254%   clauses.  Actually,  we  should   make    them   known   to  the
 3255%   cross-referencer. How do we do that?   Maybe we need a different
 3256%   API, such as in:
 3257%
 3258%     ==
 3259%     expand_term_aux(Goal, NewGoal, Clauses)
 3260%     ==
 3261%
 3262%   @tbd    Deal with source code layout?
 3263
 3264compile_aux_clauses(_Clauses) :-
 3265    current_prolog_flag(xref, true),
 3266    !.
 3267compile_aux_clauses(Clauses) :-
 3268    source_location(File, _Line),
 3269    '$compile_aux_clauses'(Clauses, File).
 3270
 3271'$compile_aux_clauses'(Clauses, File) :-
 3272    setup_call_cleanup(
 3273        '$start_aux'(File, Context),
 3274        '$store_aux_clauses'(Clauses, File),
 3275        '$end_aux'(File, Context)).
 3276
 3277'$store_aux_clauses'(Clauses, File) :-
 3278    is_list(Clauses),
 3279    !,
 3280    forall('$member'(C,Clauses),
 3281           '$compile_term'(C, _Layout, File)).
 3282'$store_aux_clauses'(Clause, File) :-
 3283    '$compile_term'(Clause, _Layout, File).
 3284
 3285
 3286                 /*******************************
 3287                 *             READING          *
 3288                 *******************************/
 3289
 3290:- multifile
 3291    prolog:comment_hook/3.                  % hook for read_clause/3
 3292
 3293
 3294                 /*******************************
 3295                 *       FOREIGN INTERFACE      *
 3296                 *******************************/
 3297
 3298%       call-back from PL_register_foreign().  First argument is the module
 3299%       into which the foreign predicate is loaded and second is a term
 3300%       describing the arguments.
 3301
 3302:- dynamic
 3303    '$foreign_registered'/2. 3304
 3305                 /*******************************
 3306                 *   TEMPORARY TERM EXPANSION   *
 3307                 *******************************/
 3308
 3309% Provide temporary definitions for the boot-loader.  These are replaced
 3310% by the real thing in load.pl
 3311
 3312:- dynamic
 3313    '$expand_goal'/2,
 3314    '$expand_term'/4. 3315
 3316'$expand_goal'(In, In).
 3317'$expand_term'(In, Layout, In, Layout).
 3318
 3319
 3320                /********************************
 3321                *     WIC CODE COMPILER         *
 3322                *********************************/
 3323
 3324/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 3325This entry point is called from pl-main.c  if the -c option (compile) is
 3326given. It compiles all files and finally calls qsave_program to create a
 3327saved state.
 3328- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 3329
 3330:- public '$compile_wic'/0. 3331
 3332'$compile_wic' :-
 3333    current_prolog_flag(os_argv, Argv),
 3334    '$get_files_argv'(Argv, Files),
 3335    '$translate_options'(Argv, Options),
 3336    '$cmd_option_val'(compileout, Out),
 3337    attach_packs,
 3338    user:consult(Files),
 3339    user:qsave_program(Out, Options).
 3340
 3341'$get_files_argv'([], []) :- !.
 3342'$get_files_argv'(['-c'|Files], Files) :- !.
 3343'$get_files_argv'([_|Rest], Files) :-
 3344    '$get_files_argv'(Rest, Files).
 3345
 3346'$translate_options'([], []).
 3347'$translate_options'([O|T0], [Opt|T]) :-
 3348    atom_chars(O, [-,-|Rest]),
 3349    '$split'(Rest, [=], Head, Tail),
 3350    !,
 3351    atom_chars(Name, Head),
 3352    '$compile_option_type'(Name, Type),
 3353    '$convert_option_value'(Type, Tail, Value),
 3354    Opt =.. [Name, Value],
 3355    '$translate_options'(T0, T).
 3356'$translate_options'([_|T0], T) :-
 3357    '$translate_options'(T0, T).
 3358
 3359'$split'(List, Split, [], Tail) :-
 3360    '$append'(Split, Tail, List),
 3361    !.
 3362'$split'([H|T0], Split, [H|T], Tail) :-
 3363    '$split'(T0, Split, T, Tail).
 3364
 3365'$compile_option_type'(argument,    integer).
 3366'$compile_option_type'(autoload,    atom).
 3367'$compile_option_type'(class,       atom).
 3368'$compile_option_type'(emulator,    atom).
 3369'$compile_option_type'(global,      integer).
 3370'$compile_option_type'(goal,        callable).
 3371'$compile_option_type'(init_file,   atom).
 3372'$compile_option_type'(local,       integer).
 3373'$compile_option_type'(map,         atom).
 3374'$compile_option_type'(op,          atom).
 3375'$compile_option_type'(stand_alone, atom).
 3376'$compile_option_type'(toplevel,    callable).
 3377'$compile_option_type'(foreign,     atom).
 3378'$compile_option_type'(trail,       integer).
 3379
 3380'$convert_option_value'(integer, Chars, Value) :-
 3381    number_chars(Value, Chars).
 3382'$convert_option_value'(atom, Chars, Value) :-
 3383    atom_chars(Value, Chars).
 3384'$convert_option_value'(callable, Chars, Value) :-
 3385    atom_chars(Atom, Chars),
 3386    term_to_atom(Value, Atom).
 3387
 3388
 3389                 /*******************************
 3390                 *         TYPE SUPPORT         *
 3391                 *******************************/
 3392
 3393'$type_error'(Type, Value) :-
 3394    (   var(Value)
 3395    ->  throw(error(instantiation_error, _))
 3396    ;   throw(error(type_error(Type, Value), _))
 3397    ).
 3398
 3399'$domain_error'(Type, Value) :-
 3400    throw(error(domain_error(Type, Value), _)).
 3401
 3402'$existence_error'(Type, Object) :-
 3403    throw(error(existence_error(Type, Object), _)).
 3404
 3405'$permission_error'(Action, Type, Term) :-
 3406    throw(error(permission_error(Action, Type, Term), _)).
 3407
 3408'$instantiation_error'(_Var) :-
 3409    throw(error(instantiation_error, _)).
 3410
 3411'$must_be'(list, X) :-
 3412    '$skip_list'(_, X, Tail),
 3413    (   Tail == []
 3414    ->  true
 3415    ;   '$type_error'(list, Tail)
 3416    ).
 3417'$must_be'(options, X) :-
 3418    (   '$is_options'(X)
 3419    ->  true
 3420    ;   '$type_error'(options, X)
 3421    ).
 3422'$must_be'(atom, X) :-
 3423    (   atom(X)
 3424    ->  true
 3425    ;   '$type_error'(atom, X)
 3426    ).
 3427'$must_be'(callable, X) :-
 3428    (   callable(X)
 3429    ->  true
 3430    ;   '$type_error'(callable, X)
 3431    ).
 3432'$must_be'(oneof(Type, Domain, List), X) :-
 3433    '$must_be'(Type, X),
 3434    (   memberchk(X, List)
 3435    ->  true
 3436    ;   '$domain_error'(Domain, X)
 3437    ).
 3438'$must_be'(boolean, X) :-
 3439    (   (X == true ; X == false)
 3440    ->  true
 3441    ;   '$type_error'(boolean, X)
 3442    ).
 3443
 3444
 3445                /********************************
 3446                *       LIST PROCESSING         *
 3447                *********************************/
 3448
 3449'$member'(El, [H|T]) :-
 3450    '$member_'(T, El, H).
 3451
 3452'$member_'(_, El, El).
 3453'$member_'([H|T], El, _) :-
 3454    '$member_'(T, El, H).
 3455
 3456
 3457'$append'([], L, L).
 3458'$append'([H|T], L, [H|R]) :-
 3459    '$append'(T, L, R).
 3460
 3461'$select'(X, [X|Tail], Tail).
 3462'$select'(Elem, [Head|Tail], [Head|Rest]) :-
 3463    '$select'(Elem, Tail, Rest).
 3464
 3465'$reverse'(L1, L2) :-
 3466    '$reverse'(L1, [], L2).
 3467
 3468'$reverse'([], List, List).
 3469'$reverse'([Head|List1], List2, List3) :-
 3470    '$reverse'(List1, [Head|List2], List3).
 3471
 3472'$delete'([], _, []) :- !.
 3473'$delete'([Elem|Tail], Elem, Result) :-
 3474    !,
 3475    '$delete'(Tail, Elem, Result).
 3476'$delete'([Head|Tail], Elem, [Head|Rest]) :-
 3477    '$delete'(Tail, Elem, Rest).
 3478
 3479'$last'([H|T], Last) :-
 3480    '$last'(T, H, Last).
 3481
 3482'$last'([], Last, Last).
 3483'$last'([H|T], _, Last) :-
 3484    '$last'(T, H, Last).
 3485
 3486
 3487%!  length(?List, ?N)
 3488%
 3489%   Is true when N is the length of List.
 3490
 3491:- '$iso'((length/2)). 3492
 3493length(List, Length) :-
 3494    var(Length),
 3495    !,
 3496    '$skip_list'(Length0, List, Tail),
 3497    (   Tail == []
 3498    ->  Length = Length0                    % +,-
 3499    ;   var(Tail)
 3500    ->  Tail \== Length,                    % avoid length(L,L)
 3501        '$length3'(Tail, Length, Length0)   % -,-
 3502    ;   throw(error(type_error(list, List),
 3503                    context(length/2, _)))
 3504    ).
 3505length(List, Length) :-
 3506    integer(Length),
 3507    Length >= 0,
 3508    !,
 3509    '$skip_list'(Length0, List, Tail),
 3510    (   Tail == []                          % proper list
 3511    ->  Length = Length0
 3512    ;   var(Tail)
 3513    ->  Extra is Length-Length0,
 3514        '$length'(Tail, Extra)
 3515    ;   throw(error(type_error(list, List),
 3516                    context(length/2, _)))
 3517    ).
 3518length(_, Length) :-
 3519    integer(Length),
 3520    !,
 3521    throw(error(domain_error(not_less_than_zero, Length),
 3522                context(length/2, _))).
 3523length(_, Length) :-
 3524    throw(error(type_error(integer, Length),
 3525                context(length/2, _))).
 3526
 3527'$length3'([], N, N).
 3528'$length3'([_|List], N, N0) :-
 3529    N1 is N0+1,
 3530    '$length3'(List, N, N1).
 3531
 3532
 3533                 /*******************************
 3534                 *       OPTION PROCESSING      *
 3535                 *******************************/
 3536
 3537%!  '$is_options'(@Term) is semidet.
 3538%
 3539%   True if Term looks like it provides options.
 3540
 3541'$is_options'(Map) :-
 3542    is_dict(Map, _),
 3543    !.
 3544'$is_options'(List) :-
 3545    is_list(List),
 3546    (   List == []
 3547    ->  true
 3548    ;   List = [H|_],
 3549        '$is_option'(H, _, _)
 3550    ).
 3551
 3552'$is_option'(Var, _, _) :-
 3553    var(Var), !, fail.
 3554'$is_option'(F, Name, Value) :-
 3555    functor(F, _, 1),
 3556    !,
 3557    F =.. [Name,Value].
 3558'$is_option'(Name=Value, Name, Value).
 3559
 3560%!  '$option'(?Opt, +Options) is semidet.
 3561
 3562'$option'(Opt, Options) :-
 3563    is_dict(Options),
 3564    !,
 3565    [Opt] :< Options.
 3566'$option'(Opt, Options) :-
 3567    memberchk(Opt, Options).
 3568
 3569%!  '$option'(?Opt, +Options, +Default) is det.
 3570
 3571'$option'(Term, Options, Default) :-
 3572    arg(1, Term, Value),
 3573    functor(Term, Name, 1),
 3574    (   is_dict(Options)
 3575    ->  (   get_dict(Name, Options, GVal)
 3576        ->  Value = GVal
 3577        ;   Value = Default
 3578        )
 3579    ;   functor(Gen, Name, 1),
 3580        arg(1, Gen, GVal),
 3581        (   memberchk(Gen, Options)
 3582        ->  Value = GVal
 3583        ;   Value = Default
 3584        )
 3585    ).
 3586
 3587%!  '$select_option'(?Opt, +Options, -Rest) is semidet.
 3588%
 3589%   Select an option from Options.
 3590%
 3591%   @arg Rest is always a map.
 3592
 3593'$select_option'(Opt, Options, Rest) :-
 3594    select_dict([Opt], Options, Rest).
 3595
 3596%!  '$merge_options'(+New, +Default, -Merged) is det.
 3597%
 3598%   Add/replace options specified in New.
 3599%
 3600%   @arg Merged is always a map.
 3601
 3602'$merge_options'(New, Old, Merged) :-
 3603    put_dict(New, Old, Merged).
 3604
 3605
 3606                 /*******************************
 3607                 *   HANDLE TRACER 'L'-COMMAND  *
 3608                 *******************************/
 3609
 3610:- public '$prolog_list_goal'/1. 3611
 3612:- multifile
 3613    user:prolog_list_goal/1. 3614
 3615'$prolog_list_goal'(Goal) :-
 3616    user:prolog_list_goal(Goal),
 3617    !.
 3618'$prolog_list_goal'(Goal) :-
 3619    user:listing(Goal).
 3620
 3621
 3622                 /*******************************
 3623                 *             HALT             *
 3624                 *******************************/
 3625
 3626:- '$iso'((halt/0)). 3627
 3628halt :-
 3629    halt(0).
 3630
 3631
 3632%!  at_halt(:Goal)
 3633%
 3634%   Register Goal to be called if the system halts.
 3635%
 3636%   @tbd: get location into the error message
 3637
 3638:- meta_predicate at_halt(0). 3639:- dynamic        system:term_expansion/2, '$at_halt'/2. 3640:- multifile      system:term_expansion/2, '$at_halt'/2. 3641
 3642system:term_expansion((:- at_halt(Goal)),
 3643                      system:'$at_halt'(Module:Goal, File:Line)) :-
 3644    \+ current_prolog_flag(xref, true),
 3645    source_location(File, Line),
 3646    '$current_source_module'(Module).
 3647
 3648at_halt(Goal) :-
 3649    asserta('$at_halt'(Goal, (-):0)).
 3650
 3651:- public '$run_at_halt'/0. 3652
 3653'$run_at_halt' :-
 3654    forall(clause('$at_halt'(Goal, Src), true, Ref),
 3655           ( '$call_at_halt'(Goal, Src),
 3656             erase(Ref)
 3657           )).
 3658
 3659'$call_at_halt'(Goal, _Src) :-
 3660    catch(Goal, E, true),
 3661    !,
 3662    (   var(E)
 3663    ->  true
 3664    ;   subsumes_term(cancel_halt(_), E)
 3665    ->  '$print_message'(informational, E),
 3666        fail
 3667    ;   '$print_message'(error, E)
 3668    ).
 3669'$call_at_halt'(Goal, _Src) :-
 3670    '$print_message'(warning, goal_failed(at_halt, Goal)).
 3671
 3672%!  cancel_halt(+Reason)
 3673%
 3674%   This predicate may be called from   at_halt/1 handlers to cancel
 3675%   halting the program. If  causes  halt/0   to  fail  rather  than
 3676%   terminating the process.
 3677
 3678cancel_halt(Reason) :-
 3679    throw(cancel_halt(Reason)).
 3680
 3681
 3682                /********************************
 3683                *      LOAD OTHER MODULES       *
 3684                *********************************/
 3685
 3686:- meta_predicate
 3687    '$load_wic_files'(:). 3688
 3689'$load_wic_files'(Files) :-
 3690    Files = Module:_,
 3691    '$execute_directive'('$set_source_module'(OldM, Module), []),
 3692    '$save_lex_state'(LexState, []),
 3693    '$style_check'(_, 0xC7),                % see style_name/2 in syspred.pl
 3694    '$compilation_mode'(OldC, wic),
 3695    consult(Files),
 3696    '$execute_directive'('$set_source_module'(OldM), []),
 3697    '$execute_directive'('$restore_lex_state'(LexState), []),
 3698    '$set_compilation_mode'(OldC).
 3699
 3700
 3701%!  '$load_additional_boot_files' is det.
 3702%
 3703%   Called from compileFileList() in pl-wic.c.   Gets the files from
 3704%   "-c file ..." and loads them into the module user.
 3705
 3706:- public '$load_additional_boot_files'/0. 3707
 3708'$load_additional_boot_files' :-
 3709    current_prolog_flag(argv, Argv),
 3710    '$get_files_argv'(Argv, Files),
 3711    (   Files \== []
 3712    ->  format('Loading additional boot files~n'),
 3713        '$load_wic_files'(user:Files),
 3714        format('additional boot files loaded~n')
 3715    ;   true
 3716    ).
 3717
 3718'$:-'((format('Loading Prolog startup files~n', []),
 3719       source_location(File, _Line),
 3720       file_directory_name(File, Dir),
 3721       atom_concat(Dir, '/load.pl', LoadFile),
 3722       '$load_wic_files'(system:[LoadFile]),
 3723       (   current_prolog_flag(windows, true)
 3724       ->  atom_concat(Dir, '/menu.pl', MenuFile),
 3725           '$load_wic_files'(system:[MenuFile])
 3726       ;   true
 3727       ),
 3728       format('SWI-Prolog boot files loaded~n', []),
 3729       '$compilation_mode'(OldC, wic),
 3730       '$execute_directive'('$set_source_module'(user), []),
 3731       '$set_compilation_mode'(OldC)
 3732      ))