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-2022, 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    det(:),
   99    '$clausable'(:),
  100    '$iso'(:),
  101    '$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.

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

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

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

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

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

 $pi_head(?PI, ?Head)

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

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

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

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

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

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

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

 \+ :Goal is semidet

Predicate version that allows for meta-calling.

  530\+ Goal :-
  531    \+ Goal.

 once(:Goal) is semidet

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

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

 ignore(:Goal) is det

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

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

 false

Synonym for fail/0, providing a declarative reading.

  557false :-
  558    fail.

 catch(:Goal, +Catcher, :Recover)

ISO compliant exception handling.

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

 prolog_cut_to(+Choice)

Cut all choice points after Choice

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

 $ is det

Declare that from now on this predicate succeeds deterministically.

  578'$' :- '$'.

 $ :Goal is det

Declare that Goal must succeed deterministically.

  584$(Goal) :- $(Goal).

 notrace(:Goal) is semidet

Suspend the tracer while running Goal.

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

 reset(:Goal, ?Ball, -Continue)

Delimited continuation support.

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

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

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

 catch_with_backtrace(:Goal, ?Ball, :Recover)

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

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

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

 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.

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

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

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

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

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

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

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

 $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.

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

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

 1191'$expand_file_search_path'(Spec, Expanded, Cond) :-
 1192    '$option'(access(Access), Cond),
 1193    memberchk(Access, [write,append]),
 1194    !,
 1195    setup_call_cleanup(
 1196	nb_setval('$create_search_directories', true),
 1197	expand_file_search_path(Spec, Expanded),
 1198	nb_delete('$create_search_directories')).
 1199'$expand_file_search_path'(Spec, Expanded, _Cond) :-
 1200    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?

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

 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.

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

 1379:- multifile(user:prolog_file_type/2). 1380:- dynamic(user:prolog_file_type/2). 1381
 1382user:prolog_file_type(pl,       prolog).
 1383user:prolog_file_type(prolog,   prolog).
 1384user:prolog_file_type(qlf,      prolog).
 1385user:prolog_file_type(qlf,      qlf).
 1386user:prolog_file_type(Ext,      executable) :-
 1387    current_prolog_flag(shared_object_extension, Ext).
 1388user:prolog_file_type(dylib,    executable) :-
 1389    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.

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

 1451'$relative_to'(Conditions, Default, Dir) :-
 1452    (   '$option'(relative_to(FileOrDir), Conditions)
 1453    *-> (   exists_directory(FileOrDir)
 1454	->  Dir = FileOrDir
 1455	;   atom_concat(Dir, /, FileOrDir)
 1456	->  true
 1457	;   file_directory_name(FileOrDir, Dir)
 1458	)
 1459    ;   Default == cwd
 1460    ->  '$cwd'(Dir)
 1461    ;   Default == source
 1462    ->  source_location(ContextFile, _Line),
 1463	file_directory_name(ContextFile, Dir)
 1464    ).

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

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

 $file_conditions(+Condition, +Path)

Verify Path satisfies Condition.

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

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