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-2021, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9                              SWI-Prolog Solutions b.v.
   10    All rights reserved.
   11
   12    Redistribution and use in source and binary forms, with or without
   13    modification, are permitted provided that the following conditions
   14    are met:
   15
   16    1. Redistributions of source code must retain the above copyright
   17       notice, this list of conditions and the following disclaimer.
   18
   19    2. Redistributions in binary form must reproduce the above copyright
   20       notice, this list of conditions and the following disclaimer in
   21       the documentation and/or other materials provided with the
   22       distribution.
   23
   24    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   25    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   26    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   27    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   28    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   29    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   30    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   31    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   32    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   33    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   34    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   35    POSSIBILITY OF SUCH DAMAGE.
   36*/
   37
   38/*
   39Consult, derivates and basic things.   This  module  is  loaded  by  the
   40C-written  bootstrap  compiler.
   41
   42The $:- directive  is  executed  by  the  bootstrap  compiler,  but  not
   43inserted  in  the  intermediate  code  file.   Used  to print diagnostic
   44messages and start the Prolog defined compiler for  the  remaining  boot
   45modules.
   46
   47If you want  to  debug  this  module,  put  a  '$:-'(trace).   directive
   48somewhere.   The  tracer will work properly under boot compilation as it
   49will use the C defined write predicate  to  print  goals  and  does  not
   50attempt to call the Prolog defined trace interceptor.
   51*/
   52
   53                /********************************
   54                *    LOAD INTO MODULE SYSTEM    *
   55                ********************************/
   56
   57:- '$set_source_module'(system).   58
   59'$boot_message'(_Format, _Args) :-
   60    current_prolog_flag(verbose, silent),
   61    !.
   62'$boot_message'(Format, Args) :-
   63    format(Format, Args),
   64    !.
   65
   66'$:-'('$boot_message'('Loading boot file ...~n', [])).
   67
   68
   69                /********************************
   70                *          DIRECTIVES           *
   71                *********************************/
   72
   73:- meta_predicate
   74    dynamic(:),
   75    multifile(:),
   76    public(:),
   77    module_transparent(:),
   78    discontiguous(:),
   79    volatile(:),
   80    thread_local(:),
   81    noprofile(:),
   82    non_terminal(:),
   83    '$clausable'(:),
   84    '$iso'(:),
   85    '$hide'(:).

 dynamic +Spec is det

 multifile +Spec is det

 module_transparent +Spec is det

 discontiguous +Spec is det

 volatile +Spec is det

 thread_local +Spec is det

 noprofile(+Spec) is det

 public +Spec is det

 non_terminal(+Spec) is det

Predicate versions of standard directives that set predicate attributes. These predicates bail out with an error on the first failure (typically permission errors).

 $iso(+Spec) is det

Set the ISO flag. This defines that the predicate cannot be redefined inside a module.

 $clausable(+Spec) is det

Specify that we can run clause/2 on a predicate, even if it is static. ISO specifies that public also plays this role. in SWI, public means that the predicate can be called, even if we cannot find a reference to it.

 $hide(+Spec) is det

Specify that the predicate cannot be seen in the debugger.

  117dynamic(Spec)            :- '$set_pattr'(Spec, pred, dynamic(true)).
  118multifile(Spec)          :- '$set_pattr'(Spec, pred, multifile(true)).
  119module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)).
  120discontiguous(Spec)      :- '$set_pattr'(Spec, pred, discontiguous(true)).
  121volatile(Spec)           :- '$set_pattr'(Spec, pred, volatile(true)).
  122thread_local(Spec)       :- '$set_pattr'(Spec, pred, thread_local(true)).
  123noprofile(Spec)          :- '$set_pattr'(Spec, pred, noprofile(true)).
  124public(Spec)             :- '$set_pattr'(Spec, pred, public(true)).
  125non_terminal(Spec)       :- '$set_pattr'(Spec, pred, non_terminal(true)).
  126det(Spec)                :- '$set_pattr'(Spec, pred, det(true)).
  127'$iso'(Spec)             :- '$set_pattr'(Spec, pred, iso(true)).
  128'$clausable'(Spec)       :- '$set_pattr'(Spec, pred, clausable(true)).
  129'$hide'(Spec)            :- '$set_pattr'(Spec, pred, trace(false)).
  130
  131'$set_pattr'(M:Pred, How, Attr) :-
  132    '$set_pattr'(Pred, M, How, Attr).

 $set_pattr(+Spec, +Module, +From, +Attr)

Set predicate attributes. From is one of pred or directive.

  138'$set_pattr'(X, _, _, _) :-
  139    var(X),
  140    '$uninstantiation_error'(X).
  141'$set_pattr'(as(Spec,Options), M, How, Attr0) :-
  142    !,
  143    '$attr_options'(Options, Attr0, Attr),
  144    '$set_pattr'(Spec, M, How, Attr).
  145'$set_pattr'([], _, _, _) :- !.
  146'$set_pattr'([H|T], M, How, Attr) :-           % ISO
  147    !,
  148    '$set_pattr'(H, M, How, Attr),
  149    '$set_pattr'(T, M, How, Attr).
  150'$set_pattr'((A,B), M, How, Attr) :-           % ISO and traditional
  151    !,
  152    '$set_pattr'(A, M, How, Attr),
  153    '$set_pattr'(B, M, How, Attr).
  154'$set_pattr'(M:T, _, How, Attr) :-
  155    !,
  156    '$set_pattr'(T, M, How, Attr).
  157'$set_pattr'(PI, M, _, []) :-
  158    !,
  159    '$pi_head'(M:PI, Pred),
  160    '$set_table_wrappers'(Pred).
  161'$set_pattr'(A, M, How, [O|OT]) :-
  162    !,
  163    '$set_pattr'(A, M, How, O),
  164    '$set_pattr'(A, M, How, OT).
  165'$set_pattr'(A, M, pred, Attr) :-
  166    !,
  167    Attr =.. [Name,Val],
  168    '$set_pi_attr'(M:A, Name, Val).
  169'$set_pattr'(A, M, directive, Attr) :-
  170    !,
  171    Attr =.. [Name,Val],
  172    catch('$set_pi_attr'(M:A, Name, Val),
  173          error(E, _),
  174          print_message(error, error(E, context((Name)/1,_)))).
  175
  176'$set_pi_attr'(PI, Name, Val) :-
  177    '$pi_head'(PI, Head),
  178    '$set_predicate_attribute'(Head, Name, Val).
  179
  180'$attr_options'(Var, _, _) :-
  181    var(Var),
  182    !,
  183    '$uninstantiation_error'(Var).
  184'$attr_options'((A,B), Attr0, Attr) :-
  185    !,
  186    '$attr_options'(A, Attr0, Attr1),
  187    '$attr_options'(B, Attr1, Attr).
  188'$attr_options'(Opt, Attr0, Attrs) :-
  189    '$must_be'(ground, Opt),
  190    (   '$attr_option'(Opt, AttrX)
  191    ->  (   is_list(Attr0)
  192        ->  '$join_attrs'(AttrX, Attr0, Attrs)
  193        ;   '$join_attrs'(AttrX, [Attr0], Attrs)
  194        )
  195    ;   '$domain_error'(predicate_option, Opt)
  196    ).
  197
  198'$join_attrs'([], Attrs, Attrs) :-
  199    !.
  200'$join_attrs'([H|T], Attrs0, Attrs) :-
  201    !,
  202    '$join_attrs'(H, Attrs0, Attrs1),
  203    '$join_attrs'(T, Attrs1, Attrs).
  204'$join_attrs'(Attr, Attrs, Attrs) :-
  205    memberchk(Attr, Attrs),
  206    !.
  207'$join_attrs'(Attr, Attrs, Attrs) :-
  208    Attr =.. [Name,Value],
  209    Gen =.. [Name,Existing],
  210    memberchk(Gen, Attrs),
  211    !,
  212    throw(error(conflict_error(Name, Value, Existing), _)).
  213'$join_attrs'(Attr, Attrs0, Attrs) :-
  214    '$append'(Attrs0, [Attr], Attrs).
  215
  216'$attr_option'(incremental, [incremental(true),opaque(false)]).
  217'$attr_option'(monotonic, monotonic(true)).
  218'$attr_option'(lazy, lazy(true)).
  219'$attr_option'(opaque, [incremental(false),opaque(true)]).
  220'$attr_option'(abstract(Level0), abstract(Level)) :-
  221    '$table_option'(Level0, Level).
  222'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :-
  223    '$table_option'(Level0, Level).
  224'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :-
  225    '$table_option'(Level0, Level).
  226'$attr_option'(max_answers(Level0), max_answers(Level)) :-
  227    '$table_option'(Level0, Level).
  228'$attr_option'(volatile, volatile(true)).
  229'$attr_option'(multifile, multifile(true)).
  230'$attr_option'(discontiguous, discontiguous(true)).
  231'$attr_option'(shared, thread_local(false)).
  232'$attr_option'(local, thread_local(true)).
  233'$attr_option'(private, thread_local(true)).
  234
  235'$table_option'(Value0, _Value) :-
  236    var(Value0),
  237    !,
  238    '$instantiation_error'(Value0).
  239'$table_option'(Value0, Value) :-
  240    integer(Value0),
  241    Value0 >= 0,
  242    !,
  243    Value = Value0.
  244'$table_option'(off, -1) :-
  245    !.
  246'$table_option'(false, -1) :-
  247    !.
  248'$table_option'(infinite, -1) :-
  249    !.
  250'$table_option'(Value, _) :-
  251    '$domain_error'(nonneg_or_false, Value).

 $pattr_directive(+Spec, +Module) is det

This implements the directive version of dynamic/1, multifile/1, etc. This version catches and prints errors. If the directive specifies multiple predicates, processing after an error continues with the remaining predicates.

  261'$pattr_directive'(dynamic(Spec), M) :-
  262    '$set_pattr'(Spec, M, directive, dynamic(true)).
  263'$pattr_directive'(multifile(Spec), M) :-
  264    '$set_pattr'(Spec, M, directive, multifile(true)).
  265'$pattr_directive'(module_transparent(Spec), M) :-
  266    '$set_pattr'(Spec, M, directive, transparent(true)).
  267'$pattr_directive'(discontiguous(Spec), M) :-
  268    '$set_pattr'(Spec, M, directive, discontiguous(true)).
  269'$pattr_directive'(volatile(Spec), M) :-
  270    '$set_pattr'(Spec, M, directive, volatile(true)).
  271'$pattr_directive'(thread_local(Spec), M) :-
  272    '$set_pattr'(Spec, M, directive, thread_local(true)).
  273'$pattr_directive'(noprofile(Spec), M) :-
  274    '$set_pattr'(Spec, M, directive, noprofile(true)).
  275'$pattr_directive'(public(Spec), M) :-
  276    '$set_pattr'(Spec, M, directive, public(true)).
  277'$pattr_directive'(det(Spec), M) :-
  278    '$set_pattr'(Spec, M, directive, det(true)).

 $pi_head(?PI, ?Head)

  282'$pi_head'(PI, Head) :-
  283    var(PI),
  284    var(Head),
  285    '$instantiation_error'([PI,Head]).
  286'$pi_head'(M:PI, M:Head) :-
  287    !,
  288    '$pi_head'(PI, Head).
  289'$pi_head'(Name/Arity, Head) :-
  290    !,
  291    '$head_name_arity'(Head, Name, Arity).
  292'$pi_head'(Name//DCGArity, Head) :-
  293    !,
  294    (   nonvar(DCGArity)
  295    ->  Arity is DCGArity+2,
  296        '$head_name_arity'(Head, Name, Arity)
  297    ;   '$head_name_arity'(Head, Name, Arity),
  298        DCGArity is Arity - 2
  299    ).
  300'$pi_head'(PI, _) :-
  301    '$type_error'(predicate_indicator, PI).

 $head_name_arity(+Goal, -Name, -Arity)

$head_name_arity(-Goal, +Name, +Arity)

  306'$head_name_arity'(Goal, Name, Arity) :-
  307    (   atom(Goal)
  308    ->  Name = Goal, Arity = 0
  309    ;   compound(Goal)
  310    ->  compound_name_arity(Goal, Name, Arity)
  311    ;   var(Goal)
  312    ->  (   Arity == 0
  313        ->  (   atom(Name)
  314            ->  Goal = Name
  315            ;   Name == []
  316            ->  Goal = Name
  317            ;   blob(Name, closure)
  318            ->  Goal = Name
  319            ;   '$type_error'(atom, Name)
  320            )
  321        ;   compound_name_arity(Goal, Name, Arity)
  322        )
  323    ;   '$type_error'(callable, Goal)
  324    ).
  325
  326:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)).  327
  328
  329                /********************************
  330                *       CALLING, CONTROL        *
  331                *********************************/
  332
  333:- noprofile((call/1,
  334              catch/3,
  335              once/1,
  336              ignore/1,
  337              call_cleanup/2,
  338              call_cleanup/3,
  339              setup_call_cleanup/3,
  340              setup_call_catcher_cleanup/4)).  341
  342:- meta_predicate
  343    ';'(0,0),
  344    ','(0,0),
  345    @(0,+),
  346    call(0),
  347    call(1,?),
  348    call(2,?,?),
  349    call(3,?,?,?),
  350    call(4,?,?,?,?),
  351    call(5,?,?,?,?,?),
  352    call(6,?,?,?,?,?,?),
  353    call(7,?,?,?,?,?,?,?),
  354    not(0),
  355    \+(0),
  356    $(0),
  357    '->'(0,0),
  358    '*->'(0,0),
  359    once(0),
  360    ignore(0),
  361    catch(0,?,0),
  362    reset(0,?,-),
  363    setup_call_cleanup(0,0,0),
  364    setup_call_catcher_cleanup(0,0,?,0),
  365    call_cleanup(0,0),
  366    call_cleanup(0,?,0),
  367    catch_with_backtrace(0,?,0),
  368    '$meta_call'(0).  369
  370:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)).  371
  372% The control structures are always compiled, both   if they appear in a
  373% clause body and if they are handed  to   call/1.  The only way to call
  374% these predicates is by means of  call/2..   In  that case, we call the
  375% hole control structure again to get it compiled by call/1 and properly
  376% deal  with  !,  etc.  Another  reason  for  having  these  things   as
  377% predicates is to be able to define   properties for them, helping code
  378% analyzers.
  379
  380(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
  381(M1:If ; M2:Then) :-    call(M1:(If ; M2:Then)).
  382(G1   , G2)       :-    call((G1   , G2)).
  383(If  -> Then)     :-    call((If  -> Then)).
  384(If *-> Then)     :-    call((If *-> Then)).
  385@(Goal,Module)    :-    @(Goal,Module).

 $meta_call(:Goal)

Interpreted meta-call implementation. By default, call/1 compiles its argument into a temporary clause. This realises better performance if the (complex) goal does a lot of backtracking because this interpreted version needs to re-interpret the remainder of the goal after backtracking.

This implementation is used by reset/3 because the continuation cannot be captured if it contains a such a compiled temporary clause.

  399'$meta_call'(M:G) :-
  400    prolog_current_choice(Ch),
  401    '$meta_call'(G, M, Ch).
  402
  403'$meta_call'(Var, _, _) :-
  404    var(Var),
  405    !,
  406    '$instantiation_error'(Var).
  407'$meta_call'((A,B), M, Ch) :-
  408    !,
  409    '$meta_call'(A, M, Ch),
  410    '$meta_call'(B, M, Ch).
  411'$meta_call'((I->T;E), M, Ch) :-
  412    !,
  413    (   prolog_current_choice(Ch2),
  414        '$meta_call'(I, M, Ch2)
  415    ->  '$meta_call'(T, M, Ch)
  416    ;   '$meta_call'(E, M, Ch)
  417    ).
  418'$meta_call'((I*->T;E), M, Ch) :-
  419    !,
  420    (   prolog_current_choice(Ch2),
  421        '$meta_call'(I, M, Ch2)
  422    *-> '$meta_call'(T, M, Ch)
  423    ;   '$meta_call'(E, M, Ch)
  424    ).
  425'$meta_call'((I->T), M, Ch) :-
  426    !,
  427    (   prolog_current_choice(Ch2),
  428        '$meta_call'(I, M, Ch2)
  429    ->  '$meta_call'(T, M, Ch)
  430    ).
  431'$meta_call'((I*->T), M, Ch) :-
  432    !,
  433    prolog_current_choice(Ch2),
  434    '$meta_call'(I, M, Ch2),
  435    '$meta_call'(T, M, Ch).
  436'$meta_call'((A;B), M, Ch) :-
  437    !,
  438    (   '$meta_call'(A, M, Ch)
  439    ;   '$meta_call'(B, M, Ch)
  440    ).
  441'$meta_call'(\+(G), M, _) :-
  442    !,
  443    prolog_current_choice(Ch),
  444    \+ '$meta_call'(G, M, Ch).
  445'$meta_call'($(G), M, _) :-
  446    !,
  447    prolog_current_choice(Ch),
  448    $('$meta_call'(G, M, Ch)).
  449'$meta_call'(call(G), M, _) :-
  450    !,
  451    prolog_current_choice(Ch),
  452    '$meta_call'(G, M, Ch).
  453'$meta_call'(M:G, _, Ch) :-
  454    !,
  455    '$meta_call'(G, M, Ch).
  456'$meta_call'(!, _, Ch) :-
  457    prolog_cut_to(Ch).
  458'$meta_call'(G, M, _Ch) :-
  459    call(M:G).

 call(:Closure, ?A)

 call(:Closure, ?A1, ?A2)

 call(:Closure, ?A1, ?A2, ?A3)

 call(:Closure, ?A1, ?A2, ?A3, ?A4)

 call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5)

 call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6)

 call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6, ?A7)

Arity 2..8 is demanded by the ISO standard. Higher arities are supported, but handled by the compiler. This implies they are not backed up by predicates and analyzers thus cannot ask for their properties. Analyzers should hard-code handling of call/2..

  475:- '$iso'((call/2,
  476           call/3,
  477           call/4,
  478           call/5,
  479           call/6,
  480           call/7,
  481           call/8)).  482
  483call(Goal) :-                           % make these available as predicates
  484    Goal.
  485call(Goal, A) :-
  486    call(Goal, A).
  487call(Goal, A, B) :-
  488    call(Goal, A, B).
  489call(Goal, A, B, C) :-
  490    call(Goal, A, B, C).
  491call(Goal, A, B, C, D) :-
  492    call(Goal, A, B, C, D).
  493call(Goal, A, B, C, D, E) :-
  494    call(Goal, A, B, C, D, E).
  495call(Goal, A, B, C, D, E, F) :-
  496    call(Goal, A, B, C, D, E, F).
  497call(Goal, A, B, C, D, E, F, G) :-
  498    call(Goal, A, B, C, D, E, F, G).

 not(:Goal) is semidet

Pre-ISO version of \+/1. Note that some systems define not/1 as a logically more sound version of \+/1.

  505not(Goal) :-
  506    \+ Goal.

 \+ :Goal is semidet

Predicate version that allows for meta-calling.

  512\+ Goal :-
  513    \+ Goal.

 once(:Goal) is semidet

ISO predicate, acting as call((Goal, !)).

  519once(Goal) :-
  520    Goal,
  521    !.

 ignore(:Goal) is det

Call Goal, cut choice-points on success and succeed on failure. intended for calling side-effects and proceed on failure.

  528ignore(Goal) :-
  529    Goal,
  530    !.
  531ignore(_Goal).
  532
  533:- '$iso'((false/0)).

 false

Synonym for fail/0, providing a declarative reading.

  539false :-
  540    fail.

 catch(:Goal, +Catcher, :Recover)

ISO compliant exception handling.

  546catch(_Goal, _Catcher, _Recover) :-
  547    '$catch'.                       % Maps to I_CATCH, I_EXITCATCH

 prolog_cut_to(+Choice)

Cut all choice points after Choice

  553prolog_cut_to(_Choice) :-
  554    '$cut'.                         % Maps to I_CUTCHP

 $ is det

Declare that from now on this predicate succeeds deterministically.

  560'$' :- '$'.

 $ :Goal is det

Declare that Goal must succeed deterministically.

  566$(Goal) :- $(Goal).

 reset(:Goal, ?Ball, -Continue)

Delimited continuation support.

  572reset(_Goal, _Ball, _Cont) :-
  573    '$reset'.

 shift(+Ball)

 shift_for_copy(+Ball)

Shift control back to the enclosing reset/3. The second version assumes the continuation will be saved to be reused in a different context.

  582shift(Ball) :-
  583    '$shift'(Ball).
  584
  585shift_for_copy(Ball) :-
  586    '$shift_for_copy'(Ball).

 call_continuation(+Continuation:list)

Call a continuation as created by shift/1. The continuation is a list of '$cont$'(Clause, PC, EnvironmentArg, ...) structures. The predicate '$call_one_tail_body'/1 creates a frame from the continuation and calls this.

Note that we can technically also push the entire continuation onto the environment and call it. Doing it incrementally as below exploits last-call optimization and therefore possible quadratic expansion of the continuation.

  600call_continuation([]).
  601call_continuation([TB|Rest]) :-
  602    (   Rest == []
  603    ->  '$call_continuation'(TB)
  604    ;   '$call_continuation'(TB),
  605        call_continuation(Rest)
  606    ).

 catch_with_backtrace(:Goal, ?Ball, :Recover)

As catch/3, but tell library(prolog_stack) to record a backtrace in case of an exception.

  613catch_with_backtrace(Goal, Ball, Recover) :-
  614    catch(Goal, Ball, Recover),
  615    '$no_lco'.
  616
  617'$no_lco'.

 $recover_and_rethrow(:Goal, +Term)

This goal is used to wrap the catch/3 recover handler if the exception is not supposed to be `catchable'. An example of an uncachable exception is '$aborted', used by abort/0. Note that we cut to ensure that the exception is not delayed forever because the recover handler leaves a choicepoint.

  627:- public '$recover_and_rethrow'/2.  628
  629'$recover_and_rethrow'(Goal, Exception) :-
  630    call_cleanup(Goal, throw(Exception)),
  631    !.

 setup_call_cleanup(:Setup, :Goal, :Cleanup)

 setup_call_catcher_cleanup(:Setup, :Goal, +Catcher, :Cleanup)

 call_cleanup(:Goal, :Cleanup)

 call_cleanup(:Goal, +Catcher, :Cleanup)

Call Cleanup once after Goal is finished (deterministic success, failure, exception or cut). The call to '$call_cleanup' is translated to I_CALLCLEANUP. This instruction relies on the exact stack layout left by setup_call_catcher_cleanup/4. Also the predicate name is used by the kernel cleanup mechanism and can only be changed together with the kernel.

  646setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
  647    '$sig_atomic'(Setup),
  648    '$call_cleanup'.
  649
  650setup_call_cleanup(Setup, Goal, Cleanup) :-
  651    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
  652
  653call_cleanup(Goal, Cleanup) :-
  654    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
  655
  656call_cleanup(Goal, Catcher, Cleanup) :-
  657    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
  658
  659                 /*******************************
  660                 *       INITIALIZATION         *
  661                 *******************************/
  662
  663:- meta_predicate
  664    initialization(0, +).  665
  666:- multifile '$init_goal'/3.  667:- dynamic   '$init_goal'/3.

 initialization(:Goal, +When)

Register Goal to be executed if a saved state is restored. In addition, the goal is executed depending on When:

now

Execute immediately

after_load

Execute after loading the file in which it appears. This is initialization/1.

restore_state

Do not execute immediately, but only when restoring the state. Not allowed in a sandboxed environment.

prepare_state

Called before saving a state. Can be used to clean the environment (see also volatile/1) or eagerly execute goals that are normally executed lazily.

program

Works as -g goal goals.

main

Starts the application. Only last declaration is used.

Note that all goals are executed when a program is restored.

  693initialization(Goal, When) :-
  694    '$must_be'(oneof(atom, initialization_type,
  695                     [ now,
  696                       after_load,
  697                       restore,
  698                       restore_state,
  699                       prepare_state,
  700                       program,
  701                       main
  702                     ]), When),
  703    '$initialization_context'(Source, Ctx),
  704    '$initialization'(When, Goal, Source, Ctx).
  705
  706'$initialization'(now, Goal, _Source, Ctx) :-
  707    '$run_init_goal'(Goal, Ctx),
  708    '$compile_init_goal'(-, Goal, Ctx).
  709'$initialization'(after_load, Goal, Source, Ctx) :-
  710    (   Source \== (-)
  711    ->  '$compile_init_goal'(Source, Goal, Ctx)
  712    ;   throw(error(context_error(nodirective,
  713                                  initialization(Goal, after_load)),
  714                    _))
  715    ).
  716'$initialization'(restore, Goal, Source, Ctx) :- % deprecated
  717    '$initialization'(restore_state, Goal, Source, Ctx).
  718'$initialization'(restore_state, Goal, _Source, Ctx) :-
  719    (   \+ current_prolog_flag(sandboxed_load, true)
  720    ->  '$compile_init_goal'(-, Goal, Ctx)
  721    ;   '$permission_error'(register, initialization(restore), Goal)
  722    ).
  723'$initialization'(prepare_state, Goal, _Source, Ctx) :-
  724    (   \+ current_prolog_flag(sandboxed_load, true)
  725    ->  '$compile_init_goal'(when(prepare_state), Goal, Ctx)
  726    ;   '$permission_error'(register, initialization(restore), Goal)
  727    ).
  728'$initialization'(program, Goal, _Source, Ctx) :-
  729    (   \+ current_prolog_flag(sandboxed_load, true)
  730    ->  '$compile_init_goal'(when(program), Goal, Ctx)
  731    ;   '$permission_error'(register, initialization(restore), Goal)
  732    ).
  733'$initialization'(main, Goal, _Source, Ctx) :-
  734    (   \+ current_prolog_flag(sandboxed_load, true)
  735    ->  '$compile_init_goal'(when(main), Goal, Ctx)
  736    ;   '$permission_error'(register, initialization(restore), Goal)
  737    ).
  738
  739
  740'$compile_init_goal'(Source, Goal, Ctx) :-
  741    atom(Source),
  742    Source \== (-),
  743    !,
  744    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
  745                          _Layout, Source, Ctx).
  746'$compile_init_goal'(Source, Goal, Ctx) :-
  747    assertz('$init_goal'(Source, Goal, Ctx)).

 $run_initialization(?File, +Options) is det

 $run_initialization(?File, +Action, +Options) is det

Run initialization directives for all files if File is unbound, or for a specified file. Note that '$run_initialization'/2 is called from runInitialization() in pl-wic.c for .qlf files. The '$run_initialization'/3 is called with Action set to loaded when called for a QLF file.

  759'$run_initialization'(_, loaded, _) :- !.
  760'$run_initialization'(File, _Action, Options) :-
  761    '$run_initialization'(File, Options).
  762
  763'$run_initialization'(File, Options) :-
  764    setup_call_cleanup(
  765        '$start_run_initialization'(Options, Restore),
  766        '$run_initialization_2'(File),
  767        '$end_run_initialization'(Restore)).
  768
  769'$start_run_initialization'(Options, OldSandBoxed) :-
  770    '$push_input_context'(initialization),
  771    '$set_sandboxed_load'(Options, OldSandBoxed).
  772'$end_run_initialization'(OldSandBoxed) :-
  773    set_prolog_flag(sandboxed_load, OldSandBoxed),
  774    '$pop_input_context'.
  775
  776'$run_initialization_2'(File) :-
  777    (   '$init_goal'(File, Goal, Ctx),
  778        File \= when(_),
  779        '$run_init_goal'(Goal, Ctx),
  780        fail
  781    ;   true
  782    ).
  783
  784'$run_init_goal'(Goal, Ctx) :-
  785    (   catch_with_backtrace('$run_init_goal'(Goal), E,
  786                             '$initialization_error'(E, Goal, Ctx))
  787    ->  true
  788    ;   '$initialization_failure'(Goal, Ctx)
  789    ).
  790
  791:- multifile prolog:sandbox_allowed_goal/1.  792
  793'$run_init_goal'(Goal) :-
  794    current_prolog_flag(sandboxed_load, false),
  795    !,
  796    call(Goal).
  797'$run_init_goal'(Goal) :-
  798    prolog:sandbox_allowed_goal(Goal),
  799    call(Goal).
  800
  801'$initialization_context'(Source, Ctx) :-
  802    (   source_location(File, Line)
  803    ->  Ctx = File:Line,
  804        '$input_context'(Context),
  805        '$top_file'(Context, File, Source)
  806    ;   Ctx = (-),
  807        File = (-)
  808    ).
  809
  810'$top_file'([input(include, F1, _, _)|T], _, F) :-
  811    !,
  812    '$top_file'(T, F1, F).
  813'$top_file'(_, F, F).
  814
  815
  816'$initialization_error'(E, Goal, Ctx) :-
  817    print_message(error, initialization_error(Goal, E, Ctx)).
  818
  819'$initialization_failure'(Goal, Ctx) :-
  820    print_message(warning, initialization_failure(Goal, Ctx)).

 $clear_source_admin(+File) is det

Removes source adminstration related to File

See also

- Called from destroySourceFile() in pl-proc.c

  828:- public '$clear_source_admin'/1.  829
  830'$clear_source_admin'(File) :-
  831    retractall('$init_goal'(_, _, File:_)),
  832    retractall('$load_context_module'(File, _, _)),
  833    retractall('$resolved_source_path_db'(_, _, File)).
  834
  835
  836                 /*******************************
  837                 *            STREAM            *
  838                 *******************************/
  839
  840:- '$iso'(stream_property/2).  841stream_property(Stream, Property) :-
  842    nonvar(Stream),
  843    nonvar(Property),
  844    !,
  845    '$stream_property'(Stream, Property).
  846stream_property(Stream, Property) :-
  847    nonvar(Stream),
  848    !,
  849    '$stream_properties'(Stream, Properties),
  850    '$member'(Property, Properties).
  851stream_property(Stream, Property) :-
  852    nonvar(Property),
  853    !,
  854    (   Property = alias(Alias),
  855        atom(Alias)
  856    ->  '$alias_stream'(Alias, Stream)
  857    ;   '$streams_properties'(Property, Pairs),
  858        '$member'(Stream-Property, Pairs)
  859    ).
  860stream_property(Stream, Property) :-
  861    '$streams_properties'(Property, Pairs),
  862    '$member'(Stream-Properties, Pairs),
  863    '$member'(Property, Properties).
  864
  865
  866                /********************************
  867                *            MODULES            *
  868                *********************************/
  869
  870%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
  871%       Tags `Term' with `Module:' if `Module' is not the context module.
  872
  873'$prefix_module'(Module, Module, Head, Head) :- !.
  874'$prefix_module'(Module, _, Head, Module:Head).

 default_module(+Me, -Super) is multi

Is true if `Super' is `Me' or a super (auto import) module of `Me'.

  880default_module(Me, Super) :-
  881    (   atom(Me)
  882    ->  (   var(Super)
  883        ->  '$default_module'(Me, Super)
  884        ;   '$default_module'(Me, Super), !
  885        )
  886    ;   '$type_error'(module, Me)
  887    ).
  888
  889'$default_module'(Me, Me).
  890'$default_module'(Me, Super) :-
  891    import_module(Me, S),
  892    '$default_module'(S, Super).
  893
  894
  895                /********************************
  896                *      TRACE AND EXCEPTIONS     *
  897                *********************************/
  898
  899:- dynamic   user:exception/3.  900:- multifile user:exception/3.  901:- '$hide'(user:exception/3).

 $undefined_procedure(+Module, +Name, +Arity, -Action) is det

This predicate is called from C on undefined predicates. First allows the user to take care of it using exception/3. Else try to give a DWIM warning. Otherwise fail. C will print an error message.

  910:- public
  911    '$undefined_procedure'/4.  912
  913'$undefined_procedure'(Module, Name, Arity, Action) :-
  914    '$prefix_module'(Module, user, Name/Arity, Pred),
  915    user:exception(undefined_predicate, Pred, Action0),
  916    !,
  917    Action = Action0.
  918'$undefined_procedure'(Module, Name, Arity, Action) :-
  919    \+ current_prolog_flag(autoload, false),
  920    '$autoload'(Module:Name/Arity),
  921    !,
  922    Action = retry.
  923'$undefined_procedure'(_, _, _, error).

 $loading(+Library)

True if the library is being loaded. Just testing that the predicate is defined is not good enough as the file may be partly loaded. Calling use_module/2 at any time has two drawbacks: it queries the filesystem, causing slowdown and it stops libraries being autoloaded from a saved state where the library is already loaded, but the source may not be accessible.

  935'$loading'(Library) :-
  936    current_prolog_flag(threads, true),
  937    (   '$loading_file'(Library, _Queue, _LoadThread)
  938    ->  true
  939    ;   '$loading_file'(FullFile, _Queue, _LoadThread),
  940        file_name_extension(Library, _, FullFile)
  941    ->  true
  942    ).
  943
  944%        handle debugger 'w', 'p' and <N> depth options.
  945
  946'$set_debugger_write_options'(write) :-
  947    !,
  948    create_prolog_flag(debugger_write_options,
  949                       [ quoted(true),
  950                         attributes(dots),
  951                         spacing(next_argument)
  952                       ], []).
  953'$set_debugger_write_options'(print) :-
  954    !,
  955    create_prolog_flag(debugger_write_options,
  956                       [ quoted(true),
  957                         portray(true),
  958                         max_depth(10),
  959                         attributes(portray),
  960                         spacing(next_argument)
  961                       ], []).
  962'$set_debugger_write_options'(Depth) :-
  963    current_prolog_flag(debugger_write_options, Options0),
  964    (   '$select'(max_depth(_), Options0, Options)
  965    ->  true
  966    ;   Options = Options0
  967    ),
  968    create_prolog_flag(debugger_write_options,
  969                       [max_depth(Depth)|Options], []).
  970
  971
  972                /********************************
  973                *        SYSTEM MESSAGES        *
  974                *********************************/

 $confirm(Spec)

Ask the user to confirm a question. Spec is a term as used for print_message/2.

  981'$confirm'(Spec) :-
  982    print_message(query, Spec),
  983    between(0, 5, _),
  984        get_single_char(Answer),
  985        (   '$in_reply'(Answer, 'yYjJ \n')
  986        ->  !,
  987            print_message(query, if_tty([yes-[]]))
  988        ;   '$in_reply'(Answer, 'nN')
  989        ->  !,
  990            print_message(query, if_tty([no-[]])),
  991            fail
  992        ;   print_message(help, query(confirm)),
  993            fail
  994        ).
  995
  996'$in_reply'(Code, Atom) :-
  997    char_code(Char, Code),
  998    sub_atom(Atom, _, _, _, Char),
  999    !.
 1000
 1001:- dynamic
 1002    user:portray/1. 1003:- multifile
 1004    user:portray/1. 1005
 1006
 1007                 /*******************************
 1008                 *       FILE_SEARCH_PATH       *
 1009                 *******************************/
 1010
 1011:- dynamic
 1012    user:file_search_path/2,
 1013    user:library_directory/1. 1014:- multifile
 1015    user:file_search_path/2,
 1016    user:library_directory/1. 1017
 1018user:(file_search_path(library, Dir) :-
 1019        library_directory(Dir)).
 1020user:file_search_path(swi, Home) :-
 1021    current_prolog_flag(home, Home).
 1022user:file_search_path(swi, Home) :-
 1023    current_prolog_flag(shared_home, Home).
 1024user:file_search_path(library, app_config(lib)).
 1025user:file_search_path(library, swi(library)).
 1026user:file_search_path(library, swi(library/clp)).
 1027user:file_search_path(foreign, swi(ArchLib)) :-
 1028    \+ current_prolog_flag(windows, true),
 1029    current_prolog_flag(arch, Arch),
 1030    atom_concat('lib/', Arch, ArchLib).
 1031user:file_search_path(foreign, swi(SoLib)) :-
 1032    (   current_prolog_flag(windows, true)
 1033    ->  SoLib = bin
 1034    ;   SoLib = lib
 1035    ).
 1036user:file_search_path(path, Dir) :-
 1037    getenv('PATH', Path),
 1038    (   current_prolog_flag(windows, true)
 1039    ->  atomic_list_concat(Dirs, (;), Path)
 1040    ;   atomic_list_concat(Dirs, :, Path)
 1041    ),
 1042    '$member'(Dir, Dirs).
 1043user:file_search_path(user_app_data, Dir) :-
 1044    '$xdg_prolog_directory'(data, Dir).
 1045user:file_search_path(common_app_data, Dir) :-
 1046    '$xdg_prolog_directory'(common_data, Dir).
 1047user:file_search_path(user_app_config, Dir) :-
 1048    '$xdg_prolog_directory'(config, Dir).
 1049user:file_search_path(common_app_config, Dir) :-
 1050    '$xdg_prolog_directory'(common_config, Dir).
 1051user:file_search_path(app_data, user_app_data('.')).
 1052user:file_search_path(app_data, common_app_data('.')).
 1053user:file_search_path(app_config, user_app_config('.')).
 1054user:file_search_path(app_config, common_app_config('.')).
 1055% backward compatibility
 1056user:file_search_path(app_preferences, user_app_config('.')).
 1057user:file_search_path(user_profile, app_preferences('.')).
 1058
 1059'$xdg_prolog_directory'(Which, Dir) :-
 1060    '$xdg_directory'(Which, XDGDir),
 1061    '$make_config_dir'(XDGDir),
 1062    '$ensure_slash'(XDGDir, XDGDirS),
 1063    atom_concat(XDGDirS, 'swi-prolog', Dir),
 1064    '$make_config_dir'(Dir).
 1065
 1066% config
 1067'$xdg_directory'(config, Home) :-
 1068    current_prolog_flag(windows, true),
 1069    catch(win_folder(appdata, Home), _, fail),
 1070    !.
 1071'$xdg_directory'(config, Home) :-
 1072    getenv('XDG_CONFIG_HOME', Home).
 1073'$xdg_directory'(config, Home) :-
 1074    expand_file_name('~/.config', [Home]).
 1075% data
 1076'$xdg_directory'(data, Home) :-
 1077    current_prolog_flag(windows, true),
 1078    catch(win_folder(local_appdata, Home), _, fail),
 1079    !.
 1080'$xdg_directory'(data, Home) :-
 1081    getenv('XDG_DATA_HOME', Home).
 1082'$xdg_directory'(data, Home) :-
 1083    expand_file_name('~/.local', [Local]),
 1084    '$make_config_dir'(Local),
 1085    atom_concat(Local, '/share', Home),
 1086    '$make_config_dir'(Home).
 1087% common data
 1088'$xdg_directory'(common_data, Dir) :-
 1089    current_prolog_flag(windows, true),
 1090    catch(win_folder(common_appdata, Dir), _, fail),
 1091    !.
 1092'$xdg_directory'(common_data, Dir) :-
 1093    '$existing_dir_from_env_path'('XDG_DATA_DIRS',
 1094                                  [ '/usr/local/share',
 1095                                    '/usr/share'
 1096                                  ],
 1097                                  Dir).
 1098% common config
 1099'$xdg_directory'(common_config, Dir) :-
 1100    current_prolog_flag(windows, true),
 1101    catch(win_folder(common_appdata, Dir), _, fail),
 1102    !.
 1103'$xdg_directory'(common_config, Dir) :-
 1104    '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir).
 1105
 1106'$existing_dir_from_env_path'(Env, Defaults, Dir) :-
 1107    (   getenv(Env, Path)
 1108    ->  '$path_sep'(Sep),
 1109        atomic_list_concat(Dirs, Sep, Path)
 1110    ;   Dirs = Defaults
 1111    ),
 1112    '$member'(Dir, Dirs),
 1113    Dir \== '',
 1114    exists_directory(Dir).
 1115
 1116'$path_sep'(Char) :-
 1117    (   current_prolog_flag(windows, true)
 1118    ->  Char = ';'
 1119    ;   Char = ':'
 1120    ).
 1121
 1122'$make_config_dir'(Dir) :-
 1123    exists_directory(Dir),
 1124    !.
 1125'$make_config_dir'(Dir) :-
 1126    nb_current('$create_search_directories', true),
 1127    file_directory_name(Dir, Parent),
 1128    '$my_file'(Parent),
 1129    catch(make_directory(Dir), _, fail).
 1130
 1131'$ensure_slash'(Dir, DirS) :-
 1132    (   sub_atom(Dir, _, _, 0, /)
 1133    ->  DirS = Dir
 1134    ;   atom_concat(Dir, /, DirS)
 1135    ).

 $expand_file_search_path(+Spec, -Expanded, +Cond) is nondet

 1140'$expand_file_search_path'(Spec, Expanded, Cond) :-
 1141    '$option'(access(Access), Cond),
 1142    memberchk(Access, [write,append]),
 1143    !,
 1144    setup_call_cleanup(
 1145        nb_setval('$create_search_directories', true),
 1146        expand_file_search_path(Spec, Expanded),
 1147        nb_delete('$create_search_directories')).
 1148'$expand_file_search_path'(Spec, Expanded, _Cond) :-
 1149    expand_file_search_path(Spec, Expanded).

 expand_file_search_path(+Spec, -Expanded) is nondet

Expand a search path. The system uses depth-first search upto a specified depth. If this depth is exceeded an exception is raised. TBD: bread-first search?

 1157expand_file_search_path(Spec, Expanded) :-
 1158    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
 1159          loop(Used),
 1160          throw(error(loop_error(Spec), file_search(Used)))).
 1161
 1162'$expand_file_search_path'(Spec, Expanded, N, Used) :-
 1163    functor(Spec, Alias, 1),
 1164    !,
 1165    user:file_search_path(Alias, Exp0),
 1166    NN is N + 1,
 1167    (   NN > 16
 1168    ->  throw(loop(Used))
 1169    ;   true
 1170    ),
 1171    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
 1172    arg(1, Spec, Segments),
 1173    '$segments_to_atom'(Segments, File),
 1174    '$make_path'(Exp1, File, Expanded).
 1175'$expand_file_search_path'(Spec, Path, _, _) :-
 1176    '$segments_to_atom'(Spec, Path).
 1177
 1178'$make_path'(Dir, '.', Path) :-
 1179    !,
 1180    Path = Dir.
 1181'$make_path'(Dir, File, Path) :-
 1182    sub_atom(Dir, _, _, 0, /),
 1183    !,
 1184    atom_concat(Dir, File, Path).
 1185'$make_path'(Dir, File, Path) :-
 1186    atomic_list_concat([Dir, /, File], Path).
 1187
 1188
 1189                /********************************
 1190                *         FILE CHECKING         *
 1191                *********************************/

 absolute_file_name(+Term, -AbsoluteFile, +Options) is nondet

Translate path-specifier into a full path-name. This predicate originates from Quintus was introduced in SWI-Prolog very early and has re-appeared in SICStus 3.9.0, where they changed argument order and added some options. We addopted the SICStus argument order, but still accept the original argument order for compatibility reasons.

 1202absolute_file_name(Spec, Options, Path) :-
 1203    '$is_options'(Options),
 1204    \+ '$is_options'(Path),
 1205    !,
 1206    absolute_file_name(Spec, Path, Options).
 1207absolute_file_name(Spec, Path, Options) :-
 1208    '$must_be'(options, Options),
 1209                    % get the valid extensions
 1210    (   '$select_option'(extensions(Exts), Options, Options1)
 1211    ->  '$must_be'(list, Exts)
 1212    ;   '$option'(file_type(Type), Options)
 1213    ->  '$must_be'(atom, Type),
 1214        '$file_type_extensions'(Type, Exts),
 1215        Options1 = Options
 1216    ;   Options1 = Options,
 1217        Exts = ['']
 1218    ),
 1219    '$canonicalise_extensions'(Exts, Extensions),
 1220                    % unless specified otherwise, ask regular file
 1221    (   (   nonvar(Type)
 1222        ;   '$option'(access(none), Options, none)
 1223        )
 1224    ->  Options2 = Options1
 1225    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
 1226    ),
 1227                    % Det or nondet?
 1228    (   '$select_option'(solutions(Sols), Options2, Options3)
 1229    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
 1230    ;   Sols = first,
 1231        Options3 = Options2
 1232    ),
 1233                    % Errors or not?
 1234    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
 1235    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
 1236    ;   FileErrors = error,
 1237        Options4 = Options3
 1238    ),
 1239                    % Expand shell patterns?
 1240    (   atomic(Spec),
 1241        '$select_option'(expand(Expand), Options4, Options5),
 1242        '$must_be'(boolean, Expand)
 1243    ->  expand_file_name(Spec, List),
 1244        '$member'(Spec1, List)
 1245    ;   Spec1 = Spec,
 1246        Options5 = Options4
 1247    ),
 1248                    % Search for files
 1249    (   Sols == first
 1250    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
 1251        ->  !       % also kill choice point of expand_file_name/2
 1252        ;   (   FileErrors == fail
 1253            ->  fail
 1254            ;   '$current_module'('$bags', _File),
 1255                findall(P,
 1256                        '$chk_file'(Spec1, Extensions, [access(exist)],
 1257                                    false, P),
 1258                        Candidates),
 1259                '$abs_file_error'(Spec, Candidates, Options5)
 1260            )
 1261        )
 1262    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 1263    ).
 1264
 1265'$abs_file_error'(Spec, Candidates, Conditions) :-
 1266    '$member'(F, Candidates),
 1267    '$member'(C, Conditions),
 1268    '$file_condition'(C),
 1269    '$file_error'(C, Spec, F, E, Comment),
 1270    !,
 1271    throw(error(E, context(_, Comment))).
 1272'$abs_file_error'(Spec, _, _) :-
 1273    '$existence_error'(source_sink, Spec).
 1274
 1275'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 1276    \+ exists_directory(File),
 1277    !,
 1278    Error = existence_error(directory, Spec),
 1279    Comment = not_a_directory(File).
 1280'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 1281    exists_directory(File),
 1282    !,
 1283    Error = existence_error(file, Spec),
 1284    Comment = directory(File).
 1285'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 1286    '$one_or_member'(Access, OneOrList),
 1287    \+ access_file(File, Access),
 1288    Error = permission_error(Access, source_sink, Spec).
 1289
 1290'$one_or_member'(Elem, List) :-
 1291    is_list(List),
 1292    !,
 1293    '$member'(Elem, List).
 1294'$one_or_member'(Elem, Elem).
 1295
 1296
 1297'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 1298    !,
 1299    '$file_type_extensions'(prolog, Exts).
 1300'$file_type_extensions'(Type, Exts) :-
 1301    '$current_module'('$bags', _File),
 1302    !,
 1303    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 1304    (   Exts0 == [],
 1305        \+ '$ft_no_ext'(Type)
 1306    ->  '$domain_error'(file_type, Type)
 1307    ;   true
 1308    ),
 1309    '$append'(Exts0, [''], Exts).
 1310'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 1311
 1312'$ft_no_ext'(txt).
 1313'$ft_no_ext'(executable).
 1314'$ft_no_ext'(directory).
 1315'$ft_no_ext'(regular).

 user:prolog_file_type(?Extension, ?Type)

Define type of file based on the extension. This is used by absolute_file_name/3 and may be used to extend the list of extensions used for some type.

Note that qlf must be last when searching for Prolog files. Otherwise use_module/1 will consider the file as not-loaded because the .qlf file is not the loaded file. Must be fixed elsewhere.

 1328:- multifile(user:prolog_file_type/2). 1329:- dynamic(user:prolog_file_type/2). 1330
 1331user:prolog_file_type(pl,       prolog).
 1332user:prolog_file_type(prolog,   prolog).
 1333user:prolog_file_type(qlf,      prolog).
 1334user:prolog_file_type(qlf,      qlf).
 1335user:prolog_file_type(Ext,      executable) :-
 1336    current_prolog_flag(shared_object_extension, Ext).
 1337user:prolog_file_type(dylib,    executable) :-
 1338    current_prolog_flag(apple,  true).

 $chk_file(+Spec, +Extensions, +Cond, +UseCache, -FullName)

File is a specification of a Prolog source file. Return the full path of the file.

 1345'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1346    \+ ground(Spec),
 1347    !,
 1348    '$instantiation_error'(Spec).
 1349'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1350    compound(Spec),
 1351    functor(Spec, _, 1),
 1352    !,
 1353    '$relative_to'(Cond, cwd, CWD),
 1354    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1355'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1356    \+ atomic(Segments),
 1357    !,
 1358    '$segments_to_atom'(Segments, Atom),
 1359    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1360'$chk_file'(File, Exts, Cond, _, FullName) :-
 1361    is_absolute_file_name(File),
 1362    !,
 1363    '$extend_file'(File, Exts, Extended),
 1364    '$file_conditions'(Cond, Extended),
 1365    '$absolute_file_name'(Extended, FullName).
 1366'$chk_file'(File, Exts, Cond, _, FullName) :-
 1367    '$relative_to'(Cond, source, Dir),
 1368    atomic_list_concat([Dir, /, File], AbsFile),
 1369    '$extend_file'(AbsFile, Exts, Extended),
 1370    '$file_conditions'(Cond, Extended),
 1371    !,
 1372    '$absolute_file_name'(Extended, FullName).
 1373'$chk_file'(File, Exts, Cond, _, FullName) :-
 1374    '$extend_file'(File, Exts, Extended),
 1375    '$file_conditions'(Cond, Extended),
 1376    '$absolute_file_name'(Extended, FullName).
 1377
 1378'$segments_to_atom'(Atom, Atom) :-
 1379    atomic(Atom),
 1380    !.
 1381'$segments_to_atom'(Segments, Atom) :-
 1382    '$segments_to_list'(Segments, List, []),
 1383    !,
 1384    atomic_list_concat(List, /, Atom).
 1385
 1386'$segments_to_list'(A/B, H, T) :-
 1387    '$segments_to_list'(A, H, T0),
 1388    '$segments_to_list'(B, T0, T).
 1389'$segments_to_list'(A, [A|T], T) :-
 1390    atomic(A).

 $relative_to(+Condition, +Default, -Dir)

Determine the directory to work from. This can be specified explicitely using one or more relative_to(FileOrDir) options or implicitely relative to the working directory or current source-file.

 1400'$relative_to'(Conditions, Default, Dir) :-
 1401    (   '$option'(relative_to(FileOrDir), Conditions)
 1402    *-> (   exists_directory(FileOrDir)
 1403        ->  Dir = FileOrDir
 1404        ;   atom_concat(Dir, /, FileOrDir)
 1405        ->  true
 1406        ;   file_directory_name(FileOrDir, Dir)
 1407        )
 1408    ;   Default == cwd
 1409    ->  '$cwd'(Dir)
 1410    ;   Default == source
 1411    ->  source_location(ContextFile, _Line),
 1412        file_directory_name(ContextFile, Dir)
 1413    ).

 $chk_alias_file(+Spec, +Exts, +Cond, +Cache, +CWD, -FullFile) is nondet

 1418:- dynamic
 1419    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1420    '$search_path_gc_time'/1.       % Time
 1421:- volatile
 1422    '$search_path_file_cache'/3,
 1423    '$search_path_gc_time'/1. 1424
 1425:- create_prolog_flag(file_search_cache_time, 10, []). 1426
 1427'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1428    !,
 1429    findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
 1430    current_prolog_flag(emulated_dialect, Dialect),
 1431    Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
 1432    variant_sha1(Spec+Cache, SHA1),
 1433    get_time(Now),
 1434    current_prolog_flag(file_search_cache_time, TimeOut),
 1435    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1436        CachedTime > Now - TimeOut,
 1437        '$file_conditions'(Cond, FullFile)
 1438    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1439    ;   '$member'(Expanded, Expansions),
 1440        '$extend_file'(Expanded, Exts, LibFile),
 1441        (   '$file_conditions'(Cond, LibFile),
 1442            '$absolute_file_name'(LibFile, FullFile),
 1443            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1444        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1445        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1446            fail
 1447        )
 1448    ).
 1449'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1450    '$expand_file_search_path'(Spec, Expanded, Cond),
 1451    '$extend_file'(Expanded, Exts, LibFile),
 1452    '$file_conditions'(Cond, LibFile),
 1453    '$absolute_file_name'(LibFile, FullFile).
 1454
 1455'$cache_file_found'(_, _, TimeOut, _) :-
 1456    TimeOut =:= 0,
 1457    !.
 1458'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1459    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1460    !,
 1461    (   Now - Saved < TimeOut/2
 1462    ->  true
 1463    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1464        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1465    ).
 1466'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1467    'gc_file_search_cache'(TimeOut),
 1468    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1469
 1470'gc_file_search_cache'(TimeOut) :-
 1471    get_time(Now),
 1472    '$search_path_gc_time'(Last),
 1473    Now-Last < TimeOut/2,
 1474    !.
 1475'gc_file_search_cache'(TimeOut) :-
 1476    get_time(Now),
 1477    retractall('$search_path_gc_time'(_)),
 1478    assertz('$search_path_gc_time'(Now)),
 1479    Before is Now - TimeOut,
 1480    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1481        Cached < Before,
 1482        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1483        fail
 1484    ;   true
 1485    ).
 1486
 1487
 1488'$search_message'(Term) :-
 1489    current_prolog_flag(verbose_file_search, true),
 1490    !,
 1491    print_message(informational, Term).
 1492'$search_message'(_).

 $file_conditions(+Condition, +Path)

Verify Path satisfies Condition.

 1499'$file_conditions'(List, File) :-
 1500    is_list(List),
 1501    !,
 1502    \+ ( '$member'(C, List),
 1503         '$file_condition'(C),
 1504         \+ '$file_condition'(C, File)
 1505       ).
 1506'$file_conditions'(Map, File) :-
 1507    \+ (  get_dict(Key, Map, Value),
 1508          C =.. [Key,Value],
 1509          '$file_condition'(C),
 1510         \+ '$file_condition'(C, File)
 1511       ).
 1512
 1513'$file_condition'(file_type(directory), File) :-
 1514    !,
 1515    exists_directory(File).
 1516'$file_condition'(file_type(_), File) :-
 1517    !,
 1518    \+ exists_directory(File).
 1519'$file_condition'(access(Accesses), File) :-
 1520    !,
 1521    \+ (  '$one_or_member'(Access, Accesses),
 1522          \+ access_file(File, Access)
 1523       ).
 1524
 1525'$file_condition'(exists).
 1526'$file_condition'(file_type(_)).
 1527'$file_condition'(access(_)).
 1528
 1529'$extend_file'(File, Exts, FileEx) :-
 1530    '$ensure_extensions'(Exts, File, Fs),
 1531    '$list_to_set'(Fs, FsSet),
 1532    '$member'(FileEx, FsSet).
 1533
 1534'$ensure_extensions'([], _, []).
 1535'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1536    file_name_extension(F, E, FE),
 1537    '$ensure_extensions'(E0, F, E1).

 $list_to_set(+List, -Set) is det

Turn list into a set, keeping the left-most copy of duplicate elements. Copied from library(lists).

 1544'$list_to_set'(List, Set) :-
 1545    '$number_list'(List, 1, Numbered),
 1546    sort(1, @=<, Numbered, ONum),
 1547    '$remove_dup_keys'(ONum, NumSet),
 1548    sort(2, @=<, NumSet, ONumSet),
 1549    '$pairs_keys'(ONumSet, Set).
 1550
 1551'$number_list'([], _, []).
 1552'$number_list'([H|T0], N, [H-N|T]) :-
 1553    N1 is N+1,
 1554    '$number_list'(T0, N1, T).
 1555
 1556'$remove_dup_keys'([], []).
 1557'$remove_dup_keys'([H|T0], [H|T]) :-
 1558    H = V-_,
 1559    '$remove_same_key'(T0, V, T1),
 1560    '$remove_dup_keys'(T1, T).
 1561
 1562'$remove_same_key'([V1-_|T0], V, T) :-
 1563    V1 == V,
 1564    !,
 1565    '$remove_same_key'(T0, V, T).
 1566'$remove_same_key'(L, _, L).
 1567
 1568'$pairs_keys'([], []).
 1569'$pairs_keys'([K-_|T0], [K|T]) :-
 1570    '$pairs_keys'(T0, T).
 1571
 1572
 1573/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 1574Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
 1575the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
 1576extensions to .ext
 1577- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 1578
 1579'$canonicalise_extensions'([], []) :- !.
 1580'$canonicalise_extensions'([H|T], [CH|CT]) :-
 1581    !,
 1582    '$must_be'(atom, H),
 1583    '$canonicalise_extension'(H, CH),
 1584    '$canonicalise_extensions'(T, CT).
 1585'$canonicalise_extensions'(E, [CE]) :-
 1586    '$canonicalise_extension'(E, CE).
 1587
 1588'$canonicalise_extension'('', '') :- !.
 1589'$canonicalise_extension'(DotAtom, DotAtom) :-
 1590    sub_atom(DotAtom, 0, _, _, '.'),
 1591    !.
 1592'$canonicalise_extension'(Atom, DotAtom) :-
 1593    atom_concat('.', Atom, DotAtom).
 1594
 1595
 1596                /********************************
 1597                *            CONSULT            *
 1598                *********************************/
 1599
 1600:- dynamic
 1601    user:library_directory/1,
 1602    user:prolog_load_file/2. 1603:- multifile
 1604    user:library_directory/1,
 1605    user:prolog_load_file/2. 1606
 1607:- prompt(_, '|: '). 1608
 1609:- thread_local
 1610    '$compilation_mode_store'/1,    % database, wic, qlf
 1611    '$directive_mode_store'/1.      % database, wic, qlf
 1612:- volatile
 1613    '$compilation_mode_store'/1,
 1614    '$directive_mode_store'/1. 1615
 1616'$compilation_mode'(Mode) :-
 1617    (   '$compilation_mode_store'(Val)
 1618    ->  Mode = Val
 1619    ;   Mode = database
 1620    ).
 1621
 1622'$set_compilation_mode'(Mode) :-
 1623    retractall('$compilation_mode_store'(_)),
 1624    assertz('$compilation_mode_store'(Mode)).
 1625
 1626'$compilation_mode'(Old, New) :-
 1627    '$compilation_mode'(Old),
 1628    (   New == Old
 1629    ->  true
 1630    ;   '$set_compilation_mode'(New)
 1631    ).
 1632
 1633'$directive_mode'(Mode) :-
 1634    (   '$directive_mode_store'(Val)
 1635    ->  Mode = Val
 1636    ;   Mode = database
 1637    ).
 1638
 1639'$directive_mode'(Old, New) :-
 1640    '$directive_mode'(Old),
 1641    (   New == Old
 1642    ->  true
 1643    ;   '$set_directive_mode'(New)
 1644    ).
 1645
 1646'$set_directive_mode'(Mode) :-
 1647    retractall('$directive_mode_store'(_)),
 1648    assertz('$directive_mode_store'(Mode)).