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) :- 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) :- 1425 ( '$relative_to'(Cond, source, Dir) 1426 *-> atomic_list_concat([Dir, /, File], AbsFile), 1427 '$extend_file'(AbsFile, Exts, Extended), 1428 '$file_conditions'(Cond, Extended) 1429 ; '$extend_file'(File, Exts, Extended), 1430 '$file_conditions'(Cond, Extended) 1431 ), 1432 !, 1433 '$absolute_file_name'(Extended, FullName). 1434 1435'$segments_to_atom'(Atom, Atom) :- 1436 atomic(Atom), 1437 !. 1438'$segments_to_atom'(Segments, Atom) :- 1439 '$segments_to_list'(Segments, List, []), 1440 !, 1441 atomic_list_concat(List, /, Atom). 1442 1443'$segments_to_list'(A/B, H, T) :- 1444 '$segments_to_list'(A, H, T0), 1445 '$segments_to_list'(B, T0, T). 1446'$segments_to_list'(A, [A|T], T) :- 1447 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1457'$relative_to'(Conditions, Default, Dir) :-
1458 ( '$option'(relative_to(FileOrDir), Conditions)
1459 *-> ( exists_directory(FileOrDir)
1460 -> Dir = FileOrDir
1461 ; atom_concat(Dir, /, FileOrDir)
1462 -> true
1463 ; file_directory_name(FileOrDir, Dir)
1464 )
1465 ; Default == cwd
1466 -> working_directory(Dir, Dir)
1467 ; Default == source
1468 -> source_location(ContextFile, _Line),
1469 file_directory_name(ContextFile, Dir)
1470 ).
1475:- dynamic 1476 '$search_path_file_cache'/3, % SHA1, Time, Path 1477 '$search_path_gc_time'/1. % Time 1478:- volatile 1479 '$search_path_file_cache'/3, 1480 '$search_path_gc_time'/1. 1481:- '$notransact'(('$search_path_file_cache'/3, 1482 '$search_path_gc_time'/1)). 1483 1484:- create_prolog_flag(file_search_cache_time, 10, []). 1485 1486'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1487 !, 1488 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1489 current_prolog_flag(emulated_dialect, Dialect), 1490 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1491 variant_sha1(Spec+Cache, SHA1), 1492 get_time(Now), 1493 current_prolog_flag(file_search_cache_time, TimeOut), 1494 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1495 CachedTime > Now - TimeOut, 1496 '$file_conditions'(Cond, FullFile) 1497 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1498 ; '$member'(Expanded, Expansions), 1499 '$extend_file'(Expanded, Exts, LibFile), 1500 ( '$file_conditions'(Cond, LibFile), 1501 '$absolute_file_name'(LibFile, FullFile), 1502 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1503 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1504 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1505 fail 1506 ) 1507 ). 1508'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1509 '$expand_file_search_path'(Spec, Expanded, Cond), 1510 '$extend_file'(Expanded, Exts, LibFile), 1511 '$file_conditions'(Cond, LibFile), 1512 '$absolute_file_name'(LibFile, FullFile). 1513 1514'$cache_file_found'(_, _, TimeOut, _) :- 1515 TimeOut =:= 0, 1516 !. 1517'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1518 '$search_path_file_cache'(SHA1, Saved, FullFile), 1519 !, 1520 ( Now - Saved < TimeOut/2 1521 -> true 1522 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1523 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1524 ). 1525'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1526 'gc_file_search_cache'(TimeOut), 1527 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1528 1529'gc_file_search_cache'(TimeOut) :- 1530 get_time(Now), 1531 '$search_path_gc_time'(Last), 1532 Now-Last < TimeOut/2, 1533 !. 1534'gc_file_search_cache'(TimeOut) :- 1535 get_time(Now), 1536 retractall('$search_path_gc_time'(_)), 1537 assertz('$search_path_gc_time'(Now)), 1538 Before is Now - TimeOut, 1539 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1540 Cached < Before, 1541 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1542 fail 1543 ; true 1544 ). 1545 1546 1547'$search_message'(Term) :- 1548 current_prolog_flag(verbose_file_search, true), 1549 !, 1550 print_message(informational, Term). 1551'$search_message'(_).
1558'$file_conditions'(List, File) :- 1559 is_list(List), 1560 !, 1561 \+ ( '$member'(C, List), 1562 '$file_condition'(C), 1563 \+ '$file_condition'(C, File) 1564 ). 1565'$file_conditions'(Map, File) :- 1566 \+ ( get_dict(Key, Map, Value), 1567 C =.. [Key,Value], 1568 '$file_condition'(C), 1569 \+ '$file_condition'(C, File) 1570 ). 1571 1572'$file_condition'(file_type(directory), File) :- 1573 !, 1574 exists_directory(File). 1575'$file_condition'(file_type(_), File) :- 1576 !, 1577 \+ exists_directory(File). 1578'$file_condition'(access(Accesses), File) :- 1579 !, 1580 \+ ( '$one_or_member'(Access, Accesses), 1581 \+ access_file(File, Access) 1582 ). 1583 1584'$file_condition'(exists). 1585'$file_condition'(file_type(_)). 1586'$file_condition'(access(_)). 1587 1588'$extend_file'(File, Exts, FileEx) :- 1589 '$ensure_extensions'(Exts, File, Fs), 1590 '$list_to_set'(Fs, FsSet), 1591 '$member'(FileEx, FsSet). 1592 1593'$ensure_extensions'([], _, []). 1594'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1595 file_name_extension(F, E, FE), 1596 '$ensure_extensions'(E0, F, E1).
1603'$list_to_set'(List, Set) :- 1604 '$number_list'(List, 1, Numbered), 1605 sort(1, @=<, Numbered, ONum), 1606 '$remove_dup_keys'(ONum, NumSet), 1607 sort(2, @=<, NumSet, ONumSet), 1608 '$pairs_keys'(ONumSet, Set). 1609 1610'$number_list'([], _, []). 1611'$number_list'([H|T0], N, [H-N|T]) :- 1612 N1 is N+1, 1613 '$number_list'(T0, N1, T). 1614 1615'$remove_dup_keys'([], []). 1616'$remove_dup_keys'([H|T0], [H|T]) :- 1617 H = V-_, 1618 '$remove_same_key'(T0, V, T1), 1619 '$remove_dup_keys'(T1, T). 1620 1621'$remove_same_key'([V1-_|T0], V, T) :- 1622 V1 == V, 1623 !, 1624 '$remove_same_key'(T0, V, T). 1625'$remove_same_key'(L, _, L). 1626 1627'$pairs_keys'([], []). 1628'$pairs_keys'([K-_|T0], [K|T]) :- 1629 '$pairs_keys'(T0, T). 1630 1631'$pairs_values'([], []). 1632'$pairs_values'([_-V|T0], [V|T]) :- 1633 '$pairs_values'(T0, T). 1634 1635/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1636Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1637the Quintus compatibility requests `pl'. This layer canonicalises all 1638extensions to .ext 1639- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1640 1641'$canonicalise_extensions'([], []) :- !. 1642'$canonicalise_extensions'([H|T], [CH|CT]) :- 1643 !, 1644 '$must_be'(atom, H), 1645 '$canonicalise_extension'(H, CH), 1646 '$canonicalise_extensions'(T, CT). 1647'$canonicalise_extensions'(E, [CE]) :- 1648 '$canonicalise_extension'(E, CE). 1649 1650'$canonicalise_extension'('', '') :- !. 1651'$canonicalise_extension'(DotAtom, DotAtom) :- 1652 sub_atom(DotAtom, 0, _, _, '.'), 1653 !. 1654'$canonicalise_extension'(Atom, DotAtom) :- 1655 atom_concat('.', Atom, DotAtom). 1656 1657 1658 /******************************** 1659 * CONSULT * 1660 *********************************/ 1661 1662:- dynamic 1663 user:library_directory/1, 1664 user:prolog_load_file/2. 1665:- multifile 1666 user:library_directory/1, 1667 user:prolog_load_file/2. 1668 1669:- prompt(_, '|: '). 1670 1671:- thread_local 1672 '$compilation_mode_store'/1, % database, wic, qlf 1673 '$directive_mode_store'/1. % database, wic, qlf 1674:- volatile 1675 '$compilation_mode_store'/1, 1676 '$directive_mode_store'/1. 1677:- '$notransact'(('$compilation_mode_store'/1, 1678 '$directive_mode_store'/1)). 1679 1680'$compilation_mode'(Mode) :- 1681 ( '$compilation_mode_store'(Val) 1682 -> Mode = Val 1683 ; Mode = database 1684 ). 1685 1686'$set_compilation_mode'(Mode) :- 1687 retractall('$compilation_mode_store'(_)), 1688 assertz('$compilation_mode_store'(Mode)). 1689 1690'$compilation_mode'(Old, New) :- 1691 '$compilation_mode'(Old), 1692 ( New == Old 1693 -> true 1694 ; '$set_compilation_mode'(New) 1695 ). 1696 1697'$directive_mode'(Mode) :- 1698 ( '$directive_mode_store'(Val) 1699 -> Mode = Val 1700 ; Mode = database 1701 ). 1702 1703'$directive_mode'(Old, New) :- 1704 '$directive_mode'(Old), 1705 ( New == Old 1706 -> true 1707 ; '$set_directive_mode'(New) 1708 ). 1709 1710'$set_directive_mode'(Mode) :- 1711 retractall('$directive_mode_store'(_)), 1712 assertz('$directive_mode_store'(Mode)).
1720'$compilation_level'(Level) :- 1721 '$input_context'(Stack), 1722 '$compilation_level'(Stack, Level). 1723 1724'$compilation_level'([], 0). 1725'$compilation_level'([Input|T], Level) :- 1726 ( arg(1, Input, see) 1727 -> '$compilation_level'(T, Level) 1728 ; '$compilation_level'(T, Level0), 1729 Level is Level0+1 1730 ).
1738compiling :- 1739 \+ ( '$compilation_mode'(database), 1740 '$directive_mode'(database) 1741 ). 1742 1743:- meta_predicate 1744 '$ifcompiling'( ). 1745 1746'$ifcompiling'(G) :- 1747 ( '$compilation_mode'(database) 1748 -> true 1749 ; call(G) 1750 ). 1751 1752 /******************************** 1753 * READ SOURCE * 1754 *********************************/
1758'$load_msg_level'(Action, Nesting, Start, Done) :- 1759 '$update_autoload_level'([], 0), 1760 !, 1761 current_prolog_flag(verbose_load, Type0), 1762 '$load_msg_compat'(Type0, Type), 1763 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1764 -> true 1765 ). 1766'$load_msg_level'(_, _, silent, silent). 1767 1768'$load_msg_compat'(true, normal) :- !. 1769'$load_msg_compat'(false, silent) :- !. 1770'$load_msg_compat'(X, X). 1771 1772'$load_msg_level'(load_file, _, full, informational, informational). 1773'$load_msg_level'(include_file, _, full, informational, informational). 1774'$load_msg_level'(load_file, _, normal, silent, informational). 1775'$load_msg_level'(include_file, _, normal, silent, silent). 1776'$load_msg_level'(load_file, 0, brief, silent, informational). 1777'$load_msg_level'(load_file, _, brief, silent, silent). 1778'$load_msg_level'(include_file, _, brief, silent, silent). 1779'$load_msg_level'(load_file, _, silent, silent, silent). 1780'$load_msg_level'(include_file, _, silent, silent, silent).
1803'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1804 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1805 ( Term == end_of_file 1806 -> !, fail 1807 ; Term \== begin_of_file 1808 ). 1809 1810'$source_term'(Input, _,_,_,_,_,_,_) :- 1811 \+ ground(Input), 1812 !, 1813 '$instantiation_error'(Input). 1814'$source_term'(stream(Id, In, Opts), 1815 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1816 !, 1817 '$record_included'(Parents, Id, Id, 0.0, Message), 1818 setup_call_cleanup( 1819 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1820 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1821 [Id|Parents], Options), 1822 '$close_source'(State, Message)). 1823'$source_term'(File, 1824 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1825 absolute_file_name(File, Path, 1826 [ file_type(prolog), 1827 access(read) 1828 ]), 1829 time_file(Path, Time), 1830 '$record_included'(Parents, File, Path, Time, Message), 1831 setup_call_cleanup( 1832 '$open_source'(Path, In, State, Parents, Options), 1833 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1834 [Path|Parents], Options), 1835 '$close_source'(State, Message)). 1836 1837:- thread_local 1838 '$load_input'/2. 1839:- volatile 1840 '$load_input'/2. 1841:- '$notransact'('$load_input'/2). 1842 1843'$open_source'(stream(Id, In, Opts), In, 1844 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1845 !, 1846 '$context_type'(Parents, ContextType), 1847 '$push_input_context'(ContextType), 1848 '$prepare_load_stream'(In, Id, StreamState), 1849 asserta('$load_input'(stream(Id), In), Ref). 1850'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1851 '$context_type'(Parents, ContextType), 1852 '$push_input_context'(ContextType), 1853 '$open_source'(Path, In, Options), 1854 '$set_encoding'(In, Options), 1855 asserta('$load_input'(Path, In), Ref). 1856 1857'$context_type'([], load_file) :- !. 1858'$context_type'(_, include). 1859 1860:- multifile prolog:open_source_hook/3. 1861 1862'$open_source'(Path, In, Options) :- 1863 prolog:open_source_hook(Path, In, Options), 1864 !. 1865'$open_source'(Path, In, _Options) :- 1866 open(Path, read, In). 1867 1868'$close_source'(close(In, _Id, Ref), Message) :- 1869 erase(Ref), 1870 call_cleanup( 1871 close(In), 1872 '$pop_input_context'), 1873 '$close_message'(Message). 1874'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1875 erase(Ref), 1876 call_cleanup( 1877 '$restore_load_stream'(In, StreamState, Opts), 1878 '$pop_input_context'), 1879 '$close_message'(Message). 1880 1881'$close_message'(message(Level, Msg)) :- 1882 !, 1883 '$print_message'(Level, Msg). 1884'$close_message'(_).
1896'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1897 Parents \= [_,_|_], 1898 ( '$load_input'(_, Input) 1899 -> stream_property(Input, file_name(File)) 1900 ), 1901 '$set_source_location'(File, 0), 1902 '$expanded_term'(In, 1903 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1904 Stream, Parents, Options). 1905'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1906 '$skip_script_line'(In, Options), 1907 '$read_clause_options'(Options, ReadOptions), 1908 '$repeat_and_read_error_mode'(ErrorMode), 1909 read_clause(In, Raw, 1910 [ syntax_errors(ErrorMode), 1911 variable_names(Bindings), 1912 term_position(Pos), 1913 subterm_positions(RawLayout) 1914 | ReadOptions 1915 ]), 1916 b_setval('$term_position', Pos), 1917 b_setval('$variable_names', Bindings), 1918 ( Raw == end_of_file 1919 -> !, 1920 ( Parents = [_,_|_] % Included file 1921 -> fail 1922 ; '$expanded_term'(In, 1923 Raw, RawLayout, Read, RLayout, Term, TLayout, 1924 Stream, Parents, Options) 1925 ) 1926 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1927 Stream, Parents, Options) 1928 ). 1929 1930'$read_clause_options'([], []). 1931'$read_clause_options'([H|T0], List) :- 1932 ( '$read_clause_option'(H) 1933 -> List = [H|T] 1934 ; List = T 1935 ), 1936 '$read_clause_options'(T0, T). 1937 1938'$read_clause_option'(syntax_errors(_)). 1939'$read_clause_option'(term_position(_)). 1940'$read_clause_option'(process_comment(_)).
expand.pl
is not yet
loaded.1948'$repeat_and_read_error_mode'(Mode) :- 1949 ( current_predicate('$including'/0) 1950 -> repeat, 1951 ( '$including' 1952 -> Mode = dec10 1953 ; Mode = quiet 1954 ) 1955 ; Mode = dec10, 1956 repeat 1957 ). 1958 1959 1960'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1961 Stream, Parents, Options) :- 1962 E = error(_,_), 1963 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1964 '$print_message_fail'(E)), 1965 ( Expanded \== [] 1966 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1967 ; Term1 = Expanded, 1968 Layout1 = ExpandedLayout 1969 ), 1970 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1971 -> ( Directive = include(File), 1972 '$current_source_module'(Module), 1973 '$valid_directive'(Module:include(File)) 1974 -> stream_property(In, encoding(Enc)), 1975 '$add_encoding'(Enc, Options, Options1), 1976 '$source_term'(File, Read, RLayout, Term, TLayout, 1977 Stream, Parents, Options1) 1978 ; Directive = encoding(Enc) 1979 -> set_stream(In, encoding(Enc)), 1980 fail 1981 ; Term = Term1, 1982 Stream = In, 1983 Read = Raw 1984 ) 1985 ; Term = Term1, 1986 TLayout = Layout1, 1987 Stream = In, 1988 Read = Raw, 1989 RLayout = RawLayout 1990 ). 1991 1992'$expansion_member'(Var, Layout, Var, Layout) :- 1993 var(Var), 1994 !. 1995'$expansion_member'([], _, _, _) :- !, fail. 1996'$expansion_member'(List, ListLayout, Term, Layout) :- 1997 is_list(List), 1998 !, 1999 ( var(ListLayout) 2000 -> '$member'(Term, List) 2001 ; is_list(ListLayout) 2002 -> '$member_rep2'(Term, Layout, List, ListLayout) 2003 ; Layout = ListLayout, 2004 '$member'(Term, List) 2005 ). 2006'$expansion_member'(X, Layout, X, Layout). 2007 2008% pairwise member, repeating last element of the second 2009% list. 2010 2011'$member_rep2'(H1, H2, [H1|_], [H2|_]). 2012'$member_rep2'(H1, H2, [_|T1], [T2]) :- 2013 !, 2014 '$member_rep2'(H1, H2, T1, [T2]). 2015'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 2016 '$member_rep2'(H1, H2, T1, T2).
2020'$add_encoding'(Enc, Options0, Options) :- 2021 ( Options0 = [encoding(Enc)|_] 2022 -> Options = Options0 2023 ; Options = [encoding(Enc)|Options0] 2024 ). 2025 2026 2027:- multifile 2028 '$included'/4. % Into, Line, File, LastModified 2029:- dynamic 2030 '$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'.
2044'$record_included'([Parent|Parents], File, Path, Time, 2045 message(DoneMsgLevel, 2046 include_file(done(Level, file(File, Path))))) :- 2047 source_location(SrcFile, Line), 2048 !, 2049 '$compilation_level'(Level), 2050 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 2051 '$print_message'(StartMsgLevel, 2052 include_file(start(Level, 2053 file(File, Path)))), 2054 '$last'([Parent|Parents], Owner), 2055 ( ( '$compilation_mode'(database) 2056 ; '$qlf_current_source'(Owner) 2057 ) 2058 -> '$store_admin_clause'( 2059 system:'$included'(Parent, Line, Path, Time), 2060 _, Owner, SrcFile:Line) 2061 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 2062 ). 2063'$record_included'(_, _, _, _, true).
2069'$master_file'(File, MasterFile) :- 2070 '$included'(MasterFile0, _Line, File, _Time), 2071 !, 2072 '$master_file'(MasterFile0, MasterFile). 2073'$master_file'(File, File). 2074 2075 2076'$skip_script_line'(_In, Options) :- 2077 '$option'(check_script(false), Options), 2078 !. 2079'$skip_script_line'(In, _Options) :- 2080 ( peek_char(In, #) 2081 -> skip(In, 10) 2082 ; true 2083 ). 2084 2085'$set_encoding'(Stream, Options) :- 2086 '$option'(encoding(Enc), Options), 2087 !, 2088 Enc \== default, 2089 set_stream(Stream, encoding(Enc)). 2090'$set_encoding'(_, _). 2091 2092 2093'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 2094 ( stream_property(In, file_name(_)) 2095 -> HasName = true, 2096 ( stream_property(In, position(_)) 2097 -> HasPos = true 2098 ; HasPos = false, 2099 set_stream(In, record_position(true)) 2100 ) 2101 ; HasName = false, 2102 set_stream(In, file_name(Id)), 2103 ( stream_property(In, position(_)) 2104 -> HasPos = true 2105 ; HasPos = false, 2106 set_stream(In, record_position(true)) 2107 ) 2108 ). 2109 2110'$restore_load_stream'(In, _State, Options) :- 2111 memberchk(close(true), Options), 2112 !, 2113 close(In). 2114'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 2115 ( HasName == false 2116 -> set_stream(In, file_name('')) 2117 ; true 2118 ), 2119 ( HasPos == false 2120 -> set_stream(In, record_position(false)) 2121 ; true 2122 ). 2123 2124 2125 /******************************* 2126 * DERIVED FILES * 2127 *******************************/ 2128 2129:- dynamic 2130 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2131 2132'$register_derived_source'(_, '-') :- !. 2133'$register_derived_source'(Loaded, DerivedFrom) :- 2134 retractall('$derived_source_db'(Loaded, _, _)), 2135 time_file(DerivedFrom, Time), 2136 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2137 2138% Auto-importing dynamic predicates is not very elegant and 2139% leads to problems with qsave_program/[1,2] 2140 2141'$derived_source'(Loaded, DerivedFrom, Time) :- 2142 '$derived_source_db'(Loaded, DerivedFrom, Time). 2143 2144 2145 /******************************** 2146 * LOAD PREDICATES * 2147 *********************************/ 2148 2149:- meta_predicate 2150 ensure_loaded( ), 2151 [, | ] 2152 consult( ), 2153 use_module( ), 2154 use_module( , ), 2155 reexport( ), 2156 reexport( , ), 2157 load_files( ), 2158 load_files( , ).
2166ensure_loaded(Files) :-
2167 load_files(Files, [if(not_loaded)]).
2176use_module(Files) :-
2177 load_files(Files, [ if(not_loaded),
2178 must_be_module(true)
2179 ]).
2186use_module(File, Import) :-
2187 load_files(File, [ if(not_loaded),
2188 must_be_module(true),
2189 imports(Import)
2190 ]).
2196reexport(Files) :-
2197 load_files(Files, [ if(not_loaded),
2198 must_be_module(true),
2199 reexport(true)
2200 ]).
2206reexport(File, Import) :- 2207 load_files(File, [ if(not_loaded), 2208 must_be_module(true), 2209 imports(Import), 2210 reexport(true) 2211 ]). 2212 2213 2214[X] :- 2215 !, 2216 consult(X). 2217[M:F|R] :- 2218 consult(M:[F|R]). 2219 2220consult(M:X) :- 2221 X == user, 2222 !, 2223 flag('$user_consult', N, N+1), 2224 NN is N + 1, 2225 atom_concat('user://', NN, Id), 2226 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2227consult(List) :- 2228 load_files(List, [expand(true)]).
2235load_files(Files) :- 2236 load_files(Files, []). 2237load_files(Module:Files, Options) :- 2238 '$must_be'(list, Options), 2239 '$load_files'(Files, Module, Options). 2240 2241'$load_files'(X, _, _) :- 2242 var(X), 2243 !, 2244 '$instantiation_error'(X). 2245'$load_files'([], _, _) :- !. 2246'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2247 '$option'(stream(_), Options), 2248 !, 2249 ( atom(Id) 2250 -> '$load_file'(Id, Module, Options) 2251 ; throw(error(type_error(atom, Id), _)) 2252 ). 2253'$load_files'(List, Module, Options) :- 2254 List = [_|_], 2255 !, 2256 '$must_be'(list, List), 2257 '$load_file_list'(List, Module, Options). 2258'$load_files'(File, Module, Options) :- 2259 '$load_one_file'(File, Module, Options). 2260 2261'$load_file_list'([], _, _). 2262'$load_file_list'([File|Rest], Module, Options) :- 2263 E = error(_,_), 2264 catch('$load_one_file'(File, Module, Options), E, 2265 '$print_message'(error, E)), 2266 '$load_file_list'(Rest, Module, Options). 2267 2268 2269'$load_one_file'(Spec, Module, Options) :- 2270 atomic(Spec), 2271 '$option'(expand(Expand), Options, false), 2272 Expand == true, 2273 !, 2274 expand_file_name(Spec, Expanded), 2275 ( Expanded = [Load] 2276 -> true 2277 ; Load = Expanded 2278 ), 2279 '$load_files'(Load, Module, [expand(false)|Options]). 2280'$load_one_file'(File, Module, Options) :- 2281 strip_module(Module:File, Into, PlainFile), 2282 '$load_file'(PlainFile, Into, Options).
2289'$noload'(true, _, _) :- 2290 !, 2291 fail. 2292'$noload'(_, FullFile, _Options) :- 2293 '$time_source_file'(FullFile, Time, system), 2294 float(Time), 2295 !. 2296'$noload'(not_loaded, FullFile, _) :- 2297 source_file(FullFile), 2298 !. 2299'$noload'(changed, Derived, _) :- 2300 '$derived_source'(_FullFile, Derived, LoadTime), 2301 time_file(Derived, Modified), 2302 Modified @=< LoadTime, 2303 !. 2304'$noload'(changed, FullFile, Options) :- 2305 '$time_source_file'(FullFile, LoadTime, user), 2306 '$modified_id'(FullFile, Modified, Options), 2307 Modified @=< LoadTime, 2308 !. 2309'$noload'(exists, File, Options) :- 2310 '$noload'(changed, File, Options).
2329'$qlf_file'(Spec, _, Spec, stream, Options) :- 2330 '$option'(stream(_), Options), % stream: no choice 2331 !. 2332'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2333 '$spec_extension'(Spec, Ext), % user explicitly specified 2334 user:prolog_file_type(Ext, prolog), 2335 !. 2336'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2337 '$compilation_mode'(database), 2338 file_name_extension(Base, PlExt, FullFile), 2339 user:prolog_file_type(PlExt, prolog), 2340 user:prolog_file_type(QlfExt, qlf), 2341 file_name_extension(Base, QlfExt, QlfFile), 2342 ( access_file(QlfFile, read), 2343 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2344 -> ( access_file(QlfFile, write) 2345 -> print_message(informational, 2346 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2347 Mode = qcompile, 2348 LoadFile = FullFile 2349 ; Why == old, 2350 ( current_prolog_flag(home, PlHome), 2351 sub_atom(FullFile, 0, _, _, PlHome) 2352 ; sub_atom(QlfFile, 0, _, _, 'res://') 2353 ) 2354 -> print_message(silent, 2355 qlf(system_lib_out_of_date(Spec, QlfFile))), 2356 Mode = qload, 2357 LoadFile = QlfFile 2358 ; print_message(warning, 2359 qlf(can_not_recompile(Spec, QlfFile, Why))), 2360 Mode = compile, 2361 LoadFile = FullFile 2362 ) 2363 ; Mode = qload, 2364 LoadFile = QlfFile 2365 ) 2366 -> ! 2367 ; '$qlf_auto'(FullFile, QlfFile, Options) 2368 -> !, Mode = qcompile, 2369 LoadFile = FullFile 2370 ). 2371'$qlf_file'(_, FullFile, FullFile, compile, _).
2379'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2380 ( access_file(PlFile, read)
2381 -> time_file(PlFile, PlTime),
2382 time_file(QlfFile, QlfTime),
2383 ( PlTime > QlfTime
2384 -> Why = old % PlFile is newer
2385 ; Error = error(Formal,_),
2386 catch('$qlf_is_compatible'(QlfFile), Error, true),
2387 nonvar(Formal) % QlfFile is incompatible
2388 -> Why = Error
2389 ; fail % QlfFile is up-to-date and ok
2390 )
2391 ; fail % can not read .pl; try .qlf
2392 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2400:- create_prolog_flag(qcompile, false, [type(atom)]). 2401 2402'$qlf_auto'(PlFile, QlfFile, Options) :- 2403 ( memberchk(qcompile(QlfMode), Options) 2404 -> true 2405 ; current_prolog_flag(qcompile, QlfMode), 2406 \+ '$in_system_dir'(PlFile) 2407 ), 2408 ( QlfMode == auto 2409 -> true 2410 ; QlfMode == large, 2411 size_file(PlFile, Size), 2412 Size > 100000 2413 ), 2414 access_file(QlfFile, write). 2415 2416'$in_system_dir'(PlFile) :- 2417 current_prolog_flag(home, Home), 2418 sub_atom(PlFile, 0, _, _, Home). 2419 2420'$spec_extension'(File, Ext) :- 2421 atom(File), 2422 file_name_extension(_, Ext, File). 2423'$spec_extension'(Spec, Ext) :- 2424 compound(Spec), 2425 arg(1, Spec, Arg), 2426 '$spec_extension'(Arg, Ext).
2438:- dynamic 2439 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2440:- '$notransact'('$resolved_source_path_db'/3). 2441 2442'$load_file'(File, Module, Options) :- 2443 '$error_count'(E0, W0), 2444 '$load_file_e'(File, Module, Options), 2445 '$error_count'(E1, W1), 2446 Errors is E1-E0, 2447 Warnings is W1-W0, 2448 ( Errors+Warnings =:= 0 2449 -> true 2450 ; '$print_message'(silent, load_file_errors(File, Errors, Warnings)) 2451 ). 2452 2453:- if(current_prolog_flag(threads, true)). 2454'$error_count'(Errors, Warnings) :- 2455 current_prolog_flag(threads, true), 2456 !, 2457 thread_self(Me), 2458 thread_statistics(Me, errors, Errors), 2459 thread_statistics(Me, warnings, Warnings). 2460:- endif. 2461'$error_count'(Errors, Warnings) :- 2462 statistics(errors, Errors), 2463 statistics(warnings, Warnings). 2464 2465'$load_file_e'(File, Module, Options) :- 2466 \+ memberchk(stream(_), Options), 2467 user:prolog_load_file(Module:File, Options), 2468 !. 2469'$load_file_e'(File, Module, Options) :- 2470 memberchk(stream(_), Options), 2471 !, 2472 '$assert_load_context_module'(File, Module, Options), 2473 '$qdo_load_file'(File, File, Module, Options). 2474'$load_file_e'(File, Module, Options) :- 2475 ( '$resolved_source_path'(File, FullFile, Options) 2476 -> true 2477 ; '$resolve_source_path'(File, FullFile, Options) 2478 ), 2479 !, 2480 '$mt_load_file'(File, FullFile, Module, Options). 2481'$load_file_e'(_, _, _).
2487'$resolved_source_path'(File, FullFile, Options) :-
2488 current_prolog_flag(emulated_dialect, Dialect),
2489 '$resolved_source_path_db'(File, Dialect, FullFile),
2490 ( '$source_file_property'(FullFile, from_state, true)
2491 ; '$source_file_property'(FullFile, resource, true)
2492 ; '$option'(if(If), Options, true),
2493 '$noload'(If, FullFile, Options)
2494 ),
2495 !.
2502'$resolve_source_path'(File, FullFile, Options) :- 2503 ( '$option'(if(If), Options), 2504 If == exists 2505 -> Extra = [file_errors(fail)] 2506 ; Extra = [] 2507 ), 2508 absolute_file_name(File, FullFile, 2509 [ file_type(prolog), 2510 access(read) 2511 | Extra 2512 ]), 2513 '$register_resolved_source_path'(File, FullFile). 2514 2515'$register_resolved_source_path'(File, FullFile) :- 2516 ( compound(File) 2517 -> current_prolog_flag(emulated_dialect, Dialect), 2518 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2519 -> true 2520 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2521 ) 2522 ; true 2523 ).
2529:- public '$translated_source'/2. 2530'$translated_source'(Old, New) :- 2531 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2532 assertz('$resolved_source_path_db'(File, Dialect, New))).
2539'$register_resource_file'(FullFile) :-
2540 ( sub_atom(FullFile, 0, _, _, 'res://'),
2541 \+ file_name_extension(_, qlf, FullFile)
2542 -> '$set_source_file'(FullFile, resource, true)
2543 ; true
2544 ).
2557'$already_loaded'(_File, FullFile, Module, Options) :- 2558 '$assert_load_context_module'(FullFile, Module, Options), 2559 '$current_module'(LoadModules, FullFile), 2560 !, 2561 ( atom(LoadModules) 2562 -> LoadModule = LoadModules 2563 ; LoadModules = [LoadModule|_] 2564 ), 2565 '$import_from_loaded_module'(LoadModule, Module, Options). 2566'$already_loaded'(_, _, user, _) :- !. 2567'$already_loaded'(File, FullFile, Module, Options) :- 2568 ( '$load_context_module'(FullFile, Module, CtxOptions), 2569 '$load_ctx_options'(Options, CtxOptions) 2570 -> true 2571 ; '$load_file'(File, Module, [if(true)|Options]) 2572 ).
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.
2587:- dynamic 2588 '$loading_file'/3. % File, Queue, Thread 2589:- volatile 2590 '$loading_file'/3. 2591:- '$notransact'('$loading_file'/3). 2592 2593:- if(current_prolog_flag(threads, true)). 2594'$mt_load_file'(File, FullFile, Module, Options) :- 2595 current_prolog_flag(threads, true), 2596 !, 2597 sig_atomic(setup_call_cleanup( 2598 with_mutex('$load_file', 2599 '$mt_start_load'(FullFile, Loading, Options)), 2600 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2601 '$mt_end_load'(Loading))). 2602:- endif. 2603'$mt_load_file'(File, FullFile, Module, Options) :- 2604 '$option'(if(If), Options, true), 2605 '$noload'(If, FullFile, Options), 2606 !, 2607 '$already_loaded'(File, FullFile, Module, Options). 2608:- if(current_prolog_flag(threads, true)). 2609'$mt_load_file'(File, FullFile, Module, Options) :- 2610 sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)). 2611:- else. 2612'$mt_load_file'(File, FullFile, Module, Options) :- 2613 '$qdo_load_file'(File, FullFile, Module, Options). 2614:- endif. 2615 2616:- if(current_prolog_flag(threads, true)). 2617'$mt_start_load'(FullFile, queue(Queue), _) :- 2618 '$loading_file'(FullFile, Queue, LoadThread), 2619 \+ thread_self(LoadThread), 2620 !. 2621'$mt_start_load'(FullFile, already_loaded, Options) :- 2622 '$option'(if(If), Options, true), 2623 '$noload'(If, FullFile, Options), 2624 !. 2625'$mt_start_load'(FullFile, Ref, _) :- 2626 thread_self(Me), 2627 message_queue_create(Queue), 2628 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2629 2630'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2631 !, 2632 catch(thread_get_message(Queue, _), error(_,_), true), 2633 '$already_loaded'(File, FullFile, Module, Options). 2634'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2635 !, 2636 '$already_loaded'(File, FullFile, Module, Options). 2637'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2638 '$assert_load_context_module'(FullFile, Module, Options), 2639 '$qdo_load_file'(File, FullFile, Module, Options). 2640 2641'$mt_end_load'(queue(_)) :- !. 2642'$mt_end_load'(already_loaded) :- !. 2643'$mt_end_load'(Ref) :- 2644 clause('$loading_file'(_, Queue, _), _, Ref), 2645 erase(Ref), 2646 thread_send_message(Queue, done), 2647 message_queue_destroy(Queue). 2648:- endif.
2654'$qdo_load_file'(File, FullFile, Module, Options) :- 2655 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2656 '$register_resource_file'(FullFile), 2657 '$run_initialization'(FullFile, Action, Options). 2658 2659'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2660 memberchk('$qlf'(QlfOut), Options), 2661 '$stage_file'(QlfOut, StageQlf), 2662 !, 2663 setup_call_catcher_cleanup( 2664 '$qstart'(StageQlf, Module, State), 2665 '$do_load_file'(File, FullFile, Module, Action, Options), 2666 Catcher, 2667 '$qend'(State, Catcher, StageQlf, QlfOut)). 2668'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2669 '$do_load_file'(File, FullFile, Module, Action, Options). 2670 2671'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2672 '$qlf_open'(Qlf), 2673 '$compilation_mode'(OldMode, qlf), 2674 '$set_source_module'(OldModule, Module). 2675 2676'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2677 '$set_source_module'(_, OldModule), 2678 '$set_compilation_mode'(OldMode), 2679 '$qlf_close', 2680 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2681 2682'$set_source_module'(OldModule, Module) :- 2683 '$current_source_module'(OldModule), 2684 '$set_source_module'(Module).
2691'$do_load_file'(File, FullFile, Module, Action, Options) :- 2692 '$option'(derived_from(DerivedFrom), Options, -), 2693 '$register_derived_source'(FullFile, DerivedFrom), 2694 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2695 ( Mode == qcompile 2696 -> qcompile(Module:File, Options) 2697 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2698 ). 2699 2700'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2701 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2702 statistics(cputime, OldTime), 2703 2704 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2705 Options), 2706 2707 '$compilation_level'(Level), 2708 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2709 '$print_message'(StartMsgLevel, 2710 load_file(start(Level, 2711 file(File, Absolute)))), 2712 2713 ( memberchk(stream(FromStream), Options) 2714 -> Input = stream 2715 ; Input = source 2716 ), 2717 2718 ( Input == stream, 2719 ( '$option'(format(qlf), Options, source) 2720 -> set_stream(FromStream, file_name(Absolute)), 2721 '$qload_stream'(FromStream, Module, Action, LM, Options) 2722 ; '$consult_file'(stream(Absolute, FromStream, []), 2723 Module, Action, LM, Options) 2724 ) 2725 -> true 2726 ; Input == source, 2727 file_name_extension(_, Ext, Absolute), 2728 ( user:prolog_file_type(Ext, qlf), 2729 E = error(_,_), 2730 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2731 E, 2732 print_message(warning, E)) 2733 -> true 2734 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2735 ) 2736 -> true 2737 ; '$print_message'(error, load_file(failed(File))), 2738 fail 2739 ), 2740 2741 '$import_from_loaded_module'(LM, Module, Options), 2742 2743 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2744 statistics(cputime, Time), 2745 ClausesCreated is NewClauses - OldClauses, 2746 TimeUsed is Time - OldTime, 2747 2748 '$print_message'(DoneMsgLevel, 2749 load_file(done(Level, 2750 file(File, Absolute), 2751 Action, 2752 LM, 2753 TimeUsed, 2754 ClausesCreated))), 2755 2756 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2757 2758'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2759 Options) :- 2760 '$save_file_scoped_flags'(ScopedFlags), 2761 '$set_sandboxed_load'(Options, OldSandBoxed), 2762 '$set_verbose_load'(Options, OldVerbose), 2763 '$set_optimise_load'(Options), 2764 '$update_autoload_level'(Options, OldAutoLevel), 2765 '$set_no_xref'(OldXRef). 2766 2767'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2768 '$set_autoload_level'(OldAutoLevel), 2769 set_prolog_flag(xref, OldXRef), 2770 set_prolog_flag(verbose_load, OldVerbose), 2771 set_prolog_flag(sandboxed_load, OldSandBoxed), 2772 '$restore_file_scoped_flags'(ScopedFlags).
2780'$save_file_scoped_flags'(State) :- 2781 current_predicate(findall/3), % Not when doing boot compile 2782 !, 2783 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2784'$save_file_scoped_flags'([]). 2785 2786'$save_file_scoped_flag'(Flag-Value) :- 2787 '$file_scoped_flag'(Flag, Default), 2788 ( current_prolog_flag(Flag, Value) 2789 -> true 2790 ; Value = Default 2791 ). 2792 2793'$file_scoped_flag'(generate_debug_info, true). 2794'$file_scoped_flag'(optimise, false). 2795'$file_scoped_flag'(xref, false). 2796 2797'$restore_file_scoped_flags'([]). 2798'$restore_file_scoped_flags'([Flag-Value|T]) :- 2799 set_prolog_flag(Flag, Value), 2800 '$restore_file_scoped_flags'(T).
2807'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2808 LoadedModule \== Module, 2809 atom(LoadedModule), 2810 !, 2811 '$option'(imports(Import), Options, all), 2812 '$option'(reexport(Reexport), Options, false), 2813 '$import_list'(Module, LoadedModule, Import, Reexport). 2814'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2822'$set_verbose_load'(Options, Old) :- 2823 current_prolog_flag(verbose_load, Old), 2824 ( memberchk(silent(Silent), Options) 2825 -> ( '$negate'(Silent, Level0) 2826 -> '$load_msg_compat'(Level0, Level) 2827 ; Level = Silent 2828 ), 2829 set_prolog_flag(verbose_load, Level) 2830 ; true 2831 ). 2832 2833'$negate'(true, false). 2834'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2843'$set_sandboxed_load'(Options, Old) :- 2844 current_prolog_flag(sandboxed_load, Old), 2845 ( memberchk(sandboxed(SandBoxed), Options), 2846 '$enter_sandboxed'(Old, SandBoxed, New), 2847 New \== Old 2848 -> set_prolog_flag(sandboxed_load, New) 2849 ; true 2850 ). 2851 2852'$enter_sandboxed'(Old, New, SandBoxed) :- 2853 ( Old == false, New == true 2854 -> SandBoxed = true, 2855 '$ensure_loaded_library_sandbox' 2856 ; Old == true, New == false 2857 -> throw(error(permission_error(leave, sandbox, -), _)) 2858 ; SandBoxed = Old 2859 ). 2860'$enter_sandboxed'(false, true, true). 2861 2862'$ensure_loaded_library_sandbox' :- 2863 source_file_property(library(sandbox), module(sandbox)), 2864 !. 2865'$ensure_loaded_library_sandbox' :- 2866 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2867 2868'$set_optimise_load'(Options) :- 2869 ( '$option'(optimise(Optimise), Options) 2870 -> set_prolog_flag(optimise, Optimise) 2871 ; true 2872 ). 2873 2874'$set_no_xref'(OldXRef) :- 2875 ( current_prolog_flag(xref, OldXRef) 2876 -> true 2877 ; OldXRef = false 2878 ), 2879 set_prolog_flag(xref, false).
2886:- thread_local 2887 '$autoload_nesting'/1. 2888:- '$notransact'('$autoload_nesting'/1). 2889 2890'$update_autoload_level'(Options, AutoLevel) :- 2891 '$option'(autoload(Autoload), Options, false), 2892 ( '$autoload_nesting'(CurrentLevel) 2893 -> AutoLevel = CurrentLevel 2894 ; AutoLevel = 0 2895 ), 2896 ( Autoload == false 2897 -> true 2898 ; NewLevel is AutoLevel + 1, 2899 '$set_autoload_level'(NewLevel) 2900 ). 2901 2902'$set_autoload_level'(New) :- 2903 retractall('$autoload_nesting'(_)), 2904 asserta('$autoload_nesting'(New)).
2912'$print_message'(Level, Term) :- 2913 current_predicate(system:print_message/2), 2914 !, 2915 print_message(Level, Term). 2916'$print_message'(warning, Term) :- 2917 source_location(File, Line), 2918 !, 2919 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2920'$print_message'(error, Term) :- 2921 !, 2922 source_location(File, Line), 2923 !, 2924 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2925'$print_message'(_Level, _Term). 2926 2927'$print_message_fail'(E) :- 2928 '$print_message'(error, E), 2929 fail.
2937'$consult_file'(Absolute, Module, What, LM, Options) :- 2938 '$current_source_module'(Module), % same module 2939 !, 2940 '$consult_file_2'(Absolute, Module, What, LM, Options). 2941'$consult_file'(Absolute, Module, What, LM, Options) :- 2942 '$set_source_module'(OldModule, Module), 2943 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2944 '$consult_file_2'(Absolute, Module, What, LM, Options), 2945 '$ifcompiling'('$qlf_end_part'), 2946 '$set_source_module'(OldModule). 2947 2948'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2949 '$set_source_module'(OldModule, Module), 2950 '$load_id'(Absolute, Id, Modified, Options), 2951 '$compile_type'(What), 2952 '$save_lex_state'(LexState, Options), 2953 '$set_dialect'(Options), 2954 setup_call_cleanup( 2955 '$start_consult'(Id, Modified), 2956 '$load_file'(Absolute, Id, LM, Options), 2957 '$end_consult'(Id, LexState, OldModule)). 2958 2959'$end_consult'(Id, LexState, OldModule) :- 2960 '$end_consult'(Id), 2961 '$restore_lex_state'(LexState), 2962 '$set_source_module'(OldModule). 2963 2964 2965:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2969'$save_lex_state'(State, Options) :- 2970 memberchk(scope_settings(false), Options), 2971 !, 2972 State = (-). 2973'$save_lex_state'(lexstate(Style, Dialect), _) :- 2974 '$style_check'(Style, Style), 2975 current_prolog_flag(emulated_dialect, Dialect). 2976 2977'$restore_lex_state'(-) :- !. 2978'$restore_lex_state'(lexstate(Style, Dialect)) :- 2979 '$style_check'(_, Style), 2980 set_prolog_flag(emulated_dialect, Dialect). 2981 2982'$set_dialect'(Options) :- 2983 memberchk(dialect(Dialect), Options), 2984 !, 2985 '$expects_dialect'(Dialect). 2986'$set_dialect'(_). 2987 2988'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 2989 !, 2990 '$modified_id'(Id, Modified, Options). 2991'$load_id'(Id, Id, Modified, Options) :- 2992 '$modified_id'(Id, Modified, Options). 2993 2994'$modified_id'(_, Modified, Options) :- 2995 '$option'(modified(Stamp), Options, Def), 2996 Stamp \== Def, 2997 !, 2998 Modified = Stamp. 2999'$modified_id'(Id, Modified, _) :- 3000 catch(time_file(Id, Modified), 3001 error(_, _), 3002 fail), 3003 !. 3004'$modified_id'(_, 0, _). 3005 3006 3007'$compile_type'(What) :- 3008 '$compilation_mode'(How), 3009 ( How == database 3010 -> What = compiled 3011 ; How == qlf 3012 -> What = '*qcompiled*' 3013 ; What = 'boot compiled' 3014 ).
3024:- dynamic 3025 '$load_context_module'/3. 3026:- multifile 3027 '$load_context_module'/3. 3028:- '$notransact'('$load_context_module'/3). 3029 3030'$assert_load_context_module'(_, _, Options) :- 3031 memberchk(register(false), Options), 3032 !. 3033'$assert_load_context_module'(File, Module, Options) :- 3034 source_location(FromFile, Line), 3035 !, 3036 '$master_file'(FromFile, MasterFile), 3037 '$check_load_non_module'(File, Module), 3038 '$add_dialect'(Options, Options1), 3039 '$load_ctx_options'(Options1, Options2), 3040 '$store_admin_clause'( 3041 system:'$load_context_module'(File, Module, Options2), 3042 _Layout, MasterFile, FromFile:Line). 3043'$assert_load_context_module'(File, Module, Options) :- 3044 '$check_load_non_module'(File, Module), 3045 '$add_dialect'(Options, Options1), 3046 '$load_ctx_options'(Options1, Options2), 3047 ( clause('$load_context_module'(File, Module, _), true, Ref), 3048 \+ clause_property(Ref, file(_)), 3049 erase(Ref) 3050 -> true 3051 ; true 3052 ), 3053 assertz('$load_context_module'(File, Module, Options2)). 3054 3055'$add_dialect'(Options0, Options) :- 3056 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 3057 !, 3058 Options = [dialect(Dialect)|Options0]. 3059'$add_dialect'(Options, Options).
3066'$load_ctx_options'(Options, CtxOptions) :- 3067 '$load_ctx_options2'(Options, CtxOptions0), 3068 sort(CtxOptions0, CtxOptions). 3069 3070'$load_ctx_options2'([], []). 3071'$load_ctx_options2'([H|T0], [H|T]) :- 3072 '$load_ctx_option'(H), 3073 !, 3074 '$load_ctx_options2'(T0, T). 3075'$load_ctx_options2'([_|T0], T) :- 3076 '$load_ctx_options2'(T0, T). 3077 3078'$load_ctx_option'(derived_from(_)). 3079'$load_ctx_option'(dialect(_)). 3080'$load_ctx_option'(encoding(_)). 3081'$load_ctx_option'(imports(_)). 3082'$load_ctx_option'(reexport(_)).
3090'$check_load_non_module'(File, _) :- 3091 '$current_module'(_, File), 3092 !. % File is a module file 3093'$check_load_non_module'(File, Module) :- 3094 '$load_context_module'(File, OldModule, _), 3095 Module \== OldModule, 3096 !, 3097 format(atom(Msg), 3098 'Non-module file already loaded into module ~w; \c 3099 trying to load into ~w', 3100 [OldModule, Module]), 3101 throw(error(permission_error(load, source, File), 3102 context(load_files/2, Msg))). 3103'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
3116'$load_file'(Path, Id, Module, Options) :- 3117 State = state(true, _, true, false, Id, -), 3118 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 3119 _Stream, Options), 3120 '$valid_term'(Term), 3121 ( arg(1, State, true) 3122 -> '$first_term'(Term, Layout, Id, State, Options), 3123 nb_setarg(1, State, false) 3124 ; '$compile_term'(Term, Layout, Id, Options) 3125 ), 3126 arg(4, State, true) 3127 ; '$fixup_reconsult'(Id), 3128 '$end_load_file'(State) 3129 ), 3130 !, 3131 arg(2, State, Module). 3132 3133'$valid_term'(Var) :- 3134 var(Var), 3135 !, 3136 print_message(error, error(instantiation_error, _)). 3137'$valid_term'(Term) :- 3138 Term \== []. 3139 3140'$end_load_file'(State) :- 3141 arg(1, State, true), % empty file 3142 !, 3143 nb_setarg(2, State, Module), 3144 arg(5, State, Id), 3145 '$current_source_module'(Module), 3146 '$ifcompiling'('$qlf_start_file'(Id)), 3147 '$ifcompiling'('$qlf_end_part'). 3148'$end_load_file'(State) :- 3149 arg(3, State, End), 3150 '$end_load_file'(End, State). 3151 3152'$end_load_file'(true, _). 3153'$end_load_file'(end_module, State) :- 3154 arg(2, State, Module), 3155 '$check_export'(Module), 3156 '$ifcompiling'('$qlf_end_part'). 3157'$end_load_file'(end_non_module, _State) :- 3158 '$ifcompiling'('$qlf_end_part'). 3159 3160 3161'$first_term'(?-(Directive), Layout, Id, State, Options) :- 3162 !, 3163 '$first_term'(:-(Directive), Layout, Id, State, Options). 3164'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 3165 nonvar(Directive), 3166 ( ( Directive = module(Name, Public) 3167 -> Imports = [] 3168 ; Directive = module(Name, Public, Imports) 3169 ) 3170 -> !, 3171 '$module_name'(Name, Id, Module, Options), 3172 '$start_module'(Module, Public, State, Options), 3173 '$module3'(Imports) 3174 ; Directive = expects_dialect(Dialect) 3175 -> !, 3176 '$set_dialect'(Dialect, State), 3177 fail % Still consider next term as first 3178 ). 3179'$first_term'(Term, Layout, Id, State, Options) :- 3180 '$start_non_module'(Id, Term, State, Options), 3181 '$compile_term'(Term, Layout, Id, Options).
3188'$compile_term'(Term, Layout, SrcId, Options) :- 3189 '$compile_term'(Term, Layout, SrcId, -, Options). 3190 3191'$compile_term'(Var, _Layout, _Id, _SrcLoc, _Options) :- 3192 var(Var), 3193 !, 3194 '$instantiation_error'(Var). 3195'$compile_term'((?-Directive), _Layout, Id, _SrcLoc, Options) :- 3196 !, 3197 '$execute_directive'(Directive, Id, Options). 3198'$compile_term'((:-Directive), _Layout, Id, _SrcLoc, Options) :- 3199 !, 3200 '$execute_directive'(Directive, Id, Options). 3201'$compile_term'('$source_location'(File, Line):Term, 3202 Layout, Id, _SrcLoc, Options) :- 3203 !, 3204 '$compile_term'(Term, Layout, Id, File:Line, Options). 3205'$compile_term'(Clause, Layout, Id, SrcLoc, _Options) :- 3206 E = error(_,_), 3207 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3208 '$print_message'(error, E)). 3209 3210'$start_non_module'(_Id, Term, _State, Options) :- 3211 '$option'(must_be_module(true), Options, false), 3212 !, 3213 '$domain_error'(module_header, Term). 3214'$start_non_module'(Id, _Term, State, _Options) :- 3215 '$current_source_module'(Module), 3216 '$ifcompiling'('$qlf_start_file'(Id)), 3217 '$qset_dialect'(State), 3218 nb_setarg(2, State, Module), 3219 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3232'$set_dialect'(Dialect, State) :- 3233 '$compilation_mode'(qlf, database), 3234 !, 3235 '$expects_dialect'(Dialect), 3236 '$compilation_mode'(_, qlf), 3237 nb_setarg(6, State, Dialect). 3238'$set_dialect'(Dialect, _) :- 3239 '$expects_dialect'(Dialect). 3240 3241'$qset_dialect'(State) :- 3242 '$compilation_mode'(qlf), 3243 arg(6, State, Dialect), Dialect \== (-), 3244 !, 3245 '$add_directive_wic'('$expects_dialect'(Dialect)). 3246'$qset_dialect'(_). 3247 3248'$expects_dialect'(Dialect) :- 3249 Dialect == swi, 3250 !, 3251 set_prolog_flag(emulated_dialect, Dialect). 3252'$expects_dialect'(Dialect) :- 3253 current_predicate(expects_dialect/1), 3254 !, 3255 expects_dialect(Dialect). 3256'$expects_dialect'(Dialect) :- 3257 use_module(library(dialect), [expects_dialect/1]), 3258 expects_dialect(Dialect). 3259 3260 3261 /******************************* 3262 * MODULES * 3263 *******************************/ 3264 3265'$start_module'(Module, _Public, State, _Options) :- 3266 '$current_module'(Module, OldFile), 3267 source_location(File, _Line), 3268 OldFile \== File, OldFile \== [], 3269 same_file(OldFile, File), 3270 !, 3271 nb_setarg(2, State, Module), 3272 nb_setarg(4, State, true). % Stop processing 3273'$start_module'(Module, Public, State, Options) :- 3274 arg(5, State, File), 3275 nb_setarg(2, State, Module), 3276 source_location(_File, Line), 3277 '$option'(redefine_module(Action), Options, false), 3278 '$module_class'(File, Class, Super), 3279 '$reset_dialect'(File, Class), 3280 '$redefine_module'(Module, File, Action), 3281 '$declare_module'(Module, Class, Super, File, Line, false), 3282 '$export_list'(Public, Module, Ops), 3283 '$ifcompiling'('$qlf_start_module'(Module)), 3284 '$export_ops'(Ops, Module, File), 3285 '$qset_dialect'(State), 3286 nb_setarg(3, State, end_module).
swi
dialect.3293'$reset_dialect'(File, library) :- 3294 file_name_extension(_, pl, File), 3295 !, 3296 set_prolog_flag(emulated_dialect, swi). 3297'$reset_dialect'(_, _).
3304'$module3'(Var) :- 3305 var(Var), 3306 !, 3307 '$instantiation_error'(Var). 3308'$module3'([]) :- !. 3309'$module3'([H|T]) :- 3310 !, 3311 '$module3'(H), 3312 '$module3'(T). 3313'$module3'(Id) :- 3314 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.3328'$module_name'(_, _, Module, Options) :- 3329 '$option'(module(Module), Options), 3330 !, 3331 '$current_source_module'(Context), 3332 Context \== Module. % cause '$first_term'/5 to fail. 3333'$module_name'(Var, Id, Module, Options) :- 3334 var(Var), 3335 !, 3336 file_base_name(Id, File), 3337 file_name_extension(Var, _, File), 3338 '$module_name'(Var, Id, Module, Options). 3339'$module_name'(Reserved, _, _, _) :- 3340 '$reserved_module'(Reserved), 3341 !, 3342 throw(error(permission_error(load, module, Reserved), _)). 3343'$module_name'(Module, _Id, Module, _). 3344 3345 3346'$reserved_module'(system). 3347'$reserved_module'(user).
3352'$redefine_module'(_Module, _, false) :- !. 3353'$redefine_module'(Module, File, true) :- 3354 !, 3355 ( module_property(Module, file(OldFile)), 3356 File \== OldFile 3357 -> unload_file(OldFile) 3358 ; true 3359 ). 3360'$redefine_module'(Module, File, ask) :- 3361 ( stream_property(user_input, tty(true)), 3362 module_property(Module, file(OldFile)), 3363 File \== OldFile, 3364 '$rdef_response'(Module, OldFile, File, true) 3365 -> '$redefine_module'(Module, File, true) 3366 ; true 3367 ). 3368 3369'$rdef_response'(Module, OldFile, File, Ok) :- 3370 repeat, 3371 print_message(query, redefine_module(Module, OldFile, File)), 3372 get_single_char(Char), 3373 '$rdef_response'(Char, Ok0), 3374 !, 3375 Ok = Ok0. 3376 3377'$rdef_response'(Char, true) :- 3378 memberchk(Char, `yY`), 3379 format(user_error, 'yes~n', []). 3380'$rdef_response'(Char, false) :- 3381 memberchk(Char, `nN`), 3382 format(user_error, 'no~n', []). 3383'$rdef_response'(Char, _) :- 3384 memberchk(Char, `a`), 3385 format(user_error, 'abort~n', []), 3386 abort. 3387'$rdef_response'(_, _) :- 3388 print_message(help, redefine_module_reply), 3389 fail.
system
, while all normal user modules inherit
from user
.3399'$module_class'(File, Class, system) :- 3400 current_prolog_flag(home, Home), 3401 sub_atom(File, 0, Len, _, Home), 3402 ( sub_atom(File, Len, _, _, '/boot/') 3403 -> !, Class = system 3404 ; '$lib_prefix'(Prefix), 3405 sub_atom(File, Len, _, _, Prefix) 3406 -> !, Class = library 3407 ; file_directory_name(File, Home), 3408 file_name_extension(_, rc, File) 3409 -> !, Class = library 3410 ). 3411'$module_class'(_, user, user). 3412 3413'$lib_prefix'('/library'). 3414'$lib_prefix'('/xpce/prolog/'). 3415 3416'$check_export'(Module) :- 3417 '$undefined_export'(Module, UndefList), 3418 ( '$member'(Undef, UndefList), 3419 strip_module(Undef, _, Local), 3420 print_message(error, 3421 undefined_export(Module, Local)), 3422 fail 3423 ; true 3424 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3433'$import_list'(_, _, Var, _) :- 3434 var(Var), 3435 !, 3436 throw(error(instantitation_error, _)). 3437'$import_list'(Target, Source, all, Reexport) :- 3438 !, 3439 '$exported_ops'(Source, Import, Predicates), 3440 '$module_property'(Source, exports(Predicates)), 3441 '$import_all'(Import, Target, Source, Reexport, weak). 3442'$import_list'(Target, Source, except(Spec), Reexport) :- 3443 !, 3444 '$exported_ops'(Source, Export, Predicates), 3445 '$module_property'(Source, exports(Predicates)), 3446 ( is_list(Spec) 3447 -> true 3448 ; throw(error(type_error(list, Spec), _)) 3449 ), 3450 '$import_except'(Spec, Source, Export, Import), 3451 '$import_all'(Import, Target, Source, Reexport, weak). 3452'$import_list'(Target, Source, Import, Reexport) :- 3453 !, 3454 is_list(Import), 3455 !, 3456 '$import_all'(Import, Target, Source, Reexport, strong). 3457'$import_list'(_, _, Import, _) :- 3458 '$type_error'(import_specifier, Import). 3459 3460 3461'$import_except'([], _, List, List). 3462'$import_except'([H|T], Source, List0, List) :- 3463 '$import_except_1'(H, Source, List0, List1), 3464 '$import_except'(T, Source, List1, List). 3465 3466'$import_except_1'(Var, _, _, _) :- 3467 var(Var), 3468 !, 3469 '$instantiation_error'(Var). 3470'$import_except_1'(PI as N, _, List0, List) :- 3471 '$pi'(PI), atom(N), 3472 !, 3473 '$canonical_pi'(PI, CPI), 3474 '$import_as'(CPI, N, List0, List). 3475'$import_except_1'(op(P,A,N), _, List0, List) :- 3476 !, 3477 '$remove_ops'(List0, op(P,A,N), List). 3478'$import_except_1'(PI, Source, List0, List) :- 3479 '$pi'(PI), 3480 !, 3481 '$canonical_pi'(PI, CPI), 3482 ( '$select'(P, List0, List), 3483 '$canonical_pi'(CPI, P) 3484 -> true 3485 ; print_message(warning, 3486 error(existence_error(export, PI, module(Source)), _)), 3487 List = List0 3488 ). 3489'$import_except_1'(Except, _, _, _) :- 3490 '$type_error'(import_specifier, Except). 3491 3492'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3493 '$canonical_pi'(PI2, CPI), 3494 !. 3495'$import_as'(PI, N, [H|T0], [H|T]) :- 3496 !, 3497 '$import_as'(PI, N, T0, T). 3498'$import_as'(PI, _, _, _) :- 3499 '$existence_error'(export, PI). 3500 3501'$pi'(N/A) :- atom(N), integer(A), !. 3502'$pi'(N//A) :- atom(N), integer(A). 3503 3504'$canonical_pi'(N//A0, N/A) :- 3505 A is A0 + 2. 3506'$canonical_pi'(PI, PI). 3507 3508'$remove_ops'([], _, []). 3509'$remove_ops'([Op|T0], Pattern, T) :- 3510 subsumes_term(Pattern, Op), 3511 !, 3512 '$remove_ops'(T0, Pattern, T). 3513'$remove_ops'([H|T0], Pattern, [H|T]) :- 3514 '$remove_ops'(T0, Pattern, T).
3519'$import_all'(Import, Context, Source, Reexport, Strength) :-
3520 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3521 ( Reexport == true,
3522 ( '$list_to_conj'(Imported, Conj)
3523 -> export(Context:Conj),
3524 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3525 ; true
3526 ),
3527 source_location(File, _Line),
3528 '$export_ops'(ImpOps, Context, File)
3529 ; true
3530 ).
3534'$import_all2'([], _, _, [], [], _). 3535'$import_all2'([PI as NewName|Rest], Context, Source, 3536 [NewName/Arity|Imported], ImpOps, Strength) :- 3537 !, 3538 '$canonical_pi'(PI, Name/Arity), 3539 length(Args, Arity), 3540 Head =.. [Name|Args], 3541 NewHead =.. [NewName|Args], 3542 ( '$get_predicate_attribute'(Source:Head, transparent, 1) 3543 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3544 ; true 3545 ), 3546 ( source_location(File, Line) 3547 -> E = error(_,_), 3548 catch('$store_admin_clause'((NewHead :- Source:Head), 3549 _Layout, File, File:Line), 3550 E, '$print_message'(error, E)) 3551 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3552 ), % duplicate load 3553 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3554'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3555 [op(P,A,N)|ImpOps], Strength) :- 3556 !, 3557 '$import_ops'(Context, Source, op(P,A,N)), 3558 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3559'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3560 Error = error(_,_), 3561 catch(Context:'$import'(Source:Pred, Strength), Error, 3562 print_message(error, Error)), 3563 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3564 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3565 3566 3567'$list_to_conj'([One], One) :- !. 3568'$list_to_conj'([H|T], (H,Rest)) :- 3569 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3576'$exported_ops'(Module, Ops, Tail) :- 3577 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3578 !, 3579 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3580'$exported_ops'(_, Ops, Ops). 3581 3582'$exported_op'(Module, P, A, N) :- 3583 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3584 Module:'$exported_op'(P, A, N).
3591'$import_ops'(To, From, Pattern) :- 3592 ground(Pattern), 3593 !, 3594 Pattern = op(P,A,N), 3595 op(P,A,To:N), 3596 ( '$exported_op'(From, P, A, N) 3597 -> true 3598 ; print_message(warning, no_exported_op(From, Pattern)) 3599 ). 3600'$import_ops'(To, From, Pattern) :- 3601 ( '$exported_op'(From, Pri, Assoc, Name), 3602 Pattern = op(Pri, Assoc, Name), 3603 op(Pri, Assoc, To:Name), 3604 fail 3605 ; true 3606 ).
3614'$export_list'(Decls, Module, Ops) :- 3615 is_list(Decls), 3616 !, 3617 '$do_export_list'(Decls, Module, Ops). 3618'$export_list'(Decls, _, _) :- 3619 var(Decls), 3620 throw(error(instantiation_error, _)). 3621'$export_list'(Decls, _, _) :- 3622 throw(error(type_error(list, Decls), _)). 3623 3624'$do_export_list'([], _, []) :- !. 3625'$do_export_list'([H|T], Module, Ops) :- 3626 !, 3627 E = error(_,_), 3628 catch('$export1'(H, Module, Ops, Ops1), 3629 E, ('$print_message'(error, E), Ops = Ops1)), 3630 '$do_export_list'(T, Module, Ops1). 3631 3632'$export1'(Var, _, _, _) :- 3633 var(Var), 3634 !, 3635 throw(error(instantiation_error, _)). 3636'$export1'(Op, _, [Op|T], T) :- 3637 Op = op(_,_,_), 3638 !. 3639'$export1'(PI0, Module, Ops, Ops) :- 3640 strip_module(Module:PI0, M, PI), 3641 ( PI = (_//_) 3642 -> non_terminal(M:PI) 3643 ; true 3644 ), 3645 export(M:PI). 3646 3647'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3648 E = error(_,_), 3649 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File, []), 3650 '$export_op'(Pri, Assoc, Name, Module, File) 3651 ), 3652 E, '$print_message'(error, E)), 3653 '$export_ops'(T, Module, File). 3654'$export_ops'([], _, _). 3655 3656'$export_op'(Pri, Assoc, Name, Module, File) :- 3657 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3658 -> true 3659 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File, []) 3660 ), 3661 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3667'$execute_directive'(Var, _F, _Options) :- 3668 var(Var), 3669 '$instantiation_error'(Var). 3670'$execute_directive'(encoding(Encoding), _F, _Options) :- 3671 !, 3672 ( '$load_input'(_F, S) 3673 -> set_stream(S, encoding(Encoding)) 3674 ). 3675'$execute_directive'(Goal, _, Options) :- 3676 \+ '$compilation_mode'(database), 3677 !, 3678 '$add_directive_wic2'(Goal, Type, Options), 3679 ( Type == call % suspend compiling into .qlf file 3680 -> '$compilation_mode'(Old, database), 3681 setup_call_cleanup( 3682 '$directive_mode'(OldDir, Old), 3683 '$execute_directive_3'(Goal), 3684 ( '$set_compilation_mode'(Old), 3685 '$set_directive_mode'(OldDir) 3686 )) 3687 ; '$execute_directive_3'(Goal) 3688 ). 3689'$execute_directive'(Goal, _, _Options) :- 3690 '$execute_directive_3'(Goal). 3691 3692'$execute_directive_3'(Goal) :- 3693 '$current_source_module'(Module), 3694 '$valid_directive'(Module:Goal), 3695 !, 3696 ( '$pattr_directive'(Goal, Module) 3697 -> true 3698 ; Term = error(_,_), 3699 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3700 -> true 3701 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3702 fail 3703 ). 3704'$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.3713:- multifile prolog:sandbox_allowed_directive/1. 3714:- multifile prolog:sandbox_allowed_clause/1. 3715:- meta_predicate '$valid_directive'( ). 3716 3717'$valid_directive'(_) :- 3718 current_prolog_flag(sandboxed_load, false), 3719 !. 3720'$valid_directive'(Goal) :- 3721 Error = error(Formal, _), 3722 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3723 !, 3724 ( var(Formal) 3725 -> true 3726 ; print_message(error, Error), 3727 fail 3728 ). 3729'$valid_directive'(Goal) :- 3730 print_message(error, 3731 error(permission_error(execute, 3732 sandboxed_directive, 3733 Goal), _)), 3734 fail. 3735 3736'$exception_in_directive'(Term) :- 3737 '$print_message'(error, Term), 3738 fail.
load
or call
. Add a call
directive to the QLF file. load
directives continue the
compilation into the QLF file.3746'$add_directive_wic2'(Goal, Type, Options) :- 3747 '$common_goal_type'(Goal, Type, Options), 3748 !, 3749 ( Type == load 3750 -> true 3751 ; '$current_source_module'(Module), 3752 '$add_directive_wic'(Module:Goal) 3753 ). 3754'$add_directive_wic2'(Goal, _, _) :- 3755 ( '$compilation_mode'(qlf) % no problem for qlf files 3756 -> true 3757 ; print_message(error, mixed_directive(Goal)) 3758 ).
load
or call
.3765'$common_goal_type'((A,B), Type, Options) :- 3766 !, 3767 '$common_goal_type'(A, Type, Options), 3768 '$common_goal_type'(B, Type, Options). 3769'$common_goal_type'((A;B), Type, Options) :- 3770 !, 3771 '$common_goal_type'(A, Type, Options), 3772 '$common_goal_type'(B, Type, Options). 3773'$common_goal_type'((A->B), Type, Options) :- 3774 !, 3775 '$common_goal_type'(A, Type, Options), 3776 '$common_goal_type'(B, Type, Options). 3777'$common_goal_type'(Goal, Type, Options) :- 3778 '$goal_type'(Goal, Type, Options). 3779 3780'$goal_type'(Goal, Type, Options) :- 3781 ( '$load_goal'(Goal, Options) 3782 -> Type = load 3783 ; Type = call 3784 ). 3785 3786:- thread_local 3787 '$qlf':qinclude/1. 3788 3789'$load_goal'([_|_], _). 3790'$load_goal'(consult(_), _). 3791'$load_goal'(load_files(_), _). 3792'$load_goal'(load_files(_,Options), _) :- 3793 memberchk(qcompile(QlfMode), Options), 3794 '$qlf_part_mode'(QlfMode). 3795'$load_goal'(ensure_loaded(_), _) :- '$compilation_mode'(wic). 3796'$load_goal'(use_module(_), _) :- '$compilation_mode'(wic). 3797'$load_goal'(use_module(_, _), _) :- '$compilation_mode'(wic). 3798'$load_goal'(reexport(_), _) :- '$compilation_mode'(wic). 3799'$load_goal'(reexport(_, _), _) :- '$compilation_mode'(wic). 3800'$load_goal'(Goal, _Options) :- 3801 '$qlf':qinclude(user), 3802 '$load_goal_file'(Goal, File), 3803 '$all_user_files'(File). 3804 3805 3806'$load_goal_file'(load_files(F), F). 3807'$load_goal_file'(load_files(F, _), F). 3808'$load_goal_file'(ensure_loaded(F), F). 3809'$load_goal_file'(use_module(F), F). 3810'$load_goal_file'(use_module(F, _), F). 3811'$load_goal_file'(reexport(F), F). 3812'$load_goal_file'(reexport(F, _), F). 3813 3814'$all_user_files'([]) :- 3815 !. 3816'$all_user_files'([H|T]) :- 3817 !, 3818 '$is_user_file'(H), 3819 '$all_user_files'(T). 3820'$all_user_files'(F) :- 3821 ground(F), 3822 '$is_user_file'(F). 3823 3824'$is_user_file'(File) :- 3825 absolute_file_name(File, Path, 3826 [ file_type(prolog), 3827 access(read) 3828 ]), 3829 '$module_class'(Path, user, _). 3830 3831'$qlf_part_mode'(part). 3832'$qlf_part_mode'(true). % compatibility 3833 3834 3835 /******************************** 3836 * COMPILE A CLAUSE * 3837 *********************************/
3844'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3845 Owner \== (-), 3846 !, 3847 setup_call_cleanup( 3848 '$start_aux'(Owner, Context), 3849 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3850 '$end_aux'(Owner, Context)). 3851'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3852 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3853 3854'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3855 ( '$compilation_mode'(database) 3856 -> '$record_clause'(Clause, File, SrcLoc) 3857 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3858 '$qlf_assert_clause'(Ref, development) 3859 ).
3869'$store_clause'((_, _), _, _, _) :- 3870 !, 3871 print_message(error, cannot_redefine_comma), 3872 fail. 3873'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3874 nonvar(Pre), 3875 Pre = (Head,Cond), 3876 !, 3877 ( '$is_true'(Cond), current_prolog_flag(optimise, true) 3878 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc) 3879 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc) 3880 ). 3881'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3882 '$valid_clause'(Clause), 3883 !, 3884 ( '$compilation_mode'(database) 3885 -> '$record_clause'(Clause, File, SrcLoc) 3886 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3887 '$qlf_assert_clause'(Ref, development) 3888 ). 3889 3890'$is_true'(true) => true. 3891'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B). 3892'$is_true'(_) => fail. 3893 3894'$valid_clause'(_) :- 3895 current_prolog_flag(sandboxed_load, false), 3896 !. 3897'$valid_clause'(Clause) :- 3898 \+ '$cross_module_clause'(Clause), 3899 !. 3900'$valid_clause'(Clause) :- 3901 Error = error(Formal, _), 3902 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3903 !, 3904 ( var(Formal) 3905 -> true 3906 ; print_message(error, Error), 3907 fail 3908 ). 3909'$valid_clause'(Clause) :- 3910 print_message(error, 3911 error(permission_error(assert, 3912 sandboxed_clause, 3913 Clause), _)), 3914 fail. 3915 3916'$cross_module_clause'(Clause) :- 3917 '$head_module'(Clause, Module), 3918 \+ '$current_source_module'(Module). 3919 3920'$head_module'(Var, _) :- 3921 var(Var), !, fail. 3922'$head_module'((Head :- _), Module) :- 3923 '$head_module'(Head, Module). 3924'$head_module'(Module:_, Module). 3925 3926'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3927'$clause_source'(Clause, Clause, -).
3934:- public 3935 '$store_clause'/2. 3936 3937'$store_clause'(Term, Id) :- 3938 '$clause_source'(Term, Clause, SrcLoc), 3939 '$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)
3960compile_aux_clauses(_Clauses) :- 3961 current_prolog_flag(xref, true), 3962 !. 3963compile_aux_clauses(Clauses) :- 3964 source_location(File, _Line), 3965 '$compile_aux_clauses'(Clauses, File). 3966 3967'$compile_aux_clauses'(Clauses, File) :- 3968 setup_call_cleanup( 3969 '$start_aux'(File, Context), 3970 '$store_aux_clauses'(Clauses, File), 3971 '$end_aux'(File, Context)). 3972 3973'$store_aux_clauses'(Clauses, File) :- 3974 is_list(Clauses), 3975 !, 3976 forall('$member'(C,Clauses), 3977 '$compile_term'(C, _Layout, File, [])). 3978'$store_aux_clauses'(Clause, File) :- 3979 '$compile_term'(Clause, _Layout, File, []). 3980 3981 3982 /******************************* 3983 * STAGING * 3984 *******************************/
3994'$stage_file'(Target, Stage) :- 3995 file_directory_name(Target, Dir), 3996 file_base_name(Target, File), 3997 current_prolog_flag(pid, Pid), 3998 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 3999 4000'$install_staged_file'(exit, Staged, Target, error) :- 4001 !, 4002 rename_file(Staged, Target). 4003'$install_staged_file'(exit, Staged, Target, OnError) :- 4004 !, 4005 InstallError = error(_,_), 4006 catch(rename_file(Staged, Target), 4007 InstallError, 4008 '$install_staged_error'(OnError, InstallError, Staged, Target)). 4009'$install_staged_file'(_, Staged, _, _OnError) :- 4010 E = error(_,_), 4011 catch(delete_file(Staged), E, true). 4012 4013'$install_staged_error'(OnError, Error, Staged, _Target) :- 4014 E = error(_,_), 4015 catch(delete_file(Staged), E, true), 4016 ( OnError = silent 4017 -> true 4018 ; OnError = fail 4019 -> fail 4020 ; print_message(warning, Error) 4021 ). 4022 4023 4024 /******************************* 4025 * READING * 4026 *******************************/ 4027 4028:- multifile 4029 prolog:comment_hook/3. % hook for read_clause/3 4030 4031 4032 /******************************* 4033 * FOREIGN INTERFACE * 4034 *******************************/ 4035 4036% call-back from PL_register_foreign(). First argument is the module 4037% into which the foreign predicate is loaded and second is a term 4038% describing the arguments. 4039 4040:- dynamic 4041 '$foreign_registered'/2. 4042 4043 /******************************* 4044 * TEMPORARY TERM EXPANSION * 4045 *******************************/ 4046 4047% Provide temporary definitions for the boot-loader. These are replaced 4048% by the real thing in load.pl 4049 4050:- dynamic 4051 '$expand_goal'/2, 4052 '$expand_term'/4. 4053 4054'$expand_goal'(In, In). 4055'$expand_term'(In, Layout, In, Layout). 4056 4057 4058 /******************************* 4059 * TYPE SUPPORT * 4060 *******************************/ 4061 4062'$type_error'(Type, Value) :- 4063 ( var(Value) 4064 -> throw(error(instantiation_error, _)) 4065 ; throw(error(type_error(Type, Value), _)) 4066 ). 4067 4068'$domain_error'(Type, Value) :- 4069 throw(error(domain_error(Type, Value), _)). 4070 4071'$existence_error'(Type, Object) :- 4072 throw(error(existence_error(Type, Object), _)). 4073 4074'$existence_error'(Type, Object, In) :- 4075 throw(error(existence_error(Type, Object, In), _)). 4076 4077'$permission_error'(Action, Type, Term) :- 4078 throw(error(permission_error(Action, Type, Term), _)). 4079 4080'$instantiation_error'(_Var) :- 4081 throw(error(instantiation_error, _)). 4082 4083'$uninstantiation_error'(NonVar) :- 4084 throw(error(uninstantiation_error(NonVar), _)). 4085 4086'$must_be'(list, X) :- !, 4087 '$skip_list'(_, X, Tail), 4088 ( Tail == [] 4089 -> true 4090 ; '$type_error'(list, Tail) 4091 ). 4092'$must_be'(options, X) :- !, 4093 ( '$is_options'(X) 4094 -> true 4095 ; '$type_error'(options, X) 4096 ). 4097'$must_be'(atom, X) :- !, 4098 ( atom(X) 4099 -> true 4100 ; '$type_error'(atom, X) 4101 ). 4102'$must_be'(integer, X) :- !, 4103 ( integer(X) 4104 -> true 4105 ; '$type_error'(integer, X) 4106 ). 4107'$must_be'(between(Low,High), X) :- !, 4108 ( integer(X) 4109 -> ( between(Low, High, X) 4110 -> true 4111 ; '$domain_error'(between(Low,High), X) 4112 ) 4113 ; '$type_error'(integer, X) 4114 ). 4115'$must_be'(callable, X) :- !, 4116 ( callable(X) 4117 -> true 4118 ; '$type_error'(callable, X) 4119 ). 4120'$must_be'(acyclic, X) :- !, 4121 ( acyclic_term(X) 4122 -> true 4123 ; '$domain_error'(acyclic_term, X) 4124 ). 4125'$must_be'(oneof(Type, Domain, List), X) :- !, 4126 '$must_be'(Type, X), 4127 ( memberchk(X, List) 4128 -> true 4129 ; '$domain_error'(Domain, X) 4130 ). 4131'$must_be'(boolean, X) :- !, 4132 ( (X == true ; X == false) 4133 -> true 4134 ; '$type_error'(boolean, X) 4135 ). 4136'$must_be'(ground, X) :- !, 4137 ( ground(X) 4138 -> true 4139 ; '$instantiation_error'(X) 4140 ). 4141'$must_be'(filespec, X) :- !, 4142 ( ( atom(X) 4143 ; string(X) 4144 ; compound(X), 4145 compound_name_arity(X, _, 1) 4146 ) 4147 -> true 4148 ; '$type_error'(filespec, X) 4149 ). 4150 4151% Use for debugging 4152%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 4153 4154 4155 /******************************** 4156 * LIST PROCESSING * 4157 *********************************/ 4158 4159'$member'(El, [H|T]) :- 4160 '$member_'(T, El, H). 4161 4162'$member_'(_, El, El). 4163'$member_'([H|T], El, _) :- 4164 '$member_'(T, El, H). 4165 4166'$append'([], L, L). 4167'$append'([H|T], L, [H|R]) :- 4168 '$append'(T, L, R). 4169 4170'$append'(ListOfLists, List) :- 4171 '$must_be'(list, ListOfLists), 4172 '$append_'(ListOfLists, List). 4173 4174'$append_'([], []). 4175'$append_'([L|Ls], As) :- 4176 '$append'(L, Ws, As), 4177 '$append_'(Ls, Ws). 4178 4179'$select'(X, [X|Tail], Tail). 4180'$select'(Elem, [Head|Tail], [Head|Rest]) :- 4181 '$select'(Elem, Tail, Rest). 4182 4183'$reverse'(L1, L2) :- 4184 '$reverse'(L1, [], L2). 4185 4186'$reverse'([], List, List). 4187'$reverse'([Head|List1], List2, List3) :- 4188 '$reverse'(List1, [Head|List2], List3). 4189 4190'$delete'([], _, []) :- !. 4191'$delete'([Elem|Tail], Elem, Result) :- 4192 !, 4193 '$delete'(Tail, Elem, Result). 4194'$delete'([Head|Tail], Elem, [Head|Rest]) :- 4195 '$delete'(Tail, Elem, Rest). 4196 4197'$last'([H|T], Last) :- 4198 '$last'(T, H, Last). 4199 4200'$last'([], Last, Last). 4201'$last'([H|T], _, Last) :- 4202 '$last'(T, H, Last). 4203 4204:- meta_predicate '$include'( , , ). 4205'$include'(_, [], []). 4206'$include'(G, [H|T0], L) :- 4207 ( call(G,H) 4208 -> L = [H|T] 4209 ; T = L 4210 ), 4211 '$include'(G, T0, T).
4218:- '$iso'((length/2)). 4219 4220length(List, Length) :- 4221 var(Length), 4222 !, 4223 '$skip_list'(Length0, List, Tail), 4224 ( Tail == [] 4225 -> Length = Length0 % +,- 4226 ; var(Tail) 4227 -> Tail \== Length, % avoid length(L,L) 4228 '$length3'(Tail, Length, Length0) % -,- 4229 ; throw(error(type_error(list, List), 4230 context(length/2, _))) 4231 ). 4232length(List, Length) :- 4233 integer(Length), 4234 Length >= 0, 4235 !, 4236 '$skip_list'(Length0, List, Tail), 4237 ( Tail == [] % proper list 4238 -> Length = Length0 4239 ; var(Tail) 4240 -> Extra is Length-Length0, 4241 '$length'(Tail, Extra) 4242 ; throw(error(type_error(list, List), 4243 context(length/2, _))) 4244 ). 4245length(_, Length) :- 4246 integer(Length), 4247 !, 4248 throw(error(domain_error(not_less_than_zero, Length), 4249 context(length/2, _))). 4250length(_, Length) :- 4251 throw(error(type_error(integer, Length), 4252 context(length/2, _))). 4253 4254'$length3'([], N, N). 4255'$length3'([_|List], N, N0) :- 4256 N1 is N0+1, 4257 '$length3'(List, N, N1). 4258 4259 4260 /******************************* 4261 * OPTION PROCESSING * 4262 *******************************/
4268'$is_options'(Map) :- 4269 is_dict(Map, _), 4270 !. 4271'$is_options'(List) :- 4272 is_list(List), 4273 ( List == [] 4274 -> true 4275 ; List = [H|_], 4276 '$is_option'(H, _, _) 4277 ). 4278 4279'$is_option'(Var, _, _) :- 4280 var(Var), !, fail. 4281'$is_option'(F, Name, Value) :- 4282 functor(F, _, 1), 4283 !, 4284 F =.. [Name,Value]. 4285'$is_option'(Name=Value, Name, Value).
4289'$option'(Opt, Options) :- 4290 is_dict(Options), 4291 !, 4292 [Opt] :< Options. 4293'$option'(Opt, Options) :- 4294 memberchk(Opt, Options).
4298'$option'(Term, Options, Default) :-
4299 arg(1, Term, Value),
4300 functor(Term, Name, 1),
4301 ( is_dict(Options)
4302 -> ( get_dict(Name, Options, GVal)
4303 -> Value = GVal
4304 ; Value = Default
4305 )
4306 ; functor(Gen, Name, 1),
4307 arg(1, Gen, GVal),
4308 ( memberchk(Gen, Options)
4309 -> Value = GVal
4310 ; Value = Default
4311 )
4312 ).
4320'$select_option'(Opt, Options, Rest) :-
4321 '$options_dict'(Options, Dict),
4322 select_dict([Opt], Dict, Rest).
4330'$merge_options'(New, Old, Merged) :-
4331 '$options_dict'(New, NewDict),
4332 '$options_dict'(Old, OldDict),
4333 put_dict(NewDict, OldDict, Merged).
4340'$options_dict'(Options, Dict) :- 4341 is_list(Options), 4342 !, 4343 '$keyed_options'(Options, Keyed), 4344 sort(1, @<, Keyed, UniqueKeyed), 4345 '$pairs_values'(UniqueKeyed, Unique), 4346 dict_create(Dict, _, Unique). 4347'$options_dict'(Dict, Dict) :- 4348 is_dict(Dict), 4349 !. 4350'$options_dict'(Options, _) :- 4351 '$domain_error'(options, Options). 4352 4353'$keyed_options'([], []). 4354'$keyed_options'([H0|T0], [H|T]) :- 4355 '$keyed_option'(H0, H), 4356 '$keyed_options'(T0, T). 4357 4358'$keyed_option'(Var, _) :- 4359 var(Var), 4360 !, 4361 '$instantiation_error'(Var). 4362'$keyed_option'(Name=Value, Name-(Name-Value)). 4363'$keyed_option'(NameValue, Name-(Name-Value)) :- 4364 compound_name_arguments(NameValue, Name, [Value]), 4365 !. 4366'$keyed_option'(Opt, _) :- 4367 '$domain_error'(option, Opt). 4368 4369 4370 /******************************* 4371 * HANDLE TRACER 'L'-COMMAND * 4372 *******************************/ 4373 4374:- public '$prolog_list_goal'/1. 4375 4376:- multifile 4377 user:prolog_list_goal/1. 4378 4379'$prolog_list_goal'(Goal) :- 4380 user:prolog_list_goal(Goal), 4381 !. 4382'$prolog_list_goal'(Goal) :- 4383 use_module(library(listing), [listing/1]), 4384 @(listing(Goal), user). 4385 4386 4387 /******************************* 4388 * HALT * 4389 *******************************/ 4390 4391:- '$iso'((halt/0)). 4392 4393halt :- 4394 '$exit_code'(Code), 4395 ( Code == 0 4396 -> true 4397 ; print_message(warning, on_error(halt(1))) 4398 ), 4399 halt(Code).
on_error
and on_warning
flags. Also used by qsave_toplevel/0.
4406'$exit_code'(Code) :-
4407 ( ( current_prolog_flag(on_error, status),
4408 statistics(errors, Count),
4409 Count > 0
4410 ; current_prolog_flag(on_warning, status),
4411 statistics(warnings, Count),
4412 Count > 0
4413 )
4414 -> Code = 1
4415 ; Code = 0
4416 ).
4425:- meta_predicate at_halt( ). 4426:- dynamic system:term_expansion/2, '$at_halt'/2. 4427:- multifile system:term_expansion/2, '$at_halt'/2. 4428 4429systemterm_expansion((:- at_halt(Goal)), 4430 system:'$at_halt'(Module:Goal, File:Line)) :- 4431 \+ current_prolog_flag(xref, true), 4432 source_location(File, Line), 4433 '$current_source_module'(Module). 4434 4435at_halt(Goal) :- 4436 asserta('$at_halt'(Goal, (-):0)). 4437 4438:- public '$run_at_halt'/0. 4439 4440'$run_at_halt' :- 4441 forall(clause('$at_halt'(Goal, Src), true, Ref), 4442 ( '$call_at_halt'(Goal, Src), 4443 erase(Ref) 4444 )). 4445 4446'$call_at_halt'(Goal, _Src) :- 4447 catch(Goal, E, true), 4448 !, 4449 ( var(E) 4450 -> true 4451 ; subsumes_term(cancel_halt(_), E) 4452 -> '$print_message'(informational, E), 4453 fail 4454 ; '$print_message'(error, E) 4455 ). 4456'$call_at_halt'(Goal, _Src) :- 4457 '$print_message'(warning, goal_failed(at_halt, Goal)).
4465cancel_halt(Reason) :-
4466 throw(cancel_halt(Reason)).
heartbeat
is
non-zero.4473:- multifile prolog:heartbeat/0. 4474 4475 4476 /******************************** 4477 * LOAD OTHER MODULES * 4478 *********************************/ 4479 4480:- meta_predicate 4481 '$load_wic_files'( ). 4482 4483'$load_wic_files'(Files) :- 4484 Files = Module:_, 4485 '$execute_directive'('$set_source_module'(OldM, Module), [], []), 4486 '$save_lex_state'(LexState, []), 4487 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4488 '$compilation_mode'(OldC, wic), 4489 consult(Files), 4490 '$execute_directive'('$set_source_module'(OldM), [], []), 4491 '$execute_directive'('$restore_lex_state'(LexState), [], []), 4492 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4500:- public '$load_additional_boot_files'/0. 4501 4502'$load_additional_boot_files' :- 4503 current_prolog_flag(argv, Argv), 4504 '$get_files_argv'(Argv, Files), 4505 ( Files \== [] 4506 -> format('Loading additional boot files~n'), 4507 '$load_wic_files'(user:Files), 4508 format('additional boot files loaded~n') 4509 ; true 4510 ). 4511 4512'$get_files_argv'([], []) :- !. 4513'$get_files_argv'(['-c'|Files], Files) :- !. 4514'$get_files_argv'([_|Rest], Files) :- 4515 '$get_files_argv'(Rest, Files). 4516 4517'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4518 source_location(File, _Line), 4519 file_directory_name(File, Dir), 4520 atom_concat(Dir, '/load.pl', LoadFile), 4521 '$load_wic_files'(system:[LoadFile]), 4522 ( current_prolog_flag(windows, true) 4523 -> atom_concat(Dir, '/menu.pl', MenuFile), 4524 '$load_wic_files'(system:[MenuFile]) 4525 ; true 4526 ), 4527 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4528 '$compilation_mode'(OldC, wic), 4529 '$execute_directive'('$set_source_module'(user), [], []), 4530 '$set_compilation_mode'(OldC) 4531 ))