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-2015, University of Amsterdam
   7                              VU University Amsterdam
   8    All rights reserved.
   9
  10    Redistribution and use in source and binary forms, with or without
  11    modification, are permitted provided that the following conditions
  12    are met:
  13
  14    1. Redistributions of source code must retain the above copyright
  15       notice, this list of conditions and the following disclaimer.
  16
  17    2. Redistributions in binary form must reproduce the above copyright
  18       notice, this list of conditions and the following disclaimer in
  19       the documentation and/or other materials provided with the
  20       distribution.
  21
  22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33    POSSIBILITY OF SUCH DAMAGE.
  34*/
  35
  36/*
  37Consult, derivates and basic things.   This  module  is  loaded  by  the
  38C-written  bootstrap  compiler.
  39
  40The $:- directive  is  executed  by  the  bootstrap  compiler,  but  not
  41inserted  in  the  intermediate  code  file.   Used  to print diagnostic
  42messages and start the Prolog defined compiler for  the  remaining  boot
  43modules.
  44
  45If you want  to  debug  this  module,  put  a  '$:-'(trace).   directive
  46somewhere.   The  tracer will work properly under boot compilation as it
  47will use the C defined write predicate  to  print  goals  and  does  not
  48attempt to call the Prolog defined trace interceptor.
  49*/
  50
  51'$:-'(format('Loading boot file ...~n', [])).
  52
  53                /********************************
  54                *    LOAD INTO MODULE SYSTEM    *
  55                ********************************/
  56
  57:- '$set_source_module'(system).
  58
  59                /********************************
  60                *          DIRECTIVES           *
  61                *********************************/
  62
  63:- meta_predicate
  64    dynamic(:),
  65    multifile(:),
  66    public(:),
  67    module_transparent(:),
  68    discontiguous(:),
  69    volatile(:),
  70    thread_local(:),
  71    noprofile(:),
  72    '$iso'(:),
  73    '$hide'(:).
  74
  75%!  dynamic(+Spec) is det.
  76%!  multifile(+Spec) is det.
  77%!  module_transparent(+Spec) is det.
  78%!  discontiguous(+Spec) is det.
  79%!  volatile(+Spec) is det.
  80%!  thread_local(+Spec) is det.
  81%!  noprofile(+Spec) is det.
  82%!  public(+Spec) is det.
  83%
  84%   Predicate versions of standard  directives   that  set predicate
  85%   attributes. These predicates bail out with an error on the first
  86%   failure (typically permission errors).
  87
  88dynamic(Spec)            :- '$set_pattr'(Spec, pred, (dynamic)).
  89multifile(Spec)          :- '$set_pattr'(Spec, pred, (multifile)).
  90module_transparent(Spec) :- '$set_pattr'(Spec, pred, (transparent)).
  91discontiguous(Spec)      :- '$set_pattr'(Spec, pred, (discontiguous)).
  92volatile(Spec)           :- '$set_pattr'(Spec, pred, (volatile)).
  93thread_local(Spec)       :- '$set_pattr'(Spec, pred, (thread_local)).
  94noprofile(Spec)          :- '$set_pattr'(Spec, pred, (noprofile)).
  95public(Spec)             :- '$set_pattr'(Spec, pred, (public)).
  96'$iso'(Spec)             :- '$set_pattr'(Spec, pred, (iso)).
  97
  98'$set_pattr'(M:Pred, How, Attr) :-
  99    '$set_pattr'(Pred, M, How, Attr).
 100
 101'$set_pattr'(X, _, _, _) :-
 102    var(X),
 103    throw(error(instantiation_error, _)).
 104'$set_pattr'([], _, _, _) :- !.
 105'$set_pattr'([H|T], M, How, Attr) :-           % ISO
 106    !,
 107    '$set_pattr'(H, M, How, Attr),
 108    '$set_pattr'(T, M, How, Attr).
 109'$set_pattr'((A,B), M, How, Attr) :-           % ISO and traditional
 110    !,
 111    '$set_pattr'(A, M, How, Attr),
 112    '$set_pattr'(B, M, How, Attr).
 113'$set_pattr'(M:T, _, How, Attr) :-
 114    !,
 115    '$set_pattr'(T, M, How, Attr).
 116'$set_pattr'(A, M, pred, Attr) :-
 117    !,
 118    '$set_predicate_attribute'(M:A, Attr, true).
 119'$set_pattr'(A, M, directive, Attr) :-
 120    !,
 121    catch('$set_predicate_attribute'(M:A, Attr, true),
 122          error(E, _),
 123          print_message(error, error(E, context((Attr)/1,_)))).
 124
 125%!  '$pattr_directive'(+Spec, +Module) is det.
 126%
 127%   This implements the directive version of dynamic/1, multifile/1,
 128%   etc. This version catches and prints   errors.  If the directive
 129%   specifies  multiple  predicates,  processing    after  an  error
 130%   continues with the remaining predicates.
 131
 132'$pattr_directive'(dynamic(Spec), M) :-
 133    '$set_pattr'(Spec, M, directive, (dynamic)).
 134'$pattr_directive'(multifile(Spec), M) :-
 135    '$set_pattr'(Spec, M, directive, (multifile)).
 136'$pattr_directive'(module_transparent(Spec), M) :-
 137    '$set_pattr'(Spec, M, directive, (transparent)).
 138'$pattr_directive'(discontiguous(Spec), M) :-
 139    '$set_pattr'(Spec, M, directive, (discontiguous)).
 140'$pattr_directive'(volatile(Spec), M) :-
 141    '$set_pattr'(Spec, M, directive, (volatile)).
 142'$pattr_directive'(thread_local(Spec), M) :-
 143    '$set_pattr'(Spec, M, directive, (thread_local)).
 144'$pattr_directive'(noprofile(Spec), M) :-
 145    '$set_pattr'(Spec, M, directive, (noprofile)).
 146'$pattr_directive'(public(Spec), M) :-
 147    '$set_pattr'(Spec, M, directive, (public)).
 148
 149
 150%!  '$hide'(:PI)
 151%
 152%   Predicates protected this way are never visible in the tracer.
 153
 154'$hide'(Pred) :-
 155    '$set_predicate_attribute'(Pred, trace, false).
 156
 157
 158                /********************************
 159                *       CALLING, CONTROL        *
 160                *********************************/
 161
 162:- noprofile((call/1,
 163              catch/3,
 164              once/1,
 165              ignore/1,
 166              call_cleanup/2,
 167              call_cleanup/3,
 168              setup_call_cleanup/3,
 169              setup_call_catcher_cleanup/4)).
 170
 171:- meta_predicate
 172    ';'(0,0),
 173    ','(0,0),
 174    @(0,+),
 175    call(0),
 176    call(1,?),
 177    call(2,?,?),
 178    call(3,?,?,?),
 179    call(4,?,?,?,?),
 180    call(5,?,?,?,?,?),
 181    call(6,?,?,?,?,?,?),
 182    call(7,?,?,?,?,?,?,?),
 183    not(0),
 184    \+(0),
 185    '->'(0,0),
 186    '*->'(0,0),
 187    once(0),
 188    ignore(0),
 189    catch(0,?,0),
 190    reset(0,-,?),
 191    setup_call_cleanup(0,0,0),
 192    setup_call_catcher_cleanup(0,0,?,0),
 193    call_cleanup(0,0),
 194    call_cleanup(0,?,0),
 195    '$meta_call'(0).
 196
 197:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)).
 198
 199% The control structures are always compiled, both   if they appear in a
 200% clause body and if they are handed  to   call/1.  The only way to call
 201% these predicates is by means of  call/2..   In  that case, we call the
 202% hole control structure again to get it compiled by call/1 and properly
 203% deal  with  !,  etc.  Another  reason  for  having  these  things   as
 204% predicates is to be able to define   properties for them, helping code
 205% analyzers.
 206
 207(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
 208(M1:If ; M2:Then) :-    call(M1:(If ; M2:Then)).
 209(G1   , G2)       :-    call((G1   , G2)).
 210(If  -> Then)     :-    call((If  -> Then)).
 211(If *-> Then)     :-    call((If *-> Then)).
 212@(Goal,Module)    :-    @(Goal,Module).
 213
 214%!  '$meta_call'(:Goal)
 215%
 216%   Interpreted  meta-call  implementation.  By    default,   call/1
 217%   compiles its argument into  a   temporary  clause. This realises
 218%   better  performance  if  the  (complex)  goal   does  a  lot  of
 219%   backtracking  because  this   interpreted    version   needs  to
 220%   re-interpret the remainder of the goal after backtracking.
 221%
 222%   This implementation is used by  reset/3 because the continuation
 223%   cannot be captured if it contains   a  such a compiled temporary
 224%   clause.
 225
 226'$meta_call'(M:G) :-
 227    prolog_current_choice(Ch),
 228    '$meta_call'(G, M, Ch).
 229
 230'$meta_call'(Var, _, _) :-
 231    var(Var),
 232    !,
 233    '$instantiation_error'(Var).
 234'$meta_call'((A,B), M, Ch) :-
 235    !,
 236    '$meta_call'(A, M, Ch),
 237    '$meta_call'(B, M, Ch).
 238'$meta_call'((I->T;E), M, Ch) :-
 239    !,
 240    (   prolog_current_choice(Ch2),
 241        '$meta_call'(I, M, Ch2)
 242    ->  '$meta_call'(T, M, Ch)
 243    ;   '$meta_call'(E, M, Ch)
 244    ).
 245'$meta_call'((I*->T;E), M, Ch) :-
 246    !,
 247    (   prolog_current_choice(Ch2),
 248        '$meta_call'(I, M, Ch2)
 249    *-> '$meta_call'(T, M, Ch)
 250    ;   '$meta_call'(E, M, Ch)
 251    ).
 252'$meta_call'((I->T), M, Ch) :-
 253    !,
 254    (   prolog_current_choice(Ch2),
 255        '$meta_call'(I, M, Ch2)
 256    ->  '$meta_call'(T, M, Ch)
 257    ).
 258'$meta_call'((I*->T), M, Ch) :-
 259    !,
 260    prolog_current_choice(Ch2),
 261    '$meta_call'(I, M, Ch2),
 262    '$meta_call'(T, M, Ch).
 263'$meta_call'((A;B), M, Ch) :-
 264    !,
 265    (   '$meta_call'(A, M, Ch)
 266    ;   '$meta_call'(B, M, Ch)
 267    ).
 268'$meta_call'(\+(G), M, _) :-
 269    !,
 270    prolog_current_choice(Ch),
 271    \+ '$meta_call'(G, M, Ch).
 272'$meta_call'(call(G), M, _) :-
 273    !,
 274    prolog_current_choice(Ch),
 275    '$meta_call'(G, M, Ch).
 276'$meta_call'(M:G, _, Ch) :-
 277    !,
 278    '$meta_call'(G, M, Ch).
 279'$meta_call'(!, _, Ch) :-
 280    prolog_cut_to(Ch).
 281'$meta_call'(G, M, _Ch) :-
 282    call(M:G).
 283
 284%!  call(:Closure, ?A).
 285%!  call(:Closure, ?A1, ?A2).
 286%!  call(:Closure, ?A1, ?A2, ?A3).
 287%!  call(:Closure, ?A1, ?A2, ?A3, ?A4).
 288%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5).
 289%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6).
 290%!  call(:Closure, ?A1, ?A2, ?A3, ?A4, ?A5, ?A6, ?A7).
 291%
 292%   Arity 2..8 is demanded by the   ISO standard. Higher arities are
 293%   supported, but handled by the compiler.   This  implies they are
 294%   not backed up by predicates and   analyzers  thus cannot ask for
 295%   their  properties.  Analyzers  should    hard-code  handling  of
 296%   call/2..
 297
 298:- '$iso'((call/2,
 299           call/3,
 300           call/4,
 301           call/5,
 302           call/6,
 303           call/7,
 304           call/8)).
 305
 306call(Goal) :-                           % make these available as predicates
 307    Goal.
 308call(Goal, A) :-
 309    call(Goal, A).
 310call(Goal, A, B) :-
 311    call(Goal, A, B).
 312call(Goal, A, B, C) :-
 313    call(Goal, A, B, C).
 314call(Goal, A, B, C, D) :-
 315    call(Goal, A, B, C, D).
 316call(Goal, A, B, C, D, E) :-
 317    call(Goal, A, B, C, D, E).
 318call(Goal, A, B, C, D, E, F) :-
 319    call(Goal, A, B, C, D, E, F).
 320call(Goal, A, B, C, D, E, F, G) :-
 321    call(Goal, A, B, C, D, E, F, G).
 322
 323%!  not(:Goal) is semidet.
 324%
 325%   Pre-ISO version of \+/1. Note that  some systems define not/1 as
 326%   a logically more sound version of \+/1.
 327
 328not(Goal) :-
 329    \+ Goal.
 330
 331%!  \+(:Goal) is semidet.
 332%
 333%   Predicate version that allows for meta-calling.
 334
 335\+ Goal :-
 336    \+ Goal.
 337
 338%!  once(:Goal) is semidet.
 339%
 340%   ISO predicate, acting as call((Goal, !)).
 341
 342once(Goal) :-
 343    Goal,
 344    !.
 345
 346%!  ignore(:Goal) is det.
 347%
 348%   Call Goal, cut choice-points on success  and succeed on failure.
 349%   intended for calling side-effects and proceed on failure.
 350
 351ignore(Goal) :-
 352    Goal,
 353    !.
 354ignore(_Goal).
 355
 356:- '$iso'((false/0)).
 357
 358%!  false.
 359%
 360%   Synonym for fail/0, providing a declarative reading.
 361
 362false :-
 363    fail.
 364
 365%!  catch(:Goal, +Catcher, :Recover)
 366%
 367%   ISO compliant exception handling.
 368
 369catch(_Goal, _Catcher, _Recover) :-
 370    '$catch'.                       % Maps to I_CATCH, I_EXITCATCH
 371
 372%!  prolog_cut_to(+Choice)
 373%
 374%   Cut all choice points after Choice
 375
 376prolog_cut_to(_Choice) :-
 377    '$cut'.                         % Maps to I_CUTCHP
 378
 379%!  reset(:Goal, ?Ball, -Continue)
 380%
 381%   Delimited continuation support.
 382
 383reset(Goal, Ball, Cont) :-
 384    '$start_reset',
 385    call(Goal),
 386    Cont = 0,
 387    Ball = 0.                       % only reached if there is no shift
 388
 389%!  call_continuation(+Continuation:list)
 390%
 391%   Call a continuation as created by shift/1. The continuation is a
 392%   list  of  '$cont$'(Clause,  PC,   Environment)  structures.  The
 393%   predicate  '$call_one_tail_body'/1  creates  a  frame  from  the
 394%   continuation and calls this.
 395%
 396%   Note that we can technically also   push the entire continuation
 397%   onto the environment and call  it.   Doing  it  incrementally as
 398%   below exploits last-call  optimization   and  therefore possible
 399%   quadratic expansion of the continuation.
 400
 401call_continuation([]).
 402call_continuation([TB|Rest]) :-
 403    '$call_one_tail_body'(TB),
 404    call_continuation(Rest).
 405
 406
 407%!  '$recover_and_rethrow'(:Goal, +Term)
 408%
 409%   This goal is used to wrap  the   catch/3  recover handler if the
 410%   exception is not supposed to be   `catchable'.  An example of an
 411%   uncachable exception is '$aborted', used   by abort/0. Note that
 412%   we cut to ensure  that  the   exception  is  not delayed forever
 413%   because the recover handler leaves a choicepoint.
 414
 415:- public '$recover_and_rethrow'/2.
 416
 417'$recover_and_rethrow'(Goal, Exception) :-
 418    call_cleanup(Goal, throw(Exception)),
 419    !.
 420
 421
 422%!  setup_call_cleanup(:Setup, :Goal, :Cleanup).
 423%!  setup_call_catcher_cleanup(:Setup, :Goal, +Catcher, :Cleanup).
 424%!  call_cleanup(:Goal, :Cleanup).
 425%!  call_cleanup(:Goal, +Catcher, :Cleanup).
 426%
 427%   Call Cleanup once after Goal is finished (deterministic success,
 428%   failure, exception or  cut).  The   call  to  '$call_cleanup' is
 429%   translated to I_CALLCLEANUP. This  instruction   relies  on  the
 430%   exact stack layout left   by  setup_call_catcher_cleanup/4. Also
 431%   the predicate name is used by   the kernel cleanup mechanism and
 432%   can only be changed together with the kernel.
 433
 434setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
 435    '$sig_atomic'(Setup),
 436    '$call_cleanup'.
 437
 438setup_call_cleanup(Setup, Goal, Cleanup) :-
 439    setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
 440
 441call_cleanup(Goal, Cleanup) :-
 442    setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
 443
 444call_cleanup(Goal, Catcher, Cleanup) :-
 445    setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
 446
 447                 /*******************************
 448                 *       INITIALIZATION         *
 449                 *******************************/
 450
 451:- meta_predicate
 452    initialization(0, +).
 453
 454:- multifile '$init_goal'/3.
 455:- dynamic   '$init_goal'/3.
 456
 457%!  initialization(:Goal, +When)
 458%
 459%   Register Goal to be executed if a saved state is restored. In
 460%   addition, the goal is executed depending on When:
 461%
 462%       * now
 463%       Execute immediately
 464%       * after_load
 465%       Execute after loading the file in which it appears
 466%       * restore
 467%       Do not execute immediately, but only when restoring the
 468%       state.  Not allowed in a sandboxed environment.
 469
 470initialization(Goal, When) :-
 471    '$initialization_context'(Source, Ctx),
 472    (   When == now
 473    ->  '$run_init_goal'(Goal, Ctx),
 474        '$compile_init_goal'(-, Goal, Ctx)
 475    ;   When == after_load
 476    ->  (   Source \== (-)
 477        ->  '$compile_init_goal'(Source, Goal, Ctx)
 478        ;   throw(error(context_error(nodirective,
 479                                      initialization(Goal, after_load)),
 480                        _))
 481        )
 482    ;   When == restore,
 483        \+ current_prolog_flag(sandboxed_load, true)
 484    ->  '$compile_init_goal'(-, Goal, Ctx)
 485    ;   (   var(When)
 486        ->  throw(error(instantiation_error, _))
 487        ;   atom(When)
 488        ->  throw(error(domain_error(initialization_type, When), _))
 489        ;   throw(error(type_error(atom, When), _))
 490        )
 491    ).
 492
 493'$compile_init_goal'(Source, Goal, Ctx) :-
 494    atom(Source),
 495    Source \== (-),
 496    !,
 497    '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
 498                          _Layout, Source, Ctx).
 499'$compile_init_goal'(Source, Goal, Ctx) :-
 500    assertz('$init_goal'(Source, Goal, Ctx)).
 501
 502
 503%!  '$run_initialization'(?File, +Options) is det.
 504%!  '$run_initialization'(?File, +Action, +Options) is det.
 505%
 506%   Run initialization directives for all files  if File is unbound,
 507%   or for a specified file.   Note  that '$run_initialization'/2 is
 508%   called from runInitialization() in pl-wic.c  for .qlf files. The
 509%   '$run_initialization'/3 is called with Action   set  to `loaded`
 510%   when called for a QLF file.
 511
 512'$run_initialization'(_, loaded, _) :- !.
 513'$run_initialization'(File, _Action, Options) :-
 514    '$run_initialization'(File, Options).
 515
 516'$run_initialization'(File, Options) :-
 517    setup_call_cleanup(
 518        '$start_run_initialization'(Options, Restore),
 519        '$run_initialization_2'(File),
 520        '$end_run_initialization'(Restore)).
 521
 522'$start_run_initialization'(Options, OldSandBoxed) :-
 523    '$push_input_context'(initialization),
 524    '$set_sandboxed_load'(Options, OldSandBoxed).
 525'$end_run_initialization'(OldSandBoxed) :-
 526    set_prolog_flag(sandboxed_load, OldSandBoxed),
 527    '$pop_input_context'.
 528
 529'$run_initialization_2'(File) :-
 530    (   '$init_goal'(File, Goal, Ctx),
 531        '$run_init_goal'(Goal, Ctx),
 532        fail
 533    ;   true
 534    ).
 535
 536'$run_init_goal'(Goal, Ctx) :-
 537    (   catch('$run_init_goal'(Goal), E,
 538              '$initialization_error'(E, Goal, Ctx))
 539    ->  true
 540    ;   '$initialization_failure'(Goal, Ctx)
 541    ).
 542
 543:- multifile prolog:sandbox_allowed_goal/1.
 544
 545'$run_init_goal'(Goal) :-
 546    current_prolog_flag(sandboxed_load, false),
 547    !,
 548    call(Goal).
 549'$run_init_goal'(Goal) :-
 550    prolog:sandbox_allowed_goal(Goal),
 551    call(Goal).
 552
 553'$initialization_context'(Source, Ctx) :-
 554    (   source_location(File, Line)
 555    ->  Ctx = File:Line,
 556        '$input_context'(Context),
 557        '$top_file'(Context, File, Source)
 558    ;   Ctx = (-),
 559        File = (-)
 560    ).
 561
 562'$top_file'([input(include, F1, _, _)|T], _, F) :-
 563    !,
 564    '$top_file'(T, F1, F).
 565'$top_file'(_, F, F).
 566
 567
 568'$initialization_error'(E, Goal, Ctx) :-
 569    print_message(error, initialization_error(Goal, E, Ctx)).
 570
 571'$initialization_failure'(Goal, Ctx) :-
 572    print_message(warning, initialization_failure(Goal, Ctx)).
 573
 574%!  '$clear_source_admin'(+File) is det.
 575%
 576%   Removes source adminstration related to File
 577%
 578%   @see Called from destroySourceFile() in pl-proc.c
 579
 580:- public '$clear_source_admin'/1.
 581
 582'$clear_source_admin'(File) :-
 583    retractall('$init_goal'(_, _, File:_)),
 584    retractall('$load_context_module'(File, _, _)).
 585
 586
 587                 /*******************************
 588                 *            STREAM            *
 589                 *******************************/
 590
 591:- '$iso'(stream_property/2).
 592stream_property(Stream, Property) :-
 593    nonvar(Stream),
 594    nonvar(Property),
 595    !,
 596    '$stream_property'(Stream, Property).
 597stream_property(Stream, Property) :-
 598    nonvar(Stream),
 599    !,
 600    '$stream_properties'(Stream, Properties),
 601    '$member'(Property, Properties).
 602stream_property(Stream, Property) :-
 603    nonvar(Property),
 604    !,
 605    (   Property = alias(Alias),
 606        atom(Alias)
 607    ->  '$alias_stream'(Alias, Stream)
 608    ;   '$streams_properties'(Property, Pairs),
 609        '$member'(Stream-Property, Pairs)
 610    ).
 611stream_property(Stream, Property) :-
 612    '$streams_properties'(Property, Pairs),
 613    '$member'(Stream-Properties, Pairs),
 614    '$member'(Property, Properties).
 615
 616
 617                /********************************
 618                *            MODULES            *
 619                *********************************/
 620
 621%       '$prefix_module'(+Module, +Context, +Term, -Prefixed)
 622%       Tags `Term' with `Module:' if `Module' is not the context module.
 623
 624'$prefix_module'(Module, Module, Head, Head) :- !.
 625'$prefix_module'(Module, _, Head, Module:Head).
 626
 627%!  default_module(+Me, -Super) is multi.
 628%
 629%   Is true if `Super' is `Me' or a super (auto import) module of `Me'.
 630
 631default_module(Me, Super) :-
 632    (   atom(Me)
 633    ->  (   var(Super)
 634        ->  '$default_module'(Me, Super)
 635        ;   '$default_module'(Me, Super), !
 636        )
 637    ;   '$type_error'(module, Me)
 638    ).
 639
 640'$default_module'(Me, Me).
 641'$default_module'(Me, Super) :-
 642    import_module(Me, S),
 643    '$default_module'(S, Super).
 644
 645
 646                /********************************
 647                *      TRACE AND EXCEPTIONS     *
 648                *********************************/
 649
 650:- user:dynamic((exception/3,
 651                 prolog_event_hook/1)).
 652:- user:multifile((exception/3,
 653                   prolog_event_hook/1)).
 654
 655%!  '$undefined_procedure'(+Module, +Name, +Arity, -Action) is det.
 656%
 657%   This predicate is called from C   on undefined predicates. First
 658%   allows the user to take care of   it using exception/3. Else try
 659%   to give a DWIM warning. Otherwise fail.   C  will print an error
 660%   message.
 661
 662:- public
 663    '$undefined_procedure'/4.
 664
 665'$undefined_procedure'(Module, Name, Arity, Action) :-
 666    '$prefix_module'(Module, user, Name/Arity, Pred),
 667    user:exception(undefined_predicate, Pred, Action0),
 668    !,
 669    Action = Action0.
 670'$undefined_procedure'(Module, Name, Arity, Action) :-
 671    current_prolog_flag(autoload, true),
 672    '$autoload'(Module, Name, Arity),
 673    !,
 674    Action = retry.
 675'$undefined_procedure'(_, _, _, error).
 676
 677'$autoload'(Module, Name, Arity) :-
 678    source_location(File, _Line),
 679    !,
 680    setup_call_cleanup(
 681        '$start_aux'(File, Context),
 682        '$autoload2'(Module, Name, Arity),
 683        '$end_aux'(File, Context)).
 684'$autoload'(Module, Name, Arity) :-
 685    '$autoload2'(Module, Name, Arity).
 686
 687'$autoload2'(Module, Name, Arity) :-
 688    '$find_library'(Module, Name, Arity, LoadModule, Library),
 689    functor(Head, Name, Arity),
 690    '$update_autoload_level'([autoload(true)], Old),
 691    (   current_prolog_flag(verbose_autoload, true)
 692    ->  Level = informational
 693    ;   Level = silent
 694    ),
 695    print_message(Level, autoload(Module:Name/Arity, Library)),
 696    '$compilation_mode'(OldComp, database),
 697    (   Module == LoadModule
 698    ->  ensure_loaded(Module:Library)
 699    ;   (   '$get_predicate_attribute'(LoadModule:Head, defined, 1),
 700            \+ '$loading'(Library)
 701        ->  Module:import(LoadModule:Name/Arity)
 702        ;   use_module(Module:Library, [Name/Arity])
 703        )
 704    ),
 705    '$set_compilation_mode'(OldComp),
 706    '$set_autoload_level'(Old),
 707    '$c_current_predicate'(_, Module:Head).
 708
 709%!  '$loading'(+Library)
 710%
 711%   True if the library  is  being   loaded.  Just  testing that the
 712%   predicate is defined is not  good  enough   as  the  file may be
 713%   partly  loaded.  Calling  use_module/2  at   any  time  has  two
 714%   drawbacks: it queries the filesystem,   causing  slowdown and it
 715%   stops libraries being autoloaded from a   saved  state where the
 716%   library is already loaded, but the source may not be accessible.
 717
 718'$loading'(Library) :-
 719    current_prolog_flag(threads, true),
 720    '$loading_file'(FullFile, _Queue, _LoadThread),
 721    file_name_extension(Library, _, FullFile),
 722    !.
 723
 724%        handle debugger 'w', 'p' and <N> depth options.
 725
 726'$set_debugger_write_options'(write) :-
 727    !,
 728    create_prolog_flag(debugger_write_options,
 729                       [ quoted(true),
 730                         attributes(dots),
 731                         spacing(next_argument)
 732                       ], []).
 733'$set_debugger_write_options'(print) :-
 734    !,
 735    create_prolog_flag(debugger_write_options,
 736                       [ quoted(true),
 737                         portray(true),
 738                         max_depth(10),
 739                         attributes(portray),
 740                         spacing(next_argument)
 741                       ], []).
 742'$set_debugger_write_options'(Depth) :-
 743    current_prolog_flag(debugger_write_options, Options0),
 744    (   '$select'(max_depth(_), Options0, Options)
 745    ->  true
 746    ;   Options = Options0
 747    ),
 748    create_prolog_flag(debugger_write_options,
 749                       [max_depth(Depth)|Options], []).
 750
 751
 752                /********************************
 753                *        SYSTEM MESSAGES        *
 754                *********************************/
 755
 756%!  '$confirm'(Spec)
 757%
 758%   Ask the user to confirm a question.  Spec is a term as used for
 759%   print_message/2.
 760
 761'$confirm'(Spec) :-
 762    print_message(query, Spec),
 763    between(0, 5, _),
 764        get_single_char(Answer),
 765        (   '$in_reply'(Answer, 'yYjJ \n')
 766        ->  !,
 767            print_message(query, if_tty([yes-[]]))
 768        ;   '$in_reply'(Answer, 'nN')
 769        ->  !,
 770            print_message(query, if_tty([no-[]])),
 771            fail
 772        ;   print_message(help, query(confirm)),
 773            fail
 774        ).
 775
 776'$in_reply'(Code, Atom) :-
 777    char_code(Char, Code),
 778    sub_atom(Atom, _, _, _, Char),
 779    !.
 780
 781:- dynamic
 782    user:portray/1.
 783:- multifile
 784    user:portray/1.
 785
 786
 787                 /*******************************
 788                 *       FILE_SEARCH_PATH       *
 789                 *******************************/
 790
 791:- dynamic user:file_search_path/2.
 792:- multifile user:file_search_path/2.
 793
 794user:(file_search_path(library, Dir) :-
 795        library_directory(Dir)).
 796user:file_search_path(swi, Home) :-
 797    current_prolog_flag(home, Home).
 798user:file_search_path(foreign, swi(ArchLib)) :-
 799    current_prolog_flag(arch, Arch),
 800    atom_concat('lib/', Arch, ArchLib).
 801user:file_search_path(foreign, swi(SoLib)) :-
 802    (   current_prolog_flag(windows, true)
 803    ->  SoLib = bin
 804    ;   SoLib = lib
 805    ).
 806user:file_search_path(path, Dir) :-
 807    getenv('PATH', Path),
 808    (   current_prolog_flag(windows, true)
 809    ->  atomic_list_concat(Dirs, (;), Path)
 810    ;   atomic_list_concat(Dirs, :, Path)
 811    ),
 812    '$member'(Dir, Dirs),
 813    '$no-null-bytes'(Dir).
 814
 815'$no-null-bytes'(Dir) :-
 816    sub_atom(Dir, _, _, _, '\u0000'),
 817    !,
 818    print_message(warning, null_byte_in_path(Dir)),
 819    fail.
 820'$no-null-bytes'(_).
 821
 822%!  expand_file_search_path(+Spec, -Expanded) is nondet.
 823%
 824%   Expand a search path.  The system uses depth-first search upto a
 825%   specified depth.  If this depth is exceeded an exception is raised.
 826%   TBD: bread-first search?
 827
 828expand_file_search_path(Spec, Expanded) :-
 829    catch('$expand_file_search_path'(Spec, Expanded, 0, []),
 830          loop(Used),
 831          throw(error(loop_error(Spec), file_search(Used)))).
 832
 833'$expand_file_search_path'(Spec, Expanded, N, Used) :-
 834    functor(Spec, Alias, 1),
 835    !,
 836    user:file_search_path(Alias, Exp0),
 837    NN is N + 1,
 838    (   NN > 16
 839    ->  throw(loop(Used))
 840    ;   true
 841    ),
 842    '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
 843    arg(1, Spec, Segments),
 844    '$segments_to_atom'(Segments, File),
 845    '$make_path'(Exp1, File, Expanded).
 846'$expand_file_search_path'(Spec, Path, _, _) :-
 847    '$segments_to_atom'(Spec, Path).
 848
 849'$make_path'(Dir, File, Path) :-
 850    atom_concat(_, /, Dir),
 851    !,
 852    atom_concat(Dir, File, Path).
 853'$make_path'(Dir, File, Path) :-
 854    atomic_list_concat([Dir, /, File], Path).
 855
 856
 857                /********************************
 858                *         FILE CHECKING         *
 859                *********************************/
 860
 861%!  absolute_file_name(+Term, -AbsoluteFile, +Options) is nondet.
 862%
 863%   Translate path-specifier into a full   path-name. This predicate
 864%   originates from Quintus was introduced  in SWI-Prolog very early
 865%   and  has  re-appeared  in  SICStus  3.9.0,  where  they  changed
 866%   argument order and added some options.   We addopted the SICStus
 867%   argument order, but still accept the original argument order for
 868%   compatibility reasons.
 869
 870absolute_file_name(Spec, Options, Path) :-
 871    '$is_options'(Options),
 872    \+ '$is_options'(Path),
 873    !,
 874    absolute_file_name(Spec, Path, Options).
 875absolute_file_name(Spec, Path, Options) :-
 876    '$must_be'(options, Options),
 877                    % get the valid extensions
 878    (   '$select_option'(extensions(Exts), Options, Options1)
 879    ->  '$must_be'(list, Exts)
 880    ;   '$option'(file_type(Type), Options)
 881    ->  '$must_be'(atom, Type),
 882        '$file_type_extensions'(Type, Exts),
 883        Options1 = Options
 884    ;   Options1 = Options,
 885        Exts = ['']
 886    ),
 887    '$canonicalise_extensions'(Exts, Extensions),
 888                    % unless specified otherwise, ask regular file
 889    (   nonvar(Type)
 890    ->  Options2 = Options1
 891    ;   '$merge_options'(_{file_type:regular}, Options1, Options2)
 892    ),
 893                    % Det or nondet?
 894    (   '$select_option'(solutions(Sols), Options2, Options3)
 895    ->  '$must_be'(oneof(atom, solutions, [first,all]), Sols)
 896    ;   Sols = first,
 897        Options3 = Options2
 898    ),
 899                    % Errors or not?
 900    (   '$select_option'(file_errors(FileErrors), Options3, Options4)
 901    ->  '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
 902    ;   FileErrors = error,
 903        Options4 = Options3
 904    ),
 905                    % Expand shell patterns?
 906    (   atomic(Spec),
 907        '$select_option'(expand(Expand), Options4, Options5),
 908        '$must_be'(boolean, Expand)
 909    ->  expand_file_name(Spec, List),
 910        '$member'(Spec1, List)
 911    ;   Spec1 = Spec,
 912        Options5 = Options4
 913    ),
 914                    % Search for files
 915    (   Sols == first
 916    ->  (   '$chk_file'(Spec1, Extensions, Options5, true, Path)
 917        ->  true
 918        ;   (   FileErrors == fail
 919            ->  fail
 920            ;   findall(P,
 921                        '$chk_file'(Spec1, Extensions, [access(exist)],
 922                                    false, P),
 923                        Candidates),
 924                '$abs_file_error'(Spec, Candidates, Options5)
 925            )
 926        )
 927    ;   '$chk_file'(Spec1, Extensions, Options5, false, Path)
 928    ).
 929
 930'$abs_file_error'(Spec, Candidates, Conditions) :-
 931    '$member'(F, Candidates),
 932    '$member'(C, Conditions),
 933    '$file_condition'(C),
 934    '$file_error'(C, Spec, F, E, Comment),
 935    !,
 936    throw(error(E, context(_, Comment))).
 937'$abs_file_error'(Spec, _, _) :-
 938    '$existence_error'(source_sink, Spec).
 939
 940'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
 941    \+ exists_directory(File),
 942    !,
 943    Error = existence_error(directory, Spec),
 944    Comment = not_a_directory(File).
 945'$file_error'(file_type(_), Spec, File, Error, Comment) :-
 946    exists_directory(File),
 947    !,
 948    Error = existence_error(file, Spec),
 949    Comment = directory(File).
 950'$file_error'(access(OneOrList), Spec, File, Error, _) :-
 951    '$one_or_member'(Access, OneOrList),
 952    \+ access_file(File, Access),
 953    Error = permission_error(Access, source_sink, Spec).
 954
 955'$one_or_member'(Elem, List) :-
 956    is_list(List),
 957    !,
 958    '$member'(Elem, List).
 959'$one_or_member'(Elem, Elem).
 960
 961
 962'$file_type_extensions'(source, Exts) :-       % SICStus 3.9 compatibility
 963    !,
 964    '$file_type_extensions'(prolog, Exts).
 965'$file_type_extensions'(Type, Exts) :-
 966    '$current_module'('$bags', _File),
 967    !,
 968    findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
 969    (   Exts0 == [],
 970        \+ '$ft_no_ext'(Type)
 971    ->  '$domain_error'(file_type, Type)
 972    ;   true
 973    ),
 974    '$append'(Exts0, [''], Exts).
 975'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ...
 976
 977'$ft_no_ext'(txt).
 978'$ft_no_ext'(executable).
 979'$ft_no_ext'(directory).
 980
 981%!  user:prolog_file_type(?Extension, ?Type)
 982%
 983%   Define type of file based on the extension.  This is used by
 984%   absolute_file_name/3 and may be used to extend the list of
 985%   extensions used for some type.
 986%
 987%   Note that =qlf= must be last   when  searching for Prolog files.
 988%   Otherwise use_module/1 will consider  the   file  as  not-loaded
 989%   because the .qlf file is not  the   loaded  file.  Must be fixed
 990%   elsewhere.
 991
 992:- multifile(user:prolog_file_type/2).
 993:- dynamic(user:prolog_file_type/2).
 994
 995user:prolog_file_type(pl,       prolog).
 996user:prolog_file_type(prolog,   prolog).
 997user:prolog_file_type(qlf,      prolog).
 998user:prolog_file_type(qlf,      qlf).
 999user:prolog_file_type(Ext,      executable) :-
1000    current_prolog_flag(shared_object_extension, Ext).
1001
1002%!  '$chk_file'(+Spec, +Extensions, +Cond, +UseCache, -FullName)
1003%
1004%   File is a specification of a Prolog source file. Return the full
1005%   path of the file.
1006
1007'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
1008    \+ ground(Spec),
1009    !,
1010    '$instantiation_error'(Spec).
1011'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
1012    compound(Spec),
1013    functor(Spec, _, 1),
1014    !,
1015    '$relative_to'(Cond, cwd, CWD),
1016    '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
1017'$chk_file'(Segments, Ext, Cond, Cache, FullName) :-    % allow a/b/...
1018    \+ atomic(Segments),
1019    !,
1020    '$segments_to_atom'(Segments, Atom),
1021    '$chk_file'(Atom, Ext, Cond, Cache, FullName).
1022'$chk_file'(File, Exts, Cond, _, FullName) :-
1023    is_absolute_file_name(File),
1024    !,
1025    '$extend_file'(File, Exts, Extended),
1026    '$file_conditions'(Cond, Extended),
1027    '$absolute_file_name'(Extended, FullName).
1028'$chk_file'(File, Exts, Cond, _, FullName) :-
1029    '$relative_to'(Cond, source, Dir),
1030    atomic_list_concat([Dir, /, File], AbsFile),
1031    '$extend_file'(AbsFile, Exts, Extended),
1032    '$file_conditions'(Cond, Extended),
1033    !,
1034    '$absolute_file_name'(Extended, FullName).
1035'$chk_file'(File, Exts, Cond, _, FullName) :-
1036    '$extend_file'(File, Exts, Extended),
1037    '$file_conditions'(Cond, Extended),
1038    '$absolute_file_name'(Extended, FullName).
1039
1040'$segments_to_atom'(Atom, Atom) :-
1041    atomic(Atom),
1042    !.
1043'$segments_to_atom'(Segments, Atom) :-
1044    '$segments_to_list'(Segments, List, []),
1045    !,
1046    atomic_list_concat(List, /, Atom).
1047
1048'$segments_to_list'(A/B, H, T) :-
1049    '$segments_to_list'(A, H, T0),
1050    '$segments_to_list'(B, T0, T).
1051'$segments_to_list'(A, [A|T], T) :-
1052    atomic(A).
1053
1054
1055%!  '$relative_to'(+Condition, +Default, -Dir)
1056%
1057%   Determine the directory to work from.  This can be specified
1058%   explicitely using one or more relative_to(FileOrDir) options
1059%   or implicitely relative to the working directory or current
1060%   source-file.
1061
1062'$relative_to'(Conditions, Default, Dir) :-
1063    (   '$option'(relative_to(FileOrDir), Conditions)
1064    *-> (   exists_directory(FileOrDir)
1065        ->  Dir = FileOrDir
1066        ;   atom_concat(Dir, /, FileOrDir)
1067        ->  true
1068        ;   file_directory_name(FileOrDir, Dir)
1069        )
1070    ;   Default == cwd
1071    ->  '$cwd'(Dir)
1072    ;   Default == source
1073    ->  source_location(ContextFile, _Line),
1074        file_directory_name(ContextFile, Dir)
1075    ).
1076
1077%!  '$chk_alias_file'(+Spec, +Exts, +Cond, +Cache, +CWD,
1078%!                    -FullFile) is nondet.
1079
1080:- dynamic
1081    '$search_path_file_cache'/3,    % SHA1, Time, Path
1082    '$search_path_gc_time'/1.       % Time
1083:- volatile
1084    '$search_path_file_cache'/3,
1085    '$search_path_gc_time'/1.
1086
1087:- create_prolog_flag(file_search_cache_time, 10, []).
1088
1089'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
1090    !,
1091    findall(Exp, expand_file_search_path(Spec, Exp), Expansions),
1092    Cache = cache(Exts, Cond, CWD, Expansions),
1093    variant_sha1(Spec+Cache, SHA1),
1094    get_time(Now),
1095    current_prolog_flag(file_search_cache_time, TimeOut),
1096    (   '$search_path_file_cache'(SHA1, CachedTime, FullFile),
1097        CachedTime > Now - TimeOut,
1098        '$file_conditions'(Cond, FullFile)
1099    ->  '$search_message'(file_search(cache(Spec, Cond), FullFile))
1100    ;   '$member'(Expanded, Expansions),
1101        '$extend_file'(Expanded, Exts, LibFile),
1102        (   '$file_conditions'(Cond, LibFile),
1103            '$absolute_file_name'(LibFile, FullFile),
1104            '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
1105        ->  '$search_message'(file_search(found(Spec, Cond), FullFile))
1106        ;   '$search_message'(file_search(tried(Spec, Cond), LibFile)),
1107            fail
1108        )
1109    ).
1110'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
1111    expand_file_search_path(Spec, Expanded),
1112    '$extend_file'(Expanded, Exts, LibFile),
1113    '$file_conditions'(Cond, LibFile),
1114    '$absolute_file_name'(LibFile, FullFile).
1115
1116'$cache_file_found'(_, _, TimeOut, _) :-
1117    TimeOut =:= 0,
1118    !.
1119'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1120    '$search_path_file_cache'(SHA1, Saved, FullFile),
1121    !,
1122    (   Now - Saved < TimeOut/2
1123    ->  true
1124    ;   retractall('$search_path_file_cache'(SHA1, _, _)),
1125        asserta('$search_path_file_cache'(SHA1, Now, FullFile))
1126    ).
1127'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1128    'gc_file_search_cache'(TimeOut),
1129    asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
1130
1131'gc_file_search_cache'(TimeOut) :-
1132    get_time(Now),
1133    '$search_path_gc_time'(Last),
1134    Now-Last < TimeOut/2,
1135    !.
1136'gc_file_search_cache'(TimeOut) :-
1137    get_time(Now),
1138    retractall('$search_path_gc_time'(_)),
1139    assertz('$search_path_gc_time'(Now)),
1140    Before is Now - TimeOut,
1141    (   '$search_path_file_cache'(SHA1, Cached, FullFile),
1142        Cached < Before,
1143        retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
1144        fail
1145    ;   true
1146    ).
1147
1148
1149'$search_message'(Term) :-
1150    current_prolog_flag(verbose_file_search, true),
1151    !,
1152    print_message(informational, Term).
1153'$search_message'(_).
1154
1155
1156%!  '$file_conditions'(+Condition, +Path)
1157%
1158%   Verify Path satisfies Condition.
1159
1160'$file_conditions'(List, File) :-
1161    is_list(List),
1162    !,
1163    \+ ( '$member'(C, List),
1164         '$file_condition'(C),
1165         \+ '$file_condition'(C, File)
1166       ).
1167'$file_conditions'(Map, File) :-
1168    \+ (  get_dict(Key, Map, Value),
1169          C =.. [Key,Value],
1170          '$file_condition'(C),
1171         \+ '$file_condition'(C, File)
1172       ).
1173
1174'$file_condition'(file_type(directory), File) :-
1175    !,
1176    exists_directory(File).
1177'$file_condition'(file_type(_), File) :-
1178    !,
1179    \+ exists_directory(File).
1180'$file_condition'(access(Accesses), File) :-
1181    !,
1182    \+ (  '$one_or_member'(Access, Accesses),
1183          \+ access_file(File, Access)
1184       ).
1185
1186'$file_condition'(exists).
1187'$file_condition'(file_type(_)).
1188'$file_condition'(access(_)).
1189
1190'$extend_file'(File, Exts, FileEx) :-
1191    '$ensure_extensions'(Exts, File, Fs),
1192    '$list_to_set'(Fs, FsSet),
1193    '$member'(FileEx, FsSet).
1194
1195'$ensure_extensions'([], _, []).
1196'$ensure_extensions'([E|E0], F, [FE|E1]) :-
1197    file_name_extension(F, E, FE),
1198    '$ensure_extensions'(E0, F, E1).
1199
1200%!  '$list_to_set'(+List, -Set) is det.
1201%
1202%   Turn list into a set, keeping   the  left-most copy of duplicate
1203%   elements.  Note  that  library(lists)  provides  an  O(N*log(N))
1204%   version, but sets of file name extensions should be short enough
1205%   for this not to matter.
1206
1207'$list_to_set'(List, Set) :-
1208    '$list_to_set'(List, [], Set).
1209
1210'$list_to_set'([], _, []).
1211'$list_to_set'([H|T], Seen, R) :-
1212    memberchk(H, Seen),
1213    !,
1214    '$list_to_set'(T, R).
1215'$list_to_set'([H|T], Seen, [H|R]) :-
1216    '$list_to_set'(T, [H|Seen], R).
1217
1218/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1219Canonicalise the extension list. Old SWI-Prolog   require  `.pl', etc, which
1220the Quintus compatibility  requests  `pl'.   This  layer  canonicalises  all
1221extensions to .ext
1222- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1223
1224'$canonicalise_extensions'([], []) :- !.
1225'$canonicalise_extensions'([H|T], [CH|CT]) :-
1226    !,
1227    '$must_be'(atom, H),
1228    '$canonicalise_extension'(H, CH),
1229    '$canonicalise_extensions'(T, CT).
1230'$canonicalise_extensions'(E, [CE]) :-
1231    '$canonicalise_extension'(E, CE).
1232
1233'$canonicalise_extension'('', '') :- !.
1234'$canonicalise_extension'(DotAtom, DotAtom) :-
1235    sub_atom(DotAtom, 0, _, _, '.'),
1236    !.
1237'$canonicalise_extension'(Atom, DotAtom) :-
1238    atom_concat('.', Atom, DotAtom).
1239
1240
1241                /********************************
1242                *            CONSULT            *
1243                *********************************/
1244
1245:- dynamic
1246    user:library_directory/1,
1247    user:prolog_load_file/2.
1248:- multifile
1249    user:library_directory/1,
1250    user:prolog_load_file/2.
1251
1252:- prompt(_, '|: ').
1253
1254:- thread_local
1255    '$compilation_mode_store'/1,    % database, wic, qlf
1256    '$directive_mode_store'/1.      % database, wic, qlf
1257:- volatile
1258    '$compilation_mode_store'/1,
1259    '$directive_mode_store'/1.
1260
1261'$compilation_mode'(Mode) :-
1262    (   '$compilation_mode_store'(Val)
1263    ->  Mode = Val
1264    ;   Mode = database
1265    ).
1266
1267'$set_compilation_mode'(Mode) :-
1268    retractall('$compilation_mode_store'(_)),
1269    assertz('$compilation_mode_store'(Mode)).
1270
1271'$compilation_mode'(Old, New) :-
1272    '$compilation_mode'(Old),
1273    (   New == Old
1274    ->  true
1275    ;   '$set_compilation_mode'(New)
1276    ).
1277
1278'$directive_mode'(Mode) :-
1279    (   '$directive_mode_store'(Val)
1280    ->  Mode = Val
1281    ;   Mode = database
1282    ).
1283
1284'$directive_mode'(Old, New) :-
1285    '$directive_mode'(Old),
1286    (   New == Old
1287    ->  true
1288    ;   '$set_directive_mode'(New)
1289    ).
1290
1291'$set_directive_mode'(Mode) :-
1292    retractall('$directive_mode_store'(_)),
1293    assertz('$directive_mode_store'(Mode)).
1294
1295
1296%!  '$compilation_level'(-Level) is det.
1297%
1298%   True when Level reflects the nesting   in  files compiling other
1299%   files. 0 if no files are being loaded.
1300
1301'$compilation_level'(Level) :-
1302    '$input_context'(Stack),
1303    '$compilation_level'(Stack, Level).
1304
1305'$compilation_level'([], 0).
1306'$compilation_level'([Input|T], Level) :-
1307    (   arg(1, Input, see)
1308    ->  '$compilation_level'(T, Level)
1309    ;   '$compilation_level'(T, Level0),
1310        Level is Level0+1
1311    ).
1312
1313
1314%!  compiling
1315%
1316%   Is true if SWI-Prolog is generating a state or qlf file or
1317%   executes a `call' directive while doing this.
1318
1319compiling :-
1320    \+ (   '$compilation_mode'(database),
1321           '$directive_mode'(database)
1322       ).
1323
1324:- meta_predicate
1325    '$ifcompiling'(0).
1326
1327'$ifcompiling'(G) :-
1328    (   '$compilation_mode'(database)
1329    ->  true
1330    ;   call(G)
1331    ).
1332
1333                /********************************
1334                *         READ SOURCE           *
1335                *********************************/
1336
1337%!  '$load_msg_level'(+Action, +NestingLevel, -StartVerbose, -EndVerbose)
1338
1339'$load_msg_level'(Action, Nesting, Start, Done) :-
1340    '$update_autoload_level'([], 0),
1341    !,
1342    current_prolog_flag(verbose_load, Type0),
1343    '$load_msg_compat'(Type0, Type),
1344    (   '$load_msg_level'(Action, Nesting, Type, Start, Done)
1345    ->  true
1346    ).
1347'$load_msg_level'(_, _, silent, silent).
1348
1349'$load_msg_compat'(true, normal) :- !.
1350'$load_msg_compat'(false, silent) :- !.
1351'$load_msg_compat'(X, X).
1352
1353'$load_msg_level'(load_file,    _, full,   informational, informational).
1354'$load_msg_level'(include_file, _, full,   informational, informational).
1355'$load_msg_level'(load_file,    _, normal, silent,        informational).
1356'$load_msg_level'(include_file, _, normal, silent,        silent).
1357'$load_msg_level'(load_file,    0, brief,  silent,        informational).
1358'$load_msg_level'(load_file,    _, brief,  silent,        silent).
1359'$load_msg_level'(include_file, _, brief,  silent,        silent).
1360'$load_msg_level'(load_file,    _, silent, silent,        silent).
1361'$load_msg_level'(include_file, _, silent, silent,        silent).
1362
1363%!  '$source_term'(+From, -Read, -RLayout, -Term, -TLayout,
1364%!                 -Stream, +Options) is nondet.
1365%
1366%   Read Prolog terms from the  input   From.  Terms are returned on
1367%   backtracking. Associated resources (i.e.,   streams)  are closed
1368%   due to setup_call_cleanup/3.
1369%
1370%   @param From is either a term stream(Id, Stream) or a file
1371%          specification.
1372%   @param Read is the raw term as read from the input.
1373%   @param Term is the term after term-expansion.  If a term is
1374%          expanded into the empty list, this is returned too.  This
1375%          is required to be able to return the raw term in Read
1376%   @param Stream is the stream from which Read is read
1377%   @param Options provides additional options:
1378%           * encoding(Enc)
1379%           Encoding used to open From
1380%           * syntax_errors(+ErrorMode)
1381%           * process_comments(+Boolean)
1382%           * term_position(-Pos)
1383
1384'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
1385    '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
1386    (   Term == end_of_file
1387    ->  !, fail
1388    ;   true
1389    ).
1390
1391'$source_term'(Input, _,_,_,_,_,_,_) :-
1392    \+ ground(Input),
1393    !,
1394    '$instantiation_error'(Input).
1395'$source_term'(stream(Id, In, Opts),
1396               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1397    !,
1398    '$record_included'(Parents, Id, Id, 0.0, Message),
1399    setup_call_cleanup(
1400        '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
1401        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1402                        [Id|Parents], Options),
1403        '$close_source'(State, Message)).
1404'$source_term'(File,
1405               Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1406    absolute_file_name(File, Path,
1407                       [ file_type(prolog),
1408                         access(read)
1409                       ]),
1410    time_file(Path, Time),
1411    '$record_included'(Parents, File, Path, Time, Message),
1412    setup_call_cleanup(
1413        '$open_source'(Path, In, State, Parents, Options),
1414        '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1415                        [Path|Parents], Options),
1416        '$close_source'(State, Message)).
1417
1418:- thread_local
1419    '$load_input'/2.
1420:- volatile
1421    '$load_input'/2.
1422
1423'$open_source'(stream(Id, In, Opts), In,
1424               restore(In, StreamState, Id, Ref, Opts), Parents, Options) :-
1425    !,
1426    '$context_type'(Parents, ContextType),
1427    '$push_input_context'(ContextType),
1428    '$set_encoding'(In, Options),
1429    '$prepare_load_stream'(In, Id, StreamState),
1430    asserta('$load_input'(stream(Id), In), Ref).
1431'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
1432    '$context_type'(Parents, ContextType),
1433    '$push_input_context'(ContextType),
1434    open(Path, read, In),
1435    '$set_encoding'(In, Options),
1436    asserta('$load_input'(Path, In), Ref).
1437
1438'$context_type'([], load_file) :- !.
1439'$context_type'(_, include).
1440
1441'$close_source'(close(In, Id, Ref), Message) :-
1442    erase(Ref),
1443    '$end_consult'(Id),
1444    call_cleanup(
1445        close(In),
1446        '$pop_input_context'),
1447    '$close_message'(Message).
1448'$close_source'(restore(In, StreamState, Id, Ref, Opts), Message) :-
1449    erase(Ref),
1450    '$end_consult'(Id),
1451    call_cleanup(
1452        '$restore_load_stream'(In, StreamState, Opts),
1453        '$pop_input_context'),
1454    '$close_message'(Message).
1455
1456'$close_message'(message(Level, Msg)) :-
1457    !,
1458    '$print_message'(Level, Msg).
1459'$close_message'(_).
1460
1461
1462%!  '$term_in_file'(+In, -Read, -RLayout, -Term, -TLayout,
1463%!                  -Stream, +Parents, +Options) is multi.
1464%
1465%   True when Term is an expanded term from   In. Read is a raw term
1466%   (before term-expansion). Stream is  the   actual  stream,  which
1467%   starts at In, but may change due to processing included files.
1468%
1469%   @see '$source_term'/8 for details.
1470
1471'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1472    '$skip_script_line'(In),
1473    '$read_clause_options'(Options, ReadOptions),
1474    repeat,
1475      read_clause(In, Raw,
1476                  [ variable_names(Bindings),
1477                    term_position(Pos),
1478                    subterm_positions(RawLayout)
1479                  | ReadOptions
1480                  ]),
1481      b_setval('$term_position', Pos),
1482      b_setval('$variable_names', Bindings),
1483      (   Raw == end_of_file
1484      ->  !,
1485          (   Parents = [_,_|_]     % Included file
1486          ->  fail
1487          ;   '$expanded_term'(In,
1488                               Raw, RawLayout, Read, RLayout, Term, TLayout,
1489                               Stream, Parents, Options)
1490          )
1491      ;   '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1492                           Stream, Parents, Options)
1493      ).
1494
1495'$read_clause_options'([], []).
1496'$read_clause_options'([H|T0], List) :-
1497    (   '$read_clause_option'(H)
1498    ->  List = [H|T]
1499    ;   List = T
1500    ),
1501    '$read_clause_options'(T0, T).
1502
1503'$read_clause_option'(syntax_errors(_)).
1504'$read_clause_option'(term_position(_)).
1505'$read_clause_option'(process_comment(_)).
1506
1507'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1508                 Stream, Parents, Options) :-
1509    catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
1510          '$print_message_fail'(E)),
1511    (   Expanded \== []
1512    ->  '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
1513    ;   Term1 = Expanded,
1514        Layout1 = ExpandedLayout
1515    ),
1516    (   nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
1517    ->  (   Directive = include(File),
1518            '$current_source_module'(Module),
1519            '$valid_directive'(Module:include(File))
1520        ->  stream_property(In, encoding(Enc)),
1521            '$add_encoding'(Enc, Options, Options1),
1522            '$source_term'(File, Read, RLayout, Term, TLayout,
1523                           Stream, Parents, Options1)
1524        ;   Directive = encoding(Enc)
1525        ->  set_stream(In, encoding(Enc)),
1526            fail
1527        ;   Term = Term1,
1528            Stream = In,
1529            Read = Raw
1530        )
1531    ;   Term = Term1,
1532        TLayout = Layout1,
1533        Stream = In,
1534        Read = Raw,
1535        RLayout = RawLayout
1536    ).
1537
1538'$expansion_member'(Var, Layout, Var, Layout) :-
1539    var(Var),
1540    !.
1541'$expansion_member'([], _, _, _) :- !, fail.
1542'$expansion_member'(List, ListLayout, Term, Layout) :-
1543    is_list(List),
1544    !,
1545    (   var(ListLayout)
1546    ->  '$member'(Term, List)
1547    ;   is_list(ListLayout)
1548    ->  '$member_rep2'(Term, Layout, List, ListLayout)
1549    ;   Layout = ListLayout,
1550        '$member'(Term, List)
1551    ).
1552'$expansion_member'(X, Layout, X, Layout).
1553
1554% pairwise member, repeating last element of the second
1555% list.
1556
1557'$member_rep2'(H1, H2, [H1|_], [H2|_]).
1558'$member_rep2'(H1, H2, [_|T1], [T2]) :-
1559    !,
1560    '$member_rep2'(H1, H2, T1, [T2]).
1561'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
1562    '$member_rep2'(H1, H2, T1, T2).
1563
1564%!  '$add_encoding'(+Enc, +Options0, -Options)
1565
1566'$add_encoding'(Enc, Options0, Options) :-
1567    (   Options0 = [encoding(Enc)|_]
1568    ->  Options = Options0
1569    ;   Options = [encoding(Enc)|Options0]
1570    ).
1571
1572
1573:- multifile
1574    '$included'/4.                  % Into, Line, File, LastModified
1575:- dynamic
1576    '$included'/4.
1577
1578%!  '$record_included'(+Parents, +File, +Path, +Time, -Message) is det.
1579%
1580%   Record that we included File into the   head of Parents. This is
1581%   troublesome when creating a QLF  file   because  this may happen
1582%   before we opened the QLF file (and  we   do  not yet know how to
1583%   open the file because we  do  not   yet  know  whether this is a
1584%   module file or not).
1585%
1586%   I think that the only sensible  solution   is  to have a special
1587%   statement for this, that may appear  both inside and outside QLF
1588%   `parts'.
1589
1590'$record_included'([Parent|Parents], File, Path, Time,
1591                   message(DoneMsgLevel,
1592                           include_file(done(Level, file(File, Path))))) :-
1593    source_location(SrcFile, Line),
1594    !,
1595    '$compilation_level'(Level),
1596    '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
1597    '$print_message'(StartMsgLevel,
1598                     include_file(start(Level,
1599                                        file(File, Path)))),
1600    '$last'([Parent|Parents], Owner),
1601    (   (   '$compilation_mode'(database)
1602        ;   '$qlf_current_source'(Owner)
1603        )
1604    ->  '$store_admin_clause'(
1605            system:'$included'(Parent, Line, Path, Time),
1606            _, Owner, SrcFile:Line)
1607    ;   '$qlf_include'(Owner, Parent, Line, Path, Time)
1608    ).
1609'$record_included'(_, _, _, _, true).
1610
1611%!  '$master_file'(+File, -MasterFile)
1612%
1613%   Find the primary load file from included files.
1614
1615'$master_file'(File, MasterFile) :-
1616    '$included'(MasterFile0, _Line, File, _Time),
1617    !,
1618    '$master_file'(MasterFile0, MasterFile).
1619'$master_file'(File, File).
1620
1621
1622'$skip_script_line'(In) :-
1623    (   peek_char(In, #)
1624    ->  skip(In, 10)
1625    ;   true
1626    ).
1627
1628'$set_encoding'(Stream, Options) :-
1629    '$option'(encoding(Enc), Options),
1630    !,
1631    Enc \== default,
1632    set_stream(Stream, encoding(Enc)).
1633'$set_encoding'(_, _).
1634
1635
1636'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
1637    (   stream_property(In, file_name(_))
1638    ->  HasName = true,
1639        (   stream_property(In, position(_))
1640        ->  HasPos = true
1641        ;   HasPos = false,
1642            set_stream(In, record_position(true))
1643        )
1644    ;   HasName = false,
1645        set_stream(In, file_name(Id)),
1646        (   stream_property(In, position(_))
1647        ->  HasPos = true
1648        ;   HasPos = false,
1649            set_stream(In, record_position(true))
1650        )
1651    ).
1652
1653'$restore_load_stream'(In, _State, Options) :-
1654    memberchk(close(true), Options),
1655    !,
1656    close(In).
1657'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
1658    (   HasName == false
1659    ->  set_stream(In, file_name(''))
1660    ;   true
1661    ),
1662    (   HasPos == false
1663    ->  set_stream(In, record_position(false))
1664    ;   true
1665    ).
1666
1667
1668                 /*******************************
1669                 *          DERIVED FILES       *
1670                 *******************************/
1671
1672:- dynamic
1673    '$derived_source_db'/3.         % Loaded, DerivedFrom, Time
1674
1675'$register_derived_source'(_, '-') :- !.
1676'$register_derived_source'(Loaded, DerivedFrom) :-
1677    retractall('$derived_source_db'(Loaded, _, _)),
1678    time_file(DerivedFrom, Time),
1679    assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
1680
1681%       Auto-importing dynamic predicates is not very elegant and
1682%       leads to problems with qsave_program/[1,2]
1683
1684'$derived_source'(Loaded, DerivedFrom, Time) :-
1685    '$derived_source_db'(Loaded, DerivedFrom, Time).
1686
1687
1688                /********************************
1689                *       LOAD PREDICATES         *
1690                *********************************/
1691
1692:- meta_predicate
1693    ensure_loaded(:),
1694    [:|+],
1695    consult(:),
1696    use_module(:),
1697    use_module(:, +),
1698    reexport(:),
1699    reexport(:, +),
1700    load_files(:),
1701    load_files(:, +).
1702
1703%!  ensure_loaded(+FileOrListOfFiles)
1704%
1705%   Load specified files, provided they where not loaded before. If the
1706%   file is a module file import the public predicates into the context
1707%   module.
1708
1709ensure_loaded(Files) :-
1710    load_files(Files, [if(not_loaded)]).
1711
1712%!  use_module(+FileOrListOfFiles)
1713%
1714%   Very similar to ensure_loaded/1, but insists on the loaded file to
1715%   be a module file. If the file is already imported, but the public
1716%   predicates are not yet imported into the context module, then do
1717%   so.
1718
1719use_module(Files) :-
1720    load_files(Files, [ if(not_loaded),
1721                        must_be_module(true)
1722                      ]).
1723
1724%!  use_module(+File, +ImportList)
1725%
1726%   As use_module/1, but takes only one file argument and imports only
1727%   the specified predicates rather than all public predicates.
1728
1729use_module(File, Import) :-
1730    load_files(File, [ if(not_loaded),
1731                       must_be_module(true),
1732                       imports(Import)
1733                     ]).
1734
1735%!  reexport(+Files)
1736%
1737%   As use_module/1, exporting all imported predicates.
1738
1739reexport(Files) :-
1740    load_files(Files, [ if(not_loaded),
1741                        must_be_module(true),
1742                        reexport(true)
1743                      ]).
1744
1745%!  reexport(+File, +ImportList)
1746%
1747%   As use_module/1, re-exporting all imported predicates.
1748
1749reexport(File, Import) :-
1750    load_files(File, [ if(not_loaded),
1751                       must_be_module(true),
1752                       imports(Import),
1753                       reexport(true)
1754                     ]).
1755
1756
1757[X] :-
1758    !,
1759    consult(X).
1760[M:F|R] :-
1761    consult(M:[F|R]).
1762
1763consult(M:X) :-
1764    X == user,
1765    !,
1766    flag('$user_consult', N, N+1),
1767    NN is N + 1,
1768    atom_concat('user://', NN, Id),
1769    load_files(M:Id, [stream(user_input)]).
1770consult(List) :-
1771    load_files(List, [expand(true)]).
1772
1773%!  load_files(:File, +Options)
1774%
1775%   Common entry for all the consult derivates.  File is the raw user
1776%   specified file specification, possibly tagged with the module.
1777
1778load_files(Files) :-
1779    load_files(Files, []).
1780load_files(Module:Files, Options) :-
1781    '$must_be'(list, Options),
1782    '$load_files'(Files, Module, Options).
1783
1784'$load_files'(X, _, _) :-
1785    var(X),
1786    !,
1787    '$instantiation_error'(X).
1788'$load_files'([], _, _) :- !.
1789'$load_files'(Id, Module, Options) :-   % load_files(foo, [stream(In)])
1790    '$option'(stream(_), Options),
1791    !,
1792    (   atom(Id)
1793    ->  '$load_file'(Id, Module, Options)
1794    ;   throw(error(type_error(atom, Id), _))
1795    ).
1796'$load_files'(List, Module, Options) :-
1797    List = [_|_],
1798    !,
1799    '$must_be'(list, List),
1800    '$load_file_list'(List, Module, Options).
1801'$load_files'(File, Module, Options) :-
1802    '$load_one_file'(File, Module, Options).
1803
1804'$load_file_list'([], _, _).
1805'$load_file_list'([File|Rest], Module, Options) :-
1806    catch('$load_one_file'(File, Module, Options), E,
1807          print_message(error, E)),
1808    '$load_file_list'(Rest, Module, Options).
1809
1810
1811'$load_one_file'(Spec, Module, Options) :-
1812    atomic(Spec),
1813    '$option'(expand(Expand), Options, false),
1814    Expand == true,
1815    !,
1816    expand_file_name(Spec, Expanded),
1817    (   Expanded = [Load]
1818    ->  true
1819    ;   Load = Expanded
1820    ),
1821    '$load_files'(Load, Module, [expand(false)|Options]).
1822'$load_one_file'(File, Module, Options) :-
1823    strip_module(Module:File, Into, PlainFile),
1824    '$load_file'(PlainFile, Into, Options).
1825
1826
1827%!  '$noload'(+Condition, +FullFile, +Options) is semidet.
1828%
1829%   True of FullFile should _not_ be loaded.
1830
1831'$noload'(true, _, _) :-
1832    !,
1833    fail.
1834'$noload'(not_loaded, FullFile, _) :-
1835    source_file(FullFile),
1836    !.
1837'$noload'(changed, Derived, _) :-
1838    '$derived_source'(_FullFile, Derived, LoadTime),
1839    time_file(Derived, Modified),
1840    Modified @=< LoadTime,
1841    !.
1842'$noload'(changed, FullFile, Options) :-
1843    '$time_source_file'(FullFile, LoadTime, user),
1844    '$modified_id'(FullFile, Modified, Options),
1845    Modified @=< LoadTime,
1846    !.
1847
1848%!  '$qlf_file'(+Spec, +PlFile, -LoadFile, -Mode, +Options) is det.
1849%
1850%   Return the QLF file if it exists.  Might check for modification
1851%   time, version, etc.
1852%
1853%   If the user-specification specified a prolog file, do not
1854%   replace this with a .qlf file.
1855
1856'$qlf_file'(Spec, _, Spec, stream, Options) :-
1857    '$option'(stream(_), Options),
1858    !.
1859'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
1860    '$spec_extension'(Spec, Ext),
1861    user:prolog_file_type(Ext, prolog),
1862    !.
1863'$qlf_file'(_, FullFile, QlfFile, Mode, Options) :-
1864    '$compilation_mode'(database),
1865    file_name_extension(Base, PlExt, FullFile),
1866    user:prolog_file_type(PlExt, prolog),
1867    user:prolog_file_type(QlfExt, qlf),
1868    file_name_extension(Base, QlfExt, QlfFile),
1869    (   access_file(QlfFile, read),
1870        (   '$qlf_up_to_date'(FullFile, QlfFile)
1871        ->  Mode = qload
1872        ;   access_file(QlfFile, write)
1873        ->  Mode = qcompile
1874        )
1875    ->  !
1876    ;   '$qlf_auto'(FullFile, QlfFile, Options)
1877    ->  !, Mode = qcompile
1878    ).
1879'$qlf_file'(_, FullFile, FullFile, compile, _).
1880
1881
1882%!  '$qlf_up_to_date'(+PlFile, +QlfFile) is semidet.
1883%
1884%   True if the QlfFile file is  considered up-to-date. This implies
1885%   that either the PlFile does not exist or that the QlfFile is not
1886%   older than the PlFile.
1887
1888'$qlf_up_to_date'(PlFile, QlfFile) :-
1889    (   exists_file(PlFile)
1890    ->  time_file(PlFile, PlTime),
1891        time_file(QlfFile, QlfTime),
1892        QlfTime >= PlTime
1893    ;   true
1894    ).
1895
1896%!  '$qlf_auto'(+PlFile, +QlfFile, +Options) is semidet.
1897%
1898%   True if we create QlfFile using   qcompile/2. This is determined
1899%   by the option qcompile(QlfMode) or, if   this is not present, by
1900%   the prolog_flag qcompile.
1901
1902:- create_prolog_flag(qcompile, false, [type(atom)]).
1903
1904'$qlf_auto'(PlFile, QlfFile, Options) :-
1905    (   memberchk(qcompile(QlfMode), Options)
1906    ->  true
1907    ;   current_prolog_flag(qcompile, QlfMode),
1908        \+ '$in_system_dir'(PlFile)
1909    ),
1910    (   QlfMode == auto
1911    ->  true
1912    ;   QlfMode == large,
1913        size_file(PlFile, Size),
1914        Size > 100000
1915    ),
1916    access_file(QlfFile, write).
1917
1918'$in_system_dir'(PlFile) :-
1919    current_prolog_flag(home, Home),
1920    sub_atom(PlFile, 0, _, _, Home).
1921
1922'$spec_extension'(File, Ext) :-
1923    atom(File),
1924    file_name_extension(_, Ext, File).
1925'$spec_extension'(Spec, Ext) :-
1926    compound(Spec),
1927    arg(1, Spec, Arg),
1928    '$spec_extension'(Arg, Ext).
1929
1930
1931%!  '$load_file'(+Spec, +ContextModule, +Options) is det.
1932%
1933%   Load the file Spec  into   ContextModule  controlled by Options.
1934%   This wrapper deals with two cases  before proceeding to the real
1935%   loader:
1936%
1937%       * User hooks based on prolog_load_file/2
1938%       * The file is already loaded.
1939
1940'$load_file'(File, Module, Options) :-
1941    \+ memberchk(stream(_), Options),
1942    user:prolog_load_file(Module:File, Options),
1943    !.
1944'$load_file'(File, Module, Options) :-
1945    memberchk(stream(_), Options),
1946    !,
1947    '$assert_load_context_module'(File, Module, Options),
1948    '$qdo_load_file'(File, File, Module, Action, Options),
1949    '$run_initialization'(File, Action, Options).
1950'$load_file'(File, Module, Options) :-
1951    absolute_file_name(File,
1952                       [ file_type(prolog),
1953                         access(read)
1954                       ],
1955                       FullFile),
1956    '$mt_load_file'(File, FullFile, Module, Options).
1957
1958
1959%!  '$already_loaded'(+File, +FulleFile, +Module, +Options) is det.
1960%
1961%   Called if File is already loaded. If  this is a module-file, the
1962%   module must be imported into the context  Module. If it is not a
1963%   module file, it must be reloaded.
1964%
1965%   @bug    A file may be associated with multiple modules.  How
1966%           do we find the `main export module'?  Currently there
1967%           is no good way to find out which module is associated
1968%           to the file as a result of the first :- module/2 term.
1969
1970'$already_loaded'(_File, FullFile, Module, Options) :-
1971    '$assert_load_context_module'(FullFile, Module, Options),
1972    '$current_module'(LoadModules, FullFile),
1973    !,
1974    (   atom(LoadModules)
1975    ->  LoadModule = LoadModules
1976    ;   LoadModules = [LoadModule|_]
1977    ),
1978    '$import_from_loaded_module'(LoadModule, Module, Options).
1979'$already_loaded'(_, _, user, _) :- !.
1980'$already_loaded'(File, _, Module, Options) :-
1981    '$load_file'(File, Module, [if(true)|Options]).
1982
1983%!  '$mt_load_file'(+File, +FullFile, +Module, +Options) is det.
1984%
1985%   Deal with multi-threaded  loading  of   files.  The  thread that
1986%   wishes to load the thread first will  do so, while other threads
1987%   will wait until the leader finished and  than act as if the file
1988%   is already loaded.
1989%
1990%   Synchronisation is handled using  a   message  queue that exists
1991%   while the file is being loaded.   This synchronisation relies on
1992%   the fact that thread_get_message/1 throws  an existence_error if
1993%   the message queue  is  destroyed.  This   is  hacky.  Events  or
1994%   condition variables would have made a cleaner design.
1995
1996:- dynamic
1997    '$loading_file'/3.              % File, Queue, Thread
1998:- volatile
1999    '$loading_file'/3.
2000
2001'$mt_load_file'(File, FullFile, Module, Options) :-
2002    current_prolog_flag(threads, true),
2003    !,
2004    setup_call_cleanup(
2005        with_mutex('$load_file',
2006                   '$mt_start_load'(FullFile, Loading, Options)),
2007        '$mt_do_load'(Loading, File, FullFile, Module, Options),
2008        '$mt_end_load'(Loading)).
2009'$mt_load_file'(File, FullFile, Module, Options) :-
2010    '$option'(if(If), Options, true),
2011    '$noload'(If, FullFile, Options),
2012    !,
2013    '$already_loaded'(File, FullFile, Module, Options).
2014'$mt_load_file'(File, FullFile, Module, Options) :-
2015    '$qdo_load_file'(File, FullFile, Module, Action, Options),
2016    '$run_initialization'(FullFile, Action, Options).
2017
2018'$mt_start_load'(FullFile, queue(Queue), _) :-
2019    '$loading_file'(FullFile, Queue, LoadThread),
2020    \+ thread_self(LoadThread),
2021    !.
2022'$mt_start_load'(FullFile, already_loaded, Options) :-
2023    '$option'(if(If), Options, true),
2024    '$noload'(If, FullFile, Options),
2025    !.
2026'$mt_start_load'(FullFile, Ref, _) :-
2027    thread_self(Me),
2028    message_queue_create(Queue),
2029    assertz('$loading_file'(FullFile, Queue, Me), Ref).
2030
2031'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
2032    !,
2033    catch(thread_get_message(Queue, _), _, true),
2034    '$already_loaded'(File, FullFile, Module, Options).
2035'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
2036    !,
2037    '$already_loaded'(File, FullFile, Module, Options).
2038'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
2039    '$assert_load_context_module'(FullFile, Module, Options),
2040    '$qdo_load_file'(File, FullFile, Module, Action, Options),
2041    '$run_initialization'(FullFile, Action, Options).
2042
2043'$mt_end_load'(queue(_)) :- !.
2044'$mt_end_load'(already_loaded) :- !.
2045'$mt_end_load'(Ref) :-
2046    clause('$loading_file'(_, Queue, _), _, Ref),
2047    erase(Ref),
2048    thread_send_message(Queue, done),
2049    message_queue_destroy(Queue).
2050
2051
2052%!  '$qdo_load_file'(+Spec, +FullFile, +ContextModule, +Options) is det.
2053%
2054%   Switch to qcompile mode if requested by the option '$qlf'(+Out)
2055
2056'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
2057    memberchk('$qlf'(QlfOut), Options),
2058    !,
2059    setup_call_cleanup(
2060        '$qstart'(QlfOut, Module, State),
2061        '$do_load_file'(File, FullFile, Module, Action, Options),
2062        '$qend'(State)).
2063'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
2064    '$do_load_file'(File, FullFile, Module, Action, Options).
2065
2066'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
2067    '$qlf_open'(Qlf),
2068    '$compilation_mode'(OldMode, qlf),
2069    '$set_source_module'(OldModule, Module).
2070
2071'$qend'(state(OldMode, OldModule)) :-
2072    '$set_source_module'(_, OldModule),
2073    '$set_compilation_mode'(OldMode),
2074    '$qlf_close'.
2075
2076'$set_source_module'(OldModule, Module) :-
2077    '$current_source_module'(OldModule),
2078    '$set_source_module'(Module).
2079
2080%!  '$do_load_file'(+Spec, +FullFile, +ContextModule,
2081%!                  -Action, +Options) is det.
2082%
2083%   Perform the actual loading.
2084
2085'$do_load_file'(File, FullFile, Module, Action, Options) :-
2086    '$option'(derived_from(DerivedFrom), Options, -),
2087    '$register_derived_source'(FullFile, DerivedFrom),
2088    '$qlf_file'(File, FullFile, Absolute, Mode, Options),
2089    (   Mode == qcompile
2090    ->  qcompile(Module:File, Options)
2091    ;   '$do_load_file_2'(File, Absolute, Module, Action, Options)
2092    ).
2093
2094'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
2095    '$source_file_property'(Absolute, number_of_clauses, OldClauses),
2096    statistics(cputime, OldTime),
2097
2098    '$set_sandboxed_load'(Options, OldSandBoxed),
2099    '$set_verbose_load'(Options, OldVerbose),
2100    '$update_autoload_level'(Options, OldAutoLevel),
2101    '$save_file_scoped_flags'(ScopedFlags),
2102    set_prolog_flag(xref, false),
2103
2104    '$compilation_level'(Level),
2105    '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
2106    '$print_message'(StartMsgLevel,
2107                     load_file(start(Level,
2108                                     file(File, Absolute)))),
2109
2110    (   memberchk(stream(FromStream), Options)
2111    ->  Input = stream
2112    ;   Input = source
2113    ),
2114
2115    (   Input == stream,
2116        (   '$option'(format(qlf), Options, source)
2117        ->  set_stream(FromStream, file_name(Absolute)),
2118            '$qload_stream'(FromStream, Module, Action, LM, Options)
2119        ;   '$consult_file'(stream(Absolute, FromStream, []),
2120                            Module, Action, LM, Options)
2121        )
2122    ->  true
2123    ;   Input == source,
2124        file_name_extension(_, Ext, Absolute),
2125        (   user:prolog_file_type(Ext, qlf)
2126        ->  '$qload_file'(Absolute, Module, Action, LM, Options)
2127        ;   '$consult_file'(Absolute, Module, Action, LM, Options)
2128        )
2129    ->  true
2130    ;   print_message(error, load_file(failed(File))),
2131        fail
2132    ),
2133
2134    '$import_from_loaded_module'(LM, Module, Options),
2135
2136    '$source_file_property'(Absolute, number_of_clauses, NewClauses),
2137    statistics(cputime, Time),
2138    ClausesCreated is NewClauses - OldClauses,
2139    TimeUsed is Time - OldTime,
2140
2141    '$print_message'(DoneMsgLevel,
2142                     load_file(done(Level,
2143                                    file(File, Absolute),
2144                                    Action,
2145                                    LM,
2146                                    TimeUsed,
2147                                    ClausesCreated))),
2148    '$set_autoload_level'(OldAutoLevel),
2149    set_prolog_flag(verbose_load, OldVerbose),
2150    set_prolog_flag(sandboxed_load, OldSandBoxed),
2151    '$restore_file_scoped_flags'(ScopedFlags).
2152
2153%!  '$save_file_scoped_flags'(-State) is det.
2154%!  '$restore_file_scoped_flags'(-State) is det.
2155%
2156%   Save/restore flags that are scoped to a compilation unit.
2157
2158'$save_file_scoped_flags'(State) :-
2159    current_predicate(findall/3),          % Not when doing boot compile
2160    !,
2161    findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
2162'$save_file_scoped_flags'([]).
2163
2164'$save_file_scoped_flag'(Flag-Value) :-
2165    '$file_scoped_flag'(Flag, Default),
2166    (   current_prolog_flag(Flag, Value)
2167    ->  true
2168    ;   Value = Default
2169    ).
2170
2171'$file_scoped_flag'(generate_debug_info, true).
2172'$file_scoped_flag'(optimise,            false).
2173'$file_scoped_flag'(xref,                false).
2174
2175'$restore_file_scoped_flags'([]).
2176'$restore_file_scoped_flags'([Flag-Value|T]) :-
2177    set_prolog_flag(Flag, Value),
2178    '$restore_file_scoped_flags'(T).
2179
2180
2181%!  '$import_from_loaded_module'(LoadedModule, Module, Options) is det.
2182%
2183%   Import public predicates from LoadedModule into Module
2184
2185'$import_from_loaded_module'(LoadedModule, Module, Options) :-
2186    LoadedModule \== Module,
2187    atom(LoadedModule),
2188    !,
2189    '$option'(imports(Import), Options, all),
2190    '$option'(reexport(Reexport), Options, false),
2191    '$import_list'(Module, LoadedModule, Import, Reexport).
2192'$import_from_loaded_module'(_, _, _).
2193
2194
2195%!  '$set_verbose_load'(+Options, -Old) is det.
2196%
2197%   Set the =verbose_load= flag according to   Options and unify Old
2198%   with the old value.
2199
2200'$set_verbose_load'(Options, Old) :-
2201    current_prolog_flag(verbose_load, Old),
2202    (   memberchk(silent(Silent), Options)
2203    ->  (   '$negate'(Silent, Level0)
2204        ->  '$load_msg_compat'(Level0, Level)
2205        ;   Level = Silent
2206        ),
2207        set_prolog_flag(verbose_load, Level)
2208    ;   true
2209    ).
2210
2211'$negate'(true, false).
2212'$negate'(false, true).
2213
2214%!  '$set_sandboxed_load'(+Options, -Old) is det.
2215%
2216%   Update the Prolog flag  =sandboxed_load=   from  Options. Old is
2217%   unified with the old flag.
2218%
2219%   @error permission_error(leave, sandbox, -)
2220
2221'$set_sandboxed_load'(Options, Old) :-
2222    current_prolog_flag(sandboxed_load, Old),
2223    (   memberchk(sandboxed(SandBoxed), Options),
2224        '$enter_sandboxed'(Old, SandBoxed, New),
2225        New \== Old
2226    ->  set_prolog_flag(sandboxed_load, New)
2227    ;   true
2228    ).
2229
2230'$enter_sandboxed'(Old, New, SandBoxed) :-
2231    (   Old == false, New == true
2232    ->  SandBoxed = true,
2233        '$ensure_loaded_library_sandbox'
2234    ;   Old == true, New == false
2235    ->  throw(error(permission_error(leave, sandbox, -), _))
2236    ;   SandBoxed = Old
2237    ).
2238'$enter_sandboxed'(false, true, true).
2239
2240'$ensure_loaded_library_sandbox' :-
2241    source_file_property(library(sandbox), module(sandbox)),
2242    !.
2243'$ensure_loaded_library_sandbox' :-
2244    load_files(library(sandbox), [if(not_loaded), silent(true)]).
2245
2246
2247%!  '$update_autoload_level'(+Options, -OldLevel)
2248%
2249%   Update the '$autoload_nesting' and return the old value.
2250
2251:- thread_local
2252    '$autoload_nesting'/1.
2253
2254'$update_autoload_level'(Options, AutoLevel) :-
2255    '$option'(autoload(Autoload), Options, false),
2256    (   '$autoload_nesting'(CurrentLevel)
2257    ->  AutoLevel = CurrentLevel
2258    ;   AutoLevel = 0
2259    ),
2260    (   Autoload == false
2261    ->  true
2262    ;   NewLevel is AutoLevel + 1,
2263        '$set_autoload_level'(NewLevel)
2264    ).
2265
2266'$set_autoload_level'(New) :-
2267    retractall('$autoload_nesting'(_)),
2268    asserta('$autoload_nesting'(New)).
2269
2270
2271%!  '$print_message'(+Level, +Term) is det.
2272%
2273%   As print_message/2, but deal with  the   fact  that  the message
2274%   system might not yet be loaded.
2275
2276'$print_message'(Level, Term) :-
2277    current_predicate(system:print_message/2),
2278    !,
2279    print_message(Level, Term).
2280'$print_message'(warning, Term) :-
2281    source_location(File, Line),
2282    !,
2283    format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
2284'$print_message'(error, Term) :-
2285    !,
2286    source_location(File, Line),
2287    !,
2288    format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
2289'$print_message'(_Level, _Term).
2290
2291'$print_message_fail'(E) :-
2292    '$print_message'(error, E),
2293    fail.
2294
2295%!  '$consult_file'(+Path, +Module, -Action, -LoadedIn, +Options)
2296%
2297%   Called  from  '$do_load_file'/4  using  the   goal  returned  by
2298%   '$consult_goal'/2. This means that the  calling conventions must
2299%   be kept synchronous with '$qload_file'/6.
2300
2301'$consult_file'(Absolute, Module, What, LM, Options) :-
2302    '$current_source_module'(Module),   % same module
2303    !,
2304    '$consult_file_2'(Absolute, Module, What, LM, Options).
2305'$consult_file'(Absolute, Module, What, LM, Options) :-
2306    '$set_source_module'(OldModule, Module),
2307    '$ifcompiling'('$qlf_start_sub_module'(Module)),
2308    '$consult_file_2'(Absolute, Module, What, LM, Options),
2309    '$ifcompiling'('$qlf_end_part'),
2310    '$set_source_module'(OldModule).
2311
2312'$consult_file_2'(Absolute, Module, What, LM, Options) :-
2313    '$set_source_module'(OldModule, Module),
2314    '$load_id'(Absolute, Id, Modified, Options),
2315    '$start_consult'(Id, Modified),
2316    (   '$derived_source'(Absolute, DerivedFrom, _)
2317    ->  '$modified_id'(DerivedFrom, DerivedModified, Options),
2318        '$start_consult'(DerivedFrom, DerivedModified)
2319    ;   true
2320    ),
2321    '$compile_type'(What),
2322    '$save_lex_state'(LexState, Options),
2323    '$set_dialect'(Options),
2324    call_cleanup('$load_file'(Absolute, Id, LM, Options),
2325                 '$end_consult'(LexState, OldModule)).
2326
2327'$end_consult'(LexState, OldModule) :-
2328    '$restore_lex_state'(LexState),
2329    '$set_source_module'(OldModule).
2330
2331
2332:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2333
2334%!  '$save_lex_state'(-LexState, +Options) is det.
2335
2336'$save_lex_state'(State, Options) :-
2337    memberchk(scope_settings(false), Options),
2338    !,
2339    State = (-).
2340'$save_lex_state'(lexstate(Style, Dialect), _) :-
2341    '$style_check'(Style, Style),
2342    current_prolog_flag(emulated_dialect, Dialect).
2343
2344'$restore_lex_state'(-) :- !.
2345'$restore_lex_state'(lexstate(Style, Dialect)) :-
2346    '$style_check'(_, Style),
2347    set_prolog_flag(emulated_dialect, Dialect).
2348
2349'$set_dialect'(Options) :-
2350    memberchk(dialect(Dialect), Options),
2351    !,
2352    expects_dialect(Dialect).               % Autoloaded from library
2353'$set_dialect'(_).
2354
2355'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
2356    !,
2357    '$modified_id'(Id, Modified, Options).
2358'$load_id'(Id, Id, Modified, Options) :-
2359    '$modified_id'(Id, Modified, Options).
2360
2361'$modified_id'(_, Modified, Options) :-
2362    '$option'(modified(Stamp), Options, Def),
2363    Stamp \== Def,
2364    !,
2365    Modified = Stamp.
2366'$modified_id'(Id, Modified, _) :-
2367    exists_file(Id),
2368    !,
2369    time_file(Id, Modified).
2370'$modified_id'(_, 0.0, _).
2371
2372
2373'$compile_type'(What) :-
2374    '$compilation_mode'(How),
2375    (   How == database
2376    ->  What = compiled
2377    ;   How == qlf
2378    ->  What = '*qcompiled*'
2379    ;   What = 'boot compiled'
2380    ).
2381
2382%!  '$assert_load_context_module'(+File, -Module, -Options)
2383%
2384%   Record the module a file was loaded from (see make/0). The first
2385%   clause deals with loading from  another   file.  On reload, this
2386%   clause will be discarded by  $start_consult/1. The second clause
2387%   deals with reload from the toplevel.   Here  we avoid creating a
2388%   duplicate dynamic (i.e., not related to a source) clause.
2389
2390:- dynamic
2391    '$load_context_module'/3.
2392:- multifile
2393    '$load_context_module'/3.
2394
2395'$assert_load_context_module'(_, _, Options) :-
2396    memberchk(register(false), Options),
2397    !.
2398'$assert_load_context_module'(File, Module, Options) :-
2399    source_location(FromFile, Line),
2400    !,
2401    '$master_file'(FromFile, MasterFile),
2402    '$check_load_non_module'(File, Module),
2403    '$add_dialect'(Options, Options1),
2404    '$load_ctx_options'(Options1, Options2),
2405    '$store_admin_clause'(
2406        system:'$load_context_module'(File, Module, Options2),
2407        _Layout, MasterFile, FromFile:Line).
2408'$assert_load_context_module'(File, Module, Options) :-
2409    '$check_load_non_module'(File, Module),
2410    '$add_dialect'(Options, Options1),
2411    '$load_ctx_options'(Options1, Options2),
2412    (   clause('$load_context_module'(File, Module, _), true, Ref),
2413        \+ clause_property(Ref, file(_)),
2414        erase(Ref)
2415    ->  true
2416    ;   true
2417    ),
2418    assertz('$load_context_module'(File, Module, Options2)).
2419
2420'$add_dialect'(Options0, Options) :-
2421    current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
2422    !,
2423    Options = [dialect(Dialect)|Options0].
2424'$add_dialect'(Options, Options).
2425
2426%!  '$load_ctx_options'(+Options, -CtxOptions) is det.
2427%
2428%   Select the load options that  determine   the  load semantics to
2429%   perform a proper reload. Delete the others.
2430
2431'$load_ctx_options'([], []).
2432'$load_ctx_options'([H|T0], [H|T]) :-
2433    '$load_ctx_option'(H),
2434    !,
2435    '$load_ctx_options'(T0, T).
2436'$load_ctx_options'([_|T0], T) :-
2437    '$load_ctx_options'(T0, T).
2438
2439'$load_ctx_option'(derived_from(_)).
2440'$load_ctx_option'(dialect(_)).
2441'$load_ctx_option'(encoding(_)).
2442'$load_ctx_option'(imports(_)).
2443'$load_ctx_option'(reexport(_)).
2444
2445
2446%!  '$check_load_non_module'(+File) is det.
2447%
2448%   Test  that  a  non-module  file  is  not  loaded  into  multiple
2449%   contexts.
2450
2451'$check_load_non_module'(File, _) :-
2452    '$current_module'(_, File),
2453    !.          % File is a module file
2454'$check_load_non_module'(File, Module) :-
2455    '$load_context_module'(File, OldModule, _),
2456    Module \== OldModule,
2457    !,
2458    format(atom(Msg),
2459           'Non-module file already loaded into module ~w; \c
2460               trying to load into ~w',
2461           [OldModule, Module]),
2462    throw(error(permission_error(load, source, File),
2463                context(load_files/2, Msg))).
2464'$check_load_non_module'(_, _).
2465
2466%!  '$load_file'(+Path, +Id, -Module, +Options)
2467%
2468%   '$load_file'/4 does the actual loading.
2469%
2470%   state(FirstTerm:boolean,
2471%         Module:atom,
2472%         AtEnd:atom,
2473%         Stop:boolean,
2474%         Id:atom,
2475%         Dialect:atom)
2476
2477'$load_file'(Path, Id, Module, Options) :-
2478    State = state(true, _, true, false, Id, -),
2479    (   '$source_term'(Path, _Read, _Layout, Term, Layout,
2480                       _Stream, Options),
2481        '$valid_term'(Term),
2482        (   arg(1, State, true)
2483        ->  '$first_term'(Term, Layout, Id, State, Options),
2484            nb_setarg(1, State, false)
2485        ;   '$compile_term'(Term, Layout, Id)
2486        ),
2487        arg(4, State, true)
2488    ;   '$end_load_file'(State)
2489    ),
2490    !,
2491    arg(2, State, Module).
2492
2493'$valid_term'(Var) :-
2494    var(Var),
2495    !,
2496    print_message(error, error(instantiation_error, _)).
2497'$valid_term'(Term) :-
2498    Term \== [].
2499
2500'$end_load_file'(State) :-
2501    arg(1, State, true),           % empty file
2502    !,
2503    nb_setarg(2, State, Module),
2504    arg(5, State, Id),
2505    '$current_source_module'(Module),
2506    '$ifcompiling'('$qlf_start_file'(Id)),
2507    '$ifcompiling'('$qlf_end_part').
2508'$end_load_file'(State) :-
2509    arg(3, State, End),
2510    '$end_load_file'(End, State).
2511
2512'$end_load_file'(true, _).
2513'$end_load_file'(end_module, State) :-
2514    arg(2, State, Module),
2515    '$check_export'(Module),
2516    '$ifcompiling'('$qlf_end_part').
2517'$end_load_file'(end_non_module, _State) :-
2518    '$ifcompiling'('$qlf_end_part').
2519
2520
2521'$first_term'(?-(Directive), Layout, Id, State, Options) :-
2522    !,
2523    '$first_term'(:-(Directive), Layout, Id, State, Options).
2524'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
2525    nonvar(Directive),
2526    (   (   Directive = module(Name, Public)
2527        ->  Imports = []
2528        ;   Directive = module(Name, Public, Imports)
2529        )
2530    ->  !,
2531        '$module_name'(Name, Id, Module, Options),
2532        '$start_module'(Module, Public, State, Options),
2533        '$module3'(Imports)
2534    ;   Directive = expects_dialect(Dialect)
2535    ->  !,
2536        '$set_dialect'(Dialect, State),
2537        fail                        % Still consider next term as first
2538    ).
2539'$first_term'(Term, Layout, Id, State, Options) :-
2540    '$start_non_module'(Id, State, Options),
2541    '$compile_term'(Term, Layout, Id).
2542
2543'$compile_term'(Term, Layout, Id) :-
2544    '$compile_term'(Term, Layout, Id, -).
2545
2546'$compile_term'(Var, _Layout, _Id, _Src) :-
2547    var(Var),
2548    !,
2549    '$instantiation_error'(Var).
2550'$compile_term'((?-Directive), _Layout, Id, _) :-
2551    !,
2552    '$execute_directive'(Directive, Id).
2553'$compile_term'((:-Directive), _Layout, Id, _) :-
2554    !,
2555    '$execute_directive'(Directive, Id).
2556'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :-
2557    !,
2558    '$compile_term'(Term, Layout, Id, File:Line).
2559'$compile_term'(Clause, Layout, Id, SrcLoc) :-
2560    catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
2561          '$print_message'(error, E)).
2562
2563'$start_non_module'(Id, _State, Options) :-
2564    '$option'(must_be_module(true), Options, false),
2565    !,
2566    throw(error(domain_error(module_file, Id), _)).
2567'$start_non_module'(Id, State, _Options) :-
2568    '$current_source_module'(Module),
2569    '$ifcompiling'('$qlf_start_file'(Id)),
2570    '$qset_dialect'(State),
2571    nb_setarg(2, State, Module),
2572    nb_setarg(3, State, end_non_module).
2573
2574%!  '$set_dialect'(+Dialect, +State)
2575%
2576%   Sets the expected dialect. This is difficult if we are compiling
2577%   a .qlf file using qcompile/1 because   the file is already open,
2578%   while we are looking for the first term to decide wether this is
2579%   a module or not. We save the   dialect  and set it after opening
2580%   the file or module.
2581%
2582%   Note that expects_dialect/1 itself may   be  autoloaded from the
2583%   library.
2584
2585'$set_dialect'(Dialect, State) :-
2586    '$compilation_mode'(qlf, database),
2587    !,
2588    expects_dialect(Dialect),
2589    '$compilation_mode'(_, qlf),
2590    nb_setarg(6, State, Dialect).
2591'$set_dialect'(Dialect, _) :-
2592    expects_dialect(Dialect).
2593
2594'$qset_dialect'(State) :-
2595    '$compilation_mode'(qlf),
2596    arg(6, State, Dialect), Dialect \== (-),
2597    !,
2598    '$add_directive_wic'(expects_dialect(Dialect)).
2599'$qset_dialect'(_).
2600
2601
2602                 /*******************************
2603                 *           MODULES            *
2604                 *******************************/
2605
2606'$start_module'(Module, _Public, State, _Options) :-
2607    '$current_module'(Module, OldFile),
2608    source_location(File, _Line),
2609    OldFile \== File, OldFile \== [],
2610    same_file(OldFile, File),
2611    !,
2612    nb_setarg(2, State, Module),
2613    nb_setarg(4, State, true).      % Stop processing
2614'$start_module'(Module, Public, State, Options) :-
2615    arg(5, State, File),
2616    nb_setarg(2, State, Module),
2617    source_location(_File, Line),
2618    '$option'(redefine_module(Action), Options, false),
2619    '$module_class'(File, Class, Super),
2620    '$redefine_module'(Module, File, Action),
2621    '$declare_module'(Module, Class, Super, File, Line, false),
2622    '$export_list'(Public, Module, Ops),
2623    '$ifcompiling'('$qlf_start_module'(Module)),
2624    '$export_ops'(Ops, Module, File),
2625    '$qset_dialect'(State),
2626    nb_setarg(3, State, end_module).
2627
2628
2629%!  '$module3'(+Spec) is det.
2630%
2631%   Handle the 3th argument of a module declartion.
2632
2633'$module3'(Var) :-
2634    var(Var),
2635    !,
2636    '$instantiation_error'(Var).
2637'$module3'([]) :- !.
2638'$module3'([H|T]) :-
2639    !,
2640    '$module3'(H),
2641    '$module3'(T).
2642'$module3'(Id) :-
2643    use_module(library(dialect/Id)).
2644
2645%!  '$module_name'(?Name, +Id, -Module, +Options) is semidet.
2646%
2647%   Determine the module name.  There are some cases:
2648%
2649%     - Option module(Module) is given.  In that case, use this
2650%       module and if Module is the load context, ignore the module
2651%       header.
2652%     - The initial name is unbound.  Use the base name of the
2653%       source identifier (normally the file name).  Compatibility
2654%       to Ciao.  This might change; I think it is wiser to use
2655%       the full unique source identifier.
2656
2657'$module_name'(_, _, Module, Options) :-
2658    '$option'(module(Module), Options),
2659    !,
2660    '$current_source_module'(Context),
2661    Context \== Module.                     % cause '$first_term'/5 to fail.
2662'$module_name'(Var, Id, Module, Options) :-
2663    var(Var),
2664    !,
2665    file_base_name(Id, File),
2666    file_name_extension(Var, _, File),
2667    '$module_name'(Var, Id, Module, Options).
2668'$module_name'(Reserved, _, _, _) :-
2669    '$reserved_module'(Reserved),
2670    !,
2671    throw(error(permission_error(load, module, Reserved), _)).
2672'$module_name'(Module, _Id, Module, _).
2673
2674
2675'$reserved_module'(system).
2676'$reserved_module'(user).
2677
2678
2679%!  '$redefine_module'(+Module, +File, -Redefine)
2680
2681'$redefine_module'(_Module, _, false) :- !.
2682'$redefine_module'(Module, File, true) :-
2683    !,
2684    (   module_property(Module, file(OldFile)),
2685        File \== OldFile
2686    ->  unload_file(OldFile)
2687    ;   true
2688    ).
2689'$redefine_module'(Module, File, ask) :-
2690    (   stream_property(user_input, tty(true)),
2691        module_property(Module, file(OldFile)),
2692        File \== OldFile,
2693        '$rdef_response'(Module, OldFile, File, true)
2694    ->  '$redefine_module'(Module, File, true)
2695    ;   true
2696    ).
2697
2698'$rdef_response'(Module, OldFile, File, Ok) :-
2699    repeat,
2700    print_message(query, redefine_module(Module, OldFile, File)),
2701    get_single_char(Char),
2702    '$rdef_response'(Char, Ok0),
2703    !,
2704    Ok = Ok0.
2705
2706'$rdef_response'(Char, true) :-
2707    memberchk(Char, "yY"),
2708    format(user_error, 'yes~n', []).
2709'$rdef_response'(Char, false) :-
2710    memberchk(Char, "nN"),
2711    format(user_error, 'no~n', []).
2712'$rdef_response'(Char, _) :-
2713    memberchk(Char, "a"),
2714    format(user_error, 'abort~n', []),
2715    abort.
2716'$rdef_response'(_, _) :-
2717    print_message(help, redefine_module_reply),
2718    fail.
2719
2720
2721%!  '$module_class'(+File, -Class, -Super) is det.
2722%
2723%   Determine the initial module from which   I  inherit. All system
2724%   and library modules inherit from =system=, while all normal user
2725%   modules inherit from =user=.
2726
2727'$module_class'(File, Class, system) :-
2728    current_prolog_flag(home, Home),
2729    sub_atom(File, 0, Len, _, Home),
2730    !,
2731    (   sub_atom(File, Len, _, _, '/boot/')
2732    ->  Class = system
2733    ;   Class = library
2734    ).
2735'$module_class'(_, user, user).
2736
2737'$check_export'(Module) :-
2738    '$undefined_export'(Module, UndefList),
2739    (   '$member'(Undef, UndefList),
2740        strip_module(Undef, _, Local),
2741        print_message(error,
2742                      undefined_export(Module, Local)),
2743        fail
2744    ;   true
2745    ).
2746
2747
2748%!  '$import_list'(+TargetModule, +FromModule, +Import, +Reexport) is det.
2749%
2750%   Import from FromModule to TargetModule. Import  is one of =all=,
2751%   a list of optionally  mapped  predicate   indicators  or  a term
2752%   except(Import).
2753
2754'$import_list'(_, _, Var, _) :-
2755    var(Var),
2756    !,
2757    throw(error(instantitation_error, _)).
2758'$import_list'(Target, Source, all, Reexport) :-
2759    !,
2760    '$exported_ops'(Source, Import, Predicates),
2761    '$module_property'(Source, exports(Predicates)),
2762    '$import_all'(Import, Target, Source, Reexport, weak).
2763'$import_list'(Target, Source, except(Spec), Reexport) :-
2764    !,
2765    '$exported_ops'(Source, Export, Predicates),
2766    '$module_property'(Source, exports(Predicates)),
2767    (   is_list(Spec)
2768    ->  true
2769    ;   throw(error(type_error(list, Spec), _))
2770    ),
2771    '$import_except'(Spec, Export, Import),
2772    '$import_all'(Import, Target, Source, Reexport, weak).
2773'$import_list'(Target, Source, Import, Reexport) :-
2774    !,
2775    is_list(Import),
2776    !,
2777    '$import_all'(Import, Target, Source, Reexport, strong).
2778'$import_list'(_, _, Import, _) :-
2779    throw(error(type_error(import_specifier, Import))).
2780
2781
2782'$import_except'([], List, List).
2783'$import_except'([H|T], List0, List) :-
2784    '$import_except_1'(H, List0, List1),
2785    '$import_except'(T, List1, List).
2786
2787'$import_except_1'(Var, _, _) :-
2788    var(Var),
2789    !,
2790    throw(error(instantitation_error, _)).
2791'$import_except_1'(PI as N, List0, List) :-
2792    '$pi'(PI), atom(N),
2793    !,
2794    '$canonical_pi'(PI, CPI),
2795    '$import_as'(CPI, N, List0, List).
2796'$import_except_1'(op(P,A,N), List0, List) :-
2797    !,
2798    '$remove_ops'(List0, op(P,A,N), List).
2799'$import_except_1'(PI, List0, List) :-
2800    '$pi'(PI),
2801    !,
2802    '$canonical_pi'(PI, CPI),
2803    '$select'(P, List0, List),
2804    '$canonical_pi'(CPI, P),
2805    !.
2806'$import_except_1'(Except, _, _) :-
2807    throw(error(type_error(import_specifier, Except), _)).
2808
2809'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
2810    '$canonical_pi'(PI2, CPI),
2811    !.
2812'$import_as'(PI, N, [H|T0], [H|T]) :-
2813    !,
2814    '$import_as'(PI, N, T0, T).
2815'$import_as'(PI, _, _, _) :-
2816    throw(error(existence_error(export, PI), _)).
2817
2818'$pi'(N/A) :- atom(N), integer(A), !.
2819'$pi'(N//A) :- atom(N), integer(A).
2820
2821'$canonical_pi'(N//A0, N/A) :-
2822    A is A0 + 2.
2823'$canonical_pi'(PI, PI).
2824
2825'$remove_ops'([], _, []).
2826'$remove_ops'([Op|T0], Pattern, T) :-
2827    subsumes_term(Pattern, Op),
2828    !,
2829    '$remove_ops'(T0, Pattern, T).
2830'$remove_ops'([H|T0], Pattern, [H|T]) :-
2831    '$remove_ops'(T0, Pattern, T).
2832
2833
2834%!  '$import_all'(+Import, +Context, +Source, +Reexport, +Strength)
2835
2836'$import_all'(Import, Context, Source, Reexport, Strength) :-
2837    '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
2838    (   Reexport == true,
2839        (   '$list_to_conj'(Imported, Conj)
2840        ->  export(Context:Conj),
2841            '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
2842        ;   true
2843        ),
2844        source_location(File, _Line),
2845        '$export_ops'(ImpOps, Context, File)
2846    ;   true
2847    ).
2848
2849%!  '$import_all2'(+Imports, +Context, +Source, -Imported, -ImpOps, +Strength)
2850
2851'$import_all2'([], _, _, [], [], _).
2852'$import_all2'([PI as NewName|Rest], Context, Source,
2853               [NewName/Arity|Imported], ImpOps, Strength) :-
2854    !,
2855    '$canonical_pi'(PI, Name/Arity),
2856    length(Args, Arity),
2857    Head =.. [Name|Args],
2858    NewHead =.. [NewName|Args],
2859    (   '$get_predicate_attribute'(Source:Head, transparent, 1)
2860    ->  '$set_predicate_attribute'(Context:NewHead, transparent, true)
2861    ;   true
2862    ),
2863    (   source_location(File, Line)
2864    ->  catch('$store_admin_clause'((NewHead :- Source:Head),
2865                                    _Layout, File, File:Line),
2866              E, '$print_message'(error, E))
2867    ;   assertz((NewHead :- !, Source:Head)) % ! avoids problems with
2868    ),                                       % duplicate load
2869    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2870'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
2871               [op(P,A,N)|ImpOps], Strength) :-
2872    !,
2873    '$import_ops'(Context, Source, op(P,A,N)),
2874    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2875'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
2876    catch(Context:'$import'(Source:Pred, Strength), Error,
2877          print_message(error, Error)),
2878    '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
2879    '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2880
2881
2882'$list_to_conj'([One], One) :- !.
2883'$list_to_conj'([H|T], (H,Rest)) :-
2884    '$list_to_conj'(T, Rest).
2885
2886%!  '$exported_ops'(+Module, -Ops, ?Tail) is det.
2887%
2888%   Ops is a list of op(P,A,N) terms representing the operators
2889%   exported from Module.
2890
2891'$exported_ops'(Module, Ops, Tail) :-
2892    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
2893    !,
2894    findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
2895'$exported_ops'(_, Ops, Ops).
2896
2897'$exported_op'(Module, P, A, N) :-
2898    '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
2899    Module:'$exported_op'(P, A, N).
2900
2901%!  '$import_ops'(+Target, +Source, +Pattern)
2902%
2903%   Import the operators export from Source into the module table of
2904%   Target.  We only import operators that unify with Pattern.
2905
2906'$import_ops'(To, From, Pattern) :-
2907    ground(Pattern),
2908    !,
2909    Pattern = op(P,A,N),
2910    op(P,A,To:N),
2911    (   '$exported_op'(From, P, A, N)
2912    ->  true
2913    ;   print_message(warning, no_exported_op(From, Pattern))
2914    ).
2915'$import_ops'(To, From, Pattern) :-
2916    (   '$exported_op'(From, Pri, Assoc, Name),
2917        Pattern = op(Pri, Assoc, Name),
2918        op(Pri, Assoc, To:Name),
2919        fail
2920    ;   true
2921    ).
2922
2923
2924%!  '$export_list'(+Declarations, +Module, -Ops)
2925%
2926%   Handle the export list of the module declaration for Module
2927%   associated to File.
2928
2929'$export_list'(Decls, Module, Ops) :-
2930    is_list(Decls),
2931    !,
2932    '$do_export_list'(Decls, Module, Ops).
2933'$export_list'(Decls, _, _) :-
2934    var(Decls),
2935    throw(error(instantiation_error, _)).
2936'$export_list'(Decls, _, _) :-
2937    throw(error(type_error(list, Decls), _)).
2938
2939'$do_export_list'([], _, []) :- !.
2940'$do_export_list'([H|T], Module, Ops) :-
2941    !,
2942    catch('$export1'(H, Module, Ops, Ops1),
2943          E, ('$print_message'(error, E), Ops = Ops1)),
2944    '$do_export_list'(T, Module, Ops1).
2945
2946'$export1'(Var, _, _, _) :-
2947    var(Var),
2948    !,
2949    throw(error(instantiation_error, _)).
2950'$export1'(Op, _, [Op|T], T) :-
2951    Op = op(_,_,_),
2952    !.
2953'$export1'(PI, Module, Ops, Ops) :-
2954    export(Module:PI).
2955
2956'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
2957    catch(( op(Pri, Assoc, Module:Name),
2958            '$export_op'(Pri, Assoc, Name, Module, File)
2959          ),
2960          E, '$print_message'(error, E)),
2961    '$export_ops'(T, Module, File).
2962'$export_ops'([], _, _).
2963
2964'$export_op'(Pri, Assoc, Name, Module, File) :-
2965    (   '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
2966    ->  true
2967    ;   '$execute_directive'(discontiguous(Module:'$exported_op'/3), File)
2968    ),
2969    '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
2970
2971%!  '$execute_directive'(:Goal, +File) is det.
2972%
2973%   Execute the argument of :- or ?- while loading a file.
2974
2975'$execute_directive'(Goal, F) :-
2976    '$expand_goal'(Goal, Goal1),
2977    '$execute_directive_2'(Goal1, F).
2978
2979'$execute_directive_2'(encoding(Encoding), F) :-
2980    !,
2981    source_location(F, _),
2982    '$load_input'(F, S),
2983    set_stream(S, encoding(Encoding)).
2984'$execute_directive_2'(ISO, F) :-
2985    '$expand_directive'(ISO, Normal),
2986    !,
2987    '$execute_directive'(Normal, F).
2988'$execute_directive_2'(Goal, _) :-
2989    \+ '$compilation_mode'(database),
2990    !,
2991    '$add_directive_wic2'(Goal, Type),
2992    (   Type == call                % suspend compiling into .qlf file
2993    ->  '$compilation_mode'(Old, database),
2994        setup_call_cleanup(
2995            '$directive_mode'(OldDir, Old),
2996            '$execute_directive_3'(Goal),
2997            ( '$set_compilation_mode'(Old),
2998              '$set_directive_mode'(OldDir)
2999            ))
3000    ;   '$execute_directive_3'(Goal)
3001    ).
3002'$execute_directive_2'(Goal, _) :-
3003    '$execute_directive_3'(Goal).
3004
3005'$execute_directive_3'(Goal) :-
3006    '$current_source_module'(Module),
3007    '$valid_directive'(Module:Goal),
3008    !,
3009    (   '$pattr_directive'(Goal, Module)
3010    ->  true
3011    ;   catch(Module:Goal, Term, '$exception_in_directive'(Term))
3012    ->  true
3013    ;   print_message(warning, goal_failed(directive, Module:Goal)),
3014        fail
3015    ).
3016'$execute_directive_3'(_).
3017
3018
3019%!  '$valid_directive'(:Directive) is det.
3020%
3021%   If   the   flag   =sandboxed_load=   is   =true=,   this   calls
3022%   prolog:sandbox_allowed_directive/1. This call can deny execution
3023%   of the directive by throwing an exception.
3024
3025:- multifile prolog:sandbox_allowed_directive/1.
3026:- multifile prolog:sandbox_allowed_clause/1.
3027:- meta_predicate '$valid_directive'(:).
3028
3029'$valid_directive'(_) :-
3030    current_prolog_flag(sandboxed_load, false),
3031    !.
3032'$valid_directive'(Goal) :-
3033    catch(prolog:sandbox_allowed_directive(Goal), Error, true),
3034    !,
3035    (   var(Error)
3036    ->  true
3037    ;   print_message(error, Error),
3038        fail
3039    ).
3040'$valid_directive'(Goal) :-
3041    print_message(error,
3042                  error(permission_error(execute,
3043                                         sandboxed_directive,
3044                                         Goal), _)),
3045    fail.
3046
3047'$exception_in_directive'(Term) :-
3048    print_message(error, Term),
3049    fail.
3050
3051%       This predicate deals with the very odd ISO requirement to allow
3052%       for :- dynamic(a/2, b/3, c/4) instead of the normally used
3053%       :- dynamic a/2, b/3, c/4 or, if operators are not desirable,
3054%       :- dynamic((a/2, b/3, c/4)).
3055
3056'$expand_directive'(Directive, Expanded) :-
3057    functor(Directive, Name, Arity),
3058    Arity > 1,
3059    '$iso_property_directive'(Name),
3060    Directive =.. [Name|Args],
3061    '$mk_normal_args'(Args, Normal),
3062    Expanded =.. [Name, Normal].
3063
3064'$iso_property_directive'(dynamic).
3065'$iso_property_directive'(multifile).
3066'$iso_property_directive'(discontiguous).
3067
3068'$mk_normal_args'([One], One).
3069'$mk_normal_args'([H|T0], (H,T)) :-
3070    '$mk_normal_args'(T0, T).
3071
3072
3073%       Note that the list, consult and ensure_loaded directives are already
3074%       handled at compile time and therefore should not go into the
3075%       intermediate code file.
3076
3077'$add_directive_wic2'(Goal, Type) :-
3078    '$common_goal_type'(Goal, Type),
3079    !,
3080    (   Type == load
3081    ->  true
3082    ;   '$current_source_module'(Module),
3083        '$add_directive_wic'(Module:Goal)
3084    ).
3085'$add_directive_wic2'(Goal, _) :-
3086    (   '$compilation_mode'(qlf)    % no problem for qlf files
3087    ->  true
3088    ;   print_message(error, mixed_directive(Goal))
3089    ).
3090
3091'$common_goal_type'((A,B), Type) :-
3092    !,
3093    '$common_goal_type'(A, Type),
3094    '$common_goal_type'(B, Type).
3095'$common_goal_type'((A;B), Type) :-
3096    !,
3097    '$common_goal_type'(A, Type),
3098    '$common_goal_type'(B, Type).
3099'$common_goal_type'((A->B), Type) :-
3100    !,
3101    '$common_goal_type'(A, Type),
3102    '$common_goal_type'(B, Type).
3103'$common_goal_type'(Goal, Type) :-
3104    '$goal_type'(Goal, Type).
3105
3106'$goal_type'(Goal, Type) :-
3107    (   '$load_goal'(Goal)
3108    ->  Type = load
3109    ;   Type = call
3110    ).
3111
3112'$load_goal'([_|_]).
3113'$load_goal'(consult(_)).
3114'$load_goal'(load_files(_)).
3115'$load_goal'(load_files(_,Options)) :-
3116    memberchk(qcompile(QlfMode), Options),
3117    '$qlf_part_mode'(QlfMode).
3118'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic).
3119'$load_goal'(use_module(_))    :- '$compilation_mode'(wic).
3120'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic).
3121
3122'$qlf_part_mode'(part).
3123'$qlf_part_mode'(true).                 % compatibility
3124
3125
3126                /********************************
3127                *        COMPILE A CLAUSE       *
3128                *********************************/
3129
3130%!  '$store_admin_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
3131%
3132%   Store a clause into the   database  for administrative purposes.
3133%   This bypasses sanity checking.
3134
3135'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
3136    source_location(File, _Line),
3137    !,
3138    setup_call_cleanup(
3139        '$start_aux'(File, Context),
3140        '$store_admin_clause2'(Clause, Layout, File, SrcLoc),
3141        '$end_aux'(File, Context)).
3142'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
3143    '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
3144
3145'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
3146    (   '$compilation_mode'(database)
3147    ->  '$record_clause'(Clause, File, SrcLoc)
3148    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
3149        '$qlf_assert_clause'(Ref, development)
3150    ).
3151
3152%!  '$store_clause'(+Clause, ?Layout, +Owner, +SrcLoc) is det.
3153%
3154%   Store a clause into the database.
3155%
3156%   @arg    Owner is the file-id that owns the clause
3157%   @arg    SrcLoc is the file:line term where the clause
3158%           originates from.
3159
3160'$store_clause'((_, _), _, _, _) :-
3161    !,
3162    print_message(error, cannot_redefine_comma),
3163    fail.
3164'$store_clause'(Clause, _Layout, File, SrcLoc) :-
3165    '$valid_clause'(Clause),
3166    !,
3167    (   '$compilation_mode'(database)
3168    ->  '$record_clause'(Clause, File, SrcLoc)
3169    ;   '$record_clause'(Clause, File, SrcLoc, Ref),
3170        '$qlf_assert_clause'(Ref, development)
3171    ).
3172
3173'$valid_clause'(_) :-
3174    current_prolog_flag(sandboxed_load, false),
3175    !.
3176'$valid_clause'(Clause) :-
3177    \+ '$cross_module_clause'(Clause),
3178    !.
3179'$valid_clause'(Clause) :-
3180    catch(prolog:sandbox_allowed_clause(Clause), Error, true),
3181    !,
3182    (   var(Error)
3183    ->  true
3184    ;   print_message(error, Error),
3185        fail
3186    ).
3187'$valid_clause'(Clause) :-
3188    print_message(error,
3189                  error(permission_error(assert,
3190                                         sandboxed_clause,
3191                                         Clause), _)),
3192    fail.
3193
3194'$cross_module_clause'(Clause) :-
3195    '$head_module'(Clause, Module),
3196    \+ '$current_source_module'(Module).
3197
3198'$head_module'(Var, _) :-
3199    var(Var), !, fail.
3200'$head_module'((Head :- _), Module) :-
3201    '$head_module'(Head, Module).
3202'$head_module'(Module:_, Module).
3203
3204'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
3205'$clause_source'(Clause, Clause, -).
3206
3207%!  '$store_clause'(+Term, +Id) is det.
3208%
3209%   This interface is used by PlDoc (and who knows).  Kept for to avoid
3210%   compatibility issues.
3211
3212:- public
3213    '$store_clause'/2.
3214
3215'$store_clause'(Term, Id) :-
3216    '$clause_source'(Term, Clause, SrcLoc),
3217    '$store_clause'(Clause, _, Id, SrcLoc).
3218
3219%!  compile_aux_clauses(+Clauses) is det.
3220%
3221%   Compile clauses given the current  source   location  but do not
3222%   change  the  notion  of   the    current   procedure  such  that
3223%   discontiguous  warnings  are  not  issued.    The   clauses  are
3224%   associated with the current file and  therefore wiped out if the
3225%   file is reloaded.
3226%
3227%   If the cross-referencer is active, we should not (re-)assert the
3228%   clauses.  Actually,  we  should   make    them   known   to  the
3229%   cross-referencer. How do we do that?   Maybe we need a different
3230%   API, such as in:
3231%
3232%     ==
3233%     expand_term_aux(Goal, NewGoal, Clauses)
3234%     ==
3235%
3236%   @tbd    Deal with source code layout?
3237
3238compile_aux_clauses(_Clauses) :-
3239    current_prolog_flag(xref, true),
3240    !.
3241compile_aux_clauses(Clauses) :-
3242    source_location(File, _Line),
3243    '$compile_aux_clauses'(Clauses, File).
3244
3245'$compile_aux_clauses'(Clauses, File) :-
3246    setup_call_cleanup(
3247        '$start_aux'(File, Context),
3248        '$store_aux_clauses'(Clauses, File),
3249        '$end_aux'(File, Context)).
3250
3251'$store_aux_clauses'(Clauses, File) :-
3252    is_list(Clauses),
3253    !,
3254    forall('$member'(C,Clauses),
3255           '$compile_term'(C, _Layout, File)).
3256'$store_aux_clauses'(Clause, File) :-
3257    '$compile_term'(Clause, _Layout, File).
3258
3259
3260                 /*******************************
3261                 *             READING          *
3262                 *******************************/
3263
3264:- multifile
3265    prolog:comment_hook/3.                  % hook for read_clause/3
3266
3267
3268                 /*******************************
3269                 *       FOREIGN INTERFACE      *
3270                 *******************************/
3271
3272%       call-back from PL_register_foreign().  First argument is the module
3273%       into which the foreign predicate is loaded and second is a term
3274%       describing the arguments.
3275
3276:- dynamic
3277    '$foreign_registered'/2.
3278
3279                 /*******************************
3280                 *   TEMPORARY TERM EXPANSION   *
3281                 *******************************/
3282
3283% Provide temporary definitions for the boot-loader.  These are replaced
3284% by the real thing in load.pl
3285
3286:- dynamic
3287    '$expand_goal'/2,
3288    '$expand_term'/4.
3289
3290'$expand_goal'(In, In).
3291'$expand_term'(In, Layout, In, Layout).
3292
3293
3294                /********************************
3295                *     WIC CODE COMPILER         *
3296                *********************************/
3297
3298/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3299This entry point is called from pl-main.c  if the -c option (compile) is
3300given. It compiles all files and finally calls qsave_program to create a
3301saved state.
3302- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3303
3304:- public '$compile_wic'/0.
3305
3306'$compile_wic' :-
3307    current_prolog_flag(os_argv, Argv),
3308    '$get_files_argv'(Argv, Files),
3309    '$translate_options'(Argv, Options),
3310    '$cmd_option_val'(compileout, Out),
3311    attach_packs,
3312    user:consult(Files),
3313    user:qsave_program(Out, Options).
3314
3315'$get_files_argv'([], []) :- !.
3316'$get_files_argv'(['-c'|Files], Files) :- !.
3317'$get_files_argv'([_|Rest], Files) :-
3318    '$get_files_argv'(Rest, Files).
3319
3320'$translate_options'([], []).
3321'$translate_options'([O|T0], [Opt|T]) :-
3322    atom_chars(O, [-,-|Rest]),
3323    '$split'(Rest, [=], Head, Tail),
3324    !,
3325    atom_chars(Name, Head),
3326    '$compile_option_type'(Name, Type),
3327    '$convert_option_value'(Type, Tail, Value),
3328    Opt =.. [Name, Value],
3329    '$translate_options'(T0, T).
3330'$translate_options'([_|T0], T) :-
3331    '$translate_options'(T0, T).
3332
3333'$split'(List, Split, [], Tail) :-
3334    '$append'(Split, Tail, List),
3335    !.
3336'$split'([H|T0], Split, [H|T], Tail) :-
3337    '$split'(T0, Split, T, Tail).
3338
3339'$compile_option_type'(argument,    integer).
3340'$compile_option_type'(autoload,    atom).
3341'$compile_option_type'(class,       atom).
3342'$compile_option_type'(emulator,    atom).
3343'$compile_option_type'(global,      integer).
3344'$compile_option_type'(goal,        callable).
3345'$compile_option_type'(init_file,   atom).
3346'$compile_option_type'(local,       integer).
3347'$compile_option_type'(map,         atom).
3348'$compile_option_type'(op,          atom).
3349'$compile_option_type'(stand_alone, atom).
3350'$compile_option_type'(toplevel,    callable).
3351'$compile_option_type'(foreign,     atom).
3352'$compile_option_type'(trail,       integer).
3353
3354'$convert_option_value'(integer, Chars, Value) :-
3355    number_chars(Value, Chars).
3356'$convert_option_value'(atom, Chars, Value) :-
3357    atom_chars(Value, Chars).
3358'$convert_option_value'(callable, Chars, Value) :-
3359    atom_chars(Atom, Chars),
3360    term_to_atom(Value, Atom).
3361
3362
3363                 /*******************************
3364                 *         TYPE SUPPORT         *
3365                 *******************************/
3366
3367'$type_error'(Type, Value) :-
3368    (   var(Value)
3369    ->  throw(error(instantiation_error, _))
3370    ;   throw(error(type_error(Type, Value), _))
3371    ).
3372
3373'$domain_error'(Type, Value) :-
3374    throw(error(domain_error(Type, Value), _)).
3375
3376'$existence_error'(Type, Object) :-
3377    throw(error(existence_error(Type, Object), _)).
3378
3379'$permission_error'(Action, Type, Term) :-
3380    throw(error(permission_error(Action, Type, Term), _)).
3381
3382'$instantiation_error'(_Var) :-
3383    throw(error(instantiation_error, _)).
3384
3385'$must_be'(list, X) :-
3386    '$skip_list'(_, X, Tail),
3387    (   Tail == []
3388    ->  true
3389    ;   '$type_error'(list, Tail)
3390    ).
3391'$must_be'(options, X) :-
3392    (   '$is_options'(X)
3393    ->  true
3394    ;   '$type_error'(options, X)
3395    ).
3396'$must_be'(atom, X) :-
3397    (   atom(X)
3398    ->  true
3399    ;   '$type_error'(atom, X)
3400    ).
3401'$must_be'(callable, X) :-
3402    (   callable(X)
3403    ->  true
3404    ;   '$type_error'(callable, X)
3405    ).
3406'$must_be'(oneof(Type, Domain, List), X) :-
3407    '$must_be'(Type, X),
3408    (   memberchk(X, List)
3409    ->  true
3410    ;   '$domain_error'(Domain, X)
3411    ).
3412'$must_be'(boolean, X) :-
3413    (   (X == true ; X == false)
3414    ->  true
3415    ;   '$type_error'(boolean, X)
3416    ).
3417
3418
3419                /********************************
3420                *       LIST PROCESSING         *
3421                *********************************/
3422
3423'$member'(El, [H|T]) :-
3424    '$member_'(T, El, H).
3425
3426'$member_'(_, El, El).
3427'$member_'([H|T], El, _) :-
3428    '$member_'(T, El, H).
3429
3430
3431'$append'([], L, L).
3432'$append'([H|T], L, [H|R]) :-
3433    '$append'(T, L, R).
3434
3435'$select'(X, [X|Tail], Tail).
3436'$select'(Elem, [Head|Tail], [Head|Rest]) :-
3437    '$select'(Elem, Tail, Rest).
3438
3439'$reverse'(L1, L2) :-
3440    '$reverse'(L1, [], L2).
3441
3442'$reverse'([], List, List).
3443'$reverse'([Head|List1], List2, List3) :-
3444    '$reverse'(List1, [Head|List2], List3).
3445
3446'$delete'([], _, []) :- !.
3447'$delete'([Elem|Tail], Elem, Result) :-
3448    !,
3449    '$delete'(Tail, Elem, Result).
3450'$delete'([Head|Tail], Elem, [Head|Rest]) :-
3451    '$delete'(Tail, Elem, Rest).
3452
3453'$last'([H|T], Last) :-
3454    '$last'(T, H, Last).
3455
3456'$last'([], Last, Last).
3457'$last'([H|T], _, Last) :-
3458    '$last'(T, H, Last).
3459
3460
3461%!  length(?List, ?N)
3462%
3463%   Is true when N is the length of List.
3464
3465:- '$iso'((length/2)).
3466
3467length(List, Length) :-
3468    var(Length),
3469    !,
3470    '$skip_list'(Length0, List, Tail),
3471    (   Tail == []
3472    ->  Length = Length0                    % +,-
3473    ;   var(Tail)
3474    ->  Tail \== Length,                    % avoid length(L,L)
3475        '$length3'(Tail, Length, Length0)   % -,-
3476    ;   throw(error(type_error(list, List),
3477                    context(length/2, _)))
3478    ).
3479length(List, Length) :-
3480    integer(Length),
3481    Length >= 0,
3482    !,
3483    '$skip_list'(Length0, List, Tail),
3484    (   Tail == []                          % proper list
3485    ->  Length = Length0
3486    ;   var(Tail)
3487    ->  Extra is Length-Length0,
3488        '$length'(Tail, Extra)
3489    ;   throw(error(type_error(list, List),
3490                    context(length/2, _)))
3491    ).
3492length(_, Length) :-
3493    integer(Length),
3494    !,
3495    throw(error(domain_error(not_less_than_zero, Length),
3496                context(length/2, _))).
3497length(_, Length) :-
3498    throw(error(type_error(integer, Length),
3499                context(length/2, _))).
3500
3501'$length3'([], N, N).
3502'$length3'([_|List], N, N0) :-
3503    N1 is N0+1,
3504    '$length3'(List, N, N1).
3505
3506
3507                 /*******************************
3508                 *       OPTION PROCESSING      *
3509                 *******************************/
3510
3511%!  '$is_options'(@Term) is semidet.
3512%
3513%   True if Term looks like it provides options.
3514
3515'$is_options'(Map) :-
3516    is_dict(Map, _),
3517    !.
3518'$is_options'(List) :-
3519    is_list(List),
3520    (   List == []
3521    ->  true
3522    ;   List = [H|_],
3523        '$is_option'(H, _, _)
3524    ).
3525
3526'$is_option'(Var, _, _) :-
3527    var(Var), !, fail.
3528'$is_option'(F, Name, Value) :-
3529    functor(F, _, 1),
3530    !,
3531    F =.. [Name,Value].
3532'$is_option'(Name=Value, Name, Value).
3533
3534%!  '$option'(?Opt, +Options) is semidet.
3535
3536'$option'(Opt, Options) :-
3537    is_dict(Options),
3538    !,
3539    [Opt] :< Options.
3540'$option'(Opt, Options) :-
3541    memberchk(Opt, Options).
3542
3543%!  '$option'(?Opt, +Options, +Default) is det.
3544
3545'$option'(Term, Options, Default) :-
3546    arg(1, Term, Value),
3547    functor(Term, Name, 1),
3548    (   is_dict(Options)
3549    ->  (   get_dict(Name, Options, GVal)
3550        ->  Value = GVal
3551        ;   Value = Default
3552        )
3553    ;   functor(Gen, Name, 1),
3554        arg(1, Gen, GVal),
3555        (   memberchk(Gen, Options)
3556        ->  Value = GVal
3557        ;   Value = Default
3558        )
3559    ).
3560
3561%!  '$select_option'(?Opt, +Options, -Rest) is semidet.
3562%
3563%   Select an option from Options.
3564%
3565%   @arg Rest is always a map.
3566
3567'$select_option'(Opt, Options, Rest) :-
3568    select_dict([Opt], Options, Rest).
3569
3570%!  '$merge_options'(+New, +Default, -Merged) is det.
3571%
3572%   Add/replace options specified in New.
3573%
3574%   @arg Merged is always a map.
3575
3576'$merge_options'(New, Old, Merged) :-
3577    put_dict(New, Old, Merged).
3578
3579
3580                 /*******************************
3581                 *   HANDLE TRACER 'L'-COMMAND  *
3582                 *******************************/
3583
3584:- public '$prolog_list_goal'/1.
3585
3586:- multifile
3587    user:prolog_list_goal/1.
3588
3589'$prolog_list_goal'(Goal) :-
3590    user:prolog_list_goal(Goal),
3591    !.
3592'$prolog_list_goal'(Goal) :-
3593    user:listing(Goal).
3594
3595
3596                 /*******************************
3597                 *             HALT             *
3598                 *******************************/
3599
3600:- '$iso'((halt/0)).
3601
3602halt :-
3603    halt(0).
3604
3605
3606%!  at_halt(:Goal)
3607%
3608%   Register Goal to be called if the system halts.
3609%
3610%   @tbd: get location into the error message
3611
3612:- meta_predicate at_halt(0).
3613:- dynamic        system:term_expansion/2, '$at_halt'/2.
3614:- multifile      system:term_expansion/2, '$at_halt'/2.
3615
3616system:term_expansion((:- at_halt(Goal)),
3617                      system:'$at_halt'(Module:Goal, File:Line)) :-
3618    \+ current_prolog_flag(xref, true),
3619    source_location(File, Line),
3620    '$current_source_module'(Module).
3621
3622at_halt(Goal) :-
3623    asserta('$at_halt'(Goal, (-):0)).
3624
3625:- public '$run_at_halt'/0.
3626
3627'$run_at_halt' :-
3628    forall(clause('$at_halt'(Goal, Src), true, Ref),
3629           ( '$call_at_halt'(Goal, Src),
3630             erase(Ref)
3631           )).
3632
3633'$call_at_halt'(Goal, _Src) :-
3634    catch(Goal, E, true),
3635    !,
3636    (   var(E)
3637    ->  true
3638    ;   subsumes_term(cancel_halt(_), E)
3639    ->  '$print_message'(informational, E),
3640        fail
3641    ;   '$print_message'(error, E)
3642    ).
3643'$call_at_halt'(Goal, _Src) :-
3644    '$print_message'(warning, goal_failed(at_halt, Goal)).
3645
3646%!  cancel_halt(+Reason)
3647%
3648%   This predicate may be called from   at_halt/1 handlers to cancel
3649%   halting the program. If  causes  halt/0   to  fail  rather  than
3650%   terminating the process.
3651
3652cancel_halt(Reason) :-
3653    throw(cancel_halt(Reason)).
3654
3655
3656                /********************************
3657                *      LOAD OTHER MODULES       *
3658                *********************************/
3659
3660:- meta_predicate
3661    '$load_wic_files'(:).
3662
3663'$load_wic_files'(Files) :-
3664    Files = Module:_,
3665    '$execute_directive'('$set_source_module'(OldM, Module), []),
3666    '$save_lex_state'(LexState, []),
3667    '$style_check'(_, 0xC7),                % see style_name/2 in syspred.pl
3668    '$compilation_mode'(OldC, wic),
3669    consult(Files),
3670    '$execute_directive'('$set_source_module'(OldM), []),
3671    '$execute_directive'('$restore_lex_state'(LexState), []),
3672    '$set_compilation_mode'(OldC).
3673
3674
3675%!  '$load_additional_boot_files' is det.
3676%
3677%   Called from compileFileList() in pl-wic.c.   Gets the files from
3678%   "-c file ..." and loads them into the module user.
3679
3680:- public '$load_additional_boot_files'/0.
3681
3682'$load_additional_boot_files' :-
3683    current_prolog_flag(argv, Argv),
3684    '$get_files_argv'(Argv, Files),
3685    (   Files \== []
3686    ->  format('Loading additional boot files~n'),
3687        '$load_wic_files'(user:Files),
3688        format('additional boot files loaded~n')
3689    ;   true
3690    ).
3691
3692'$:-'((format('Loading Prolog startup files~n', []),
3693       source_location(File, _Line),
3694       file_directory_name(File, Dir),
3695       atom_concat(Dir, '/load.pl', LoadFile),
3696       '$load_wic_files'(system:[LoadFile]),
3697       (   current_prolog_flag(windows, true)
3698       ->  atom_concat(Dir, '/menu.pl', MenuFile),
3699           '$load_wic_files'(system:[MenuFile])
3700       ;   true
3701       ),
3702       format('SWI-Prolog boot files loaded~n', []),
3703       '$compilation_mode'(OldC, wic),
3704       '$execute_directive'('$set_source_module'(user), []),
3705       '$set_compilation_mode'(OldC)
3706      )).