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

  100dynamic(Spec)            :- '$set_pattr'(Spec, pred, (dynamic)).
  101multifile(Spec)          :- '$set_pattr'(Spec, pred, (multifile)).
  102module_transparent(Spec) :- '$set_pattr'(Spec, pred, (transparent)).
  103discontiguous(Spec)      :- '$set_pattr'(Spec, pred, (discontiguous)).
  104volatile(Spec)           :- '$set_pattr'(Spec, pred, (volatile)).
  105thread_local(Spec)       :- '$set_pattr'(Spec, pred, (thread_local)).
  106noprofile(Spec)          :- '$set_pattr'(Spec, pred, (noprofile)).
  107public(Spec)             :- '$set_pattr'(Spec, pred, (public)).
  108non_terminal(Spec)       :- '$set_pattr'(Spec, pred, (non_terminal)).
  109'$iso'(Spec)             :- '$set_pattr'(Spec, pred, (iso)).
  110'$clausable'(Spec)       :- '$set_pattr'(Spec, pred, (clausable)).
  111
  112'$set_pattr'(M:Pred, How, Attr) :-
  113    '$set_pattr'(Pred, M, How, Attr).
  114
  115'$set_pattr'(X, _, _, _) :-
  116    var(X),
  117    throw(error(instantiation_error, _)).
  118'$set_pattr'([], _, _, _) :- !.
  119'$set_pattr'([H|T], M, How, Attr) :-           % ISO
  120    !,
  121    '$set_pattr'(H, M, How, Attr),
  122    '$set_pattr'(T, M, How, Attr).
  123'$set_pattr'((A,B), M, How, Attr) :-           % ISO and traditional
  124    !,
  125    '$set_pattr'(A, M, How, Attr),
  126    '$set_pattr'(B, M, How, Attr).
  127'$set_pattr'(M:T, _, How, Attr) :-
  128    !,
  129    '$set_pattr'(T, M, How, Attr).
  130'$set_pattr'(A, M, pred, Attr) :-
  131    !,
  132    '$set_predicate_attribute'(M:A, Attr, true).
  133'$set_pattr'(A, M, directive, Attr) :-
  134    !,
  135    catch('$set_predicate_attribute'(M:A, Attr, true),
  136          error(E, _),
  137          print_message(error, error(E, context((Attr)/1,_)))).

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

  146'$pattr_directive'(dynamic(Spec), M) :-
  147    '$set_pattr'(Spec, M, directive, (dynamic)).
  148'$pattr_directive'(multifile(Spec), M) :-
  149    '$set_pattr'(Spec, M, directive, (multifile)).
  150'$pattr_directive'(module_transparent(Spec), M) :-
  151    '$set_pattr'(Spec, M, directive, (transparent)).
  152'$pattr_directive'(discontiguous(Spec), M) :-
  153    '$set_pattr'(Spec, M, directive, (discontiguous)).
  154'$pattr_directive'(volatile(Spec), M) :-
  155    '$set_pattr'(Spec, M, directive, (volatile)).
  156'$pattr_directive'(thread_local(Spec), M) :-
  157    '$set_pattr'(Spec, M, directive, (thread_local)).
  158'$pattr_directive'(noprofile(Spec), M) :-
  159    '$set_pattr'(Spec, M, directive, (noprofile)).
  160'$pattr_directive'(public(Spec), M) :-
  161    '$set_pattr'(Spec, M, directive, (public)).

 $hide(:PI)

Predicates protected this way are never visible in the tracer.

  168'$hide'(Pred) :-
  169    '$set_predicate_attribute'(Pred, trace, false).
  170
  171
  172                /********************************
  173                *       CALLING, CONTROL        *
  174                *********************************/
  175
  176:- noprofile((call/1,
  177              catch/3,
  178              once/1,
  179              ignore/1,
  180              call_cleanup/2,
  181              call_cleanup/3,
  182              setup_call_cleanup/3,
  183              setup_call_catcher_cleanup/4)).  184
  185:- meta_predicate
  186    ';'(0,0),
  187    ','(0,0),
  188    @(0,+),
  189    call(0),
  190    call(1,?),
  191    call(2,?,?),
  192    call(3,?,?,?),
  193    call(4,?,?,?,?),
  194    call(5,?,?,?,?,?),
  195    call(6,?,?,?,?,?,?),
  196    call(7,?,?,?,?,?,?,?),
  197    not(0),
  198    \+(0),
  199    '->'(0,0),
  200    '*->'(0,0),
  201    once(0),
  202    ignore(0),
  203    catch(0,?,0),
  204    reset(0,?,-),
  205    setup_call_cleanup(0,0,0),
  206    setup_call_catcher_cleanup(0,0,?,0),
  207    call_cleanup(0,0),
  208    call_cleanup(0,?,0),
  209    catch_with_backtrace(0,?,0),
  210    '$meta_call'(0).  211
  212:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)).  213
  214% The control structures are always compiled, both   if they appear in a
  215% clause body and if they are handed  to   call/1.  The only way to call
  216% these predicates is by means of  call/2..   In  that case, we call the
  217% hole control structure again to get it compiled by call/1 and properly
  218% deal  with  !,  etc.  Another  reason  for  having  these  things   as
  219% predicates is to be able to define   properties for them, helping code
  220% analyzers.
  221
  222(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
  223(M1:If ; M2:Then) :-    call(M1:(If ; M2:Then)).
  224(G1   , G2)       :-    call((G1   , G2)).
  225(If  -> Then)     :-    call((If  -> Then)).
  226(If *-> Then)     :-    call((If *-> Then)).
  227@(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.

  241'$meta_call'(M:G) :-
  242    prolog_current_choice(Ch),
  243    '$meta_call'(G, M, Ch).
  244
  245'$meta_call'(Var, _, _) :-
  246    var(Var),
  247    !,
  248    '$instantiation_error'(Var).
  249'$meta_call'((A,B), M, Ch) :-
  250    !,
  251    '$meta_call'(A, M, Ch),
  252    '$meta_call'(B, M, Ch).
  253'$meta_call'((I->T;E), M, Ch) :-
  254    !,
  255    (   prolog_current_choice(Ch2),
  256        '$meta_call'(I, M, Ch2)
  257    ->  '$meta_call'(T, M, Ch)
  258    ;   '$meta_call'(E, M, Ch)
  259    ).
  260'$meta_call'((I*->T;E), M, Ch) :-
  261    !,
  262    (   prolog_current_choice(Ch2),
  263        '$meta_call'(I, M, Ch2)
  264    *-> '$meta_call'(T, M, Ch)
  265    ;   '$meta_call'(E, M, Ch)
  266    ).
  267'$meta_call'((I->T), M, Ch) :-
  268    !,
  269    (   prolog_current_choice(Ch2),
  270        '$meta_call'(I, M, Ch2)
  271    ->  '$meta_call'(T, M, Ch)
  272    ).
  273'$meta_call'((I*->T), M, Ch) :-
  274    !,
  275    prolog_current_choice(Ch2),
  276    '$meta_call'(I, M, Ch2),
  277    '$meta_call'(T, M, Ch).
  278'$meta_call'((A;B), M, Ch) :-
  279    !,
  280    (   '$meta_call'(A, M, Ch)
  281    ;   '$meta_call'(B, M, Ch)
  282    ).
  283'$meta_call'(\+(G), M, _) :-
  284    !,
  285    prolog_current_choice(Ch),
  286    \+ '$meta_call'(G, M, Ch).
  287'$meta_call'(call(G), M, _) :-
  288    !,
  289    prolog_current_choice(Ch),
  290    '$meta_call'(G, M, Ch).
  291'$meta_call'(M:G, _, Ch) :-
  292    !,
  293    '$meta_call'(G, M, Ch).
  294'$meta_call'(!, _, Ch) :-
  295    prolog_cut_to(Ch).
  296'$meta_call'(G, M, _Ch) :-
  297    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..

  313:- '$iso'((call/2,
  314           call/3,
  315           call/4,
  316           call/5,
  317           call/6,
  318           call/7,
  319           call/8)).  320
  321call(Goal) :-                           % make these available as predicates
  322    Goal.
  323call(Goal, A) :-
  324    call(Goal, A).
  325call(Goal, A, B) :-
  326    call(Goal, A, B).
  327call(Goal, A, B, C) :-
  328    call(Goal, A, B, C).
  329call(Goal, A, B, C, D) :-
  330    call(Goal, A, B, C, D).
  331call(Goal, A, B, C, D, E) :-
  332    call(Goal, A, B, C, D, E).
  333call(Goal, A, B, C, D, E, F) :-
  334    call(Goal, A, B, C, D, E, F).
  335call(Goal, A, B, C, D, E, F, G) :-
  336    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.

  343not(Goal) :-
  344    \+ Goal.

 \+ :Goal is semidet

Predicate version that allows for meta-calling.

  350\+ Goal :-
  351    \+ Goal.

 once(:Goal) is semidet

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

  357once(Goal) :-
  358    Goal,
  359    !.

 ignore(:Goal) is det

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

  366ignore(Goal) :-
  367    Goal,
  368    !.
  369ignore(_Goal).
  370
  371:- '$iso'((false/0)).
  372
  373%!  false.
  374%
  375%   Synonym for fail/0, providing a declarative reading.
  376
  377false :-    fail.

 catch(:Goal, +Catcher, :Recover)

ISO compliant exception handling.

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

 prolog_cut_to(+Choice)

Cut all choice points after Choice

  391prolog_cut_to(_Choice) :-
  392    '$cut'.                         % Maps to I_CUTCHP

 reset(:Goal, ?Ball, -Continue)

Delimited continuation support.

  398reset(_Goal, _Ball, _Cont) :-
  399    '$reset'.

 shift(+Ball)

Shift control back to the enclosing reset/3

  405shift(Ball) :-
  406    '$shift'(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.

  420call_continuation([]).
  421call_continuation([TB|Rest]) :-
  422    (   Rest == []
  423    ->  '$call_continuation'(TB)
  424    ;   '$call_continuation'(TB),
  425        call_continuation(Rest)
  426    ).

 catch_with_backtrace(:Goal, ?Ball, :Recover)

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

  433catch_with_backtrace(Goal, Ball, Recover) :-
  434    catch(Goal, Ball, Recover),
  435    '$no_lco'.
  436
  437'$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.

  447:- public '$recover_and_rethrow'/2.  448
  449'$recover_and_rethrow'(Goal, Exception) :-
  450    call_cleanup(Goal, throw(Exception)),
  451    !.

 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.

  466setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
  467    '$sig_atomic'(Setup),
  468    '$call_cleanup'.
  469
  470setup_call_cleanup(Setup, Goal, Cleanup) :-
  471    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
  472
  473call_cleanup(Goal, Cleanup) :-
  474    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
  475
  476call_cleanup(Goal, Catcher, Cleanup) :-
  477    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
  478
  479                 /*******************************
  480                 *       INITIALIZATION         *
  481                 *******************************/
  482
  483:- meta_predicate
  484    initialization(0, +).  485
  486:- multifile '$init_goal'/3.  487:- 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.

  513initialization(Goal, When) :-
  514    '$must_be'(oneof(atom, initialization_type,
  515                     [ now,
  516                       after_load,
  517                       restore,
  518                       restore_state,
  519                       prepare_state,
  520                       program,
  521                       main
  522                     ]), When),
  523    '$initialization_context'(Source, Ctx),
  524    '$initialization'(When, Goal, Source, Ctx).
  525
  526'$initialization'(now, Goal, _Source, Ctx) :-
  527    '$run_init_goal'(Goal, Ctx),
  528    '$compile_init_goal'(-, Goal, Ctx).
  529'$initialization'(after_load, Goal, Source, Ctx) :-
  530    (   Source \== (-)
  531    ->  '$compile_init_goal'(Source, Goal, Ctx)
  532    ;   throw(error(context_error(nodirective,
  533                                  initialization(Goal, after_load)),
  534                    _))
  535    ).
  536'$initialization'(restore, Goal, Source, Ctx) :- % deprecated
  537    '$initialization'(restore_state, Goal, Source, Ctx).
  538'$initialization'(restore_state, Goal, _Source, Ctx) :-
  539    (   \+ current_prolog_flag(sandboxed_load, true)
  540    ->  '$compile_init_goal'(-, Goal, Ctx)
  541    ;   '$permission_error'(register, initialization(restore), Goal)
  542    ).
  543'$initialization'(prepare_state, Goal, _Source, Ctx) :-
  544    (   \+ current_prolog_flag(sandboxed_load, true)
  545    ->  '$compile_init_goal'(when(prepare_state), Goal, Ctx)
  546    ;   '$permission_error'(register, initialization(restore), Goal)
  547    ).
  548'$initialization'(program, Goal, _Source, Ctx) :-
  549    (   \+ current_prolog_flag(sandboxed_load, true)
  550    ->  '$compile_init_goal'(when(program), Goal, Ctx)
  551    ;   '$permission_error'(register, initialization(restore), Goal)
  552    ).
  553'$initialization'(main, Goal, _Source, Ctx) :-
  554    (   \+ current_prolog_flag(sandboxed_load, true)
  555    ->  '$compile_init_goal'(when(main), Goal, Ctx)
  556    ;   '$permission_error'(register, initialization(restore), Goal)
  557    ).
  558
  559
  560'$compile_init_goal'(Source, Goal, Ctx) :-
  561    atom(Source),
  562    Source \== (-),
  563    !,
  564    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
  565                          _Layout, Source, Ctx).
  566'$compile_init_goal'(Source, Goal, Ctx) :-
  567    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.

  579'$run_initialization'(_, loaded, _) :- !.
  580'$run_initialization'(File, _Action, Options) :-
  581    '$run_initialization'(File, Options).
  582
  583'$run_initialization'(File, Options) :-
  584    setup_call_cleanup(
  585        '$start_run_initialization'(Options, Restore),
  586        '$run_initialization_2'(File),
  587        '$end_run_initialization'(Restore)).
  588
  589'$start_run_initialization'(Options, OldSandBoxed) :-
  590    '$push_input_context'(initialization),
  591    '$set_sandboxed_load'(Options, OldSandBoxed).
  592'$end_run_initialization'(OldSandBoxed) :-
  593    set_prolog_flag(sandboxed_load, OldSandBoxed),
  594    '$pop_input_context'.
  595
  596'$run_initialization_2'(File) :-
  597    (   '$init_goal'(File, Goal, Ctx),
  598        File \= when(_),
  599        '$run_init_goal'(Goal, Ctx),
  600        fail
  601    ;   true
  602    ).
  603
  604'$run_init_goal'(Goal, Ctx) :-
  605    (   catch_with_backtrace('$run_init_goal'(Goal), E,
  606                             '$initialization_error'(E, Goal, Ctx))
  607    ->  true
  608    ;   '$initialization_failure'(Goal, Ctx)
  609    ).
  610
  611:- multifile prolog:sandbox_allowed_goal/1.  612
  613'$run_init_goal'(Goal) :-
  614    current_prolog_flag(sandboxed_load, false),
  615    !,
  616    call(Goal).
  617'$run_init_goal'(Goal) :-
  618    prolog:sandbox_allowed_goal(Goal),
  619    call(Goal).
  620
  621'$initialization_context'(Source, Ctx) :-
  622    (   source_location(File, Line)
  623    ->  Ctx = File:Line,
  624        '$input_context'(Context),
  625        '$top_file'(Context, File, Source)
  626    ;   Ctx = (-),
  627        File = (-)
  628    ).
  629
  630'$top_file'([input(include, F1, _, _)|T], _, F) :-
  631    !,
  632    '$top_file'(T, F1, F).
  633'$top_file'(_, F, F).
  634
  635
  636'$initialization_error'(E, Goal, Ctx) :-
  637    print_message(error, initialization_error(Goal, E, Ctx)).
  638
  639'$initialization_failure'(Goal, Ctx) :-
  640    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

  648:- public '$clear_source_admin'/1.  649
  650'$clear_source_admin'(File) :-
  651    retractall('$init_goal'(_, _, File:_)),
  652    retractall('$load_context_module'(File, _, _)),
  653    retractall('$resolved_source_path'(_, File)).
  654
  655
  656                 /*******************************
  657                 *            STREAM            *
  658                 *******************************/
  659
  660:- '$iso'(stream_property/2).  661stream_property(Stream, Property) :-
  662    nonvar(Stream),
  663    nonvar(Property),
  664    !,
  665    '$stream_property'(Stream, Property).
  666stream_property(Stream, Property) :-
  667    nonvar(Stream),
  668    !,
  669    '$stream_properties'(Stream, Properties),
  670    '$member'(Property, Properties).
  671stream_property(Stream, Property) :-
  672    nonvar(Property),
  673    !,
  674    (   Property = alias(Alias),
  675        atom(Alias)
  676    ->  '$alias_stream'(Alias, Stream)
  677    ;   '$streams_properties'(Property, Pairs),
  678        '$member'(Stream-Property, Pairs)
  679    ).
  680stream_property(Stream, Property) :-
  681    '$streams_properties'(Property, Pairs),
  682    '$member'(Stream-Properties, Pairs),
  683    '$member'(Property, Properties).
  684
  685
  686                /********************************
  687                *            MODULES            *
  688                *********************************/
  689
  690%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
  691%       Tags `Term' with `Module:' if `Module' is not the context module.
  692
  693'$prefix_module'(Module, Module, Head, Head) :- !.
  694'$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'.

  700default_module(Me, Super) :-
  701    (   atom(Me)
  702    ->  (   var(Super)
  703        ->  '$default_module'(Me, Super)
  704        ;   '$default_module'(Me, Super), !
  705        )
  706    ;   '$type_error'(module, Me)
  707    ).
  708
  709'$default_module'(Me, Me).
  710'$default_module'(Me, Super) :-
  711    import_module(Me, S),
  712    '$default_module'(S, Super).
  713
  714
  715                /********************************
  716                *      TRACE AND EXCEPTIONS     *
  717                *********************************/
  718
  719:- user:dynamic((exception/3,
  720                 prolog_event_hook/1)).  721:- user:multifile((exception/3,
  722                   prolog_event_hook/1)).

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

  731:- public
  732    '$undefined_procedure'/4.  733
  734'$undefined_procedure'(Module, Name, Arity, Action) :-
  735    '$prefix_module'(Module, user, Name/Arity, Pred),
  736    user:exception(undefined_predicate, Pred, Action0),
  737    !,
  738    Action = Action0.
  739'$undefined_procedure'(Module, Name, Arity, Action) :-
  740    current_prolog_flag(autoload, true),
  741    '$autoload'(Module, Name, Arity),
  742    !,
  743    Action = retry.
  744'$undefined_procedure'(_, _, _, error).
  745
  746'$autoload'(Module, Name, Arity) :-
  747    source_location(File, _Line),
  748    !,
  749    setup_call_cleanup(
  750        '$start_aux'(File, Context),
  751        '$autoload2'(Module, Name, Arity),
  752        '$end_aux'(File, Context)).
  753'$autoload'(Module, Name, Arity) :-
  754    '$autoload2'(Module, Name, Arity).
  755
  756'$autoload2'(Module, Name, Arity) :-
  757    '$find_library'(Module, Name, Arity, LoadModule, Library),
  758    functor(Head, Name, Arity),
  759    '$update_autoload_level'([autoload(true)], Old),
  760    (   current_prolog_flag(verbose_autoload, true)
  761    ->  Level = informational
  762    ;   Level = silent
  763    ),
  764    print_message(Level, autoload(Module:Name/Arity, Library)),
  765    '$compilation_mode'(OldComp, database),
  766    (   Module == LoadModule
  767    ->  ensure_loaded(Module:Library)
  768    ;   (   '$get_predicate_attribute'(LoadModule:Head, defined, 1),
  769            \+ '$loading'(Library)
  770        ->  Module:import(LoadModule:Name/Arity)
  771        ;   use_module(Module:Library, [Name/Arity])
  772        )
  773    ),
  774    '$set_compilation_mode'(OldComp),
  775    '$set_autoload_level'(Old),
  776    '$c_current_predicate'(_, Module:Head).

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

  787'$loading'(Library) :-
  788    current_prolog_flag(threads, true),
  789    '$loading_file'(FullFile, _Queue, _LoadThread),
  790    file_name_extension(Library, _, FullFile),
  791    !.
  792
  793%        handle debugger 'w', 'p' and <N> depth options.
  794
  795'$set_debugger_write_options'(write) :-
  796    !,
  797    create_prolog_flag(debugger_write_options,
  798                       [ quoted(true),
  799                         attributes(dots),
  800                         spacing(next_argument)
  801                       ], []).
  802'$set_debugger_write_options'(print) :-
  803    !,
  804    create_prolog_flag(debugger_write_options,
  805                       [ quoted(true),
  806                         portray(true),
  807                         max_depth(10),
  808                         attributes(portray),
  809                         spacing(next_argument)
  810                       ], []).
  811'$set_debugger_write_options'(Depth) :-
  812    current_prolog_flag(debugger_write_options, Options0),
  813    (   '$select'(max_depth(_), Options0, Options)
  814    ->  true
  815    ;   Options = Options0
  816    ),
  817    create_prolog_flag(debugger_write_options,
  818                       [max_depth(Depth)|Options], []).
  819
  820
  821                /********************************
  822                *        SYSTEM MESSAGES        *
  823                *********************************/

 $confirm(Spec)

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

  830'$confirm'(Spec) :-
  831    print_message(query, Spec),
  832    between(0, 5, _),
  833        get_single_char(Answer),
  834        (   '$in_reply'(Answer, 'yYjJ \n')
  835        ->  !,
  836            print_message(query, if_tty([yes-[]]))
  837        ;   '$in_reply'(Answer, 'nN')
  838        ->  !,
  839            print_message(query, if_tty([no-[]])),
  840            fail
  841        ;   print_message(help, query(confirm)),
  842            fail
  843        ).
  844
  845'$in_reply'(Code, Atom) :-
  846    char_code(Char, Code),
  847    sub_atom(Atom, _, _, _, Char),
  848    !.
  849
  850:- dynamic
  851    user:portray/1.  852:- multifile
  853    user:portray/1.  854
  855
  856                 /*******************************
  857                 *       FILE_SEARCH_PATH       *
  858                 *******************************/
  859
  860:- dynamic user:file_search_path/2.  861:- multifile user:file_search_path/2.  862
  863user:(file_search_path(library, Dir) :-
  864        library_directory(Dir)).
  865user:file_search_path(swi, Home) :-
  866    current_prolog_flag(home, Home).
  867user:file_search_path(foreign, swi(ArchLib)) :-
  868    current_prolog_flag(arch, Arch),
  869    atom_concat('lib/', Arch, ArchLib).
  870user:file_search_path(foreign, swi(SoLib)) :-
  871    (   current_prolog_flag(windows, true)
  872    ->  SoLib = bin
  873    ;   SoLib = lib
  874    ).
  875user:file_search_path(path, Dir) :-
  876    getenv('PATH', Path),
  877    (   current_prolog_flag(windows, true)
  878    ->  atomic_list_concat(Dirs, (;), Path)
  879    ;   atomic_list_concat(Dirs, :, Path)
  880    ),
  881    '$member'(Dir, Dirs),
  882    '$no-null-bytes'(Dir).
  883
  884'$no-null-bytes'(Dir) :-
  885    sub_atom(Dir, _, _, _, '\u0000'),
  886    !,
  887    print_message(warning, null_byte_in_path(Dir)),
  888    fail.
  889'$no-null-bytes'(_).

 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?

  897expand_file_search_path(Spec, Expanded) :-
  898    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
  899          loop(Used),
  900          throw(error(loop_error(Spec), file_search(Used)))).
  901
  902'$expand_file_search_path'(Spec, Expanded, N, Used) :-
  903    functor(Spec, Alias, 1),
  904    !,
  905    user:file_search_path(Alias, Exp0),
  906    NN is N + 1,
  907    (   NN > 16
  908    ->  throw(loop(Used))
  909    ;   true
  910    ),
  911    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
  912    arg(1, Spec, Segments),
  913    '$segments_to_atom'(Segments, File),
  914    '$make_path'(Exp1, File, Expanded).
  915'$expand_file_search_path'(Spec, Path, _, _) :-
  916    '$segments_to_atom'(Spec, Path).
  917
  918'$make_path'(Dir, '.', Path) :-
  919    !,
  920    Path = Dir.
  921'$make_path'(Dir, File, Path) :-
  922    sub_atom(Dir, _, _, 0, /),
  923    !,
  924    atom_concat(Dir, File, Path).
  925'$make_path'(Dir, File, Path) :-
  926    atomic_list_concat([Dir, /, File], Path).
  927
  928
  929                /********************************
  930                *         FILE CHECKING         *
  931                *********************************/

 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.

  942absolute_file_name(Spec, Options, Path) :-
  943    '$is_options'(Options),
  944    \+ '$is_options'(Path),
  945    !,
  946    absolute_file_name(Spec, Path, Options).
  947absolute_file_name(Spec, Path, Options) :-
  948    '$must_be'(options, Options),
  949                    % get the valid extensions
  950    (   '$select_option'(extensions(Exts), Options, Options1)
  951    ->  '$must_be'(list, Exts)
  952    ;   '$option'(file_type(Type), Options)
  953    ->  '$must_be'(atom, Type),
  954        '$file_type_extensions'(Type, Exts),
  955        Options1 = Options
  956    ;   Options1 = Options,
  957        Exts = ['']
  958    ),
  959    '$canonicalise_extensions'(Exts, Extensions),
  960                    % unless specified otherwise, ask regular file
  961    (   nonvar(Type)
  962    ->  Options2 = Options1
  963    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
  964    ),
  965                    % Det or nondet?
  966    (   '$select_option'(solutions(Sols), Options2, Options3)
  967    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
  968    ;   Sols = first,
  969        Options3 = Options2
  970    ),
  971                    % Errors or not?
  972    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
  973    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
  974    ;   FileErrors = error,
  975        Options4 = Options3
  976    ),
  977                    % Expand shell patterns?
  978    (   atomic(Spec),
  979        '$select_option'(expand(Expand), Options4, Options5),
  980        '$must_be'(boolean, Expand)
  981    ->  expand_file_name(Spec, List),
  982        '$member'(Spec1, List)
  983    ;   Spec1 = Spec,
  984        Options5 = Options4
  985    ),
  986                    % Search for files
  987    (   Sols == first
  988    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
  989        ->  !       % also kill choice point of expand_file_name/2
  990        ;   (   FileErrors == fail
  991            ->  fail
  992            ;   '$current_module'('$bags', _File),
  993                findall(P,
  994                        '$chk_file'(Spec1, Extensions, [access(exist)],
  995                                    false, P),
  996                        Candidates),
  997                '$abs_file_error'(Spec, Candidates, Options5)
  998            )
  999        )
 1000    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 1001    ).
 1002
 1003'$abs_file_error'(Spec, Candidates, Conditions) :-
 1004    '$member'(F, Candidates),
 1005    '$member'(C, Conditions),
 1006    '$file_condition'(C),
 1007    '$file_error'(C, Spec, F, E, Comment),
 1008    !,
 1009    throw(error(E, context(_, Comment))).
 1010'$abs_file_error'(Spec, _, _) :-
 1011    '$existence_error'(source_sink, Spec).
 1012
 1013'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 1014    \+ exists_directory(File),
 1015    !,
 1016    Error = existence_error(directory, Spec),
 1017    Comment = not_a_directory(File).
 1018'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 1019    exists_directory(File),
 1020    !,
 1021    Error = existence_error(file, Spec),
 1022    Comment = directory(File).
 1023'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 1024    '$one_or_member'(Access, OneOrList),
 1025    \+ access_file(File, Access),
 1026    Error = permission_error(Access, source_sink, Spec).
 1027
 1028'$one_or_member'(Elem, List) :-
 1029    is_list(List),
 1030    !,
 1031    '$member'(Elem, List).
 1032'$one_or_member'(Elem, Elem).
 1033
 1034
 1035'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 1036    !,
 1037    '$file_type_extensions'(prolog, Exts).
 1038'$file_type_extensions'(Type, Exts) :-
 1039    '$current_module'('$bags', _File),
 1040    !,
 1041    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 1042    (   Exts0 == [],
 1043        \+ '$ft_no_ext'(Type)
 1044    ->  '$domain_error'(file_type, Type)
 1045    ;   true
 1046    ),
 1047    '$append'(Exts0, [''], Exts).
 1048'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 1049
 1050'$ft_no_ext'(txt).
 1051'$ft_no_ext'(executable).
 1052'$ft_no_ext'(directory).

 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.

 1065:- multifile(user:prolog_file_type/2). 1066:- dynamic(user:prolog_file_type/2). 1067
 1068user:prolog_file_type(pl,       prolog).
 1069user:prolog_file_type(prolog,   prolog).
 1070user:prolog_file_type(qlf,      prolog).
 1071user:prolog_file_type(qlf,      qlf).
 1072user:prolog_file_type(Ext,      executable) :-
 1073    current_prolog_flag(shared_object_extension, Ext).
 1074user:prolog_file_type(dylib,    executable) :-
 1075    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.

 1082'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
 1083    \+ ground(Spec),
 1084    !,
 1085    '$instantiation_error'(Spec).
 1086'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
 1087    compound(Spec),
 1088    functor(Spec, _, 1),
 1089    !,
 1090    '$relative_to'(Cond, cwd, CWD),
 1091    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
 1092'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
 1093    \+ atomic(Segments),
 1094    !,
 1095    '$segments_to_atom'(Segments, Atom),
 1096    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
 1097'$chk_file'(File, Exts, Cond, _, FullName) :-
 1098    is_absolute_file_name(File),
 1099    !,
 1100    '$extend_file'(File, Exts, Extended),
 1101    '$file_conditions'(Cond, Extended),
 1102    '$absolute_file_name'(Extended, FullName).
 1103'$chk_file'(File, Exts, Cond, _, FullName) :-
 1104    '$relative_to'(Cond, source, Dir),
 1105    atomic_list_concat([Dir, /, File], AbsFile),
 1106    '$extend_file'(AbsFile, Exts, Extended),
 1107    '$file_conditions'(Cond, Extended),
 1108    !,
 1109    '$absolute_file_name'(Extended, FullName).
 1110'$chk_file'(File, Exts, Cond, _, FullName) :-
 1111    '$extend_file'(File, Exts, Extended),
 1112    '$file_conditions'(Cond, Extended),
 1113    '$absolute_file_name'(Extended, FullName).
 1114
 1115'$segments_to_atom'(Atom, Atom) :-
 1116    atomic(Atom),
 1117    !.
 1118'$segments_to_atom'(Segments, Atom) :-
 1119    '$segments_to_list'(Segments, List, []),
 1120    !,
 1121    atomic_list_concat(List, /, Atom).
 1122
 1123'$segments_to_list'(A/B, H, T) :-
 1124    '$segments_to_list'(A, H, T0),
 1125    '$segments_to_list'(B, T0, T).
 1126'$segments_to_list'(A, [A|T], T) :-
 1127    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.

 1137'$relative_to'(Conditions, Default, Dir) :-
 1138    (   '$option'(relative_to(FileOrDir), Conditions)
 1139    *-> (   exists_directory(FileOrDir)
 1140        ->  Dir = FileOrDir
 1141        ;   atom_concat(Dir, /, FileOrDir)
 1142        ->  true
 1143        ;   file_directory_name(FileOrDir, Dir)
 1144        )
 1145    ;   Default == cwd
 1146    ->  '$cwd'(Dir)
 1147    ;   Default == source
 1148    ->  source_location(ContextFile, _Line),
 1149        file_directory_name(ContextFile, Dir)
 1150    ).

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

 1155:- dynamic
 1156    '$search_path_file_cache'/3,    % SHA1, Time, Path
 1157    '$search_path_gc_time'/1.       % Time
 1158:- volatile
 1159    '$search_path_file_cache'/3,
 1160    '$search_path_gc_time'/1. 1161
 1162:- create_prolog_flag(file_search_cache_time, 10, []). 1163
 1164'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
 1165    !,
 1166    findall(Exp, expand_file_search_path(Spec, Exp), Expansions),
 1167    Cache = cache(Exts, Cond, CWD, Expansions),
 1168    variant_sha1(Spec+Cache, SHA1),
 1169    get_time(Now),
 1170    current_prolog_flag(file_search_cache_time, TimeOut),
 1171    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
 1172        CachedTime > Now - TimeOut,
 1173        '$file_conditions'(Cond, FullFile)
 1174    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
 1175    ;   '$member'(Expanded, Expansions),
 1176        '$extend_file'(Expanded, Exts, LibFile),
 1177        (   '$file_conditions'(Cond, LibFile),
 1178            '$absolute_file_name'(LibFile, FullFile),
 1179            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
 1180        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
 1181        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
 1182            fail
 1183        )
 1184    ).
 1185'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
 1186    expand_file_search_path(Spec, Expanded),
 1187    '$extend_file'(Expanded, Exts, LibFile),
 1188    '$file_conditions'(Cond, LibFile),
 1189    '$absolute_file_name'(LibFile, FullFile).
 1190
 1191'$cache_file_found'(_, _, TimeOut, _) :-
 1192    TimeOut =:= 0,
 1193    !.
 1194'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1195    '$search_path_file_cache'(SHA1, Saved, FullFile),
 1196    !,
 1197    (   Now - Saved < TimeOut/2
 1198    ->  true
 1199    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
 1200        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
 1201    ).
 1202'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
 1203    'gc_file_search_cache'(TimeOut),
 1204    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
 1205
 1206'gc_file_search_cache'(TimeOut) :-
 1207    get_time(Now),
 1208    '$search_path_gc_time'(Last),
 1209    Now-Last < TimeOut/2,
 1210    !.
 1211'gc_file_search_cache'(TimeOut) :-
 1212    get_time(Now),
 1213    retractall('$search_path_gc_time'(_)),
 1214    assertz('$search_path_gc_time'(Now)),
 1215    Before is Now - TimeOut,
 1216    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
 1217        Cached < Before,
 1218        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
 1219        fail
 1220    ;   true
 1221    ).
 1222
 1223
 1224'$search_message'(Term) :-
 1225    current_prolog_flag(verbose_file_search, true),
 1226    !,
 1227    print_message(informational, Term).
 1228'$search_message'(_).

 $file_conditions(+Condition, +Path)

Verify Path satisfies Condition.

 1235'$file_conditions'(List, File) :-
 1236    is_list(List),
 1237    !,
 1238    \+ ( '$member'(C, List),
 1239         '$file_condition'(C),
 1240         \+ '$file_condition'(C, File)
 1241       ).
 1242'$file_conditions'(Map, File) :-
 1243    \+ (  get_dict(Key, Map, Value),
 1244          C =.. [Key,Value],
 1245          '$file_condition'(C),
 1246         \+ '$file_condition'(C, File)
 1247       ).
 1248
 1249'$file_condition'(file_type(directory), File) :-
 1250    !,
 1251    exists_directory(File).
 1252'$file_condition'(file_type(_), File) :-
 1253    !,
 1254    \+ exists_directory(File).
 1255'$file_condition'(access(Accesses), File) :-
 1256    !,
 1257    \+ (  '$one_or_member'(Access, Accesses),
 1258          \+ access_file(File, Access)
 1259       ).
 1260
 1261'$file_condition'(exists).
 1262'$file_condition'(file_type(_)).
 1263'$file_condition'(access(_)).
 1264
 1265'$extend_file'(File, Exts, FileEx) :-
 1266    '$ensure_extensions'(Exts, File, Fs),
 1267    '$list_to_set'(Fs, FsSet),
 1268    '$member'(FileEx, FsSet).
 1269
 1270'$ensure_extensions'([], _, []).
 1271'$ensure_extensions'([E|E0], F, [FE|E1]) :-
 1272    file_name_extension(F, E, FE),
 1273    '$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. Note that library(lists) provides an O(N*log(N)) version, but sets of file name extensions should be short enough for this not to matter.

 1282'$list_to_set'(List, Set) :-
 1283    '$list_to_set'(List, [], Set).
 1284
 1285'$list_to_set'([], _, []).
 1286'$list_to_set'([H|T], Seen, R) :-
 1287    memberchk(H, Seen),
 1288    !,
 1289    '$list_to_set'(T, R).
 1290'$list_to_set'([H|T], Seen, [H|R]) :-
 1291    '$list_to_set'(T, [H|Seen], R).
 1292
 1293/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 1294Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
 1295the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
 1296extensions to .ext
 1297- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 1298
 1299'$canonicalise_extensions'([], []) :- !.
 1300'$canonicalise_extensions'([H|T], [CH|CT]) :-
 1301    !,
 1302    '$must_be'(atom, H),
 1303    '$canonicalise_extension'(H, CH),
 1304    '$canonicalise_extensions'(T, CT).
 1305'$canonicalise_extensions'(E, [CE]) :-
 1306    '$canonicalise_extension'(E, CE).
 1307
 1308'$canonicalise_extension'('', '') :- !.
 1309'$canonicalise_extension'(DotAtom, DotAtom) :-
 1310    sub_atom(DotAtom, 0, _, _, '.'),
 1311    !.
 1312'$canonicalise_extension'(Atom, DotAtom) :-
 1313    atom_concat('.', Atom, DotAtom).
 1314
 1315
 1316                /********************************
 1317                *            CONSULT            *
 1318                *********************************/
 1319
 1320:- dynamic
 1321    user:library_directory/1,
 1322    user:prolog_load_file/2. 1323:- multifile
 1324    user:library_directory/1,
 1325    user:prolog_load_file/2. 1326
 1327:- prompt(_, '|: '). 1328
 1329:- thread_local
 1330    '$compilation_mode_store'/1,    % database, wic, qlf
 1331    '$directive_mode_store'/1.      % database, wic, qlf
 1332:- volatile
 1333    '$compilation_mode_store'/1,
 1334    '$directive_mode_store'/1. 1335
 1336'$compilation_mode'(Mode) :-
 1337    (   '$compilation_mode_store'(Val)
 1338    ->  Mode = Val
 1339    ;   Mode = database
 1340    ).
 1341
 1342'$set_compilation_mode'(Mode) :-
 1343    retractall('$compilation_mode_store'(_)),
 1344    assertz('$compilation_mode_store'(Mode)).
 1345
 1346'$compilation_mode'(Old, New) :-
 1347    '$compilation_mode'(Old),
 1348    (   New == Old
 1349    ->  true
 1350    ;   '$set_compilation_mode'(New)
 1351    ).
 1352
 1353'$directive_mode'(Mode) :-
 1354    (   '$directive_mode_store'(Val)
 1355    ->  Mode = Val
 1356    ;   Mode = database
 1357    ).
 1358
 1359'$directive_mode'(Old, New) :-
 1360    '$directive_mode'(Old),
 1361    (   New == Old
 1362    ->  true
 1363    ;   '$set_directive_mode'(New)
 1364    ).
 1365
 1366'$set_directive_mode'(Mode) :-
 1367    retractall('$directive_mode_store'(_)),
 1368    assertz('$directive_mode_store'(Mode)).

 $compilation_level(-Level) is det

True when Level reflects the nesting in files compiling other files. 0 if no files are being loaded.

 1376'$compilation_level'(Level) :-
 1377    '$input_context'(Stack),
 1378    '$compilation_level'(Stack, Level).
 1379
 1380'$compilation_level'([], 0).
 1381'$compilation_level'([Input|T], Level) :-
 1382    (   arg(1, Input, see)
 1383    ->  '$compilation_level'(T, Level)
 1384    ;   '$compilation_level'(T, Level0),
 1385        Level is Level0+1
 1386    ).

 compiling

Is true if SWI-Prolog is generating a state or qlf file or executes a `call' directive while doing this.

 1394compiling :-
 1395    \+ (   '$compilation_mode'(database),
 1396           '$directive_mode'(database)
 1397       ).
 1398
 1399:- meta_predicate
 1400    '$ifcompiling'(0). 1401
 1402'$ifcompiling'(G) :-
 1403    (   '$compilation_mode'(database)
 1404    ->  true
 1405    ;   call(G)
 1406    ).
 1407
 1408                /********************************
 1409                *         READ SOURCE           *
 1410                *********************************/

 $load_msg_level(+Action, +NestingLevel, -StartVerbose, -EndVerbose)

 1414'$load_msg_level'(Action, Nesting, Start, Done) :-
 1415    '$update_autoload_level'([], 0),
 1416    !,
 1417    current_prolog_flag(verbose_load, Type0),
 1418    '$load_msg_compat'(Type0, Type),
 1419    (   '$load_msg_level'(Action, Nesting, Type, Start, Done)
 1420    ->  true
 1421    ).
 1422'$load_msg_level'(_, _, silent, silent).
 1423
 1424'$load_msg_compat'(true, normal) :- !.
 1425'$load_msg_compat'(false, silent) :- !.
 1426'$load_msg_compat'(X, X).
 1427
 1428'$load_msg_level'(load_file,    _, full,   informational, informational).
 1429'$load_msg_level'(include_file, _, full,   informational, informational).
 1430'$load_msg_level'(load_file,    _, normal, silent,        informational).
 1431'$load_msg_level'(include_file, _, normal, silent,        silent).
 1432'$load_msg_level'(load_file,    0, brief,  silent,        informational).
 1433'$load_msg_level'(load_file,    _, brief,  silent,        silent).
 1434'$load_msg_level'(include_file, _, brief,  silent,        silent).
 1435'$load_msg_level'(load_file,    _, silent, silent,        silent).
 1436'$load_msg_level'(include_file, _, silent, silent,        silent).

 $source_term(+From, -Read, -RLayout, -Term, -TLayout, -Stream, +Options) is nondet

Read Prolog terms from the input From. Terms are returned on backtracking. Associated resources (i.e., streams) are closed due to setup_call_cleanup/3.

Arguments:

From	- is either a term stream(Id, Stream) or a file specification.
Read	- is the raw term as read from the input.
Term	- is the term after term-expansion. If a term is expanded into the empty list, this is returned too. This is required to be able to return the raw term in Read
Stream	- is the stream from which Read is read
Options	- provides additional options: encoding(Enc) Encoding used to open From syntax_errors(+ErrorMode) process_comments(+Boolean) term_position(-Pos)

 1459'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
 1460    '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
 1461    (   Term == end_of_file
 1462    ->  !, fail
 1463    ;   Term \== begin_of_file
 1464    ).
 1465
 1466'$source_term'(Input, _,_,_,_,_,_,_) :-
 1467    \+ ground(Input),
 1468    !,
 1469    '$instantiation_error'(Input).
 1470'$source_term'(stream(Id, In, Opts),
 1471               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1472    !,
 1473    '$record_included'(Parents, Id, Id, 0.0, Message),
 1474    setup_call_cleanup(
 1475        '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
 1476        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1477                        [Id|Parents], Options),
 1478        '$close_source'(State, Message)).
 1479'$source_term'(File,
 1480               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1481    absolute_file_name(File, Path,
 1482                       [ file_type(prolog),
 1483                         access(read)
 1484                       ]),
 1485    time_file(Path, Time),
 1486    '$record_included'(Parents, File, Path, Time, Message),
 1487    setup_call_cleanup(
 1488        '$open_source'(Path, In, State, Parents, Options),
 1489        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
 1490                        [Path|Parents], Options),
 1491        '$close_source'(State, Message)).
 1492
 1493:- thread_local
 1494    '$load_input'/2. 1495:- volatile
 1496    '$load_input'/2. 1497
 1498'$open_source'(stream(Id, In, Opts), In,
 1499               restore(In, StreamState, Id, Ref, Opts), Parents, Options) :-
 1500    !,
 1501    '$context_type'(Parents, ContextType),
 1502    '$push_input_context'(ContextType),
 1503    '$set_encoding'(In, Options),
 1504    '$prepare_load_stream'(In, Id, StreamState),
 1505    asserta('$load_input'(stream(Id), In), Ref).
 1506'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
 1507    '$context_type'(Parents, ContextType),
 1508    '$push_input_context'(ContextType),
 1509    open(Path, read, In),
 1510    '$set_encoding'(In, Options),
 1511    asserta('$load_input'(Path, In), Ref).
 1512
 1513'$context_type'([], load_file) :- !.
 1514'$context_type'(_, include).
 1515
 1516'$close_source'(close(In, Id, Ref), Message) :-
 1517    erase(Ref),
 1518    '$end_consult'(Id),
 1519    call_cleanup(
 1520        close(In),
 1521        '$pop_input_context'),
 1522    '$close_message'(Message).
 1523'$close_source'(restore(In, StreamState, Id, Ref, Opts), Message) :-
 1524    erase(Ref),
 1525    '$end_consult'(Id),
 1526    call_cleanup(
 1527        '$restore_load_stream'(In, StreamState, Opts),
 1528        '$pop_input_context'),
 1529    '$close_message'(Message).
 1530
 1531'$close_message'(message(Level, Msg)) :-
 1532    !,
 1533    '$print_message'(Level, Msg).
 1534'$close_message'(_).

 $term_in_file(+In, -Read, -RLayout, -Term, -TLayout, -Stream, +Parents, +Options) is multi

True when Term is an expanded term from In. Read is a raw term (before term-expansion). Stream is the actual stream, which starts at In, but may change due to processing included files.

See also

- '$source_term'/8 for details.

 1546'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1547    Parents \= [_,_|_],
 1548    (   '$load_input'(_, Input)
 1549    ->  stream_property(Input, file_name(File))
 1550    ),
 1551    '$set_source_location'(File, 0),
 1552    '$expanded_term'(In,
 1553                     begin_of_file, 0-0, Read, RLayout, Term, TLayout,
 1554                     Stream, Parents, Options).
 1555'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
 1556    '$skip_script_line'(In, Options),
 1557    '$read_clause_options'(Options, ReadOptions),
 1558    repeat,
 1559      read_clause(In, Raw,
 1560                  [ variable_names(Bindings),
 1561                    term_position(Pos),
 1562                    subterm_positions(RawLayout)
 1563                  | ReadOptions
 1564                  ]),
 1565      b_setval('$term_position', Pos),
 1566      b_setval('$variable_names', Bindings),
 1567      (   Raw == end_of_file
 1568      ->  !,
 1569          (   Parents = [_,_|_]     % Included file
 1570          ->  fail
 1571          ;   '$expanded_term'(In,
 1572                               Raw, RawLayout, Read, RLayout, Term, TLayout,
 1573                               Stream, Parents, Options)
 1574          )
 1575      ;   '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1576                           Stream, Parents, Options)
 1577      ).
 1578
 1579'$read_clause_options'([], []).
 1580'$read_clause_options'([H|T0], List) :-
 1581    (   '$read_clause_option'(H)
 1582    ->  List = [H|T]
 1583    ;   List = T
 1584    ),
 1585    '$read_clause_options'(T0, T).
 1586
 1587'$read_clause_option'(syntax_errors(_)).
 1588'$read_clause_option'(term_position(_)).
 1589'$read_clause_option'(process_comment(_)).
 1590
 1591'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
 1592                 Stream, Parents, Options) :-
 1593    E = error(_,_),
 1594    catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
 1595          '$print_message_fail'(E)),
 1596    (   Expanded \== []
 1597    ->  '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
 1598    ;   Term1 = Expanded,
 1599        Layout1 = ExpandedLayout
 1600    ),
 1601    (   nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
 1602    ->  (   Directive = include(File),
 1603            '$current_source_module'(Module),
 1604            '$valid_directive'(Module:include(File))
 1605        ->  stream_property(In, encoding(Enc)),
 1606            '$add_encoding'(Enc, Options, Options1),
 1607            '$source_term'(File, Read, RLayout, Term, TLayout,
 1608                           Stream, Parents, Options1)
 1609        ;   Directive = encoding(Enc)
 1610        ->  set_stream(In, encoding(Enc)),
 1611            fail
 1612        ;   Term = Term1,
 1613            Stream = In,
 1614            Read = Raw
 1615        )
 1616    ;   Term = Term1,
 1617        TLayout = Layout1,
 1618        Stream = In,
 1619        Read = Raw,
 1620        RLayout = RawLayout
 1621    ).
 1622
 1623'$expansion_member'(Var, Layout, Var, Layout) :-
 1624    var(Var),
 1625    !.
 1626'$expansion_member'([], _, _, _) :- !, fail.
 1627'$expansion_member'(List, ListLayout, Term, Layout) :-
 1628    is_list(List),
 1629    !,
 1630    (   var(ListLayout)
 1631    ->  '$member'(Term, List)
 1632    ;   is_list(ListLayout)
 1633    ->  '$member_rep2'(Term, Layout, List, ListLayout)
 1634    ;   Layout = ListLayout,
 1635        '$member'(Term, List)
 1636    ).
 1637'$expansion_member'(X, Layout, X, Layout).
 1638
 1639% pairwise member, repeating last element of the second
 1640% list.
 1641
 1642'$member_rep2'(H1, H2, [H1|_], [H2|_]).
 1643'$member_rep2'(H1, H2, [_|T1], [T2]) :-
 1644    !,
 1645    '$member_rep2'(H1, H2, T1, [T2]).
 1646'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
 1647    '$member_rep2'(H1, H2, T1, T2).

 $add_encoding(+Enc, +Options0, -Options)

 1651'$add_encoding'(Enc, Options0, Options) :-
 1652    (   Options0 = [encoding(Enc)|_]
 1653    ->  Options = Options0
 1654    ;   Options = [encoding(Enc)|Options0]
 1655    ).
 1656
 1657
 1658:- multifile
 1659    '$included'/4.                  % Into, Line, File, LastModified
 1660:- dynamic
 1661    '$included'/4.

 $record_included(+Parents, +File, +Path, +Time, -Message) is det

Record that we included File into the head of Parents. This is troublesome when creating a QLF file because this may happen before we opened the QLF file (and we do not yet know how to open the file because we do not yet know whether this is a module file or not).

I think that the only sensible solution is to have a special statement for this, that may appear both inside and outside QLF `parts'.

 1675'$record_included'([Parent|Parents], File, Path, Time,
 1676                   message(DoneMsgLevel,
 1677                           include_file(done(Level, file(File, Path))))) :-
 1678    source_location(SrcFile, Line),
 1679    !,
 1680    '$compilation_level'(Level),
 1681    '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
 1682    '$print_message'(StartMsgLevel,
 1683                     include_file(start(Level,
 1684                                        file(File, Path)))),
 1685    '$last'([Parent|Parents], Owner),
 1686    (   (   '$compilation_mode'(database)
 1687        ;   '$qlf_current_source'(Owner)
 1688        )
 1689    ->  '$store_admin_clause'(
 1690            system:'$included'(Parent, Line, Path, Time),
 1691            _, Owner, SrcFile:Line)
 1692    ;   '$qlf_include'(Owner, Parent, Line, Path, Time)
 1693    ).
 1694'$record_included'(_, _, _, _, true).