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