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-2022, 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'( ).
public
also plays this role. in SWI,
public
means that the predicate can be called, even if we cannot
find a reference to it.133dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)). 134multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)). 135module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)). 136discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)). 137volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)). 138thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)). 139noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)). 140public(Spec) :- '$set_pattr'(Spec, pred, public(true)). 141non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)). 142det(Spec) :- '$set_pattr'(Spec, pred, det(true)). 143'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)). 144'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)). 145'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)). 146 147'$set_pattr'(M:Pred, How, Attr) :- 148 '$set_pattr'(Pred, M, How, Attr).
pred
or directive
.154'$set_pattr'(X, _, _, _) :- 155 var(X), 156 '$uninstantiation_error'(X). 157'$set_pattr'(as(Spec,Options), M, How, Attr0) :- 158 !, 159 '$attr_options'(Options, Attr0, Attr), 160 '$set_pattr'(Spec, M, How, Attr). 161'$set_pattr'([], _, _, _) :- !. 162'$set_pattr'([H|T], M, How, Attr) :- % ISO 163 !, 164 '$set_pattr'(H, M, How, Attr), 165 '$set_pattr'(T, M, How, Attr). 166'$set_pattr'((A,B), M, How, Attr) :- % ISO and traditional 167 !, 168 '$set_pattr'(A, M, How, Attr), 169 '$set_pattr'(B, M, How, Attr). 170'$set_pattr'(M:T, _, How, Attr) :- 171 !, 172 '$set_pattr'(T, M, How, Attr). 173'$set_pattr'(PI, M, _, []) :- 174 !, 175 '$pi_head'(M:PI, Pred), 176 '$set_table_wrappers'(Pred). 177'$set_pattr'(A, M, How, [O|OT]) :- 178 !, 179 '$set_pattr'(A, M, How, O), 180 '$set_pattr'(A, M, How, OT). 181'$set_pattr'(A, M, pred, Attr) :- 182 !, 183 Attr =.. [Name,Val], 184 '$set_pi_attr'(M:A, Name, Val). 185'$set_pattr'(A, M, directive, Attr) :- 186 !, 187 Attr =.. [Name,Val], 188 catch('$set_pi_attr'(M:A, Name, Val), 189 error(E, _), 190 print_message(error, error(E, context((Name)/1,_)))). 191 192'$set_pi_attr'(PI, Name, Val) :- 193 '$pi_head'(PI, Head), 194 '$set_predicate_attribute'(Head, Name, Val). 195 196'$attr_options'(Var, _, _) :- 197 var(Var), 198 !, 199 '$uninstantiation_error'(Var). 200'$attr_options'((A,B), Attr0, Attr) :- 201 !, 202 '$attr_options'(A, Attr0, Attr1), 203 '$attr_options'(B, Attr1, Attr). 204'$attr_options'(Opt, Attr0, Attrs) :- 205 '$must_be'(ground, Opt), 206 ( '$attr_option'(Opt, AttrX) 207 -> ( is_list(Attr0) 208 -> '$join_attrs'(AttrX, Attr0, Attrs) 209 ; '$join_attrs'(AttrX, [Attr0], Attrs) 210 ) 211 ; '$domain_error'(predicate_option, Opt) 212 ). 213 214'$join_attrs'([], Attrs, Attrs) :- 215 !. 216'$join_attrs'([H|T], Attrs0, Attrs) :- 217 !, 218 '$join_attrs'(H, Attrs0, Attrs1), 219 '$join_attrs'(T, Attrs1, Attrs). 220'$join_attrs'(Attr, Attrs, Attrs) :- 221 memberchk(Attr, Attrs), 222 !. 223'$join_attrs'(Attr, Attrs, Attrs) :- 224 Attr =.. [Name,Value], 225 Gen =.. [Name,Existing], 226 memberchk(Gen, Attrs), 227 !, 228 throw(error(conflict_error(Name, Value, Existing), _)). 229'$join_attrs'(Attr, Attrs0, Attrs) :- 230 '$append'(Attrs0, [Attr], Attrs). 231 232'$attr_option'(incremental, [incremental(true),opaque(false)]). 233'$attr_option'(monotonic, monotonic(true)). 234'$attr_option'(lazy, lazy(true)). 235'$attr_option'(opaque, [incremental(false),opaque(true)]). 236'$attr_option'(abstract(Level0), abstract(Level)) :- 237 '$table_option'(Level0, Level). 238'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :- 239 '$table_option'(Level0, Level). 240'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :- 241 '$table_option'(Level0, Level). 242'$attr_option'(max_answers(Level0), max_answers(Level)) :- 243 '$table_option'(Level0, Level). 244'$attr_option'(volatile, volatile(true)). 245'$attr_option'(multifile, multifile(true)). 246'$attr_option'(discontiguous, discontiguous(true)). 247'$attr_option'(shared, thread_local(false)). 248'$attr_option'(local, thread_local(true)). 249'$attr_option'(private, thread_local(true)). 250 251'$table_option'(Value0, _Value) :- 252 var(Value0), 253 !, 254 '$instantiation_error'(Value0). 255'$table_option'(Value0, Value) :- 256 integer(Value0), 257 Value0 >= 0, 258 !, 259 Value = Value0. 260'$table_option'(off, -1) :- 261 !. 262'$table_option'(false, -1) :- 263 !. 264'$table_option'(infinite, -1) :- 265 !. 266'$table_option'(Value, _) :- 267 '$domain_error'(nonneg_or_false, Value).
277'$pattr_directive'(dynamic(Spec), M) :- 278 '$set_pattr'(Spec, M, directive, dynamic(true)). 279'$pattr_directive'(multifile(Spec), M) :- 280 '$set_pattr'(Spec, M, directive, multifile(true)). 281'$pattr_directive'(module_transparent(Spec), M) :- 282 '$set_pattr'(Spec, M, directive, transparent(true)). 283'$pattr_directive'(discontiguous(Spec), M) :- 284 '$set_pattr'(Spec, M, directive, discontiguous(true)). 285'$pattr_directive'(volatile(Spec), M) :- 286 '$set_pattr'(Spec, M, directive, volatile(true)). 287'$pattr_directive'(thread_local(Spec), M) :- 288 '$set_pattr'(Spec, M, directive, thread_local(true)). 289'$pattr_directive'(noprofile(Spec), M) :- 290 '$set_pattr'(Spec, M, directive, noprofile(true)). 291'$pattr_directive'(public(Spec), M) :- 292 '$set_pattr'(Spec, M, directive, public(true)). 293'$pattr_directive'(det(Spec), M) :- 294 '$set_pattr'(Spec, M, directive, det(true)).
298'$pi_head'(PI, Head) :- 299 var(PI), 300 var(Head), 301 '$instantiation_error'([PI,Head]). 302'$pi_head'(M:PI, M:Head) :- 303 !, 304 '$pi_head'(PI, Head). 305'$pi_head'(Name/Arity, Head) :- 306 !, 307 '$head_name_arity'(Head, Name, Arity). 308'$pi_head'(Name//DCGArity, Head) :- 309 !, 310 ( nonvar(DCGArity) 311 -> Arity is DCGArity+2, 312 '$head_name_arity'(Head, Name, Arity) 313 ; '$head_name_arity'(Head, Name, Arity), 314 DCGArity is Arity - 2 315 ). 316'$pi_head'(PI, _) :- 317 '$type_error'(predicate_indicator, PI).
322'$head_name_arity'(Goal, Name, Arity) :- 323 ( atom(Goal) 324 -> Name = Goal, Arity = 0 325 ; compound(Goal) 326 -> compound_name_arity(Goal, Name, Arity) 327 ; var(Goal) 328 -> ( Arity == 0 329 -> ( atom(Name) 330 -> Goal = Name 331 ; Name == [] 332 -> Goal = Name 333 ; blob(Name, closure) 334 -> Goal = Name 335 ; '$type_error'(atom, Name) 336 ) 337 ; compound_name_arity(Goal, Name, Arity) 338 ) 339 ; '$type_error'(callable, Goal) 340 ). 341 342:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 343 344 345 /******************************** 346 * CALLING, CONTROL * 347 *********************************/ 348 349:- noprofile((call/1, 350 catch/3, 351 once/1, 352 ignore/1, 353 call_cleanup/2, 354 call_cleanup/3, 355 setup_call_cleanup/3, 356 setup_call_catcher_cleanup/4, 357 notrace/1)). 358 359:- meta_predicate 360 ';'( , ), 361 ','( , ), 362 @( , ), 363 call( ), 364 call( , ), 365 call( , , ), 366 call( , , , ), 367 call( , , , , ), 368 call( , , , , , ), 369 call( , , , , , , ), 370 call( , , , , , , , ), 371 not( ), 372 \+( ), 373 $( ), 374 '->'( , ), 375 '*->'( , ), 376 once( ), 377 ignore( ), 378 catch( , , ), 379 reset( , , ), 380 setup_call_cleanup( , , ), 381 setup_call_catcher_cleanup( , , , ), 382 call_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 !.
677setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :- 678 sig_atomic(Setup), 679 '$call_cleanup'. 680 681setup_call_cleanup(Setup, Goal, Cleanup) :- 682 setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup). 683 684call_cleanup(Goal, Cleanup) :- 685 setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup). 686 687call_cleanup(Goal, Catcher, Cleanup) :- 688 setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup). 689 690 /******************************* 691 * INITIALIZATION * 692 *******************************/ 693 694:- meta_predicate 695 initialization( , ). 696 697:- multifile '$init_goal'/3. 698:- dynamic '$init_goal'/3.
-g goal
goals.Note that all goals are executed when a program is restored.
724initialization(Goal, When) :- 725 '$must_be'(oneof(atom, initialization_type, 726 [ now, 727 after_load, 728 restore, 729 restore_state, 730 prepare_state, 731 program, 732 main 733 ]), When), 734 '$initialization_context'(Source, Ctx), 735 '$initialization'(When, Goal, Source, Ctx). 736 737'$initialization'(now, Goal, _Source, Ctx) :- 738 '$run_init_goal'(Goal, Ctx), 739 '$compile_init_goal'(-, Goal, Ctx). 740'$initialization'(after_load, Goal, Source, Ctx) :- 741 ( Source \== (-) 742 -> '$compile_init_goal'(Source, Goal, Ctx) 743 ; throw(error(context_error(nodirective, 744 initialization(Goal, after_load)), 745 _)) 746 ). 747'$initialization'(restore, Goal, Source, Ctx) :- % deprecated 748 '$initialization'(restore_state, Goal, Source, Ctx). 749'$initialization'(restore_state, Goal, _Source, Ctx) :- 750 ( \+ current_prolog_flag(sandboxed_load, true) 751 -> '$compile_init_goal'(-, Goal, Ctx) 752 ; '$permission_error'(register, initialization(restore), Goal) 753 ). 754'$initialization'(prepare_state, Goal, _Source, Ctx) :- 755 ( \+ current_prolog_flag(sandboxed_load, true) 756 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx) 757 ; '$permission_error'(register, initialization(restore), Goal) 758 ). 759'$initialization'(program, Goal, _Source, Ctx) :- 760 ( \+ current_prolog_flag(sandboxed_load, true) 761 -> '$compile_init_goal'(when(program), Goal, Ctx) 762 ; '$permission_error'(register, initialization(restore), Goal) 763 ). 764'$initialization'(main, Goal, _Source, Ctx) :- 765 ( \+ current_prolog_flag(sandboxed_load, true) 766 -> '$compile_init_goal'(when(main), Goal, Ctx) 767 ; '$permission_error'(register, initialization(restore), Goal) 768 ). 769 770 771'$compile_init_goal'(Source, Goal, Ctx) :- 772 atom(Source), 773 Source \== (-), 774 !, 775 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx), 776 _Layout, Source, Ctx). 777'$compile_init_goal'(Source, Goal, Ctx) :- 778 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.790'$run_initialization'(_, loaded, _) :- !. 791'$run_initialization'(File, _Action, Options) :- 792 '$run_initialization'(File, Options). 793 794'$run_initialization'(File, Options) :- 795 setup_call_cleanup( 796 '$start_run_initialization'(Options, Restore), 797 '$run_initialization_2'(File), 798 '$end_run_initialization'(Restore)). 799 800'$start_run_initialization'(Options, OldSandBoxed) :- 801 '$push_input_context'(initialization), 802 '$set_sandboxed_load'(Options, OldSandBoxed). 803'$end_run_initialization'(OldSandBoxed) :- 804 set_prolog_flag(sandboxed_load, OldSandBoxed), 805 '$pop_input_context'. 806 807'$run_initialization_2'(File) :- 808 ( '$init_goal'(File, Goal, Ctx), 809 File \= when(_), 810 '$run_init_goal'(Goal, Ctx), 811 fail 812 ; true 813 ). 814 815'$run_init_goal'(Goal, Ctx) :- 816 ( catch_with_backtrace('$run_init_goal'(Goal), E, 817 '$initialization_error'(E, Goal, Ctx)) 818 -> true 819 ; '$initialization_failure'(Goal, Ctx) 820 ). 821 822:- multifile prolog:sandbox_allowed_goal/1. 823 824'$run_init_goal'(Goal) :- 825 current_prolog_flag(sandboxed_load, false), 826 !, 827 call(Goal). 828'$run_init_goal'(Goal) :- 829 prolog:sandbox_allowed_goal(Goal), 830 call(Goal). 831 832'$initialization_context'(Source, Ctx) :- 833 ( source_location(File, Line) 834 -> Ctx = File:Line, 835 '$input_context'(Context), 836 '$top_file'(Context, File, Source) 837 ; Ctx = (-), 838 File = (-) 839 ). 840 841'$top_file'([input(include, F1, _, _)|T], _, F) :- 842 !, 843 '$top_file'(T, F1, F). 844'$top_file'(_, F, F). 845 846 847'$initialization_error'(E, Goal, Ctx) :- 848 print_message(error, initialization_error(Goal, E, Ctx)). 849 850'$initialization_failure'(Goal, Ctx) :- 851 print_message(warning, initialization_failure(Goal, Ctx)).
859:- public '$clear_source_admin'/1. 860 861'$clear_source_admin'(File) :- 862 retractall('$init_goal'(_, _, File:_)), 863 retractall('$load_context_module'(File, _, _)), 864 retractall('$resolved_source_path_db'(_, _, File)). 865 866 867 /******************************* 868 * STREAM * 869 *******************************/ 870 871:- '$iso'(stream_property/2). 872stream_property(Stream, Property) :- 873 nonvar(Stream), 874 nonvar(Property), 875 !, 876 '$stream_property'(Stream, Property). 877stream_property(Stream, Property) :- 878 nonvar(Stream), 879 !, 880 '$stream_properties'(Stream, Properties), 881 '$member'(Property, Properties). 882stream_property(Stream, Property) :- 883 nonvar(Property), 884 !, 885 ( Property = alias(Alias), 886 atom(Alias) 887 -> '$alias_stream'(Alias, Stream) 888 ; '$streams_properties'(Property, Pairs), 889 '$member'(Stream-Property, Pairs) 890 ). 891stream_property(Stream, Property) :- 892 '$streams_properties'(Property, Pairs), 893 '$member'(Stream-Properties, Pairs), 894 '$member'(Property, Properties). 895 896 897 /******************************** 898 * MODULES * 899 *********************************/ 900 901% '$prefix_module'(+Module, +Context, +Term, -Prefixed) 902% Tags `Term' with `Module:' if `Module' is not the context module. 903 904'$prefix_module'(Module, Module, Head, Head) :- !. 905'$prefix_module'(Module, _, Head, Module:Head).
911default_module(Me, Super) :- 912 ( atom(Me) 913 -> ( var(Super) 914 -> '$default_module'(Me, Super) 915 ; '$default_module'(Me, Super), ! 916 ) 917 ; '$type_error'(module, Me) 918 ). 919 920'$default_module'(Me, Me). 921'$default_module'(Me, Super) :- 922 import_module(Me, S), 923 '$default_module'(S, Super). 924 925 926 /******************************** 927 * TRACE AND EXCEPTIONS * 928 *********************************/ 929 930:- dynamic user:exception/3. 931:- multifile user:exception/3. 932:- '$hide'(user:exception/3).
941:- public 942 '$undefined_procedure'/4. 943 944'$undefined_procedure'(Module, Name, Arity, Action) :- 945 '$prefix_module'(Module, user, Name/Arity, Pred), 946 user:exception(undefined_predicate, Pred, Action0), 947 !, 948 Action = Action0. 949'$undefined_procedure'(Module, Name, Arity, Action) :- 950 \+ current_prolog_flag(autoload, false), 951 '$autoload'(Module:Name/Arity), 952 !, 953 Action = retry. 954'$undefined_procedure'(_, _, _, error).
966'$loading'(Library) :- 967 current_prolog_flag(threads, true), 968 ( '$loading_file'(Library, _Queue, _LoadThread) 969 -> true 970 ; '$loading_file'(FullFile, _Queue, _LoadThread), 971 file_name_extension(Library, _, FullFile) 972 -> true 973 ). 974 975% handle debugger 'w', 'p' and <N> depth options. 976 977'$set_debugger_write_options'(write) :- 978 !, 979 create_prolog_flag(debugger_write_options, 980 [ quoted(true), 981 attributes(dots), 982 spacing(next_argument) 983 ], []). 984'$set_debugger_write_options'(print) :- 985 !, 986 create_prolog_flag(debugger_write_options, 987 [ quoted(true), 988 portray(true), 989 max_depth(10), 990 attributes(portray), 991 spacing(next_argument) 992 ], []). 993'$set_debugger_write_options'(Depth) :- 994 current_prolog_flag(debugger_write_options, Options0), 995 ( '$select'(max_depth(_), Options0, Options) 996 -> true 997 ; Options = Options0 998 ), 999 create_prolog_flag(debugger_write_options, 1000 [max_depth(Depth)|Options], []). 1001 1002 1003 /******************************** 1004 * SYSTEM MESSAGES * 1005 *********************************/
query
channel. This
predicate may be hooked using confirm/2, which must return
a boolean.1014:- multifile 1015 prolog:confirm/2. 1016 1017'$confirm'(Spec) :- 1018 prolog:confirm(Spec, Result), 1019 !, 1020 Result == true. 1021'$confirm'(Spec) :- 1022 print_message(query, Spec), 1023 between(0, 5, _), 1024 get_single_char(Answer), 1025 ( '$in_reply'(Answer, 'yYjJ \n') 1026 -> !, 1027 print_message(query, if_tty([yes-[]])) 1028 ; '$in_reply'(Answer, 'nN') 1029 -> !, 1030 print_message(query, if_tty([no-[]])), 1031 fail 1032 ; print_message(help, query(confirm)), 1033 fail 1034 ). 1035 1036'$in_reply'(Code, Atom) :- 1037 char_code(Char, Code), 1038 sub_atom(Atom, _, _, _, Char), 1039 !. 1040 1041:- dynamic 1042 user:portray/1. 1043:- multifile 1044 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 1058user(file_search_path(library, Dir) :- 1059 library_directory(Dir)). 1060user:file_search_path(swi, Home) :- 1061 current_prolog_flag(home, Home). 1062user:file_search_path(swi, Home) :- 1063 current_prolog_flag(shared_home, Home). 1064user:file_search_path(library, app_config(lib)). 1065user:file_search_path(library, swi(library)). 1066user:file_search_path(library, swi(library/clp)). 1067user:file_search_path(foreign, swi(ArchLib)) :- 1068 current_prolog_flag(apple_universal_binary, true), 1069 ArchLib = 'lib/fat-darwin'. 1070user:file_search_path(foreign, swi(ArchLib)) :- 1071 \+ current_prolog_flag(windows, true), 1072 current_prolog_flag(arch, Arch), 1073 atom_concat('lib/', Arch, ArchLib). 1074user:file_search_path(foreign, swi(ArchLib)) :- 1075 current_prolog_flag(msys2, true), 1076 current_prolog_flag(arch, Arch), 1077 atomic_list_concat([lib, Arch], /, ArchLib). 1078user:file_search_path(foreign, swi(SoLib)) :- 1079 current_prolog_flag(msys2, true), 1080 current_prolog_flag(arch, Arch), 1081 atomic_list_concat([bin, Arch], /, SoLib). 1082user:file_search_path(foreign, swi(SoLib)) :- 1083 ( current_prolog_flag(windows, true) 1084 -> SoLib = bin 1085 ; SoLib = lib 1086 ). 1087user:file_search_path(path, Dir) :- 1088 getenv('PATH', Path), 1089 ( current_prolog_flag(windows, true) 1090 -> atomic_list_concat(Dirs, (;), Path) 1091 ; atomic_list_concat(Dirs, :, Path) 1092 ), 1093 '$member'(Dir, Dirs). 1094user:file_search_path(user_app_data, Dir) :- 1095 '$xdg_prolog_directory'(data, Dir). 1096user:file_search_path(common_app_data, Dir) :- 1097 '$xdg_prolog_directory'(common_data, Dir). 1098user:file_search_path(user_app_config, Dir) :- 1099 '$xdg_prolog_directory'(config, Dir). 1100user:file_search_path(common_app_config, Dir) :- 1101 '$xdg_prolog_directory'(common_config, Dir). 1102user:file_search_path(app_data, user_app_data('.')). 1103user:file_search_path(app_data, common_app_data('.')). 1104user:file_search_path(app_config, user_app_config('.')). 1105user:file_search_path(app_config, common_app_config('.')). 1106% backward compatibility 1107user:file_search_path(app_preferences, user_app_config('.')). 1108user:file_search_path(user_profile, app_preferences('.')). 1109 1110'$xdg_prolog_directory'(Which, Dir) :- 1111 '$xdg_directory'(Which, XDGDir), 1112 '$make_config_dir'(XDGDir), 1113 '$ensure_slash'(XDGDir, XDGDirS), 1114 atom_concat(XDGDirS, 'swi-prolog', Dir), 1115 '$make_config_dir'(Dir). 1116 1117% config 1118'$xdg_directory'(config, Home) :- 1119 current_prolog_flag(windows, true), 1120 catch(win_folder(appdata, Home), _, fail), 1121 !. 1122'$xdg_directory'(config, Home) :- 1123 getenv('XDG_CONFIG_HOME', Home). 1124'$xdg_directory'(config, Home) :- 1125 expand_file_name('~/.config', [Home]). 1126% data 1127'$xdg_directory'(data, Home) :- 1128 current_prolog_flag(windows, true), 1129 catch(win_folder(local_appdata, Home), _, fail), 1130 !. 1131'$xdg_directory'(data, Home) :- 1132 getenv('XDG_DATA_HOME', Home). 1133'$xdg_directory'(data, Home) :- 1134 expand_file_name('~/.local', [Local]), 1135 '$make_config_dir'(Local), 1136 atom_concat(Local, '/share', Home), 1137 '$make_config_dir'(Home). 1138% common data 1139'$xdg_directory'(common_data, Dir) :- 1140 current_prolog_flag(windows, true), 1141 catch(win_folder(common_appdata, Dir), _, fail), 1142 !. 1143'$xdg_directory'(common_data, Dir) :- 1144 '$existing_dir_from_env_path'('XDG_DATA_DIRS', 1145 [ '/usr/local/share', 1146 '/usr/share' 1147 ], 1148 Dir). 1149% common config 1150'$xdg_directory'(common_config, Dir) :- 1151 current_prolog_flag(windows, true), 1152 catch(win_folder(common_appdata, Dir), _, fail), 1153 !. 1154'$xdg_directory'(common_config, Dir) :- 1155 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir). 1156 1157'$existing_dir_from_env_path'(Env, Defaults, Dir) :- 1158 ( getenv(Env, Path) 1159 -> '$path_sep'(Sep), 1160 atomic_list_concat(Dirs, Sep, Path) 1161 ; Dirs = Defaults 1162 ), 1163 '$member'(Dir, Dirs), 1164 Dir \== '', 1165 exists_directory(Dir). 1166 1167'$path_sep'(Char) :- 1168 ( current_prolog_flag(windows, true) 1169 -> Char = ';' 1170 ; Char = ':' 1171 ). 1172 1173'$make_config_dir'(Dir) :- 1174 exists_directory(Dir), 1175 !. 1176'$make_config_dir'(Dir) :- 1177 nb_current('$create_search_directories', true), 1178 file_directory_name(Dir, Parent), 1179 '$my_file'(Parent), 1180 catch(make_directory(Dir), _, fail). 1181 1182'$ensure_slash'(Dir, DirS) :- 1183 ( sub_atom(Dir, _, _, 0, /) 1184 -> DirS = Dir 1185 ; atom_concat(Dir, /, DirS) 1186 ).
1191'$expand_file_search_path'(Spec, Expanded, Cond) :- 1192 '$option'(access(Access), Cond), 1193 memberchk(Access, [write,append]), 1194 !, 1195 setup_call_cleanup( 1196 nb_setval('$create_search_directories', true), 1197 expand_file_search_path(Spec, Expanded), 1198 nb_delete('$create_search_directories')). 1199'$expand_file_search_path'(Spec, Expanded, _Cond) :- 1200 expand_file_search_path(Spec, Expanded).
1208expand_file_search_path(Spec, Expanded) :- 1209 catch('$expand_file_search_path'(Spec, Expanded, 0, []), 1210 loop(Used), 1211 throw(error(loop_error(Spec), file_search(Used)))). 1212 1213'$expand_file_search_path'(Spec, Expanded, N, Used) :- 1214 functor(Spec, Alias, 1), 1215 !, 1216 user:file_search_path(Alias, Exp0), 1217 NN is N + 1, 1218 ( NN > 16 1219 -> throw(loop(Used)) 1220 ; true 1221 ), 1222 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]), 1223 arg(1, Spec, Segments), 1224 '$segments_to_atom'(Segments, File), 1225 '$make_path'(Exp1, File, Expanded). 1226'$expand_file_search_path'(Spec, Path, _, _) :- 1227 '$segments_to_atom'(Spec, Path). 1228 1229'$make_path'(Dir, '.', Path) :- 1230 !, 1231 Path = Dir. 1232'$make_path'(Dir, File, Path) :- 1233 sub_atom(Dir, _, _, 0, /), 1234 !, 1235 atom_concat(Dir, File, Path). 1236'$make_path'(Dir, File, Path) :- 1237 atomic_list_concat([Dir, /, File], Path). 1238 1239 1240 /******************************** 1241 * FILE CHECKING * 1242 *********************************/
1253absolute_file_name(Spec, Options, Path) :- 1254 '$is_options'(Options), 1255 \+ '$is_options'(Path), 1256 !, 1257 absolute_file_name(Spec, Path, Options). 1258absolute_file_name(Spec, Path, Options) :- 1259 '$must_be'(options, Options), 1260 % get the valid extensions 1261 ( '$select_option'(extensions(Exts), Options, Options1) 1262 -> '$must_be'(list, Exts) 1263 ; '$option'(file_type(Type), Options) 1264 -> '$must_be'(atom, Type), 1265 '$file_type_extensions'(Type, Exts), 1266 Options1 = Options 1267 ; Options1 = Options, 1268 Exts = [''] 1269 ), 1270 '$canonicalise_extensions'(Exts, Extensions), 1271 % unless specified otherwise, ask regular file 1272 ( ( nonvar(Type) 1273 ; '$option'(access(none), Options, none) 1274 ) 1275 -> Options2 = Options1 1276 ; '$merge_options'(_{file_type:regular}, Options1, Options2) 1277 ), 1278 % Det or nondet? 1279 ( '$select_option'(solutions(Sols), Options2, Options3) 1280 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols) 1281 ; Sols = first, 1282 Options3 = Options2 1283 ), 1284 % Errors or not? 1285 ( '$select_option'(file_errors(FileErrors), Options3, Options4) 1286 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors) 1287 ; FileErrors = error, 1288 Options4 = Options3 1289 ), 1290 % Expand shell patterns? 1291 ( atomic(Spec), 1292 '$select_option'(expand(Expand), Options4, Options5), 1293 '$must_be'(boolean, Expand) 1294 -> expand_file_name(Spec, List), 1295 '$member'(Spec1, List) 1296 ; Spec1 = Spec, 1297 Options5 = Options4 1298 ), 1299 % Search for files 1300 ( Sols == first 1301 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path) 1302 -> ! % also kill choice point of expand_file_name/2 1303 ; ( FileErrors == fail 1304 -> fail 1305 ; '$current_module'('$bags', _File), 1306 findall(P, 1307 '$chk_file'(Spec1, Extensions, [access(exist)], 1308 false, P), 1309 Candidates), 1310 '$abs_file_error'(Spec, Candidates, Options5) 1311 ) 1312 ) 1313 ; '$chk_file'(Spec1, Extensions, Options5, false, Path) 1314 ). 1315 1316'$abs_file_error'(Spec, Candidates, Conditions) :- 1317 '$member'(F, Candidates), 1318 '$member'(C, Conditions), 1319 '$file_condition'(C), 1320 '$file_error'(C, Spec, F, E, Comment), 1321 !, 1322 throw(error(E, context(_, Comment))). 1323'$abs_file_error'(Spec, _, _) :- 1324 '$existence_error'(source_sink, Spec). 1325 1326'$file_error'(file_type(directory), Spec, File, Error, Comment) :- 1327 \+ exists_directory(File), 1328 !, 1329 Error = existence_error(directory, Spec), 1330 Comment = not_a_directory(File). 1331'$file_error'(file_type(_), Spec, File, Error, Comment) :- 1332 exists_directory(File), 1333 !, 1334 Error = existence_error(file, Spec), 1335 Comment = directory(File). 1336'$file_error'(access(OneOrList), Spec, File, Error, _) :- 1337 '$one_or_member'(Access, OneOrList), 1338 \+ access_file(File, Access), 1339 Error = permission_error(Access, source_sink, Spec). 1340 1341'$one_or_member'(Elem, List) :- 1342 is_list(List), 1343 !, 1344 '$member'(Elem, List). 1345'$one_or_member'(Elem, Elem). 1346 1347 1348'$file_type_extensions'(source, Exts) :- % SICStus 3.9 compatibility 1349 !, 1350 '$file_type_extensions'(prolog, Exts). 1351'$file_type_extensions'(Type, Exts) :- 1352 '$current_module'('$bags', _File), 1353 !, 1354 findall(Ext, user:prolog_file_type(Ext, Type), Exts0), 1355 ( Exts0 == [], 1356 \+ '$ft_no_ext'(Type) 1357 -> '$domain_error'(file_type, Type) 1358 ; true 1359 ), 1360 '$append'(Exts0, [''], Exts). 1361'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ... 1362 1363'$ft_no_ext'(txt). 1364'$ft_no_ext'(executable). 1365'$ft_no_ext'(directory). 1366'$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.
1379:- multifile(user:prolog_file_type/2). 1380:- dynamic(user:prolog_file_type/2). 1381 1382userprolog_file_type(pl, prolog). 1383userprolog_file_type(prolog, prolog). 1384userprolog_file_type(qlf, prolog). 1385userprolog_file_type(qlf, qlf). 1386userprolog_file_type(Ext, executable) :- 1387 current_prolog_flag(shared_object_extension, Ext). 1388userprolog_file_type(dylib, executable) :- 1389 current_prolog_flag(apple, true).
1396'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :- 1397 \+ ground(Spec), 1398 !, 1399 '$instantiation_error'(Spec). 1400'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :- 1401 compound(Spec), 1402 functor(Spec, _, 1), 1403 !, 1404 '$relative_to'(Cond, cwd, CWD), 1405 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName). 1406'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- % allow a/b/... 1407 \+ atomic(Segments), 1408 !, 1409 '$segments_to_atom'(Segments, Atom), 1410 '$chk_file'(Atom, Ext, Cond, Cache, FullName). 1411'$chk_file'(File, Exts, Cond, _, FullName) :- 1412 is_absolute_file_name(File), 1413 !, 1414 '$extend_file'(File, Exts, Extended), 1415 '$file_conditions'(Cond, Extended), 1416 '$absolute_file_name'(Extended, FullName). 1417'$chk_file'(File, Exts, Cond, _, FullName) :- 1418 '$relative_to'(Cond, source, Dir), 1419 atomic_list_concat([Dir, /, File], AbsFile), 1420 '$extend_file'(AbsFile, Exts, Extended), 1421 '$file_conditions'(Cond, Extended), 1422 !, 1423 '$absolute_file_name'(Extended, FullName). 1424'$chk_file'(File, Exts, Cond, _, FullName) :- 1425 '$extend_file'(File, Exts, Extended), 1426 '$file_conditions'(Cond, Extended), 1427 '$absolute_file_name'(Extended, FullName). 1428 1429'$segments_to_atom'(Atom, Atom) :- 1430 atomic(Atom), 1431 !. 1432'$segments_to_atom'(Segments, Atom) :- 1433 '$segments_to_list'(Segments, List, []), 1434 !, 1435 atomic_list_concat(List, /, Atom). 1436 1437'$segments_to_list'(A/B, H, T) :- 1438 '$segments_to_list'(A, H, T0), 1439 '$segments_to_list'(B, T0, T). 1440'$segments_to_list'(A, [A|T], T) :- 1441 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1451'$relative_to'(Conditions, Default, Dir) :-
1452 ( '$option'(relative_to(FileOrDir), Conditions)
1453 *-> ( exists_directory(FileOrDir)
1454 -> Dir = FileOrDir
1455 ; atom_concat(Dir, /, FileOrDir)
1456 -> true
1457 ; file_directory_name(FileOrDir, Dir)
1458 )
1459 ; Default == cwd
1460 -> '$cwd'(Dir)
1461 ; Default == source
1462 -> source_location(ContextFile, _Line),
1463 file_directory_name(ContextFile, Dir)
1464 ).
1469:- dynamic 1470 '$search_path_file_cache'/3, % SHA1, Time, Path 1471 '$search_path_gc_time'/1. % Time 1472:- volatile 1473 '$search_path_file_cache'/3, 1474 '$search_path_gc_time'/1. 1475 1476:- create_prolog_flag(file_search_cache_time, 10, []). 1477 1478'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1479 !, 1480 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1481 current_prolog_flag(emulated_dialect, Dialect), 1482 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1483 variant_sha1(Spec+Cache, SHA1), 1484 get_time(Now), 1485 current_prolog_flag(file_search_cache_time, TimeOut), 1486 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1487 CachedTime > Now - TimeOut, 1488 '$file_conditions'(Cond, FullFile) 1489 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1490 ; '$member'(Expanded, Expansions), 1491 '$extend_file'(Expanded, Exts, LibFile), 1492 ( '$file_conditions'(Cond, LibFile), 1493 '$absolute_file_name'(LibFile, FullFile), 1494 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1495 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1496 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1497 fail 1498 ) 1499 ). 1500'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1501 '$expand_file_search_path'(Spec, Expanded, Cond), 1502 '$extend_file'(Expanded, Exts, LibFile), 1503 '$file_conditions'(Cond, LibFile), 1504 '$absolute_file_name'(LibFile, FullFile). 1505 1506'$cache_file_found'(_, _, TimeOut, _) :- 1507 TimeOut =:= 0, 1508 !. 1509'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1510 '$search_path_file_cache'(SHA1, Saved, FullFile), 1511 !, 1512 ( Now - Saved < TimeOut/2 1513 -> true 1514 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1515 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1516 ). 1517'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1518 'gc_file_search_cache'(TimeOut), 1519 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1520 1521'gc_file_search_cache'(TimeOut) :- 1522 get_time(Now), 1523 '$search_path_gc_time'(Last), 1524 Now-Last < TimeOut/2, 1525 !. 1526'gc_file_search_cache'(TimeOut) :- 1527 get_time(Now), 1528 retractall('$search_path_gc_time'(_)), 1529 assertz('$search_path_gc_time'(Now)), 1530 Before is Now - TimeOut, 1531 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1532 Cached < Before, 1533 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1534 fail 1535 ; true 1536 ). 1537 1538 1539'$search_message'(Term) :- 1540 current_prolog_flag(verbose_file_search, true), 1541 !, 1542 print_message(informational, Term). 1543'$search_message'(_).
1550'$file_conditions'(List, File) :- 1551 is_list(List), 1552 !, 1553 \+ ( '$member'(C, List), 1554 '$file_condition'(C), 1555 \+ '$file_condition'(C, File) 1556 ). 1557'$file_conditions'(Map, File) :- 1558 \+ ( get_dict(Key, Map, Value), 1559 C =.. [Key,Value], 1560 '$file_condition'(C), 1561 \+ '$file_condition'(C, File) 1562 ). 1563 1564'$file_condition'(file_type(directory), File) :- 1565 !, 1566 exists_directory(File). 1567'$file_condition'(file_type(_), File) :- 1568 !, 1569 \+ exists_directory(File). 1570'$file_condition'(access(Accesses), File) :- 1571 !, 1572 \+ ( '$one_or_member'(Access, Accesses), 1573 \+ access_file(File, Access) 1574 ). 1575 1576'$file_condition'(exists). 1577'$file_condition'(file_type(_)). 1578'$file_condition'(access(_)). 1579 1580'$extend_file'(File, Exts, FileEx) :- 1581 '$ensure_extensions'(Exts, File, Fs), 1582 '$list_to_set'(Fs, FsSet), 1583 '$member'(FileEx, FsSet). 1584 1585'$ensure_extensions'([], _, []). 1586'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1587 file_name_extension(F, E, FE), 1588 '$ensure_extensions'(E0, F, E1).
1595'$list_to_set'(List, Set) :- 1596 '$number_list'(List, 1, Numbered), 1597 sort(1, @=<, Numbered, ONum), 1598 '$remove_dup_keys'(ONum, NumSet), 1599 sort(2, @=<, NumSet, ONumSet), 1600 '$pairs_keys'(ONumSet, Set). 1601 1602'$number_list'([], _, []). 1603'$number_list'([H|T0], N, [H-N|T]) :- 1604 N1 is N+1, 1605 '$number_list'(T0, N1, T). 1606 1607'$remove_dup_keys'([], []). 1608'$remove_dup_keys'([H|T0], [H|T]) :- 1609 H = V-_, 1610 '$remove_same_key'(T0, V, T1), 1611 '$remove_dup_keys'(T1, T). 1612 1613'$remove_same_key'([V1-_|T0], V, T) :- 1614 V1 == V, 1615 !, 1616 '$remove_same_key'(T0, V, T). 1617'$remove_same_key'(L, _, L). 1618 1619'$pairs_keys'([], []). 1620'$pairs_keys'([K-_|T0], [K|T]) :- 1621 '$pairs_keys'(T0, T). 1622 1623 1624/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1625Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1626the Quintus compatibility requests `pl'. This layer canonicalises all 1627extensions to .ext 1628- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1629 1630'$canonicalise_extensions'([], []) :- !. 1631'$canonicalise_extensions'([H|T], [CH|CT]) :- 1632 !, 1633 '$must_be'(atom, H), 1634 '$canonicalise_extension'(H, CH), 1635 '$canonicalise_extensions'(T, CT). 1636'$canonicalise_extensions'(E, [CE]) :- 1637 '$canonicalise_extension'(E, CE). 1638 1639'$canonicalise_extension'('', '') :- !. 1640'$canonicalise_extension'(DotAtom, DotAtom) :- 1641 sub_atom(DotAtom, 0, _, _, '.'), 1642 !. 1643'$canonicalise_extension'(Atom, DotAtom) :- 1644 atom_concat('.', Atom, DotAtom). 1645 1646 1647 /******************************** 1648 * CONSULT * 1649 *********************************/ 1650 1651:- dynamic 1652 user:library_directory/1, 1653 user:prolog_load_file/2. 1654:- multifile 1655 user:library_directory/1, 1656 user:prolog_load_file/2. 1657 1658:- prompt(_, '|: '). 1659 1660:- thread_local 1661 '$compilation_mode_store'/1, % database, wic, qlf 1662 '$directive_mode_store'/1. % database, wic, qlf 1663:- volatile 1664 '$compilation_mode_store'/1, 1665 '$directive_mode_store'/1. 1666 1667'$compilation_mode'(Mode) :- 1668 ( '$compilation_mode_store'(Val) 1669 -> Mode = Val 1670 ; Mode = database 1671 ). 1672 1673'$set_compilation_mode'(Mode) :- 1674 retractall('$compilation_mode_store'(_)), 1675 assertz('$compilation_mode_store'(Mode)). 1676 1677'$compilation_mode'(Old, New) :- 1678 '$compilation_mode'(Old), 1679 ( New == Old 1680 -> true 1681 ; '$set_compilation_mode'(New) 1682 ). 1683 1684'$directive_mode'(Mode) :- 1685 ( '$directive_mode_store'(Val) 1686 -> Mode = Val 1687 ; Mode = database 1688 ). 1689 1690'$directive_mode'(Old, New) :- 1691 '$directive_mode'(Old), 1692 ( New == Old 1693 -> true 1694 ; '$set_directive_mode'(New) 1695 ). 1696 1697'$set_directive_mode'(Mode) :- 1698 retractall('$directive_mode_store'(_)), 1699 assertz('$directive_mode_store'(Mode)).
1707'$compilation_level'(Level) :- 1708 '$input_context'(Stack), 1709 '$compilation_level'(Stack, Level). 1710 1711'$compilation_level'([], 0). 1712'$compilation_level'([Input|T], Level) :- 1713 ( arg(1, Input, see) 1714 -> '$compilation_level'(T, Level) 1715 ; '$compilation_level'(T, Level0), 1716 Level is Level0+1 1717 ).
1725compiling :- 1726 \+ ( '$compilation_mode'(database), 1727 '$directive_mode'(database) 1728 ). 1729 1730:- meta_predicate 1731 '$ifcompiling'( ). 1732 1733'$ifcompiling'(G) :- 1734 ( '$compilation_mode'(database) 1735 -> true 1736 ; call(G) 1737 ). 1738 1739 /******************************** 1740 * READ SOURCE * 1741 *********************************/
1745'$load_msg_level'(Action, Nesting, Start, Done) :- 1746 '$update_autoload_level'([], 0), 1747 !, 1748 current_prolog_flag(verbose_load, Type0), 1749 '$load_msg_compat'(Type0, Type), 1750 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1751 -> true 1752 ). 1753'$load_msg_level'(_, _, silent, silent). 1754 1755'$load_msg_compat'(true, normal) :- !. 1756'$load_msg_compat'(false, silent) :- !. 1757'$load_msg_compat'(X, X). 1758 1759'$load_msg_level'(load_file, _, full, informational, informational). 1760'$load_msg_level'(include_file, _, full, informational, informational). 1761'$load_msg_level'(load_file, _, normal, silent, informational). 1762'$load_msg_level'(include_file, _, normal, silent, silent). 1763'$load_msg_level'(load_file, 0, brief, silent, informational). 1764'$load_msg_level'(load_file, _, brief, silent, silent). 1765'$load_msg_level'(include_file, _, brief, silent, silent). 1766'$load_msg_level'(load_file, _, silent, silent, silent). 1767'$load_msg_level'(include_file, _, silent, silent, silent).
1790'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1791 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1792 ( Term == end_of_file 1793 -> !, fail 1794 ; Term \== begin_of_file 1795 ). 1796 1797'$source_term'(Input, _,_,_,_,_,_,_) :- 1798 \+ ground(Input), 1799 !, 1800 '$instantiation_error'(Input). 1801'$source_term'(stream(Id, In, Opts), 1802 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1803 !, 1804 '$record_included'(Parents, Id, Id, 0.0, Message), 1805 setup_call_cleanup( 1806 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1807 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1808 [Id|Parents], Options), 1809 '$close_source'(State, Message)). 1810'$source_term'(File, 1811 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1812 absolute_file_name(File, Path, 1813 [ file_type(prolog), 1814 access(read) 1815 ]), 1816 time_file(Path, Time), 1817 '$record_included'(Parents, File, Path, Time, Message), 1818 setup_call_cleanup( 1819 '$open_source'(Path, In, State, Parents, Options), 1820 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1821 [Path|Parents], Options), 1822 '$close_source'(State, Message)). 1823 1824:- thread_local 1825 '$load_input'/2. 1826:- volatile 1827 '$load_input'/2. 1828 1829'$open_source'(stream(Id, In, Opts), In, 1830 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1831 !, 1832 '$context_type'(Parents, ContextType), 1833 '$push_input_context'(ContextType), 1834 '$prepare_load_stream'(In, Id, StreamState), 1835 asserta('$load_input'(stream(Id), In), Ref). 1836'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1837 '$context_type'(Parents, ContextType), 1838 '$push_input_context'(ContextType), 1839 '$open_source'(Path, In, Options), 1840 '$set_encoding'(In, Options), 1841 asserta('$load_input'(Path, In), Ref). 1842 1843'$context_type'([], load_file) :- !. 1844'$context_type'(_, include). 1845 1846:- multifile prolog:open_source_hook/3. 1847 1848'$open_source'(Path, In, Options) :- 1849 prolog:open_source_hook(Path, In, Options), 1850 !. 1851'$open_source'(Path, In, _Options) :- 1852 open(Path, read, In). 1853 1854'$close_source'(close(In, _Id, Ref), Message) :- 1855 erase(Ref), 1856 call_cleanup( 1857 close(In), 1858 '$pop_input_context'), 1859 '$close_message'(Message). 1860'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1861 erase(Ref), 1862 call_cleanup( 1863 '$restore_load_stream'(In, StreamState, Opts), 1864 '$pop_input_context'), 1865 '$close_message'(Message). 1866 1867'$close_message'(message(Level, Msg)) :- 1868 !, 1869 '$print_message'(Level, Msg). 1870'$close_message'(_).
1882'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1883 Parents \= [_,_|_], 1884 ( '$load_input'(_, Input) 1885 -> stream_property(Input, file_name(File)) 1886 ), 1887 '$set_source_location'(File, 0), 1888 '$expanded_term'(In, 1889 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1890 Stream, Parents, Options). 1891'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1892 '$skip_script_line'(In, Options), 1893 '$read_clause_options'(Options, ReadOptions), 1894 '$repeat_and_read_error_mode'(ErrorMode), 1895 read_clause(In, Raw, 1896 [ syntax_errors(ErrorMode), 1897 variable_names(Bindings), 1898 term_position(Pos), 1899 subterm_positions(RawLayout) 1900 | ReadOptions 1901 ]), 1902 b_setval('$term_position', Pos), 1903 b_setval('$variable_names', Bindings), 1904 ( Raw == end_of_file 1905 -> !, 1906 ( Parents = [_,_|_] % Included file 1907 -> fail 1908 ; '$expanded_term'(In, 1909 Raw, RawLayout, Read, RLayout, Term, TLayout, 1910 Stream, Parents, Options) 1911 ) 1912 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1913 Stream, Parents, Options) 1914 ). 1915 1916'$read_clause_options'([], []). 1917'$read_clause_options'([H|T0], List) :- 1918 ( '$read_clause_option'(H) 1919 -> List = [H|T] 1920 ; List = T 1921 ), 1922 '$read_clause_options'(T0, T). 1923 1924'$read_clause_option'(syntax_errors(_)). 1925'$read_clause_option'(term_position(_)). 1926'$read_clause_option'(process_comment(_)).
expand.pl
is not yet
loaded.1934'$repeat_and_read_error_mode'(Mode) :- 1935 ( current_predicate('$including'/0) 1936 -> repeat, 1937 ( '$including' 1938 -> Mode = dec10 1939 ; Mode = quiet 1940 ) 1941 ; Mode = dec10, 1942 repeat 1943 ). 1944 1945 1946'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1947 Stream, Parents, Options) :- 1948 E = error(_,_), 1949 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1950 '$print_message_fail'(E)), 1951 ( Expanded \== [] 1952 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1953 ; Term1 = Expanded, 1954 Layout1 = ExpandedLayout 1955 ), 1956 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1957 -> ( Directive = include(File), 1958 '$current_source_module'(Module), 1959 '$valid_directive'(Module:include(File)) 1960 -> stream_property(In, encoding(Enc)), 1961 '$add_encoding'(Enc, Options, Options1), 1962 '$source_term'(File, Read, RLayout, Term, TLayout, 1963 Stream, Parents, Options1) 1964 ; Directive = encoding(Enc) 1965 -> set_stream(In, encoding(Enc)), 1966 fail 1967 ; Term = Term1, 1968 Stream = In, 1969 Read = Raw 1970 ) 1971 ; Term = Term1, 1972 TLayout = Layout1, 1973 Stream = In, 1974 Read = Raw, 1975 RLayout = RawLayout 1976 ). 1977 1978'$expansion_member'(Var, Layout, Var, Layout) :- 1979 var(Var), 1980 !. 1981'$expansion_member'([], _, _, _) :- !, fail. 1982'$expansion_member'(List, ListLayout, Term, Layout) :- 1983 is_list(List), 1984 !, 1985 ( var(ListLayout) 1986 -> '$member'(Term, List) 1987 ; is_list(ListLayout) 1988 -> '$member_rep2'(Term, Layout, List, ListLayout) 1989 ; Layout = ListLayout, 1990 '$member'(Term, List) 1991 ). 1992'$expansion_member'(X, Layout, X, Layout). 1993 1994% pairwise member, repeating last element of the second 1995% list. 1996 1997'$member_rep2'(H1, H2, [H1|_], [H2|_]). 1998'$member_rep2'(H1, H2, [_|T1], [T2]) :- 1999 !, 2000 '$member_rep2'(H1, H2, T1, [T2]). 2001'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 2002 '$member_rep2'(H1, H2, T1, T2).
2006'$add_encoding'(Enc, Options0, Options) :- 2007 ( Options0 = [encoding(Enc)|_] 2008 -> Options = Options0 2009 ; Options = [encoding(Enc)|Options0] 2010 ). 2011 2012 2013:- multifile 2014 '$included'/4. % Into, Line, File, LastModified 2015:- dynamic 2016 '$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'.
2030'$record_included'([Parent|Parents], File, Path, Time, 2031 message(DoneMsgLevel, 2032 include_file(done(Level, file(File, Path))))) :- 2033 source_location(SrcFile, Line), 2034 !, 2035 '$compilation_level'(Level), 2036 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 2037 '$print_message'(StartMsgLevel, 2038 include_file(start(Level, 2039 file(File, Path)))), 2040 '$last'([Parent|Parents], Owner), 2041 ( ( '$compilation_mode'(database) 2042 ; '$qlf_current_source'(Owner) 2043 ) 2044 -> '$store_admin_clause'( 2045 system:'$included'(Parent, Line, Path, Time), 2046 _, Owner, SrcFile:Line) 2047 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 2048 ). 2049'$record_included'(_, _, _, _, true).
2055'$master_file'(File, MasterFile) :- 2056 '$included'(MasterFile0, _Line, File, _Time), 2057 !, 2058 '$master_file'(MasterFile0, MasterFile). 2059'$master_file'(File, File). 2060 2061 2062'$skip_script_line'(_In, Options) :- 2063 '$option'(check_script(false), Options), 2064 !. 2065'$skip_script_line'(In, _Options) :- 2066 ( peek_char(In, #) 2067 -> skip(In, 10) 2068 ; true 2069 ). 2070 2071'$set_encoding'(Stream, Options) :- 2072 '$option'(encoding(Enc), Options), 2073 !, 2074 Enc \== default, 2075 set_stream(Stream, encoding(Enc)). 2076'$set_encoding'(_, _). 2077 2078 2079'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 2080 ( stream_property(In, file_name(_)) 2081 -> HasName = true, 2082 ( stream_property(In, position(_)) 2083 -> HasPos = true 2084 ; HasPos = false, 2085 set_stream(In, record_position(true)) 2086 ) 2087 ; HasName = false, 2088 set_stream(In, file_name(Id)), 2089 ( stream_property(In, position(_)) 2090 -> HasPos = true 2091 ; HasPos = false, 2092 set_stream(In, record_position(true)) 2093 ) 2094 ). 2095 2096'$restore_load_stream'(In, _State, Options) :- 2097 memberchk(close(true), Options), 2098 !, 2099 close(In). 2100'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 2101 ( HasName == false 2102 -> set_stream(In, file_name('')) 2103 ; true 2104 ), 2105 ( HasPos == false 2106 -> set_stream(In, record_position(false)) 2107 ; true 2108 ). 2109 2110 2111 /******************************* 2112 * DERIVED FILES * 2113 *******************************/ 2114 2115:- dynamic 2116 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2117 2118'$register_derived_source'(_, '-') :- !. 2119'$register_derived_source'(Loaded, DerivedFrom) :- 2120 retractall('$derived_source_db'(Loaded, _, _)), 2121 time_file(DerivedFrom, Time), 2122 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2123 2124% Auto-importing dynamic predicates is not very elegant and 2125% leads to problems with qsave_program/[1,2] 2126 2127'$derived_source'(Loaded, DerivedFrom, Time) :- 2128 '$derived_source_db'(Loaded, DerivedFrom, Time). 2129 2130 2131 /******************************** 2132 * LOAD PREDICATES * 2133 *********************************/ 2134 2135:- meta_predicate 2136 ensure_loaded( ), 2137 [, | ] 2138 consult( ), 2139 use_module( ), 2140 use_module( , ), 2141 reexport( ), 2142 reexport( , ), 2143 load_files( ), 2144 load_files( , ).
2152ensure_loaded(Files) :-
2153 load_files(Files, [if(not_loaded)]).
2162use_module(Files) :-
2163 load_files(Files, [ if(not_loaded),
2164 must_be_module(true)
2165 ]).
2172use_module(File, Import) :-
2173 load_files(File, [ if(not_loaded),
2174 must_be_module(true),
2175 imports(Import)
2176 ]).
2182reexport(Files) :-
2183 load_files(Files, [ if(not_loaded),
2184 must_be_module(true),
2185 reexport(true)
2186 ]).
2192reexport(File, Import) :- 2193 load_files(File, [ if(not_loaded), 2194 must_be_module(true), 2195 imports(Import), 2196 reexport(true) 2197 ]). 2198 2199 2200[X] :- 2201 !, 2202 consult(X). 2203[M:F|R] :- 2204 consult(M:[F|R]). 2205 2206consult(M:X) :- 2207 X == user, 2208 !, 2209 flag('$user_consult', N, N+1), 2210 NN is N + 1, 2211 atom_concat('user://', NN, Id), 2212 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2213consult(List) :- 2214 load_files(List, [expand(true)]).
2221load_files(Files) :- 2222 load_files(Files, []). 2223load_files(Module:Files, Options) :- 2224 '$must_be'(list, Options), 2225 '$load_files'(Files, Module, Options). 2226 2227'$load_files'(X, _, _) :- 2228 var(X), 2229 !, 2230 '$instantiation_error'(X). 2231'$load_files'([], _, _) :- !. 2232'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2233 '$option'(stream(_), Options), 2234 !, 2235 ( atom(Id) 2236 -> '$load_file'(Id, Module, Options) 2237 ; throw(error(type_error(atom, Id), _)) 2238 ). 2239'$load_files'(List, Module, Options) :- 2240 List = [_|_], 2241 !, 2242 '$must_be'(list, List), 2243 '$load_file_list'(List, Module, Options). 2244'$load_files'(File, Module, Options) :- 2245 '$load_one_file'(File, Module, Options). 2246 2247'$load_file_list'([], _, _). 2248'$load_file_list'([File|Rest], Module, Options) :- 2249 E = error(_,_), 2250 catch('$load_one_file'(File, Module, Options), E, 2251 '$print_message'(error, E)), 2252 '$load_file_list'(Rest, Module, Options). 2253 2254 2255'$load_one_file'(Spec, Module, Options) :- 2256 atomic(Spec), 2257 '$option'(expand(Expand), Options, false), 2258 Expand == true, 2259 !, 2260 expand_file_name(Spec, Expanded), 2261 ( Expanded = [Load] 2262 -> true 2263 ; Load = Expanded 2264 ), 2265 '$load_files'(Load, Module, [expand(false)|Options]). 2266'$load_one_file'(File, Module, Options) :- 2267 strip_module(Module:File, Into, PlainFile), 2268 '$load_file'(PlainFile, Into, Options).
2275'$noload'(true, _, _) :- 2276 !, 2277 fail. 2278'$noload'(_, FullFile, _Options) :- 2279 '$time_source_file'(FullFile, Time, system), 2280 Time > 0.0, 2281 !. 2282'$noload'(not_loaded, FullFile, _) :- 2283 source_file(FullFile), 2284 !. 2285'$noload'(changed, Derived, _) :- 2286 '$derived_source'(_FullFile, Derived, LoadTime), 2287 time_file(Derived, Modified), 2288 Modified @=< LoadTime, 2289 !. 2290'$noload'(changed, FullFile, Options) :- 2291 '$time_source_file'(FullFile, LoadTime, user), 2292 '$modified_id'(FullFile, Modified, Options), 2293 Modified @=< LoadTime, 2294 !. 2295'$noload'(exists, File, Options) :- 2296 '$noload'(changed, File, Options).
2315'$qlf_file'(Spec, _, Spec, stream, Options) :- 2316 '$option'(stream(_), Options), % stream: no choice 2317 !. 2318'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2319 '$spec_extension'(Spec, Ext), % user explicitly specified 2320 user:prolog_file_type(Ext, prolog), 2321 !. 2322'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2323 '$compilation_mode'(database), 2324 file_name_extension(Base, PlExt, FullFile), 2325 user:prolog_file_type(PlExt, prolog), 2326 user:prolog_file_type(QlfExt, qlf), 2327 file_name_extension(Base, QlfExt, QlfFile), 2328 ( access_file(QlfFile, read), 2329 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2330 -> ( access_file(QlfFile, write) 2331 -> print_message(informational, 2332 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2333 Mode = qcompile, 2334 LoadFile = FullFile 2335 ; Why == old, 2336 ( current_prolog_flag(home, PlHome), 2337 sub_atom(FullFile, 0, _, _, PlHome) 2338 ; sub_atom(QlfFile, 0, _, _, 'res://') 2339 ) 2340 -> print_message(silent, 2341 qlf(system_lib_out_of_date(Spec, QlfFile))), 2342 Mode = qload, 2343 LoadFile = QlfFile 2344 ; print_message(warning, 2345 qlf(can_not_recompile(Spec, QlfFile, Why))), 2346 Mode = compile, 2347 LoadFile = FullFile 2348 ) 2349 ; Mode = qload, 2350 LoadFile = QlfFile 2351 ) 2352 -> ! 2353 ; '$qlf_auto'(FullFile, QlfFile, Options) 2354 -> !, Mode = qcompile, 2355 LoadFile = FullFile 2356 ). 2357'$qlf_file'(_, FullFile, FullFile, compile, _).
2365'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2366 ( access_file(PlFile, read)
2367 -> time_file(PlFile, PlTime),
2368 time_file(QlfFile, QlfTime),
2369 ( PlTime > QlfTime
2370 -> Why = old % PlFile is newer
2371 ; Error = error(Formal,_),
2372 catch('$qlf_info'(QlfFile, _CVer, _MLVer,
2373 _FVer, _CSig, _FSig),
2374 Error, true),
2375 nonvar(Formal) % QlfFile is incompatible
2376 -> Why = Error
2377 ; fail % QlfFile is up-to-date and ok
2378 )
2379 ; fail % can not read .pl; try .qlf
2380 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2388:- create_prolog_flag(qcompile, false, [type(atom)]). 2389 2390'$qlf_auto'(PlFile, QlfFile, Options) :- 2391 ( memberchk(qcompile(QlfMode), Options) 2392 -> true 2393 ; current_prolog_flag(qcompile, QlfMode), 2394 \+ '$in_system_dir'(PlFile) 2395 ), 2396 ( QlfMode == auto 2397 -> true 2398 ; QlfMode == large, 2399 size_file(PlFile, Size), 2400 Size > 100000 2401 ), 2402 access_file(QlfFile, write). 2403 2404'$in_system_dir'(PlFile) :- 2405 current_prolog_flag(home, Home), 2406 sub_atom(PlFile, 0, _, _, Home). 2407 2408'$spec_extension'(File, Ext) :- 2409 atom(File), 2410 file_name_extension(_, Ext, File). 2411'$spec_extension'(Spec, Ext) :- 2412 compound(Spec), 2413 arg(1, Spec, Arg), 2414 '$spec_extension'(Arg, Ext).
2426:- dynamic 2427 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2428 2429'$load_file'(File, Module, Options) :- 2430 '$error_count'(E0, W0), 2431 '$load_file_e'(File, Module, Options), 2432 '$error_count'(E1, W1), 2433 Errors is E1-E0, 2434 Warnings is W1-W0, 2435 ( Errors+Warnings =:= 0 2436 -> true 2437 ; '$print_message'(silent, load_file_errors(File, Errors, Warnings)) 2438 ). 2439 2440:- if(current_prolog_flag(threads, true)). 2441'$error_count'(Errors, Warnings) :- 2442 current_prolog_flag(threads, true), 2443 !, 2444 thread_self(Me), 2445 thread_statistics(Me, errors, Errors), 2446 thread_statistics(Me, warnings, Warnings). 2447:- endif. 2448'$error_count'(Errors, Warnings) :- 2449 statistics(errors, Errors), 2450 statistics(warnings, Warnings). 2451 2452'$load_file_e'(File, Module, Options) :- 2453 \+ memberchk(stream(_), Options), 2454 user:prolog_load_file(Module:File, Options), 2455 !. 2456'$load_file_e'(File, Module, Options) :- 2457 memberchk(stream(_), Options), 2458 !, 2459 '$assert_load_context_module'(File, Module, Options), 2460 '$qdo_load_file'(File, File, Module, Options). 2461'$load_file_e'(File, Module, Options) :- 2462 ( '$resolved_source_path'(File, FullFile, Options) 2463 -> true 2464 ; '$resolve_source_path'(File, FullFile, Options) 2465 ), 2466 !, 2467 '$mt_load_file'(File, FullFile, Module, Options). 2468'$load_file_e'(_, _, _).
2474'$resolved_source_path'(File, FullFile, Options) :-
2475 current_prolog_flag(emulated_dialect, Dialect),
2476 '$resolved_source_path_db'(File, Dialect, FullFile),
2477 ( '$source_file_property'(FullFile, from_state, true)
2478 ; '$source_file_property'(FullFile, resource, true)
2479 ; '$option'(if(If), Options, true),
2480 '$noload'(If, FullFile, Options)
2481 ),
2482 !.
2489'$resolve_source_path'(File, FullFile, Options) :- 2490 ( '$option'(if(If), Options), 2491 If == exists 2492 -> Extra = [file_errors(fail)] 2493 ; Extra = [] 2494 ), 2495 absolute_file_name(File, FullFile, 2496 [ file_type(prolog), 2497 access(read) 2498 | Extra 2499 ]), 2500 '$register_resolved_source_path'(File, FullFile). 2501 2502'$register_resolved_source_path'(File, FullFile) :- 2503 ( compound(File) 2504 -> current_prolog_flag(emulated_dialect, Dialect), 2505 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2506 -> true 2507 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2508 ) 2509 ; true 2510 ).
2516:- public '$translated_source'/2. 2517'$translated_source'(Old, New) :- 2518 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2519 assertz('$resolved_source_path_db'(File, Dialect, New))).
2526'$register_resource_file'(FullFile) :-
2527 ( sub_atom(FullFile, 0, _, _, 'res://'),
2528 \+ file_name_extension(_, qlf, FullFile)
2529 -> '$set_source_file'(FullFile, resource, true)
2530 ; true
2531 ).
2544'$already_loaded'(_File, FullFile, Module, Options) :- 2545 '$assert_load_context_module'(FullFile, Module, Options), 2546 '$current_module'(LoadModules, FullFile), 2547 !, 2548 ( atom(LoadModules) 2549 -> LoadModule = LoadModules 2550 ; LoadModules = [LoadModule|_] 2551 ), 2552 '$import_from_loaded_module'(LoadModule, Module, Options). 2553'$already_loaded'(_, _, user, _) :- !. 2554'$already_loaded'(File, FullFile, Module, Options) :- 2555 ( '$load_context_module'(FullFile, Module, CtxOptions), 2556 '$load_ctx_options'(Options, CtxOptions) 2557 -> true 2558 ; '$load_file'(File, Module, [if(true)|Options]) 2559 ).
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.
2574:- dynamic 2575 '$loading_file'/3. % File, Queue, Thread 2576:- volatile 2577 '$loading_file'/3. 2578 2579:- if(current_prolog_flag(threads, true)). 2580'$mt_load_file'(File, FullFile, Module, Options) :- 2581 current_prolog_flag(threads, true), 2582 !, 2583 sig_atomic(setup_call_cleanup( 2584 with_mutex('$load_file', 2585 '$mt_start_load'(FullFile, Loading, Options)), 2586 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2587 '$mt_end_load'(Loading))). 2588:- endif. 2589'$mt_load_file'(File, FullFile, Module, Options) :- 2590 '$option'(if(If), Options, true), 2591 '$noload'(If, FullFile, Options), 2592 !, 2593 '$already_loaded'(File, FullFile, Module, Options). 2594:- if(current_prolog_flag(threads, true)). 2595'$mt_load_file'(File, FullFile, Module, Options) :- 2596 sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)). 2597:- else. 2598'$mt_load_file'(File, FullFile, Module, Options) :- 2599 '$qdo_load_file'(File, FullFile, Module, Options). 2600:- endif. 2601 2602:- if(current_prolog_flag(threads, true)). 2603'$mt_start_load'(FullFile, queue(Queue), _) :- 2604 '$loading_file'(FullFile, Queue, LoadThread), 2605 \+ thread_self(LoadThread), 2606 !. 2607'$mt_start_load'(FullFile, already_loaded, Options) :- 2608 '$option'(if(If), Options, true), 2609 '$noload'(If, FullFile, Options), 2610 !. 2611'$mt_start_load'(FullFile, Ref, _) :- 2612 thread_self(Me), 2613 message_queue_create(Queue), 2614 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2615 2616'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2617 !, 2618 catch(thread_get_message(Queue, _), error(_,_), true), 2619 '$already_loaded'(File, FullFile, Module, Options). 2620'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2621 !, 2622 '$already_loaded'(File, FullFile, Module, Options). 2623'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2624 '$assert_load_context_module'(FullFile, Module, Options), 2625 '$qdo_load_file'(File, FullFile, Module, Options). 2626 2627'$mt_end_load'(queue(_)) :- !. 2628'$mt_end_load'(already_loaded) :- !. 2629'$mt_end_load'(Ref) :- 2630 clause('$loading_file'(_, Queue, _), _, Ref), 2631 erase(Ref), 2632 thread_send_message(Queue, done), 2633 message_queue_destroy(Queue). 2634:- endif.
2640'$qdo_load_file'(File, FullFile, Module, Options) :- 2641 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2642 '$register_resource_file'(FullFile), 2643 '$run_initialization'(FullFile, Action, Options). 2644 2645'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2646 memberchk('$qlf'(QlfOut), Options), 2647 '$stage_file'(QlfOut, StageQlf), 2648 !, 2649 setup_call_catcher_cleanup( 2650 '$qstart'(StageQlf, Module, State), 2651 '$do_load_file'(File, FullFile, Module, Action, Options), 2652 Catcher, 2653 '$qend'(State, Catcher, StageQlf, QlfOut)). 2654'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2655 '$do_load_file'(File, FullFile, Module, Action, Options). 2656 2657'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2658 '$qlf_open'(Qlf), 2659 '$compilation_mode'(OldMode, qlf), 2660 '$set_source_module'(OldModule, Module). 2661 2662'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2663 '$set_source_module'(_, OldModule), 2664 '$set_compilation_mode'(OldMode), 2665 '$qlf_close', 2666 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2667 2668'$set_source_module'(OldModule, Module) :- 2669 '$current_source_module'(OldModule), 2670 '$set_source_module'(Module).
2677'$do_load_file'(File, FullFile, Module, Action, Options) :- 2678 '$option'(derived_from(DerivedFrom), Options, -), 2679 '$register_derived_source'(FullFile, DerivedFrom), 2680 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2681 ( Mode == qcompile 2682 -> qcompile(Module:File, Options) 2683 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2684 ). 2685 2686'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2687 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2688 statistics(cputime, OldTime), 2689 2690 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2691 Options), 2692 2693 '$compilation_level'(Level), 2694 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2695 '$print_message'(StartMsgLevel, 2696 load_file(start(Level, 2697 file(File, Absolute)))), 2698 2699 ( memberchk(stream(FromStream), Options) 2700 -> Input = stream 2701 ; Input = source 2702 ), 2703 2704 ( Input == stream, 2705 ( '$option'(format(qlf), Options, source) 2706 -> set_stream(FromStream, file_name(Absolute)), 2707 '$qload_stream'(FromStream, Module, Action, LM, Options) 2708 ; '$consult_file'(stream(Absolute, FromStream, []), 2709 Module, Action, LM, Options) 2710 ) 2711 -> true 2712 ; Input == source, 2713 file_name_extension(_, Ext, Absolute), 2714 ( user:prolog_file_type(Ext, qlf), 2715 E = error(_,_), 2716 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2717 E, 2718 print_message(warning, E)) 2719 -> true 2720 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2721 ) 2722 -> true 2723 ; '$print_message'(error, load_file(failed(File))), 2724 fail 2725 ), 2726 2727 '$import_from_loaded_module'(LM, Module, Options), 2728 2729 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2730 statistics(cputime, Time), 2731 ClausesCreated is NewClauses - OldClauses, 2732 TimeUsed is Time - OldTime, 2733 2734 '$print_message'(DoneMsgLevel, 2735 load_file(done(Level, 2736 file(File, Absolute), 2737 Action, 2738 LM, 2739 TimeUsed, 2740 ClausesCreated))), 2741 2742 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2743 2744'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2745 Options) :- 2746 '$save_file_scoped_flags'(ScopedFlags), 2747 '$set_sandboxed_load'(Options, OldSandBoxed), 2748 '$set_verbose_load'(Options, OldVerbose), 2749 '$set_optimise_load'(Options), 2750 '$update_autoload_level'(Options, OldAutoLevel), 2751 '$set_no_xref'(OldXRef). 2752 2753'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2754 '$set_autoload_level'(OldAutoLevel), 2755 set_prolog_flag(xref, OldXRef), 2756 set_prolog_flag(verbose_load, OldVerbose), 2757 set_prolog_flag(sandboxed_load, OldSandBoxed), 2758 '$restore_file_scoped_flags'(ScopedFlags).
2766'$save_file_scoped_flags'(State) :- 2767 current_predicate(findall/3), % Not when doing boot compile 2768 !, 2769 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2770'$save_file_scoped_flags'([]). 2771 2772'$save_file_scoped_flag'(Flag-Value) :- 2773 '$file_scoped_flag'(Flag, Default), 2774 ( current_prolog_flag(Flag, Value) 2775 -> true 2776 ; Value = Default 2777 ). 2778 2779'$file_scoped_flag'(generate_debug_info, true). 2780'$file_scoped_flag'(optimise, false). 2781'$file_scoped_flag'(xref, false). 2782 2783'$restore_file_scoped_flags'([]). 2784'$restore_file_scoped_flags'([Flag-Value|T]) :- 2785 set_prolog_flag(Flag, Value), 2786 '$restore_file_scoped_flags'(T).
2793'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2794 LoadedModule \== Module, 2795 atom(LoadedModule), 2796 !, 2797 '$option'(imports(Import), Options, all), 2798 '$option'(reexport(Reexport), Options, false), 2799 '$import_list'(Module, LoadedModule, Import, Reexport). 2800'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2808'$set_verbose_load'(Options, Old) :- 2809 current_prolog_flag(verbose_load, Old), 2810 ( memberchk(silent(Silent), Options) 2811 -> ( '$negate'(Silent, Level0) 2812 -> '$load_msg_compat'(Level0, Level) 2813 ; Level = Silent 2814 ), 2815 set_prolog_flag(verbose_load, Level) 2816 ; true 2817 ). 2818 2819'$negate'(true, false). 2820'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2829'$set_sandboxed_load'(Options, Old) :- 2830 current_prolog_flag(sandboxed_load, Old), 2831 ( memberchk(sandboxed(SandBoxed), Options), 2832 '$enter_sandboxed'(Old, SandBoxed, New), 2833 New \== Old 2834 -> set_prolog_flag(sandboxed_load, New) 2835 ; true 2836 ). 2837 2838'$enter_sandboxed'(Old, New, SandBoxed) :- 2839 ( Old == false, New == true 2840 -> SandBoxed = true, 2841 '$ensure_loaded_library_sandbox' 2842 ; Old == true, New == false 2843 -> throw(error(permission_error(leave, sandbox, -), _)) 2844 ; SandBoxed = Old 2845 ). 2846'$enter_sandboxed'(false, true, true). 2847 2848'$ensure_loaded_library_sandbox' :- 2849 source_file_property(library(sandbox), module(sandbox)), 2850 !. 2851'$ensure_loaded_library_sandbox' :- 2852 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2853 2854'$set_optimise_load'(Options) :- 2855 ( '$option'(optimise(Optimise), Options) 2856 -> set_prolog_flag(optimise, Optimise) 2857 ; true 2858 ). 2859 2860'$set_no_xref'(OldXRef) :- 2861 ( current_prolog_flag(xref, OldXRef) 2862 -> true 2863 ; OldXRef = false 2864 ), 2865 set_prolog_flag(xref, false).
2872:- thread_local 2873 '$autoload_nesting'/1. 2874 2875'$update_autoload_level'(Options, AutoLevel) :- 2876 '$option'(autoload(Autoload), Options, false), 2877 ( '$autoload_nesting'(CurrentLevel) 2878 -> AutoLevel = CurrentLevel 2879 ; AutoLevel = 0 2880 ), 2881 ( Autoload == false 2882 -> true 2883 ; NewLevel is AutoLevel + 1, 2884 '$set_autoload_level'(NewLevel) 2885 ). 2886 2887'$set_autoload_level'(New) :- 2888 retractall('$autoload_nesting'(_)), 2889 asserta('$autoload_nesting'(New)).
2897'$print_message'(Level, Term) :- 2898 current_predicate(system:print_message/2), 2899 !, 2900 print_message(Level, Term). 2901'$print_message'(warning, Term) :- 2902 source_location(File, Line), 2903 !, 2904 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2905'$print_message'(error, Term) :- 2906 !, 2907 source_location(File, Line), 2908 !, 2909 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2910'$print_message'(_Level, _Term). 2911 2912'$print_message_fail'(E) :- 2913 '$print_message'(error, E), 2914 fail.
2922'$consult_file'(Absolute, Module, What, LM, Options) :- 2923 '$current_source_module'(Module), % same module 2924 !, 2925 '$consult_file_2'(Absolute, Module, What, LM, Options). 2926'$consult_file'(Absolute, Module, What, LM, Options) :- 2927 '$set_source_module'(OldModule, Module), 2928 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2929 '$consult_file_2'(Absolute, Module, What, LM, Options), 2930 '$ifcompiling'('$qlf_end_part'), 2931 '$set_source_module'(OldModule). 2932 2933'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2934 '$set_source_module'(OldModule, Module), 2935 '$load_id'(Absolute, Id, Modified, Options), 2936 '$compile_type'(What), 2937 '$save_lex_state'(LexState, Options), 2938 '$set_dialect'(Options), 2939 setup_call_cleanup( 2940 '$start_consult'(Id, Modified), 2941 '$load_file'(Absolute, Id, LM, Options), 2942 '$end_consult'(Id, LexState, OldModule)). 2943 2944'$end_consult'(Id, LexState, OldModule) :- 2945 '$end_consult'(Id), 2946 '$restore_lex_state'(LexState), 2947 '$set_source_module'(OldModule). 2948 2949 2950:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2954'$save_lex_state'(State, Options) :- 2955 memberchk(scope_settings(false), Options), 2956 !, 2957 State = (-). 2958'$save_lex_state'(lexstate(Style, Dialect), _) :- 2959 '$style_check'(Style, Style), 2960 current_prolog_flag(emulated_dialect, Dialect). 2961 2962'$restore_lex_state'(-) :- !. 2963'$restore_lex_state'(lexstate(Style, Dialect)) :- 2964 '$style_check'(_, Style), 2965 set_prolog_flag(emulated_dialect, Dialect). 2966 2967'$set_dialect'(Options) :- 2968 memberchk(dialect(Dialect), Options), 2969 !, 2970 '$expects_dialect'(Dialect). 2971'$set_dialect'(_). 2972 2973'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 2974 !, 2975 '$modified_id'(Id, Modified, Options). 2976'$load_id'(Id, Id, Modified, Options) :- 2977 '$modified_id'(Id, Modified, Options). 2978 2979'$modified_id'(_, Modified, Options) :- 2980 '$option'(modified(Stamp), Options, Def), 2981 Stamp \== Def, 2982 !, 2983 Modified = Stamp. 2984'$modified_id'(Id, Modified, _) :- 2985 catch(time_file(Id, Modified), 2986 error(_, _), 2987 fail), 2988 !. 2989'$modified_id'(_, 0.0, _). 2990 2991 2992'$compile_type'(What) :- 2993 '$compilation_mode'(How), 2994 ( How == database 2995 -> What = compiled 2996 ; How == qlf 2997 -> What = '*qcompiled*' 2998 ; What = 'boot compiled' 2999 ).
3009:- dynamic 3010 '$load_context_module'/3. 3011:- multifile 3012 '$load_context_module'/3. 3013 3014'$assert_load_context_module'(_, _, Options) :- 3015 memberchk(register(false), Options), 3016 !. 3017'$assert_load_context_module'(File, Module, Options) :- 3018 source_location(FromFile, Line), 3019 !, 3020 '$master_file'(FromFile, MasterFile), 3021 '$check_load_non_module'(File, Module), 3022 '$add_dialect'(Options, Options1), 3023 '$load_ctx_options'(Options1, Options2), 3024 '$store_admin_clause'( 3025 system:'$load_context_module'(File, Module, Options2), 3026 _Layout, MasterFile, FromFile:Line). 3027'$assert_load_context_module'(File, Module, Options) :- 3028 '$check_load_non_module'(File, Module), 3029 '$add_dialect'(Options, Options1), 3030 '$load_ctx_options'(Options1, Options2), 3031 ( clause('$load_context_module'(File, Module, _), true, Ref), 3032 \+ clause_property(Ref, file(_)), 3033 erase(Ref) 3034 -> true 3035 ; true 3036 ), 3037 assertz('$load_context_module'(File, Module, Options2)). 3038 3039'$add_dialect'(Options0, Options) :- 3040 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 3041 !, 3042 Options = [dialect(Dialect)|Options0]. 3043'$add_dialect'(Options, Options).
3050'$load_ctx_options'(Options, CtxOptions) :- 3051 '$load_ctx_options2'(Options, CtxOptions0), 3052 sort(CtxOptions0, CtxOptions). 3053 3054'$load_ctx_options2'([], []). 3055'$load_ctx_options2'([H|T0], [H|T]) :- 3056 '$load_ctx_option'(H), 3057 !, 3058 '$load_ctx_options2'(T0, T). 3059'$load_ctx_options2'([_|T0], T) :- 3060 '$load_ctx_options2'(T0, T). 3061 3062'$load_ctx_option'(derived_from(_)). 3063'$load_ctx_option'(dialect(_)). 3064'$load_ctx_option'(encoding(_)). 3065'$load_ctx_option'(imports(_)). 3066'$load_ctx_option'(reexport(_)).
3074'$check_load_non_module'(File, _) :- 3075 '$current_module'(_, File), 3076 !. % File is a module file 3077'$check_load_non_module'(File, Module) :- 3078 '$load_context_module'(File, OldModule, _), 3079 Module \== OldModule, 3080 !, 3081 format(atom(Msg), 3082 'Non-module file already loaded into module ~w; \c 3083 trying to load into ~w', 3084 [OldModule, Module]), 3085 throw(error(permission_error(load, source, File), 3086 context(load_files/2, Msg))). 3087'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
3100'$load_file'(Path, Id, Module, Options) :- 3101 State = state(true, _, true, false, Id, -), 3102 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 3103 _Stream, Options), 3104 '$valid_term'(Term), 3105 ( arg(1, State, true) 3106 -> '$first_term'(Term, Layout, Id, State, Options), 3107 nb_setarg(1, State, false) 3108 ; '$compile_term'(Term, Layout, Id, Options) 3109 ), 3110 arg(4, State, true) 3111 ; '$fixup_reconsult'(Id), 3112 '$end_load_file'(State) 3113 ), 3114 !, 3115 arg(2, State, Module). 3116 3117'$valid_term'(Var) :- 3118 var(Var), 3119 !, 3120 print_message(error, error(instantiation_error, _)). 3121'$valid_term'(Term) :- 3122 Term \== []. 3123 3124'$end_load_file'(State) :- 3125 arg(1, State, true), % empty file 3126 !, 3127 nb_setarg(2, State, Module), 3128 arg(5, State, Id), 3129 '$current_source_module'(Module), 3130 '$ifcompiling'('$qlf_start_file'(Id)), 3131 '$ifcompiling'('$qlf_end_part'). 3132'$end_load_file'(State) :- 3133 arg(3, State, End), 3134 '$end_load_file'(End, State). 3135 3136'$end_load_file'(true, _). 3137'$end_load_file'(end_module, State) :- 3138 arg(2, State, Module), 3139 '$check_export'(Module), 3140 '$ifcompiling'('$qlf_end_part'). 3141'$end_load_file'(end_non_module, _State) :- 3142 '$ifcompiling'('$qlf_end_part'). 3143 3144 3145'$first_term'(?-(Directive), Layout, Id, State, Options) :- 3146 !, 3147 '$first_term'(:-(Directive), Layout, Id, State, Options). 3148'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 3149 nonvar(Directive), 3150 ( ( Directive = module(Name, Public) 3151 -> Imports = [] 3152 ; Directive = module(Name, Public, Imports) 3153 ) 3154 -> !, 3155 '$module_name'(Name, Id, Module, Options), 3156 '$start_module'(Module, Public, State, Options), 3157 '$module3'(Imports) 3158 ; Directive = expects_dialect(Dialect) 3159 -> !, 3160 '$set_dialect'(Dialect, State), 3161 fail % Still consider next term as first 3162 ). 3163'$first_term'(Term, Layout, Id, State, Options) :- 3164 '$start_non_module'(Id, Term, State, Options), 3165 '$compile_term'(Term, Layout, Id, Options).
3172'$compile_term'(Term, Layout, SrcId, Options) :- 3173 '$compile_term'(Term, Layout, SrcId, -, Options). 3174 3175'$compile_term'(Var, _Layout, _Id, _SrcLoc, _Options) :- 3176 var(Var), 3177 !, 3178 '$instantiation_error'(Var). 3179'$compile_term'((?-Directive), _Layout, Id, _SrcLoc, Options) :- 3180 !, 3181 '$execute_directive'(Directive, Id, Options). 3182'$compile_term'((:-Directive), _Layout, Id, _SrcLoc, Options) :- 3183 !, 3184 '$execute_directive'(Directive, Id, Options). 3185'$compile_term'('$source_location'(File, Line):Term, 3186 Layout, Id, _SrcLoc, Options) :- 3187 !, 3188 '$compile_term'(Term, Layout, Id, File:Line, Options). 3189'$compile_term'(Clause, Layout, Id, SrcLoc, _Options) :- 3190 E = error(_,_), 3191 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3192 '$print_message'(error, E)). 3193 3194'$start_non_module'(_Id, Term, _State, Options) :- 3195 '$option'(must_be_module(true), Options, false), 3196 !, 3197 '$domain_error'(module_header, Term). 3198'$start_non_module'(Id, _Term, State, _Options) :- 3199 '$current_source_module'(Module), 3200 '$ifcompiling'('$qlf_start_file'(Id)), 3201 '$qset_dialect'(State), 3202 nb_setarg(2, State, Module), 3203 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3216'$set_dialect'(Dialect, State) :- 3217 '$compilation_mode'(qlf, database), 3218 !, 3219 '$expects_dialect'(Dialect), 3220 '$compilation_mode'(_, qlf), 3221 nb_setarg(6, State, Dialect). 3222'$set_dialect'(Dialect, _) :- 3223 '$expects_dialect'(Dialect). 3224 3225'$qset_dialect'(State) :- 3226 '$compilation_mode'(qlf), 3227 arg(6, State, Dialect), Dialect \== (-), 3228 !, 3229 '$add_directive_wic'('$expects_dialect'(Dialect)). 3230'$qset_dialect'(_). 3231 3232'$expects_dialect'(Dialect) :- 3233 Dialect == swi, 3234 !, 3235 set_prolog_flag(emulated_dialect, Dialect). 3236'$expects_dialect'(Dialect) :- 3237 current_predicate(expects_dialect/1), 3238 !, 3239 expects_dialect(Dialect). 3240'$expects_dialect'(Dialect) :- 3241 use_module(library(dialect), [expects_dialect/1]), 3242 expects_dialect(Dialect). 3243 3244 3245 /******************************* 3246 * MODULES * 3247 *******************************/ 3248 3249'$start_module'(Module, _Public, State, _Options) :- 3250 '$current_module'(Module, OldFile), 3251 source_location(File, _Line), 3252 OldFile \== File, OldFile \== [], 3253 same_file(OldFile, File), 3254 !, 3255 nb_setarg(2, State, Module), 3256 nb_setarg(4, State, true). % Stop processing 3257'$start_module'(Module, Public, State, Options) :- 3258 arg(5, State, File), 3259 nb_setarg(2, State, Module), 3260 source_location(_File, Line), 3261 '$option'(redefine_module(Action), Options, false), 3262 '$module_class'(File, Class, Super), 3263 '$reset_dialect'(File, Class), 3264 '$redefine_module'(Module, File, Action), 3265 '$declare_module'(Module, Class, Super, File, Line, false), 3266 '$export_list'(Public, Module, Ops), 3267 '$ifcompiling'('$qlf_start_module'(Module)), 3268 '$export_ops'(Ops, Module, File), 3269 '$qset_dialect'(State), 3270 nb_setarg(3, State, end_module).
swi
dialect.3277'$reset_dialect'(File, library) :- 3278 file_name_extension(_, pl, File), 3279 !, 3280 set_prolog_flag(emulated_dialect, swi). 3281'$reset_dialect'(_, _).
3288'$module3'(Var) :- 3289 var(Var), 3290 !, 3291 '$instantiation_error'(Var). 3292'$module3'([]) :- !. 3293'$module3'([H|T]) :- 3294 !, 3295 '$module3'(H), 3296 '$module3'(T). 3297'$module3'(Id) :- 3298 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.3312'$module_name'(_, _, Module, Options) :- 3313 '$option'(module(Module), Options), 3314 !, 3315 '$current_source_module'(Context), 3316 Context \== Module. % cause '$first_term'/5 to fail. 3317'$module_name'(Var, Id, Module, Options) :- 3318 var(Var), 3319 !, 3320 file_base_name(Id, File), 3321 file_name_extension(Var, _, File), 3322 '$module_name'(Var, Id, Module, Options). 3323'$module_name'(Reserved, _, _, _) :- 3324 '$reserved_module'(Reserved), 3325 !, 3326 throw(error(permission_error(load, module, Reserved), _)). 3327'$module_name'(Module, _Id, Module, _). 3328 3329 3330'$reserved_module'(system). 3331'$reserved_module'(user).
3336'$redefine_module'(_Module, _, false) :- !. 3337'$redefine_module'(Module, File, true) :- 3338 !, 3339 ( module_property(Module, file(OldFile)), 3340 File \== OldFile 3341 -> unload_file(OldFile) 3342 ; true 3343 ). 3344'$redefine_module'(Module, File, ask) :- 3345 ( stream_property(user_input, tty(true)), 3346 module_property(Module, file(OldFile)), 3347 File \== OldFile, 3348 '$rdef_response'(Module, OldFile, File, true) 3349 -> '$redefine_module'(Module, File, true) 3350 ; true 3351 ). 3352 3353'$rdef_response'(Module, OldFile, File, Ok) :- 3354 repeat, 3355 print_message(query, redefine_module(Module, OldFile, File)), 3356 get_single_char(Char), 3357 '$rdef_response'(Char, Ok0), 3358 !, 3359 Ok = Ok0. 3360 3361'$rdef_response'(Char, true) :- 3362 memberchk(Char, `yY`), 3363 format(user_error, 'yes~n', []). 3364'$rdef_response'(Char, false) :- 3365 memberchk(Char, `nN`), 3366 format(user_error, 'no~n', []). 3367'$rdef_response'(Char, _) :- 3368 memberchk(Char, `a`), 3369 format(user_error, 'abort~n', []), 3370 abort. 3371'$rdef_response'(_, _) :- 3372 print_message(help, redefine_module_reply), 3373 fail.
system
, while all normal user modules inherit
from user
.3383'$module_class'(File, Class, system) :- 3384 current_prolog_flag(home, Home), 3385 sub_atom(File, 0, Len, _, Home), 3386 ( sub_atom(File, Len, _, _, '/boot/') 3387 -> !, Class = system 3388 ; '$lib_prefix'(Prefix), 3389 sub_atom(File, Len, _, _, Prefix) 3390 -> !, Class = library 3391 ; file_directory_name(File, Home), 3392 file_name_extension(_, rc, File) 3393 -> !, Class = library 3394 ). 3395'$module_class'(_, user, user). 3396 3397'$lib_prefix'('/library'). 3398'$lib_prefix'('/xpce/prolog/'). 3399 3400'$check_export'(Module) :- 3401 '$undefined_export'(Module, UndefList), 3402 ( '$member'(Undef, UndefList), 3403 strip_module(Undef, _, Local), 3404 print_message(error, 3405 undefined_export(Module, Local)), 3406 fail 3407 ; true 3408 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3417'$import_list'(_, _, Var, _) :- 3418 var(Var), 3419 !, 3420 throw(error(instantitation_error, _)). 3421'$import_list'(Target, Source, all, Reexport) :- 3422 !, 3423 '$exported_ops'(Source, Import, Predicates), 3424 '$module_property'(Source, exports(Predicates)), 3425 '$import_all'(Import, Target, Source, Reexport, weak). 3426'$import_list'(Target, Source, except(Spec), Reexport) :- 3427 !, 3428 '$exported_ops'(Source, Export, Predicates), 3429 '$module_property'(Source, exports(Predicates)), 3430 ( is_list(Spec) 3431 -> true 3432 ; throw(error(type_error(list, Spec), _)) 3433 ), 3434 '$import_except'(Spec, Export, Import), 3435 '$import_all'(Import, Target, Source, Reexport, weak). 3436'$import_list'(Target, Source, Import, Reexport) :- 3437 !, 3438 is_list(Import), 3439 !, 3440 '$import_all'(Import, Target, Source, Reexport, strong). 3441'$import_list'(_, _, Import, _) :- 3442 throw(error(type_error(import_specifier, Import))). 3443 3444 3445'$import_except'([], List, List). 3446'$import_except'([H|T], List0, List) :- 3447 '$import_except_1'(H, List0, List1), 3448 '$import_except'(T, List1, List). 3449 3450'$import_except_1'(Var, _, _) :- 3451 var(Var), 3452 !, 3453 throw(error(instantitation_error, _)). 3454'$import_except_1'(PI as N, List0, List) :- 3455 '$pi'(PI), atom(N), 3456 !, 3457 '$canonical_pi'(PI, CPI), 3458 '$import_as'(CPI, N, List0, List). 3459'$import_except_1'(op(P,A,N), List0, List) :- 3460 !, 3461 '$remove_ops'(List0, op(P,A,N), List). 3462'$import_except_1'(PI, List0, List) :- 3463 '$pi'(PI), 3464 !, 3465 '$canonical_pi'(PI, CPI), 3466 '$select'(P, List0, List), 3467 '$canonical_pi'(CPI, P), 3468 !. 3469'$import_except_1'(Except, _, _) :- 3470 throw(error(type_error(import_specifier, Except), _)). 3471 3472'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3473 '$canonical_pi'(PI2, CPI), 3474 !. 3475'$import_as'(PI, N, [H|T0], [H|T]) :- 3476 !, 3477 '$import_as'(PI, N, T0, T). 3478'$import_as'(PI, _, _, _) :- 3479 throw(error(existence_error(export, PI), _)). 3480 3481'$pi'(N/A) :- atom(N), integer(A), !. 3482'$pi'(N//A) :- atom(N), integer(A). 3483 3484'$canonical_pi'(N//A0, N/A) :- 3485 A is A0 + 2. 3486'$canonical_pi'(PI, PI). 3487 3488'$remove_ops'([], _, []). 3489'$remove_ops'([Op|T0], Pattern, T) :- 3490 subsumes_term(Pattern, Op), 3491 !, 3492 '$remove_ops'(T0, Pattern, T). 3493'$remove_ops'([H|T0], Pattern, [H|T]) :- 3494 '$remove_ops'(T0, Pattern, T).
3499'$import_all'(Import, Context, Source, Reexport, Strength) :-
3500 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3501 ( Reexport == true,
3502 ( '$list_to_conj'(Imported, Conj)
3503 -> export(Context:Conj),
3504 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3505 ; true
3506 ),
3507 source_location(File, _Line),
3508 '$export_ops'(ImpOps, Context, File)
3509 ; true
3510 ).
3514'$import_all2'([], _, _, [], [], _). 3515'$import_all2'([PI as NewName|Rest], Context, Source, 3516 [NewName/Arity|Imported], ImpOps, Strength) :- 3517 !, 3518 '$canonical_pi'(PI, Name/Arity), 3519 length(Args, Arity), 3520 Head =.. [Name|Args], 3521 NewHead =.. [NewName|Args], 3522 ( '$get_predicate_attribute'(Source:Head, transparent, 1) 3523 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3524 ; true 3525 ), 3526 ( source_location(File, Line) 3527 -> E = error(_,_), 3528 catch('$store_admin_clause'((NewHead :- Source:Head), 3529 _Layout, File, File:Line), 3530 E, '$print_message'(error, E)) 3531 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3532 ), % duplicate load 3533 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3534'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3535 [op(P,A,N)|ImpOps], Strength) :- 3536 !, 3537 '$import_ops'(Context, Source, op(P,A,N)), 3538 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3539'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3540 Error = error(_,_), 3541 catch(Context:'$import'(Source:Pred, Strength), Error, 3542 print_message(error, Error)), 3543 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3544 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3545 3546 3547'$list_to_conj'([One], One) :- !. 3548'$list_to_conj'([H|T], (H,Rest)) :- 3549 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3556'$exported_ops'(Module, Ops, Tail) :- 3557 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3558 !, 3559 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3560'$exported_ops'(_, Ops, Ops). 3561 3562'$exported_op'(Module, P, A, N) :- 3563 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3564 Module:'$exported_op'(P, A, N).
3571'$import_ops'(To, From, Pattern) :- 3572 ground(Pattern), 3573 !, 3574 Pattern = op(P,A,N), 3575 op(P,A,To:N), 3576 ( '$exported_op'(From, P, A, N) 3577 -> true 3578 ; print_message(warning, no_exported_op(From, Pattern)) 3579 ). 3580'$import_ops'(To, From, Pattern) :- 3581 ( '$exported_op'(From, Pri, Assoc, Name), 3582 Pattern = op(Pri, Assoc, Name), 3583 op(Pri, Assoc, To:Name), 3584 fail 3585 ; true 3586 ).
3594'$export_list'(Decls, Module, Ops) :- 3595 is_list(Decls), 3596 !, 3597 '$do_export_list'(Decls, Module, Ops). 3598'$export_list'(Decls, _, _) :- 3599 var(Decls), 3600 throw(error(instantiation_error, _)). 3601'$export_list'(Decls, _, _) :- 3602 throw(error(type_error(list, Decls), _)). 3603 3604'$do_export_list'([], _, []) :- !. 3605'$do_export_list'([H|T], Module, Ops) :- 3606 !, 3607 E = error(_,_), 3608 catch('$export1'(H, Module, Ops, Ops1), 3609 E, ('$print_message'(error, E), Ops = Ops1)), 3610 '$do_export_list'(T, Module, Ops1). 3611 3612'$export1'(Var, _, _, _) :- 3613 var(Var), 3614 !, 3615 throw(error(instantiation_error, _)). 3616'$export1'(Op, _, [Op|T], T) :- 3617 Op = op(_,_,_), 3618 !. 3619'$export1'(PI0, Module, Ops, Ops) :- 3620 strip_module(Module:PI0, M, PI), 3621 ( PI = (_//_) 3622 -> non_terminal(M:PI) 3623 ; true 3624 ), 3625 export(M:PI). 3626 3627'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3628 E = error(_,_), 3629 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File, []), 3630 '$export_op'(Pri, Assoc, Name, Module, File) 3631 ), 3632 E, '$print_message'(error, E)), 3633 '$export_ops'(T, Module, File). 3634'$export_ops'([], _, _). 3635 3636'$export_op'(Pri, Assoc, Name, Module, File) :- 3637 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3638 -> true 3639 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File, []) 3640 ), 3641 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3647'$execute_directive'(Var, _F, _Options) :- 3648 var(Var), 3649 '$instantiation_error'(Var). 3650'$execute_directive'(encoding(Encoding), _F, _Options) :- 3651 !, 3652 ( '$load_input'(_F, S) 3653 -> set_stream(S, encoding(Encoding)) 3654 ). 3655'$execute_directive'(Goal, _, Options) :- 3656 \+ '$compilation_mode'(database), 3657 !, 3658 '$add_directive_wic2'(Goal, Type, Options), 3659 ( Type == call % suspend compiling into .qlf file 3660 -> '$compilation_mode'(Old, database), 3661 setup_call_cleanup( 3662 '$directive_mode'(OldDir, Old), 3663 '$execute_directive_3'(Goal), 3664 ( '$set_compilation_mode'(Old), 3665 '$set_directive_mode'(OldDir) 3666 )) 3667 ; '$execute_directive_3'(Goal) 3668 ). 3669'$execute_directive'(Goal, _, _Options) :- 3670 '$execute_directive_3'(Goal). 3671 3672'$execute_directive_3'(Goal) :- 3673 '$current_source_module'(Module), 3674 '$valid_directive'(Module:Goal), 3675 !, 3676 ( '$pattr_directive'(Goal, Module) 3677 -> true 3678 ; Term = error(_,_), 3679 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3680 -> true 3681 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3682 fail 3683 ). 3684'$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.3693:- multifile prolog:sandbox_allowed_directive/1. 3694:- multifile prolog:sandbox_allowed_clause/1. 3695:- meta_predicate '$valid_directive'( ). 3696 3697'$valid_directive'(_) :- 3698 current_prolog_flag(sandboxed_load, false), 3699 !. 3700'$valid_directive'(Goal) :- 3701 Error = error(Formal, _), 3702 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3703 !, 3704 ( var(Formal) 3705 -> true 3706 ; print_message(error, Error), 3707 fail 3708 ). 3709'$valid_directive'(Goal) :- 3710 print_message(error, 3711 error(permission_error(execute, 3712 sandboxed_directive, 3713 Goal), _)), 3714 fail. 3715 3716'$exception_in_directive'(Term) :- 3717 '$print_message'(error, Term), 3718 fail.
load
or call
. Add a call
directive to the QLF file. load
directives continue the
compilation into the QLF file.3726'$add_directive_wic2'(Goal, Type, Options) :- 3727 '$common_goal_type'(Goal, Type, Options), 3728 !, 3729 ( Type == load 3730 -> true 3731 ; '$current_source_module'(Module), 3732 '$add_directive_wic'(Module:Goal) 3733 ). 3734'$add_directive_wic2'(Goal, _, _) :- 3735 ( '$compilation_mode'(qlf) % no problem for qlf files 3736 -> true 3737 ; print_message(error, mixed_directive(Goal)) 3738 ).
load
or call
.3745'$common_goal_type'((A,B), Type, Options) :- 3746 !, 3747 '$common_goal_type'(A, Type, Options), 3748 '$common_goal_type'(B, Type, Options). 3749'$common_goal_type'((A;B), Type, Options) :- 3750 !, 3751 '$common_goal_type'(A, Type, Options), 3752 '$common_goal_type'(B, Type, Options). 3753'$common_goal_type'((A->B), Type, Options) :- 3754 !, 3755 '$common_goal_type'(A, Type, Options), 3756 '$common_goal_type'(B, Type, Options). 3757'$common_goal_type'(Goal, Type, Options) :- 3758 '$goal_type'(Goal, Type, Options). 3759 3760'$goal_type'(Goal, Type, Options) :- 3761 ( '$load_goal'(Goal, Options) 3762 -> Type = load 3763 ; Type = call 3764 ). 3765 3766:- thread_local 3767 '$qlf':qinclude/1. 3768 3769'$load_goal'([_|_], _). 3770'$load_goal'(consult(_), _). 3771'$load_goal'(load_files(_), _). 3772'$load_goal'(load_files(_,Options), _) :- 3773 memberchk(qcompile(QlfMode), Options), 3774 '$qlf_part_mode'(QlfMode). 3775'$load_goal'(ensure_loaded(_), _) :- '$compilation_mode'(wic). 3776'$load_goal'(use_module(_), _) :- '$compilation_mode'(wic). 3777'$load_goal'(use_module(_, _), _) :- '$compilation_mode'(wic). 3778'$load_goal'(reexport(_), _) :- '$compilation_mode'(wic). 3779'$load_goal'(reexport(_, _), _) :- '$compilation_mode'(wic). 3780'$load_goal'(Goal, _Options) :- 3781 '$qlf':qinclude(user), 3782 '$load_goal_file'(Goal, File), 3783 '$all_user_files'(File). 3784 3785 3786'$load_goal_file'(load_files(F), F). 3787'$load_goal_file'(load_files(F, _), F). 3788'$load_goal_file'(ensure_loaded(F), F). 3789'$load_goal_file'(use_module(F), F). 3790'$load_goal_file'(use_module(F, _), F). 3791'$load_goal_file'(reexport(F), F). 3792'$load_goal_file'(reexport(F, _), F). 3793 3794'$all_user_files'([]) :- 3795 !. 3796'$all_user_files'([H|T]) :- 3797 !, 3798 '$is_user_file'(H), 3799 '$all_user_files'(T). 3800'$all_user_files'(F) :- 3801 ground(F), 3802 '$is_user_file'(F). 3803 3804'$is_user_file'(File) :- 3805 absolute_file_name(File, Path, 3806 [ file_type(prolog), 3807 access(read) 3808 ]), 3809 '$module_class'(Path, user, _). 3810 3811'$qlf_part_mode'(part). 3812'$qlf_part_mode'(true). % compatibility 3813 3814 3815 /******************************** 3816 * COMPILE A CLAUSE * 3817 *********************************/
3824'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3825 Owner \== (-), 3826 !, 3827 setup_call_cleanup( 3828 '$start_aux'(Owner, Context), 3829 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3830 '$end_aux'(Owner, Context)). 3831'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3832 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3833 3834'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3835 ( '$compilation_mode'(database) 3836 -> '$record_clause'(Clause, File, SrcLoc) 3837 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3838 '$qlf_assert_clause'(Ref, development) 3839 ).
3849'$store_clause'((_, _), _, _, _) :- 3850 !, 3851 print_message(error, cannot_redefine_comma), 3852 fail. 3853'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3854 nonvar(Pre), 3855 Pre = (Head,Cond), 3856 !, 3857 ( '$is_true'(Cond), current_prolog_flag(optimise, true) 3858 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc) 3859 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc) 3860 ). 3861'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3862 '$valid_clause'(Clause), 3863 !, 3864 ( '$compilation_mode'(database) 3865 -> '$record_clause'(Clause, File, SrcLoc) 3866 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3867 '$qlf_assert_clause'(Ref, development) 3868 ). 3869 3870'$is_true'(true) => true. 3871'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B). 3872'$is_true'(_) => fail. 3873 3874'$valid_clause'(_) :- 3875 current_prolog_flag(sandboxed_load, false), 3876 !. 3877'$valid_clause'(Clause) :- 3878 \+ '$cross_module_clause'(Clause), 3879 !. 3880'$valid_clause'(Clause) :- 3881 Error = error(Formal, _), 3882 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3883 !, 3884 ( var(Formal) 3885 -> true 3886 ; print_message(error, Error), 3887 fail 3888 ). 3889'$valid_clause'(Clause) :- 3890 print_message(error, 3891 error(permission_error(assert, 3892 sandboxed_clause, 3893 Clause), _)), 3894 fail. 3895 3896'$cross_module_clause'(Clause) :- 3897 '$head_module'(Clause, Module), 3898 \+ '$current_source_module'(Module). 3899 3900'$head_module'(Var, _) :- 3901 var(Var), !, fail. 3902'$head_module'((Head :- _), Module) :- 3903 '$head_module'(Head, Module). 3904'$head_module'(Module:_, Module). 3905 3906'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3907'$clause_source'(Clause, Clause, -).
3914:- public 3915 '$store_clause'/2. 3916 3917'$store_clause'(Term, Id) :- 3918 '$clause_source'(Term, Clause, SrcLoc), 3919 '$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)
3940compile_aux_clauses(_Clauses) :- 3941 current_prolog_flag(xref, true), 3942 !. 3943compile_aux_clauses(Clauses) :- 3944 source_location(File, _Line), 3945 '$compile_aux_clauses'(Clauses, File). 3946 3947'$compile_aux_clauses'(Clauses, File) :- 3948 setup_call_cleanup( 3949 '$start_aux'(File, Context), 3950 '$store_aux_clauses'(Clauses, File), 3951 '$end_aux'(File, Context)). 3952 3953'$store_aux_clauses'(Clauses, File) :- 3954 is_list(Clauses), 3955 !, 3956 forall('$member'(C,Clauses), 3957 '$compile_term'(C, _Layout, File, [])). 3958'$store_aux_clauses'(Clause, File) :- 3959 '$compile_term'(Clause, _Layout, File, []). 3960 3961 3962 /******************************* 3963 * STAGING * 3964 *******************************/
3974'$stage_file'(Target, Stage) :- 3975 file_directory_name(Target, Dir), 3976 file_base_name(Target, File), 3977 current_prolog_flag(pid, Pid), 3978 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 3979 3980'$install_staged_file'(exit, Staged, Target, error) :- 3981 !, 3982 rename_file(Staged, Target). 3983'$install_staged_file'(exit, Staged, Target, OnError) :- 3984 !, 3985 InstallError = error(_,_), 3986 catch(rename_file(Staged, Target), 3987 InstallError, 3988 '$install_staged_error'(OnError, InstallError, Staged, Target)). 3989'$install_staged_file'(_, Staged, _, _OnError) :- 3990 E = error(_,_), 3991 catch(delete_file(Staged), E, true). 3992 3993'$install_staged_error'(OnError, Error, Staged, _Target) :- 3994 E = error(_,_), 3995 catch(delete_file(Staged), E, true), 3996 ( OnError = silent 3997 -> true 3998 ; OnError = fail 3999 -> fail 4000 ; print_message(warning, Error) 4001 ). 4002 4003 4004 /******************************* 4005 * READING * 4006 *******************************/ 4007 4008:- multifile 4009 prolog:comment_hook/3. % hook for read_clause/3 4010 4011 4012 /******************************* 4013 * FOREIGN INTERFACE * 4014 *******************************/ 4015 4016% call-back from PL_register_foreign(). First argument is the module 4017% into which the foreign predicate is loaded and second is a term 4018% describing the arguments. 4019 4020:- dynamic 4021 '$foreign_registered'/2. 4022 4023 /******************************* 4024 * TEMPORARY TERM EXPANSION * 4025 *******************************/ 4026 4027% Provide temporary definitions for the boot-loader. These are replaced 4028% by the real thing in load.pl 4029 4030:- dynamic 4031 '$expand_goal'/2, 4032 '$expand_term'/4. 4033 4034'$expand_goal'(In, In). 4035'$expand_term'(In, Layout, In, Layout). 4036 4037 4038 /******************************* 4039 * TYPE SUPPORT * 4040 *******************************/ 4041 4042'$type_error'(Type, Value) :- 4043 ( var(Value) 4044 -> throw(error(instantiation_error, _)) 4045 ; throw(error(type_error(Type, Value), _)) 4046 ). 4047 4048'$domain_error'(Type, Value) :- 4049 throw(error(domain_error(Type, Value), _)). 4050 4051'$existence_error'(Type, Object) :- 4052 throw(error(existence_error(Type, Object), _)). 4053 4054'$permission_error'(Action, Type, Term) :- 4055 throw(error(permission_error(Action, Type, Term), _)). 4056 4057'$instantiation_error'(_Var) :- 4058 throw(error(instantiation_error, _)). 4059 4060'$uninstantiation_error'(NonVar) :- 4061 throw(error(uninstantiation_error(NonVar), _)). 4062 4063'$must_be'(list, X) :- !, 4064 '$skip_list'(_, X, Tail), 4065 ( Tail == [] 4066 -> true 4067 ; '$type_error'(list, Tail) 4068 ). 4069'$must_be'(options, X) :- !, 4070 ( '$is_options'(X) 4071 -> true 4072 ; '$type_error'(options, X) 4073 ). 4074'$must_be'(atom, X) :- !, 4075 ( atom(X) 4076 -> true 4077 ; '$type_error'(atom, X) 4078 ). 4079'$must_be'(integer, X) :- !, 4080 ( integer(X) 4081 -> true 4082 ; '$type_error'(integer, X) 4083 ). 4084'$must_be'(between(Low,High), X) :- !, 4085 ( integer(X) 4086 -> ( between(Low, High, X) 4087 -> true 4088 ; '$domain_error'(between(Low,High), X) 4089 ) 4090 ; '$type_error'(integer, X) 4091 ). 4092'$must_be'(callable, X) :- !, 4093 ( callable(X) 4094 -> true 4095 ; '$type_error'(callable, X) 4096 ). 4097'$must_be'(acyclic, X) :- !, 4098 ( acyclic_term(X) 4099 -> true 4100 ; '$domain_error'(acyclic_term, X) 4101 ). 4102'$must_be'(oneof(Type, Domain, List), X) :- !, 4103 '$must_be'(Type, X), 4104 ( memberchk(X, List) 4105 -> true 4106 ; '$domain_error'(Domain, X) 4107 ). 4108'$must_be'(boolean, X) :- !, 4109 ( (X == true ; X == false) 4110 -> true 4111 ; '$type_error'(boolean, X) 4112 ). 4113'$must_be'(ground, X) :- !, 4114 ( ground(X) 4115 -> true 4116 ; '$instantiation_error'(X) 4117 ). 4118'$must_be'(filespec, X) :- !, 4119 ( ( atom(X) 4120 ; string(X) 4121 ; compound(X), 4122 compound_name_arity(X, _, 1) 4123 ) 4124 -> true 4125 ; '$type_error'(filespec, X) 4126 ). 4127 4128% Use for debugging 4129%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 4130 4131 4132 /******************************** 4133 * LIST PROCESSING * 4134 *********************************/ 4135 4136'$member'(El, [H|T]) :- 4137 '$member_'(T, El, H). 4138 4139'$member_'(_, El, El). 4140'$member_'([H|T], El, _) :- 4141 '$member_'(T, El, H). 4142 4143'$append'([], L, L). 4144'$append'([H|T], L, [H|R]) :- 4145 '$append'(T, L, R). 4146 4147'$append'(ListOfLists, List) :- 4148 '$must_be'(list, ListOfLists), 4149 '$append_'(ListOfLists, List). 4150 4151'$append_'([], []). 4152'$append_'([L|Ls], As) :- 4153 '$append'(L, Ws, As), 4154 '$append_'(Ls, Ws). 4155 4156'$select'(X, [X|Tail], Tail). 4157'$select'(Elem, [Head|Tail], [Head|Rest]) :- 4158 '$select'(Elem, Tail, Rest). 4159 4160'$reverse'(L1, L2) :- 4161 '$reverse'(L1, [], L2). 4162 4163'$reverse'([], List, List). 4164'$reverse'([Head|List1], List2, List3) :- 4165 '$reverse'(List1, [Head|List2], List3). 4166 4167'$delete'([], _, []) :- !. 4168'$delete'([Elem|Tail], Elem, Result) :- 4169 !, 4170 '$delete'(Tail, Elem, Result). 4171'$delete'([Head|Tail], Elem, [Head|Rest]) :- 4172 '$delete'(Tail, Elem, Rest). 4173 4174'$last'([H|T], Last) :- 4175 '$last'(T, H, Last). 4176 4177'$last'([], Last, Last). 4178'$last'([H|T], _, Last) :- 4179 '$last'(T, H, Last).
4186:- '$iso'((length/2)). 4187 4188length(List, Length) :- 4189 var(Length), 4190 !, 4191 '$skip_list'(Length0, List, Tail), 4192 ( Tail == [] 4193 -> Length = Length0 % +,- 4194 ; var(Tail) 4195 -> Tail \== Length, % avoid length(L,L) 4196 '$length3'(Tail, Length, Length0) % -,- 4197 ; throw(error(type_error(list, List), 4198 context(length/2, _))) 4199 ). 4200length(List, Length) :- 4201 integer(Length), 4202 Length >= 0, 4203 !, 4204 '$skip_list'(Length0, List, Tail), 4205 ( Tail == [] % proper list 4206 -> Length = Length0 4207 ; var(Tail) 4208 -> Extra is Length-Length0, 4209 '$length'(Tail, Extra) 4210 ; throw(error(type_error(list, List), 4211 context(length/2, _))) 4212 ). 4213length(_, Length) :- 4214 integer(Length), 4215 !, 4216 throw(error(domain_error(not_less_than_zero, Length), 4217 context(length/2, _))). 4218length(_, Length) :- 4219 throw(error(type_error(integer, Length), 4220 context(length/2, _))). 4221 4222'$length3'([], N, N). 4223'$length3'([_|List], N, N0) :- 4224 N1 is N0+1, 4225 '$length3'(List, N, N1). 4226 4227 4228 /******************************* 4229 * OPTION PROCESSING * 4230 *******************************/
4236'$is_options'(Map) :- 4237 is_dict(Map, _), 4238 !. 4239'$is_options'(List) :- 4240 is_list(List), 4241 ( List == [] 4242 -> true 4243 ; List = [H|_], 4244 '$is_option'(H, _, _) 4245 ). 4246 4247'$is_option'(Var, _, _) :- 4248 var(Var), !, fail. 4249'$is_option'(F, Name, Value) :- 4250 functor(F, _, 1), 4251 !, 4252 F =.. [Name,Value]. 4253'$is_option'(Name=Value, Name, Value).
4257'$option'(Opt, Options) :- 4258 is_dict(Options), 4259 !, 4260 [Opt] :< Options. 4261'$option'(Opt, Options) :- 4262 memberchk(Opt, Options).
4266'$option'(Term, Options, Default) :-
4267 arg(1, Term, Value),
4268 functor(Term, Name, 1),
4269 ( is_dict(Options)
4270 -> ( get_dict(Name, Options, GVal)
4271 -> Value = GVal
4272 ; Value = Default
4273 )
4274 ; functor(Gen, Name, 1),
4275 arg(1, Gen, GVal),
4276 ( memberchk(Gen, Options)
4277 -> Value = GVal
4278 ; Value = Default
4279 )
4280 ).
4288'$select_option'(Opt, Options, Rest) :-
4289 select_dict([Opt], Options, Rest).
4297'$merge_options'(New, Old, Merged) :- 4298 put_dict(New, Old, Merged). 4299 4300 4301 /******************************* 4302 * HANDLE TRACER 'L'-COMMAND * 4303 *******************************/ 4304 4305:- public '$prolog_list_goal'/1. 4306 4307:- multifile 4308 user:prolog_list_goal/1. 4309 4310'$prolog_list_goal'(Goal) :- 4311 user:prolog_list_goal(Goal), 4312 !. 4313'$prolog_list_goal'(Goal) :- 4314 use_module(library(listing), [listing/1]), 4315 @(listing(Goal), user). 4316 4317 4318 /******************************* 4319 * HALT * 4320 *******************************/ 4321 4322:- '$iso'((halt/0)). 4323 4324halt :- 4325 '$exit_code'(Code), 4326 ( Code == 0 4327 -> true 4328 ; print_message(warning, on_error(halt(1))) 4329 ), 4330 halt(Code).
on_error
and on_warning
flags. Also used by qsave_toplevel/0.
4337'$exit_code'(Code) :-
4338 ( ( current_prolog_flag(on_error, status),
4339 statistics(errors, Count),
4340 Count > 0
4341 ; current_prolog_flag(on_warning, status),
4342 statistics(warnings, Count),
4343 Count > 0
4344 )
4345 -> Code = 1
4346 ; Code = 0
4347 ).
4356:- meta_predicate at_halt( ). 4357:- dynamic system:term_expansion/2, '$at_halt'/2. 4358:- multifile system:term_expansion/2, '$at_halt'/2. 4359 4360systemterm_expansion((:- at_halt(Goal)), 4361 system:'$at_halt'(Module:Goal, File:Line)) :- 4362 \+ current_prolog_flag(xref, true), 4363 source_location(File, Line), 4364 '$current_source_module'(Module). 4365 4366at_halt(Goal) :- 4367 asserta('$at_halt'(Goal, (-):0)). 4368 4369:- public '$run_at_halt'/0. 4370 4371'$run_at_halt' :- 4372 forall(clause('$at_halt'(Goal, Src), true, Ref), 4373 ( '$call_at_halt'(Goal, Src), 4374 erase(Ref) 4375 )). 4376 4377'$call_at_halt'(Goal, _Src) :- 4378 catch(Goal, E, true), 4379 !, 4380 ( var(E) 4381 -> true 4382 ; subsumes_term(cancel_halt(_), E) 4383 -> '$print_message'(informational, E), 4384 fail 4385 ; '$print_message'(error, E) 4386 ). 4387'$call_at_halt'(Goal, _Src) :- 4388 '$print_message'(warning, goal_failed(at_halt, Goal)).
4396cancel_halt(Reason) :-
4397 throw(cancel_halt(Reason)).
heartbeat
is
non-zero.4404:- multifile prolog:heartbeat/0. 4405 4406 4407 /******************************** 4408 * LOAD OTHER MODULES * 4409 *********************************/ 4410 4411:- meta_predicate 4412 '$load_wic_files'( ). 4413 4414'$load_wic_files'(Files) :- 4415 Files = Module:_, 4416 '$execute_directive'('$set_source_module'(OldM, Module), [], []), 4417 '$save_lex_state'(LexState, []), 4418 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4419 '$compilation_mode'(OldC, wic), 4420 consult(Files), 4421 '$execute_directive'('$set_source_module'(OldM), [], []), 4422 '$execute_directive'('$restore_lex_state'(LexState), [], []), 4423 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4431:- public '$load_additional_boot_files'/0. 4432 4433'$load_additional_boot_files' :- 4434 current_prolog_flag(argv, Argv), 4435 '$get_files_argv'(Argv, Files), 4436 ( Files \== [] 4437 -> format('Loading additional boot files~n'), 4438 '$load_wic_files'(user:Files), 4439 format('additional boot files loaded~n') 4440 ; true 4441 ). 4442 4443'$get_files_argv'([], []) :- !. 4444'$get_files_argv'(['-c'|Files], Files) :- !. 4445'$get_files_argv'([_|Rest], Files) :- 4446 '$get_files_argv'(Rest, Files). 4447 4448'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4449 source_location(File, _Line), 4450 file_directory_name(File, Dir), 4451 atom_concat(Dir, '/load.pl', LoadFile), 4452 '$load_wic_files'(system:[LoadFile]), 4453 ( current_prolog_flag(windows, true) 4454 -> atom_concat(Dir, '/menu.pl', MenuFile), 4455 '$load_wic_files'(system:[MenuFile]) 4456 ; true 4457 ), 4458 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4459 '$compilation_mode'(OldC, wic), 4460 '$execute_directive'('$set_source_module'(user), [], []), 4461 '$set_compilation_mode'(OldC) 4462 ))