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', [])).

 memberchk(?E, ?List) is semidet

Semantically equivalent to once(member(E,List)). Implemented in C. If List is partial though we need to do the work in Prolog to get the proper constraint behavior. Needs to be defined early as the boot code uses it.

   76memberchk(E, List) :-
   77    '$memberchk'(E, List, Tail),
   78    (   nonvar(Tail)
   79    ->  true
   80    ;   Tail = [_|_],
   81        memberchk(E, Tail)
   82    ).
   83
   84                /********************************
   85                *          DIRECTIVES           *
   86                *********************************/
   87
   88:- meta_predicate
   89    dynamic(:),
   90    multifile(:),
   91    public(:),
   92    module_transparent(:),
   93    discontiguous(:),
   94    volatile(:),
   95    thread_local(:),
   96    noprofile(:),
   97    non_terminal(:),
   98    '$clausable'(:),
   99    '$iso'(:),
  100    '$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.

  132dynamic(Spec)            :- '$set_pattr'(Spec, pred, dynamic(true)).
  133multifile(Spec)          :- '$set_pattr'(Spec, pred, multifile(true)).
  134module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)).
  135discontiguous(Spec)      :- '$set_pattr'(Spec, pred, discontiguous(true)).
  136volatile(Spec)           :- '$set_pattr'(Spec, pred, volatile(true)).
  137thread_local(Spec)       :- '$set_pattr'(Spec, pred, thread_local(true)).
  138noprofile(Spec)          :- '$set_pattr'(Spec, pred, noprofile(true)).
  139public(Spec)             :- '$set_pattr'(Spec, pred, public(true)).
  140non_terminal(Spec)       :- '$set_pattr'(Spec, pred, non_terminal(true)).
  141det(Spec)                :- '$set_pattr'(Spec, pred, det(true)).
  142'$iso'(Spec)             :- '$set_pattr'(Spec, pred, iso(true)).
  143'$clausable'(Spec)       :- '$set_pattr'(Spec, pred, clausable(true)).
  144'$hide'(Spec)            :- '$set_pattr'(Spec, pred, trace(false)).
  145
  146'$set_pattr'(M:Pred, How, Attr) :-
  147    '$set_pattr'(Pred, M, How, Attr).

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

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

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

  276'$pattr_directive'(dynamic(Spec), M) :-
  277    '$set_pattr'(Spec, M, directive, dynamic(true)).
  278'$pattr_directive'(multifile(Spec), M) :-
  279    '$set_pattr'(Spec, M, directive, multifile(true)).
  280'$pattr_directive'(module_transparent(Spec), M) :-
  281    '$set_pattr'(Spec, M, directive, transparent(true)).
  282'$pattr_directive'(discontiguous(Spec), M) :-
  283    '$set_pattr'(Spec, M, directive, discontiguous(true)).
  284'$pattr_directive'(volatile(Spec), M) :-
  285    '$set_pattr'(Spec, M, directive, volatile(true)).
  286'$pattr_directive'(thread_local(Spec), M) :-
  287    '$set_pattr'(Spec, M, directive, thread_local(true)).
  288'$pattr_directive'(noprofile(Spec), M) :-
  289    '$set_pattr'(Spec, M, directive, noprofile(true)).
  290'$pattr_directive'(public(Spec), M) :-
  291    '$set_pattr'(Spec, M, directive, public(true)).
  292'$pattr_directive'(det(Spec), M) :-
  293    '$set_pattr'(Spec, M, directive, det(true)).

 $pi_head(?PI, ?Head)

  297'$pi_head'(PI, Head) :-
  298    var(PI),
  299    var(Head),
  300    '$instantiation_error'([PI,Head]).
  301'$pi_head'(M:PI, M:Head) :-
  302    !,
  303    '$pi_head'(PI, Head).
  304'$pi_head'(Name/Arity, Head) :-
  305    !,
  306    '$head_name_arity'(Head, Name, Arity).
  307'$pi_head'(Name//DCGArity, Head) :-
  308    !,
  309    (   nonvar(DCGArity)
  310    ->  Arity is DCGArity+2,
  311        '$head_name_arity'(Head, Name, Arity)
  312    ;   '$head_name_arity'(Head, Name, Arity),
  313        DCGArity is Arity - 2
  314    ).
  315'$pi_head'(PI, _) :-
  316    '$type_error'(predicate_indicator, PI).

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

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

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

  416'$meta_call'(M:G) :-
  417    prolog_current_choice(Ch),
  418    '$meta_call'(G, M, Ch).
  419
  420'$meta_call'(Var, _, _) :-
  421    var(Var),
  422    !,
  423    '$instantiation_error'(Var).
  424'$meta_call'((A,B), M, Ch) :-
  425    !,
  426    '$meta_call'(A, M, Ch),
  427    '$meta_call'(B, M, Ch).
  428'$meta_call'((I->T;E), M, Ch) :-
  429    !,
  430    (   prolog_current_choice(Ch2),
  431        '$meta_call'(I, M, Ch2)
  432    ->  '$meta_call'(T, M, Ch)
  433    ;   '$meta_call'(E, M, Ch)
  434    ).
  435'$meta_call'((I*->T;E), M, Ch) :-
  436    !,
  437    (   prolog_current_choice(Ch2),
  438        '$meta_call'(I, M, Ch2)
  439    *-> '$meta_call'(T, M, Ch)
  440    ;   '$meta_call'(E, M, Ch)
  441    ).
  442'$meta_call'((I->T), M, Ch) :-
  443    !,
  444    (   prolog_current_choice(Ch2),
  445        '$meta_call'(I, M, Ch2)
  446    ->  '$meta_call'(T, M, Ch)
  447    ).
  448'$meta_call'((I*->T), M, Ch) :-
  449    !,
  450    prolog_current_choice(Ch2),
  451    '$meta_call'(I, M, Ch2),
  452    '$meta_call'(T, M, Ch).
  453'$meta_call'((A;B), M, Ch) :-
  454    !,
  455    (   '$meta_call'(A, M, Ch)
  456    ;   '$meta_call'(B, M, Ch)
  457    ).
  458'$meta_call'(\+(G), M, _) :-
  459    !,
  460    prolog_current_choice(Ch),
  461    \+ '$meta_call'(G, M, Ch).
  462'$meta_call'($(G), M, _) :-
  463    !,
  464    prolog_current_choice(Ch),
  465    $('$meta_call'(G, M, Ch)).
  466'$meta_call'(call(G), M, _) :-
  467    !,
  468    prolog_current_choice(Ch),
  469    '$meta_call'(G, M, Ch).
  470'$meta_call'(M:G, _, Ch) :-
  471    !,
  472    '$meta_call'(G, M, Ch).
  473'$meta_call'(!, _, Ch) :-
  474    prolog_cut_to(Ch).
  475'$meta_call'(G, M, _Ch) :-
  476    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..

  492:- '$iso'((call/2,
  493           call/3,
  494           call/4,
  495           call/5,
  496           call/6,
  497           call/7,
  498           call/8)).  499
  500call(Goal) :-                           % make these available as predicates
  501    Goal.
  502call(Goal, A) :-
  503    call(Goal, A).
  504call(Goal, A, B) :-
  505    call(Goal, A, B).
  506call(Goal, A, B, C) :-
  507    call(Goal, A, B, C).
  508call(Goal, A, B, C, D) :-
  509    call(Goal, A, B, C, D).
  510call(Goal, A, B, C, D, E) :-
  511    call(Goal, A, B, C, D, E).
  512call(Goal, A, B, C, D, E, F) :-
  513    call(Goal, A, B, C, D, E, F).
  514call(Goal, A, B, C, D, E, F, G) :-
  515    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.

  522not(Goal) :-
  523    \+ Goal.

 \+ :Goal is semidet

Predicate version that allows for meta-calling.

  529\+ Goal :-
  530    \+ Goal.

 once(:Goal) is semidet

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

  536once(Goal) :-
  537    Goal,
  538    !.

 ignore(:Goal) is det

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

  545ignore(Goal) :-
  546    Goal,
  547    !.
  548ignore(_Goal).
  549
  550:- '$iso'((false/0)).

 false

Synonym for fail/0, providing a declarative reading.

  556false :-
  557    fail.

 catch(:Goal, +Catcher, :Recover)

ISO compliant exception handling.

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

 prolog_cut_to(+Choice)

Cut all choice points after Choice

  570prolog_cut_to(_Choice) :-
  571    '$cut'.                         % Maps to I_CUTCHP

 $ is det

Declare that from now on this predicate succeeds deterministically.

  577'$' :- '$'.

 $ :Goal is det

Declare that Goal must succeed deterministically.

  583$(Goal) :- $(Goal).

 notrace(:Goal) is semidet

Suspend the tracer while running Goal.

  589:- '$hide'(notrace/1).  590
  591notrace(Goal) :-
  592    setup_call_cleanup(
  593        '$notrace'(Flags, SkipLevel),
  594        once(Goal),
  595        '$restore_trace'(Flags, SkipLevel)).

 reset(:Goal, ?Ball, -Continue)

Delimited continuation support.

  602reset(_Goal, _Ball, _Cont) :-
  603    '$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.

  612shift(Ball) :-
  613    '$shift'(Ball).
  614
  615shift_for_copy(Ball) :-
  616    '$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.

  630call_continuation([]).
  631call_continuation([TB|Rest]) :-
  632    (   Rest == []
  633    ->  '$call_continuation'(TB)
  634    ;   '$call_continuation'(TB),
  635        call_continuation(Rest)
  636    ).

 catch_with_backtrace(:Goal, ?Ball, :Recover)

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

  643catch_with_backtrace(Goal, Ball, Recover) :-
  644    catch(Goal, Ball, Recover),
  645    '$no_lco'.
  646
  647'$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.

  657:- public '$recover_and_rethrow'/2.  658
  659'$recover_and_rethrow'(Goal, Exception) :-
  660    call_cleanup(Goal, throw(Exception)),
  661    !.

 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.

  676setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
  677    sig_atomic(Setup),
  678    '$call_cleanup'.
  679
  680setup_call_cleanup(Setup, Goal, Cleanup) :-
  681    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
  682
  683call_cleanup(Goal, Cleanup) :-
  684    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
  685
  686call_cleanup(Goal, Catcher, Cleanup) :-
  687    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
  688
  689                 /*******************************
  690                 *       INITIALIZATION         *
  691                 *******************************/
  692
  693:- meta_predicate
  694    initialization(0, +).  695
  696:- multifile '$init_goal'/3.  697:- 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.

  723initialization(Goal, When) :-
  724    '$must_be'(oneof(atom, initialization_type,
  725                     [ now,
  726                       after_load,
  727                       restore,
  728                       restore_state,
  729                       prepare_state,
  730                       program,
  731                       main
  732                     ]), When),
  733    '$initialization_context'(Source, Ctx),
  734    '$initialization'(When, Goal, Source, Ctx).
  735
  736'$initialization'(now, Goal, _Source, Ctx) :-
  737    '$run_init_goal'(Goal, Ctx),
  738    '$compile_init_goal'(-, Goal, Ctx).
  739'$initialization'(after_load, Goal, Source, Ctx) :-
  740    (   Source \== (-)
  741    ->  '$compile_init_goal'(Source, Goal, Ctx)
  742    ;   throw(error(context_error(nodirective,
  743                                  initialization(Goal, after_load)),
  744                    _))
  745    ).
  746'$initialization'(restore, Goal, Source, Ctx) :- % deprecated
  747    '$initialization'(restore_state, Goal, Source, Ctx).
  748'$initialization'(restore_state, Goal, _Source, Ctx) :-
  749    (   \+ current_prolog_flag(sandboxed_load, true)
  750    ->  '$compile_init_goal'(-, Goal, Ctx)
  751    ;   '$permission_error'(register, initialization(restore), Goal)
  752    ).
  753'$initialization'(prepare_state, Goal, _Source, Ctx) :-
  754    (   \+ current_prolog_flag(sandboxed_load, true)
  755    ->  '$compile_init_goal'(when(prepare_state), Goal, Ctx)
  756    ;   '$permission_error'(register, initialization(restore), Goal)
  757    ).
  758'$initialization'(program, Goal, _Source, Ctx) :-
  759    (   \+ current_prolog_flag(sandboxed_load, true)
  760    ->  '$compile_init_goal'(when(program), Goal, Ctx)
  761    ;   '$permission_error'(register, initialization(restore), Goal)
  762    ).
  763'$initialization'(main, Goal, _Source, Ctx) :-
  764    (   \+ current_prolog_flag(sandboxed_load, true)
  765    ->  '$compile_init_goal'(when(main), Goal, Ctx)
  766    ;   '$permission_error'(register, initialization(restore), Goal)
  767    ).
  768
  769
  770'$compile_init_goal'(Source, Goal, Ctx) :-
  771    atom(Source),
  772    Source \== (-),
  773    !,
  774    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
  775                          _Layout, Source, Ctx).
  776'$compile_init_goal'(Source, Goal, Ctx) :-
  777    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.

  789'$run_initialization'(_, loaded, _) :- !.
  790'$run_initialization'(File, _Action, Options) :-
  791    '$run_initialization'(File, Options).
  792
  793'$run_initialization'(File, Options) :-
  794    setup_call_cleanup(
  795        '$start_run_initialization'(Options, Restore),
  796        '$run_initialization_2'(File),
  797        '$end_run_initialization'(Restore)).
  798
  799'$start_run_initialization'(Options, OldSandBoxed) :-
  800    '$push_input_context'(initialization),
  801    '$set_sandboxed_load'(Options, OldSandBoxed).
  802'$end_run_initialization'(OldSandBoxed) :-
  803    set_prolog_flag(sandboxed_load, OldSandBoxed),
  804    '$pop_input_context'.
  805
  806'$run_initialization_2'(File) :-
  807    (   '$init_goal'(File, Goal, Ctx),
  808        File \= when(_),
  809        '$run_init_goal'(Goal, Ctx),
  810        fail
  811    ;   true
  812    ).
  813
  814'$run_init_goal'(Goal, Ctx) :-
  815    (   catch_with_backtrace('$run_init_goal'(Goal), E,
  816                             '$initialization_error'(E, Goal, Ctx))
  817    ->  true
  818    ;   '$initialization_failure'(Goal, Ctx)
  819    ).
  820
  821:- multifile prolog:sandbox_allowed_goal/1.  822
  823'$run_init_goal'(Goal) :-
  824    current_prolog_flag(sandboxed_load, false),
  825    !,
  826    call(Goal).
  827'$run_init_goal'(Goal) :-
  828    prolog:sandbox_allowed_goal(Goal),
  829    call(Goal).
  830
  831'$initialization_context'(Source, Ctx) :-
  832    (   source_location(File, Line)
  833    ->  Ctx = File:Line,
  834        '$input_context'(Context),
  835        '$top_file'(Context, File, Source)
  836    ;   Ctx = (-),
  837        File = (-)
  838    ).
  839
  840'$top_file'([input(include, F1, _, _)|T], _, F) :-
  841    !,
  842    '$top_file'(T, F1, F).
  843'$top_file'(_, F, F).
  844
  845
  846'$initialization_error'(E, Goal, Ctx) :-
  847    print_message(error, initialization_error(Goal, E, Ctx)).
  848
  849'$initialization_failure'(Goal, Ctx) :-
  850    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

  858:- public '$clear_source_admin'/1.  859
  860'$clear_source_admin'(File) :-
  861    retractall('$init_goal'(_, _, File:_)),
  862    retractall('$load_context_module'(File, _, _)),
  863    retractall('$resolved_source_path_db'(_, _, File)).
  864
  865
  866                 /*******************************
  867                 *            STREAM            *
  868                 *******************************/
  869
  870:- '$iso'(stream_property/2).  871stream_property(Stream, Property) :-
  872    nonvar(Stream),
  873    nonvar(Property),
  874    !,
  875    '$stream_property'(Stream, Property).
  876stream_property(Stream, Property) :-
  877    nonvar(Stream),
  878    !,
  879    '$stream_properties'(Stream, Properties),
  880    '$member'(Property, Properties).
  881stream_property(Stream, Property) :-
  882    nonvar(Property),
  883    !,
  884    (   Property = alias(Alias),
  885        atom(Alias)
  886    ->  '$alias_stream'(Alias, Stream)
  887    ;   '$streams_properties'(Property, Pairs),
  888        '$member'(Stream-Property, Pairs)
  889    ).
  890stream_property(Stream, Property) :-
  891    '$streams_properties'(Property, Pairs),
  892    '$member'(Stream-Properties, Pairs),
  893    '$member'(Property, Properties).
  894
  895
  896                /********************************
  897                *            MODULES            *
  898                *********************************/
  899
  900%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
  901%       Tags `Term' with `Module:' if `Module' is not the context module.
  902
  903'$prefix_module'(Module, Module, Head, Head) :- !.
  904'$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'.

  910default_module(Me, Super) :-
  911    (   atom(Me)
  912    ->  (   var(Super)
  913        ->  '$default_module'(Me, Super)
  914        ;   '$default_module'(Me, Super), !
  915        )
  916    ;   '$type_error'(module, Me)
  917    ).
  918
  919'$default_module'(Me, Me).
  920'$default_module'(Me, Super) :-
  921    import_module(Me, S),
  922    '$default_module'(S, Super).
  923
  924
  925                /********************************
  926                *      TRACE AND EXCEPTIONS     *
  927                *********************************/
  928
  929:- dynamic   user:exception/3.  930:- multifile user:exception/3.  931:- '$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.

  940:- public
  941    '$undefined_procedure'/4.  942
  943'$undefined_procedure'(Module, Name, Arity, Action) :-
  944    '$prefix_module'(Module, user, Name/Arity, Pred),
  945    user:exception(undefined_predicate, Pred, Action0),
  946    !,
  947    Action = Action0.
  948'$undefined_procedure'(Module, Name, Arity, Action) :-
  949    \+ current_prolog_flag(autoload, false),
  950    '$autoload'(Module:Name/Arity),
  951    !,
  952    Action = retry.
  953'$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.

  965'$loading'(Library) :-
  966    current_prolog_flag(threads, true),
  967    (   '$loading_file'(Library, _Queue, _LoadThread)
  968    ->  true
  969    ;   '$loading_file'(FullFile, _Queue, _LoadThread),
  970        file_name_extension(Library, _, FullFile)
  971    ->  true
  972    ).
  973
  974%        handle debugger 'w', 'p' and <N> depth options.
  975
  976'$set_debugger_write_options'(write) :-
  977    !,
  978    create_prolog_flag(debugger_write_options,
  979                       [ quoted(true),
  980                         attributes(dots),
  981                         spacing(next_argument)
  982                       ], []).
  983'$set_debugger_write_options'(print) :-
  984    !,
  985    create_prolog_flag(debugger_write_options,
  986                       [ quoted(true),
  987                         portray(true),
  988                         max_depth(10),
  989                         attributes(portray),
  990                         spacing(next_argument)
  991                       ], []).
  992'$set_debugger_write_options'(Depth) :-
  993    current_prolog_flag(debugger_write_options, Options0),
  994    (   '$select'(max_depth(_), Options0, Options)
  995    ->  true
  996    ;   Options = Options0
  997    ),
  998    create_prolog_flag(debugger_write_options,
  999                       [max_depth(Depth)|Options], []).
 1000
 1001
 1002                /********************************
 1003                *        SYSTEM MESSAGES        *
 1004                *********************************/

 $confirm(Spec) is semidet

Ask the user to confirm a question. Spec is a term as used for print_message/2. It is printed the the query channel. This predicate may be hooked using confirm/2, which must return a boolean.

 1013:- multifile
 1014    prolog:confirm/2. 1015
 1016'$confirm'(Spec) :-
 1017    prolog:confirm(Spec, Result),
 1018    !,
 1019    Result == true.
 1020'$confirm'(Spec) :-
 1021    print_message(query, Spec),
 1022    between(0, 5, _),
 1023        get_single_char(Answer),
 1024        (   '$in_reply'(Answer, 'yYjJ \n')
 1025        ->  !,
 1026            print_message(query, if_tty([yes-[]]))
 1027        ;   '$in_reply'(Answer, 'nN')
 1028        ->  !,
 1029            print_message(query, if_tty([no-[]])),
 1030            fail
 1031        ;   print_message(help, query(confirm)),
 1032            fail
 1033        ).
 1034
 1035'$in_reply'(Code, Atom) :-
 1036    char_code(Char, Code),
 1037    sub_atom(Atom, _, _, _, Char),
 1038    !.
 1039
 1040:- dynamic
 1041    user:portray/1. 1042:- multifile
 1043    user:portray/1. 1044
 1045
 1046                 /*******************************
 1047                 *       FILE_SEARCH_PATH       *
 1048                 *******************************/
 1049
 1050:- dynamic
 1051    user:file_search_path/2,
 1052    user:library_directory/1. 1053:- multifile
 1054    user:file_search_path/2,
 1055    user:library_directory/1. 1056
 1057user:(file_search_path(library, Dir) :-
 1058        library_directory(Dir)).
 1059user:file_search_path(swi, Home) :-
 1060    current_prolog_flag(home, Home).
 1061user:file_search_path(swi, Home) :-
 1062    current_prolog_flag(shared_home, Home).
 1063user:file_search_path(library, app_config(lib)).
 1064user:file_search_path(library, swi(library)).
 1065user:file_search_path(library, swi(library/clp)).
 1066user:file_search_path(foreign, swi(ArchLib)) :-
 1067    current_prolog_flag(apple_universal_binary, true),
 1068    ArchLib = 'lib/fat-darwin'.
 1069user:file_search_path(foreign, swi(ArchLib)) :-
 1070    \+ current_prolog_flag(windows, true),
 1071    current_prolog_flag(arch, Arch),
 1072    atom_concat('lib/', Arch, ArchLib).
 1073user:file_search_path(foreign, swi(SoLib)) :-
 1074    (   current_prolog_flag(windows, true)
 1075    ->  SoLib = bin
 1076    ;   SoLib = lib
 1077    ).
 1078user:file_search_path(path, Dir) :-
 1079    getenv('PATH', Path),
 1080    (   current_prolog_flag(windows, true)
 1081    ->  atomic_list_concat(Dirs, (;), Path)
 1082    ;   atomic_list_concat(Dirs, :, Path)
 1083    ),
 1084    '$member'(Dir, Dirs).
 1085user:file_search_path(user_app_data, Dir) :-
 1086    '$xdg_prolog_directory'(data, Dir).
 1087user:file_search_path(common_app_data, Dir) :-
 1088    '$xdg_prolog_directory'(common_data, Dir).
 1089user:file_search_path(user_app_config, Dir) :-
 1090    '$xdg_prolog_directory'(config, Dir).
 1091user:file_search_path(common_app_config, Dir) :-
 1092    '$xdg_prolog_directory'(common_config, Dir).
 1093user:file_search_path(app_data, user_app_data('.')).
 1094user:file_search_path(app_data, common_app_data('.')).
 1095user:file_search_path(app_config, user_app_config('.')).
 1096user:file_search_path(app_config, common_app_config('.')).
 1097% backward compatibility
 1098user:file_search_path(app_preferences, user_app_config('.')).
 1099user:file_search_path(user_profile, app_preferences('.')).
 1100
 1101'$xdg_prolog_directory'(Which, Dir) :-
 1102    '$xdg_directory'(Which, XDGDir),
 1103    '$make_config_dir'(XDGDir),
 1104    '$ensure_slash'(XDGDir, XDGDirS),
 1105    atom_concat(XDGDirS, 'swi-prolog', Dir),
 1106    '$make_config_dir'(Dir).
 1107
 1108% config
 1109'$xdg_directory'(config, Home) :-
 1110    current_prolog_flag(windows, true),
 1111    catch(win_folder(appdata, Home), _, fail),
 1112    !.
 1113'$xdg_directory'(config, Home) :-
 1114    getenv('XDG_CONFIG_HOME', Home).
 1115'$xdg_directory'(config, Home) :-
 1116    expand_file_name('~/.config', [Home]).
 1117% data
 1118'$xdg_directory'(data, Home) :-
 1119    current_prolog_flag(windows, true),
 1120    catch(win_folder(local_appdata, Home), _, fail),
 1121    !.
 1122'$xdg_directory'(data, Home) :-
 1123    getenv('XDG_DATA_HOME', Home).
 1124'$xdg_directory'(data, Home) :-
 1125    expand_file_name('~/.local', [Local]),
 1126    '$make_config_dir'(Local),
 1127    atom_concat(Local, '/share', Home),
 1128    '$make_config_dir'(Home).
 1129% common data
 1130'$xdg_directory'(common_data, Dir) :-
 1131    current_prolog_flag(windows, true),
 1132    catch(win_folder(common_appdata, Dir), _, fail),
 1133    !.
 1134'$xdg_directory'(common_data, Dir) :-
 1135    '$existing_dir_from_env_path'('XDG_DATA_DIRS',
 1136                                  [ '/usr/local/share',
 1137                                    '/usr/share'
 1138                                  ],
 1139                                  Dir).
 1140% common config
 1141'$xdg_directory'(common_config, Dir) :-
 1142    current_prolog_flag(windows, true),
 1143    catch(win_folder(common_appdata, Dir), _, fail),
 1144    !.
 1145'$xdg_directory'(common_config, Dir) :-
 1146    '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir).
 1147
 1148'$existing_dir_from_env_path'(Env, Defaults, Dir) :-
 1149    (   getenv(Env, Path)
 1150    ->  '$path_sep'(Sep),
 1151        atomic_list_concat(Dirs, Sep, Path)
 1152    ;   Dirs = Defaults
 1153    ),
 1154    '$member'(Dir, Dirs),
 1155    Dir \== '',
 1156    exists_directory(Dir).
 1157
 1158'$path_sep'(Char) :-
 1159    (   current_prolog_flag(windows, true)
 1160    ->  Char = ';'
 1161    ;   Char = ':'
 1162    ).
 1163
 1164'$make_config_dir'(Dir) :-
 1165    exists_directory(Dir),
 1166    !.
 1167'$make_config_dir'(Dir) :-
 1168    nb_current('$create_search_directories', true),
 1169    file_directory_name(Dir, Parent),
 1170    '$my_file'(Parent),
 1171    catch(make_directory(Dir), _, fail).
 1172
 1173'$ensure_slash'(Dir, DirS) :-
 1174    (   sub_atom(Dir, _, _, 0, /)
 1175    ->  DirS = Dir
 1176    ;   atom_concat(Dir, /, DirS)
 1177    ).

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

 1182'$expand_file_search_path'(Spec, Expanded, Cond) :-
 1183    '$option'(access(Access), Cond),
 1184    memberchk(Access, [write,append]),
 1185    !,
 1186    setup_call_cleanup(
 1187        nb_setval('$create_search_directories', true),
 1188        expand_file_search_path(Spec, Expanded),
 1189        nb_delete('$create_search_directories')).
 1190'$expand_file_search_path'(Spec, Expanded, _Cond) :-
 1191    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?

 1199expand_file_search_path(Spec, Expanded) :-
 1200    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
 1201          loop(Used),
 1202          throw(error(loop_error(Spec), file_search(Used)))).
 1203
 1204'$expand_file_search_path'(Spec, Expanded, N, Used) :-
 1205    functor(Spec, Alias, 1),
 1206    !,
 1207    user:file_search_path(Alias, Exp0),
 1208    NN is N + 1,
 1209    (   NN > 16
 1210    ->  throw(loop(Used))
 1211    ;   true
 1212    ),
 1213    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
 1214    arg(1, Spec, Segments),
 1215    '$segments_to_atom'(Segments, File),
 1216    '$make_path'(Exp1, File, Expanded).
 1217'$expand_file_search_path'(Spec, Path, _, _) :-
 1218    '$segments_to_atom'(Spec, Path).
 1219
 1220'$make_path'(Dir, '.', Path) :-
 1221    !,
 1222    Path = Dir.
 1223'$make_path'(Dir, File, Path) :-
 1224    sub_atom(Dir, _, _, 0, /),
 1225    !,
 1226    atom_concat(Dir, File, Path).
 1227'$make_path'(Dir, File, Path) :-
 1228    atomic_list_concat([Dir, /, File], Path).
 1229
 1230
 1231                /********************************
 1232                *         FILE CHECKING         *
 1233                *********************************/

 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.

 1244absolute_file_name(Spec, Options, Path) :-
 1245    '$is_options'(Options),
 1246    \+ '$is_options'(Path),
 1247    !,
 1248    absolute_file_name(Spec, Path, Options).
 1249absolute_file_name(Spec, Path, Options) :-
 1250    '$must_be'(options, Options),
 1251                    % get the valid extensions
 1252    (   '$select_option'(extensions(Exts), Options, Options1)
 1253    ->  '$must_be'(list, Exts)
 1254    ;   '$option'(file_type(Type), Options)
 1255    ->  '$must_be'(atom, Type),
 1256        '$file_type_extensions'(Type, Exts),
 1257        Options1 = Options
 1258    ;   Options1 = Options,
 1259        Exts = ['']
 1260    ),
 1261    '$canonicalise_extensions'(Exts, Extensions),
 1262                    % unless specified otherwise, ask regular file
 1263    (   (   nonvar(Type)
 1264        ;   '$option'(access(none), Options, none)
 1265        )
 1266    ->  Options2 = Options1
 1267    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
 1268    ),
 1269                    % Det or nondet?
 1270    (   '$select_option'(solutions(Sols), Options2, Options3)
 1271    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
 1272    ;   Sols = first,
 1273        Options3 = Options2
 1274    ),
 1275                    % Errors or not?
 1276    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
 1277    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
 1278    ;   FileErrors = error,
 1279        Options4 = Options3
 1280    ),
 1281                    % Expand shell patterns?
 1282    (   atomic(Spec),
 1283        '$select_option'(expand(Expand), Options4, Options5),
 1284        '$must_be'(boolean, Expand)
 1285    ->  expand_file_name(Spec, List),
 1286        '$member'(Spec1, List)
 1287    ;   Spec1 = Spec,
 1288        Options5 = Options4
 1289    ),
 1290                    % Search for files
 1291    (   Sols == first
 1292    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
 1293        ->  !       % also kill choice point of expand_file_name/2
 1294        ;   (   FileErrors == fail
 1295            ->  fail
 1296            ;   '$current_module'('$bags', _File),
 1297                findall(P,
 1298                        '$chk_file'(Spec1, Extensions, [access(exist)],
 1299                                    false, P),
 1300                        Candidates),
 1301                '$abs_file_error'(Spec, Candidates, Options5)
 1302            )
 1303        )
 1304    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 1305    ).
 1306
 1307'$abs_file_error'(Spec, Candidates, Conditions) :-
 1308    '$member'(F, Candidates),
 1309    '$member'(C, Conditions),
 1310    '$file_condition'(C),
 1311    '$file_error'(C, Spec, F, E, Comment),
 1312    !,
 1313    throw(error(E, context(_, Comment))).
 1314'$abs_file_error'(Spec, _, _) :-
 1315    '$existence_error'(source_sink, Spec).
 1316
 1317'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 1318    \+ exists_directory(File),
 1319    !,
 1320    Error = existence_error(directory, Spec),
 1321    Comment = not_a_directory(File).
 1322'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 1323    exists_directory(File),
 1324    !,
 1325    Error = existence_error(file, Spec),
 1326    Comment = directory(File).
 1327'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 1328    '$one_or_member'(Access, OneOrList),
 1329    \+ access_file(File, Access),
 1330    Error = permission_error(Access, source_sink, Spec).
 1331
 1332'$one_or_member'(Elem, List) :-
 1333    is_list(List),
 1334    !,
 1335    '$member'(Elem, List).
 1336'$one_or_member'(Elem, Elem).
 1337
 1338
 1339'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 1340    !,
 1341    '$file_type_extensions'(prolog, Exts).
 1342'$file_type_extensions'(Type, Exts) :-
 1343    '$current_module'('$bags', _File),
 1344    !,
 1345    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 1346    (   Exts0 == [],
 1347        \+ '$ft_no_ext'(Type)
 1348    ->  '$domain_error'(file_type, Type)
 1349    ;   true
 1350    ),
 1351    '$append'(Exts0, [''], Exts).
 1352'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 1353
 1354'$ft_no_ext'(txt).
 1355'$ft_no_ext'(executable).
 1356'$ft_no_ext'(directory).
 1357'$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.

 1370:- multifile(user:prolog_file_type/2). 1371:- dynamic(user:prolog_file_type/2). 1372
 1373user:prolog_file_type(pl,       prolog).
 1374user:prolog_file_type(prolog,   prolog).
 1375user:prolog_file_type(qlf,      prolog).
 1376user:prolog_file_type(qlf,      qlf).
 1377user:prolog_file_type(Ext,      executable) :-
 1378    current_prolog_flag(shared_object_extension, Ext).
 1379user:prolog_file_type(dylib,    executable) :-
 1380    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.

 1387'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1388    \+ ground(Spec),
 1389    !,
 1390    '$instantiation_error'(Spec).
 1391'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1392    compound(Spec),
 1393    functor(Spec, _, 1),
 1394    !,
 1395    '$relative_to'(Cond, cwd, CWD),
 1396    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1397'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1398    \+ atomic(Segments),
 1399    !,
 1400    '$segments_to_atom'(Segments, Atom),
 1401    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1402'$chk_file'(File, Exts, Cond, _, FullName) :-
 1403    is_absolute_file_name(File),
 1404    !,
 1405    '$extend_file'(File, Exts, Extended),
 1406    '$file_conditions'(Cond, Extended),
 1407    '$absolute_file_name'(Extended, FullName).
 1408'$chk_file'(File, Exts, Cond, _, FullName) :-
 1409    '$relative_to'(Cond, source, Dir),
 1410    atomic_list_concat([Dir, /, File], AbsFile),
 1411    '$extend_file'(AbsFile, Exts, Extended),
 1412    '$file_conditions'(Cond, Extended),
 1413    !,
 1414    '$absolute_file_name'(Extended, FullName).
 1415'$chk_file'(File, Exts, Cond, _, FullName) :-
 1416    '$extend_file'(File, Exts, Extended),
 1417    '$file_conditions'(Cond, Extended),
 1418    '$absolute_file_name'(Extended, FullName).
 1419
 1420'$segments_to_atom'(Atom, Atom) :-
 1421    atomic(Atom),
 1422    !.
 1423'$segments_to_atom'(Segments, Atom) :-
 1424    '$segments_to_list'(Segments, List, []),
 1425    !,
 1426    atomic_list_concat(List, /, Atom).
 1427
 1428'$segments_to_list'(A/B, H, T) :-
 1429    '$segments_to_list'(A, H, T0),
 1430    '$segments_to_list'(B, T0, T).
 1431'$segments_to_list'(A, [A|T], T) :-
 1432    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.

 1442'$relative_to'(Conditions, Default, Dir) :-
 1443    (   '$option'(relative_to(FileOrDir), Conditions)
 1444    *-> (   exists_directory(FileOrDir)
 1445        ->  Dir = FileOrDir
 1446        ;   atom_concat(Dir, /, FileOrDir)
 1447        ->  true
 1448        ;   file_directory_name(FileOrDir, Dir)
 1449        )
 1450    ;   Default == cwd
 1451    ->  '$cwd'(Dir)
 1452    ;   Default == source
 1453    ->  source_location(ContextFile, _Line),
 1454        file_directory_name(ContextFile, Dir)
 1455    ).

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

 1460:- dynamic
 1461    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1462    '$search_path_gc_time'/1.       % Time
 1463:- volatile
 1464    '$search_path_file_cache'/3,
 1465    '$search_path_gc_time'/1. 1466
 1467:- create_prolog_flag(file_search_cache_time, 10, []). 1468
 1469'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1470    !,
 1471    findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
 1472    current_prolog_flag(emulated_dialect, Dialect),
 1473    Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
 1474    variant_sha1(Spec+Cache, SHA1),
 1475    get_time(Now),
 1476    current_prolog_flag(file_search_cache_time, TimeOut),
 1477    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1478        CachedTime > Now - TimeOut,
 1479        '$file_conditions'(Cond, FullFile)
 1480    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1481    ;   '$member'(Expanded, Expansions),
 1482        '$extend_file'(Expanded, Exts, LibFile),
 1483        (   '$file_conditions'(Cond, LibFile),
 1484            '$absolute_file_name'(LibFile, FullFile),
 1485            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1486        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1487        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1488            fail
 1489        )
 1490    ).
 1491'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1492    '$expand_file_search_path'(Spec, Expanded, Cond),
 1493    '$extend_file'(Expanded, Exts, LibFile),
 1494    '$file_conditions'(Cond, LibFile),
 1495    '$absolute_file_name'(LibFile, FullFile).
 1496
 1497'$cache_file_found'(_, _, TimeOut, _) :-
 1498    TimeOut =:= 0,
 1499    !.
 1500'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1501    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1502    !,
 1503    (   Now - Saved < TimeOut/2
 1504    ->  true
 1505    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1506        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1507    ).
 1508'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1509    'gc_file_search_cache'(TimeOut),
 1510    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1511
 1512'gc_file_search_cache'(TimeOut) :-
 1513    get_time(Now),
 1514    '$search_path_gc_time'(Last),
 1515    Now-Last < TimeOut/2,
 1516    !.
 1517'gc_file_search_cache'(TimeOut) :-
 1518    get_time(Now),
 1519    retractall('$search_path_gc_time'(_)),
 1520    assertz('$search_path_gc_time'(Now)),
 1521    Before is Now - TimeOut,
 1522    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1523        Cached < Before,
 1524        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1525        fail
 1526    ;   true
 1527    ).
 1528
 1529
 1530'$search_message'(Term) :-
 1531    current_prolog_flag(verbose_file_search, true),
 1532    !,
 1533    print_message(informational, Term).
 1534'$search_message'(_).

 $file_conditions(+Condition, +Path)

Verify Path satisfies Condition.

 1541'$file_conditions'(List, File) :-
 1542    is_list(List),
 1543    !,
 1544    \+ ( '$member'(C, List),
 1545         '$file_condition'(C),
 1546         \+ '$file_condition'(C, File)
 1547       ).
 1548'$file_conditions'(Map, File) :-
 1549    \+ (  get_dict(Key, Map, Value),
 1550          C =.. [Key,Value],
 1551          '$file_condition'(C),
 1552         \+ '$file_condition'(C, File)
 1553       ).
 1554
 1555'$file_condition'(file_type(directory), File) :-
 1556    !,
 1557    exists_directory(File).
 1558'$file_condition'(file_type(_), File) :-
 1559    !,
 1560    \+ exists_directory(File).
 1561'$file_condition'(access(Accesses), File) :-
 1562    !,
 1563    \+ (  '$one_or_member'(Access, Accesses),
 1564          \+ access_file(File, Access)
 1565       ).
 1566
 1567'$file_condition'(exists).
 1568'$file_condition'(file_type(_)).
 1569'$file_condition'(access(_)).
 1570
 1571'$extend_file'(File, Exts, FileEx) :-
 1572    '$ensure_extensions'(Exts, File, Fs),
 1573    '$list_to_set'(Fs, FsSet),
 1574    '$member'(FileEx, FsSet).
 1575
 1576'$ensure_extensions'([], _, []).
 1577'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1578    file_name_extension(F, E, FE),
 1579    '$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).

 1586'$list_to_set'(List, Set) :-
 1587    '$number_list'(List, 1, Numbered),
 1588    sort(1, @=<, Numbered, ONum),
 1589    '$remove_dup_keys'(ONum, NumSet),
 1590    sort(2, @=<, NumSet, ONumSet),
 1591    '$pairs_keys'(ONumSet, Set).
 1592
 1593'$number_list'([], _, []).
 1594'$number_list'([H|T0], N, [H-N|T]) :-
 1595    N1 is N+1,
 1596    '$number_list'(T0, N1, T).
 1597
 1598'$remove_dup_keys'([], []).
 1599'$remove_dup_keys'([H|T0], [H|T]) :-
 1600    H = V-_,
 1601    '$remove_same_key'(T0, V, T1),
 1602    '$remove_dup_keys'(T1, T).
 1603
 1604'$remove_same_key'([V1-_|T0], V, T) :-
 1605    V1 == V,
 1606    !,
 1607    '$remove_same_key'(T0, V, T).
 1608'$remove_same_key'(L, _, L).
 1609
 1610'$pairs_keys'([], []).
 1611'$pairs_keys'([K-_|T0], [K|T]) :-
 1612    '$pairs_keys'(T0, T).
 1613
 1614
 1615/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 1616Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
 1617the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
 1618extensions to .ext
 1619- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 1620
 1621'$canonicalise_extensions'([], []) :- !.
 1622'$canonicalise_extensions'([H|T], [CH|CT]) :-
 1623    !,
 1624    '$must_be'(atom, H),
 1625    '$canonicalise_extension'(H, CH),
 1626    '$canonicalise_extensions'(T, CT).
 1627'$canonicalise_extensions'(E, [CE]) :-
 1628    '$canonicalise_extension'(E, CE).
 1629
 1630'$canonicalise_extension'('', '') :- !.
 1631'$canonicalise_extension'(DotAtom, DotAtom) :-
 1632    sub_atom(DotAtom, 0, _, _, '.'),
 1633    !.
 1634'$canonicalise_extension'(Atom, DotAtom) :-
 1635    atom_concat('.', Atom, DotAtom).
 1636
 1637
 1638                /********************************
 1639                *            CONSULT            *
 1640                *********************************/
 1641
 1642:- dynamic
 1643    user:library_directory/1,
 1644    user:prolog_load_file/2. 1645:- multifile
 1646    user:library_directory/1,
 1647    user:prolog_load_file/2. 1648
 1649:- prompt(_, '|: '). 1650
 1651:- thread_local
 1652    '$compilation_mode_store'/1,    % database, wic, qlf
 1653    '$directive_mode_store'/1.      % database, wic, qlf
 1654:- volatile
 1655    '$compilation_mode_store'/1,
 1656    '$directive_mode_store'/1. 1657
 1658'$compilation_mode'(Mode) :-
 1659    (   '$compilation_mode_store'(Val)
 1660    ->  Mode = Val
 1661    ;   Mode = database
 1662    ).
 1663
 1664'$set_compilation_mode'(Mode) :-
 1665    retractall('$compilation_mode_store'(_)),
 1666    assertz('$compilation_mode_store'(Mode)).
 1667
 1668'$compilation_mode'(Old, New) :-
 1669    '$compilation_mode'(Old),
 1670    (   New == Old
 1671    ->  true
 1672    ;   '$set_compilation_mode'(New)
 1673    ).
 1674
 1675'$directive_mode'(Mode) :-
 1676    (   '$directive_mode_store'(Val)
 1677    ->  Mode = Val
 1678    ;   Mode = database
 1679    ).
 1680
 1681'$directive_mode'(Old, New) :-
 1682    '$directive_mode'(Old),
 1683    (   New == Old
 1684    ->  true
 1685    ;   '$set_directive_mode'(New)
 1686    ).
 1687
 1688'$set_directive_mode'(Mode) :-
 1689    retractall('$directive_mode_store'(_)),
 1690    assertz('$directive_mode_store'(Mode)).