1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 1985-2021, University of Amsterdam 7 VU University Amsterdam 8 CWI, Amsterdam 9 SWI-Prolog Solutions b.v. 10 All rights reserved. 11 12 Redistribution and use in source and binary forms, with or without 13 modification, are permitted provided that the following conditions 14 are met: 15 16 1. Redistributions of source code must retain the above copyright 17 notice, this list of conditions and the following disclaimer. 18 19 2. Redistributions in binary form must reproduce the above copyright 20 notice, this list of conditions and the following disclaimer in 21 the documentation and/or other materials provided with the 22 distribution. 23 24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 29 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 30 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 32 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 33 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 POSSIBILITY OF SUCH DAMAGE. 36*/ 37 38/* 39Consult, derivates and basic things. This module is loaded by the 40C-written bootstrap compiler. 41 42The $:- directive is executed by the bootstrap compiler, but not 43inserted in the intermediate code file. Used to print diagnostic 44messages and start the Prolog defined compiler for the remaining boot 45modules. 46 47If you want to debug this module, put a '$:-'(trace). directive 48somewhere. The tracer will work properly under boot compilation as it 49will use the C defined write predicate to print goals and does not 50attempt to call the Prolog defined trace interceptor. 51*/ 52 53 /******************************** 54 * LOAD INTO MODULE SYSTEM * 55 ********************************/ 56 57:- '$set_source_module'(system). 58 59'$boot_message'(_Format, _Args) :- 60 current_prolog_flag(verbose, silent), 61 !. 62'$boot_message'(Format, Args) :- 63 format(Format, Args), 64 !. 65 66'$:-'('$boot_message'('Loading boot file ...~n', [])).
once(member(E,List))
. Implemented in C.
If List is partial though we need to do the work in Prolog to get
the proper constraint behavior. Needs to be defined early as the
boot code uses it.76memberchk(E, List) :- 77 '$memberchk'(E, List, Tail), 78 ( nonvar(Tail) 79 -> true 80 ; Tail = [_|_], 81 memberchk(E, Tail) 82 ). 83 84 /******************************** 85 * DIRECTIVES * 86 *********************************/ 87 88:- meta_predicate 89 dynamic( ), 90 multifile( ), 91 public( ), 92 module_transparent( ), 93 discontiguous( ), 94 volatile( ), 95 thread_local( ), 96 noprofile( ), 97 non_terminal( ), 98 '$clausable'( ), 99 '$iso'( ), 100 '$hide'( ).
public
also plays this role. in SWI,
public
means that the predicate can be called, even if we cannot
find a reference to it.132dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)). 133multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)). 134module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)). 135discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)). 136volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)). 137thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)). 138noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)). 139public(Spec) :- '$set_pattr'(Spec, pred, public(true)). 140non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)). 141det(Spec) :- '$set_pattr'(Spec, pred, det(true)). 142'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)). 143'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)). 144'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)). 145 146'$set_pattr'(M:Pred, How, Attr) :- 147 '$set_pattr'(Pred, M, How, Attr).
pred
or directive
.153'$set_pattr'(X, _, _, _) :- 154 var(X), 155 '$uninstantiation_error'(X). 156'$set_pattr'(as(Spec,Options), M, How, Attr0) :- 157 !, 158 '$attr_options'(Options, Attr0, Attr), 159 '$set_pattr'(Spec, M, How, Attr). 160'$set_pattr'([], _, _, _) :- !. 161'$set_pattr'([H|T], M, How, Attr) :- % ISO 162 !, 163 '$set_pattr'(H, M, How, Attr), 164 '$set_pattr'(T, M, How, Attr). 165'$set_pattr'((A,B), M, How, Attr) :- % ISO and traditional 166 !, 167 '$set_pattr'(A, M, How, Attr), 168 '$set_pattr'(B, M, How, Attr). 169'$set_pattr'(M:T, _, How, Attr) :- 170 !, 171 '$set_pattr'(T, M, How, Attr). 172'$set_pattr'(PI, M, _, []) :- 173 !, 174 '$pi_head'(M:PI, Pred), 175 '$set_table_wrappers'(Pred). 176'$set_pattr'(A, M, How, [O|OT]) :- 177 !, 178 '$set_pattr'(A, M, How, O), 179 '$set_pattr'(A, M, How, OT). 180'$set_pattr'(A, M, pred, Attr) :- 181 !, 182 Attr =.. [Name,Val], 183 '$set_pi_attr'(M:A, Name, Val). 184'$set_pattr'(A, M, directive, Attr) :- 185 !, 186 Attr =.. [Name,Val], 187 catch('$set_pi_attr'(M:A, Name, Val), 188 error(E, _), 189 print_message(error, error(E, context((Name)/1,_)))). 190 191'$set_pi_attr'(PI, Name, Val) :- 192 '$pi_head'(PI, Head), 193 '$set_predicate_attribute'(Head, Name, Val). 194 195'$attr_options'(Var, _, _) :- 196 var(Var), 197 !, 198 '$uninstantiation_error'(Var). 199'$attr_options'((A,B), Attr0, Attr) :- 200 !, 201 '$attr_options'(A, Attr0, Attr1), 202 '$attr_options'(B, Attr1, Attr). 203'$attr_options'(Opt, Attr0, Attrs) :- 204 '$must_be'(ground, Opt), 205 ( '$attr_option'(Opt, AttrX) 206 -> ( is_list(Attr0) 207 -> '$join_attrs'(AttrX, Attr0, Attrs) 208 ; '$join_attrs'(AttrX, [Attr0], Attrs) 209 ) 210 ; '$domain_error'(predicate_option, Opt) 211 ). 212 213'$join_attrs'([], Attrs, Attrs) :- 214 !. 215'$join_attrs'([H|T], Attrs0, Attrs) :- 216 !, 217 '$join_attrs'(H, Attrs0, Attrs1), 218 '$join_attrs'(T, Attrs1, Attrs). 219'$join_attrs'(Attr, Attrs, Attrs) :- 220 memberchk(Attr, Attrs), 221 !. 222'$join_attrs'(Attr, Attrs, Attrs) :- 223 Attr =.. [Name,Value], 224 Gen =.. [Name,Existing], 225 memberchk(Gen, Attrs), 226 !, 227 throw(error(conflict_error(Name, Value, Existing), _)). 228'$join_attrs'(Attr, Attrs0, Attrs) :- 229 '$append'(Attrs0, [Attr], Attrs). 230 231'$attr_option'(incremental, [incremental(true),opaque(false)]). 232'$attr_option'(monotonic, monotonic(true)). 233'$attr_option'(lazy, lazy(true)). 234'$attr_option'(opaque, [incremental(false),opaque(true)]). 235'$attr_option'(abstract(Level0), abstract(Level)) :- 236 '$table_option'(Level0, Level). 237'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :- 238 '$table_option'(Level0, Level). 239'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :- 240 '$table_option'(Level0, Level). 241'$attr_option'(max_answers(Level0), max_answers(Level)) :- 242 '$table_option'(Level0, Level). 243'$attr_option'(volatile, volatile(true)). 244'$attr_option'(multifile, multifile(true)). 245'$attr_option'(discontiguous, discontiguous(true)). 246'$attr_option'(shared, thread_local(false)). 247'$attr_option'(local, thread_local(true)). 248'$attr_option'(private, thread_local(true)). 249 250'$table_option'(Value0, _Value) :- 251 var(Value0), 252 !, 253 '$instantiation_error'(Value0). 254'$table_option'(Value0, Value) :- 255 integer(Value0), 256 Value0 >= 0, 257 !, 258 Value = Value0. 259'$table_option'(off, -1) :- 260 !. 261'$table_option'(false, -1) :- 262 !. 263'$table_option'(infinite, -1) :- 264 !. 265'$table_option'(Value, _) :- 266 '$domain_error'(nonneg_or_false, Value).
276'$pattr_directive'(dynamic(Spec), M) :- 277 '$set_pattr'(Spec, M, directive, dynamic(true)). 278'$pattr_directive'(multifile(Spec), M) :- 279 '$set_pattr'(Spec, M, directive, multifile(true)). 280'$pattr_directive'(module_transparent(Spec), M) :- 281 '$set_pattr'(Spec, M, directive, transparent(true)). 282'$pattr_directive'(discontiguous(Spec), M) :- 283 '$set_pattr'(Spec, M, directive, discontiguous(true)). 284'$pattr_directive'(volatile(Spec), M) :- 285 '$set_pattr'(Spec, M, directive, volatile(true)). 286'$pattr_directive'(thread_local(Spec), M) :- 287 '$set_pattr'(Spec, M, directive, thread_local(true)). 288'$pattr_directive'(noprofile(Spec), M) :- 289 '$set_pattr'(Spec, M, directive, noprofile(true)). 290'$pattr_directive'(public(Spec), M) :- 291 '$set_pattr'(Spec, M, directive, public(true)). 292'$pattr_directive'(det(Spec), M) :- 293 '$set_pattr'(Spec, M, directive, det(true)).
297'$pi_head'(PI, Head) :- 298 var(PI), 299 var(Head), 300 '$instantiation_error'([PI,Head]). 301'$pi_head'(M:PI, M:Head) :- 302 !, 303 '$pi_head'(PI, Head). 304'$pi_head'(Name/Arity, Head) :- 305 !, 306 '$head_name_arity'(Head, Name, Arity). 307'$pi_head'(Name//DCGArity, Head) :- 308 !, 309 ( nonvar(DCGArity) 310 -> Arity is DCGArity+2, 311 '$head_name_arity'(Head, Name, Arity) 312 ; '$head_name_arity'(Head, Name, Arity), 313 DCGArity is Arity - 2 314 ). 315'$pi_head'(PI, _) :- 316 '$type_error'(predicate_indicator, PI).
321'$head_name_arity'(Goal, Name, Arity) :- 322 ( atom(Goal) 323 -> Name = Goal, Arity = 0 324 ; compound(Goal) 325 -> compound_name_arity(Goal, Name, Arity) 326 ; var(Goal) 327 -> ( Arity == 0 328 -> ( atom(Name) 329 -> Goal = Name 330 ; Name == [] 331 -> Goal = Name 332 ; blob(Name, closure) 333 -> Goal = Name 334 ; '$type_error'(atom, Name) 335 ) 336 ; compound_name_arity(Goal, Name, Arity) 337 ) 338 ; '$type_error'(callable, Goal) 339 ). 340 341:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 342 343 344 /******************************** 345 * CALLING, CONTROL * 346 *********************************/ 347 348:- noprofile((call/1, 349 catch/3, 350 once/1, 351 ignore/1, 352 call_cleanup/2, 353 call_cleanup/3, 354 setup_call_cleanup/3, 355 setup_call_catcher_cleanup/4)). 356 357:- meta_predicate 358 ';'( , ), 359 ','( , ), 360 @( , ), 361 call( ), 362 call( , ), 363 call( , , ), 364 call( , , , ), 365 call( , , , , ), 366 call( , , , , , ), 367 call( , , , , , , ), 368 call( , , , , , , , ), 369 not( ), 370 \+( ), 371 $( ), 372 '->'( , ), 373 '*->'( , ), 374 once( ), 375 ignore( ), 376 catch( , , ), 377 reset( , , ), 378 setup_call_cleanup( , , ), 379 setup_call_catcher_cleanup( , , , ), 380 call_cleanup( , ), 381 call_cleanup( , , ), 382 catch_with_backtrace( , , ), 383 '$meta_call'( ). 384 385:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 386 387% The control structures are always compiled, both if they appear in a 388% clause body and if they are handed to call/1. The only way to call 389% these predicates is by means of call/2.. In that case, we call the 390% hole control structure again to get it compiled by call/1 and properly 391% deal with !, etc. Another reason for having these things as 392% predicates is to be able to define properties for them, helping code 393% analyzers. 394 395(M0:If ; M0:Then) :- !, call(M0:(If ; Then)). 396(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)). 397(G1 , G2) :- call((G1 , G2)). 398(If -> Then) :- call((If -> Then)). 399(If *-> Then) :- call((If *-> Then)). 400@(Goal,Module) :- @(Goal,Module).
This implementation is used by reset/3 because the continuation cannot be captured if it contains a such a compiled temporary clause.
414'$meta_call'(M:G) :- 415 prolog_current_choice(Ch), 416 '$meta_call'(G, M, Ch). 417 418'$meta_call'(Var, _, _) :- 419 var(Var), 420 !, 421 '$instantiation_error'(Var). 422'$meta_call'((A,B), M, Ch) :- 423 !, 424 '$meta_call'(A, M, Ch), 425 '$meta_call'(B, M, Ch). 426'$meta_call'((I->T;E), M, Ch) :- 427 !, 428 ( prolog_current_choice(Ch2), 429 '$meta_call'(I, M, Ch2) 430 -> '$meta_call'(T, M, Ch) 431 ; '$meta_call'(E, M, Ch) 432 ). 433'$meta_call'((I*->T;E), M, Ch) :- 434 !, 435 ( prolog_current_choice(Ch2), 436 '$meta_call'(I, M, Ch2) 437 *-> '$meta_call'(T, M, Ch) 438 ; '$meta_call'(E, M, Ch) 439 ). 440'$meta_call'((I->T), M, Ch) :- 441 !, 442 ( prolog_current_choice(Ch2), 443 '$meta_call'(I, M, Ch2) 444 -> '$meta_call'(T, M, Ch) 445 ). 446'$meta_call'((I*->T), M, Ch) :- 447 !, 448 prolog_current_choice(Ch2), 449 '$meta_call'(I, M, Ch2), 450 '$meta_call'(T, M, Ch). 451'$meta_call'((A;B), M, Ch) :- 452 !, 453 ( '$meta_call'(A, M, Ch) 454 ; '$meta_call'(B, M, Ch) 455 ). 456'$meta_call'(\+(G), M, _) :- 457 !, 458 prolog_current_choice(Ch), 459 \+ '$meta_call'(G, M, Ch). 460'$meta_call'($(G), M, _) :- 461 !, 462 prolog_current_choice(Ch), 463 $('$meta_call'(G, M, Ch)). 464'$meta_call'(call(G), M, _) :- 465 !, 466 prolog_current_choice(Ch), 467 '$meta_call'(G, M, Ch). 468'$meta_call'(M:G, _, Ch) :- 469 !, 470 '$meta_call'(G, M, Ch). 471'$meta_call'(!, _, Ch) :- 472 prolog_cut_to(Ch). 473'$meta_call'(G, M, _Ch) :- 474 call(M:G).
490:- '$iso'((call/2, 491 call/3, 492 call/4, 493 call/5, 494 call/6, 495 call/7, 496 call/8)). 497 498call(Goal) :- % make these available as predicates 499 . 500call(Goal, A) :- 501 call(Goal, A). 502call(Goal, A, B) :- 503 call(Goal, A, B). 504call(Goal, A, B, C) :- 505 call(Goal, A, B, C). 506call(Goal, A, B, C, D) :- 507 call(Goal, A, B, C, D). 508call(Goal, A, B, C, D, E) :- 509 call(Goal, A, B, C, D, E). 510call(Goal, A, B, C, D, E, F) :- 511 call(Goal, A, B, C, D, E, F). 512call(Goal, A, B, C, D, E, F, G) :- 513 call(Goal, A, B, C, D, E, F, G).
520not(Goal) :-
521 \+ .
527\+ Goal :-
528 \+ .
call((Goal, !))
.
534once(Goal) :-
535 ,
536 !.
543ignore(Goal) :- 544 , 545 !. 546ignore(_Goal). 547 548:- '$iso'((false/0)).
554false :-
555 fail.
561catch(_Goal, _Catcher, _Recover) :- 562 '$catch'. % Maps to I_CATCH, I_EXITCATCH
568prolog_cut_to(_Choice) :- 569 '$cut'. % Maps to I_CUTCHP
575'$' :- '$'.
581$(Goal) :- $(Goal).
587reset(_Goal, _Ball, _Cont) :-
588 '$reset'.
597shift(Ball) :- 598 '$shift'(Ball). 599 600shift_for_copy(Ball) :- 601 '$shift_for_copy'(Ball).
Note that we can technically also push the entire continuation onto the environment and call it. Doing it incrementally as below exploits last-call optimization and therefore possible quadratic expansion of the continuation.
615call_continuation([]). 616call_continuation([TB|Rest]) :- 617 ( Rest == [] 618 -> '$call_continuation'(TB) 619 ; '$call_continuation'(TB), 620 call_continuation(Rest) 621 ).
628catch_with_backtrace(Goal, Ball, Recover) :- 629 catch(Goal, Ball, Recover), 630 '$no_lco'. 631 632'$no_lco'.
642:- public '$recover_and_rethrow'/2. 643 644'$recover_and_rethrow'(Goal, Exception) :- 645 call_cleanup(Goal, throw(Exception)), 646 !.
661setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :- 662 sig_atomic(Setup), 663 '$call_cleanup'. 664 665setup_call_cleanup(Setup, Goal, Cleanup) :- 666 setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup). 667 668call_cleanup(Goal, Cleanup) :- 669 setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup). 670 671call_cleanup(Goal, Catcher, Cleanup) :- 672 setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup). 673 674 /******************************* 675 * INITIALIZATION * 676 *******************************/ 677 678:- meta_predicate 679 initialization( , ). 680 681:- multifile '$init_goal'/3. 682:- dynamic '$init_goal'/3.
-g goal
goals.Note that all goals are executed when a program is restored.
708initialization(Goal, When) :- 709 '$must_be'(oneof(atom, initialization_type, 710 [ now, 711 after_load, 712 restore, 713 restore_state, 714 prepare_state, 715 program, 716 main 717 ]), When), 718 '$initialization_context'(Source, Ctx), 719 '$initialization'(When, Goal, Source, Ctx). 720 721'$initialization'(now, Goal, _Source, Ctx) :- 722 '$run_init_goal'(Goal, Ctx), 723 '$compile_init_goal'(-, Goal, Ctx). 724'$initialization'(after_load, Goal, Source, Ctx) :- 725 ( Source \== (-) 726 -> '$compile_init_goal'(Source, Goal, Ctx) 727 ; throw(error(context_error(nodirective, 728 initialization(Goal, after_load)), 729 _)) 730 ). 731'$initialization'(restore, Goal, Source, Ctx) :- % deprecated 732 '$initialization'(restore_state, Goal, Source, Ctx). 733'$initialization'(restore_state, Goal, _Source, Ctx) :- 734 ( \+ current_prolog_flag(sandboxed_load, true) 735 -> '$compile_init_goal'(-, Goal, Ctx) 736 ; '$permission_error'(register, initialization(restore), Goal) 737 ). 738'$initialization'(prepare_state, Goal, _Source, Ctx) :- 739 ( \+ current_prolog_flag(sandboxed_load, true) 740 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx) 741 ; '$permission_error'(register, initialization(restore), Goal) 742 ). 743'$initialization'(program, Goal, _Source, Ctx) :- 744 ( \+ current_prolog_flag(sandboxed_load, true) 745 -> '$compile_init_goal'(when(program), Goal, Ctx) 746 ; '$permission_error'(register, initialization(restore), Goal) 747 ). 748'$initialization'(main, Goal, _Source, Ctx) :- 749 ( \+ current_prolog_flag(sandboxed_load, true) 750 -> '$compile_init_goal'(when(main), Goal, Ctx) 751 ; '$permission_error'(register, initialization(restore), Goal) 752 ). 753 754 755'$compile_init_goal'(Source, Goal, Ctx) :- 756 atom(Source), 757 Source \== (-), 758 !, 759 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx), 760 _Layout, Source, Ctx). 761'$compile_init_goal'(Source, Goal, Ctx) :- 762 assertz('$init_goal'(Source, Goal, Ctx)).
runInitialization()
in pl-wic.c for .qlf files. The
'$run_initialization'/3 is called with Action set to loaded
when called for a QLF file.774'$run_initialization'(_, loaded, _) :- !. 775'$run_initialization'(File, _Action, Options) :- 776 '$run_initialization'(File, Options). 777 778'$run_initialization'(File, Options) :- 779 setup_call_cleanup( 780 '$start_run_initialization'(Options, Restore), 781 '$run_initialization_2'(File), 782 '$end_run_initialization'(Restore)). 783 784'$start_run_initialization'(Options, OldSandBoxed) :- 785 '$push_input_context'(initialization), 786 '$set_sandboxed_load'(Options, OldSandBoxed). 787'$end_run_initialization'(OldSandBoxed) :- 788 set_prolog_flag(sandboxed_load, OldSandBoxed), 789 '$pop_input_context'. 790 791'$run_initialization_2'(File) :- 792 ( '$init_goal'(File, Goal, Ctx), 793 File \= when(_), 794 '$run_init_goal'(Goal, Ctx), 795 fail 796 ; true 797 ). 798 799'$run_init_goal'(Goal, Ctx) :- 800 ( catch_with_backtrace('$run_init_goal'(Goal), E, 801 '$initialization_error'(E, Goal, Ctx)) 802 -> true 803 ; '$initialization_failure'(Goal, Ctx) 804 ). 805 806:- multifile prolog:sandbox_allowed_goal/1. 807 808'$run_init_goal'(Goal) :- 809 current_prolog_flag(sandboxed_load, false), 810 !, 811 call(Goal). 812'$run_init_goal'(Goal) :- 813 prolog:sandbox_allowed_goal(Goal), 814 call(Goal). 815 816'$initialization_context'(Source, Ctx) :- 817 ( source_location(File, Line) 818 -> Ctx = File:Line, 819 '$input_context'(Context), 820 '$top_file'(Context, File, Source) 821 ; Ctx = (-), 822 File = (-) 823 ). 824 825'$top_file'([input(include, F1, _, _)|T], _, F) :- 826 !, 827 '$top_file'(T, F1, F). 828'$top_file'(_, F, F). 829 830 831'$initialization_error'(E, Goal, Ctx) :- 832 print_message(error, initialization_error(Goal, E, Ctx)). 833 834'$initialization_failure'(Goal, Ctx) :- 835 print_message(warning, initialization_failure(Goal, Ctx)).
843:- public '$clear_source_admin'/1. 844 845'$clear_source_admin'(File) :- 846 retractall('$init_goal'(_, _, File:_)), 847 retractall('$load_context_module'(File, _, _)), 848 retractall('$resolved_source_path_db'(_, _, File)). 849 850 851 /******************************* 852 * STREAM * 853 *******************************/ 854 855:- '$iso'(stream_property/2). 856stream_property(Stream, Property) :- 857 nonvar(Stream), 858 nonvar(Property), 859 !, 860 '$stream_property'(Stream, Property). 861stream_property(Stream, Property) :- 862 nonvar(Stream), 863 !, 864 '$stream_properties'(Stream, Properties), 865 '$member'(Property, Properties). 866stream_property(Stream, Property) :- 867 nonvar(Property), 868 !, 869 ( Property = alias(Alias), 870 atom(Alias) 871 -> '$alias_stream'(Alias, Stream) 872 ; '$streams_properties'(Property, Pairs), 873 '$member'(Stream-Property, Pairs) 874 ). 875stream_property(Stream, Property) :- 876 '$streams_properties'(Property, Pairs), 877 '$member'(Stream-Properties, Pairs), 878 '$member'(Property, Properties). 879 880 881 /******************************** 882 * MODULES * 883 *********************************/ 884 885% '$prefix_module'(+Module, +Context, +Term, -Prefixed) 886% Tags `Term' with `Module:' if `Module' is not the context module. 887 888'$prefix_module'(Module, Module, Head, Head) :- !. 889'$prefix_module'(Module, _, Head, Module:Head).
895default_module(Me, Super) :- 896 ( atom(Me) 897 -> ( var(Super) 898 -> '$default_module'(Me, Super) 899 ; '$default_module'(Me, Super), ! 900 ) 901 ; '$type_error'(module, Me) 902 ). 903 904'$default_module'(Me, Me). 905'$default_module'(Me, Super) :- 906 import_module(Me, S), 907 '$default_module'(S, Super). 908 909 910 /******************************** 911 * TRACE AND EXCEPTIONS * 912 *********************************/ 913 914:- dynamic user:exception/3. 915:- multifile user:exception/3. 916:- '$hide'(user:exception/3).
925:- public 926 '$undefined_procedure'/4. 927 928'$undefined_procedure'(Module, Name, Arity, Action) :- 929 '$prefix_module'(Module, user, Name/Arity, Pred), 930 user:exception(undefined_predicate, Pred, Action0), 931 !, 932 Action = Action0. 933'$undefined_procedure'(Module, Name, Arity, Action) :- 934 \+ current_prolog_flag(autoload, false), 935 '$autoload'(Module:Name/Arity), 936 !, 937 Action = retry. 938'$undefined_procedure'(_, _, _, error).
950'$loading'(Library) :- 951 current_prolog_flag(threads, true), 952 ( '$loading_file'(Library, _Queue, _LoadThread) 953 -> true 954 ; '$loading_file'(FullFile, _Queue, _LoadThread), 955 file_name_extension(Library, _, FullFile) 956 -> true 957 ). 958 959% handle debugger 'w', 'p' and <N> depth options. 960 961'$set_debugger_write_options'(write) :- 962 !, 963 create_prolog_flag(debugger_write_options, 964 [ quoted(true), 965 attributes(dots), 966 spacing(next_argument) 967 ], []). 968'$set_debugger_write_options'(print) :- 969 !, 970 create_prolog_flag(debugger_write_options, 971 [ quoted(true), 972 portray(true), 973 max_depth(10), 974 attributes(portray), 975 spacing(next_argument) 976 ], []). 977'$set_debugger_write_options'(Depth) :- 978 current_prolog_flag(debugger_write_options, Options0), 979 ( '$select'(max_depth(_), Options0, Options) 980 -> true 981 ; Options = Options0 982 ), 983 create_prolog_flag(debugger_write_options, 984 [max_depth(Depth)|Options], []). 985 986 987 /******************************** 988 * SYSTEM MESSAGES * 989 *********************************/
996'$confirm'(Spec) :- 997 print_message(query, Spec), 998 between(0, 5, _), 999 get_single_char(Answer), 1000 ( '$in_reply'(Answer, 'yYjJ \n') 1001 -> !, 1002 print_message(query, if_tty([yes-[]])) 1003 ; '$in_reply'(Answer, 'nN') 1004 -> !, 1005 print_message(query, if_tty([no-[]])), 1006 fail 1007 ; print_message(help, query(confirm)), 1008 fail 1009 ). 1010 1011'$in_reply'(Code, Atom) :- 1012 char_code(Char, Code), 1013 sub_atom(Atom, _, _, _, Char), 1014 !. 1015 1016:- dynamic 1017 user:portray/1. 1018:- multifile 1019 user:portray/1. 1020 1021 1022 /******************************* 1023 * FILE_SEARCH_PATH * 1024 *******************************/ 1025 1026:- dynamic 1027 user:file_search_path/2, 1028 user:library_directory/1. 1029:- multifile 1030 user:file_search_path/2, 1031 user:library_directory/1. 1032 1033user(file_search_path(library, Dir) :- 1034 library_directory(Dir)). 1035user:file_search_path(swi, Home) :- 1036 current_prolog_flag(home, Home). 1037user:file_search_path(swi, Home) :- 1038 current_prolog_flag(shared_home, Home). 1039user:file_search_path(library, app_config(lib)). 1040user:file_search_path(library, swi(library)). 1041user:file_search_path(library, swi(library/clp)). 1042user:file_search_path(foreign, swi(ArchLib)) :- 1043 current_prolog_flag(apple_universal_binary, true), 1044 ArchLib = 'lib/fat-darwin'. 1045user:file_search_path(foreign, swi(ArchLib)) :- 1046 \+ current_prolog_flag(windows, true), 1047 current_prolog_flag(arch, Arch), 1048 atom_concat('lib/', Arch, ArchLib). 1049user:file_search_path(foreign, swi(SoLib)) :- 1050 ( current_prolog_flag(windows, true) 1051 -> SoLib = bin 1052 ; SoLib = lib 1053 ). 1054user:file_search_path(path, Dir) :- 1055 getenv('PATH', Path), 1056 ( current_prolog_flag(windows, true) 1057 -> atomic_list_concat(Dirs, (;), Path) 1058 ; atomic_list_concat(Dirs, :, Path) 1059 ), 1060 '$member'(Dir, Dirs). 1061user:file_search_path(user_app_data, Dir) :- 1062 '$xdg_prolog_directory'(data, Dir). 1063user:file_search_path(common_app_data, Dir) :- 1064 '$xdg_prolog_directory'(common_data, Dir). 1065user:file_search_path(user_app_config, Dir) :- 1066 '$xdg_prolog_directory'(config, Dir). 1067user:file_search_path(common_app_config, Dir) :- 1068 '$xdg_prolog_directory'(common_config, Dir). 1069user:file_search_path(app_data, user_app_data('.')). 1070user:file_search_path(app_data, common_app_data('.')). 1071user:file_search_path(app_config, user_app_config('.')). 1072user:file_search_path(app_config, common_app_config('.')). 1073% backward compatibility 1074user:file_search_path(app_preferences, user_app_config('.')). 1075user:file_search_path(user_profile, app_preferences('.')). 1076 1077'$xdg_prolog_directory'(Which, Dir) :- 1078 '$xdg_directory'(Which, XDGDir), 1079 '$make_config_dir'(XDGDir), 1080 '$ensure_slash'(XDGDir, XDGDirS), 1081 atom_concat(XDGDirS, 'swi-prolog', Dir), 1082 '$make_config_dir'(Dir). 1083 1084% config 1085'$xdg_directory'(config, Home) :- 1086 current_prolog_flag(windows, true), 1087 catch(win_folder(appdata, Home), _, fail), 1088 !. 1089'$xdg_directory'(config, Home) :- 1090 getenv('XDG_CONFIG_HOME', Home). 1091'$xdg_directory'(config, Home) :- 1092 expand_file_name('~/.config', [Home]). 1093% data 1094'$xdg_directory'(data, Home) :- 1095 current_prolog_flag(windows, true), 1096 catch(win_folder(local_appdata, Home), _, fail), 1097 !. 1098'$xdg_directory'(data, Home) :- 1099 getenv('XDG_DATA_HOME', Home). 1100'$xdg_directory'(data, Home) :- 1101 expand_file_name('~/.local', [Local]), 1102 '$make_config_dir'(Local), 1103 atom_concat(Local, '/share', Home), 1104 '$make_config_dir'(Home). 1105% common data 1106'$xdg_directory'(common_data, Dir) :- 1107 current_prolog_flag(windows, true), 1108 catch(win_folder(common_appdata, Dir), _, fail), 1109 !. 1110'$xdg_directory'(common_data, Dir) :- 1111 '$existing_dir_from_env_path'('XDG_DATA_DIRS', 1112 [ '/usr/local/share', 1113 '/usr/share' 1114 ], 1115 Dir). 1116% common config 1117'$xdg_directory'(common_config, Dir) :- 1118 current_prolog_flag(windows, true), 1119 catch(win_folder(common_appdata, Dir), _, fail), 1120 !. 1121'$xdg_directory'(common_config, Dir) :- 1122 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir). 1123 1124'$existing_dir_from_env_path'(Env, Defaults, Dir) :- 1125 ( getenv(Env, Path) 1126 -> '$path_sep'(Sep), 1127 atomic_list_concat(Dirs, Sep, Path) 1128 ; Dirs = Defaults 1129 ), 1130 '$member'(Dir, Dirs), 1131 Dir \== '', 1132 exists_directory(Dir). 1133 1134'$path_sep'(Char) :- 1135 ( current_prolog_flag(windows, true) 1136 -> Char = ';' 1137 ; Char = ':' 1138 ). 1139 1140'$make_config_dir'(Dir) :- 1141 exists_directory(Dir), 1142 !. 1143'$make_config_dir'(Dir) :- 1144 nb_current('$create_search_directories', true), 1145 file_directory_name(Dir, Parent), 1146 '$my_file'(Parent), 1147 catch(make_directory(Dir), _, fail). 1148 1149'$ensure_slash'(Dir, DirS) :- 1150 ( sub_atom(Dir, _, _, 0, /) 1151 -> DirS = Dir 1152 ; atom_concat(Dir, /, DirS) 1153 ).
1158'$expand_file_search_path'(Spec, Expanded, Cond) :- 1159 '$option'(access(Access), Cond), 1160 memberchk(Access, [write,append]), 1161 !, 1162 setup_call_cleanup( 1163 nb_setval('$create_search_directories', true), 1164 expand_file_search_path(Spec, Expanded), 1165 nb_delete('$create_search_directories')). 1166'$expand_file_search_path'(Spec, Expanded, _Cond) :- 1167 expand_file_search_path(Spec, Expanded).
1175expand_file_search_path(Spec, Expanded) :- 1176 catch('$expand_file_search_path'(Spec, Expanded, 0, []), 1177 loop(Used), 1178 throw(error(loop_error(Spec), file_search(Used)))). 1179 1180'$expand_file_search_path'(Spec, Expanded, N, Used) :- 1181 functor(Spec, Alias, 1), 1182 !, 1183 user:file_search_path(Alias, Exp0), 1184 NN is N + 1, 1185 ( NN > 16 1186 -> throw(loop(Used)) 1187 ; true 1188 ), 1189 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]), 1190 arg(1, Spec, Segments), 1191 '$segments_to_atom'(Segments, File), 1192 '$make_path'(Exp1, File, Expanded). 1193'$expand_file_search_path'(Spec, Path, _, _) :- 1194 '$segments_to_atom'(Spec, Path). 1195 1196'$make_path'(Dir, '.', Path) :- 1197 !, 1198 Path = Dir. 1199'$make_path'(Dir, File, Path) :- 1200 sub_atom(Dir, _, _, 0, /), 1201 !, 1202 atom_concat(Dir, File, Path). 1203'$make_path'(Dir, File, Path) :- 1204 atomic_list_concat([Dir, /, File], Path). 1205 1206 1207 /******************************** 1208 * FILE CHECKING * 1209 *********************************/
1220absolute_file_name(Spec, Options, Path) :- 1221 '$is_options'(Options), 1222 \+ '$is_options'(Path), 1223 !, 1224 absolute_file_name(Spec, Path, Options). 1225absolute_file_name(Spec, Path, Options) :- 1226 '$must_be'(options, Options), 1227 % get the valid extensions 1228 ( '$select_option'(extensions(Exts), Options, Options1) 1229 -> '$must_be'(list, Exts) 1230 ; '$option'(file_type(Type), Options) 1231 -> '$must_be'(atom, Type), 1232 '$file_type_extensions'(Type, Exts), 1233 Options1 = Options 1234 ; Options1 = Options, 1235 Exts = [''] 1236 ), 1237 '$canonicalise_extensions'(Exts, Extensions), 1238 % unless specified otherwise, ask regular file 1239 ( ( nonvar(Type) 1240 ; '$option'(access(none), Options, none) 1241 ) 1242 -> Options2 = Options1 1243 ; '$merge_options'(_{file_type:regular}, Options1, Options2) 1244 ), 1245 % Det or nondet? 1246 ( '$select_option'(solutions(Sols), Options2, Options3) 1247 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols) 1248 ; Sols = first, 1249 Options3 = Options2 1250 ), 1251 % Errors or not? 1252 ( '$select_option'(file_errors(FileErrors), Options3, Options4) 1253 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors) 1254 ; FileErrors = error, 1255 Options4 = Options3 1256 ), 1257 % Expand shell patterns? 1258 ( atomic(Spec), 1259 '$select_option'(expand(Expand), Options4, Options5), 1260 '$must_be'(boolean, Expand) 1261 -> expand_file_name(Spec, List), 1262 '$member'(Spec1, List) 1263 ; Spec1 = Spec, 1264 Options5 = Options4 1265 ), 1266 % Search for files 1267 ( Sols == first 1268 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path) 1269 -> ! % also kill choice point of expand_file_name/2 1270 ; ( FileErrors == fail 1271 -> fail 1272 ; '$current_module'('$bags', _File), 1273 findall(P, 1274 '$chk_file'(Spec1, Extensions, [access(exist)], 1275 false, P), 1276 Candidates), 1277 '$abs_file_error'(Spec, Candidates, Options5) 1278 ) 1279 ) 1280 ; '$chk_file'(Spec1, Extensions, Options5, false, Path) 1281 ). 1282 1283'$abs_file_error'(Spec, Candidates, Conditions) :- 1284 '$member'(F, Candidates), 1285 '$member'(C, Conditions), 1286 '$file_condition'(C), 1287 '$file_error'(C, Spec, F, E, Comment), 1288 !, 1289 throw(error(E, context(_, Comment))). 1290'$abs_file_error'(Spec, _, _) :- 1291 '$existence_error'(source_sink, Spec). 1292 1293'$file_error'(file_type(directory), Spec, File, Error, Comment) :- 1294 \+ exists_directory(File), 1295 !, 1296 Error = existence_error(directory, Spec), 1297 Comment = not_a_directory(File). 1298'$file_error'(file_type(_), Spec, File, Error, Comment) :- 1299 exists_directory(File), 1300 !, 1301 Error = existence_error(file, Spec), 1302 Comment = directory(File). 1303'$file_error'(access(OneOrList), Spec, File, Error, _) :- 1304 '$one_or_member'(Access, OneOrList), 1305 \+ access_file(File, Access), 1306 Error = permission_error(Access, source_sink, Spec). 1307 1308'$one_or_member'(Elem, List) :- 1309 is_list(List), 1310 !, 1311 '$member'(Elem, List). 1312'$one_or_member'(Elem, Elem). 1313 1314 1315'$file_type_extensions'(source, Exts) :- % SICStus 3.9 compatibility 1316 !, 1317 '$file_type_extensions'(prolog, Exts). 1318'$file_type_extensions'(Type, Exts) :- 1319 '$current_module'('$bags', _File), 1320 !, 1321 findall(Ext, user:prolog_file_type(Ext, Type), Exts0), 1322 ( Exts0 == [], 1323 \+ '$ft_no_ext'(Type) 1324 -> '$domain_error'(file_type, Type) 1325 ; true 1326 ), 1327 '$append'(Exts0, [''], Exts). 1328'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ... 1329 1330'$ft_no_ext'(txt). 1331'$ft_no_ext'(executable). 1332'$ft_no_ext'(directory). 1333'$ft_no_ext'(regular).
Note that qlf
must be last when searching for Prolog files.
Otherwise use_module/1 will consider the file as not-loaded
because the .qlf file is not the loaded file. Must be fixed
elsewhere.
1346:- multifile(user:prolog_file_type/2). 1347:- dynamic(user:prolog_file_type/2). 1348 1349userprolog_file_type(pl, prolog). 1350userprolog_file_type(prolog, prolog). 1351userprolog_file_type(qlf, prolog). 1352userprolog_file_type(qlf, qlf). 1353userprolog_file_type(Ext, executable) :- 1354 current_prolog_flag(shared_object_extension, Ext). 1355userprolog_file_type(dylib, executable) :- 1356 current_prolog_flag(apple, true).
1363'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :- 1364 \+ ground(Spec), 1365 !, 1366 '$instantiation_error'(Spec). 1367'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :- 1368 compound(Spec), 1369 functor(Spec, _, 1), 1370 !, 1371 '$relative_to'(Cond, cwd, CWD), 1372 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName). 1373'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- % allow a/b/... 1374 \+ atomic(Segments), 1375 !, 1376 '$segments_to_atom'(Segments, Atom), 1377 '$chk_file'(Atom, Ext, Cond, Cache, FullName). 1378'$chk_file'(File, Exts, Cond, _, FullName) :- 1379 is_absolute_file_name(File), 1380 !, 1381 '$extend_file'(File, Exts, Extended), 1382 '$file_conditions'(Cond, Extended), 1383 '$absolute_file_name'(Extended, FullName). 1384'$chk_file'(File, Exts, Cond, _, FullName) :- 1385 '$relative_to'(Cond, source, Dir), 1386 atomic_list_concat([Dir, /, File], AbsFile), 1387 '$extend_file'(AbsFile, Exts, Extended), 1388 '$file_conditions'(Cond, Extended), 1389 !, 1390 '$absolute_file_name'(Extended, FullName). 1391'$chk_file'(File, Exts, Cond, _, FullName) :- 1392 '$extend_file'(File, Exts, Extended), 1393 '$file_conditions'(Cond, Extended), 1394 '$absolute_file_name'(Extended, FullName). 1395 1396'$segments_to_atom'(Atom, Atom) :- 1397 atomic(Atom), 1398 !. 1399'$segments_to_atom'(Segments, Atom) :- 1400 '$segments_to_list'(Segments, List, []), 1401 !, 1402 atomic_list_concat(List, /, Atom). 1403 1404'$segments_to_list'(A/B, H, T) :- 1405 '$segments_to_list'(A, H, T0), 1406 '$segments_to_list'(B, T0, T). 1407'$segments_to_list'(A, [A|T], T) :- 1408 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1418'$relative_to'(Conditions, Default, Dir) :-
1419 ( '$option'(relative_to(FileOrDir), Conditions)
1420 *-> ( exists_directory(FileOrDir)
1421 -> Dir = FileOrDir
1422 ; atom_concat(Dir, /, FileOrDir)
1423 -> true
1424 ; file_directory_name(FileOrDir, Dir)
1425 )
1426 ; Default == cwd
1427 -> '$cwd'(Dir)
1428 ; Default == source
1429 -> source_location(ContextFile, _Line),
1430 file_directory_name(ContextFile, Dir)
1431 ).
1436:- dynamic 1437 '$search_path_file_cache'/3, % SHA1, Time, Path 1438 '$search_path_gc_time'/1. % Time 1439:- volatile 1440 '$search_path_file_cache'/3, 1441 '$search_path_gc_time'/1. 1442 1443:- create_prolog_flag(file_search_cache_time, 10, []). 1444 1445'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1446 !, 1447 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1448 current_prolog_flag(emulated_dialect, Dialect), 1449 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1450 variant_sha1(Spec+Cache, SHA1), 1451 get_time(Now), 1452 current_prolog_flag(file_search_cache_time, TimeOut), 1453 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1454 CachedTime > Now - TimeOut, 1455 '$file_conditions'(Cond, FullFile) 1456 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1457 ; '$member'(Expanded, Expansions), 1458 '$extend_file'(Expanded, Exts, LibFile), 1459 ( '$file_conditions'(Cond, LibFile), 1460 '$absolute_file_name'(LibFile, FullFile), 1461 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1462 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1463 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1464 fail 1465 ) 1466 ). 1467'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1468 '$expand_file_search_path'(Spec, Expanded, Cond), 1469 '$extend_file'(Expanded, Exts, LibFile), 1470 '$file_conditions'(Cond, LibFile), 1471 '$absolute_file_name'(LibFile, FullFile). 1472 1473'$cache_file_found'(_, _, TimeOut, _) :- 1474 TimeOut =:= 0, 1475 !. 1476'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1477 '$search_path_file_cache'(SHA1, Saved, FullFile), 1478 !, 1479 ( Now - Saved < TimeOut/2 1480 -> true 1481 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1482 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1483 ). 1484'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1485 'gc_file_search_cache'(TimeOut), 1486 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1487 1488'gc_file_search_cache'(TimeOut) :- 1489 get_time(Now), 1490 '$search_path_gc_time'(Last), 1491 Now-Last < TimeOut/2, 1492 !. 1493'gc_file_search_cache'(TimeOut) :- 1494 get_time(Now), 1495 retractall('$search_path_gc_time'(_)), 1496 assertz('$search_path_gc_time'(Now)), 1497 Before is Now - TimeOut, 1498 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1499 Cached < Before, 1500 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1501 fail 1502 ; true 1503 ). 1504 1505 1506'$search_message'(Term) :- 1507 current_prolog_flag(verbose_file_search, true), 1508 !, 1509 print_message(informational, Term). 1510'$search_message'(_).
1517'$file_conditions'(List, File) :- 1518 is_list(List), 1519 !, 1520 \+ ( '$member'(C, List), 1521 '$file_condition'(C), 1522 \+ '$file_condition'(C, File) 1523 ). 1524'$file_conditions'(Map, File) :- 1525 \+ ( get_dict(Key, Map, Value), 1526 C =.. [Key,Value], 1527 '$file_condition'(C), 1528 \+ '$file_condition'(C, File) 1529 ). 1530 1531'$file_condition'(file_type(directory), File) :- 1532 !, 1533 exists_directory(File). 1534'$file_condition'(file_type(_), File) :- 1535 !, 1536 \+ exists_directory(File). 1537'$file_condition'(access(Accesses), File) :- 1538 !, 1539 \+ ( '$one_or_member'(Access, Accesses), 1540 \+ access_file(File, Access) 1541 ). 1542 1543'$file_condition'(exists). 1544'$file_condition'(file_type(_)). 1545'$file_condition'(access(_)). 1546 1547'$extend_file'(File, Exts, FileEx) :- 1548 '$ensure_extensions'(Exts, File, Fs), 1549 '$list_to_set'(Fs, FsSet), 1550 '$member'(FileEx, FsSet). 1551 1552'$ensure_extensions'([], _, []). 1553'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1554 file_name_extension(F, E, FE), 1555 '$ensure_extensions'(E0, F, E1).
1562'$list_to_set'(List, Set) :- 1563 '$number_list'(List, 1, Numbered), 1564 sort(1, @=<, Numbered, ONum), 1565 '$remove_dup_keys'(ONum, NumSet), 1566 sort(2, @=<, NumSet, ONumSet), 1567 '$pairs_keys'(ONumSet, Set). 1568 1569'$number_list'([], _, []). 1570'$number_list'([H|T0], N, [H-N|T]) :- 1571 N1 is N+1, 1572 '$number_list'(T0, N1, T). 1573 1574'$remove_dup_keys'([], []). 1575'$remove_dup_keys'([H|T0], [H|T]) :- 1576 H = V-_, 1577 '$remove_same_key'(T0, V, T1), 1578 '$remove_dup_keys'(T1, T). 1579 1580'$remove_same_key'([V1-_|T0], V, T) :- 1581 V1 == V, 1582 !, 1583 '$remove_same_key'(T0, V, T). 1584'$remove_same_key'(L, _, L). 1585 1586'$pairs_keys'([], []). 1587'$pairs_keys'([K-_|T0], [K|T]) :- 1588 '$pairs_keys'(T0, T). 1589 1590 1591/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1592Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1593the Quintus compatibility requests `pl'. This layer canonicalises all 1594extensions to .ext 1595- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1596 1597'$canonicalise_extensions'([], []) :- !. 1598'$canonicalise_extensions'([H|T], [CH|CT]) :- 1599 !, 1600 '$must_be'(atom, H), 1601 '$canonicalise_extension'(H, CH), 1602 '$canonicalise_extensions'(T, CT). 1603'$canonicalise_extensions'(E, [CE]) :- 1604 '$canonicalise_extension'(E, CE). 1605 1606'$canonicalise_extension'('', '') :- !. 1607'$canonicalise_extension'(DotAtom, DotAtom) :- 1608 sub_atom(DotAtom, 0, _, _, '.'), 1609 !. 1610'$canonicalise_extension'(Atom, DotAtom) :- 1611 atom_concat('.', Atom, DotAtom). 1612 1613 1614 /******************************** 1615 * CONSULT * 1616 *********************************/ 1617 1618:- dynamic 1619 user:library_directory/1, 1620 user:prolog_load_file/2. 1621:- multifile 1622 user:library_directory/1, 1623 user:prolog_load_file/2. 1624 1625:- prompt(_, '|: '). 1626 1627:- thread_local 1628 '$compilation_mode_store'/1, % database, wic, qlf 1629 '$directive_mode_store'/1. % database, wic, qlf 1630:- volatile 1631 '$compilation_mode_store'/1, 1632 '$directive_mode_store'/1. 1633 1634'$compilation_mode'(Mode) :- 1635 ( '$compilation_mode_store'(Val) 1636 -> Mode = Val 1637 ; Mode = database 1638 ). 1639 1640'$set_compilation_mode'(Mode) :- 1641 retractall('$compilation_mode_store'(_)), 1642 assertz('$compilation_mode_store'(Mode)). 1643 1644'$compilation_mode'(Old, New) :- 1645 '$compilation_mode'(Old), 1646 ( New == Old 1647 -> true 1648 ; '$set_compilation_mode'(New) 1649 ). 1650 1651'$directive_mode'(Mode) :- 1652 ( '$directive_mode_store'(Val) 1653 -> Mode = Val 1654 ; Mode = database 1655 ). 1656 1657'$directive_mode'(Old, New) :- 1658 '$directive_mode'(Old), 1659 ( New == Old 1660 -> true 1661 ; '$set_directive_mode'(New) 1662 ). 1663 1664'$set_directive_mode'(Mode) :- 1665 retractall('$directive_mode_store'(_)), 1666 assertz('$directive_mode_store'(Mode)).
1674'$compilation_level'(Level) :- 1675 '$input_context'(Stack), 1676 '$compilation_level'(Stack, Level). 1677 1678'$compilation_level'([], 0). 1679'$compilation_level'([Input|T], Level) :- 1680 ( arg(1, Input, see) 1681 -> '$compilation_level'(T, Level) 1682 ; '$compilation_level'(T, Level0), 1683 Level is Level0+1 1684 ).
1692compiling :- 1693 \+ ( '$compilation_mode'(database), 1694 '$directive_mode'(database) 1695 ). 1696 1697:- meta_predicate 1698 '$ifcompiling'( ). 1699 1700'$ifcompiling'(G) :- 1701 ( '$compilation_mode'(database) 1702 -> true 1703 ; call(G) 1704 ). 1705 1706 /******************************** 1707 * READ SOURCE * 1708 *********************************/
1712'$load_msg_level'(Action, Nesting, Start, Done) :- 1713 '$update_autoload_level'([], 0), 1714 !, 1715 current_prolog_flag(verbose_load, Type0), 1716 '$load_msg_compat'(Type0, Type), 1717 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1718 -> true 1719 ). 1720'$load_msg_level'(_, _, silent, silent). 1721 1722'$load_msg_compat'(true, normal) :- !. 1723'$load_msg_compat'(false, silent) :- !. 1724'$load_msg_compat'(X, X). 1725 1726'$load_msg_level'(load_file, _, full, informational, informational). 1727'$load_msg_level'(include_file, _, full, informational, informational). 1728'$load_msg_level'(load_file, _, normal, silent, informational). 1729'$load_msg_level'(include_file, _, normal, silent, silent). 1730'$load_msg_level'(load_file, 0, brief, silent, informational). 1731'$load_msg_level'(load_file, _, brief, silent, silent). 1732'$load_msg_level'(include_file, _, brief, silent, silent). 1733'$load_msg_level'(load_file, _, silent, silent, silent). 1734'$load_msg_level'(include_file, _, silent, silent, silent).
1757'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1758 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1759 ( Term == end_of_file 1760 -> !, fail 1761 ; Term \== begin_of_file 1762 ). 1763 1764'$source_term'(Input, _,_,_,_,_,_,_) :- 1765 \+ ground(Input), 1766 !, 1767 '$instantiation_error'(Input). 1768'$source_term'(stream(Id, In, Opts), 1769 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1770 !, 1771 '$record_included'(Parents, Id, Id, 0.0, Message), 1772 setup_call_cleanup( 1773 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1774 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1775 [Id|Parents], Options), 1776 '$close_source'(State, Message)). 1777'$source_term'(File, 1778 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1779 absolute_file_name(File, Path, 1780 [ file_type(prolog), 1781 access(read) 1782 ]), 1783 time_file(Path, Time), 1784 '$record_included'(Parents, File, Path, Time, Message), 1785 setup_call_cleanup( 1786 '$open_source'(Path, In, State, Parents, Options), 1787 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1788 [Path|Parents], Options), 1789 '$close_source'(State, Message)). 1790 1791:- thread_local 1792 '$load_input'/2. 1793:- volatile 1794 '$load_input'/2. 1795 1796'$open_source'(stream(Id, In, Opts), In, 1797 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1798 !, 1799 '$context_type'(Parents, ContextType), 1800 '$push_input_context'(ContextType), 1801 '$prepare_load_stream'(In, Id, StreamState), 1802 asserta('$load_input'(stream(Id), In), Ref). 1803'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1804 '$context_type'(Parents, ContextType), 1805 '$push_input_context'(ContextType), 1806 '$open_source'(Path, In, Options), 1807 '$set_encoding'(In, Options), 1808 asserta('$load_input'(Path, In), Ref). 1809 1810'$context_type'([], load_file) :- !. 1811'$context_type'(_, include). 1812 1813:- multifile prolog:open_source_hook/3. 1814 1815'$open_source'(Path, In, Options) :- 1816 prolog:open_source_hook(Path, In, Options), 1817 !. 1818'$open_source'(Path, In, _Options) :- 1819 open(Path, read, In). 1820 1821'$close_source'(close(In, _Id, Ref), Message) :- 1822 erase(Ref), 1823 call_cleanup( 1824 close(In), 1825 '$pop_input_context'), 1826 '$close_message'(Message). 1827'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1828 erase(Ref), 1829 call_cleanup( 1830 '$restore_load_stream'(In, StreamState, Opts), 1831 '$pop_input_context'), 1832 '$close_message'(Message). 1833 1834'$close_message'(message(Level, Msg)) :- 1835 !, 1836 '$print_message'(Level, Msg). 1837'$close_message'(_).
1849'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1850 Parents \= [_,_|_], 1851 ( '$load_input'(_, Input) 1852 -> stream_property(Input, file_name(File)) 1853 ), 1854 '$set_source_location'(File, 0), 1855 '$expanded_term'(In, 1856 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1857 Stream, Parents, Options). 1858'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1859 '$skip_script_line'(In, Options), 1860 '$read_clause_options'(Options, ReadOptions), 1861 repeat, 1862 read_clause(In, Raw, 1863 [ variable_names(Bindings), 1864 term_position(Pos), 1865 subterm_positions(RawLayout) 1866 | ReadOptions 1867 ]), 1868 b_setval('$term_position', Pos), 1869 b_setval('$variable_names', Bindings), 1870 ( Raw == end_of_file 1871 -> !, 1872 ( Parents = [_,_|_] % Included file 1873 -> fail 1874 ; '$expanded_term'(In, 1875 Raw, RawLayout, Read, RLayout, Term, TLayout, 1876 Stream, Parents, Options) 1877 ) 1878 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1879 Stream, Parents, Options) 1880 ). 1881 1882'$read_clause_options'([], []). 1883'$read_clause_options'([H|T0], List) :- 1884 ( '$read_clause_option'(H) 1885 -> List = [H|T] 1886 ; List = T 1887 ), 1888 '$read_clause_options'(T0, T). 1889 1890'$read_clause_option'(syntax_errors(_)). 1891'$read_clause_option'(term_position(_)). 1892'$read_clause_option'(process_comment(_)). 1893 1894'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1895 Stream, Parents, Options) :- 1896 E = error(_,_), 1897 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1898 '$print_message_fail'(E)), 1899 ( Expanded \== [] 1900 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1901 ; Term1 = Expanded, 1902 Layout1 = ExpandedLayout 1903 ), 1904 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1905 -> ( Directive = include(File), 1906 '$current_source_module'(Module), 1907 '$valid_directive'(Module:include(File)) 1908 -> stream_property(In, encoding(Enc)), 1909 '$add_encoding'(Enc, Options, Options1), 1910 '$source_term'(File, Read, RLayout, Term, TLayout, 1911 Stream, Parents, Options1) 1912 ; Directive = encoding(Enc) 1913 -> set_stream(In, encoding(Enc)), 1914 fail 1915 ; Term = Term1, 1916 Stream = In, 1917 Read = Raw 1918 ) 1919 ; Term = Term1, 1920 TLayout = Layout1, 1921 Stream = In, 1922 Read = Raw, 1923 RLayout = RawLayout 1924 ). 1925 1926'$expansion_member'(Var, Layout, Var, Layout) :- 1927 var(Var), 1928 !. 1929'$expansion_member'([], _, _, _) :- !, fail. 1930'$expansion_member'(List, ListLayout, Term, Layout) :- 1931 is_list(List), 1932 !, 1933 ( var(ListLayout) 1934 -> '$member'(Term, List) 1935 ; is_list(ListLayout) 1936 -> '$member_rep2'(Term, Layout, List, ListLayout) 1937 ; Layout = ListLayout, 1938 '$member'(Term, List) 1939 ). 1940'$expansion_member'(X, Layout, X, Layout). 1941 1942% pairwise member, repeating last element of the second 1943% list. 1944 1945'$member_rep2'(H1, H2, [H1|_], [H2|_]). 1946'$member_rep2'(H1, H2, [_|T1], [T2]) :- 1947 !, 1948 '$member_rep2'(H1, H2, T1, [T2]). 1949'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 1950 '$member_rep2'(H1, H2, T1, T2).
1954'$add_encoding'(Enc, Options0, Options) :- 1955 ( Options0 = [encoding(Enc)|_] 1956 -> Options = Options0 1957 ; Options = [encoding(Enc)|Options0] 1958 ). 1959 1960 1961:- multifile 1962 '$included'/4. % Into, Line, File, LastModified 1963:- dynamic 1964 '$included'/4.
I think that the only sensible solution is to have a special statement for this, that may appear both inside and outside QLF `parts'.
1978'$record_included'([Parent|Parents], File, Path, Time, 1979 message(DoneMsgLevel, 1980 include_file(done(Level, file(File, Path))))) :- 1981 source_location(SrcFile, Line), 1982 !, 1983 '$compilation_level'(Level), 1984 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 1985 '$print_message'(StartMsgLevel, 1986 include_file(start(Level, 1987 file(File, Path)))), 1988 '$last'([Parent|Parents], Owner), 1989 ( ( '$compilation_mode'(database) 1990 ; '$qlf_current_source'(Owner) 1991 ) 1992 -> '$store_admin_clause'( 1993 system:'$included'(Parent, Line, Path, Time), 1994 _, Owner, SrcFile:Line) 1995 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 1996 ). 1997'$record_included'(_, _, _, _, true).
2003'$master_file'(File, MasterFile) :- 2004 '$included'(MasterFile0, _Line, File, _Time), 2005 !, 2006 '$master_file'(MasterFile0, MasterFile). 2007'$master_file'(File, File). 2008 2009 2010'$skip_script_line'(_In, Options) :- 2011 '$option'(check_script(false), Options), 2012 !. 2013'$skip_script_line'(In, _Options) :- 2014 ( peek_char(In, #) 2015 -> skip(In, 10) 2016 ; true 2017 ). 2018 2019'$set_encoding'(Stream, Options) :- 2020 '$option'(encoding(Enc), Options), 2021 !, 2022 Enc \== default, 2023 set_stream(Stream, encoding(Enc)). 2024'$set_encoding'(_, _). 2025 2026 2027'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 2028 ( stream_property(In, file_name(_)) 2029 -> HasName = true, 2030 ( stream_property(In, position(_)) 2031 -> HasPos = true 2032 ; HasPos = false, 2033 set_stream(In, record_position(true)) 2034 ) 2035 ; HasName = false, 2036 set_stream(In, file_name(Id)), 2037 ( stream_property(In, position(_)) 2038 -> HasPos = true 2039 ; HasPos = false, 2040 set_stream(In, record_position(true)) 2041 ) 2042 ). 2043 2044'$restore_load_stream'(In, _State, Options) :- 2045 memberchk(close(true), Options), 2046 !, 2047 close(In). 2048'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 2049 ( HasName == false 2050 -> set_stream(In, file_name('')) 2051 ; true 2052 ), 2053 ( HasPos == false 2054 -> set_stream(In, record_position(false)) 2055 ; true 2056 ). 2057 2058 2059 /******************************* 2060 * DERIVED FILES * 2061 *******************************/ 2062 2063:- dynamic 2064 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2065 2066'$register_derived_source'(_, '-') :- !. 2067'$register_derived_source'(Loaded, DerivedFrom) :- 2068 retractall('$derived_source_db'(Loaded, _, _)), 2069 time_file(DerivedFrom, Time), 2070 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2071 2072% Auto-importing dynamic predicates is not very elegant and 2073% leads to problems with qsave_program/[1,2] 2074 2075'$derived_source'(Loaded, DerivedFrom, Time) :- 2076 '$derived_source_db'(Loaded, DerivedFrom, Time). 2077 2078 2079 /******************************** 2080 * LOAD PREDICATES * 2081 *********************************/ 2082 2083:- meta_predicate 2084 ensure_loaded( ), 2085 [, | ] 2086 consult( ), 2087 use_module( ), 2088 use_module( , ), 2089 reexport( ), 2090 reexport( , ), 2091 load_files( ), 2092 load_files( , ).
2100ensure_loaded(Files) :-
2101 load_files(Files, [if(not_loaded)]).
2110use_module(Files) :-
2111 load_files(Files, [ if(not_loaded),
2112 must_be_module(true)
2113 ]).
2120use_module(File, Import) :-
2121 load_files(File, [ if(not_loaded),
2122 must_be_module(true),
2123 imports(Import)
2124 ]).
2130reexport(Files) :-
2131 load_files(Files, [ if(not_loaded),
2132 must_be_module(true),
2133 reexport(true)
2134 ]).
2140reexport(File, Import) :- 2141 load_files(File, [ if(not_loaded), 2142 must_be_module(true), 2143 imports(Import), 2144 reexport(true) 2145 ]). 2146 2147 2148[X] :- 2149 !, 2150 consult(X). 2151[M:F|R] :- 2152 consult(M:[F|R]). 2153 2154consult(M:X) :- 2155 X == user, 2156 !, 2157 flag('$user_consult', N, N+1), 2158 NN is N + 1, 2159 atom_concat('user://', NN, Id), 2160 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2161consult(List) :- 2162 load_files(List, [expand(true)]).
2169load_files(Files) :- 2170 load_files(Files, []). 2171load_files(Module:Files, Options) :- 2172 '$must_be'(list, Options), 2173 '$load_files'(Files, Module, Options). 2174 2175'$load_files'(X, _, _) :- 2176 var(X), 2177 !, 2178 '$instantiation_error'(X). 2179'$load_files'([], _, _) :- !. 2180'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2181 '$option'(stream(_), Options), 2182 !, 2183 ( atom(Id) 2184 -> '$load_file'(Id, Module, Options) 2185 ; throw(error(type_error(atom, Id), _)) 2186 ). 2187'$load_files'(List, Module, Options) :- 2188 List = [_|_], 2189 !, 2190 '$must_be'(list, List), 2191 '$load_file_list'(List, Module, Options). 2192'$load_files'(File, Module, Options) :- 2193 '$load_one_file'(File, Module, Options). 2194 2195'$load_file_list'([], _, _). 2196'$load_file_list'([File|Rest], Module, Options) :- 2197 E = error(_,_), 2198 catch('$load_one_file'(File, Module, Options), E, 2199 '$print_message'(error, E)), 2200 '$load_file_list'(Rest, Module, Options). 2201 2202 2203'$load_one_file'(Spec, Module, Options) :- 2204 atomic(Spec), 2205 '$option'(expand(Expand), Options, false), 2206 Expand == true, 2207 !, 2208 expand_file_name(Spec, Expanded), 2209 ( Expanded = [Load] 2210 -> true 2211 ; Load = Expanded 2212 ), 2213 '$load_files'(Load, Module, [expand(false)|Options]). 2214'$load_one_file'(File, Module, Options) :- 2215 strip_module(Module:File, Into, PlainFile), 2216 '$load_file'(PlainFile, Into, Options).
2223'$noload'(true, _, _) :- 2224 !, 2225 fail. 2226'$noload'(_, FullFile, _Options) :- 2227 '$time_source_file'(FullFile, Time, system), 2228 Time > 0.0, 2229 !. 2230'$noload'(not_loaded, FullFile, _) :- 2231 source_file(FullFile), 2232 !. 2233'$noload'(changed, Derived, _) :- 2234 '$derived_source'(_FullFile, Derived, LoadTime), 2235 time_file(Derived, Modified), 2236 Modified @=< LoadTime, 2237 !. 2238'$noload'(changed, FullFile, Options) :- 2239 '$time_source_file'(FullFile, LoadTime, user), 2240 '$modified_id'(FullFile, Modified, Options), 2241 Modified @=< LoadTime, 2242 !.
2261'$qlf_file'(Spec, _, Spec, stream, Options) :- 2262 '$option'(stream(_), Options), % stream: no choice 2263 !. 2264'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2265 '$spec_extension'(Spec, Ext), % user explicitly specified 2266 user:prolog_file_type(Ext, prolog), 2267 !. 2268'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2269 '$compilation_mode'(database), 2270 file_name_extension(Base, PlExt, FullFile), 2271 user:prolog_file_type(PlExt, prolog), 2272 user:prolog_file_type(QlfExt, qlf), 2273 file_name_extension(Base, QlfExt, QlfFile), 2274 ( access_file(QlfFile, read), 2275 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2276 -> ( access_file(QlfFile, write) 2277 -> print_message(informational, 2278 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2279 Mode = qcompile, 2280 LoadFile = FullFile 2281 ; Why == old, 2282 ( current_prolog_flag(home, PlHome), 2283 sub_atom(FullFile, 0, _, _, PlHome) 2284 ; sub_atom(QlfFile, 0, _, _, 'res://') 2285 ) 2286 -> print_message(silent, 2287 qlf(system_lib_out_of_date(Spec, QlfFile))), 2288 Mode = qload, 2289 LoadFile = QlfFile 2290 ; print_message(warning, 2291 qlf(can_not_recompile(Spec, QlfFile, Why))), 2292 Mode = compile, 2293 LoadFile = FullFile 2294 ) 2295 ; Mode = qload, 2296 LoadFile = QlfFile 2297 ) 2298 -> ! 2299 ; '$qlf_auto'(FullFile, QlfFile, Options) 2300 -> !, Mode = qcompile, 2301 LoadFile = FullFile 2302 ). 2303'$qlf_file'(_, FullFile, FullFile, compile, _).
2311'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2312 ( access_file(PlFile, read)
2313 -> time_file(PlFile, PlTime),
2314 time_file(QlfFile, QlfTime),
2315 ( PlTime > QlfTime
2316 -> Why = old % PlFile is newer
2317 ; Error = error(Formal,_),
2318 catch('$qlf_info'(QlfFile, _CVer, _MLVer,
2319 _FVer, _CSig, _FSig),
2320 Error, true),
2321 nonvar(Formal) % QlfFile is incompatible
2322 -> Why = Error
2323 ; fail % QlfFile is up-to-date and ok
2324 )
2325 ; fail % can not read .pl; try .qlf
2326 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2334:- create_prolog_flag(qcompile, false, [type(atom)]). 2335 2336'$qlf_auto'(PlFile, QlfFile, Options) :- 2337 ( memberchk(qcompile(QlfMode), Options) 2338 -> true 2339 ; current_prolog_flag(qcompile, QlfMode), 2340 \+ '$in_system_dir'(PlFile) 2341 ), 2342 ( QlfMode == auto 2343 -> true 2344 ; QlfMode == large, 2345 size_file(PlFile, Size), 2346 Size > 100000 2347 ), 2348 access_file(QlfFile, write). 2349 2350'$in_system_dir'(PlFile) :- 2351 current_prolog_flag(home, Home), 2352 sub_atom(PlFile, 0, _, _, Home). 2353 2354'$spec_extension'(File, Ext) :- 2355 atom(File), 2356 file_name_extension(_, Ext, File). 2357'$spec_extension'(Spec, Ext) :- 2358 compound(Spec), 2359 arg(1, Spec, Arg), 2360 '$spec_extension'(Arg, Ext).
2372:- dynamic 2373 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2374 2375'$load_file'(File, Module, Options) :- 2376 '$error_count'(E0, W0), 2377 '$load_file_e'(File, Module, Options), 2378 '$error_count'(E1, W1), 2379 Errors is E1-E0, 2380 Warnings is W1-W0, 2381 ( Errors+Warnings =:= 0 2382 -> true 2383 ; '$print_message'(silent, load_file_errors(File, Errors, Warnings)) 2384 ). 2385 2386'$error_count'(Errors, Warnings) :- 2387 current_prolog_flag(threads, true), 2388 !, 2389 thread_self(Me), 2390 thread_statistics(Me, errors, Errors), 2391 thread_statistics(Me, warnings, Warnings). 2392'$error_count'(Errors, Warnings) :- 2393 statistics(errors, Errors), 2394 statistics(warnings, Warnings). 2395 2396'$load_file_e'(File, Module, Options) :- 2397 \+ memberchk(stream(_), Options), 2398 user:prolog_load_file(Module:File, Options), 2399 !. 2400'$load_file_e'(File, Module, Options) :- 2401 memberchk(stream(_), Options), 2402 !, 2403 '$assert_load_context_module'(File, Module, Options), 2404 '$qdo_load_file'(File, File, Module, Options). 2405'$load_file_e'(File, Module, Options) :- 2406 ( '$resolved_source_path'(File, FullFile, Options) 2407 -> true 2408 ; '$resolve_source_path'(File, FullFile, Options) 2409 ), 2410 '$mt_load_file'(File, FullFile, Module, Options).
2416'$resolved_source_path'(File, FullFile, Options) :-
2417 current_prolog_flag(emulated_dialect, Dialect),
2418 '$resolved_source_path_db'(File, Dialect, FullFile),
2419 ( '$source_file_property'(FullFile, from_state, true)
2420 ; '$source_file_property'(FullFile, resource, true)
2421 ; '$option'(if(If), Options, true),
2422 '$noload'(If, FullFile, Options)
2423 ),
2424 !.
2431'$resolve_source_path'(File, FullFile, _Options) :- 2432 absolute_file_name(File, FullFile, 2433 [ file_type(prolog), 2434 access(read) 2435 ]), 2436 '$register_resolved_source_path'(File, FullFile). 2437 2438 2439'$register_resolved_source_path'(File, FullFile) :- 2440 ( compound(File) 2441 -> current_prolog_flag(emulated_dialect, Dialect), 2442 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2443 -> true 2444 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2445 ) 2446 ; true 2447 ).
2453:- public '$translated_source'/2. 2454'$translated_source'(Old, New) :- 2455 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2456 assertz('$resolved_source_path_db'(File, Dialect, New))).
2463'$register_resource_file'(FullFile) :-
2464 ( sub_atom(FullFile, 0, _, _, 'res://'),
2465 \+ file_name_extension(_, qlf, FullFile)
2466 -> '$set_source_file'(FullFile, resource, true)
2467 ; true
2468 ).
2481'$already_loaded'(_File, FullFile, Module, Options) :- 2482 '$assert_load_context_module'(FullFile, Module, Options), 2483 '$current_module'(LoadModules, FullFile), 2484 !, 2485 ( atom(LoadModules) 2486 -> LoadModule = LoadModules 2487 ; LoadModules = [LoadModule|_] 2488 ), 2489 '$import_from_loaded_module'(LoadModule, Module, Options). 2490'$already_loaded'(_, _, user, _) :- !. 2491'$already_loaded'(File, FullFile, Module, Options) :- 2492 ( '$load_context_module'(FullFile, Module, CtxOptions), 2493 '$load_ctx_options'(Options, CtxOptions) 2494 -> true 2495 ; '$load_file'(File, Module, [if(true)|Options]) 2496 ).
Synchronisation is handled using a message queue that exists while the file is being loaded. This synchronisation relies on the fact that thread_get_message/1 throws an existence_error if the message queue is destroyed. This is hacky. Events or condition variables would have made a cleaner design.
2511:- dynamic 2512 '$loading_file'/3. % File, Queue, Thread 2513:- volatile 2514 '$loading_file'/3. 2515 2516'$mt_load_file'(File, FullFile, Module, Options) :- 2517 current_prolog_flag(threads, true), 2518 !, 2519 sig_atomic(setup_call_cleanup( 2520 with_mutex('$load_file', 2521 '$mt_start_load'(FullFile, Loading, Options)), 2522 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2523 '$mt_end_load'(Loading))). 2524'$mt_load_file'(File, FullFile, Module, Options) :- 2525 '$option'(if(If), Options, true), 2526 '$noload'(If, FullFile, Options), 2527 !, 2528 '$already_loaded'(File, FullFile, Module, Options). 2529'$mt_load_file'(File, FullFile, Module, Options) :- 2530 sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)). 2531 2532'$mt_start_load'(FullFile, queue(Queue), _) :- 2533 '$loading_file'(FullFile, Queue, LoadThread), 2534 \+ thread_self(LoadThread), 2535 !. 2536'$mt_start_load'(FullFile, already_loaded, Options) :- 2537 '$option'(if(If), Options, true), 2538 '$noload'(If, FullFile, Options), 2539 !. 2540'$mt_start_load'(FullFile, Ref, _) :- 2541 thread_self(Me), 2542 message_queue_create(Queue), 2543 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2544 2545'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2546 !, 2547 catch(thread_get_message(Queue, _), error(_,_), true), 2548 '$already_loaded'(File, FullFile, Module, Options). 2549'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2550 !, 2551 '$already_loaded'(File, FullFile, Module, Options). 2552'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2553 '$assert_load_context_module'(FullFile, Module, Options), 2554 '$qdo_load_file'(File, FullFile, Module, Options). 2555 2556'$mt_end_load'(queue(_)) :- !. 2557'$mt_end_load'(already_loaded) :- !. 2558'$mt_end_load'(Ref) :- 2559 clause('$loading_file'(_, Queue, _), _, Ref), 2560 erase(Ref), 2561 thread_send_message(Queue, done), 2562 message_queue_destroy(Queue).
2569'$qdo_load_file'(File, FullFile, Module, Options) :- 2570 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2571 '$register_resource_file'(FullFile), 2572 '$run_initialization'(FullFile, Action, Options). 2573 2574'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2575 memberchk('$qlf'(QlfOut), Options), 2576 '$stage_file'(QlfOut, StageQlf), 2577 !, 2578 setup_call_catcher_cleanup( 2579 '$qstart'(StageQlf, Module, State), 2580 '$do_load_file'(File, FullFile, Module, Action, Options), 2581 Catcher, 2582 '$qend'(State, Catcher, StageQlf, QlfOut)). 2583'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2584 '$do_load_file'(File, FullFile, Module, Action, Options). 2585 2586'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2587 '$qlf_open'(Qlf), 2588 '$compilation_mode'(OldMode, qlf), 2589 '$set_source_module'(OldModule, Module). 2590 2591'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2592 '$set_source_module'(_, OldModule), 2593 '$set_compilation_mode'(OldMode), 2594 '$qlf_close', 2595 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2596 2597'$set_source_module'(OldModule, Module) :- 2598 '$current_source_module'(OldModule), 2599 '$set_source_module'(Module).
2606'$do_load_file'(File, FullFile, Module, Action, Options) :- 2607 '$option'(derived_from(DerivedFrom), Options, -), 2608 '$register_derived_source'(FullFile, DerivedFrom), 2609 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2610 ( Mode == qcompile 2611 -> qcompile(Module:File, Options) 2612 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2613 ). 2614 2615'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2616 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2617 statistics(cputime, OldTime), 2618 2619 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2620 Options), 2621 2622 '$compilation_level'(Level), 2623 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2624 '$print_message'(StartMsgLevel, 2625 load_file(start(Level, 2626 file(File, Absolute)))), 2627 2628 ( memberchk(stream(FromStream), Options) 2629 -> Input = stream 2630 ; Input = source 2631 ), 2632 2633 ( Input == stream, 2634 ( '$option'(format(qlf), Options, source) 2635 -> set_stream(FromStream, file_name(Absolute)), 2636 '$qload_stream'(FromStream, Module, Action, LM, Options) 2637 ; '$consult_file'(stream(Absolute, FromStream, []), 2638 Module, Action, LM, Options) 2639 ) 2640 -> true 2641 ; Input == source, 2642 file_name_extension(_, Ext, Absolute), 2643 ( user:prolog_file_type(Ext, qlf), 2644 E = error(_,_), 2645 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2646 E, 2647 print_message(warning, E)) 2648 -> true 2649 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2650 ) 2651 -> true 2652 ; '$print_message'(error, load_file(failed(File))), 2653 fail 2654 ), 2655 2656 '$import_from_loaded_module'(LM, Module, Options), 2657 2658 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2659 statistics(cputime, Time), 2660 ClausesCreated is NewClauses - OldClauses, 2661 TimeUsed is Time - OldTime, 2662 2663 '$print_message'(DoneMsgLevel, 2664 load_file(done(Level, 2665 file(File, Absolute), 2666 Action, 2667 LM, 2668 TimeUsed, 2669 ClausesCreated))), 2670 2671 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2672 2673'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2674 Options) :- 2675 '$save_file_scoped_flags'(ScopedFlags), 2676 '$set_sandboxed_load'(Options, OldSandBoxed), 2677 '$set_verbose_load'(Options, OldVerbose), 2678 '$set_optimise_load'(Options), 2679 '$update_autoload_level'(Options, OldAutoLevel), 2680 '$set_no_xref'(OldXRef). 2681 2682'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2683 '$set_autoload_level'(OldAutoLevel), 2684 set_prolog_flag(xref, OldXRef), 2685 set_prolog_flag(verbose_load, OldVerbose), 2686 set_prolog_flag(sandboxed_load, OldSandBoxed), 2687 '$restore_file_scoped_flags'(ScopedFlags).
2695'$save_file_scoped_flags'(State) :- 2696 current_predicate(findall/3), % Not when doing boot compile 2697 !, 2698 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2699'$save_file_scoped_flags'([]). 2700 2701'$save_file_scoped_flag'(Flag-Value) :- 2702 '$file_scoped_flag'(Flag, Default), 2703 ( current_prolog_flag(Flag, Value) 2704 -> true 2705 ; Value = Default 2706 ). 2707 2708'$file_scoped_flag'(generate_debug_info, true). 2709'$file_scoped_flag'(optimise, false). 2710'$file_scoped_flag'(xref, false). 2711 2712'$restore_file_scoped_flags'([]). 2713'$restore_file_scoped_flags'([Flag-Value|T]) :- 2714 set_prolog_flag(Flag, Value), 2715 '$restore_file_scoped_flags'(T).
2722'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2723 LoadedModule \== Module, 2724 atom(LoadedModule), 2725 !, 2726 '$option'(imports(Import), Options, all), 2727 '$option'(reexport(Reexport), Options, false), 2728 '$import_list'(Module, LoadedModule, Import, Reexport). 2729'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2737'$set_verbose_load'(Options, Old) :- 2738 current_prolog_flag(verbose_load, Old), 2739 ( memberchk(silent(Silent), Options) 2740 -> ( '$negate'(Silent, Level0) 2741 -> '$load_msg_compat'(Level0, Level) 2742 ; Level = Silent 2743 ), 2744 set_prolog_flag(verbose_load, Level) 2745 ; true 2746 ). 2747 2748'$negate'(true, false). 2749'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2758'$set_sandboxed_load'(Options, Old) :- 2759 current_prolog_flag(sandboxed_load, Old), 2760 ( memberchk(sandboxed(SandBoxed), Options), 2761 '$enter_sandboxed'(Old, SandBoxed, New), 2762 New \== Old 2763 -> set_prolog_flag(sandboxed_load, New) 2764 ; true 2765 ). 2766 2767'$enter_sandboxed'(Old, New, SandBoxed) :- 2768 ( Old == false, New == true 2769 -> SandBoxed = true, 2770 '$ensure_loaded_library_sandbox' 2771 ; Old == true, New == false 2772 -> throw(error(permission_error(leave, sandbox, -), _)) 2773 ; SandBoxed = Old 2774 ). 2775'$enter_sandboxed'(false, true, true). 2776 2777'$ensure_loaded_library_sandbox' :- 2778 source_file_property(library(sandbox), module(sandbox)), 2779 !. 2780'$ensure_loaded_library_sandbox' :- 2781 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2782 2783'$set_optimise_load'(Options) :- 2784 ( '$option'(optimise(Optimise), Options) 2785 -> set_prolog_flag(optimise, Optimise) 2786 ; true 2787 ). 2788 2789'$set_no_xref'(OldXRef) :- 2790 ( current_prolog_flag(xref, OldXRef) 2791 -> true 2792 ; OldXRef = false 2793 ), 2794 set_prolog_flag(xref, false).
2801:- thread_local 2802 '$autoload_nesting'/1. 2803 2804'$update_autoload_level'(Options, AutoLevel) :- 2805 '$option'(autoload(Autoload), Options, false), 2806 ( '$autoload_nesting'(CurrentLevel) 2807 -> AutoLevel = CurrentLevel 2808 ; AutoLevel = 0 2809 ), 2810 ( Autoload == false 2811 -> true 2812 ; NewLevel is AutoLevel + 1, 2813 '$set_autoload_level'(NewLevel) 2814 ). 2815 2816'$set_autoload_level'(New) :- 2817 retractall('$autoload_nesting'(_)), 2818 asserta('$autoload_nesting'(New)).
2826'$print_message'(Level, Term) :- 2827 current_predicate(system:print_message/2), 2828 !, 2829 print_message(Level, Term). 2830'$print_message'(warning, Term) :- 2831 source_location(File, Line), 2832 !, 2833 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2834'$print_message'(error, Term) :- 2835 !, 2836 source_location(File, Line), 2837 !, 2838 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2839'$print_message'(_Level, _Term). 2840 2841'$print_message_fail'(E) :- 2842 '$print_message'(error, E), 2843 fail.
2851'$consult_file'(Absolute, Module, What, LM, Options) :- 2852 '$current_source_module'(Module), % same module 2853 !, 2854 '$consult_file_2'(Absolute, Module, What, LM, Options). 2855'$consult_file'(Absolute, Module, What, LM, Options) :- 2856 '$set_source_module'(OldModule, Module), 2857 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2858 '$consult_file_2'(Absolute, Module, What, LM, Options), 2859 '$ifcompiling'('$qlf_end_part'), 2860 '$set_source_module'(OldModule). 2861 2862'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2863 '$set_source_module'(OldModule, Module), 2864 '$load_id'(Absolute, Id, Modified, Options), 2865 '$compile_type'(What), 2866 '$save_lex_state'(LexState, Options), 2867 '$set_dialect'(Options), 2868 setup_call_cleanup( 2869 '$start_consult'(Id, Modified), 2870 '$load_file'(Absolute, Id, LM, Options), 2871 '$end_consult'(Id, LexState, OldModule)). 2872 2873'$end_consult'(Id, LexState, OldModule) :- 2874 '$end_consult'(Id), 2875 '$restore_lex_state'(LexState), 2876 '$set_source_module'(OldModule). 2877 2878 2879:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2883'$save_lex_state'(State, Options) :- 2884 memberchk(scope_settings(false), Options), 2885 !, 2886 State = (-). 2887'$save_lex_state'(lexstate(Style, Dialect), _) :- 2888 '$style_check'(Style, Style), 2889 current_prolog_flag(emulated_dialect, Dialect). 2890 2891'$restore_lex_state'(-) :- !. 2892'$restore_lex_state'(lexstate(Style, Dialect)) :- 2893 '$style_check'(_, Style), 2894 set_prolog_flag(emulated_dialect, Dialect). 2895 2896'$set_dialect'(Options) :- 2897 memberchk(dialect(Dialect), Options), 2898 !, 2899 '$expects_dialect'(Dialect). 2900'$set_dialect'(_). 2901 2902'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 2903 !, 2904 '$modified_id'(Id, Modified, Options). 2905'$load_id'(Id, Id, Modified, Options) :- 2906 '$modified_id'(Id, Modified, Options). 2907 2908'$modified_id'(_, Modified, Options) :- 2909 '$option'(modified(Stamp), Options, Def), 2910 Stamp \== Def, 2911 !, 2912 Modified = Stamp. 2913'$modified_id'(Id, Modified, _) :- 2914 catch(time_file(Id, Modified), 2915 error(_, _), 2916 fail), 2917 !. 2918'$modified_id'(_, 0.0, _). 2919 2920 2921'$compile_type'(What) :- 2922 '$compilation_mode'(How), 2923 ( How == database 2924 -> What = compiled 2925 ; How == qlf 2926 -> What = '*qcompiled*' 2927 ; What = 'boot compiled' 2928 ).
2938:- dynamic 2939 '$load_context_module'/3. 2940:- multifile 2941 '$load_context_module'/3. 2942 2943'$assert_load_context_module'(_, _, Options) :- 2944 memberchk(register(false), Options), 2945 !. 2946'$assert_load_context_module'(File, Module, Options) :- 2947 source_location(FromFile, Line), 2948 !, 2949 '$master_file'(FromFile, MasterFile), 2950 '$check_load_non_module'(File, Module), 2951 '$add_dialect'(Options, Options1), 2952 '$load_ctx_options'(Options1, Options2), 2953 '$store_admin_clause'( 2954 system:'$load_context_module'(File, Module, Options2), 2955 _Layout, MasterFile, FromFile:Line). 2956'$assert_load_context_module'(File, Module, Options) :- 2957 '$check_load_non_module'(File, Module), 2958 '$add_dialect'(Options, Options1), 2959 '$load_ctx_options'(Options1, Options2), 2960 ( clause('$load_context_module'(File, Module, _), true, Ref), 2961 \+ clause_property(Ref, file(_)), 2962 erase(Ref) 2963 -> true 2964 ; true 2965 ), 2966 assertz('$load_context_module'(File, Module, Options2)). 2967 2968'$add_dialect'(Options0, Options) :- 2969 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 2970 !, 2971 Options = [dialect(Dialect)|Options0]. 2972'$add_dialect'(Options, Options).
2979'$load_ctx_options'(Options, CtxOptions) :- 2980 '$load_ctx_options2'(Options, CtxOptions0), 2981 sort(CtxOptions0, CtxOptions). 2982 2983'$load_ctx_options2'([], []). 2984'$load_ctx_options2'([H|T0], [H|T]) :- 2985 '$load_ctx_option'(H), 2986 !, 2987 '$load_ctx_options2'(T0, T). 2988'$load_ctx_options2'([_|T0], T) :- 2989 '$load_ctx_options2'(T0, T). 2990 2991'$load_ctx_option'(derived_from(_)). 2992'$load_ctx_option'(dialect(_)). 2993'$load_ctx_option'(encoding(_)). 2994'$load_ctx_option'(imports(_)). 2995'$load_ctx_option'(reexport(_)).
3003'$check_load_non_module'(File, _) :- 3004 '$current_module'(_, File), 3005 !. % File is a module file 3006'$check_load_non_module'(File, Module) :- 3007 '$load_context_module'(File, OldModule, _), 3008 Module \== OldModule, 3009 !, 3010 format(atom(Msg), 3011 'Non-module file already loaded into module ~w; \c 3012 trying to load into ~w', 3013 [OldModule, Module]), 3014 throw(error(permission_error(load, source, File), 3015 context(load_files/2, Msg))). 3016'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
3029'$load_file'(Path, Id, Module, Options) :- 3030 State = state(true, _, true, false, Id, -), 3031 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 3032 _Stream, Options), 3033 '$valid_term'(Term), 3034 ( arg(1, State, true) 3035 -> '$first_term'(Term, Layout, Id, State, Options), 3036 nb_setarg(1, State, false) 3037 ; '$compile_term'(Term, Layout, Id) 3038 ), 3039 arg(4, State, true) 3040 ; '$fixup_reconsult'(Id), 3041 '$end_load_file'(State) 3042 ), 3043 !, 3044 arg(2, State, Module). 3045 3046'$valid_term'(Var) :- 3047 var(Var), 3048 !, 3049 print_message(error, error(instantiation_error, _)). 3050'$valid_term'(Term) :- 3051 Term \== []. 3052 3053'$end_load_file'(State) :- 3054 arg(1, State, true), % empty file 3055 !, 3056 nb_setarg(2, State, Module), 3057 arg(5, State, Id), 3058 '$current_source_module'(Module), 3059 '$ifcompiling'('$qlf_start_file'(Id)), 3060 '$ifcompiling'('$qlf_end_part'). 3061'$end_load_file'(State) :- 3062 arg(3, State, End), 3063 '$end_load_file'(End, State). 3064 3065'$end_load_file'(true, _). 3066'$end_load_file'(end_module, State) :- 3067 arg(2, State, Module), 3068 '$check_export'(Module), 3069 '$ifcompiling'('$qlf_end_part'). 3070'$end_load_file'(end_non_module, _State) :- 3071 '$ifcompiling'('$qlf_end_part'). 3072 3073 3074'$first_term'(?-(Directive), Layout, Id, State, Options) :- 3075 !, 3076 '$first_term'(:-(Directive), Layout, Id, State, Options). 3077'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 3078 nonvar(Directive), 3079 ( ( Directive = module(Name, Public) 3080 -> Imports = [] 3081 ; Directive = module(Name, Public, Imports) 3082 ) 3083 -> !, 3084 '$module_name'(Name, Id, Module, Options), 3085 '$start_module'(Module, Public, State, Options), 3086 '$module3'(Imports) 3087 ; Directive = expects_dialect(Dialect) 3088 -> !, 3089 '$set_dialect'(Dialect, State), 3090 fail % Still consider next term as first 3091 ). 3092'$first_term'(Term, Layout, Id, State, Options) :- 3093 '$start_non_module'(Id, Term, State, Options), 3094 '$compile_term'(Term, Layout, Id). 3095 3096'$compile_term'(Term, Layout, Id) :- 3097 '$compile_term'(Term, Layout, Id, -). 3098 3099'$compile_term'(Var, _Layout, _Id, _Src) :- 3100 var(Var), 3101 !, 3102 '$instantiation_error'(Var). 3103'$compile_term'((?-Directive), _Layout, Id, _) :- 3104 !, 3105 '$execute_directive'(Directive, Id). 3106'$compile_term'((:-Directive), _Layout, Id, _) :- 3107 !, 3108 '$execute_directive'(Directive, Id). 3109'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :- 3110 !, 3111 '$compile_term'(Term, Layout, Id, File:Line). 3112'$compile_term'(Clause, Layout, Id, SrcLoc) :- 3113 E = error(_,_), 3114 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3115 '$print_message'(error, E)). 3116 3117'$start_non_module'(_Id, Term, _State, Options) :- 3118 '$option'(must_be_module(true), Options, false), 3119 !, 3120 '$domain_error'(module_header, Term). 3121'$start_non_module'(Id, _Term, State, _Options) :- 3122 '$current_source_module'(Module), 3123 '$ifcompiling'('$qlf_start_file'(Id)), 3124 '$qset_dialect'(State), 3125 nb_setarg(2, State, Module), 3126 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3139'$set_dialect'(Dialect, State) :- 3140 '$compilation_mode'(qlf, database), 3141 !, 3142 '$expects_dialect'(Dialect), 3143 '$compilation_mode'(_, qlf), 3144 nb_setarg(6, State, Dialect). 3145'$set_dialect'(Dialect, _) :- 3146 '$expects_dialect'(Dialect). 3147 3148'$qset_dialect'(State) :- 3149 '$compilation_mode'(qlf), 3150 arg(6, State, Dialect), Dialect \== (-), 3151 !, 3152 '$add_directive_wic'('$expects_dialect'(Dialect)). 3153'$qset_dialect'(_). 3154 3155'$expects_dialect'(Dialect) :- 3156 Dialect == swi, 3157 !, 3158 set_prolog_flag(emulated_dialect, Dialect). 3159'$expects_dialect'(Dialect) :- 3160 current_predicate(expects_dialect/1), 3161 !, 3162 expects_dialect(Dialect). 3163'$expects_dialect'(Dialect) :- 3164 use_module(library(dialect), [expects_dialect/1]), 3165 expects_dialect(Dialect). 3166 3167 3168 /******************************* 3169 * MODULES * 3170 *******************************/ 3171 3172'$start_module'(Module, _Public, State, _Options) :- 3173 '$current_module'(Module, OldFile), 3174 source_location(File, _Line), 3175 OldFile \== File, OldFile \== [], 3176 same_file(OldFile, File), 3177 !, 3178 nb_setarg(2, State, Module), 3179 nb_setarg(4, State, true). % Stop processing 3180'$start_module'(Module, Public, State, Options) :- 3181 arg(5, State, File), 3182 nb_setarg(2, State, Module), 3183 source_location(_File, Line), 3184 '$option'(redefine_module(Action), Options, false), 3185 '$module_class'(File, Class, Super), 3186 '$reset_dialect'(File, Class), 3187 '$redefine_module'(Module, File, Action), 3188 '$declare_module'(Module, Class, Super, File, Line, false), 3189 '$export_list'(Public, Module, Ops), 3190 '$ifcompiling'('$qlf_start_module'(Module)), 3191 '$export_ops'(Ops, Module, File), 3192 '$qset_dialect'(State), 3193 nb_setarg(3, State, end_module).
swi
dialect.3200'$reset_dialect'(File, library) :- 3201 file_name_extension(_, pl, File), 3202 !, 3203 set_prolog_flag(emulated_dialect, swi). 3204'$reset_dialect'(_, _).
3211'$module3'(Var) :- 3212 var(Var), 3213 !, 3214 '$instantiation_error'(Var). 3215'$module3'([]) :- !. 3216'$module3'([H|T]) :- 3217 !, 3218 '$module3'(H), 3219 '$module3'(T). 3220'$module3'(Id) :- 3221 use_module(library(dialect/Id)).
module(Module)
is given. In that case, use this
module and if Module is the load context, ignore the module
header.3235'$module_name'(_, _, Module, Options) :- 3236 '$option'(module(Module), Options), 3237 !, 3238 '$current_source_module'(Context), 3239 Context \== Module. % cause '$first_term'/5 to fail. 3240'$module_name'(Var, Id, Module, Options) :- 3241 var(Var), 3242 !, 3243 file_base_name(Id, File), 3244 file_name_extension(Var, _, File), 3245 '$module_name'(Var, Id, Module, Options). 3246'$module_name'(Reserved, _, _, _) :- 3247 '$reserved_module'(Reserved), 3248 !, 3249 throw(error(permission_error(load, module, Reserved), _)). 3250'$module_name'(Module, _Id, Module, _). 3251 3252 3253'$reserved_module'(system). 3254'$reserved_module'(user).
3259'$redefine_module'(_Module, _, false) :- !. 3260'$redefine_module'(Module, File, true) :- 3261 !, 3262 ( module_property(Module, file(OldFile)), 3263 File \== OldFile 3264 -> unload_file(OldFile) 3265 ; true 3266 ). 3267'$redefine_module'(Module, File, ask) :- 3268 ( stream_property(user_input, tty(true)), 3269 module_property(Module, file(OldFile)), 3270 File \== OldFile, 3271 '$rdef_response'(Module, OldFile, File, true) 3272 -> '$redefine_module'(Module, File, true) 3273 ; true 3274 ). 3275 3276'$rdef_response'(Module, OldFile, File, Ok) :- 3277 repeat, 3278 print_message(query, redefine_module(Module, OldFile, File)), 3279 get_single_char(Char), 3280 '$rdef_response'(Char, Ok0), 3281 !, 3282 Ok = Ok0. 3283 3284'$rdef_response'(Char, true) :- 3285 memberchk(Char, `yY`), 3286 format(user_error, 'yes~n', []). 3287'$rdef_response'(Char, false) :- 3288 memberchk(Char, `nN`), 3289 format(user_error, 'no~n', []). 3290'$rdef_response'(Char, _) :- 3291 memberchk(Char, `a`), 3292 format(user_error, 'abort~n', []), 3293 abort. 3294'$rdef_response'(_, _) :- 3295 print_message(help, redefine_module_reply), 3296 fail.
system
, while all normal user modules inherit
from user
.3306'$module_class'(File, Class, system) :- 3307 current_prolog_flag(home, Home), 3308 sub_atom(File, 0, Len, _, Home), 3309 ( sub_atom(File, Len, _, _, '/boot/') 3310 -> Class = system 3311 ; '$lib_prefix'(Prefix), 3312 sub_atom(File, Len, _, _, Prefix) 3313 -> Class = library 3314 ; file_directory_name(File, Home), 3315 file_name_extension(_, rc, File) 3316 -> Class = library 3317 ), 3318 !. 3319'$module_class'(_, user, user). 3320 3321'$lib_prefix'('/library'). 3322'$lib_prefix'('/xpce/prolog/'). 3323 3324'$check_export'(Module) :- 3325 '$undefined_export'(Module, UndefList), 3326 ( '$member'(Undef, UndefList), 3327 strip_module(Undef, _, Local), 3328 print_message(error, 3329 undefined_export(Module, Local)), 3330 fail 3331 ; true 3332 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3341'$import_list'(_, _, Var, _) :- 3342 var(Var), 3343 !, 3344 throw(error(instantitation_error, _)). 3345'$import_list'(Target, Source, all, Reexport) :- 3346 !, 3347 '$exported_ops'(Source, Import, Predicates), 3348 '$module_property'(Source, exports(Predicates)), 3349 '$import_all'(Import, Target, Source, Reexport, weak). 3350'$import_list'(Target, Source, except(Spec), Reexport) :- 3351 !, 3352 '$exported_ops'(Source, Export, Predicates), 3353 '$module_property'(Source, exports(Predicates)), 3354 ( is_list(Spec) 3355 -> true 3356 ; throw(error(type_error(list, Spec), _)) 3357 ), 3358 '$import_except'(Spec, Export, Import), 3359 '$import_all'(Import, Target, Source, Reexport, weak). 3360'$import_list'(Target, Source, Import, Reexport) :- 3361 !, 3362 is_list(Import), 3363 !, 3364 '$import_all'(Import, Target, Source, Reexport, strong). 3365'$import_list'(_, _, Import, _) :- 3366 throw(error(type_error(import_specifier, Import))). 3367 3368 3369'$import_except'([], List, List). 3370'$import_except'([H|T], List0, List) :- 3371 '$import_except_1'(H, List0, List1), 3372 '$import_except'(T, List1, List). 3373 3374'$import_except_1'(Var, _, _) :- 3375 var(Var), 3376 !, 3377 throw(error(instantitation_error, _)). 3378'$import_except_1'(PI as N, List0, List) :- 3379 '$pi'(PI), atom(N), 3380 !, 3381 '$canonical_pi'(PI, CPI), 3382 '$import_as'(CPI, N, List0, List). 3383'$import_except_1'(op(P,A,N), List0, List) :- 3384 !, 3385 '$remove_ops'(List0, op(P,A,N), List). 3386'$import_except_1'(PI, List0, List) :- 3387 '$pi'(PI), 3388 !, 3389 '$canonical_pi'(PI, CPI), 3390 '$select'(P, List0, List), 3391 '$canonical_pi'(CPI, P), 3392 !. 3393'$import_except_1'(Except, _, _) :- 3394 throw(error(type_error(import_specifier, Except), _)). 3395 3396'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3397 '$canonical_pi'(PI2, CPI), 3398 !. 3399'$import_as'(PI, N, [H|T0], [H|T]) :- 3400 !, 3401 '$import_as'(PI, N, T0, T). 3402'$import_as'(PI, _, _, _) :- 3403 throw(error(existence_error(export, PI), _)). 3404 3405'$pi'(N/A) :- atom(N), integer(A), !. 3406'$pi'(N//A) :- atom(N), integer(A). 3407 3408'$canonical_pi'(N//A0, N/A) :- 3409 A is A0 + 2. 3410'$canonical_pi'(PI, PI). 3411 3412'$remove_ops'([], _, []). 3413'$remove_ops'([Op|T0], Pattern, T) :- 3414 subsumes_term(Pattern, Op), 3415 !, 3416 '$remove_ops'(T0, Pattern, T). 3417'$remove_ops'([H|T0], Pattern, [H|T]) :- 3418 '$remove_ops'(T0, Pattern, T).
3423'$import_all'(Import, Context, Source, Reexport, Strength) :-
3424 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3425 ( Reexport == true,
3426 ( '$list_to_conj'(Imported, Conj)
3427 -> export(Context:Conj),
3428 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3429 ; true
3430 ),
3431 source_location(File, _Line),
3432 '$export_ops'(ImpOps, Context, File)
3433 ; true
3434 ).
3438'$import_all2'([], _, _, [], [], _). 3439'$import_all2'([PI as NewName|Rest], Context, Source, 3440 [NewName/Arity|Imported], ImpOps, Strength) :- 3441 !, 3442 '$canonical_pi'(PI, Name/Arity), 3443 length(Args, Arity), 3444 Head =.. [Name|Args], 3445 NewHead =.. [NewName|Args], 3446 ( '$get_predicate_attribute'(Source:Head, transparent, 1) 3447 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3448 ; true 3449 ), 3450 ( source_location(File, Line) 3451 -> E = error(_,_), 3452 catch('$store_admin_clause'((NewHead :- Source:Head), 3453 _Layout, File, File:Line), 3454 E, '$print_message'(error, E)) 3455 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3456 ), % duplicate load 3457 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3458'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3459 [op(P,A,N)|ImpOps], Strength) :- 3460 !, 3461 '$import_ops'(Context, Source, op(P,A,N)), 3462 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3463'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3464 Error = error(_,_), 3465 catch(Context:'$import'(Source:Pred, Strength), Error, 3466 print_message(error, Error)), 3467 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3468 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3469 3470 3471'$list_to_conj'([One], One) :- !. 3472'$list_to_conj'([H|T], (H,Rest)) :- 3473 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3480'$exported_ops'(Module, Ops, Tail) :- 3481 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3482 !, 3483 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3484'$exported_ops'(_, Ops, Ops). 3485 3486'$exported_op'(Module, P, A, N) :- 3487 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3488 Module:'$exported_op'(P, A, N).
3495'$import_ops'(To, From, Pattern) :- 3496 ground(Pattern), 3497 !, 3498 Pattern = op(P,A,N), 3499 op(P,A,To:N), 3500 ( '$exported_op'(From, P, A, N) 3501 -> true 3502 ; print_message(warning, no_exported_op(From, Pattern)) 3503 ). 3504'$import_ops'(To, From, Pattern) :- 3505 ( '$exported_op'(From, Pri, Assoc, Name), 3506 Pattern = op(Pri, Assoc, Name), 3507 op(Pri, Assoc, To:Name), 3508 fail 3509 ; true 3510 ).
3518'$export_list'(Decls, Module, Ops) :- 3519 is_list(Decls), 3520 !, 3521 '$do_export_list'(Decls, Module, Ops). 3522'$export_list'(Decls, _, _) :- 3523 var(Decls), 3524 throw(error(instantiation_error, _)). 3525'$export_list'(Decls, _, _) :- 3526 throw(error(type_error(list, Decls), _)). 3527 3528'$do_export_list'([], _, []) :- !. 3529'$do_export_list'([H|T], Module, Ops) :- 3530 !, 3531 E = error(_,_), 3532 catch('$export1'(H, Module, Ops, Ops1), 3533 E, ('$print_message'(error, E), Ops = Ops1)), 3534 '$do_export_list'(T, Module, Ops1). 3535 3536'$export1'(Var, _, _, _) :- 3537 var(Var), 3538 !, 3539 throw(error(instantiation_error, _)). 3540'$export1'(Op, _, [Op|T], T) :- 3541 Op = op(_,_,_), 3542 !. 3543'$export1'(PI0, Module, Ops, Ops) :- 3544 strip_module(Module:PI0, M, PI), 3545 ( PI = (_//_) 3546 -> non_terminal(M:PI) 3547 ; true 3548 ), 3549 export(M:PI). 3550 3551'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3552 E = error(_,_), 3553 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File), 3554 '$export_op'(Pri, Assoc, Name, Module, File) 3555 ), 3556 E, '$print_message'(error, E)), 3557 '$export_ops'(T, Module, File). 3558'$export_ops'([], _, _). 3559 3560'$export_op'(Pri, Assoc, Name, Module, File) :- 3561 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3562 -> true 3563 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File) 3564 ), 3565 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3571'$execute_directive'(Goal, F) :- 3572 '$execute_directive_2'(Goal, F). 3573 3574'$execute_directive_2'(encoding(Encoding), _F) :- 3575 !, 3576 ( '$load_input'(_F, S) 3577 -> set_stream(S, encoding(Encoding)) 3578 ). 3579'$execute_directive_2'(Goal, _) :- 3580 \+ '$compilation_mode'(database), 3581 !, 3582 '$add_directive_wic2'(Goal, Type), 3583 ( Type == call % suspend compiling into .qlf file 3584 -> '$compilation_mode'(Old, database), 3585 setup_call_cleanup( 3586 '$directive_mode'(OldDir, Old), 3587 '$execute_directive_3'(Goal), 3588 ( '$set_compilation_mode'(Old), 3589 '$set_directive_mode'(OldDir) 3590 )) 3591 ; '$execute_directive_3'(Goal) 3592 ). 3593'$execute_directive_2'(Goal, _) :- 3594 '$execute_directive_3'(Goal). 3595 3596'$execute_directive_3'(Goal) :- 3597 '$current_source_module'(Module), 3598 '$valid_directive'(Module:Goal), 3599 !, 3600 ( '$pattr_directive'(Goal, Module) 3601 -> true 3602 ; Term = error(_,_), 3603 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3604 -> true 3605 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3606 fail 3607 ). 3608'$execute_directive_3'(_).
sandboxed_load
is true
, this calls
prolog:sandbox_allowed_directive/1. This call can deny execution
of the directive by throwing an exception.3617:- multifile prolog:sandbox_allowed_directive/1. 3618:- multifile prolog:sandbox_allowed_clause/1. 3619:- meta_predicate '$valid_directive'( ). 3620 3621'$valid_directive'(_) :- 3622 current_prolog_flag(sandboxed_load, false), 3623 !. 3624'$valid_directive'(Goal) :- 3625 Error = error(Formal, _), 3626 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3627 !, 3628 ( var(Formal) 3629 -> true 3630 ; print_message(error, Error), 3631 fail 3632 ). 3633'$valid_directive'(Goal) :- 3634 print_message(error, 3635 error(permission_error(execute, 3636 sandboxed_directive, 3637 Goal), _)), 3638 fail. 3639 3640'$exception_in_directive'(Term) :- 3641 '$print_message'(error, Term), 3642 fail. 3643 3644% Note that the list, consult and ensure_loaded directives are already 3645% handled at compile time and therefore should not go into the 3646% intermediate code file. 3647 3648'$add_directive_wic2'(Goal, Type) :- 3649 '$common_goal_type'(Goal, Type), 3650 !, 3651 ( Type == load 3652 -> true 3653 ; '$current_source_module'(Module), 3654 '$add_directive_wic'(Module:Goal) 3655 ). 3656'$add_directive_wic2'(Goal, _) :- 3657 ( '$compilation_mode'(qlf) % no problem for qlf files 3658 -> true 3659 ; print_message(error, mixed_directive(Goal)) 3660 ). 3661 3662'$common_goal_type'((A,B), Type) :- 3663 !, 3664 '$common_goal_type'(A, Type), 3665 '$common_goal_type'(B, Type). 3666'$common_goal_type'((A;B), Type) :- 3667 !, 3668 '$common_goal_type'(A, Type), 3669 '$common_goal_type'(B, Type). 3670'$common_goal_type'((A->B), Type) :- 3671 !, 3672 '$common_goal_type'(A, Type), 3673 '$common_goal_type'(B, Type). 3674'$common_goal_type'(Goal, Type) :- 3675 '$goal_type'(Goal, Type). 3676 3677'$goal_type'(Goal, Type) :- 3678 ( '$load_goal'(Goal) 3679 -> Type = load 3680 ; Type = call 3681 ). 3682 3683'$load_goal'([_|_]). 3684'$load_goal'(consult(_)). 3685'$load_goal'(load_files(_)). 3686'$load_goal'(load_files(_,Options)) :- 3687 memberchk(qcompile(QlfMode), Options), 3688 '$qlf_part_mode'(QlfMode). 3689'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic). 3690'$load_goal'(use_module(_)) :- '$compilation_mode'(wic). 3691'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic). 3692 3693'$qlf_part_mode'(part). 3694'$qlf_part_mode'(true). % compatibility 3695 3696 3697 /******************************** 3698 * COMPILE A CLAUSE * 3699 *********************************/
3706'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3707 Owner \== (-), 3708 !, 3709 setup_call_cleanup( 3710 '$start_aux'(Owner, Context), 3711 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3712 '$end_aux'(Owner, Context)). 3713'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3714 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3715 3716'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3717 ( '$compilation_mode'(database) 3718 -> '$record_clause'(Clause, File, SrcLoc) 3719 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3720 '$qlf_assert_clause'(Ref, development) 3721 ).
3731'$store_clause'((_, _), _, _, _) :- 3732 !, 3733 print_message(error, cannot_redefine_comma), 3734 fail. 3735'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3736 nonvar(Pre), 3737 Pre = (Head,Cond), 3738 !, 3739 ( '$is_true'(Cond), current_prolog_flag(optimise, true) 3740 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc) 3741 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc) 3742 ). 3743'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3744 '$valid_clause'(Clause), 3745 !, 3746 ( '$compilation_mode'(database) 3747 -> '$record_clause'(Clause, File, SrcLoc) 3748 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3749 '$qlf_assert_clause'(Ref, development) 3750 ). 3751 3752'$is_true'(true) => true. 3753'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B). 3754'$is_true'(_) => fail. 3755 3756'$valid_clause'(_) :- 3757 current_prolog_flag(sandboxed_load, false), 3758 !. 3759'$valid_clause'(Clause) :- 3760 \+ '$cross_module_clause'(Clause), 3761 !. 3762'$valid_clause'(Clause) :- 3763 Error = error(Formal, _), 3764 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3765 !, 3766 ( var(Formal) 3767 -> true 3768 ; print_message(error, Error), 3769 fail 3770 ). 3771'$valid_clause'(Clause) :- 3772 print_message(error, 3773 error(permission_error(assert, 3774 sandboxed_clause, 3775 Clause), _)), 3776 fail. 3777 3778'$cross_module_clause'(Clause) :- 3779 '$head_module'(Clause, Module), 3780 \+ '$current_source_module'(Module). 3781 3782'$head_module'(Var, _) :- 3783 var(Var), !, fail. 3784'$head_module'((Head :- _), Module) :- 3785 '$head_module'(Head, Module). 3786'$head_module'(Module:_, Module). 3787 3788'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3789'$clause_source'(Clause, Clause, -).
3796:- public 3797 '$store_clause'/2. 3798 3799'$store_clause'(Term, Id) :- 3800 '$clause_source'(Term, Clause, SrcLoc), 3801 '$store_clause'(Clause, _, Id, SrcLoc).
If the cross-referencer is active, we should not (re-)assert the clauses. Actually, we should make them known to the cross-referencer. How do we do that? Maybe we need a different API, such as in:
expand_term_aux(Goal, NewGoal, Clauses)
3822compile_aux_clauses(_Clauses) :- 3823 current_prolog_flag(xref, true), 3824 !. 3825compile_aux_clauses(Clauses) :- 3826 source_location(File, _Line), 3827 '$compile_aux_clauses'(Clauses, File). 3828 3829'$compile_aux_clauses'(Clauses, File) :- 3830 setup_call_cleanup( 3831 '$start_aux'(File, Context), 3832 '$store_aux_clauses'(Clauses, File), 3833 '$end_aux'(File, Context)). 3834 3835'$store_aux_clauses'(Clauses, File) :- 3836 is_list(Clauses), 3837 !, 3838 forall('$member'(C,Clauses), 3839 '$compile_term'(C, _Layout, File)). 3840'$store_aux_clauses'(Clause, File) :- 3841 '$compile_term'(Clause, _Layout, File). 3842 3843 3844 /******************************* 3845 * STAGING * 3846 *******************************/
3856'$stage_file'(Target, Stage) :- 3857 file_directory_name(Target, Dir), 3858 file_base_name(Target, File), 3859 current_prolog_flag(pid, Pid), 3860 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 3861 3862'$install_staged_file'(exit, Staged, Target, error) :- 3863 !, 3864 rename_file(Staged, Target). 3865'$install_staged_file'(exit, Staged, Target, OnError) :- 3866 !, 3867 InstallError = error(_,_), 3868 catch(rename_file(Staged, Target), 3869 InstallError, 3870 '$install_staged_error'(OnError, InstallError, Staged, Target)). 3871'$install_staged_file'(_, Staged, _, _OnError) :- 3872 E = error(_,_), 3873 catch(delete_file(Staged), E, true). 3874 3875'$install_staged_error'(OnError, Error, Staged, _Target) :- 3876 E = error(_,_), 3877 catch(delete_file(Staged), E, true), 3878 ( OnError = silent 3879 -> true 3880 ; OnError = fail 3881 -> fail 3882 ; print_message(warning, Error) 3883 ). 3884 3885 3886 /******************************* 3887 * READING * 3888 *******************************/ 3889 3890:- multifile 3891 prolog:comment_hook/3. % hook for read_clause/3 3892 3893 3894 /******************************* 3895 * FOREIGN INTERFACE * 3896 *******************************/ 3897 3898% call-back from PL_register_foreign(). First argument is the module 3899% into which the foreign predicate is loaded and second is a term 3900% describing the arguments. 3901 3902:- dynamic 3903 '$foreign_registered'/2. 3904 3905 /******************************* 3906 * TEMPORARY TERM EXPANSION * 3907 *******************************/ 3908 3909% Provide temporary definitions for the boot-loader. These are replaced 3910% by the real thing in load.pl 3911 3912:- dynamic 3913 '$expand_goal'/2, 3914 '$expand_term'/4. 3915 3916'$expand_goal'(In, In). 3917'$expand_term'(In, Layout, In, Layout). 3918 3919 3920 /******************************* 3921 * TYPE SUPPORT * 3922 *******************************/ 3923 3924'$type_error'(Type, Value) :- 3925 ( var(Value) 3926 -> throw(error(instantiation_error, _)) 3927 ; throw(error(type_error(Type, Value), _)) 3928 ). 3929 3930'$domain_error'(Type, Value) :- 3931 throw(error(domain_error(Type, Value), _)). 3932 3933'$existence_error'(Type, Object) :- 3934 throw(error(existence_error(Type, Object), _)). 3935 3936'$permission_error'(Action, Type, Term) :- 3937 throw(error(permission_error(Action, Type, Term), _)). 3938 3939'$instantiation_error'(_Var) :- 3940 throw(error(instantiation_error, _)). 3941 3942'$uninstantiation_error'(NonVar) :- 3943 throw(error(uninstantiation_error(NonVar), _)). 3944 3945'$must_be'(list, X) :- !, 3946 '$skip_list'(_, X, Tail), 3947 ( Tail == [] 3948 -> true 3949 ; '$type_error'(list, Tail) 3950 ). 3951'$must_be'(options, X) :- !, 3952 ( '$is_options'(X) 3953 -> true 3954 ; '$type_error'(options, X) 3955 ). 3956'$must_be'(atom, X) :- !, 3957 ( atom(X) 3958 -> true 3959 ; '$type_error'(atom, X) 3960 ). 3961'$must_be'(integer, X) :- !, 3962 ( integer(X) 3963 -> true 3964 ; '$type_error'(integer, X) 3965 ). 3966'$must_be'(between(Low,High), X) :- !, 3967 ( integer(X) 3968 -> ( between(Low, High, X) 3969 -> true 3970 ; '$domain_error'(between(Low,High), X) 3971 ) 3972 ; '$type_error'(integer, X) 3973 ). 3974'$must_be'(callable, X) :- !, 3975 ( callable(X) 3976 -> true 3977 ; '$type_error'(callable, X) 3978 ). 3979'$must_be'(acyclic, X) :- !, 3980 ( acyclic_term(X) 3981 -> true 3982 ; '$domain_error'(acyclic_term, X) 3983 ). 3984'$must_be'(oneof(Type, Domain, List), X) :- !, 3985 '$must_be'(Type, X), 3986 ( memberchk(X, List) 3987 -> true 3988 ; '$domain_error'(Domain, X) 3989 ). 3990'$must_be'(boolean, X) :- !, 3991 ( (X == true ; X == false) 3992 -> true 3993 ; '$type_error'(boolean, X) 3994 ). 3995'$must_be'(ground, X) :- !, 3996 ( ground(X) 3997 -> true 3998 ; '$instantiation_error'(X) 3999 ). 4000'$must_be'(filespec, X) :- !, 4001 ( ( atom(X) 4002 ; string(X) 4003 ; compound(X), 4004 compound_name_arity(X, _, 1) 4005 ) 4006 -> true 4007 ; '$type_error'(filespec, X) 4008 ). 4009 4010% Use for debugging 4011%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 4012 4013 4014 /******************************** 4015 * LIST PROCESSING * 4016 *********************************/ 4017 4018'$member'(El, [H|T]) :- 4019 '$member_'(T, El, H). 4020 4021'$member_'(_, El, El). 4022'$member_'([H|T], El, _) :- 4023 '$member_'(T, El, H). 4024 4025'$append'([], L, L). 4026'$append'([H|T], L, [H|R]) :- 4027 '$append'(T, L, R). 4028 4029'$append'(ListOfLists, List) :- 4030 '$must_be'(list, ListOfLists), 4031 '$append_'(ListOfLists, List). 4032 4033'$append_'([], []). 4034'$append_'([L|Ls], As) :- 4035 '$append'(L, Ws, As), 4036 '$append_'(Ls, Ws). 4037 4038'$select'(X, [X|Tail], Tail). 4039'$select'(Elem, [Head|Tail], [Head|Rest]) :- 4040 '$select'(Elem, Tail, Rest). 4041 4042'$reverse'(L1, L2) :- 4043 '$reverse'(L1, [], L2). 4044 4045'$reverse'([], List, List). 4046'$reverse'([Head|List1], List2, List3) :- 4047 '$reverse'(List1, [Head|List2], List3). 4048 4049'$delete'([], _, []) :- !. 4050'$delete'([Elem|Tail], Elem, Result) :- 4051 !, 4052 '$delete'(Tail, Elem, Result). 4053'$delete'([Head|Tail], Elem, [Head|Rest]) :- 4054 '$delete'(Tail, Elem, Rest). 4055 4056'$last'([H|T], Last) :- 4057 '$last'(T, H, Last). 4058 4059'$last'([], Last, Last). 4060'$last'([H|T], _, Last) :- 4061 '$last'(T, H, Last).
4068:- '$iso'((length/2)). 4069 4070length(List, Length) :- 4071 var(Length), 4072 !, 4073 '$skip_list'(Length0, List, Tail), 4074 ( Tail == [] 4075 -> Length = Length0 % +,- 4076 ; var(Tail) 4077 -> Tail \== Length, % avoid length(L,L) 4078 '$length3'(Tail, Length, Length0) % -,- 4079 ; throw(error(type_error(list, List), 4080 context(length/2, _))) 4081 ). 4082length(List, Length) :- 4083 integer(Length), 4084 Length >= 0, 4085 !, 4086 '$skip_list'(Length0, List, Tail), 4087 ( Tail == [] % proper list 4088 -> Length = Length0 4089 ; var(Tail) 4090 -> Extra is Length-Length0, 4091 '$length'(Tail, Extra) 4092 ; throw(error(type_error(list, List), 4093 context(length/2, _))) 4094 ). 4095length(_, Length) :- 4096 integer(Length), 4097 !, 4098 throw(error(domain_error(not_less_than_zero, Length), 4099 context(length/2, _))). 4100length(_, Length) :- 4101 throw(error(type_error(integer, Length), 4102 context(length/2, _))). 4103 4104'$length3'([], N, N). 4105'$length3'([_|List], N, N0) :- 4106 N1 is N0+1, 4107 '$length3'(List, N, N1). 4108 4109 4110 /******************************* 4111 * OPTION PROCESSING * 4112 *******************************/
4118'$is_options'(Map) :- 4119 is_dict(Map, _), 4120 !. 4121'$is_options'(List) :- 4122 is_list(List), 4123 ( List == [] 4124 -> true 4125 ; List = [H|_], 4126 '$is_option'(H, _, _) 4127 ). 4128 4129'$is_option'(Var, _, _) :- 4130 var(Var), !, fail. 4131'$is_option'(F, Name, Value) :- 4132 functor(F, _, 1), 4133 !, 4134 F =.. [Name,Value]. 4135'$is_option'(Name=Value, Name, Value).
4139'$option'(Opt, Options) :- 4140 is_dict(Options), 4141 !, 4142 [Opt] :< Options. 4143'$option'(Opt, Options) :- 4144 memberchk(Opt, Options).
4148'$option'(Term, Options, Default) :-
4149 arg(1, Term, Value),
4150 functor(Term, Name, 1),
4151 ( is_dict(Options)
4152 -> ( get_dict(Name, Options, GVal)
4153 -> Value = GVal
4154 ; Value = Default
4155 )
4156 ; functor(Gen, Name, 1),
4157 arg(1, Gen, GVal),
4158 ( memberchk(Gen, Options)
4159 -> Value = GVal
4160 ; Value = Default
4161 )
4162 ).
4170'$select_option'(Opt, Options, Rest) :-
4171 select_dict([Opt], Options, Rest).
4179'$merge_options'(New, Old, Merged) :- 4180 put_dict(New, Old, Merged). 4181 4182 4183 /******************************* 4184 * HANDLE TRACER 'L'-COMMAND * 4185 *******************************/ 4186 4187:- public '$prolog_list_goal'/1. 4188 4189:- multifile 4190 user:prolog_list_goal/1. 4191 4192'$prolog_list_goal'(Goal) :- 4193 user:prolog_list_goal(Goal), 4194 !. 4195'$prolog_list_goal'(Goal) :- 4196 use_module(library(listing), [listing/1]), 4197 @(listing(Goal), user). 4198 4199 4200 /******************************* 4201 * HALT * 4202 *******************************/ 4203 4204:- '$iso'((halt/0)). 4205 4206halt :- 4207 '$exit_code'(Code), 4208 ( Code == 0 4209 -> true 4210 ; print_message(warning, on_error(halt(1))) 4211 ), 4212 halt(Code).
on_error
and on_warning
flags. Also used by qsave_toplevel/0.
4219'$exit_code'(Code) :-
4220 ( ( current_prolog_flag(on_error, status),
4221 statistics(errors, Count),
4222 Count > 0
4223 ; current_prolog_flag(on_warning, status),
4224 statistics(warnings, Count),
4225 Count > 0
4226 )
4227 -> Code = 1
4228 ; Code = 0
4229 ).
4238:- meta_predicate at_halt( ). 4239:- dynamic system:term_expansion/2, '$at_halt'/2. 4240:- multifile system:term_expansion/2, '$at_halt'/2. 4241 4242systemterm_expansion((:- at_halt(Goal)), 4243 system:'$at_halt'(Module:Goal, File:Line)) :- 4244 \+ current_prolog_flag(xref, true), 4245 source_location(File, Line), 4246 '$current_source_module'(Module). 4247 4248at_halt(Goal) :- 4249 asserta('$at_halt'(Goal, (-):0)). 4250 4251:- public '$run_at_halt'/0. 4252 4253'$run_at_halt' :- 4254 forall(clause('$at_halt'(Goal, Src), true, Ref), 4255 ( '$call_at_halt'(Goal, Src), 4256 erase(Ref) 4257 )). 4258 4259'$call_at_halt'(Goal, _Src) :- 4260 catch(Goal, E, true), 4261 !, 4262 ( var(E) 4263 -> true 4264 ; subsumes_term(cancel_halt(_), E) 4265 -> '$print_message'(informational, E), 4266 fail 4267 ; '$print_message'(error, E) 4268 ). 4269'$call_at_halt'(Goal, _Src) :- 4270 '$print_message'(warning, goal_failed(at_halt, Goal)).
4278cancel_halt(Reason) :- 4279 throw(cancel_halt(Reason)). 4280 4281 4282 /******************************** 4283 * LOAD OTHER MODULES * 4284 *********************************/ 4285 4286:- meta_predicate 4287 '$load_wic_files'( ). 4288 4289'$load_wic_files'(Files) :- 4290 Files = Module:_, 4291 '$execute_directive'('$set_source_module'(OldM, Module), []), 4292 '$save_lex_state'(LexState, []), 4293 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4294 '$compilation_mode'(OldC, wic), 4295 consult(Files), 4296 '$execute_directive'('$set_source_module'(OldM), []), 4297 '$execute_directive'('$restore_lex_state'(LexState), []), 4298 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4306:- public '$load_additional_boot_files'/0. 4307 4308'$load_additional_boot_files' :- 4309 current_prolog_flag(argv, Argv), 4310 '$get_files_argv'(Argv, Files), 4311 ( Files \== [] 4312 -> format('Loading additional boot files~n'), 4313 '$load_wic_files'(user:Files), 4314 format('additional boot files loaded~n') 4315 ; true 4316 ). 4317 4318'$get_files_argv'([], []) :- !. 4319'$get_files_argv'(['-c'|Files], Files) :- !. 4320'$get_files_argv'([_|Rest], Files) :- 4321 '$get_files_argv'(Rest, Files). 4322 4323'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4324 source_location(File, _Line), 4325 file_directory_name(File, Dir), 4326 atom_concat(Dir, '/load.pl', LoadFile), 4327 '$load_wic_files'(system:[LoadFile]), 4328 ( current_prolog_flag(windows, true) 4329 -> atom_concat(Dir, '/menu.pl', MenuFile), 4330 '$load_wic_files'(system:[MenuFile]) 4331 ; true 4332 ), 4333 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4334 '$compilation_mode'(OldC, wic), 4335 '$execute_directive'('$set_source_module'(user), []), 4336 '$set_compilation_mode'(OldC) 4337 ))