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-2024, 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 det( ), 99 '$clausable'( ), 100 '$iso'( ), 101 '$hide'( ), 102 '$notransact'( ).
public
also plays this role. in SWI,
public
means that the predicate can be called, even if we cannot
find a reference to it.134dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)). 135multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)). 136module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)). 137discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)). 138volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)). 139thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)). 140noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)). 141public(Spec) :- '$set_pattr'(Spec, pred, public(true)). 142non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)). 143det(Spec) :- '$set_pattr'(Spec, pred, det(true)). 144'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)). 145'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)). 146'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)). 147'$notransact'(Spec) :- '$set_pattr'(Spec, pred, transact(false)). 148 149'$set_pattr'(M:Pred, How, Attr) :- 150 '$set_pattr'(Pred, M, How, Attr).
pred
or directive
.156'$set_pattr'(X, _, _, _) :- 157 var(X), 158 '$uninstantiation_error'(X). 159'$set_pattr'(as(Spec,Options), M, How, Attr0) :- 160 !, 161 '$attr_options'(Options, Attr0, Attr), 162 '$set_pattr'(Spec, M, How, Attr). 163'$set_pattr'([], _, _, _) :- !. 164'$set_pattr'([H|T], M, How, Attr) :- % ISO 165 !, 166 '$set_pattr'(H, M, How, Attr), 167 '$set_pattr'(T, M, How, Attr). 168'$set_pattr'((A,B), M, How, Attr) :- % ISO and traditional 169 !, 170 '$set_pattr'(A, M, How, Attr), 171 '$set_pattr'(B, M, How, Attr). 172'$set_pattr'(M:T, _, How, Attr) :- 173 !, 174 '$set_pattr'(T, M, How, Attr). 175'$set_pattr'(PI, M, _, []) :- 176 !, 177 '$pi_head'(M:PI, Pred), 178 '$set_table_wrappers'(Pred). 179'$set_pattr'(A, M, How, [O|OT]) :- 180 !, 181 '$set_pattr'(A, M, How, O), 182 '$set_pattr'(A, M, How, OT). 183'$set_pattr'(A, M, pred, Attr) :- 184 !, 185 Attr =.. [Name,Val], 186 '$set_pi_attr'(M:A, Name, Val). 187'$set_pattr'(A, M, directive, Attr) :- 188 !, 189 Attr =.. [Name,Val], 190 catch('$set_pi_attr'(M:A, Name, Val), 191 error(E, _), 192 print_message(error, error(E, context((Name)/1,_)))). 193 194'$set_pi_attr'(PI, Name, Val) :- 195 '$pi_head'(PI, Head), 196 '$set_predicate_attribute'(Head, Name, Val). 197 198'$attr_options'(Var, _, _) :- 199 var(Var), 200 !, 201 '$uninstantiation_error'(Var). 202'$attr_options'((A,B), Attr0, Attr) :- 203 !, 204 '$attr_options'(A, Attr0, Attr1), 205 '$attr_options'(B, Attr1, Attr). 206'$attr_options'(Opt, Attr0, Attrs) :- 207 '$must_be'(ground, Opt), 208 ( '$attr_option'(Opt, AttrX) 209 -> ( is_list(Attr0) 210 -> '$join_attrs'(AttrX, Attr0, Attrs) 211 ; '$join_attrs'(AttrX, [Attr0], Attrs) 212 ) 213 ; '$domain_error'(predicate_option, Opt) 214 ). 215 216'$join_attrs'([], Attrs, Attrs) :- 217 !. 218'$join_attrs'([H|T], Attrs0, Attrs) :- 219 !, 220 '$join_attrs'(H, Attrs0, Attrs1), 221 '$join_attrs'(T, Attrs1, Attrs). 222'$join_attrs'(Attr, Attrs, Attrs) :- 223 memberchk(Attr, Attrs), 224 !. 225'$join_attrs'(Attr, Attrs, Attrs) :- 226 Attr =.. [Name,Value], 227 Gen =.. [Name,Existing], 228 memberchk(Gen, Attrs), 229 !, 230 throw(error(conflict_error(Name, Value, Existing), _)). 231'$join_attrs'(Attr, Attrs0, Attrs) :- 232 '$append'(Attrs0, [Attr], Attrs). 233 234'$attr_option'(incremental, [incremental(true),opaque(false)]). 235'$attr_option'(monotonic, monotonic(true)). 236'$attr_option'(lazy, lazy(true)). 237'$attr_option'(opaque, [incremental(false),opaque(true)]). 238'$attr_option'(abstract(Level0), abstract(Level)) :- 239 '$table_option'(Level0, Level). 240'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :- 241 '$table_option'(Level0, Level). 242'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :- 243 '$table_option'(Level0, Level). 244'$attr_option'(max_answers(Level0), max_answers(Level)) :- 245 '$table_option'(Level0, Level). 246'$attr_option'(volatile, volatile(true)). 247'$attr_option'(multifile, multifile(true)). 248'$attr_option'(discontiguous, discontiguous(true)). 249'$attr_option'(shared, thread_local(false)). 250'$attr_option'(local, thread_local(true)). 251'$attr_option'(private, thread_local(true)). 252 253'$table_option'(Value0, _Value) :- 254 var(Value0), 255 !, 256 '$instantiation_error'(Value0). 257'$table_option'(Value0, Value) :- 258 integer(Value0), 259 Value0 >= 0, 260 !, 261 Value = Value0. 262'$table_option'(off, -1) :- 263 !. 264'$table_option'(false, -1) :- 265 !. 266'$table_option'(infinite, -1) :- 267 !. 268'$table_option'(Value, _) :- 269 '$domain_error'(nonneg_or_false, Value).
279'$pattr_directive'(dynamic(Spec), M) :- 280 '$set_pattr'(Spec, M, directive, dynamic(true)). 281'$pattr_directive'(multifile(Spec), M) :- 282 '$set_pattr'(Spec, M, directive, multifile(true)). 283'$pattr_directive'(module_transparent(Spec), M) :- 284 '$set_pattr'(Spec, M, directive, transparent(true)). 285'$pattr_directive'(discontiguous(Spec), M) :- 286 '$set_pattr'(Spec, M, directive, discontiguous(true)). 287'$pattr_directive'(volatile(Spec), M) :- 288 '$set_pattr'(Spec, M, directive, volatile(true)). 289'$pattr_directive'(thread_local(Spec), M) :- 290 '$set_pattr'(Spec, M, directive, thread_local(true)). 291'$pattr_directive'(noprofile(Spec), M) :- 292 '$set_pattr'(Spec, M, directive, noprofile(true)). 293'$pattr_directive'(public(Spec), M) :- 294 '$set_pattr'(Spec, M, directive, public(true)). 295'$pattr_directive'(det(Spec), M) :- 296 '$set_pattr'(Spec, M, directive, det(true)).
300'$pi_head'(PI, Head) :- 301 var(PI), 302 var(Head), 303 '$instantiation_error'([PI,Head]). 304'$pi_head'(M:PI, M:Head) :- 305 !, 306 '$pi_head'(PI, Head). 307'$pi_head'(Name/Arity, Head) :- 308 !, 309 '$head_name_arity'(Head, Name, Arity). 310'$pi_head'(Name//DCGArity, Head) :- 311 !, 312 ( nonvar(DCGArity) 313 -> Arity is DCGArity+2, 314 '$head_name_arity'(Head, Name, Arity) 315 ; '$head_name_arity'(Head, Name, Arity), 316 DCGArity is Arity - 2 317 ). 318'$pi_head'(PI, _) :- 319 '$type_error'(predicate_indicator, PI).
324'$head_name_arity'(Goal, Name, Arity) :- 325 ( atom(Goal) 326 -> Name = Goal, Arity = 0 327 ; compound(Goal) 328 -> compound_name_arity(Goal, Name, Arity) 329 ; var(Goal) 330 -> ( Arity == 0 331 -> ( atom(Name) 332 -> Goal = Name 333 ; Name == [] 334 -> Goal = Name 335 ; blob(Name, closure) 336 -> Goal = Name 337 ; '$type_error'(atom, Name) 338 ) 339 ; compound_name_arity(Goal, Name, Arity) 340 ) 341 ; '$type_error'(callable, Goal) 342 ). 343 344:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 345 346 347 /******************************** 348 * CALLING, CONTROL * 349 *********************************/ 350 351:- noprofile((call/1, 352 catch/3, 353 once/1, 354 ignore/1, 355 call_cleanup/2, 356 setup_call_cleanup/3, 357 setup_call_catcher_cleanup/4, 358 notrace/1)). 359 360:- meta_predicate 361 ';'( , ), 362 ','( , ), 363 @( , ), 364 call( ), 365 call( , ), 366 call( , , ), 367 call( , , , ), 368 call( , , , , ), 369 call( , , , , , ), 370 call( , , , , , , ), 371 call( , , , , , , , ), 372 not( ), 373 \+( ), 374 $( ), 375 '->'( , ), 376 '*->'( , ), 377 once( ), 378 ignore( ), 379 catch( , , ), 380 reset( , , ), 381 setup_call_cleanup( , , ), 382 setup_call_catcher_cleanup( , , , ), 383 call_cleanup( , ), 384 catch_with_backtrace( , , ), 385 notrace( ), 386 '$meta_call'( ). 387 388:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 389 390% The control structures are always compiled, both if they appear in a 391% clause body and if they are handed to call/1. The only way to call 392% these predicates is by means of call/2.. In that case, we call the 393% hole control structure again to get it compiled by call/1 and properly 394% deal with !, etc. Another reason for having these things as 395% predicates is to be able to define properties for them, helping code 396% analyzers. 397 398(M0:If ; M0:Then) :- !, call(M0:(If ; Then)). 399(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)). 400(G1 , G2) :- call((G1 , G2)). 401(If -> Then) :- call((If -> Then)). 402(If *-> Then) :- call((If *-> Then)). 403@(Goal,Module) :- @(Goal,Module).
This implementation is used by reset/3 because the continuation cannot be captured if it contains a such a compiled temporary clause.
417'$meta_call'(M:G) :- 418 prolog_current_choice(Ch), 419 '$meta_call'(G, M, Ch). 420 421'$meta_call'(Var, _, _) :- 422 var(Var), 423 !, 424 '$instantiation_error'(Var). 425'$meta_call'((A,B), M, Ch) :- 426 !, 427 '$meta_call'(A, M, Ch), 428 '$meta_call'(B, M, Ch). 429'$meta_call'((I->T;E), M, Ch) :- 430 !, 431 ( prolog_current_choice(Ch2), 432 '$meta_call'(I, M, Ch2) 433 -> '$meta_call'(T, M, Ch) 434 ; '$meta_call'(E, M, Ch) 435 ). 436'$meta_call'((I*->T;E), M, Ch) :- 437 !, 438 ( prolog_current_choice(Ch2), 439 '$meta_call'(I, M, Ch2) 440 *-> '$meta_call'(T, M, Ch) 441 ; '$meta_call'(E, M, Ch) 442 ). 443'$meta_call'((I->T), M, Ch) :- 444 !, 445 ( prolog_current_choice(Ch2), 446 '$meta_call'(I, M, Ch2) 447 -> '$meta_call'(T, M, Ch) 448 ). 449'$meta_call'((I*->T), M, Ch) :- 450 !, 451 prolog_current_choice(Ch2), 452 '$meta_call'(I, M, Ch2), 453 '$meta_call'(T, M, Ch). 454'$meta_call'((A;B), M, Ch) :- 455 !, 456 ( '$meta_call'(A, M, Ch) 457 ; '$meta_call'(B, M, Ch) 458 ). 459'$meta_call'(\+(G), M, _) :- 460 !, 461 prolog_current_choice(Ch), 462 \+ '$meta_call'(G, M, Ch). 463'$meta_call'($(G), M, _) :- 464 !, 465 prolog_current_choice(Ch), 466 $('$meta_call'(G, M, Ch)). 467'$meta_call'(call(G), M, _) :- 468 !, 469 prolog_current_choice(Ch), 470 '$meta_call'(G, M, Ch). 471'$meta_call'(M:G, _, Ch) :- 472 !, 473 '$meta_call'(G, M, Ch). 474'$meta_call'(!, _, Ch) :- 475 prolog_cut_to(Ch). 476'$meta_call'(G, M, _Ch) :- 477 call(M:G).
493:- '$iso'((call/2, 494 call/3, 495 call/4, 496 call/5, 497 call/6, 498 call/7, 499 call/8)). 500 501call(Goal) :- % make these available as predicates 502 . 503call(Goal, A) :- 504 call(Goal, A). 505call(Goal, A, B) :- 506 call(Goal, A, B). 507call(Goal, A, B, C) :- 508 call(Goal, A, B, C). 509call(Goal, A, B, C, D) :- 510 call(Goal, A, B, C, D). 511call(Goal, A, B, C, D, E) :- 512 call(Goal, A, B, C, D, E). 513call(Goal, A, B, C, D, E, F) :- 514 call(Goal, A, B, C, D, E, F). 515call(Goal, A, B, C, D, E, F, G) :- 516 call(Goal, A, B, C, D, E, F, G).
523not(Goal) :-
524 \+ .
530\+ Goal :-
531 \+ .
call((Goal, !))
.
537once(Goal) :-
538 ,
539 !.
546ignore(Goal) :- 547 , 548 !. 549ignore(_Goal). 550 551:- '$iso'((false/0)).
557false :-
558 fail.
564catch(_Goal, _Catcher, _Recover) :- 565 '$catch'. % Maps to I_CATCH, I_EXITCATCH
571prolog_cut_to(_Choice) :- 572 '$cut'. % Maps to I_CUTCHP
578'$' :- '$'.
584$(Goal) :- $(Goal).
590:- '$hide'(notrace/1). 591 592notrace(Goal) :- 593 setup_call_cleanup( 594 '$notrace'(Flags, SkipLevel), 595 once(Goal), 596 '$restore_trace'(Flags, SkipLevel)).
603reset(_Goal, _Ball, _Cont) :-
604 '$reset'.
613shift(Ball) :- 614 '$shift'(Ball). 615 616shift_for_copy(Ball) :- 617 '$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.
631call_continuation([]). 632call_continuation([TB|Rest]) :- 633 ( Rest == [] 634 -> '$call_continuation'(TB) 635 ; '$call_continuation'(TB), 636 call_continuation(Rest) 637 ).
644catch_with_backtrace(Goal, Ball, Recover) :- 645 catch(Goal, Ball, Recover), 646 '$no_lco'. 647 648'$no_lco'.
658:- public '$recover_and_rethrow'/2. 659 660'$recover_and_rethrow'(Goal, Exception) :- 661 call_cleanup(Goal, throw(Exception)), 662 !.
I_CALLCLEANUP
, I_EXITCLEANUP
. These
instructions rely on the exact stack layout left by these
predicates, where the variant is determined by the arity. See also
callCleanupHandler()
in pl-wam.c
.676setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :- 677 sig_atomic(Setup), 678 '$call_cleanup'. 679 680setup_call_cleanup(Setup, _Goal, _Cleanup) :- 681 sig_atomic(Setup), 682 '$call_cleanup'. 683 684call_cleanup(_Goal, _Cleanup) :- 685 '$call_cleanup'. 686 687 688 /******************************* 689 * INITIALIZATION * 690 *******************************/ 691 692:- meta_predicate 693 initialization( , ). 694 695:- multifile '$init_goal'/3. 696:- dynamic '$init_goal'/3. 697:- '$notransact'('$init_goal'/3).
-g goal
goals.Note that all goals are executed when a program is restored.
723initialization(Goal, When) :- 724 '$must_be'(oneof(atom, initialization_type, 725 [ now, 726 after_load, 727 restore, 728 restore_state, 729 prepare_state, 730 program, 731 main 732 ]), When), 733 '$initialization_context'(Source, Ctx), 734 '$initialization'(When, Goal, Source, Ctx). 735 736'$initialization'(now, Goal, _Source, Ctx) :- 737 '$run_init_goal'(Goal, Ctx), 738 '$compile_init_goal'(-, Goal, Ctx). 739'$initialization'(after_load, Goal, Source, Ctx) :- 740 ( Source \== (-) 741 -> '$compile_init_goal'(Source, Goal, Ctx) 742 ; throw(error(context_error(nodirective, 743 initialization(Goal, after_load)), 744 _)) 745 ). 746'$initialization'(restore, Goal, Source, Ctx) :- % deprecated 747 '$initialization'(restore_state, Goal, Source, Ctx). 748'$initialization'(restore_state, Goal, _Source, Ctx) :- 749 ( \+ current_prolog_flag(sandboxed_load, true) 750 -> '$compile_init_goal'(-, Goal, Ctx) 751 ; '$permission_error'(register, initialization(restore), Goal) 752 ). 753'$initialization'(prepare_state, Goal, _Source, Ctx) :- 754 ( \+ current_prolog_flag(sandboxed_load, true) 755 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx) 756 ; '$permission_error'(register, initialization(restore), Goal) 757 ). 758'$initialization'(program, Goal, _Source, Ctx) :- 759 ( \+ current_prolog_flag(sandboxed_load, true) 760 -> '$compile_init_goal'(when(program), Goal, Ctx) 761 ; '$permission_error'(register, initialization(restore), Goal) 762 ). 763'$initialization'(main, Goal, _Source, Ctx) :- 764 ( \+ current_prolog_flag(sandboxed_load, true) 765 -> '$compile_init_goal'(when(main), Goal, Ctx) 766 ; '$permission_error'(register, initialization(restore), Goal) 767 ). 768 769 770'$compile_init_goal'(Source, Goal, Ctx) :- 771 atom(Source), 772 Source \== (-), 773 !, 774 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx), 775 _Layout, Source, Ctx). 776'$compile_init_goal'(Source, Goal, Ctx) :- 777 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.789'$run_initialization'(_, loaded, _) :- !. 790'$run_initialization'(File, _Action, Options) :- 791 '$run_initialization'(File, Options). 792 793'$run_initialization'(File, Options) :- 794 setup_call_cleanup( 795 '$start_run_initialization'(Options, Restore), 796 '$run_initialization_2'(File), 797 '$end_run_initialization'(Restore)). 798 799'$start_run_initialization'(Options, OldSandBoxed) :- 800 '$push_input_context'(initialization), 801 '$set_sandboxed_load'(Options, OldSandBoxed). 802'$end_run_initialization'(OldSandBoxed) :- 803 set_prolog_flag(sandboxed_load, OldSandBoxed), 804 '$pop_input_context'. 805 806'$run_initialization_2'(File) :- 807 ( '$init_goal'(File, Goal, Ctx), 808 File \= when(_), 809 '$run_init_goal'(Goal, Ctx), 810 fail 811 ; true 812 ). 813 814'$run_init_goal'(Goal, Ctx) :- 815 ( catch_with_backtrace('$run_init_goal'(Goal), E, 816 '$initialization_error'(E, Goal, Ctx)) 817 -> true 818 ; '$initialization_failure'(Goal, Ctx) 819 ). 820 821:- multifile prolog:sandbox_allowed_goal/1. 822 823'$run_init_goal'(Goal) :- 824 current_prolog_flag(sandboxed_load, false), 825 !, 826 call(Goal). 827'$run_init_goal'(Goal) :- 828 prolog:sandbox_allowed_goal(Goal), 829 call(Goal). 830 831'$initialization_context'(Source, Ctx) :- 832 ( source_location(File, Line) 833 -> Ctx = File:Line, 834 '$input_context'(Context), 835 '$top_file'(Context, File, Source) 836 ; Ctx = (-), 837 File = (-) 838 ). 839 840'$top_file'([input(include, F1, _, _)|T], _, F) :- 841 !, 842 '$top_file'(T, F1, F). 843'$top_file'(_, F, F). 844 845 846'$initialization_error'(E, Goal, Ctx) :- 847 print_message(error, initialization_error(Goal, E, Ctx)). 848 849'$initialization_failure'(Goal, Ctx) :- 850 print_message(warning, initialization_failure(Goal, Ctx)).
858:- public '$clear_source_admin'/1. 859 860'$clear_source_admin'(File) :- 861 retractall('$init_goal'(_, _, File:_)), 862 retractall('$load_context_module'(File, _, _)), 863 retractall('$resolved_source_path_db'(_, _, File)). 864 865 866 /******************************* 867 * STREAM * 868 *******************************/ 869 870:- '$iso'(stream_property/2). 871stream_property(Stream, Property) :- 872 nonvar(Stream), 873 nonvar(Property), 874 !, 875 '$stream_property'(Stream, Property). 876stream_property(Stream, Property) :- 877 nonvar(Stream), 878 !, 879 '$stream_properties'(Stream, Properties), 880 '$member'(Property, Properties). 881stream_property(Stream, Property) :- 882 nonvar(Property), 883 !, 884 ( Property = alias(Alias), 885 atom(Alias) 886 -> '$alias_stream'(Alias, Stream) 887 ; '$streams_properties'(Property, Pairs), 888 '$member'(Stream-Property, Pairs) 889 ). 890stream_property(Stream, Property) :- 891 '$streams_properties'(Property, Pairs), 892 '$member'(Stream-Properties, Pairs), 893 '$member'(Property, Properties). 894 895 896 /******************************** 897 * MODULES * 898 *********************************/ 899 900% '$prefix_module'(+Module, +Context, +Term, -Prefixed) 901% Tags `Term' with `Module:' if `Module' is not the context module. 902 903'$prefix_module'(Module, Module, Head, Head) :- !. 904'$prefix_module'(Module, _, Head, Module:Head).
910default_module(Me, Super) :- 911 ( atom(Me) 912 -> ( var(Super) 913 -> '$default_module'(Me, Super) 914 ; '$default_module'(Me, Super), ! 915 ) 916 ; '$type_error'(module, Me) 917 ). 918 919'$default_module'(Me, Me). 920'$default_module'(Me, Super) :- 921 import_module(Me, S), 922 '$default_module'(S, Super). 923 924 925 /******************************** 926 * TRACE AND EXCEPTIONS * 927 *********************************/ 928 929:- dynamic user:exception/3. 930:- multifile user:exception/3. 931:- '$hide'(user:exception/3).
940:- public 941 '$undefined_procedure'/4. 942 943'$undefined_procedure'(Module, Name, Arity, Action) :- 944 '$prefix_module'(Module, user, Name/Arity, Pred), 945 user:exception(undefined_predicate, Pred, Action0), 946 !, 947 Action = Action0. 948'$undefined_procedure'(Module, Name, Arity, Action) :- 949 \+ current_prolog_flag(autoload, false), 950 '$autoload'(Module:Name/Arity), 951 !, 952 Action = retry. 953'$undefined_procedure'(_, _, _, error).
965'$loading'(Library) :- 966 current_prolog_flag(threads, true), 967 ( '$loading_file'(Library, _Queue, _LoadThread) 968 -> true 969 ; '$loading_file'(FullFile, _Queue, _LoadThread), 970 file_name_extension(Library, _, FullFile) 971 -> true 972 ). 973 974% handle debugger 'w', 'p' and <N> depth options. 975 976'$set_debugger_write_options'(write) :- 977 !, 978 create_prolog_flag(debugger_write_options, 979 [ quoted(true), 980 attributes(dots), 981 spacing(next_argument) 982 ], []). 983'$set_debugger_write_options'(print) :- 984 !, 985 create_prolog_flag(debugger_write_options, 986 [ quoted(true), 987 portray(true), 988 max_depth(10), 989 attributes(portray), 990 spacing(next_argument) 991 ], []). 992'$set_debugger_write_options'(Depth) :- 993 current_prolog_flag(debugger_write_options, Options0), 994 ( '$select'(max_depth(_), Options0, Options) 995 -> true 996 ; Options = Options0 997 ), 998 create_prolog_flag(debugger_write_options, 999 [max_depth(Depth)|Options], []). 1000 1001 1002 /******************************** 1003 * SYSTEM MESSAGES * 1004 *********************************/
query
channel. This
predicate may be hooked using confirm/2, which must return
a boolean.1013:- multifile 1014 prolog:confirm/2. 1015 1016'$confirm'(Spec) :- 1017 prolog:confirm(Spec, Result), 1018 !, 1019 Result == true. 1020'$confirm'(Spec) :- 1021 print_message(query, Spec), 1022 between(0, 5, _), 1023 get_single_char(Answer), 1024 ( '$in_reply'(Answer, 'yYjJ \n') 1025 -> !, 1026 print_message(query, if_tty([yes-[]])) 1027 ; '$in_reply'(Answer, 'nN') 1028 -> !, 1029 print_message(query, if_tty([no-[]])), 1030 fail 1031 ; print_message(help, query(confirm)), 1032 fail 1033 ). 1034 1035'$in_reply'(Code, Atom) :- 1036 char_code(Char, Code), 1037 sub_atom(Atom, _, _, _, Char), 1038 !. 1039 1040:- dynamic 1041 user:portray/1. 1042:- multifile 1043 user:portray/1. 1044:- '$notransact'(user:portray/1). 1045 1046 1047 /******************************* 1048 * FILE_SEARCH_PATH * 1049 *******************************/ 1050 1051:- dynamic 1052 user:file_search_path/2, 1053 user:library_directory/1. 1054:- multifile 1055 user:file_search_path/2, 1056 user:library_directory/1. 1057:- '$notransact'((user:file_search_path/2, 1058 user:library_directory/1)). 1059 1060user(file_search_path(library, Dir) :- 1061 library_directory(Dir)). 1062user:file_search_path(swi, Home) :- 1063 current_prolog_flag(home, Home). 1064user:file_search_path(swi, Home) :- 1065 current_prolog_flag(shared_home, Home). 1066user:file_search_path(library, app_config(lib)). 1067user:file_search_path(library, swi(library)). 1068user:file_search_path(library, swi(library/clp)). 1069user:file_search_path(library, Dir) :- 1070 '$ext_library_directory'(Dir). 1071user:file_search_path(foreign, swi(ArchLib)) :- 1072 current_prolog_flag(apple_universal_binary, true), 1073 ArchLib = 'lib/fat-darwin'. 1074user:file_search_path(path, Dir) :- 1075 getenv('PATH', Path), 1076 current_prolog_flag(path_sep, Sep), 1077 atomic_list_concat(Dirs, Sep, Path), 1078 '$member'(Dir, Dirs). 1079user:file_search_path(user_app_data, Dir) :- 1080 '$xdg_prolog_directory'(data, Dir). 1081user:file_search_path(common_app_data, Dir) :- 1082 '$xdg_prolog_directory'(common_data, Dir). 1083user:file_search_path(user_app_config, Dir) :- 1084 '$xdg_prolog_directory'(config, Dir). 1085user:file_search_path(common_app_config, Dir) :- 1086 '$xdg_prolog_directory'(common_config, Dir). 1087user:file_search_path(app_data, user_app_data('.')). 1088user:file_search_path(app_data, common_app_data('.')). 1089user:file_search_path(app_config, user_app_config('.')). 1090user:file_search_path(app_config, common_app_config('.')). 1091% backward compatibility 1092user:file_search_path(app_preferences, user_app_config('.')). 1093user:file_search_path(user_profile, app_preferences('.')). 1094user:file_search_path(app, swi(app)). 1095user:file_search_path(app, app_data(app)). 1096user:file_search_path(working_directory, CWD) :- 1097 working_directory(CWD, CWD). 1098 1099'$xdg_prolog_directory'(Which, Dir) :- 1100 '$xdg_directory'(Which, XDGDir), 1101 '$make_config_dir'(XDGDir), 1102 '$ensure_slash'(XDGDir, XDGDirS), 1103 atom_concat(XDGDirS, 'swi-prolog', Dir), 1104 '$make_config_dir'(Dir). 1105 1106'$xdg_directory'(Which, Dir) :- 1107 '$xdg_directory_search'(Where), 1108 '$xdg_directory'(Which, Where, Dir). 1109 1110'$xdg_directory_search'(xdg) :- 1111 current_prolog_flag(xdg, true), 1112 !. 1113'$xdg_directory_search'(Where) :- 1114 current_prolog_flag(windows, true), 1115 ( current_prolog_flag(xdg, false) 1116 -> Where = windows 1117 ; '$member'(Where, [windows, xdg]) 1118 ). 1119 1120% config 1121'$xdg_directory'(config, windows, Home) :- 1122 catch(win_folder(appdata, Home), _, fail). 1123'$xdg_directory'(config, xdg, Home) :- 1124 getenv('XDG_CONFIG_HOME', Home). 1125'$xdg_directory'(config, xdg, Home) :- 1126 expand_file_name('~/.config', [Home]). 1127% data 1128'$xdg_directory'(data, windows, Home) :- 1129 catch(win_folder(local_appdata, Home), _, fail). 1130'$xdg_directory'(data, xdg, Home) :- 1131 getenv('XDG_DATA_HOME', Home). 1132'$xdg_directory'(data, xdg, Home) :- 1133 expand_file_name('~/.local', [Local]), 1134 '$make_config_dir'(Local), 1135 atom_concat(Local, '/share', Home), 1136 '$make_config_dir'(Home). 1137% common data 1138'$xdg_directory'(common_data, windows, Dir) :- 1139 catch(win_folder(common_appdata, Dir), _, fail). 1140'$xdg_directory'(common_data, xdg, Dir) :- 1141 '$existing_dir_from_env_path'('XDG_DATA_DIRS', 1142 [ '/usr/local/share', 1143 '/usr/share' 1144 ], 1145 Dir). 1146% common config 1147'$xdg_directory'(common_config, windows, Dir) :- 1148 catch(win_folder(common_appdata, Dir), _, fail). 1149'$xdg_directory'(common_config, xdg, Dir) :- 1150 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir). 1151 1152'$existing_dir_from_env_path'(Env, Defaults, Dir) :- 1153 ( getenv(Env, Path) 1154 -> current_prolog_flag(path_sep, Sep), 1155 atomic_list_concat(Dirs, Sep, Path) 1156 ; Dirs = Defaults 1157 ), 1158 '$member'(Dir, Dirs), 1159 Dir \== '', 1160 exists_directory(Dir). 1161 1162'$make_config_dir'(Dir) :- 1163 exists_directory(Dir), 1164 !. 1165'$make_config_dir'(Dir) :- 1166 nb_current('$create_search_directories', true), 1167 file_directory_name(Dir, Parent), 1168 '$my_file'(Parent), 1169 catch(make_directory(Dir), _, fail). 1170 1171'$ensure_slash'(Dir, DirS) :- 1172 ( sub_atom(Dir, _, _, 0, /) 1173 -> DirS = Dir 1174 ; atom_concat(Dir, /, DirS) 1175 ). 1176 1177:- dynamic '$ext_lib_dirs'/1. 1178:- volatile '$ext_lib_dirs'/1. 1179 1180'$ext_library_directory'(Dir) :- 1181 '$ext_lib_dirs'(Dirs), 1182 !, 1183 '$member'(Dir, Dirs). 1184'$ext_library_directory'(Dir) :- 1185 current_prolog_flag(home, Home), 1186 atom_concat(Home, '/library/ext/*', Pattern), 1187 expand_file_name(Pattern, Dirs0), 1188 '$include'(exists_directory, Dirs0, Dirs), 1189 asserta('$ext_lib_dirs'(Dirs)), 1190 '$member'(Dir, Dirs).
1195'$expand_file_search_path'(Spec, Expanded, Cond) :- 1196 '$option'(access(Access), Cond), 1197 memberchk(Access, [write,append]), 1198 !, 1199 setup_call_cleanup( 1200 nb_setval('$create_search_directories', true), 1201 expand_file_search_path(Spec, Expanded), 1202 nb_delete('$create_search_directories')). 1203'$expand_file_search_path'(Spec, Expanded, _Cond) :- 1204 expand_file_search_path(Spec, Expanded).
1212expand_file_search_path(Spec, Expanded) :- 1213 catch('$expand_file_search_path'(Spec, Expanded, 0, []), 1214 loop(Used), 1215 throw(error(loop_error(Spec), file_search(Used)))). 1216 1217'$expand_file_search_path'(Spec, Expanded, N, Used) :- 1218 functor(Spec, Alias, 1), 1219 !, 1220 user:file_search_path(Alias, Exp0), 1221 NN is N + 1, 1222 ( NN > 16 1223 -> throw(loop(Used)) 1224 ; true 1225 ), 1226 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]), 1227 arg(1, Spec, Segments), 1228 '$segments_to_atom'(Segments, File), 1229 '$make_path'(Exp1, File, Expanded). 1230'$expand_file_search_path'(Spec, Path, _, _) :- 1231 '$segments_to_atom'(Spec, Path). 1232 1233'$make_path'(Dir, '.', Path) :- 1234 !, 1235 Path = Dir. 1236'$make_path'(Dir, File, Path) :- 1237 sub_atom(Dir, _, _, 0, /), 1238 !, 1239 atom_concat(Dir, File, Path). 1240'$make_path'(Dir, File, Path) :- 1241 atomic_list_concat([Dir, /, File], Path). 1242 1243 1244 /******************************** 1245 * FILE CHECKING * 1246 *********************************/
1257absolute_file_name(Spec, Options, Path) :- 1258 '$is_options'(Options), 1259 \+ '$is_options'(Path), 1260 !, 1261 '$absolute_file_name'(Spec, Path, Options). 1262absolute_file_name(Spec, Path, Options) :- 1263 '$absolute_file_name'(Spec, Path, Options). 1264 1265'$absolute_file_name'(Spec, Path, Options0) :- 1266 '$options_dict'(Options0, Options), 1267 % get the valid extensions 1268 ( '$select_option'(extensions(Exts), Options, Options1) 1269 -> '$must_be'(list, Exts) 1270 ; '$option'(file_type(Type), Options) 1271 -> '$must_be'(atom, Type), 1272 '$file_type_extensions'(Type, Exts), 1273 Options1 = Options 1274 ; Options1 = Options, 1275 Exts = [''] 1276 ), 1277 '$canonicalise_extensions'(Exts, Extensions), 1278 % unless specified otherwise, ask regular file 1279 ( ( nonvar(Type) 1280 ; '$option'(access(none), Options, none) 1281 ) 1282 -> Options2 = Options1 1283 ; '$merge_options'(_{file_type:regular}, Options1, Options2) 1284 ), 1285 % Det or nondet? 1286 ( '$select_option'(solutions(Sols), Options2, Options3) 1287 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols) 1288 ; Sols = first, 1289 Options3 = Options2 1290 ), 1291 % Errors or not? 1292 ( '$select_option'(file_errors(FileErrors), Options3, Options4) 1293 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors) 1294 ; FileErrors = error, 1295 Options4 = Options3 1296 ), 1297 % Expand shell patterns? 1298 ( atomic(Spec), 1299 '$select_option'(expand(Expand), Options4, Options5), 1300 '$must_be'(boolean, Expand) 1301 -> expand_file_name(Spec, List), 1302 '$member'(Spec1, List) 1303 ; Spec1 = Spec, 1304 Options5 = Options4 1305 ), 1306 % Search for files 1307 ( Sols == first 1308 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path) 1309 -> ! % also kill choice point of expand_file_name/2 1310 ; ( FileErrors == fail 1311 -> fail 1312 ; '$current_module'('$bags', _File), 1313 findall(P, 1314 '$chk_file'(Spec1, Extensions, [access(exist)], 1315 false, P), 1316 Candidates), 1317 '$abs_file_error'(Spec, Candidates, Options5) 1318 ) 1319 ) 1320 ; '$chk_file'(Spec1, Extensions, Options5, false, Path) 1321 ). 1322 1323'$abs_file_error'(Spec, Candidates, Conditions) :- 1324 '$member'(F, Candidates), 1325 '$member'(C, Conditions), 1326 '$file_condition'(C), 1327 '$file_error'(C, Spec, F, E, Comment), 1328 !, 1329 throw(error(E, context(_, Comment))). 1330'$abs_file_error'(Spec, _, _) :- 1331 '$existence_error'(source_sink, Spec). 1332 1333'$file_error'(file_type(directory), Spec, File, Error, Comment) :- 1334 \+ exists_directory(File), 1335 !, 1336 Error = existence_error(directory, Spec), 1337 Comment = not_a_directory(File). 1338'$file_error'(file_type(_), Spec, File, Error, Comment) :- 1339 exists_directory(File), 1340 !, 1341 Error = existence_error(file, Spec), 1342 Comment = directory(File). 1343'$file_error'(access(OneOrList), Spec, File, Error, _) :- 1344 '$one_or_member'(Access, OneOrList), 1345 \+ access_file(File, Access), 1346 Error = permission_error(Access, source_sink, Spec). 1347 1348'$one_or_member'(Elem, List) :- 1349 is_list(List), 1350 !, 1351 '$member'(Elem, List). 1352'$one_or_member'(Elem, Elem). 1353 1354 1355'$file_type_extensions'(source, Exts) :- % SICStus 3.9 compatibility 1356 !, 1357 '$file_type_extensions'(prolog, Exts). 1358'$file_type_extensions'(Type, Exts) :- 1359 '$current_module'('$bags', _File), 1360 !, 1361 findall(Ext, user:prolog_file_type(Ext, Type), Exts0), 1362 ( Exts0 == [], 1363 \+ '$ft_no_ext'(Type) 1364 -> '$domain_error'(file_type, Type) 1365 ; true 1366 ), 1367 '$append'(Exts0, [''], Exts). 1368'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ... 1369 1370'$ft_no_ext'(txt). 1371'$ft_no_ext'(executable). 1372'$ft_no_ext'(directory). 1373'$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.
1386:- multifile(user:prolog_file_type/2). 1387:- dynamic(user:prolog_file_type/2). 1388 1389userprolog_file_type(pl, prolog). 1390userprolog_file_type(prolog, prolog). 1391userprolog_file_type(qlf, prolog). 1392userprolog_file_type(qlf, qlf). 1393userprolog_file_type(Ext, executable) :- 1394 current_prolog_flag(shared_object_extension, Ext). 1395userprolog_file_type(dylib, executable) :- 1396 current_prolog_flag(apple, true).
1403'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :- 1404 \+ ground(Spec), 1405 !, 1406 '$instantiation_error'(Spec). 1407'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :- 1408 compound(Spec), 1409 functor(Spec, _, 1), 1410 !, 1411 '$relative_to'(Cond, cwd, CWD), 1412 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName). 1413'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- % allow a/b/... 1414 \+ atomic(Segments), 1415 !, 1416 '$segments_to_atom'(Segments, Atom), 1417 '$chk_file'(Atom, Ext, Cond, Cache, FullName). 1418'$chk_file'(File, Exts, Cond, _, FullName) :- % Absolute files 1419 is_absolute_file_name(File), 1420 !, 1421 '$extend_file'(File, Exts, Extended), 1422 '$file_conditions'(Cond, Extended), 1423 '$absolute_file_name'(Extended, FullName). 1424'$chk_file'(File, Exts, Cond, _, FullName) :- % Explicit relative_to 1425 '$option'(relative_to(_), Cond), 1426 !, 1427 '$relative_to'(Cond, none, Dir), 1428 '$chk_file_relative_to'(File, Exts, Cond, Dir, FullName). 1429'$chk_file'(File, Exts, Cond, _Cache, FullName) :- % From source 1430 source_location(ContextFile, _Line), 1431 !, 1432 ( file_directory_name(ContextFile, Dir), 1433 '$chk_file_relative_to'(File, Exts, Cond, Dir, FullName) 1434 -> true 1435 ; current_prolog_flag(source_search_working_directory, true), 1436 '$extend_file'(File, Exts, Extended), 1437 '$file_conditions'(Cond, Extended), 1438 '$absolute_file_name'(Extended, FullName), 1439 '$print_message'(warning, 1440 deprecated(source_search_working_directory( 1441 File, FullName))) 1442 ). 1443'$chk_file'(File, Exts, Cond, _Cache, FullName) :- % Not loading source 1444 '$extend_file'(File, Exts, Extended), 1445 '$file_conditions'(Cond, Extended), 1446 '$absolute_file_name'(Extended, FullName). 1447 1448'$chk_file_relative_to'(File, Exts, Cond, Dir, FullName) :- 1449 atomic_list_concat([Dir, /, File], AbsFile), 1450 '$extend_file'(AbsFile, Exts, Extended), 1451 '$file_conditions'(Cond, Extended), 1452 '$absolute_file_name'(Extended, FullName). 1453 1454 1455'$segments_to_atom'(Atom, Atom) :- 1456 atomic(Atom), 1457 !. 1458'$segments_to_atom'(Segments, Atom) :- 1459 '$segments_to_list'(Segments, List, []), 1460 !, 1461 atomic_list_concat(List, /, Atom). 1462 1463'$segments_to_list'(A/B, H, T) :- 1464 '$segments_to_list'(A, H, T0), 1465 '$segments_to_list'(B, T0, T). 1466'$segments_to_list'(A, [A|T], T) :- 1467 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1477'$relative_to'(Conditions, Default, Dir) :-
1478 ( '$option'(relative_to(FileOrDir), Conditions)
1479 *-> ( exists_directory(FileOrDir)
1480 -> Dir = FileOrDir
1481 ; atom_concat(Dir, /, FileOrDir)
1482 -> true
1483 ; file_directory_name(FileOrDir, Dir)
1484 )
1485 ; Default == cwd
1486 -> working_directory(Dir, Dir)
1487 ; Default == source
1488 -> source_location(ContextFile, _Line),
1489 file_directory_name(ContextFile, Dir)
1490 ).
1495:- dynamic 1496 '$search_path_file_cache'/3, % SHA1, Time, Path 1497 '$search_path_gc_time'/1. % Time 1498:- volatile 1499 '$search_path_file_cache'/3, 1500 '$search_path_gc_time'/1. 1501:- '$notransact'(('$search_path_file_cache'/3, 1502 '$search_path_gc_time'/1)). 1503 1504:- create_prolog_flag(file_search_cache_time, 10, []). 1505 1506'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1507 !, 1508 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1509 current_prolog_flag(emulated_dialect, Dialect), 1510 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1511 variant_sha1(Spec+Cache, SHA1), 1512 get_time(Now), 1513 current_prolog_flag(file_search_cache_time, TimeOut), 1514 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1515 CachedTime > Now - TimeOut, 1516 '$file_conditions'(Cond, FullFile) 1517 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1518 ; '$member'(Expanded, Expansions), 1519 '$extend_file'(Expanded, Exts, LibFile), 1520 ( '$file_conditions'(Cond, LibFile), 1521 '$absolute_file_name'(LibFile, FullFile), 1522 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1523 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1524 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1525 fail 1526 ) 1527 ). 1528'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1529 '$expand_file_search_path'(Spec, Expanded, Cond), 1530 '$extend_file'(Expanded, Exts, LibFile), 1531 '$file_conditions'(Cond, LibFile), 1532 '$absolute_file_name'(LibFile, FullFile). 1533 1534'$cache_file_found'(_, _, TimeOut, _) :- 1535 TimeOut =:= 0, 1536 !. 1537'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1538 '$search_path_file_cache'(SHA1, Saved, FullFile), 1539 !, 1540 ( Now - Saved < TimeOut/2 1541 -> true 1542 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1543 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1544 ). 1545'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1546 'gc_file_search_cache'(TimeOut), 1547 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1548 1549'gc_file_search_cache'(TimeOut) :- 1550 get_time(Now), 1551 '$search_path_gc_time'(Last), 1552 Now-Last < TimeOut/2, 1553 !. 1554'gc_file_search_cache'(TimeOut) :- 1555 get_time(Now), 1556 retractall('$search_path_gc_time'(_)), 1557 assertz('$search_path_gc_time'(Now)), 1558 Before is Now - TimeOut, 1559 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1560 Cached < Before, 1561 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1562 fail 1563 ; true 1564 ). 1565 1566 1567'$search_message'(Term) :- 1568 current_prolog_flag(verbose_file_search, true), 1569 !, 1570 print_message(informational, Term). 1571'$search_message'(_).
1578'$file_conditions'(List, File) :- 1579 is_list(List), 1580 !, 1581 \+ ( '$member'(C, List), 1582 '$file_condition'(C), 1583 \+ '$file_condition'(C, File) 1584 ). 1585'$file_conditions'(Map, File) :- 1586 \+ ( get_dict(Key, Map, Value), 1587 C =.. [Key,Value], 1588 '$file_condition'(C), 1589 \+ '$file_condition'(C, File) 1590 ). 1591 1592'$file_condition'(file_type(directory), File) :- 1593 !, 1594 exists_directory(File). 1595'$file_condition'(file_type(_), File) :- 1596 !, 1597 \+ exists_directory(File). 1598'$file_condition'(access(Accesses), File) :- 1599 !, 1600 \+ ( '$one_or_member'(Access, Accesses), 1601 \+ access_file(File, Access) 1602 ). 1603 1604'$file_condition'(exists). 1605'$file_condition'(file_type(_)). 1606'$file_condition'(access(_)). 1607 1608'$extend_file'(File, Exts, FileEx) :- 1609 '$ensure_extensions'(Exts, File, Fs), 1610 '$list_to_set'(Fs, FsSet), 1611 '$member'(FileEx, FsSet). 1612 1613'$ensure_extensions'([], _, []). 1614'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1615 file_name_extension(F, E, FE), 1616 '$ensure_extensions'(E0, F, E1).
1623'$list_to_set'(List, Set) :- 1624 '$number_list'(List, 1, Numbered), 1625 sort(1, @=<, Numbered, ONum), 1626 '$remove_dup_keys'(ONum, NumSet), 1627 sort(2, @=<, NumSet, ONumSet), 1628 '$pairs_keys'(ONumSet, Set). 1629 1630'$number_list'([], _, []). 1631'$number_list'([H|T0], N, [H-N|T]) :- 1632 N1 is N+1, 1633 '$number_list'(T0, N1, T). 1634 1635'$remove_dup_keys'([], []). 1636'$remove_dup_keys'([H|T0], [H|T]) :- 1637 H = V-_, 1638 '$remove_same_key'(T0, V, T1), 1639 '$remove_dup_keys'(T1, T). 1640 1641'$remove_same_key'([V1-_|T0], V, T) :- 1642 V1 == V, 1643 !, 1644 '$remove_same_key'(T0, V, T). 1645'$remove_same_key'(L, _, L). 1646 1647'$pairs_keys'([], []). 1648'$pairs_keys'([K-_|T0], [K|T]) :- 1649 '$pairs_keys'(T0, T). 1650 1651'$pairs_values'([], []). 1652'$pairs_values'([_-V|T0], [V|T]) :- 1653 '$pairs_values'(T0, T). 1654 1655/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1656Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1657the Quintus compatibility requests `pl'. This layer canonicalises all 1658extensions to .ext 1659- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1660 1661'$canonicalise_extensions'([], []) :- !. 1662'$canonicalise_extensions'([H|T], [CH|CT]) :- 1663 !, 1664 '$must_be'(atom, H), 1665 '$canonicalise_extension'(H, CH), 1666 '$canonicalise_extensions'(T, CT). 1667'$canonicalise_extensions'(E, [CE]) :- 1668 '$canonicalise_extension'(E, CE). 1669 1670'$canonicalise_extension'('', '') :- !. 1671'$canonicalise_extension'(DotAtom, DotAtom) :- 1672 sub_atom(DotAtom, 0, _, _, '.'), 1673 !. 1674'$canonicalise_extension'(Atom, DotAtom) :- 1675 atom_concat('.', Atom, DotAtom). 1676 1677 1678 /******************************** 1679 * CONSULT * 1680 *********************************/ 1681 1682:- dynamic 1683 user:library_directory/1, 1684 user:prolog_load_file/2. 1685:- multifile 1686 user:library_directory/1, 1687 user:prolog_load_file/2. 1688 1689:- prompt(_, '|: '). 1690 1691:- thread_local 1692 '$compilation_mode_store'/1, % database, wic, qlf 1693 '$directive_mode_store'/1. % database, wic, qlf 1694:- volatile 1695 '$compilation_mode_store'/1, 1696 '$directive_mode_store'/1. 1697:- '$notransact'(('$compilation_mode_store'/1, 1698 '$directive_mode_store'/1)). 1699 1700'$compilation_mode'(Mode) :- 1701 ( '$compilation_mode_store'(Val) 1702 -> Mode = Val 1703 ; Mode = database 1704 ). 1705 1706'$set_compilation_mode'(Mode) :- 1707 retractall('$compilation_mode_store'(_)), 1708 assertz('$compilation_mode_store'(Mode)). 1709 1710'$compilation_mode'(Old, New) :- 1711 '$compilation_mode'(Old), 1712 ( New == Old 1713 -> true 1714 ; '$set_compilation_mode'(New) 1715 ). 1716 1717'$directive_mode'(Mode) :- 1718 ( '$directive_mode_store'(Val) 1719 -> Mode = Val 1720 ; Mode = database 1721 ). 1722 1723'$directive_mode'(Old, New) :- 1724 '$directive_mode'(Old), 1725 ( New == Old 1726 -> true 1727 ; '$set_directive_mode'(New) 1728 ). 1729 1730'$set_directive_mode'(Mode) :- 1731 retractall('$directive_mode_store'(_)), 1732 assertz('$directive_mode_store'(Mode)).
1740'$compilation_level'(Level) :- 1741 '$input_context'(Stack), 1742 '$compilation_level'(Stack, Level). 1743 1744'$compilation_level'([], 0). 1745'$compilation_level'([Input|T], Level) :- 1746 ( arg(1, Input, see) 1747 -> '$compilation_level'(T, Level) 1748 ; '$compilation_level'(T, Level0), 1749 Level is Level0+1 1750 ).
1758compiling :- 1759 \+ ( '$compilation_mode'(database), 1760 '$directive_mode'(database) 1761 ). 1762 1763:- meta_predicate 1764 '$ifcompiling'( ). 1765 1766'$ifcompiling'(G) :- 1767 ( '$compilation_mode'(database) 1768 -> true 1769 ; call(G) 1770 ). 1771 1772 /******************************** 1773 * READ SOURCE * 1774 *********************************/
1778'$load_msg_level'(Action, Nesting, Start, Done) :- 1779 '$update_autoload_level'([], 0), 1780 !, 1781 current_prolog_flag(verbose_load, Type0), 1782 '$load_msg_compat'(Type0, Type), 1783 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1784 -> true 1785 ). 1786'$load_msg_level'(_, _, silent, silent). 1787 1788'$load_msg_compat'(true, normal) :- !. 1789'$load_msg_compat'(false, silent) :- !. 1790'$load_msg_compat'(X, X). 1791 1792'$load_msg_level'(load_file, _, full, informational, informational). 1793'$load_msg_level'(include_file, _, full, informational, informational). 1794'$load_msg_level'(load_file, _, normal, silent, informational). 1795'$load_msg_level'(include_file, _, normal, silent, silent). 1796'$load_msg_level'(load_file, 0, brief, silent, informational). 1797'$load_msg_level'(load_file, _, brief, silent, silent). 1798'$load_msg_level'(include_file, _, brief, silent, silent). 1799'$load_msg_level'(load_file, _, silent, silent, silent). 1800'$load_msg_level'(include_file, _, silent, silent, silent).
1823'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1824 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1825 ( Term == end_of_file 1826 -> !, fail 1827 ; Term \== begin_of_file 1828 ). 1829 1830'$source_term'(Input, _,_,_,_,_,_,_) :- 1831 \+ ground(Input), 1832 !, 1833 '$instantiation_error'(Input). 1834'$source_term'(stream(Id, In, Opts), 1835 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1836 !, 1837 '$record_included'(Parents, Id, Id, 0.0, Message), 1838 setup_call_cleanup( 1839 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1840 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1841 [Id|Parents], Options), 1842 '$close_source'(State, Message)). 1843'$source_term'(File, 1844 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1845 absolute_file_name(File, Path, 1846 [ file_type(prolog), 1847 access(read) 1848 ]), 1849 time_file(Path, Time), 1850 '$record_included'(Parents, File, Path, Time, Message), 1851 setup_call_cleanup( 1852 '$open_source'(Path, In, State, Parents, Options), 1853 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1854 [Path|Parents], Options), 1855 '$close_source'(State, Message)). 1856 1857:- thread_local 1858 '$load_input'/2. 1859:- volatile 1860 '$load_input'/2. 1861:- '$notransact'('$load_input'/2). 1862 1863'$open_source'(stream(Id, In, Opts), In, 1864 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1865 !, 1866 '$context_type'(Parents, ContextType), 1867 '$push_input_context'(ContextType), 1868 '$prepare_load_stream'(In, Id, StreamState), 1869 asserta('$load_input'(stream(Id), In), Ref). 1870'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1871 '$context_type'(Parents, ContextType), 1872 '$push_input_context'(ContextType), 1873 '$open_source'(Path, In, Options), 1874 '$set_encoding'(In, Options), 1875 asserta('$load_input'(Path, In), Ref). 1876 1877'$context_type'([], load_file) :- !. 1878'$context_type'(_, include). 1879 1880:- multifile prolog:open_source_hook/3. 1881 1882'$open_source'(Path, In, Options) :- 1883 prolog:open_source_hook(Path, In, Options), 1884 !. 1885'$open_source'(Path, In, _Options) :- 1886 open(Path, read, In). 1887 1888'$close_source'(close(In, _Id, Ref), Message) :- 1889 erase(Ref), 1890 call_cleanup( 1891 close(In), 1892 '$pop_input_context'), 1893 '$close_message'(Message). 1894'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1895 erase(Ref), 1896 call_cleanup( 1897 '$restore_load_stream'(In, StreamState, Opts), 1898 '$pop_input_context'), 1899 '$close_message'(Message). 1900 1901'$close_message'(message(Level, Msg)) :- 1902 !, 1903 '$print_message'(Level, Msg). 1904'$close_message'(_).
1916'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1917 Parents \= [_,_|_], 1918 ( '$load_input'(_, Input) 1919 -> stream_property(Input, file_name(File)) 1920 ), 1921 '$set_source_location'(File, 0), 1922 '$expanded_term'(In, 1923 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1924 Stream, Parents, Options). 1925'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1926 '$skip_script_line'(In, Options), 1927 '$read_clause_options'(Options, ReadOptions), 1928 '$repeat_and_read_error_mode'(ErrorMode), 1929 read_clause(In, Raw, 1930 [ syntax_errors(ErrorMode), 1931 variable_names(Bindings), 1932 term_position(Pos), 1933 subterm_positions(RawLayout) 1934 | ReadOptions 1935 ]), 1936 b_setval('$term_position', Pos), 1937 b_setval('$variable_names', Bindings), 1938 ( Raw == end_of_file 1939 -> !, 1940 ( Parents = [_,_|_] % Included file 1941 -> fail 1942 ; '$expanded_term'(In, 1943 Raw, RawLayout, Read, RLayout, Term, TLayout, 1944 Stream, Parents, Options) 1945 ) 1946 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1947 Stream, Parents, Options) 1948 ). 1949 1950'$read_clause_options'([], []). 1951'$read_clause_options'([H|T0], List) :- 1952 ( '$read_clause_option'(H) 1953 -> List = [H|T] 1954 ; List = T 1955 ), 1956 '$read_clause_options'(T0, T). 1957 1958'$read_clause_option'(syntax_errors(_)). 1959'$read_clause_option'(term_position(_)). 1960'$read_clause_option'(process_comment(_)).
expand.pl
is not yet
loaded.1968'$repeat_and_read_error_mode'(Mode) :- 1969 ( current_predicate('$including'/0) 1970 -> repeat, 1971 ( '$including' 1972 -> Mode = dec10 1973 ; Mode = quiet 1974 ) 1975 ; Mode = dec10, 1976 repeat 1977 ). 1978 1979 1980'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1981 Stream, Parents, Options) :- 1982 E = error(_,_), 1983 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1984 '$print_message_fail'(E)), 1985 ( Expanded \== [] 1986 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1987 ; Term1 = Expanded, 1988 Layout1 = ExpandedLayout 1989 ), 1990 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1991 -> ( Directive = include(File), 1992 '$current_source_module'(Module), 1993 '$valid_directive'(Module:include(File)) 1994 -> stream_property(In, encoding(Enc)), 1995 '$add_encoding'(Enc, Options, Options1), 1996 '$source_term'(File, Read, RLayout, Term, TLayout, 1997 Stream, Parents, Options1) 1998 ; Directive = encoding(Enc) 1999 -> set_stream(In, encoding(Enc)), 2000 fail 2001 ; Term = Term1, 2002 Stream = In, 2003 Read = Raw 2004 ) 2005 ; Term = Term1, 2006 TLayout = Layout1, 2007 Stream = In, 2008 Read = Raw, 2009 RLayout = RawLayout 2010 ). 2011 2012'$expansion_member'(Var, Layout, Var, Layout) :- 2013 var(Var), 2014 !. 2015'$expansion_member'([], _, _, _) :- !, fail. 2016'$expansion_member'(List, ListLayout, Term, Layout) :- 2017 is_list(List), 2018 !, 2019 ( var(ListLayout) 2020 -> '$member'(Term, List) 2021 ; is_list(ListLayout) 2022 -> '$member_rep2'(Term, Layout, List, ListLayout) 2023 ; Layout = ListLayout, 2024 '$member'(Term, List) 2025 ). 2026'$expansion_member'(X, Layout, X, Layout). 2027 2028% pairwise member, repeating last element of the second 2029% list. 2030 2031'$member_rep2'(H1, H2, [H1|_], [H2|_]). 2032'$member_rep2'(H1, H2, [_|T1], [T2]) :- 2033 !, 2034 '$member_rep2'(H1, H2, T1, [T2]). 2035'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 2036 '$member_rep2'(H1, H2, T1, T2).
2040'$add_encoding'(Enc, Options0, Options) :- 2041 ( Options0 = [encoding(Enc)|_] 2042 -> Options = Options0 2043 ; Options = [encoding(Enc)|Options0] 2044 ). 2045 2046 2047:- multifile 2048 '$included'/4. % Into, Line, File, LastModified 2049:- dynamic 2050 '$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'.
2064'$record_included'([Parent|Parents], File, Path, Time, 2065 message(DoneMsgLevel, 2066 include_file(done(Level, file(File, Path))))) :- 2067 source_location(SrcFile, Line), 2068 !, 2069 '$compilation_level'(Level), 2070 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 2071 '$print_message'(StartMsgLevel, 2072 include_file(start(Level, 2073 file(File, Path)))), 2074 '$last'([Parent|Parents], Owner), 2075 ( ( '$compilation_mode'(database) 2076 ; '$qlf_current_source'(Owner) 2077 ) 2078 -> '$store_admin_clause'( 2079 system:'$included'(Parent, Line, Path, Time), 2080 _, Owner, SrcFile:Line) 2081 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 2082 ). 2083'$record_included'(_, _, _, _, true).
2089'$master_file'(File, MasterFile) :- 2090 '$included'(MasterFile0, _Line, File, _Time), 2091 !, 2092 '$master_file'(MasterFile0, MasterFile). 2093'$master_file'(File, File). 2094 2095 2096'$skip_script_line'(_In, Options) :- 2097 '$option'(check_script(false), Options), 2098 !. 2099'$skip_script_line'(In, _Options) :- 2100 ( peek_char(In, #) 2101 -> skip(In, 10) 2102 ; true 2103 ). 2104 2105'$set_encoding'(Stream, Options) :- 2106 '$option'(encoding(Enc), Options), 2107 !, 2108 Enc \== default, 2109 set_stream(Stream, encoding(Enc)). 2110'$set_encoding'(_, _). 2111 2112 2113'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 2114 ( stream_property(In, file_name(_)) 2115 -> HasName = true, 2116 ( stream_property(In, position(_)) 2117 -> HasPos = true 2118 ; HasPos = false, 2119 set_stream(In, record_position(true)) 2120 ) 2121 ; HasName = false, 2122 set_stream(In, file_name(Id)), 2123 ( stream_property(In, position(_)) 2124 -> HasPos = true 2125 ; HasPos = false, 2126 set_stream(In, record_position(true)) 2127 ) 2128 ). 2129 2130'$restore_load_stream'(In, _State, Options) :- 2131 memberchk(close(true), Options), 2132 !, 2133 close(In). 2134'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 2135 ( HasName == false 2136 -> set_stream(In, file_name('')) 2137 ; true 2138 ), 2139 ( HasPos == false 2140 -> set_stream(In, record_position(false)) 2141 ; true 2142 ). 2143 2144 2145 /******************************* 2146 * DERIVED FILES * 2147 *******************************/ 2148 2149:- dynamic 2150 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2151 2152'$register_derived_source'(_, '-') :- !. 2153'$register_derived_source'(Loaded, DerivedFrom) :- 2154 retractall('$derived_source_db'(Loaded, _, _)), 2155 time_file(DerivedFrom, Time), 2156 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2157 2158% Auto-importing dynamic predicates is not very elegant and 2159% leads to problems with qsave_program/[1,2] 2160 2161'$derived_source'(Loaded, DerivedFrom, Time) :- 2162 '$derived_source_db'(Loaded, DerivedFrom, Time). 2163 2164 2165 /******************************** 2166 * LOAD PREDICATES * 2167 *********************************/ 2168 2169:- meta_predicate 2170 ensure_loaded( ), 2171 [, | ] 2172 consult( ), 2173 use_module( ), 2174 use_module( , ), 2175 reexport( ), 2176 reexport( , ), 2177 load_files( ), 2178 load_files( , ).
2186ensure_loaded(Files) :-
2187 load_files(Files, [if(not_loaded)]).
2196use_module(Files) :-
2197 load_files(Files, [ if(not_loaded),
2198 must_be_module(true)
2199 ]).
2206use_module(File, Import) :-
2207 load_files(File, [ if(not_loaded),
2208 must_be_module(true),
2209 imports(Import)
2210 ]).
2216reexport(Files) :-
2217 load_files(Files, [ if(not_loaded),
2218 must_be_module(true),
2219 reexport(true)
2220 ]).
2226reexport(File, Import) :- 2227 load_files(File, [ if(not_loaded), 2228 must_be_module(true), 2229 imports(Import), 2230 reexport(true) 2231 ]). 2232 2233 2234[X] :- 2235 !, 2236 consult(X). 2237[M:F|R] :- 2238 consult(M:[F|R]). 2239 2240consult(M:X) :- 2241 X == user, 2242 !, 2243 flag('$user_consult', N, N+1), 2244 NN is N + 1, 2245 atom_concat('user://', NN, Id), 2246 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2247consult(List) :- 2248 load_files(List, [expand(true)]).
2255load_files(Files) :- 2256 load_files(Files, []). 2257load_files(Module:Files, Options) :- 2258 '$must_be'(list, Options), 2259 '$load_files'(Files, Module, Options). 2260 2261'$load_files'(X, _, _) :- 2262 var(X), 2263 !, 2264 '$instantiation_error'(X). 2265'$load_files'([], _, _) :- !. 2266'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2267 '$option'(stream(_), Options), 2268 !, 2269 ( atom(Id) 2270 -> '$load_file'(Id, Module, Options) 2271 ; throw(error(type_error(atom, Id), _)) 2272 ). 2273'$load_files'(List, Module, Options) :- 2274 List = [_|_], 2275 !, 2276 '$must_be'(list, List), 2277 '$load_file_list'(List, Module, Options). 2278'$load_files'(File, Module, Options) :- 2279 '$load_one_file'(File, Module, Options). 2280 2281'$load_file_list'([], _, _). 2282'$load_file_list'([File|Rest], Module, Options) :- 2283 E = error(_,_), 2284 catch('$load_one_file'(File, Module, Options), E, 2285 '$print_message'(error, E)), 2286 '$load_file_list'(Rest, Module, Options). 2287 2288 2289'$load_one_file'(Spec, Module, Options) :- 2290 atomic(Spec), 2291 '$option'(expand(Expand), Options, false), 2292 Expand == true, 2293 !, 2294 expand_file_name(Spec, Expanded), 2295 ( Expanded = [Load] 2296 -> true 2297 ; Load = Expanded 2298 ), 2299 '$load_files'(Load, Module, [expand(false)|Options]). 2300'$load_one_file'(File, Module, Options) :- 2301 strip_module(Module:File, Into, PlainFile), 2302 '$load_file'(PlainFile, Into, Options).
2309'$noload'(true, _, _) :- 2310 !, 2311 fail. 2312'$noload'(_, FullFile, _Options) :- 2313 '$time_source_file'(FullFile, Time, system), 2314 float(Time), 2315 !. 2316'$noload'(not_loaded, FullFile, _) :- 2317 source_file(FullFile), 2318 !. 2319'$noload'(changed, Derived, _) :- 2320 '$derived_source'(_FullFile, Derived, LoadTime), 2321 time_file(Derived, Modified), 2322 Modified @=< LoadTime, 2323 !. 2324'$noload'(changed, FullFile, Options) :- 2325 '$time_source_file'(FullFile, LoadTime, user), 2326 '$modified_id'(FullFile, Modified, Options), 2327 Modified @=< LoadTime, 2328 !. 2329'$noload'(exists, File, Options) :- 2330 '$noload'(changed, File, Options).
2349'$qlf_file'(Spec, _, Spec, stream, Options) :- 2350 '$option'(stream(_), Options), % stream: no choice 2351 !. 2352'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2353 '$spec_extension'(Spec, Ext), % user explicitly specified 2354 user:prolog_file_type(Ext, prolog), 2355 !. 2356'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2357 '$compilation_mode'(database), 2358 file_name_extension(Base, PlExt, FullFile), 2359 user:prolog_file_type(PlExt, prolog), 2360 user:prolog_file_type(QlfExt, qlf), 2361 file_name_extension(Base, QlfExt, QlfFile), 2362 ( access_file(QlfFile, read), 2363 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2364 -> ( access_file(QlfFile, write) 2365 -> print_message(informational, 2366 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2367 Mode = qcompile, 2368 LoadFile = FullFile 2369 ; Why == old, 2370 ( current_prolog_flag(home, PlHome), 2371 sub_atom(FullFile, 0, _, _, PlHome) 2372 ; sub_atom(QlfFile, 0, _, _, 'res://') 2373 ) 2374 -> print_message(silent, 2375 qlf(system_lib_out_of_date(Spec, QlfFile))), 2376 Mode = qload, 2377 LoadFile = QlfFile 2378 ; print_message(warning, 2379 qlf(can_not_recompile(Spec, QlfFile, Why))), 2380 Mode = compile, 2381 LoadFile = FullFile 2382 ) 2383 ; Mode = qload, 2384 LoadFile = QlfFile 2385 ) 2386 -> ! 2387 ; '$qlf_auto'(FullFile, QlfFile, Options) 2388 -> !, Mode = qcompile, 2389 LoadFile = FullFile 2390 ). 2391'$qlf_file'(_, FullFile, FullFile, compile, _).
2399'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2400 ( access_file(PlFile, read)
2401 -> time_file(PlFile, PlTime),
2402 time_file(QlfFile, QlfTime),
2403 ( PlTime > QlfTime
2404 -> Why = old % PlFile is newer
2405 ; Error = error(Formal,_),
2406 catch('$qlf_is_compatible'(QlfFile), Error, true),
2407 nonvar(Formal) % QlfFile is incompatible
2408 -> Why = Error
2409 ; fail % QlfFile is up-to-date and ok
2410 )
2411 ; fail % can not read .pl; try .qlf
2412 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2420:- create_prolog_flag(qcompile, false, [type(atom)]). 2421 2422'$qlf_auto'(PlFile, QlfFile, Options) :- 2423 ( memberchk(qcompile(QlfMode), Options) 2424 -> true 2425 ; current_prolog_flag(qcompile, QlfMode), 2426 \+ '$in_system_dir'(PlFile) 2427 ), 2428 ( QlfMode == auto 2429 -> true 2430 ; QlfMode == large, 2431 size_file(PlFile, Size), 2432 Size > 100000 2433 ), 2434 access_file(QlfFile, write). 2435 2436'$in_system_dir'(PlFile) :- 2437 current_prolog_flag(home, Home), 2438 sub_atom(PlFile, 0, _, _, Home). 2439 2440'$spec_extension'(File, Ext) :- 2441 atom(File), 2442 file_name_extension(_, Ext, File). 2443'$spec_extension'(Spec, Ext) :- 2444 compound(Spec), 2445 arg(1, Spec, Arg), 2446 '$spec_extension'(Arg, Ext).
2458:- dynamic 2459 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2460:- '$notransact'('$resolved_source_path_db'/3). 2461 2462'$load_file'(File, Module, Options) :- 2463 '$error_count'(E0, W0), 2464 '$load_file_e'(File, Module, Options), 2465 '$error_count'(E1, W1), 2466 Errors is E1-E0, 2467 Warnings is W1-W0, 2468 ( Errors+Warnings =:= 0 2469 -> true 2470 ; '$print_message'(silent, load_file_errors(File, Errors, Warnings)) 2471 ). 2472 2473:- if(current_prolog_flag(threads, true)). 2474'$error_count'(Errors, Warnings) :- 2475 current_prolog_flag(threads, true), 2476 !, 2477 thread_self(Me), 2478 thread_statistics(Me, errors, Errors), 2479 thread_statistics(Me, warnings, Warnings). 2480:- endif. 2481'$error_count'(Errors, Warnings) :- 2482 statistics(errors, Errors), 2483 statistics(warnings, Warnings). 2484 2485'$load_file_e'(File, Module, Options) :- 2486 \+ memberchk(stream(_), Options), 2487 user:prolog_load_file(Module:File, Options), 2488 !. 2489'$load_file_e'(File, Module, Options) :- 2490 memberchk(stream(_), Options), 2491 !, 2492 '$assert_load_context_module'(File, Module, Options), 2493 '$qdo_load_file'(File, File, Module, Options). 2494'$load_file_e'(File, Module, Options) :- 2495 ( '$resolved_source_path'(File, FullFile, Options) 2496 -> true 2497 ; '$resolve_source_path'(File, FullFile, Options) 2498 ), 2499 !, 2500 '$mt_load_file'(File, FullFile, Module, Options). 2501'$load_file_e'(_, _, _).
2507'$resolved_source_path'(File, FullFile, Options) :-
2508 current_prolog_flag(emulated_dialect, Dialect),
2509 '$resolved_source_path_db'(File, Dialect, FullFile),
2510 ( '$source_file_property'(FullFile, from_state, true)
2511 ; '$source_file_property'(FullFile, resource, true)
2512 ; '$option'(if(If), Options, true),
2513 '$noload'(If, FullFile, Options)
2514 ),
2515 !.
2522'$resolve_source_path'(File, FullFile, Options) :- 2523 ( '$option'(if(If), Options), 2524 If == exists 2525 -> Extra = [file_errors(fail)] 2526 ; Extra = [] 2527 ), 2528 absolute_file_name(File, FullFile, 2529 [ file_type(prolog), 2530 access(read) 2531 | Extra 2532 ]), 2533 '$register_resolved_source_path'(File, FullFile). 2534 2535'$register_resolved_source_path'(File, FullFile) :- 2536 ( compound(File) 2537 -> current_prolog_flag(emulated_dialect, Dialect), 2538 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2539 -> true 2540 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2541 ) 2542 ; true 2543 ).
2549:- public '$translated_source'/2. 2550'$translated_source'(Old, New) :- 2551 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2552 assertz('$resolved_source_path_db'(File, Dialect, New))).
2559'$register_resource_file'(FullFile) :-
2560 ( sub_atom(FullFile, 0, _, _, 'res://'),
2561 \+ file_name_extension(_, qlf, FullFile)
2562 -> '$set_source_file'(FullFile, resource, true)
2563 ; true
2564 ).
2577'$already_loaded'(_File, FullFile, Module, Options) :- 2578 '$assert_load_context_module'(FullFile, Module, Options), 2579 '$current_module'(LoadModules, FullFile), 2580 !, 2581 ( atom(LoadModules) 2582 -> LoadModule = LoadModules 2583 ; LoadModules = [LoadModule|_] 2584 ), 2585 '$import_from_loaded_module'(LoadModule, Module, Options). 2586'$already_loaded'(_, _, user, _) :- !. 2587'$already_loaded'(File, FullFile, Module, Options) :- 2588 ( '$load_context_module'(FullFile, Module, CtxOptions), 2589 '$load_ctx_options'(Options, CtxOptions) 2590 -> true 2591 ; '$load_file'(File, Module, [if(true)|Options]) 2592 ).
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.
2607:- dynamic 2608 '$loading_file'/3. % File, Queue, Thread 2609:- volatile 2610 '$loading_file'/3. 2611:- '$notransact'('$loading_file'/3). 2612 2613:- if(current_prolog_flag(threads, true)). 2614'$mt_load_file'(File, FullFile, Module, Options) :- 2615 current_prolog_flag(threads, true), 2616 !, 2617 sig_atomic(setup_call_cleanup( 2618 with_mutex('$load_file', 2619 '$mt_start_load'(FullFile, Loading, Options)), 2620 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2621 '$mt_end_load'(Loading))). 2622:- endif. 2623'$mt_load_file'(File, FullFile, Module, Options) :- 2624 '$option'(if(If), Options, true), 2625 '$noload'(If, FullFile, Options), 2626 !, 2627 '$already_loaded'(File, FullFile, Module, Options). 2628:- if(current_prolog_flag(threads, true)). 2629'$mt_load_file'(File, FullFile, Module, Options) :- 2630 sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)). 2631:- else. 2632'$mt_load_file'(File, FullFile, Module, Options) :- 2633 '$qdo_load_file'(File, FullFile, Module, Options). 2634:- endif. 2635 2636:- if(current_prolog_flag(threads, true)). 2637'$mt_start_load'(FullFile, queue(Queue), _) :- 2638 '$loading_file'(FullFile, Queue, LoadThread), 2639 \+ thread_self(LoadThread), 2640 !. 2641'$mt_start_load'(FullFile, already_loaded, Options) :- 2642 '$option'(if(If), Options, true), 2643 '$noload'(If, FullFile, Options), 2644 !. 2645'$mt_start_load'(FullFile, Ref, _) :- 2646 thread_self(Me), 2647 message_queue_create(Queue), 2648 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2649 2650'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2651 !, 2652 catch(thread_get_message(Queue, _), error(_,_), true), 2653 '$already_loaded'(File, FullFile, Module, Options). 2654'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2655 !, 2656 '$already_loaded'(File, FullFile, Module, Options). 2657'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2658 '$assert_load_context_module'(FullFile, Module, Options), 2659 '$qdo_load_file'(File, FullFile, Module, Options). 2660 2661'$mt_end_load'(queue(_)) :- !. 2662'$mt_end_load'(already_loaded) :- !. 2663'$mt_end_load'(Ref) :- 2664 clause('$loading_file'(_, Queue, _), _, Ref), 2665 erase(Ref), 2666 thread_send_message(Queue, done), 2667 message_queue_destroy(Queue). 2668:- endif.
2674'$qdo_load_file'(File, FullFile, Module, Options) :- 2675 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2676 '$register_resource_file'(FullFile), 2677 '$run_initialization'(FullFile, Action, Options). 2678 2679'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2680 memberchk('$qlf'(QlfOut), Options), 2681 '$stage_file'(QlfOut, StageQlf), 2682 !, 2683 setup_call_catcher_cleanup( 2684 '$qstart'(StageQlf, Module, State), 2685 '$do_load_file'(File, FullFile, Module, Action, Options), 2686 Catcher, 2687 '$qend'(State, Catcher, StageQlf, QlfOut)). 2688'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2689 '$do_load_file'(File, FullFile, Module, Action, Options). 2690 2691'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2692 '$qlf_open'(Qlf), 2693 '$compilation_mode'(OldMode, qlf), 2694 '$set_source_module'(OldModule, Module). 2695 2696'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2697 '$set_source_module'(_, OldModule), 2698 '$set_compilation_mode'(OldMode), 2699 '$qlf_close', 2700 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2701 2702'$set_source_module'(OldModule, Module) :- 2703 '$current_source_module'(OldModule), 2704 '$set_source_module'(Module).
2711'$do_load_file'(File, FullFile, Module, Action, Options) :- 2712 '$option'(derived_from(DerivedFrom), Options, -), 2713 '$register_derived_source'(FullFile, DerivedFrom), 2714 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2715 ( Mode == qcompile 2716 -> qcompile(Module:File, Options) 2717 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2718 ). 2719 2720'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2721 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2722 statistics(cputime, OldTime), 2723 2724 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2725 Options), 2726 2727 '$compilation_level'(Level), 2728 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2729 '$print_message'(StartMsgLevel, 2730 load_file(start(Level, 2731 file(File, Absolute)))), 2732 2733 ( memberchk(stream(FromStream), Options) 2734 -> Input = stream 2735 ; Input = source 2736 ), 2737 2738 ( Input == stream, 2739 ( '$option'(format(qlf), Options, source) 2740 -> set_stream(FromStream, file_name(Absolute)), 2741 '$qload_stream'(FromStream, Module, Action, LM, Options) 2742 ; '$consult_file'(stream(Absolute, FromStream, []), 2743 Module, Action, LM, Options) 2744 ) 2745 -> true 2746 ; Input == source, 2747 file_name_extension(_, Ext, Absolute), 2748 ( user:prolog_file_type(Ext, qlf), 2749 E = error(_,_), 2750 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2751 E, 2752 print_message(warning, E)) 2753 -> true 2754 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2755 ) 2756 -> true 2757 ; '$print_message'(error, load_file(failed(File))), 2758 fail 2759 ), 2760 2761 '$import_from_loaded_module'(LM, Module, Options), 2762 2763 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2764 statistics(cputime, Time), 2765 ClausesCreated is NewClauses - OldClauses, 2766 TimeUsed is Time - OldTime, 2767 2768 '$print_message'(DoneMsgLevel, 2769 load_file(done(Level, 2770 file(File, Absolute), 2771 Action, 2772 LM, 2773 TimeUsed, 2774 ClausesCreated))), 2775 2776 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2777 2778'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2779 Options) :- 2780 '$save_file_scoped_flags'(ScopedFlags), 2781 '$set_sandboxed_load'(Options, OldSandBoxed), 2782 '$set_verbose_load'(Options, OldVerbose), 2783 '$set_optimise_load'(Options), 2784 '$update_autoload_level'(Options, OldAutoLevel), 2785 '$set_no_xref'(OldXRef). 2786 2787'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2788 '$set_autoload_level'(OldAutoLevel), 2789 set_prolog_flag(xref, OldXRef), 2790 set_prolog_flag(verbose_load, OldVerbose), 2791 set_prolog_flag(sandboxed_load, OldSandBoxed), 2792 '$restore_file_scoped_flags'(ScopedFlags).
2800'$save_file_scoped_flags'(State) :- 2801 current_predicate(findall/3), % Not when doing boot compile 2802 !, 2803 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2804'$save_file_scoped_flags'([]). 2805 2806'$save_file_scoped_flag'(Flag-Value) :- 2807 '$file_scoped_flag'(Flag, Default), 2808 ( current_prolog_flag(Flag, Value) 2809 -> true 2810 ; Value = Default 2811 ). 2812 2813'$file_scoped_flag'(generate_debug_info, true). 2814'$file_scoped_flag'(optimise, false). 2815'$file_scoped_flag'(xref, false). 2816 2817'$restore_file_scoped_flags'([]). 2818'$restore_file_scoped_flags'([Flag-Value|T]) :- 2819 set_prolog_flag(Flag, Value), 2820 '$restore_file_scoped_flags'(T).
2827'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2828 LoadedModule \== Module, 2829 atom(LoadedModule), 2830 !, 2831 '$option'(imports(Import), Options, all), 2832 '$option'(reexport(Reexport), Options, false), 2833 '$import_list'(Module, LoadedModule, Import, Reexport). 2834'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2842'$set_verbose_load'(Options, Old) :- 2843 current_prolog_flag(verbose_load, Old), 2844 ( memberchk(silent(Silent), Options) 2845 -> ( '$negate'(Silent, Level0) 2846 -> '$load_msg_compat'(Level0, Level) 2847 ; Level = Silent 2848 ), 2849 set_prolog_flag(verbose_load, Level) 2850 ; true 2851 ). 2852 2853'$negate'(true, false). 2854'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2863'$set_sandboxed_load'(Options, Old) :- 2864 current_prolog_flag(sandboxed_load, Old), 2865 ( memberchk(sandboxed(SandBoxed), Options), 2866 '$enter_sandboxed'(Old, SandBoxed, New), 2867 New \== Old 2868 -> set_prolog_flag(sandboxed_load, New) 2869 ; true 2870 ). 2871 2872'$enter_sandboxed'(Old, New, SandBoxed) :- 2873 ( Old == false, New == true 2874 -> SandBoxed = true, 2875 '$ensure_loaded_library_sandbox' 2876 ; Old == true, New == false 2877 -> throw(error(permission_error(leave, sandbox, -), _)) 2878 ; SandBoxed = Old 2879 ). 2880'$enter_sandboxed'(false, true, true). 2881 2882'$ensure_loaded_library_sandbox' :- 2883 source_file_property(library(sandbox), module(sandbox)), 2884 !. 2885'$ensure_loaded_library_sandbox' :- 2886 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2887 2888'$set_optimise_load'(Options) :- 2889 ( '$option'(optimise(Optimise), Options) 2890 -> set_prolog_flag(optimise, Optimise) 2891 ; true 2892 ). 2893 2894'$set_no_xref'(OldXRef) :- 2895 ( current_prolog_flag(xref, OldXRef) 2896 -> true 2897 ; OldXRef = false 2898 ), 2899 set_prolog_flag(xref, false).
2906:- thread_local 2907 '$autoload_nesting'/1. 2908:- '$notransact'('$autoload_nesting'/1). 2909 2910'$update_autoload_level'(Options, AutoLevel) :- 2911 '$option'(autoload(Autoload), Options, false), 2912 ( '$autoload_nesting'(CurrentLevel) 2913 -> AutoLevel = CurrentLevel 2914 ; AutoLevel = 0 2915 ), 2916 ( Autoload == false 2917 -> true 2918 ; NewLevel is AutoLevel + 1, 2919 '$set_autoload_level'(NewLevel) 2920 ). 2921 2922'$set_autoload_level'(New) :- 2923 retractall('$autoload_nesting'(_)), 2924 asserta('$autoload_nesting'(New)).
2932'$print_message'(Level, Term) :- 2933 current_predicate(system:print_message/2), 2934 !, 2935 print_message(Level, Term). 2936'$print_message'(warning, Term) :- 2937 source_location(File, Line), 2938 !, 2939 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2940'$print_message'(error, Term) :- 2941 !, 2942 source_location(File, Line), 2943 !, 2944 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2945'$print_message'(_Level, _Term). 2946 2947'$print_message_fail'(E) :- 2948 '$print_message'(error, E), 2949 fail.
2957'$consult_file'(Absolute, Module, What, LM, Options) :- 2958 '$current_source_module'(Module), % same module 2959 !, 2960 '$consult_file_2'(Absolute, Module, What, LM, Options). 2961'$consult_file'(Absolute, Module, What, LM, Options) :- 2962 '$set_source_module'(OldModule, Module), 2963 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2964 '$consult_file_2'(Absolute, Module, What, LM, Options), 2965 '$ifcompiling'('$qlf_end_part'), 2966 '$set_source_module'(OldModule). 2967 2968'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2969 '$set_source_module'(OldModule, Module), 2970 '$load_id'(Absolute, Id, Modified, Options), 2971 '$compile_type'(What), 2972 '$save_lex_state'(LexState, Options), 2973 '$set_dialect'(Options), 2974 setup_call_cleanup( 2975 '$start_consult'(Id, Modified), 2976 '$load_file'(Absolute, Id, LM, Options), 2977 '$end_consult'(Id, LexState, OldModule)). 2978 2979'$end_consult'(Id, LexState, OldModule) :- 2980 '$end_consult'(Id), 2981 '$restore_lex_state'(LexState), 2982 '$set_source_module'(OldModule). 2983 2984 2985:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2989'$save_lex_state'(State, Options) :- 2990 memberchk(scope_settings(false), Options), 2991 !, 2992 State = (-). 2993'$save_lex_state'(lexstate(Style, Dialect), _) :- 2994 '$style_check'(Style, Style), 2995 current_prolog_flag(emulated_dialect, Dialect). 2996 2997'$restore_lex_state'(-) :- !. 2998'$restore_lex_state'(lexstate(Style, Dialect)) :- 2999 '$style_check'(_, Style), 3000 set_prolog_flag(emulated_dialect, Dialect). 3001 3002'$set_dialect'(Options) :- 3003 memberchk(dialect(Dialect), Options), 3004 !, 3005 '$expects_dialect'(Dialect). 3006'$set_dialect'(_). 3007 3008'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 3009 !, 3010 '$modified_id'(Id, Modified, Options). 3011'$load_id'(Id, Id, Modified, Options) :- 3012 '$modified_id'(Id, Modified, Options). 3013 3014'$modified_id'(_, Modified, Options) :- 3015 '$option'(modified(Stamp), Options, Def), 3016 Stamp \== Def, 3017 !, 3018 Modified = Stamp. 3019'$modified_id'(Id, Modified, _) :- 3020 catch(time_file(Id, Modified), 3021 error(_, _), 3022 fail), 3023 !. 3024'$modified_id'(_, 0, _). 3025 3026 3027'$compile_type'(What) :- 3028 '$compilation_mode'(How), 3029 ( How == database 3030 -> What = compiled 3031 ; How == qlf 3032 -> What = '*qcompiled*' 3033 ; What = 'boot compiled' 3034 ).
3044:- dynamic 3045 '$load_context_module'/3. 3046:- multifile 3047 '$load_context_module'/3. 3048:- '$notransact'('$load_context_module'/3). 3049 3050'$assert_load_context_module'(_, _, Options) :- 3051 memberchk(register(false), Options), 3052 !. 3053'$assert_load_context_module'(File, Module, Options) :- 3054 source_location(FromFile, Line), 3055 !, 3056 '$master_file'(FromFile, MasterFile), 3057 '$check_load_non_module'(File, Module), 3058 '$add_dialect'(Options, Options1), 3059 '$load_ctx_options'(Options1, Options2), 3060 '$store_admin_clause'( 3061 system:'$load_context_module'(File, Module, Options2), 3062 _Layout, MasterFile, FromFile:Line). 3063'$assert_load_context_module'(File, Module, Options) :- 3064 '$check_load_non_module'(File, Module), 3065 '$add_dialect'(Options, Options1), 3066 '$load_ctx_options'(Options1, Options2), 3067 ( clause('$load_context_module'(File, Module, _), true, Ref), 3068 \+ clause_property(Ref, file(_)), 3069 erase(Ref) 3070 -> true 3071 ; true 3072 ), 3073 assertz('$load_context_module'(File, Module, Options2)). 3074 3075'$add_dialect'(Options0, Options) :- 3076 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 3077 !, 3078 Options = [dialect(Dialect)|Options0]. 3079'$add_dialect'(Options, Options).
3086'$load_ctx_options'(Options, CtxOptions) :- 3087 '$load_ctx_options2'(Options, CtxOptions0), 3088 sort(CtxOptions0, CtxOptions). 3089 3090'$load_ctx_options2'([], []). 3091'$load_ctx_options2'([H|T0], [H|T]) :- 3092 '$load_ctx_option'(H), 3093 !, 3094 '$load_ctx_options2'(T0, T). 3095'$load_ctx_options2'([_|T0], T) :- 3096 '$load_ctx_options2'(T0, T). 3097 3098'$load_ctx_option'(derived_from(_)). 3099'$load_ctx_option'(dialect(_)). 3100'$load_ctx_option'(encoding(_)). 3101'$load_ctx_option'(imports(_)). 3102'$load_ctx_option'(reexport(_)).
3110'$check_load_non_module'(File, _) :- 3111 '$current_module'(_, File), 3112 !. % File is a module file 3113'$check_load_non_module'(File, Module) :- 3114 '$load_context_module'(File, OldModule, _), 3115 Module \== OldModule, 3116 !, 3117 format(atom(Msg), 3118 'Non-module file already loaded into module ~w; \c 3119 trying to load into ~w', 3120 [OldModule, Module]), 3121 throw(error(permission_error(load, source, File), 3122 context(load_files/2, Msg))). 3123'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
3136'$load_file'(Path, Id, Module, Options) :- 3137 State = state(true, _, true, false, Id, -), 3138 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 3139 _Stream, Options), 3140 '$valid_term'(Term), 3141 ( arg(1, State, true) 3142 -> '$first_term'(Term, Layout, Id, State, Options), 3143 nb_setarg(1, State, false) 3144 ; '$compile_term'(Term, Layout, Id, Options) 3145 ), 3146 arg(4, State, true) 3147 ; '$fixup_reconsult'(Id), 3148 '$end_load_file'(State) 3149 ), 3150 !, 3151 arg(2, State, Module). 3152 3153'$valid_term'(Var) :- 3154 var(Var), 3155 !, 3156 print_message(error, error(instantiation_error, _)). 3157'$valid_term'(Term) :- 3158 Term \== []. 3159 3160'$end_load_file'(State) :- 3161 arg(1, State, true), % empty file 3162 !, 3163 nb_setarg(2, State, Module), 3164 arg(5, State, Id), 3165 '$current_source_module'(Module), 3166 '$ifcompiling'('$qlf_start_file'(Id)), 3167 '$ifcompiling'('$qlf_end_part'). 3168'$end_load_file'(State) :- 3169 arg(3, State, End), 3170 '$end_load_file'(End, State). 3171 3172'$end_load_file'(true, _). 3173'$end_load_file'(end_module, State) :- 3174 arg(2, State, Module), 3175 '$check_export'(Module), 3176 '$ifcompiling'('$qlf_end_part'). 3177'$end_load_file'(end_non_module, _State) :- 3178 '$ifcompiling'('$qlf_end_part'). 3179 3180 3181'$first_term'(?-(Directive), Layout, Id, State, Options) :- 3182 !, 3183 '$first_term'(:-(Directive), Layout, Id, State, Options). 3184'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 3185 nonvar(Directive), 3186 ( ( Directive = module(Name, Public) 3187 -> Imports = [] 3188 ; Directive = module(Name, Public, Imports) 3189 ) 3190 -> !, 3191 '$module_name'(Name, Id, Module, Options), 3192 '$start_module'(Module, Public, State, Options), 3193 '$module3'(Imports) 3194 ; Directive = expects_dialect(Dialect) 3195 -> !, 3196 '$set_dialect'(Dialect, State), 3197 fail % Still consider next term as first 3198 ). 3199'$first_term'(Term, Layout, Id, State, Options) :- 3200 '$start_non_module'(Id, Term, State, Options), 3201 '$compile_term'(Term, Layout, Id, Options).
3208'$compile_term'(Term, Layout, SrcId, Options) :- 3209 '$compile_term'(Term, Layout, SrcId, -, Options). 3210 3211'$compile_term'(Var, _Layout, _Id, _SrcLoc, _Options) :- 3212 var(Var), 3213 !, 3214 '$instantiation_error'(Var). 3215'$compile_term'((?-Directive), _Layout, Id, _SrcLoc, Options) :- 3216 !, 3217 '$execute_directive'(Directive, Id, Options). 3218'$compile_term'((:-Directive), _Layout, Id, _SrcLoc, Options) :- 3219 !, 3220 '$execute_directive'(Directive, Id, Options). 3221'$compile_term'('$source_location'(File, Line):Term, 3222 Layout, Id, _SrcLoc, Options) :- 3223 !, 3224 '$compile_term'(Term, Layout, Id, File:Line, Options). 3225'$compile_term'(Clause, Layout, Id, SrcLoc, _Options) :- 3226 E = error(_,_), 3227 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3228 '$print_message'(error, E)). 3229 3230'$start_non_module'(_Id, Term, _State, Options) :- 3231 '$option'(must_be_module(true), Options, false), 3232 !, 3233 '$domain_error'(module_header, Term). 3234'$start_non_module'(Id, _Term, State, _Options) :- 3235 '$current_source_module'(Module), 3236 '$ifcompiling'('$qlf_start_file'(Id)), 3237 '$qset_dialect'(State), 3238 nb_setarg(2, State, Module), 3239 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3252'$set_dialect'(Dialect, State) :- 3253 '$compilation_mode'(qlf, database), 3254 !, 3255 '$expects_dialect'(Dialect), 3256 '$compilation_mode'(_, qlf), 3257 nb_setarg(6, State, Dialect). 3258'$set_dialect'(Dialect, _) :- 3259 '$expects_dialect'(Dialect). 3260 3261'$qset_dialect'(State) :- 3262 '$compilation_mode'(qlf), 3263 arg(6, State, Dialect), Dialect \== (-), 3264 !, 3265 '$add_directive_wic'('$expects_dialect'(Dialect)). 3266'$qset_dialect'(_). 3267 3268'$expects_dialect'(Dialect) :- 3269 Dialect == swi, 3270 !, 3271 set_prolog_flag(emulated_dialect, Dialect). 3272'$expects_dialect'(Dialect) :- 3273 current_predicate(expects_dialect/1), 3274 !, 3275 expects_dialect(Dialect). 3276'$expects_dialect'(Dialect) :- 3277 use_module(library(dialect), [expects_dialect/1]), 3278 expects_dialect(Dialect). 3279 3280 3281 /******************************* 3282 * MODULES * 3283 *******************************/ 3284 3285'$start_module'(Module, _Public, State, _Options) :- 3286 '$current_module'(Module, OldFile), 3287 source_location(File, _Line), 3288 OldFile \== File, OldFile \== [], 3289 same_file(OldFile, File), 3290 !, 3291 nb_setarg(2, State, Module), 3292 nb_setarg(4, State, true). % Stop processing 3293'$start_module'(Module, Public, State, Options) :- 3294 arg(5, State, File), 3295 nb_setarg(2, State, Module), 3296 source_location(_File, Line), 3297 '$option'(redefine_module(Action), Options, false), 3298 '$module_class'(File, Class, Super), 3299 '$reset_dialect'(File, Class), 3300 '$redefine_module'(Module, File, Action), 3301 '$declare_module'(Module, Class, Super, File, Line, false), 3302 '$export_list'(Public, Module, Ops), 3303 '$ifcompiling'('$qlf_start_module'(Module)), 3304 '$export_ops'(Ops, Module, File), 3305 '$qset_dialect'(State), 3306 nb_setarg(3, State, end_module).
swi
dialect.3313'$reset_dialect'(File, library) :- 3314 file_name_extension(_, pl, File), 3315 !, 3316 set_prolog_flag(emulated_dialect, swi). 3317'$reset_dialect'(_, _).
3324'$module3'(Var) :- 3325 var(Var), 3326 !, 3327 '$instantiation_error'(Var). 3328'$module3'([]) :- !. 3329'$module3'([H|T]) :- 3330 !, 3331 '$module3'(H), 3332 '$module3'(T). 3333'$module3'(Id) :- 3334 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.3348'$module_name'(_, _, Module, Options) :- 3349 '$option'(module(Module), Options), 3350 !, 3351 '$current_source_module'(Context), 3352 Context \== Module. % cause '$first_term'/5 to fail. 3353'$module_name'(Var, Id, Module, Options) :- 3354 var(Var), 3355 !, 3356 file_base_name(Id, File), 3357 file_name_extension(Var, _, File), 3358 '$module_name'(Var, Id, Module, Options). 3359'$module_name'(Reserved, _, _, _) :- 3360 '$reserved_module'(Reserved), 3361 !, 3362 throw(error(permission_error(load, module, Reserved), _)). 3363'$module_name'(Module, _Id, Module, _). 3364 3365 3366'$reserved_module'(system). 3367'$reserved_module'(user).
3372'$redefine_module'(_Module, _, false) :- !. 3373'$redefine_module'(Module, File, true) :- 3374 !, 3375 ( module_property(Module, file(OldFile)), 3376 File \== OldFile 3377 -> unload_file(OldFile) 3378 ; true 3379 ). 3380'$redefine_module'(Module, File, ask) :- 3381 ( stream_property(user_input, tty(true)), 3382 module_property(Module, file(OldFile)), 3383 File \== OldFile, 3384 '$rdef_response'(Module, OldFile, File, true) 3385 -> '$redefine_module'(Module, File, true) 3386 ; true 3387 ). 3388 3389'$rdef_response'(Module, OldFile, File, Ok) :- 3390 repeat, 3391 print_message(query, redefine_module(Module, OldFile, File)), 3392 get_single_char(Char), 3393 '$rdef_response'(Char, Ok0), 3394 !, 3395 Ok = Ok0. 3396 3397'$rdef_response'(Char, true) :- 3398 memberchk(Char, `yY`), 3399 format(user_error, 'yes~n', []). 3400'$rdef_response'(Char, false) :- 3401 memberchk(Char, `nN`), 3402 format(user_error, 'no~n', []). 3403'$rdef_response'(Char, _) :- 3404 memberchk(Char, `a`), 3405 format(user_error, 'abort~n', []), 3406 abort. 3407'$rdef_response'(_, _) :- 3408 print_message(help, redefine_module_reply), 3409 fail.
system
, while all normal user modules inherit
from user
.3419'$module_class'(File, Class, system) :- 3420 current_prolog_flag(home, Home), 3421 sub_atom(File, 0, Len, _, Home), 3422 ( sub_atom(File, Len, _, _, '/boot/') 3423 -> !, Class = system 3424 ; '$lib_prefix'(Prefix), 3425 sub_atom(File, Len, _, _, Prefix) 3426 -> !, Class = library 3427 ; file_directory_name(File, Home), 3428 file_name_extension(_, rc, File) 3429 -> !, Class = library 3430 ). 3431'$module_class'(_, user, user). 3432 3433'$lib_prefix'('/library'). 3434'$lib_prefix'('/xpce/prolog/'). 3435 3436'$check_export'(Module) :- 3437 '$undefined_export'(Module, UndefList), 3438 ( '$member'(Undef, UndefList), 3439 strip_module(Undef, _, Local), 3440 print_message(error, 3441 undefined_export(Module, Local)), 3442 fail 3443 ; true 3444 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3453'$import_list'(_, _, Var, _) :- 3454 var(Var), 3455 !, 3456 throw(error(instantitation_error, _)). 3457'$import_list'(Target, Source, all, Reexport) :- 3458 !, 3459 '$exported_ops'(Source, Import, Predicates), 3460 '$module_property'(Source, exports(Predicates)), 3461 '$import_all'(Import, Target, Source, Reexport, weak). 3462'$import_list'(Target, Source, except(Spec), Reexport) :- 3463 !, 3464 '$exported_ops'(Source, Export, Predicates), 3465 '$module_property'(Source, exports(Predicates)), 3466 ( is_list(Spec) 3467 -> true 3468 ; throw(error(type_error(list, Spec), _)) 3469 ), 3470 '$import_except'(Spec, Source, Export, Import), 3471 '$import_all'(Import, Target, Source, Reexport, weak). 3472'$import_list'(Target, Source, Import, Reexport) :- 3473 !, 3474 is_list(Import), 3475 !, 3476 '$import_all'(Import, Target, Source, Reexport, strong). 3477'$import_list'(_, _, Import, _) :- 3478 '$type_error'(import_specifier, Import). 3479 3480 3481'$import_except'([], _, List, List). 3482'$import_except'([H|T], Source, List0, List) :- 3483 '$import_except_1'(H, Source, List0, List1), 3484 '$import_except'(T, Source, List1, List). 3485 3486'$import_except_1'(Var, _, _, _) :- 3487 var(Var), 3488 !, 3489 '$instantiation_error'(Var). 3490'$import_except_1'(PI as N, _, List0, List) :- 3491 '$pi'(PI), atom(N), 3492 !, 3493 '$canonical_pi'(PI, CPI), 3494 '$import_as'(CPI, N, List0, List). 3495'$import_except_1'(op(P,A,N), _, List0, List) :- 3496 !, 3497 '$remove_ops'(List0, op(P,A,N), List). 3498'$import_except_1'(PI, Source, List0, List) :- 3499 '$pi'(PI), 3500 !, 3501 '$canonical_pi'(PI, CPI), 3502 ( '$select'(P, List0, List), 3503 '$canonical_pi'(CPI, P) 3504 -> true 3505 ; print_message(warning, 3506 error(existence_error(export, PI, module(Source)), _)), 3507 List = List0 3508 ). 3509'$import_except_1'(Except, _, _, _) :- 3510 '$type_error'(import_specifier, Except). 3511 3512'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3513 '$canonical_pi'(PI2, CPI), 3514 !. 3515'$import_as'(PI, N, [H|T0], [H|T]) :- 3516 !, 3517 '$import_as'(PI, N, T0, T). 3518'$import_as'(PI, _, _, _) :- 3519 '$existence_error'(export, PI). 3520 3521'$pi'(N/A) :- atom(N), integer(A), !. 3522'$pi'(N//A) :- atom(N), integer(A). 3523 3524'$canonical_pi'(N//A0, N/A) :- 3525 A is A0 + 2. 3526'$canonical_pi'(PI, PI). 3527 3528'$remove_ops'([], _, []). 3529'$remove_ops'([Op|T0], Pattern, T) :- 3530 subsumes_term(Pattern, Op), 3531 !, 3532 '$remove_ops'(T0, Pattern, T). 3533'$remove_ops'([H|T0], Pattern, [H|T]) :- 3534 '$remove_ops'(T0, Pattern, T).
3539'$import_all'(Import, Context, Source, Reexport, Strength) :-
3540 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3541 ( Reexport == true,
3542 ( '$list_to_conj'(Imported, Conj)
3543 -> export(Context:Conj),
3544 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3545 ; true
3546 ),
3547 source_location(File, _Line),
3548 '$export_ops'(ImpOps, Context, File)
3549 ; true
3550 ).
3554'$import_all2'([], _, _, [], [], _). 3555'$import_all2'([PI as NewName|Rest], Context, Source, 3556 [NewName/Arity|Imported], ImpOps, Strength) :- 3557 !, 3558 '$canonical_pi'(PI, Name/Arity), 3559 length(Args, Arity), 3560 Head =.. [Name|Args], 3561 NewHead =.. [NewName|Args], 3562 ( '$get_predicate_attribute'(Source:Head, meta_predicate, Meta) 3563 -> Meta =.. [Name|MetaArgs], 3564 NewMeta =.. [NewName|MetaArgs], 3565 meta_predicate(Context:NewMeta) 3566 ; '$get_predicate_attribute'(Source:Head, transparent, 1) 3567 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3568 ; true 3569 ), 3570 ( source_location(File, Line) 3571 -> E = error(_,_), 3572 catch('$store_admin_clause'((NewHead :- Source:Head), 3573 _Layout, File, File:Line), 3574 E, '$print_message'(error, E)) 3575 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3576 ), % duplicate load 3577 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3578'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3579 [op(P,A,N)|ImpOps], Strength) :- 3580 !, 3581 '$import_ops'(Context, Source, op(P,A,N)), 3582 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3583'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3584 Error = error(_,_), 3585 catch(Context:'$import'(Source:Pred, Strength), Error, 3586 print_message(error, Error)), 3587 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3588 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3589 3590 3591'$list_to_conj'([One], One) :- !. 3592'$list_to_conj'([H|T], (H,Rest)) :- 3593 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3600'$exported_ops'(Module, Ops, Tail) :- 3601 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3602 !, 3603 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3604'$exported_ops'(_, Ops, Ops). 3605 3606'$exported_op'(Module, P, A, N) :- 3607 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3608 Module:'$exported_op'(P, A, N).
3615'$import_ops'(To, From, Pattern) :- 3616 ground(Pattern), 3617 !, 3618 Pattern = op(P,A,N), 3619 op(P,A,To:N), 3620 ( '$exported_op'(From, P, A, N) 3621 -> true 3622 ; print_message(warning, no_exported_op(From, Pattern)) 3623 ). 3624'$import_ops'(To, From, Pattern) :- 3625 ( '$exported_op'(From, Pri, Assoc, Name), 3626 Pattern = op(Pri, Assoc, Name), 3627 op(Pri, Assoc, To:Name), 3628 fail 3629 ; true 3630 ).
3638'$export_list'(Decls, Module, Ops) :- 3639 is_list(Decls), 3640 !, 3641 '$do_export_list'(Decls, Module, Ops). 3642'$export_list'(Decls, _, _) :- 3643 var(Decls), 3644 throw(error(instantiation_error, _)). 3645'$export_list'(Decls, _, _) :- 3646 throw(error(type_error(list, Decls), _)). 3647 3648'$do_export_list'([], _, []) :- !. 3649'$do_export_list'([H|T], Module, Ops) :- 3650 !, 3651 E = error(_,_), 3652 catch('$export1'(H, Module, Ops, Ops1), 3653 E, ('$print_message'(error, E), Ops = Ops1)), 3654 '$do_export_list'(T, Module, Ops1). 3655 3656'$export1'(Var, _, _, _) :- 3657 var(Var), 3658 !, 3659 throw(error(instantiation_error, _)). 3660'$export1'(Op, _, [Op|T], T) :- 3661 Op = op(_,_,_), 3662 !. 3663'$export1'(PI0, Module, Ops, Ops) :- 3664 strip_module(Module:PI0, M, PI), 3665 ( PI = (_//_) 3666 -> non_terminal(M:PI) 3667 ; true 3668 ), 3669 export(M:PI). 3670 3671'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3672 E = error(_,_), 3673 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File, []), 3674 '$export_op'(Pri, Assoc, Name, Module, File) 3675 ), 3676 E, '$print_message'(error, E)), 3677 '$export_ops'(T, Module, File). 3678'$export_ops'([], _, _). 3679 3680'$export_op'(Pri, Assoc, Name, Module, File) :- 3681 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3682 -> true 3683 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File, []) 3684 ), 3685 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3691'$execute_directive'(Var, _F, _Options) :- 3692 var(Var), 3693 '$instantiation_error'(Var). 3694'$execute_directive'(encoding(Encoding), _F, _Options) :- 3695 !, 3696 ( '$load_input'(_F, S) 3697 -> set_stream(S, encoding(Encoding)) 3698 ). 3699'$execute_directive'(Goal, _, Options) :- 3700 \+ '$compilation_mode'(database), 3701 !, 3702 '$add_directive_wic2'(Goal, Type, Options), 3703 ( Type == call % suspend compiling into .qlf file 3704 -> '$compilation_mode'(Old, database), 3705 setup_call_cleanup( 3706 '$directive_mode'(OldDir, Old), 3707 '$execute_directive_3'(Goal), 3708 ( '$set_compilation_mode'(Old), 3709 '$set_directive_mode'(OldDir) 3710 )) 3711 ; '$execute_directive_3'(Goal) 3712 ). 3713'$execute_directive'(Goal, _, _Options) :- 3714 '$execute_directive_3'(Goal). 3715 3716'$execute_directive_3'(Goal) :- 3717 '$current_source_module'(Module), 3718 '$valid_directive'(Module:Goal), 3719 !, 3720 ( '$pattr_directive'(Goal, Module) 3721 -> true 3722 ; Term = error(_,_), 3723 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3724 -> true 3725 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3726 fail 3727 ). 3728'$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.3737:- multifile prolog:sandbox_allowed_directive/1. 3738:- multifile prolog:sandbox_allowed_clause/1. 3739:- meta_predicate '$valid_directive'( ). 3740 3741'$valid_directive'(_) :- 3742 current_prolog_flag(sandboxed_load, false), 3743 !. 3744'$valid_directive'(Goal) :- 3745 Error = error(Formal, _), 3746 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3747 !, 3748 ( var(Formal) 3749 -> true 3750 ; print_message(error, Error), 3751 fail 3752 ). 3753'$valid_directive'(Goal) :- 3754 print_message(error, 3755 error(permission_error(execute, 3756 sandboxed_directive, 3757 Goal), _)), 3758 fail. 3759 3760'$exception_in_directive'(Term) :- 3761 '$print_message'(error, Term), 3762 fail.
load
or call
. Add a call
directive to the QLF file. load
directives continue the
compilation into the QLF file.3770'$add_directive_wic2'(Goal, Type, Options) :- 3771 '$common_goal_type'(Goal, Type, Options), 3772 !, 3773 ( Type == load 3774 -> true 3775 ; '$current_source_module'(Module), 3776 '$add_directive_wic'(Module:Goal) 3777 ). 3778'$add_directive_wic2'(Goal, _, _) :- 3779 ( '$compilation_mode'(qlf) % no problem for qlf files 3780 -> true 3781 ; print_message(error, mixed_directive(Goal)) 3782 ).
load
or call
.3789'$common_goal_type'((A,B), Type, Options) :- 3790 !, 3791 '$common_goal_type'(A, Type, Options), 3792 '$common_goal_type'(B, Type, Options). 3793'$common_goal_type'((A;B), Type, Options) :- 3794 !, 3795 '$common_goal_type'(A, Type, Options), 3796 '$common_goal_type'(B, Type, Options). 3797'$common_goal_type'((A->B), Type, Options) :- 3798 !, 3799 '$common_goal_type'(A, Type, Options), 3800 '$common_goal_type'(B, Type, Options). 3801'$common_goal_type'(Goal, Type, Options) :- 3802 '$goal_type'(Goal, Type, Options). 3803 3804'$goal_type'(Goal, Type, Options) :- 3805 ( '$load_goal'(Goal, Options) 3806 -> Type = load 3807 ; Type = call 3808 ). 3809 3810:- thread_local 3811 '$qlf':qinclude/1. 3812 3813'$load_goal'([_|_], _). 3814'$load_goal'(consult(_), _). 3815'$load_goal'(load_files(_), _). 3816'$load_goal'(load_files(_,Options), _) :- 3817 memberchk(qcompile(QlfMode), Options), 3818 '$qlf_part_mode'(QlfMode). 3819'$load_goal'(ensure_loaded(_), _) :- '$compilation_mode'(wic). 3820'$load_goal'(use_module(_), _) :- '$compilation_mode'(wic). 3821'$load_goal'(use_module(_, _), _) :- '$compilation_mode'(wic). 3822'$load_goal'(reexport(_), _) :- '$compilation_mode'(wic). 3823'$load_goal'(reexport(_, _), _) :- '$compilation_mode'(wic). 3824'$load_goal'(Goal, _Options) :- 3825 '$qlf':qinclude(user), 3826 '$load_goal_file'(Goal, File), 3827 '$all_user_files'(File). 3828 3829 3830'$load_goal_file'(load_files(F), F). 3831'$load_goal_file'(load_files(F, _), F). 3832'$load_goal_file'(ensure_loaded(F), F). 3833'$load_goal_file'(use_module(F), F). 3834'$load_goal_file'(use_module(F, _), F). 3835'$load_goal_file'(reexport(F), F). 3836'$load_goal_file'(reexport(F, _), F). 3837 3838'$all_user_files'([]) :- 3839 !. 3840'$all_user_files'([H|T]) :- 3841 !, 3842 '$is_user_file'(H), 3843 '$all_user_files'(T). 3844'$all_user_files'(F) :- 3845 ground(F), 3846 '$is_user_file'(F). 3847 3848'$is_user_file'(File) :- 3849 absolute_file_name(File, Path, 3850 [ file_type(prolog), 3851 access(read) 3852 ]), 3853 '$module_class'(Path, user, _). 3854 3855'$qlf_part_mode'(part). 3856'$qlf_part_mode'(true). % compatibility 3857 3858 3859 /******************************** 3860 * COMPILE A CLAUSE * 3861 *********************************/
3868'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3869 Owner \== (-), 3870 !, 3871 setup_call_cleanup( 3872 '$start_aux'(Owner, Context), 3873 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3874 '$end_aux'(Owner, Context)). 3875'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3876 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3877 3878'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3879 ( '$compilation_mode'(database) 3880 -> '$record_clause'(Clause, File, SrcLoc) 3881 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3882 '$qlf_assert_clause'(Ref, development) 3883 ).
3893'$store_clause'((_, _), _, _, _) :- 3894 !, 3895 print_message(error, cannot_redefine_comma), 3896 fail. 3897'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3898 nonvar(Pre), 3899 Pre = (Head,Cond), 3900 !, 3901 ( '$is_true'(Cond), current_prolog_flag(optimise, true) 3902 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc) 3903 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc) 3904 ). 3905'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3906 '$valid_clause'(Clause), 3907 !, 3908 ( '$compilation_mode'(database) 3909 -> '$record_clause'(Clause, File, SrcLoc) 3910 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3911 '$qlf_assert_clause'(Ref, development) 3912 ). 3913 3914'$is_true'(true) => true. 3915'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B). 3916'$is_true'(_) => fail. 3917 3918'$valid_clause'(_) :- 3919 current_prolog_flag(sandboxed_load, false), 3920 !. 3921'$valid_clause'(Clause) :- 3922 \+ '$cross_module_clause'(Clause), 3923 !. 3924'$valid_clause'(Clause) :- 3925 Error = error(Formal, _), 3926 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3927 !, 3928 ( var(Formal) 3929 -> true 3930 ; print_message(error, Error), 3931 fail 3932 ). 3933'$valid_clause'(Clause) :- 3934 print_message(error, 3935 error(permission_error(assert, 3936 sandboxed_clause, 3937 Clause), _)), 3938 fail. 3939 3940'$cross_module_clause'(Clause) :- 3941 '$head_module'(Clause, Module), 3942 \+ '$current_source_module'(Module). 3943 3944'$head_module'(Var, _) :- 3945 var(Var), !, fail. 3946'$head_module'((Head :- _), Module) :- 3947 '$head_module'(Head, Module). 3948'$head_module'(Module:_, Module). 3949 3950'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3951'$clause_source'(Clause, Clause, -).
3958:- public 3959 '$store_clause'/2. 3960 3961'$store_clause'(Term, Id) :- 3962 '$clause_source'(Term, Clause, SrcLoc), 3963 '$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)
3984compile_aux_clauses(_Clauses) :- 3985 current_prolog_flag(xref, true), 3986 !. 3987compile_aux_clauses(Clauses) :- 3988 source_location(File, _Line), 3989 '$compile_aux_clauses'(Clauses, File). 3990 3991'$compile_aux_clauses'(Clauses, File) :- 3992 setup_call_cleanup( 3993 '$start_aux'(File, Context), 3994 '$store_aux_clauses'(Clauses, File), 3995 '$end_aux'(File, Context)). 3996 3997'$store_aux_clauses'(Clauses, File) :- 3998 is_list(Clauses), 3999 !, 4000 forall('$member'(C,Clauses), 4001 '$compile_term'(C, _Layout, File, [])). 4002'$store_aux_clauses'(Clause, File) :- 4003 '$compile_term'(Clause, _Layout, File, []). 4004 4005 4006 /******************************* 4007 * STAGING * 4008 *******************************/
4018'$stage_file'(Target, Stage) :- 4019 file_directory_name(Target, Dir), 4020 file_base_name(Target, File), 4021 current_prolog_flag(pid, Pid), 4022 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 4023 4024'$install_staged_file'(exit, Staged, Target, error) :- 4025 !, 4026 rename_file(Staged, Target). 4027'$install_staged_file'(exit, Staged, Target, OnError) :- 4028 !, 4029 InstallError = error(_,_), 4030 catch(rename_file(Staged, Target), 4031 InstallError, 4032 '$install_staged_error'(OnError, InstallError, Staged, Target)). 4033'$install_staged_file'(_, Staged, _, _OnError) :- 4034 E = error(_,_), 4035 catch(delete_file(Staged), E, true). 4036 4037'$install_staged_error'(OnError, Error, Staged, _Target) :- 4038 E = error(_,_), 4039 catch(delete_file(Staged), E, true), 4040 ( OnError = silent 4041 -> true 4042 ; OnError = fail 4043 -> fail 4044 ; print_message(warning, Error) 4045 ). 4046 4047 4048 /******************************* 4049 * READING * 4050 *******************************/ 4051 4052:- multifile 4053 prolog:comment_hook/3. % hook for read_clause/3 4054 4055 4056 /******************************* 4057 * FOREIGN INTERFACE * 4058 *******************************/ 4059 4060% call-back from PL_register_foreign(). First argument is the module 4061% into which the foreign predicate is loaded and second is a term 4062% describing the arguments. 4063 4064:- dynamic 4065 '$foreign_registered'/2. 4066 4067 /******************************* 4068 * TEMPORARY TERM EXPANSION * 4069 *******************************/ 4070 4071% Provide temporary definitions for the boot-loader. These are replaced 4072% by the real thing in load.pl 4073 4074:- dynamic 4075 '$expand_goal'/2, 4076 '$expand_term'/4. 4077 4078'$expand_goal'(In, In). 4079'$expand_term'(In, Layout, In, Layout). 4080 4081 4082 /******************************* 4083 * TYPE SUPPORT * 4084 *******************************/ 4085 4086'$type_error'(Type, Value) :- 4087 ( var(Value) 4088 -> throw(error(instantiation_error, _)) 4089 ; throw(error(type_error(Type, Value), _)) 4090 ). 4091 4092'$domain_error'(Type, Value) :- 4093 throw(error(domain_error(Type, Value), _)). 4094 4095'$existence_error'(Type, Object) :- 4096 throw(error(existence_error(Type, Object), _)). 4097 4098'$existence_error'(Type, Object, In) :- 4099 throw(error(existence_error(Type, Object, In), _)). 4100 4101'$permission_error'(Action, Type, Term) :- 4102 throw(error(permission_error(Action, Type, Term), _)). 4103 4104'$instantiation_error'(_Var) :- 4105 throw(error(instantiation_error, _)). 4106 4107'$uninstantiation_error'(NonVar) :- 4108 throw(error(uninstantiation_error(NonVar), _)). 4109 4110'$must_be'(list, X) :- !, 4111 '$skip_list'(_, X, Tail), 4112 ( Tail == [] 4113 -> true 4114 ; '$type_error'(list, Tail) 4115 ). 4116'$must_be'(options, X) :- !, 4117 ( '$is_options'(X) 4118 -> true 4119 ; '$type_error'(options, X) 4120 ). 4121'$must_be'(atom, X) :- !, 4122 ( atom(X) 4123 -> true 4124 ; '$type_error'(atom, X) 4125 ). 4126'$must_be'(integer, X) :- !, 4127 ( integer(X) 4128 -> true 4129 ; '$type_error'(integer, X) 4130 ). 4131'$must_be'(between(Low,High), X) :- !, 4132 ( integer(X) 4133 -> ( between(Low, High, X) 4134 -> true 4135 ; '$domain_error'(between(Low,High), X) 4136 ) 4137 ; '$type_error'(integer, X) 4138 ). 4139'$must_be'(callable, X) :- !, 4140 ( callable(X) 4141 -> true 4142 ; '$type_error'(callable, X) 4143 ). 4144'$must_be'(acyclic, X) :- !, 4145 ( acyclic_term(X) 4146 -> true 4147 ; '$domain_error'(acyclic_term, X) 4148 ). 4149'$must_be'(oneof(Type, Domain, List), X) :- !, 4150 '$must_be'(Type, X), 4151 ( memberchk(X, List) 4152 -> true 4153 ; '$domain_error'(Domain, X) 4154 ). 4155'$must_be'(boolean, X) :- !, 4156 ( (X == true ; X == false) 4157 -> true 4158 ; '$type_error'(boolean, X) 4159 ). 4160'$must_be'(ground, X) :- !, 4161 ( ground(X) 4162 -> true 4163 ; '$instantiation_error'(X) 4164 ). 4165'$must_be'(filespec, X) :- !, 4166 ( ( atom(X) 4167 ; string(X) 4168 ; compound(X), 4169 compound_name_arity(X, _, 1) 4170 ) 4171 -> true 4172 ; '$type_error'(filespec, X) 4173 ). 4174 4175% Use for debugging 4176%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 4177 4178 4179 /******************************** 4180 * LIST PROCESSING * 4181 *********************************/ 4182 4183'$member'(El, [H|T]) :- 4184 '$member_'(T, El, H). 4185 4186'$member_'(_, El, El). 4187'$member_'([H|T], El, _) :- 4188 '$member_'(T, El, H). 4189 4190'$append'([], L, L). 4191'$append'([H|T], L, [H|R]) :- 4192 '$append'(T, L, R). 4193 4194'$append'(ListOfLists, List) :- 4195 '$must_be'(list, ListOfLists), 4196 '$append_'(ListOfLists, List). 4197 4198'$append_'([], []). 4199'$append_'([L|Ls], As) :- 4200 '$append'(L, Ws, As), 4201 '$append_'(Ls, Ws). 4202 4203'$select'(X, [X|Tail], Tail). 4204'$select'(Elem, [Head|Tail], [Head|Rest]) :- 4205 '$select'(Elem, Tail, Rest). 4206 4207'$reverse'(L1, L2) :- 4208 '$reverse'(L1, [], L2). 4209 4210'$reverse'([], List, List). 4211'$reverse'([Head|List1], List2, List3) :- 4212 '$reverse'(List1, [Head|List2], List3). 4213 4214'$delete'([], _, []) :- !. 4215'$delete'([Elem|Tail], Elem, Result) :- 4216 !, 4217 '$delete'(Tail, Elem, Result). 4218'$delete'([Head|Tail], Elem, [Head|Rest]) :- 4219 '$delete'(Tail, Elem, Rest). 4220 4221'$last'([H|T], Last) :- 4222 '$last'(T, H, Last). 4223 4224'$last'([], Last, Last). 4225'$last'([H|T], _, Last) :- 4226 '$last'(T, H, Last). 4227 4228:- meta_predicate '$include'( , , ). 4229'$include'(_, [], []). 4230'$include'(G, [H|T0], L) :- 4231 ( call(G,H) 4232 -> L = [H|T] 4233 ; T = L 4234 ), 4235 '$include'(G, T0, T).
4242:- '$iso'((length/2)). 4243 4244length(List, Length) :- 4245 var(Length), 4246 !, 4247 '$skip_list'(Length0, List, Tail), 4248 ( Tail == [] 4249 -> Length = Length0 % +,- 4250 ; var(Tail) 4251 -> Tail \== Length, % avoid length(L,L) 4252 '$length3'(Tail, Length, Length0) % -,- 4253 ; throw(error(type_error(list, List), 4254 context(length/2, _))) 4255 ). 4256length(List, Length) :- 4257 integer(Length), 4258 Length >= 0, 4259 !, 4260 '$skip_list'(Length0, List, Tail), 4261 ( Tail == [] % proper list 4262 -> Length = Length0 4263 ; var(Tail) 4264 -> Extra is Length-Length0, 4265 '$length'(Tail, Extra) 4266 ; throw(error(type_error(list, List), 4267 context(length/2, _))) 4268 ). 4269length(_, Length) :- 4270 integer(Length), 4271 !, 4272 throw(error(domain_error(not_less_than_zero, Length), 4273 context(length/2, _))). 4274length(_, Length) :- 4275 throw(error(type_error(integer, Length), 4276 context(length/2, _))). 4277 4278'$length3'([], N, N). 4279'$length3'([_|List], N, N0) :- 4280 N1 is N0+1, 4281 '$length3'(List, N, N1). 4282 4283 4284 /******************************* 4285 * OPTION PROCESSING * 4286 *******************************/
4292'$is_options'(Map) :- 4293 is_dict(Map, _), 4294 !. 4295'$is_options'(List) :- 4296 is_list(List), 4297 ( List == [] 4298 -> true 4299 ; List = [H|_], 4300 '$is_option'(H, _, _) 4301 ). 4302 4303'$is_option'(Var, _, _) :- 4304 var(Var), !, fail. 4305'$is_option'(F, Name, Value) :- 4306 functor(F, _, 1), 4307 !, 4308 F =.. [Name,Value]. 4309'$is_option'(Name=Value, Name, Value).
4313'$option'(Opt, Options) :- 4314 is_dict(Options), 4315 !, 4316 [Opt] :< Options. 4317'$option'(Opt, Options) :- 4318 memberchk(Opt, Options).
4322'$option'(Term, Options, Default) :-
4323 arg(1, Term, Value),
4324 functor(Term, Name, 1),
4325 ( is_dict(Options)
4326 -> ( get_dict(Name, Options, GVal)
4327 -> Value = GVal
4328 ; Value = Default
4329 )
4330 ; functor(Gen, Name, 1),
4331 arg(1, Gen, GVal),
4332 ( memberchk(Gen, Options)
4333 -> Value = GVal
4334 ; Value = Default
4335 )
4336 ).
4344'$select_option'(Opt, Options, Rest) :-
4345 '$options_dict'(Options, Dict),
4346 select_dict([Opt], Dict, Rest).
4354'$merge_options'(New, Old, Merged) :-
4355 '$options_dict'(New, NewDict),
4356 '$options_dict'(Old, OldDict),
4357 put_dict(NewDict, OldDict, Merged).
4364'$options_dict'(Options, Dict) :- 4365 is_list(Options), 4366 !, 4367 '$keyed_options'(Options, Keyed), 4368 sort(1, @<, Keyed, UniqueKeyed), 4369 '$pairs_values'(UniqueKeyed, Unique), 4370 dict_create(Dict, _, Unique). 4371'$options_dict'(Dict, Dict) :- 4372 is_dict(Dict), 4373 !. 4374'$options_dict'(Options, _) :- 4375 '$domain_error'(options, Options). 4376 4377'$keyed_options'([], []). 4378'$keyed_options'([H0|T0], [H|T]) :- 4379 '$keyed_option'(H0, H), 4380 '$keyed_options'(T0, T). 4381 4382'$keyed_option'(Var, _) :- 4383 var(Var), 4384 !, 4385 '$instantiation_error'(Var). 4386'$keyed_option'(Name=Value, Name-(Name-Value)). 4387'$keyed_option'(NameValue, Name-(Name-Value)) :- 4388 compound_name_arguments(NameValue, Name, [Value]), 4389 !. 4390'$keyed_option'(Opt, _) :- 4391 '$domain_error'(option, Opt). 4392 4393 4394 /******************************* 4395 * HANDLE TRACER 'L'-COMMAND * 4396 *******************************/ 4397 4398:- public '$prolog_list_goal'/1. 4399 4400:- multifile 4401 user:prolog_list_goal/1. 4402 4403'$prolog_list_goal'(Goal) :- 4404 user:prolog_list_goal(Goal), 4405 !. 4406'$prolog_list_goal'(Goal) :- 4407 use_module(library(listing), [listing/1]), 4408 @(listing(Goal), user). 4409 4410 4411 /******************************* 4412 * HALT * 4413 *******************************/ 4414 4415:- '$iso'((halt/0)). 4416 4417halt :- 4418 '$exit_code'(Code), 4419 ( Code == 0 4420 -> true 4421 ; print_message(warning, on_error(halt(1))) 4422 ), 4423 halt(Code).
on_error
and on_warning
flags. Also used by qsave_toplevel/0.
4430'$exit_code'(Code) :-
4431 ( ( current_prolog_flag(on_error, status),
4432 statistics(errors, Count),
4433 Count > 0
4434 ; current_prolog_flag(on_warning, status),
4435 statistics(warnings, Count),
4436 Count > 0
4437 )
4438 -> Code = 1
4439 ; Code = 0
4440 ).
4449:- meta_predicate at_halt( ). 4450:- dynamic system:term_expansion/2, '$at_halt'/2. 4451:- multifile system:term_expansion/2, '$at_halt'/2. 4452 4453systemterm_expansion((:- at_halt(Goal)), 4454 system:'$at_halt'(Module:Goal, File:Line)) :- 4455 \+ current_prolog_flag(xref, true), 4456 source_location(File, Line), 4457 '$current_source_module'(Module). 4458 4459at_halt(Goal) :- 4460 asserta('$at_halt'(Goal, (-):0)). 4461 4462:- public '$run_at_halt'/0. 4463 4464'$run_at_halt' :- 4465 forall(clause('$at_halt'(Goal, Src), true, Ref), 4466 ( '$call_at_halt'(Goal, Src), 4467 erase(Ref) 4468 )). 4469 4470'$call_at_halt'(Goal, _Src) :- 4471 catch(Goal, E, true), 4472 !, 4473 ( var(E) 4474 -> true 4475 ; subsumes_term(cancel_halt(_), E) 4476 -> '$print_message'(informational, E), 4477 fail 4478 ; '$print_message'(error, E) 4479 ). 4480'$call_at_halt'(Goal, _Src) :- 4481 '$print_message'(warning, goal_failed(at_halt, Goal)).
4489cancel_halt(Reason) :-
4490 throw(cancel_halt(Reason)).
heartbeat
is
non-zero.4497:- multifile prolog:heartbeat/0. 4498 4499 4500 /******************************** 4501 * LOAD OTHER MODULES * 4502 *********************************/ 4503 4504:- meta_predicate 4505 '$load_wic_files'( ). 4506 4507'$load_wic_files'(Files) :- 4508 Files = Module:_, 4509 '$execute_directive'('$set_source_module'(OldM, Module), [], []), 4510 '$save_lex_state'(LexState, []), 4511 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4512 '$compilation_mode'(OldC, wic), 4513 consult(Files), 4514 '$execute_directive'('$set_source_module'(OldM), [], []), 4515 '$execute_directive'('$restore_lex_state'(LexState), [], []), 4516 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4524:- public '$load_additional_boot_files'/0. 4525 4526'$load_additional_boot_files' :- 4527 current_prolog_flag(argv, Argv), 4528 '$get_files_argv'(Argv, Files), 4529 ( Files \== [] 4530 -> format('Loading additional boot files~n'), 4531 '$load_wic_files'(user:Files), 4532 format('additional boot files loaded~n') 4533 ; true 4534 ). 4535 4536'$get_files_argv'([], []) :- !. 4537'$get_files_argv'(['-c'|Files], Files) :- !. 4538'$get_files_argv'([_|Rest], Files) :- 4539 '$get_files_argv'(Rest, Files). 4540 4541'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4542 source_location(File, _Line), 4543 file_directory_name(File, Dir), 4544 atom_concat(Dir, '/load.pl', LoadFile), 4545 '$load_wic_files'(system:[LoadFile]), 4546 ( current_prolog_flag(windows, true) 4547 -> atom_concat(Dir, '/menu.pl', MenuFile), 4548 '$load_wic_files'(system:[MenuFile]) 4549 ; true 4550 ), 4551 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4552 '$compilation_mode'(OldC, wic), 4553 '$execute_directive'('$set_source_module'(user), [], []), 4554 '$set_compilation_mode'(OldC) 4555 ))