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
  357:- meta_predicate
  358    ';'(0,0),
  359    ','(0,0),
  360    @(0,+),
  361    call(0),
  362    call(1,?),
  363    call(2,?,?),
  364    call(3,?,?,?),
  365    call(4,?,?,?,?),
  366    call(5,?,?,?,?,?),
  367    call(6,?,?,?,?,?,?),
  368    call(7,?,?,?,?,?,?,?),
  369    not(0),
  370    \+(0),
  371    $(0),
  372    '->'(0,0),
  373    '*->'(0,0),
  374    once(0),
  375    ignore(0),
  376    catch(0,?,0),
  377    reset(0,?,-),
  378    setup_call_cleanup(0,0,0),
  379    setup_call_catcher_cleanup(0,0,?,0),
  380    call_cleanup(0,0),
  381    call_cleanup(0,?,0),
  382    catch_with_backtrace(0,?,0),
  383    '$meta_call'(0).  384
  385:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)).  386
  387% The control structures are always compiled, both   if they appear in a
  388% clause body and if they are handed  to   call/1.  The only way to call
  389% these predicates is by means of  call/2..   In  that case, we call the
  390% hole control structure again to get it compiled by call/1 and properly
  391% deal  with  !,  etc.  Another  reason  for  having  these  things   as
  392% predicates is to be able to define   properties for them, helping code
  393% analyzers.
  394
  395(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
  396(M1:If ; M2:Then) :-    call(M1:(If ; M2:Then)).
  397(G1   , G2)       :-    call((G1   , G2)).
  398(If  -> Then)     :-    call((If  -> Then)).
  399(If *-> Then)     :-    call((If *-> Then)).
  400@(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.

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

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

  520not(Goal) :-
  521    \+ Goal.

 \+ :Goal is semidet

Predicate version that allows for meta-calling.

  527\+ Goal :-
  528    \+ Goal.

 once(:Goal) is semidet

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

  534once(Goal) :-
  535    Goal,
  536    !.

 ignore(:Goal) is det

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

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

 false

Synonym for fail/0, providing a declarative reading.

  554false :-
  555    fail.

 catch(:Goal, +Catcher, :Recover)

ISO compliant exception handling.

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

 prolog_cut_to(+Choice)

Cut all choice points after Choice

  568prolog_cut_to(_Choice) :-
  569    '$cut'.                         % Maps to I_CUTCHP

 $ is det

Declare that from now on this predicate succeeds deterministically.

  575'$' :- '$'.

 $ :Goal is det

Declare that Goal must succeed deterministically.

  581$(Goal) :- $(Goal).

 reset(:Goal, ?Ball, -Continue)

Delimited continuation support.

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

  597shift(Ball) :-
  598    '$shift'(Ball).
  599
  600shift_for_copy(Ball) :-
  601    '$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.

  615call_continuation([]).
  616call_continuation([TB|Rest]) :-
  617    (   Rest == []
  618    ->  '$call_continuation'(TB)
  619    ;   '$call_continuation'(TB),
  620        call_continuation(Rest)
  621    ).

 catch_with_backtrace(:Goal, ?Ball, :Recover)

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

  628catch_with_backtrace(Goal, Ball, Recover) :-
  629    catch(Goal, Ball, Recover),
  630    '$no_lco'.
  631
  632'$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.

  642:- public '$recover_and_rethrow'/2.  643
  644'$recover_and_rethrow'(Goal, Exception) :-
  645    call_cleanup(Goal, throw(Exception)),
  646    !.

 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.

  661setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
  662    sig_atomic(Setup),
  663    '$call_cleanup'.
  664
  665setup_call_cleanup(Setup, Goal, Cleanup) :-
  666    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
  667
  668call_cleanup(Goal, Cleanup) :-
  669    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
  670
  671call_cleanup(Goal, Catcher, Cleanup) :-
  672    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
  673
  674                 /*******************************
  675                 *       INITIALIZATION         *
  676                 *******************************/
  677
  678:- meta_predicate
  679    initialization(0, +).  680
  681:- multifile '$init_goal'/3.  682:- 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.

  708initialization(Goal, When) :-
  709    '$must_be'(oneof(atom, initialization_type,
  710                     [ now,
  711                       after_load,
  712                       restore,
  713                       restore_state,
  714                       prepare_state,
  715                       program,
  716                       main
  717                     ]), When),
  718    '$initialization_context'(Source, Ctx),
  719    '$initialization'(When, Goal, Source, Ctx).
  720
  721'$initialization'(now, Goal, _Source, Ctx) :-
  722    '$run_init_goal'(Goal, Ctx),
  723    '$compile_init_goal'(-, Goal, Ctx).
  724'$initialization'(after_load, Goal, Source, Ctx) :-
  725    (   Source \== (-)
  726    ->  '$compile_init_goal'(Source, Goal, Ctx)
  727    ;   throw(error(context_error(nodirective,
  728                                  initialization(Goal, after_load)),
  729                    _))
  730    ).
  731'$initialization'(restore, Goal, Source, Ctx) :- % deprecated
  732    '$initialization'(restore_state, Goal, Source, Ctx).
  733'$initialization'(restore_state, Goal, _Source, Ctx) :-
  734    (   \+ current_prolog_flag(sandboxed_load, true)
  735    ->  '$compile_init_goal'(-, Goal, Ctx)
  736    ;   '$permission_error'(register, initialization(restore), Goal)
  737    ).
  738'$initialization'(prepare_state, Goal, _Source, Ctx) :-
  739    (   \+ current_prolog_flag(sandboxed_load, true)
  740    ->  '$compile_init_goal'(when(prepare_state), Goal, Ctx)
  741    ;   '$permission_error'(register, initialization(restore), Goal)
  742    ).
  743'$initialization'(program, Goal, _Source, Ctx) :-
  744    (   \+ current_prolog_flag(sandboxed_load, true)
  745    ->  '$compile_init_goal'(when(program), Goal, Ctx)
  746    ;   '$permission_error'(register, initialization(restore), Goal)
  747    ).
  748'$initialization'(main, Goal, _Source, Ctx) :-
  749    (   \+ current_prolog_flag(sandboxed_load, true)
  750    ->  '$compile_init_goal'(when(main), Goal, Ctx)
  751    ;   '$permission_error'(register, initialization(restore), Goal)
  752    ).
  753
  754
  755'$compile_init_goal'(Source, Goal, Ctx) :-
  756    atom(Source),
  757    Source \== (-),
  758    !,
  759    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
  760                          _Layout, Source, Ctx).
  761'$compile_init_goal'(Source, Goal, Ctx) :-
  762    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.

  774'$run_initialization'(_, loaded, _) :- !.
  775'$run_initialization'(File, _Action, Options) :-
  776    '$run_initialization'(File, Options).
  777
  778'$run_initialization'(File, Options) :-
  779    setup_call_cleanup(
  780        '$start_run_initialization'(Options, Restore),
  781        '$run_initialization_2'(File),
  782        '$end_run_initialization'(Restore)).
  783
  784'$start_run_initialization'(Options, OldSandBoxed) :-
  785    '$push_input_context'(initialization),
  786    '$set_sandboxed_load'(Options, OldSandBoxed).
  787'$end_run_initialization'(OldSandBoxed) :-
  788    set_prolog_flag(sandboxed_load, OldSandBoxed),
  789    '$pop_input_context'.
  790
  791'$run_initialization_2'(File) :-
  792    (   '$init_goal'(File, Goal, Ctx),
  793        File \= when(_),
  794        '$run_init_goal'(Goal, Ctx),
  795        fail
  796    ;   true
  797    ).
  798
  799'$run_init_goal'(Goal, Ctx) :-
  800    (   catch_with_backtrace('$run_init_goal'(Goal), E,
  801                             '$initialization_error'(E, Goal, Ctx))
  802    ->  true
  803    ;   '$initialization_failure'(Goal, Ctx)
  804    ).
  805
  806:- multifile prolog:sandbox_allowed_goal/1.  807
  808'$run_init_goal'(Goal) :-
  809    current_prolog_flag(sandboxed_load, false),
  810    !,
  811    call(Goal).
  812'$run_init_goal'(Goal) :-
  813    prolog:sandbox_allowed_goal(Goal),
  814    call(Goal).
  815
  816'$initialization_context'(Source, Ctx) :-
  817    (   source_location(File, Line)
  818    ->  Ctx = File:Line,
  819        '$input_context'(Context),
  820        '$top_file'(Context, File, Source)
  821    ;   Ctx = (-),
  822        File = (-)
  823    ).
  824
  825'$top_file'([input(include, F1, _, _)|T], _, F) :-
  826    !,
  827    '$top_file'(T, F1, F).
  828'$top_file'(_, F, F).
  829
  830
  831'$initialization_error'(E, Goal, Ctx) :-
  832    print_message(error, initialization_error(Goal, E, Ctx)).
  833
  834'$initialization_failure'(Goal, Ctx) :-
  835    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

  843:- public '$clear_source_admin'/1.  844
  845'$clear_source_admin'(File) :-
  846    retractall('$init_goal'(_, _, File:_)),
  847    retractall('$load_context_module'(File, _, _)),
  848    retractall('$resolved_source_path_db'(_, _, File)).
  849
  850
  851                 /*******************************
  852                 *            STREAM            *
  853                 *******************************/
  854
  855:- '$iso'(stream_property/2).  856stream_property(Stream, Property) :-
  857    nonvar(Stream),
  858    nonvar(Property),
  859    !,
  860    '$stream_property'(Stream, Property).
  861stream_property(Stream, Property) :-
  862    nonvar(Stream),
  863    !,
  864    '$stream_properties'(Stream, Properties),
  865    '$member'(Property, Properties).
  866stream_property(Stream, Property) :-
  867    nonvar(Property),
  868    !,
  869    (   Property = alias(Alias),
  870        atom(Alias)
  871    ->  '$alias_stream'(Alias, Stream)
  872    ;   '$streams_properties'(Property, Pairs),
  873        '$member'(Stream-Property, Pairs)
  874    ).
  875stream_property(Stream, Property) :-
  876    '$streams_properties'(Property, Pairs),
  877    '$member'(Stream-Properties, Pairs),
  878    '$member'(Property, Properties).
  879
  880
  881                /********************************
  882                *            MODULES            *
  883                *********************************/
  884
  885%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
  886%       Tags `Term' with `Module:' if `Module' is not the context module.
  887
  888'$prefix_module'(Module, Module, Head, Head) :- !.
  889'$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'.

  895default_module(Me, Super) :-
  896    (   atom(Me)
  897    ->  (   var(Super)
  898        ->  '$default_module'(Me, Super)
  899        ;   '$default_module'(Me, Super), !
  900        )
  901    ;   '$type_error'(module, Me)
  902    ).
  903
  904'$default_module'(Me, Me).
  905'$default_module'(Me, Super) :-
  906    import_module(Me, S),
  907    '$default_module'(S, Super).
  908
  909
  910                /********************************
  911                *      TRACE AND EXCEPTIONS     *
  912                *********************************/
  913
  914:- dynamic   user:exception/3.  915:- multifile user:exception/3.  916:- '$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.

  925:- public
  926    '$undefined_procedure'/4.  927
  928'$undefined_procedure'(Module, Name, Arity, Action) :-
  929    '$prefix_module'(Module, user, Name/Arity, Pred),
  930    user:exception(undefined_predicate, Pred, Action0),
  931    !,
  932    Action = Action0.
  933'$undefined_procedure'(Module, Name, Arity, Action) :-
  934    \+ current_prolog_flag(autoload, false),
  935    '$autoload'(Module:Name/Arity),
  936    !,
  937    Action = retry.
  938'$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.

  950'$loading'(Library) :-
  951    current_prolog_flag(threads, true),
  952    (   '$loading_file'(Library, _Queue, _LoadThread)
  953    ->  true
  954    ;   '$loading_file'(FullFile, _Queue, _LoadThread),
  955        file_name_extension(Library, _, FullFile)
  956    ->  true
  957    ).
  958
  959%        handle debugger 'w', 'p' and <N> depth options.
  960
  961'$set_debugger_write_options'(write) :-
  962    !,
  963    create_prolog_flag(debugger_write_options,
  964                       [ quoted(true),
  965                         attributes(dots),
  966                         spacing(next_argument)
  967                       ], []).
  968'$set_debugger_write_options'(print) :-
  969    !,
  970    create_prolog_flag(debugger_write_options,
  971                       [ quoted(true),
  972                         portray(true),
  973                         max_depth(10),
  974                         attributes(portray),
  975                         spacing(next_argument)
  976                       ], []).
  977'$set_debugger_write_options'(Depth) :-
  978    current_prolog_flag(debugger_write_options, Options0),
  979    (   '$select'(max_depth(_), Options0, Options)
  980    ->  true
  981    ;   Options = Options0
  982    ),
  983    create_prolog_flag(debugger_write_options,
  984                       [max_depth(Depth)|Options], []).
  985
  986
  987                /********************************
  988                *        SYSTEM MESSAGES        *
  989                *********************************/

 $confirm(Spec)

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

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

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

 1158'$expand_file_search_path'(Spec, Expanded, Cond) :-
 1159    '$option'(access(Access), Cond),
 1160    memberchk(Access, [write,append]),
 1161    !,
 1162    setup_call_cleanup(
 1163        nb_setval('$create_search_directories', true),
 1164        expand_file_search_path(Spec, Expanded),
 1165        nb_delete('$create_search_directories')).
 1166'$expand_file_search_path'(Spec, Expanded, _Cond) :-
 1167    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?

 1175expand_file_search_path(Spec, Expanded) :-
 1176    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
 1177          loop(Used),
 1178          throw(error(loop_error(Spec), file_search(Used)))).
 1179
 1180'$expand_file_search_path'(Spec, Expanded, N, Used) :-
 1181    functor(Spec, Alias, 1),
 1182    !,
 1183    user:file_search_path(Alias, Exp0),
 1184    NN is N + 1,
 1185    (   NN > 16
 1186    ->  throw(loop(Used))
 1187    ;   true
 1188    ),
 1189    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
 1190    arg(1, Spec, Segments),
 1191    '$segments_to_atom'(Segments, File),
 1192    '$make_path'(Exp1, File, Expanded).
 1193'$expand_file_search_path'(Spec, Path, _, _) :-
 1194    '$segments_to_atom'(Spec, Path).
 1195
 1196'$make_path'(Dir, '.', Path) :-
 1197    !,
 1198    Path = Dir.
 1199'$make_path'(Dir, File, Path) :-
 1200    sub_atom(Dir, _, _, 0, /),
 1201    !,
 1202    atom_concat(Dir, File, Path).
 1203'$make_path'(Dir, File, Path) :-
 1204    atomic_list_concat([Dir, /, File], Path).
 1205
 1206
 1207                /********************************
 1208                *         FILE CHECKING         *
 1209                *********************************/

 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.

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

 1346:- multifile(user:prolog_file_type/2). 1347:- dynamic(user:prolog_file_type/2). 1348
 1349user:prolog_file_type(pl,       prolog).
 1350user:prolog_file_type(prolog,   prolog).
 1351user:prolog_file_type(qlf,      prolog).
 1352user:prolog_file_type(qlf,      qlf).
 1353user:prolog_file_type(Ext,      executable) :-
 1354    current_prolog_flag(shared_object_extension, Ext).
 1355user:prolog_file_type(dylib,    executable) :-
 1356    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.

 1363'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1364    \+ ground(Spec),
 1365    !,
 1366    '$instantiation_error'(Spec).
 1367'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1368    compound(Spec),
 1369    functor(Spec, _, 1),
 1370    !,
 1371    '$relative_to'(Cond, cwd, CWD),
 1372    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1373'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1374    \+ atomic(Segments),
 1375    !,
 1376    '$segments_to_atom'(Segments, Atom),
 1377    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1378'$chk_file'(File, Exts, Cond, _, FullName) :-
 1379    is_absolute_file_name(File),
 1380    !,
 1381    '$extend_file'(File, Exts, Extended),
 1382    '$file_conditions'(Cond, Extended),
 1383    '$absolute_file_name'(Extended, FullName).
 1384'$chk_file'(File, Exts, Cond, _, FullName) :-
 1385    '$relative_to'(Cond, source, Dir),
 1386    atomic_list_concat([Dir, /, File], AbsFile),
 1387    '$extend_file'(AbsFile, Exts, Extended),
 1388    '$file_conditions'(Cond, Extended),
 1389    !,
 1390    '$absolute_file_name'(Extended, FullName).
 1391'$chk_file'(File, Exts, Cond, _, FullName) :-
 1392    '$extend_file'(File, Exts, Extended),
 1393    '$file_conditions'(Cond, Extended),
 1394    '$absolute_file_name'(Extended, FullName).
 1395
 1396'$segments_to_atom'(Atom, Atom) :-
 1397    atomic(Atom),
 1398    !.
 1399'$segments_to_atom'(Segments, Atom) :-
 1400    '$segments_to_list'(Segments, List, []),
 1401    !,
 1402    atomic_list_concat(List, /, Atom).
 1403
 1404'$segments_to_list'(A/B, H, T) :-
 1405    '$segments_to_list'(A, H, T0),
 1406    '$segments_to_list'(B, T0, T).
 1407'$segments_to_list'(A, [A|T], T) :-
 1408    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.

 1418'$relative_to'(Conditions, Default, Dir) :-
 1419    (   '$option'(relative_to(FileOrDir), Conditions)
 1420    *-> (   exists_directory(FileOrDir)
 1421        ->  Dir = FileOrDir
 1422        ;   atom_concat(Dir, /, FileOrDir)
 1423        ->  true
 1424        ;   file_directory_name(FileOrDir, Dir)
 1425        )
 1426    ;   Default == cwd
 1427    ->  '$cwd'(Dir)
 1428    ;   Default == source
 1429    ->  source_location(ContextFile, _Line),
 1430        file_directory_name(ContextFile, Dir)
 1431    ).

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

 1436:- dynamic
 1437    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1438    '$search_path_gc_time'/1.       % Time
 1439:- volatile
 1440    '$search_path_file_cache'/3,
 1441    '$search_path_gc_time'/1. 1442
 1443:- create_prolog_flag(file_search_cache_time, 10, []). 1444
 1445'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1446    !,
 1447    findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
 1448    current_prolog_flag(emulated_dialect, Dialect),
 1449    Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
 1450    variant_sha1(Spec+Cache, SHA1),
 1451    get_time(Now),
 1452    current_prolog_flag(file_search_cache_time, TimeOut),
 1453    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1454        CachedTime > Now - TimeOut,
 1455        '$file_conditions'(Cond, FullFile)
 1456    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1457    ;   '$member'(Expanded, Expansions),
 1458        '$extend_file'(Expanded, Exts, LibFile),
 1459        (   '$file_conditions'(Cond, LibFile),
 1460            '$absolute_file_name'(LibFile, FullFile),
 1461            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1462        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1463        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1464            fail
 1465        )
 1466    ).
 1467'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1468    '$expand_file_search_path'(Spec, Expanded, Cond),
 1469    '$extend_file'(Expanded, Exts, LibFile),
 1470    '$file_conditions'(Cond, LibFile),
 1471    '$absolute_file_name'(LibFile, FullFile).
 1472
 1473'$cache_file_found'(_, _, TimeOut, _) :-
 1474    TimeOut =:= 0,
 1475    !.
 1476'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1477    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1478    !,
 1479    (   Now - Saved < TimeOut/2
 1480    ->  true
 1481    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1482        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1483    ).
 1484'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1485    'gc_file_search_cache'(TimeOut),
 1486    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1487
 1488'gc_file_search_cache'(TimeOut) :-
 1489    get_time(Now),
 1490    '$search_path_gc_time'(Last),
 1491    Now-Last < TimeOut/2,
 1492    !.
 1493'gc_file_search_cache'(TimeOut) :-
 1494    get_time(Now),
 1495    retractall('$search_path_gc_time'(_)),
 1496    assertz('$search_path_gc_time'(Now)),
 1497    Before is Now - TimeOut,
 1498    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1499        Cached < Before,
 1500        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1501        fail
 1502    ;   true
 1503    ).
 1504
 1505
 1506'$search_message'(Term) :-
 1507    current_prolog_flag(verbose_file_search, true),
 1508    !,
 1509    print_message(informational, Term).
 1510'$search_message'(_).

 $file_conditions(+Condition, +Path)

Verify Path satisfies Condition.

 1517'$file_conditions'(List, File) :-
 1518    is_list(List),
 1519    !,
 1520    \+ ( '$member'(C, List),
 1521         '$file_condition'(C),
 1522         \+ '$file_condition'(C, File)
 1523       ).
 1524'$file_conditions'(Map, File) :-
 1525    \+ (  get_dict(Key, Map, Value),
 1526          C =.. [Key,Value],
 1527          '$file_condition'(C),
 1528         \+ '$file_condition'(C, File)
 1529       ).
 1530
 1531'$file_condition'(file_type(directory), File) :-
 1532    !,
 1533    exists_directory(File).
 1534'$file_condition'(file_type(_), File) :-
 1535    !,
 1536    \+ exists_directory(File).
 1537'$file_condition'(access(Accesses), File) :-
 1538    !,
 1539    \+ (  '$one_or_member'(Access, Accesses),
 1540          \+ access_file(File, Access)
 1541       ).
 1542
 1543'$file_condition'(exists).
 1544'$file_condition'(file_type(_)).
 1545'$file_condition'(access(_)).
 1546
 1547'$extend_file'(File, Exts, FileEx) :-
 1548    '$ensure_extensions'(Exts, File, Fs),
 1549    '$list_to_set'(Fs, FsSet),
 1550    '$member'(FileEx, FsSet).
 1551
 1552'$ensure_extensions'([], _, []).
 1553'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1554    file_name_extension(F, E, FE),
 1555    '$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).

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