1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 1985-2021, University of Amsterdam 7 VU University Amsterdam 8 CWI, Amsterdam 9 SWI-Prolog Solutions b.v. 10 All rights reserved. 11 12 Redistribution and use in source and binary forms, with or without 13 modification, are permitted provided that the following conditions 14 are met: 15 16 1. Redistributions of source code must retain the above copyright 17 notice, this list of conditions and the following disclaimer. 18 19 2. Redistributions in binary form must reproduce the above copyright 20 notice, this list of conditions and the following disclaimer in 21 the documentation and/or other materials provided with the 22 distribution. 23 24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 29 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 30 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 32 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 33 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 POSSIBILITY OF SUCH DAMAGE. 36*/ 37 38/* 39Consult, derivates and basic things. This module is loaded by the 40C-written bootstrap compiler. 41 42The $:- directive is executed by the bootstrap compiler, but not 43inserted in the intermediate code file. Used to print diagnostic 44messages and start the Prolog defined compiler for the remaining boot 45modules. 46 47If you want to debug this module, put a '$:-'(trace). directive 48somewhere. The tracer will work properly under boot compilation as it 49will use the C defined write predicate to print goals and does not 50attempt to call the Prolog defined trace interceptor. 51*/ 52 53 /******************************** 54 * LOAD INTO MODULE SYSTEM * 55 ********************************/ 56 57:- '$set_source_module'(system). 58 59'$boot_message'(_Format, _Args) :- 60 current_prolog_flag(verbose, silent), 61 !. 62'$boot_message'(Format, Args) :- 63 format(Format, Args), 64 !. 65 66'$:-'('$boot_message'('Loading boot file ...~n', [])). 67 68 69 /******************************** 70 * DIRECTIVES * 71 *********************************/ 72 73:- meta_predicate 74 dynamic( ), 75 multifile( ), 76 public( ), 77 module_transparent( ), 78 discontiguous( ), 79 volatile( ), 80 thread_local( ), 81 noprofile( ), 82 non_terminal( ), 83 '$clausable'( ), 84 '$iso'( ), 85 '$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.117dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)). 118multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)). 119module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)). 120discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)). 121volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)). 122thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)). 123noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)). 124public(Spec) :- '$set_pattr'(Spec, pred, public(true)). 125non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)). 126det(Spec) :- '$set_pattr'(Spec, pred, det(true)). 127'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)). 128'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)). 129'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)). 130 131'$set_pattr'(M:Pred, How, Attr) :- 132 '$set_pattr'(Pred, M, How, Attr).
pred
or directive
.138'$set_pattr'(X, _, _, _) :- 139 var(X), 140 '$uninstantiation_error'(X). 141'$set_pattr'(as(Spec,Options), M, How, Attr0) :- 142 !, 143 '$attr_options'(Options, Attr0, Attr), 144 '$set_pattr'(Spec, M, How, Attr). 145'$set_pattr'([], _, _, _) :- !. 146'$set_pattr'([H|T], M, How, Attr) :- % ISO 147 !, 148 '$set_pattr'(H, M, How, Attr), 149 '$set_pattr'(T, M, How, Attr). 150'$set_pattr'((A,B), M, How, Attr) :- % ISO and traditional 151 !, 152 '$set_pattr'(A, M, How, Attr), 153 '$set_pattr'(B, M, How, Attr). 154'$set_pattr'(M:T, _, How, Attr) :- 155 !, 156 '$set_pattr'(T, M, How, Attr). 157'$set_pattr'(PI, M, _, []) :- 158 !, 159 '$pi_head'(M:PI, Pred), 160 '$set_table_wrappers'(Pred). 161'$set_pattr'(A, M, How, [O|OT]) :- 162 !, 163 '$set_pattr'(A, M, How, O), 164 '$set_pattr'(A, M, How, OT). 165'$set_pattr'(A, M, pred, Attr) :- 166 !, 167 Attr =.. [Name,Val], 168 '$set_pi_attr'(M:A, Name, Val). 169'$set_pattr'(A, M, directive, Attr) :- 170 !, 171 Attr =.. [Name,Val], 172 catch('$set_pi_attr'(M:A, Name, Val), 173 error(E, _), 174 print_message(error, error(E, context((Name)/1,_)))). 175 176'$set_pi_attr'(PI, Name, Val) :- 177 '$pi_head'(PI, Head), 178 '$set_predicate_attribute'(Head, Name, Val). 179 180'$attr_options'(Var, _, _) :- 181 var(Var), 182 !, 183 '$uninstantiation_error'(Var). 184'$attr_options'((A,B), Attr0, Attr) :- 185 !, 186 '$attr_options'(A, Attr0, Attr1), 187 '$attr_options'(B, Attr1, Attr). 188'$attr_options'(Opt, Attr0, Attrs) :- 189 '$must_be'(ground, Opt), 190 ( '$attr_option'(Opt, AttrX) 191 -> ( is_list(Attr0) 192 -> '$join_attrs'(AttrX, Attr0, Attrs) 193 ; '$join_attrs'(AttrX, [Attr0], Attrs) 194 ) 195 ; '$domain_error'(predicate_option, Opt) 196 ). 197 198'$join_attrs'([], Attrs, Attrs) :- 199 !. 200'$join_attrs'([H|T], Attrs0, Attrs) :- 201 !, 202 '$join_attrs'(H, Attrs0, Attrs1), 203 '$join_attrs'(T, Attrs1, Attrs). 204'$join_attrs'(Attr, Attrs, Attrs) :- 205 memberchk(Attr, Attrs), 206 !. 207'$join_attrs'(Attr, Attrs, Attrs) :- 208 Attr =.. [Name,Value], 209 Gen =.. [Name,Existing], 210 memberchk(Gen, Attrs), 211 !, 212 throw(error(conflict_error(Name, Value, Existing), _)). 213'$join_attrs'(Attr, Attrs0, Attrs) :- 214 '$append'(Attrs0, [Attr], Attrs). 215 216'$attr_option'(incremental, [incremental(true),opaque(false)]). 217'$attr_option'(monotonic, monotonic(true)). 218'$attr_option'(lazy, lazy(true)). 219'$attr_option'(opaque, [incremental(false),opaque(true)]). 220'$attr_option'(abstract(Level0), abstract(Level)) :- 221 '$table_option'(Level0, Level). 222'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :- 223 '$table_option'(Level0, Level). 224'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :- 225 '$table_option'(Level0, Level). 226'$attr_option'(max_answers(Level0), max_answers(Level)) :- 227 '$table_option'(Level0, Level). 228'$attr_option'(volatile, volatile(true)). 229'$attr_option'(multifile, multifile(true)). 230'$attr_option'(discontiguous, discontiguous(true)). 231'$attr_option'(shared, thread_local(false)). 232'$attr_option'(local, thread_local(true)). 233'$attr_option'(private, thread_local(true)). 234 235'$table_option'(Value0, _Value) :- 236 var(Value0), 237 !, 238 '$instantiation_error'(Value0). 239'$table_option'(Value0, Value) :- 240 integer(Value0), 241 Value0 >= 0, 242 !, 243 Value = Value0. 244'$table_option'(off, -1) :- 245 !. 246'$table_option'(false, -1) :- 247 !. 248'$table_option'(infinite, -1) :- 249 !. 250'$table_option'(Value, _) :- 251 '$domain_error'(nonneg_or_false, Value).
261'$pattr_directive'(dynamic(Spec), M) :- 262 '$set_pattr'(Spec, M, directive, dynamic(true)). 263'$pattr_directive'(multifile(Spec), M) :- 264 '$set_pattr'(Spec, M, directive, multifile(true)). 265'$pattr_directive'(module_transparent(Spec), M) :- 266 '$set_pattr'(Spec, M, directive, transparent(true)). 267'$pattr_directive'(discontiguous(Spec), M) :- 268 '$set_pattr'(Spec, M, directive, discontiguous(true)). 269'$pattr_directive'(volatile(Spec), M) :- 270 '$set_pattr'(Spec, M, directive, volatile(true)). 271'$pattr_directive'(thread_local(Spec), M) :- 272 '$set_pattr'(Spec, M, directive, thread_local(true)). 273'$pattr_directive'(noprofile(Spec), M) :- 274 '$set_pattr'(Spec, M, directive, noprofile(true)). 275'$pattr_directive'(public(Spec), M) :- 276 '$set_pattr'(Spec, M, directive, public(true)). 277'$pattr_directive'(det(Spec), M) :- 278 '$set_pattr'(Spec, M, directive, det(true)).
282'$pi_head'(PI, Head) :- 283 var(PI), 284 var(Head), 285 '$instantiation_error'([PI,Head]). 286'$pi_head'(M:PI, M:Head) :- 287 !, 288 '$pi_head'(PI, Head). 289'$pi_head'(Name/Arity, Head) :- 290 !, 291 '$head_name_arity'(Head, Name, Arity). 292'$pi_head'(Name//DCGArity, Head) :- 293 !, 294 ( nonvar(DCGArity) 295 -> Arity is DCGArity+2, 296 '$head_name_arity'(Head, Name, Arity) 297 ; '$head_name_arity'(Head, Name, Arity), 298 DCGArity is Arity - 2 299 ). 300'$pi_head'(PI, _) :- 301 '$type_error'(predicate_indicator, PI).
306'$head_name_arity'(Goal, Name, Arity) :- 307 ( atom(Goal) 308 -> Name = Goal, Arity = 0 309 ; compound(Goal) 310 -> compound_name_arity(Goal, Name, Arity) 311 ; var(Goal) 312 -> ( Arity == 0 313 -> ( atom(Name) 314 -> Goal = Name 315 ; Name == [] 316 -> Goal = Name 317 ; blob(Name, closure) 318 -> Goal = Name 319 ; '$type_error'(atom, Name) 320 ) 321 ; compound_name_arity(Goal, Name, Arity) 322 ) 323 ; '$type_error'(callable, Goal) 324 ). 325 326:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 327 328 329 /******************************** 330 * CALLING, CONTROL * 331 *********************************/ 332 333:- noprofile((call/1, 334 catch/3, 335 once/1, 336 ignore/1, 337 call_cleanup/2, 338 call_cleanup/3, 339 setup_call_cleanup/3, 340 setup_call_catcher_cleanup/4)). 341 342:- meta_predicate 343 ';'( , ), 344 ','( , ), 345 @( , ), 346 call( ), 347 call( , ), 348 call( , , ), 349 call( , , , ), 350 call( , , , , ), 351 call( , , , , , ), 352 call( , , , , , , ), 353 call( , , , , , , , ), 354 not( ), 355 \+( ), 356 $( ), 357 '->'( , ), 358 '*->'( , ), 359 once( ), 360 ignore( ), 361 catch( , , ), 362 reset( , , ), 363 setup_call_cleanup( , , ), 364 setup_call_catcher_cleanup( , , , ), 365 call_cleanup( , ), 366 call_cleanup( , , ), 367 catch_with_backtrace( , , ), 368 '$meta_call'( ). 369 370:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 371 372% The control structures are always compiled, both if they appear in a 373% clause body and if they are handed to call/1. The only way to call 374% these predicates is by means of call/2.. In that case, we call the 375% hole control structure again to get it compiled by call/1 and properly 376% deal with !, etc. Another reason for having these things as 377% predicates is to be able to define properties for them, helping code 378% analyzers. 379 380(M0:If ; M0:Then) :- !, call(M0:(If ; Then)). 381(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)). 382(G1 , G2) :- call((G1 , G2)). 383(If -> Then) :- call((If -> Then)). 384(If *-> Then) :- call((If *-> Then)). 385@(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.
399'$meta_call'(M:G) :- 400 prolog_current_choice(Ch), 401 '$meta_call'(G, M, Ch). 402 403'$meta_call'(Var, _, _) :- 404 var(Var), 405 !, 406 '$instantiation_error'(Var). 407'$meta_call'((A,B), M, Ch) :- 408 !, 409 '$meta_call'(A, M, Ch), 410 '$meta_call'(B, M, Ch). 411'$meta_call'((I->T;E), M, Ch) :- 412 !, 413 ( prolog_current_choice(Ch2), 414 '$meta_call'(I, M, Ch2) 415 -> '$meta_call'(T, M, Ch) 416 ; '$meta_call'(E, M, Ch) 417 ). 418'$meta_call'((I*->T;E), M, Ch) :- 419 !, 420 ( prolog_current_choice(Ch2), 421 '$meta_call'(I, M, Ch2) 422 *-> '$meta_call'(T, M, Ch) 423 ; '$meta_call'(E, M, Ch) 424 ). 425'$meta_call'((I->T), M, Ch) :- 426 !, 427 ( prolog_current_choice(Ch2), 428 '$meta_call'(I, M, Ch2) 429 -> '$meta_call'(T, M, Ch) 430 ). 431'$meta_call'((I*->T), M, Ch) :- 432 !, 433 prolog_current_choice(Ch2), 434 '$meta_call'(I, M, Ch2), 435 '$meta_call'(T, M, Ch). 436'$meta_call'((A;B), M, Ch) :- 437 !, 438 ( '$meta_call'(A, M, Ch) 439 ; '$meta_call'(B, M, Ch) 440 ). 441'$meta_call'(\+(G), M, _) :- 442 !, 443 prolog_current_choice(Ch), 444 \+ '$meta_call'(G, M, Ch). 445'$meta_call'($(G), M, _) :- 446 !, 447 prolog_current_choice(Ch), 448 $('$meta_call'(G, M, Ch)). 449'$meta_call'(call(G), M, _) :- 450 !, 451 prolog_current_choice(Ch), 452 '$meta_call'(G, M, Ch). 453'$meta_call'(M:G, _, Ch) :- 454 !, 455 '$meta_call'(G, M, Ch). 456'$meta_call'(!, _, Ch) :- 457 prolog_cut_to(Ch). 458'$meta_call'(G, M, _Ch) :- 459 call(M:G).
475:- '$iso'((call/2, 476 call/3, 477 call/4, 478 call/5, 479 call/6, 480 call/7, 481 call/8)). 482 483call(Goal) :- % make these available as predicates 484 . 485call(Goal, A) :- 486 call(Goal, A). 487call(Goal, A, B) :- 488 call(Goal, A, B). 489call(Goal, A, B, C) :- 490 call(Goal, A, B, C). 491call(Goal, A, B, C, D) :- 492 call(Goal, A, B, C, D). 493call(Goal, A, B, C, D, E) :- 494 call(Goal, A, B, C, D, E). 495call(Goal, A, B, C, D, E, F) :- 496 call(Goal, A, B, C, D, E, F). 497call(Goal, A, B, C, D, E, F, G) :- 498 call(Goal, A, B, C, D, E, F, G).
505not(Goal) :-
506 \+ .
512\+ Goal :-
513 \+ .
call((Goal, !))
.
519once(Goal) :-
520 ,
521 !.
528ignore(Goal) :- 529 , 530 !. 531ignore(_Goal). 532 533:- '$iso'((false/0)).
539false :-
540 fail.
546catch(_Goal, _Catcher, _Recover) :- 547 '$catch'. % Maps to I_CATCH, I_EXITCATCH
553prolog_cut_to(_Choice) :- 554 '$cut'. % Maps to I_CUTCHP
560'$' :- '$'.
566$(Goal) :- $(Goal).
572reset(_Goal, _Ball, _Cont) :-
573 '$reset'.
582shift(Ball) :- 583 '$shift'(Ball). 584 585shift_for_copy(Ball) :- 586 '$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.
600call_continuation([]). 601call_continuation([TB|Rest]) :- 602 ( Rest == [] 603 -> '$call_continuation'(TB) 604 ; '$call_continuation'(TB), 605 call_continuation(Rest) 606 ).
613catch_with_backtrace(Goal, Ball, Recover) :- 614 catch(Goal, Ball, Recover), 615 '$no_lco'. 616 617'$no_lco'.
627:- public '$recover_and_rethrow'/2. 628 629'$recover_and_rethrow'(Goal, Exception) :- 630 call_cleanup(Goal, throw(Exception)), 631 !.
646setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :- 647 '$sig_atomic'(Setup), 648 '$call_cleanup'. 649 650setup_call_cleanup(Setup, Goal, Cleanup) :- 651 setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup). 652 653call_cleanup(Goal, Cleanup) :- 654 setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup). 655 656call_cleanup(Goal, Catcher, Cleanup) :- 657 setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup). 658 659 /******************************* 660 * INITIALIZATION * 661 *******************************/ 662 663:- meta_predicate 664 initialization( , ). 665 666:- multifile '$init_goal'/3. 667:- dynamic '$init_goal'/3.
-g goal
goals.Note that all goals are executed when a program is restored.
693initialization(Goal, When) :- 694 '$must_be'(oneof(atom, initialization_type, 695 [ now, 696 after_load, 697 restore, 698 restore_state, 699 prepare_state, 700 program, 701 main 702 ]), When), 703 '$initialization_context'(Source, Ctx), 704 '$initialization'(When, Goal, Source, Ctx). 705 706'$initialization'(now, Goal, _Source, Ctx) :- 707 '$run_init_goal'(Goal, Ctx), 708 '$compile_init_goal'(-, Goal, Ctx). 709'$initialization'(after_load, Goal, Source, Ctx) :- 710 ( Source \== (-) 711 -> '$compile_init_goal'(Source, Goal, Ctx) 712 ; throw(error(context_error(nodirective, 713 initialization(Goal, after_load)), 714 _)) 715 ). 716'$initialization'(restore, Goal, Source, Ctx) :- % deprecated 717 '$initialization'(restore_state, Goal, Source, Ctx). 718'$initialization'(restore_state, Goal, _Source, Ctx) :- 719 ( \+ current_prolog_flag(sandboxed_load, true) 720 -> '$compile_init_goal'(-, Goal, Ctx) 721 ; '$permission_error'(register, initialization(restore), Goal) 722 ). 723'$initialization'(prepare_state, Goal, _Source, Ctx) :- 724 ( \+ current_prolog_flag(sandboxed_load, true) 725 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx) 726 ; '$permission_error'(register, initialization(restore), Goal) 727 ). 728'$initialization'(program, Goal, _Source, Ctx) :- 729 ( \+ current_prolog_flag(sandboxed_load, true) 730 -> '$compile_init_goal'(when(program), Goal, Ctx) 731 ; '$permission_error'(register, initialization(restore), Goal) 732 ). 733'$initialization'(main, Goal, _Source, Ctx) :- 734 ( \+ current_prolog_flag(sandboxed_load, true) 735 -> '$compile_init_goal'(when(main), Goal, Ctx) 736 ; '$permission_error'(register, initialization(restore), Goal) 737 ). 738 739 740'$compile_init_goal'(Source, Goal, Ctx) :- 741 atom(Source), 742 Source \== (-), 743 !, 744 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx), 745 _Layout, Source, Ctx). 746'$compile_init_goal'(Source, Goal, Ctx) :- 747 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.759'$run_initialization'(_, loaded, _) :- !. 760'$run_initialization'(File, _Action, Options) :- 761 '$run_initialization'(File, Options). 762 763'$run_initialization'(File, Options) :- 764 setup_call_cleanup( 765 '$start_run_initialization'(Options, Restore), 766 '$run_initialization_2'(File), 767 '$end_run_initialization'(Restore)). 768 769'$start_run_initialization'(Options, OldSandBoxed) :- 770 '$push_input_context'(initialization), 771 '$set_sandboxed_load'(Options, OldSandBoxed). 772'$end_run_initialization'(OldSandBoxed) :- 773 set_prolog_flag(sandboxed_load, OldSandBoxed), 774 '$pop_input_context'. 775 776'$run_initialization_2'(File) :- 777 ( '$init_goal'(File, Goal, Ctx), 778 File \= when(_), 779 '$run_init_goal'(Goal, Ctx), 780 fail 781 ; true 782 ). 783 784'$run_init_goal'(Goal, Ctx) :- 785 ( catch_with_backtrace('$run_init_goal'(Goal), E, 786 '$initialization_error'(E, Goal, Ctx)) 787 -> true 788 ; '$initialization_failure'(Goal, Ctx) 789 ). 790 791:- multifile prolog:sandbox_allowed_goal/1. 792 793'$run_init_goal'(Goal) :- 794 current_prolog_flag(sandboxed_load, false), 795 !, 796 call(Goal). 797'$run_init_goal'(Goal) :- 798 prolog:sandbox_allowed_goal(Goal), 799 call(Goal). 800 801'$initialization_context'(Source, Ctx) :- 802 ( source_location(File, Line) 803 -> Ctx = File:Line, 804 '$input_context'(Context), 805 '$top_file'(Context, File, Source) 806 ; Ctx = (-), 807 File = (-) 808 ). 809 810'$top_file'([input(include, F1, _, _)|T], _, F) :- 811 !, 812 '$top_file'(T, F1, F). 813'$top_file'(_, F, F). 814 815 816'$initialization_error'(E, Goal, Ctx) :- 817 print_message(error, initialization_error(Goal, E, Ctx)). 818 819'$initialization_failure'(Goal, Ctx) :- 820 print_message(warning, initialization_failure(Goal, Ctx)).
828:- public '$clear_source_admin'/1. 829 830'$clear_source_admin'(File) :- 831 retractall('$init_goal'(_, _, File:_)), 832 retractall('$load_context_module'(File, _, _)), 833 retractall('$resolved_source_path_db'(_, _, File)). 834 835 836 /******************************* 837 * STREAM * 838 *******************************/ 839 840:- '$iso'(stream_property/2). 841stream_property(Stream, Property) :- 842 nonvar(Stream), 843 nonvar(Property), 844 !, 845 '$stream_property'(Stream, Property). 846stream_property(Stream, Property) :- 847 nonvar(Stream), 848 !, 849 '$stream_properties'(Stream, Properties), 850 '$member'(Property, Properties). 851stream_property(Stream, Property) :- 852 nonvar(Property), 853 !, 854 ( Property = alias(Alias), 855 atom(Alias) 856 -> '$alias_stream'(Alias, Stream) 857 ; '$streams_properties'(Property, Pairs), 858 '$member'(Stream-Property, Pairs) 859 ). 860stream_property(Stream, Property) :- 861 '$streams_properties'(Property, Pairs), 862 '$member'(Stream-Properties, Pairs), 863 '$member'(Property, Properties). 864 865 866 /******************************** 867 * MODULES * 868 *********************************/ 869 870% '$prefix_module'(+Module, +Context, +Term, -Prefixed) 871% Tags `Term' with `Module:' if `Module' is not the context module. 872 873'$prefix_module'(Module, Module, Head, Head) :- !. 874'$prefix_module'(Module, _, Head, Module:Head).
880default_module(Me, Super) :- 881 ( atom(Me) 882 -> ( var(Super) 883 -> '$default_module'(Me, Super) 884 ; '$default_module'(Me, Super), ! 885 ) 886 ; '$type_error'(module, Me) 887 ). 888 889'$default_module'(Me, Me). 890'$default_module'(Me, Super) :- 891 import_module(Me, S), 892 '$default_module'(S, Super). 893 894 895 /******************************** 896 * TRACE AND EXCEPTIONS * 897 *********************************/ 898 899:- dynamic user:exception/3. 900:- multifile user:exception/3. 901:- '$hide'(user:exception/3).
910:- public 911 '$undefined_procedure'/4. 912 913'$undefined_procedure'(Module, Name, Arity, Action) :- 914 '$prefix_module'(Module, user, Name/Arity, Pred), 915 user:exception(undefined_predicate, Pred, Action0), 916 !, 917 Action = Action0. 918'$undefined_procedure'(Module, Name, Arity, Action) :- 919 \+ current_prolog_flag(autoload, false), 920 '$autoload'(Module:Name/Arity), 921 !, 922 Action = retry. 923'$undefined_procedure'(_, _, _, error).
935'$loading'(Library) :- 936 current_prolog_flag(threads, true), 937 ( '$loading_file'(Library, _Queue, _LoadThread) 938 -> true 939 ; '$loading_file'(FullFile, _Queue, _LoadThread), 940 file_name_extension(Library, _, FullFile) 941 -> true 942 ). 943 944% handle debugger 'w', 'p' and <N> depth options. 945 946'$set_debugger_write_options'(write) :- 947 !, 948 create_prolog_flag(debugger_write_options, 949 [ quoted(true), 950 attributes(dots), 951 spacing(next_argument) 952 ], []). 953'$set_debugger_write_options'(print) :- 954 !, 955 create_prolog_flag(debugger_write_options, 956 [ quoted(true), 957 portray(true), 958 max_depth(10), 959 attributes(portray), 960 spacing(next_argument) 961 ], []). 962'$set_debugger_write_options'(Depth) :- 963 current_prolog_flag(debugger_write_options, Options0), 964 ( '$select'(max_depth(_), Options0, Options) 965 -> true 966 ; Options = Options0 967 ), 968 create_prolog_flag(debugger_write_options, 969 [max_depth(Depth)|Options], []). 970 971 972 /******************************** 973 * SYSTEM MESSAGES * 974 *********************************/
981'$confirm'(Spec) :- 982 print_message(query, Spec), 983 between(0, 5, _), 984 get_single_char(Answer), 985 ( '$in_reply'(Answer, 'yYjJ \n') 986 -> !, 987 print_message(query, if_tty([yes-[]])) 988 ; '$in_reply'(Answer, 'nN') 989 -> !, 990 print_message(query, if_tty([no-[]])), 991 fail 992 ; print_message(help, query(confirm)), 993 fail 994 ). 995 996'$in_reply'(Code, Atom) :- 997 char_code(Char, Code), 998 sub_atom(Atom, _, _, _, Char), 999 !. 1000 1001:- dynamic 1002 user:portray/1. 1003:- multifile 1004 user:portray/1. 1005 1006 1007 /******************************* 1008 * FILE_SEARCH_PATH * 1009 *******************************/ 1010 1011:- dynamic 1012 user:file_search_path/2, 1013 user:library_directory/1. 1014:- multifile 1015 user:file_search_path/2, 1016 user:library_directory/1. 1017 1018user(file_search_path(library, Dir) :- 1019 library_directory(Dir)). 1020user:file_search_path(swi, Home) :- 1021 current_prolog_flag(home, Home). 1022user:file_search_path(swi, Home) :- 1023 current_prolog_flag(shared_home, Home). 1024user:file_search_path(library, app_config(lib)). 1025user:file_search_path(library, swi(library)). 1026user:file_search_path(library, swi(library/clp)). 1027user:file_search_path(foreign, swi(ArchLib)) :- 1028 \+ current_prolog_flag(windows, true), 1029 current_prolog_flag(arch, Arch), 1030 atom_concat('lib/', Arch, ArchLib). 1031user:file_search_path(foreign, swi(SoLib)) :- 1032 ( current_prolog_flag(windows, true) 1033 -> SoLib = bin 1034 ; SoLib = lib 1035 ). 1036user:file_search_path(path, Dir) :- 1037 getenv('PATH', Path), 1038 ( current_prolog_flag(windows, true) 1039 -> atomic_list_concat(Dirs, (;), Path) 1040 ; atomic_list_concat(Dirs, :, Path) 1041 ), 1042 '$member'(Dir, Dirs). 1043user:file_search_path(user_app_data, Dir) :- 1044 '$xdg_prolog_directory'(data, Dir). 1045user:file_search_path(common_app_data, Dir) :- 1046 '$xdg_prolog_directory'(common_data, Dir). 1047user:file_search_path(user_app_config, Dir) :- 1048 '$xdg_prolog_directory'(config, Dir). 1049user:file_search_path(common_app_config, Dir) :- 1050 '$xdg_prolog_directory'(common_config, Dir). 1051user:file_search_path(app_data, user_app_data('.')). 1052user:file_search_path(app_data, common_app_data('.')). 1053user:file_search_path(app_config, user_app_config('.')). 1054user:file_search_path(app_config, common_app_config('.')). 1055% backward compatibility 1056user:file_search_path(app_preferences, user_app_config('.')). 1057user:file_search_path(user_profile, app_preferences('.')). 1058 1059'$xdg_prolog_directory'(Which, Dir) :- 1060 '$xdg_directory'(Which, XDGDir), 1061 '$make_config_dir'(XDGDir), 1062 '$ensure_slash'(XDGDir, XDGDirS), 1063 atom_concat(XDGDirS, 'swi-prolog', Dir), 1064 '$make_config_dir'(Dir). 1065 1066% config 1067'$xdg_directory'(config, Home) :- 1068 current_prolog_flag(windows, true), 1069 catch(win_folder(appdata, Home), _, fail), 1070 !. 1071'$xdg_directory'(config, Home) :- 1072 getenv('XDG_CONFIG_HOME', Home). 1073'$xdg_directory'(config, Home) :- 1074 expand_file_name('~/.config', [Home]). 1075% data 1076'$xdg_directory'(data, Home) :- 1077 current_prolog_flag(windows, true), 1078 catch(win_folder(local_appdata, Home), _, fail), 1079 !. 1080'$xdg_directory'(data, Home) :- 1081 getenv('XDG_DATA_HOME', Home). 1082'$xdg_directory'(data, Home) :- 1083 expand_file_name('~/.local', [Local]), 1084 '$make_config_dir'(Local), 1085 atom_concat(Local, '/share', Home), 1086 '$make_config_dir'(Home). 1087% common data 1088'$xdg_directory'(common_data, Dir) :- 1089 current_prolog_flag(windows, true), 1090 catch(win_folder(common_appdata, Dir), _, fail), 1091 !. 1092'$xdg_directory'(common_data, Dir) :- 1093 '$existing_dir_from_env_path'('XDG_DATA_DIRS', 1094 [ '/usr/local/share', 1095 '/usr/share' 1096 ], 1097 Dir). 1098% common config 1099'$xdg_directory'(common_config, Dir) :- 1100 current_prolog_flag(windows, true), 1101 catch(win_folder(common_appdata, Dir), _, fail), 1102 !. 1103'$xdg_directory'(common_config, Dir) :- 1104 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir). 1105 1106'$existing_dir_from_env_path'(Env, Defaults, Dir) :- 1107 ( getenv(Env, Path) 1108 -> '$path_sep'(Sep), 1109 atomic_list_concat(Dirs, Sep, Path) 1110 ; Dirs = Defaults 1111 ), 1112 '$member'(Dir, Dirs), 1113 Dir \== '', 1114 exists_directory(Dir). 1115 1116'$path_sep'(Char) :- 1117 ( current_prolog_flag(windows, true) 1118 -> Char = ';' 1119 ; Char = ':' 1120 ). 1121 1122'$make_config_dir'(Dir) :- 1123 exists_directory(Dir), 1124 !. 1125'$make_config_dir'(Dir) :- 1126 nb_current('$create_search_directories', true), 1127 file_directory_name(Dir, Parent), 1128 '$my_file'(Parent), 1129 catch(make_directory(Dir), _, fail). 1130 1131'$ensure_slash'(Dir, DirS) :- 1132 ( sub_atom(Dir, _, _, 0, /) 1133 -> DirS = Dir 1134 ; atom_concat(Dir, /, DirS) 1135 ).
1140'$expand_file_search_path'(Spec, Expanded, Cond) :- 1141 '$option'(access(Access), Cond), 1142 memberchk(Access, [write,append]), 1143 !, 1144 setup_call_cleanup( 1145 nb_setval('$create_search_directories', true), 1146 expand_file_search_path(Spec, Expanded), 1147 nb_delete('$create_search_directories')). 1148'$expand_file_search_path'(Spec, Expanded, _Cond) :- 1149 expand_file_search_path(Spec, Expanded).
1157expand_file_search_path(Spec, Expanded) :- 1158 catch('$expand_file_search_path'(Spec, Expanded, 0, []), 1159 loop(Used), 1160 throw(error(loop_error(Spec), file_search(Used)))). 1161 1162'$expand_file_search_path'(Spec, Expanded, N, Used) :- 1163 functor(Spec, Alias, 1), 1164 !, 1165 user:file_search_path(Alias, Exp0), 1166 NN is N + 1, 1167 ( NN > 16 1168 -> throw(loop(Used)) 1169 ; true 1170 ), 1171 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]), 1172 arg(1, Spec, Segments), 1173 '$segments_to_atom'(Segments, File), 1174 '$make_path'(Exp1, File, Expanded). 1175'$expand_file_search_path'(Spec, Path, _, _) :- 1176 '$segments_to_atom'(Spec, Path). 1177 1178'$make_path'(Dir, '.', Path) :- 1179 !, 1180 Path = Dir. 1181'$make_path'(Dir, File, Path) :- 1182 sub_atom(Dir, _, _, 0, /), 1183 !, 1184 atom_concat(Dir, File, Path). 1185'$make_path'(Dir, File, Path) :- 1186 atomic_list_concat([Dir, /, File], Path). 1187 1188 1189 /******************************** 1190 * FILE CHECKING * 1191 *********************************/
1202absolute_file_name(Spec, Options, Path) :- 1203 '$is_options'(Options), 1204 \+ '$is_options'(Path), 1205 !, 1206 absolute_file_name(Spec, Path, Options). 1207absolute_file_name(Spec, Path, Options) :- 1208 '$must_be'(options, Options), 1209 % get the valid extensions 1210 ( '$select_option'(extensions(Exts), Options, Options1) 1211 -> '$must_be'(list, Exts) 1212 ; '$option'(file_type(Type), Options) 1213 -> '$must_be'(atom, Type), 1214 '$file_type_extensions'(Type, Exts), 1215 Options1 = Options 1216 ; Options1 = Options, 1217 Exts = [''] 1218 ), 1219 '$canonicalise_extensions'(Exts, Extensions), 1220 % unless specified otherwise, ask regular file 1221 ( nonvar(Type) 1222 -> Options2 = Options1 1223 ; '$merge_options'(_{file_type:regular}, Options1, Options2) 1224 ), 1225 % Det or nondet? 1226 ( '$select_option'(solutions(Sols), Options2, Options3) 1227 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols) 1228 ; Sols = first, 1229 Options3 = Options2 1230 ), 1231 % Errors or not? 1232 ( '$select_option'(file_errors(FileErrors), Options3, Options4) 1233 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors) 1234 ; FileErrors = error, 1235 Options4 = Options3 1236 ), 1237 % Expand shell patterns? 1238 ( atomic(Spec), 1239 '$select_option'(expand(Expand), Options4, Options5), 1240 '$must_be'(boolean, Expand) 1241 -> expand_file_name(Spec, List), 1242 '$member'(Spec1, List) 1243 ; Spec1 = Spec, 1244 Options5 = Options4 1245 ), 1246 % Search for files 1247 ( Sols == first 1248 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path) 1249 -> ! % also kill choice point of expand_file_name/2 1250 ; ( FileErrors == fail 1251 -> fail 1252 ; '$current_module'('$bags', _File), 1253 findall(P, 1254 '$chk_file'(Spec1, Extensions, [access(exist)], 1255 false, P), 1256 Candidates), 1257 '$abs_file_error'(Spec, Candidates, Options5) 1258 ) 1259 ) 1260 ; '$chk_file'(Spec1, Extensions, Options5, false, Path) 1261 ). 1262 1263'$abs_file_error'(Spec, Candidates, Conditions) :- 1264 '$member'(F, Candidates), 1265 '$member'(C, Conditions), 1266 '$file_condition'(C), 1267 '$file_error'(C, Spec, F, E, Comment), 1268 !, 1269 throw(error(E, context(_, Comment))). 1270'$abs_file_error'(Spec, _, _) :- 1271 '$existence_error'(source_sink, Spec). 1272 1273'$file_error'(file_type(directory), Spec, File, Error, Comment) :- 1274 \+ exists_directory(File), 1275 !, 1276 Error = existence_error(directory, Spec), 1277 Comment = not_a_directory(File). 1278'$file_error'(file_type(_), Spec, File, Error, Comment) :- 1279 exists_directory(File), 1280 !, 1281 Error = existence_error(file, Spec), 1282 Comment = directory(File). 1283'$file_error'(access(OneOrList), Spec, File, Error, _) :- 1284 '$one_or_member'(Access, OneOrList), 1285 \+ access_file(File, Access), 1286 Error = permission_error(Access, source_sink, Spec). 1287 1288'$one_or_member'(Elem, List) :- 1289 is_list(List), 1290 !, 1291 '$member'(Elem, List). 1292'$one_or_member'(Elem, Elem). 1293 1294 1295'$file_type_extensions'(source, Exts) :- % SICStus 3.9 compatibility 1296 !, 1297 '$file_type_extensions'(prolog, Exts). 1298'$file_type_extensions'(Type, Exts) :- 1299 '$current_module'('$bags', _File), 1300 !, 1301 findall(Ext, user:prolog_file_type(Ext, Type), Exts0), 1302 ( Exts0 == [], 1303 \+ '$ft_no_ext'(Type) 1304 -> '$domain_error'(file_type, Type) 1305 ; true 1306 ), 1307 '$append'(Exts0, [''], Exts). 1308'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ... 1309 1310'$ft_no_ext'(txt). 1311'$ft_no_ext'(executable). 1312'$ft_no_ext'(directory).
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.
1325:- multifile(user:prolog_file_type/2). 1326:- dynamic(user:prolog_file_type/2). 1327 1328userprolog_file_type(pl, prolog). 1329userprolog_file_type(prolog, prolog). 1330userprolog_file_type(qlf, prolog). 1331userprolog_file_type(qlf, qlf). 1332userprolog_file_type(Ext, executable) :- 1333 current_prolog_flag(shared_object_extension, Ext). 1334userprolog_file_type(dylib, executable) :- 1335 current_prolog_flag(apple, true).
1342'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :- 1343 \+ ground(Spec), 1344 !, 1345 '$instantiation_error'(Spec). 1346'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :- 1347 compound(Spec), 1348 functor(Spec, _, 1), 1349 !, 1350 '$relative_to'(Cond, cwd, CWD), 1351 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName). 1352'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- % allow a/b/... 1353 \+ atomic(Segments), 1354 !, 1355 '$segments_to_atom'(Segments, Atom), 1356 '$chk_file'(Atom, Ext, Cond, Cache, FullName). 1357'$chk_file'(File, Exts, Cond, _, FullName) :- 1358 is_absolute_file_name(File), 1359 !, 1360 '$extend_file'(File, Exts, Extended), 1361 '$file_conditions'(Cond, Extended), 1362 '$absolute_file_name'(Extended, FullName). 1363'$chk_file'(File, Exts, Cond, _, FullName) :- 1364 '$relative_to'(Cond, source, Dir), 1365 atomic_list_concat([Dir, /, File], AbsFile), 1366 '$extend_file'(AbsFile, Exts, Extended), 1367 '$file_conditions'(Cond, Extended), 1368 !, 1369 '$absolute_file_name'(Extended, FullName). 1370'$chk_file'(File, Exts, Cond, _, FullName) :- 1371 '$extend_file'(File, Exts, Extended), 1372 '$file_conditions'(Cond, Extended), 1373 '$absolute_file_name'(Extended, FullName). 1374 1375'$segments_to_atom'(Atom, Atom) :- 1376 atomic(Atom), 1377 !. 1378'$segments_to_atom'(Segments, Atom) :- 1379 '$segments_to_list'(Segments, List, []), 1380 !, 1381 atomic_list_concat(List, /, Atom). 1382 1383'$segments_to_list'(A/B, H, T) :- 1384 '$segments_to_list'(A, H, T0), 1385 '$segments_to_list'(B, T0, T). 1386'$segments_to_list'(A, [A|T], T) :- 1387 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1397'$relative_to'(Conditions, Default, Dir) :-
1398 ( '$option'(relative_to(FileOrDir), Conditions)
1399 *-> ( exists_directory(FileOrDir)
1400 -> Dir = FileOrDir
1401 ; atom_concat(Dir, /, FileOrDir)
1402 -> true
1403 ; file_directory_name(FileOrDir, Dir)
1404 )
1405 ; Default == cwd
1406 -> '$cwd'(Dir)
1407 ; Default == source
1408 -> source_location(ContextFile, _Line),
1409 file_directory_name(ContextFile, Dir)
1410 ).
1415:- dynamic 1416 '$search_path_file_cache'/3, % SHA1, Time, Path 1417 '$search_path_gc_time'/1. % Time 1418:- volatile 1419 '$search_path_file_cache'/3, 1420 '$search_path_gc_time'/1. 1421 1422:- create_prolog_flag(file_search_cache_time, 10, []). 1423 1424'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1425 !, 1426 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1427 current_prolog_flag(emulated_dialect, Dialect), 1428 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1429 variant_sha1(Spec+Cache, SHA1), 1430 get_time(Now), 1431 current_prolog_flag(file_search_cache_time, TimeOut), 1432 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1433 CachedTime > Now - TimeOut, 1434 '$file_conditions'(Cond, FullFile) 1435 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1436 ; '$member'(Expanded, Expansions), 1437 '$extend_file'(Expanded, Exts, LibFile), 1438 ( '$file_conditions'(Cond, LibFile), 1439 '$absolute_file_name'(LibFile, FullFile), 1440 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1441 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1442 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1443 fail 1444 ) 1445 ). 1446'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1447 '$expand_file_search_path'(Spec, Expanded, Cond), 1448 '$extend_file'(Expanded, Exts, LibFile), 1449 '$file_conditions'(Cond, LibFile), 1450 '$absolute_file_name'(LibFile, FullFile). 1451 1452'$cache_file_found'(_, _, TimeOut, _) :- 1453 TimeOut =:= 0, 1454 !. 1455'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1456 '$search_path_file_cache'(SHA1, Saved, FullFile), 1457 !, 1458 ( Now - Saved < TimeOut/2 1459 -> true 1460 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1461 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1462 ). 1463'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1464 'gc_file_search_cache'(TimeOut), 1465 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1466 1467'gc_file_search_cache'(TimeOut) :- 1468 get_time(Now), 1469 '$search_path_gc_time'(Last), 1470 Now-Last < TimeOut/2, 1471 !. 1472'gc_file_search_cache'(TimeOut) :- 1473 get_time(Now), 1474 retractall('$search_path_gc_time'(_)), 1475 assertz('$search_path_gc_time'(Now)), 1476 Before is Now - TimeOut, 1477 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1478 Cached < Before, 1479 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1480 fail 1481 ; true 1482 ). 1483 1484 1485'$search_message'(Term) :- 1486 current_prolog_flag(verbose_file_search, true), 1487 !, 1488 print_message(informational, Term). 1489'$search_message'(_).
1496'$file_conditions'(List, File) :- 1497 is_list(List), 1498 !, 1499 \+ ( '$member'(C, List), 1500 '$file_condition'(C), 1501 \+ '$file_condition'(C, File) 1502 ). 1503'$file_conditions'(Map, File) :- 1504 \+ ( get_dict(Key, Map, Value), 1505 C =.. [Key,Value], 1506 '$file_condition'(C), 1507 \+ '$file_condition'(C, File) 1508 ). 1509 1510'$file_condition'(file_type(directory), File) :- 1511 !, 1512 exists_directory(File). 1513'$file_condition'(file_type(_), File) :- 1514 !, 1515 \+ exists_directory(File). 1516'$file_condition'(access(Accesses), File) :- 1517 !, 1518 \+ ( '$one_or_member'(Access, Accesses), 1519 \+ access_file(File, Access) 1520 ). 1521 1522'$file_condition'(exists). 1523'$file_condition'(file_type(_)). 1524'$file_condition'(access(_)). 1525 1526'$extend_file'(File, Exts, FileEx) :- 1527 '$ensure_extensions'(Exts, File, Fs), 1528 '$list_to_set'(Fs, FsSet), 1529 '$member'(FileEx, FsSet). 1530 1531'$ensure_extensions'([], _, []). 1532'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1533 file_name_extension(F, E, FE), 1534 '$ensure_extensions'(E0, F, E1).
1541'$list_to_set'(List, Set) :- 1542 '$number_list'(List, 1, Numbered), 1543 sort(1, @=<, Numbered, ONum), 1544 '$remove_dup_keys'(ONum, NumSet), 1545 sort(2, @=<, NumSet, ONumSet), 1546 '$pairs_keys'(ONumSet, Set). 1547 1548'$number_list'([], _, []). 1549'$number_list'([H|T0], N, [H-N|T]) :- 1550 N1 is N+1, 1551 '$number_list'(T0, N1, T). 1552 1553'$remove_dup_keys'([], []). 1554'$remove_dup_keys'([H|T0], [H|T]) :- 1555 H = V-_, 1556 '$remove_same_key'(T0, V, T1), 1557 '$remove_dup_keys'(T1, T). 1558 1559'$remove_same_key'([V1-_|T0], V, T) :- 1560 V1 == V, 1561 !, 1562 '$remove_same_key'(T0, V, T). 1563'$remove_same_key'(L, _, L). 1564 1565'$pairs_keys'([], []). 1566'$pairs_keys'([K-_|T0], [K|T]) :- 1567 '$pairs_keys'(T0, T). 1568 1569 1570/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1571Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1572the Quintus compatibility requests `pl'. This layer canonicalises all 1573extensions to .ext 1574- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1575 1576'$canonicalise_extensions'([], []) :- !. 1577'$canonicalise_extensions'([H|T], [CH|CT]) :- 1578 !, 1579 '$must_be'(atom, H), 1580 '$canonicalise_extension'(H, CH), 1581 '$canonicalise_extensions'(T, CT). 1582'$canonicalise_extensions'(E, [CE]) :- 1583 '$canonicalise_extension'(E, CE). 1584 1585'$canonicalise_extension'('', '') :- !. 1586'$canonicalise_extension'(DotAtom, DotAtom) :- 1587 sub_atom(DotAtom, 0, _, _, '.'), 1588 !. 1589'$canonicalise_extension'(Atom, DotAtom) :- 1590 atom_concat('.', Atom, DotAtom). 1591 1592 1593 /******************************** 1594 * CONSULT * 1595 *********************************/ 1596 1597:- dynamic 1598 user:library_directory/1, 1599 user:prolog_load_file/2. 1600:- multifile 1601 user:library_directory/1, 1602 user:prolog_load_file/2. 1603 1604:- prompt(_, '|: '). 1605 1606:- thread_local 1607 '$compilation_mode_store'/1, % database, wic, qlf 1608 '$directive_mode_store'/1. % database, wic, qlf 1609:- volatile 1610 '$compilation_mode_store'/1, 1611 '$directive_mode_store'/1. 1612 1613'$compilation_mode'(Mode) :- 1614 ( '$compilation_mode_store'(Val) 1615 -> Mode = Val 1616 ; Mode = database 1617 ). 1618 1619'$set_compilation_mode'(Mode) :- 1620 retractall('$compilation_mode_store'(_)), 1621 assertz('$compilation_mode_store'(Mode)). 1622 1623'$compilation_mode'(Old, New) :- 1624 '$compilation_mode'(Old), 1625 ( New == Old 1626 -> true 1627 ; '$set_compilation_mode'(New) 1628 ). 1629 1630'$directive_mode'(Mode) :- 1631 ( '$directive_mode_store'(Val) 1632 -> Mode = Val 1633 ; Mode = database 1634 ). 1635 1636'$directive_mode'(Old, New) :- 1637 '$directive_mode'(Old), 1638 ( New == Old 1639 -> true 1640 ; '$set_directive_mode'(New) 1641 ). 1642 1643'$set_directive_mode'(Mode) :- 1644 retractall('$directive_mode_store'(_)), 1645 assertz('$directive_mode_store'(Mode)).
1653'$compilation_level'(Level) :- 1654 '$input_context'(Stack), 1655 '$compilation_level'(Stack, Level). 1656 1657'$compilation_level'([], 0). 1658'$compilation_level'([Input|T], Level) :- 1659 ( arg(1, Input, see) 1660 -> '$compilation_level'(T, Level) 1661 ; '$compilation_level'(T, Level0), 1662 Level is Level0+1 1663 ).
1671compiling :- 1672 \+ ( '$compilation_mode'(database), 1673 '$directive_mode'(database) 1674 ). 1675 1676:- meta_predicate 1677 '$ifcompiling'( ). 1678 1679'$ifcompiling'(G) :- 1680 ( '$compilation_mode'(database) 1681 -> true 1682 ; call(G) 1683 ). 1684 1685 /******************************** 1686 * READ SOURCE * 1687 *********************************/
1691'$load_msg_level'(Action, Nesting, Start, Done) :- 1692 '$update_autoload_level'([], 0), 1693 !, 1694 current_prolog_flag(verbose_load, Type0), 1695 '$load_msg_compat'(Type0, Type), 1696 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1697 -> true 1698 ). 1699'$load_msg_level'(_, _, silent, silent). 1700 1701'$load_msg_compat'(true, normal) :- !. 1702'$load_msg_compat'(false, silent) :- !. 1703'$load_msg_compat'(X, X). 1704 1705'$load_msg_level'(load_file, _, full, informational, informational). 1706'$load_msg_level'(include_file, _, full, informational, informational). 1707'$load_msg_level'(load_file, _, normal, silent, informational). 1708'$load_msg_level'(include_file, _, normal, silent, silent). 1709'$load_msg_level'(load_file, 0, brief, silent, informational). 1710'$load_msg_level'(load_file, _, brief, silent, silent). 1711'$load_msg_level'(include_file, _, brief, silent, silent). 1712'$load_msg_level'(load_file, _, silent, silent, silent). 1713'$load_msg_level'(include_file, _, silent, silent, silent).
1736'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1737 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1738 ( Term == end_of_file 1739 -> !, fail 1740 ; Term \== begin_of_file 1741 ). 1742 1743'$source_term'(Input, _,_,_,_,_,_,_) :- 1744 \+ ground(Input), 1745 !, 1746 '$instantiation_error'(Input). 1747'$source_term'(stream(Id, In, Opts), 1748 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1749 !, 1750 '$record_included'(Parents, Id, Id, 0.0, Message), 1751 setup_call_cleanup( 1752 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1753 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1754 [Id|Parents], Options), 1755 '$close_source'(State, Message)). 1756'$source_term'(File, 1757 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1758 absolute_file_name(File, Path, 1759 [ file_type(prolog), 1760 access(read) 1761 ]), 1762 time_file(Path, Time), 1763 '$record_included'(Parents, File, Path, Time, Message), 1764 setup_call_cleanup( 1765 '$open_source'(Path, In, State, Parents, Options), 1766 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1767 [Path|Parents], Options), 1768 '$close_source'(State, Message)). 1769 1770:- thread_local 1771 '$load_input'/2. 1772:- volatile 1773 '$load_input'/2. 1774 1775'$open_source'(stream(Id, In, Opts), In, 1776 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1777 !, 1778 '$context_type'(Parents, ContextType), 1779 '$push_input_context'(ContextType), 1780 '$prepare_load_stream'(In, Id, StreamState), 1781 asserta('$load_input'(stream(Id), In), Ref). 1782'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1783 '$context_type'(Parents, ContextType), 1784 '$push_input_context'(ContextType), 1785 '$open_source'(Path, In, Options), 1786 '$set_encoding'(In, Options), 1787 asserta('$load_input'(Path, In), Ref). 1788 1789'$context_type'([], load_file) :- !. 1790'$context_type'(_, include). 1791 1792:- multifile prolog:open_source_hook/3. 1793 1794'$open_source'(Path, In, Options) :- 1795 prolog:open_source_hook(Path, In, Options), 1796 !. 1797'$open_source'(Path, In, _Options) :- 1798 open(Path, read, In). 1799 1800'$close_source'(close(In, _Id, Ref), Message) :- 1801 erase(Ref), 1802 call_cleanup( 1803 close(In), 1804 '$pop_input_context'), 1805 '$close_message'(Message). 1806'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1807 erase(Ref), 1808 call_cleanup( 1809 '$restore_load_stream'(In, StreamState, Opts), 1810 '$pop_input_context'), 1811 '$close_message'(Message). 1812 1813'$close_message'(message(Level, Msg)) :- 1814 !, 1815 '$print_message'(Level, Msg). 1816'$close_message'(_).
1828'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1829 Parents \= [_,_|_], 1830 ( '$load_input'(_, Input) 1831 -> stream_property(Input, file_name(File)) 1832 ), 1833 '$set_source_location'(File, 0), 1834 '$expanded_term'(In, 1835 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1836 Stream, Parents, Options). 1837'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1838 '$skip_script_line'(In, Options), 1839 '$read_clause_options'(Options, ReadOptions), 1840 repeat, 1841 read_clause(In, Raw, 1842 [ variable_names(Bindings), 1843 term_position(Pos), 1844 subterm_positions(RawLayout) 1845 | ReadOptions 1846 ]), 1847 b_setval('$term_position', Pos), 1848 b_setval('$variable_names', Bindings), 1849 ( Raw == end_of_file 1850 -> !, 1851 ( Parents = [_,_|_] % Included file 1852 -> fail 1853 ; '$expanded_term'(In, 1854 Raw, RawLayout, Read, RLayout, Term, TLayout, 1855 Stream, Parents, Options) 1856 ) 1857 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1858 Stream, Parents, Options) 1859 ). 1860 1861'$read_clause_options'([], []). 1862'$read_clause_options'([H|T0], List) :- 1863 ( '$read_clause_option'(H) 1864 -> List = [H|T] 1865 ; List = T 1866 ), 1867 '$read_clause_options'(T0, T). 1868 1869'$read_clause_option'(syntax_errors(_)). 1870'$read_clause_option'(term_position(_)). 1871'$read_clause_option'(process_comment(_)). 1872 1873'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1874 Stream, Parents, Options) :- 1875 E = error(_,_), 1876 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1877 '$print_message_fail'(E)), 1878 ( Expanded \== [] 1879 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1880 ; Term1 = Expanded, 1881 Layout1 = ExpandedLayout 1882 ), 1883 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1884 -> ( Directive = include(File), 1885 '$current_source_module'(Module), 1886 '$valid_directive'(Module:include(File)) 1887 -> stream_property(In, encoding(Enc)), 1888 '$add_encoding'(Enc, Options, Options1), 1889 '$source_term'(File, Read, RLayout, Term, TLayout, 1890 Stream, Parents, Options1) 1891 ; Directive = encoding(Enc) 1892 -> set_stream(In, encoding(Enc)), 1893 fail 1894 ; Term = Term1, 1895 Stream = In, 1896 Read = Raw 1897 ) 1898 ; Term = Term1, 1899 TLayout = Layout1, 1900 Stream = In, 1901 Read = Raw, 1902 RLayout = RawLayout 1903 ). 1904 1905'$expansion_member'(Var, Layout, Var, Layout) :- 1906 var(Var), 1907 !. 1908'$expansion_member'([], _, _, _) :- !, fail. 1909'$expansion_member'(List, ListLayout, Term, Layout) :- 1910 is_list(List), 1911 !, 1912 ( var(ListLayout) 1913 -> '$member'(Term, List) 1914 ; is_list(ListLayout) 1915 -> '$member_rep2'(Term, Layout, List, ListLayout) 1916 ; Layout = ListLayout, 1917 '$member'(Term, List) 1918 ). 1919'$expansion_member'(X, Layout, X, Layout). 1920 1921% pairwise member, repeating last element of the second 1922% list. 1923 1924'$member_rep2'(H1, H2, [H1|_], [H2|_]). 1925'$member_rep2'(H1, H2, [_|T1], [T2]) :- 1926 !, 1927 '$member_rep2'(H1, H2, T1, [T2]). 1928'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 1929 '$member_rep2'(H1, H2, T1, T2).
1933'$add_encoding'(Enc, Options0, Options) :- 1934 ( Options0 = [encoding(Enc)|_] 1935 -> Options = Options0 1936 ; Options = [encoding(Enc)|Options0] 1937 ). 1938 1939 1940:- multifile 1941 '$included'/4. % Into, Line, File, LastModified 1942:- dynamic 1943 '$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'.
1957'$record_included'([Parent|Parents], File, Path, Time, 1958 message(DoneMsgLevel, 1959 include_file(done(Level, file(File, Path))))) :- 1960 source_location(SrcFile, Line), 1961 !, 1962 '$compilation_level'(Level), 1963 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 1964 '$print_message'(StartMsgLevel, 1965 include_file(start(Level, 1966 file(File, Path)))), 1967 '$last'([Parent|Parents], Owner), 1968 ( ( '$compilation_mode'(database) 1969 ; '$qlf_current_source'(Owner) 1970 ) 1971 -> '$store_admin_clause'( 1972 system:'$included'(Parent, Line, Path, Time), 1973 _, Owner, SrcFile:Line) 1974 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 1975 ). 1976'$record_included'(_, _, _, _, true).
1982'$master_file'(File, MasterFile) :- 1983 '$included'(MasterFile0, _Line, File, _Time), 1984 !, 1985 '$master_file'(MasterFile0, MasterFile). 1986'$master_file'(File, File). 1987 1988 1989'$skip_script_line'(_In, Options) :- 1990 '$option'(check_script(false), Options), 1991 !. 1992'$skip_script_line'(In, _Options) :- 1993 ( peek_char(In, #) 1994 -> skip(In, 10) 1995 ; true 1996 ). 1997 1998'$set_encoding'(Stream, Options) :- 1999 '$option'(encoding(Enc), Options), 2000 !, 2001 Enc \== default, 2002 set_stream(Stream, encoding(Enc)). 2003'$set_encoding'(_, _). 2004 2005 2006'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 2007 ( stream_property(In, file_name(_)) 2008 -> HasName = true, 2009 ( stream_property(In, position(_)) 2010 -> HasPos = true 2011 ; HasPos = false, 2012 set_stream(In, record_position(true)) 2013 ) 2014 ; HasName = false, 2015 set_stream(In, file_name(Id)), 2016 ( stream_property(In, position(_)) 2017 -> HasPos = true 2018 ; HasPos = false, 2019 set_stream(In, record_position(true)) 2020 ) 2021 ). 2022 2023'$restore_load_stream'(In, _State, Options) :- 2024 memberchk(close(true), Options), 2025 !, 2026 close(In). 2027'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 2028 ( HasName == false 2029 -> set_stream(In, file_name('')) 2030 ; true 2031 ), 2032 ( HasPos == false 2033 -> set_stream(In, record_position(false)) 2034 ; true 2035 ). 2036 2037 2038 /******************************* 2039 * DERIVED FILES * 2040 *******************************/ 2041 2042:- dynamic 2043 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2044 2045'$register_derived_source'(_, '-') :- !. 2046'$register_derived_source'(Loaded, DerivedFrom) :- 2047 retractall('$derived_source_db'(Loaded, _, _)), 2048 time_file(DerivedFrom, Time), 2049 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2050 2051% Auto-importing dynamic predicates is not very elegant and 2052% leads to problems with qsave_program/[1,2] 2053 2054'$derived_source'(Loaded, DerivedFrom, Time) :- 2055 '$derived_source_db'(Loaded, DerivedFrom, Time). 2056 2057 2058 /******************************** 2059 * LOAD PREDICATES * 2060 *********************************/ 2061 2062:- meta_predicate 2063 ensure_loaded( ), 2064 [, | ] 2065 consult( ), 2066 use_module( ), 2067 use_module( , ), 2068 reexport( ), 2069 reexport( , ), 2070 load_files( ), 2071 load_files( , ).
2079ensure_loaded(Files) :-
2080 load_files(Files, [if(not_loaded)]).
2089use_module(Files) :-
2090 load_files(Files, [ if(not_loaded),
2091 must_be_module(true)
2092 ]).
2099use_module(File, Import) :-
2100 load_files(File, [ if(not_loaded),
2101 must_be_module(true),
2102 imports(Import)
2103 ]).
2109reexport(Files) :-
2110 load_files(Files, [ if(not_loaded),
2111 must_be_module(true),
2112 reexport(true)
2113 ]).
2119reexport(File, Import) :- 2120 load_files(File, [ if(not_loaded), 2121 must_be_module(true), 2122 imports(Import), 2123 reexport(true) 2124 ]). 2125 2126 2127[X] :- 2128 !, 2129 consult(X). 2130[M:F|R] :- 2131 consult(M:[F|R]). 2132 2133consult(M:X) :- 2134 X == user, 2135 !, 2136 flag('$user_consult', N, N+1), 2137 NN is N + 1, 2138 atom_concat('user://', NN, Id), 2139 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2140consult(List) :- 2141 load_files(List, [expand(true)]).
2148load_files(Files) :- 2149 load_files(Files, []). 2150load_files(Module:Files, Options) :- 2151 '$must_be'(list, Options), 2152 '$load_files'(Files, Module, Options). 2153 2154'$load_files'(X, _, _) :- 2155 var(X), 2156 !, 2157 '$instantiation_error'(X). 2158'$load_files'([], _, _) :- !. 2159'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2160 '$option'(stream(_), Options), 2161 !, 2162 ( atom(Id) 2163 -> '$load_file'(Id, Module, Options) 2164 ; throw(error(type_error(atom, Id), _)) 2165 ). 2166'$load_files'(List, Module, Options) :- 2167 List = [_|_], 2168 !, 2169 '$must_be'(list, List), 2170 '$load_file_list'(List, Module, Options). 2171'$load_files'(File, Module, Options) :- 2172 '$load_one_file'(File, Module, Options). 2173 2174'$load_file_list'([], _, _). 2175'$load_file_list'([File|Rest], Module, Options) :- 2176 E = error(_,_), 2177 catch('$load_one_file'(File, Module, Options), E, 2178 '$print_message'(error, E)), 2179 '$load_file_list'(Rest, Module, Options). 2180 2181 2182'$load_one_file'(Spec, Module, Options) :- 2183 atomic(Spec), 2184 '$option'(expand(Expand), Options, false), 2185 Expand == true, 2186 !, 2187 expand_file_name(Spec, Expanded), 2188 ( Expanded = [Load] 2189 -> true 2190 ; Load = Expanded 2191 ), 2192 '$load_files'(Load, Module, [expand(false)|Options]). 2193'$load_one_file'(File, Module, Options) :- 2194 strip_module(Module:File, Into, PlainFile), 2195 '$load_file'(PlainFile, Into, Options).
2202'$noload'(true, _, _) :- 2203 !, 2204 fail. 2205'$noload'(_, FullFile, _Options) :- 2206 '$time_source_file'(FullFile, Time, system), 2207 Time > 0.0, 2208 !. 2209'$noload'(not_loaded, FullFile, _) :- 2210 source_file(FullFile), 2211 !. 2212'$noload'(changed, Derived, _) :- 2213 '$derived_source'(_FullFile, Derived, LoadTime), 2214 time_file(Derived, Modified), 2215 Modified @=< LoadTime, 2216 !. 2217'$noload'(changed, FullFile, Options) :- 2218 '$time_source_file'(FullFile, LoadTime, user), 2219 '$modified_id'(FullFile, Modified, Options), 2220 Modified @=< LoadTime, 2221 !.
2240'$qlf_file'(Spec, _, Spec, stream, Options) :- 2241 '$option'(stream(_), Options), % stream: no choice 2242 !. 2243'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2244 '$spec_extension'(Spec, Ext), % user explicitly specified 2245 user:prolog_file_type(Ext, prolog), 2246 !. 2247'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2248 '$compilation_mode'(database), 2249 file_name_extension(Base, PlExt, FullFile), 2250 user:prolog_file_type(PlExt, prolog), 2251 user:prolog_file_type(QlfExt, qlf), 2252 file_name_extension(Base, QlfExt, QlfFile), 2253 ( access_file(QlfFile, read), 2254 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2255 -> ( access_file(QlfFile, write) 2256 -> print_message(informational, 2257 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2258 Mode = qcompile, 2259 LoadFile = FullFile 2260 ; Why == old, 2261 current_prolog_flag(home, PlHome), 2262 sub_atom(FullFile, 0, _, _, PlHome) 2263 -> print_message(silent, 2264 qlf(system_lib_out_of_date(Spec, QlfFile))), 2265 Mode = qload, 2266 LoadFile = QlfFile 2267 ; print_message(warning, 2268 qlf(can_not_recompile(Spec, QlfFile, Why))), 2269 Mode = compile, 2270 LoadFile = FullFile 2271 ) 2272 ; Mode = qload, 2273 LoadFile = QlfFile 2274 ) 2275 -> ! 2276 ; '$qlf_auto'(FullFile, QlfFile, Options) 2277 -> !, Mode = qcompile, 2278 LoadFile = FullFile 2279 ). 2280'$qlf_file'(_, FullFile, FullFile, compile, _).
2288'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2289 ( access_file(PlFile, read)
2290 -> time_file(PlFile, PlTime),
2291 time_file(QlfFile, QlfTime),
2292 ( PlTime > QlfTime
2293 -> Why = old % PlFile is newer
2294 ; Error = error(Formal,_),
2295 catch('$qlf_sources'(QlfFile, _Files), Error, true),
2296 nonvar(Formal) % QlfFile is incompatible
2297 -> Why = Error
2298 ; fail % QlfFile is up-to-date and ok
2299 )
2300 ; fail % can not read .pl; try .qlf
2301 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2309:- create_prolog_flag(qcompile, false, [type(atom)]). 2310 2311'$qlf_auto'(PlFile, QlfFile, Options) :- 2312 ( memberchk(qcompile(QlfMode), Options) 2313 -> true 2314 ; current_prolog_flag(qcompile, QlfMode), 2315 \+ '$in_system_dir'(PlFile) 2316 ), 2317 ( QlfMode == auto 2318 -> true 2319 ; QlfMode == large, 2320 size_file(PlFile, Size), 2321 Size > 100000 2322 ), 2323 access_file(QlfFile, write). 2324 2325'$in_system_dir'(PlFile) :- 2326 current_prolog_flag(home, Home), 2327 sub_atom(PlFile, 0, _, _, Home). 2328 2329'$spec_extension'(File, Ext) :- 2330 atom(File), 2331 file_name_extension(_, Ext, File). 2332'$spec_extension'(Spec, Ext) :- 2333 compound(Spec), 2334 arg(1, Spec, Arg), 2335 '$spec_extension'(Arg, Ext).
2347:- dynamic 2348 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2349 2350'$load_file'(File, Module, Options) :- 2351 \+ memberchk(stream(_), Options), 2352 user:prolog_load_file(Module:File, Options), 2353 !. 2354'$load_file'(File, Module, Options) :- 2355 memberchk(stream(_), Options), 2356 !, 2357 '$assert_load_context_module'(File, Module, Options), 2358 '$qdo_load_file'(File, File, Module, Options). 2359'$load_file'(File, Module, Options) :- 2360 ( '$resolved_source_path'(File, FullFile, Options) 2361 -> true 2362 ; '$resolve_source_path'(File, FullFile, Options) 2363 ), 2364 '$mt_load_file'(File, FullFile, Module, Options).
2370'$resolved_source_path'(File, FullFile, Options) :-
2371 current_prolog_flag(emulated_dialect, Dialect),
2372 '$resolved_source_path_db'(File, Dialect, FullFile),
2373 ( '$source_file_property'(FullFile, from_state, true)
2374 ; '$source_file_property'(FullFile, resource, true)
2375 ; '$option'(if(If), Options, true),
2376 '$noload'(If, FullFile, Options)
2377 ),
2378 !.
2385'$resolve_source_path'(File, FullFile, _Options) :- 2386 absolute_file_name(File, FullFile, 2387 [ file_type(prolog), 2388 access(read) 2389 ]), 2390 '$register_resolved_source_path'(File, FullFile). 2391 2392 2393'$register_resolved_source_path'(File, FullFile) :- 2394 ( compound(File) 2395 -> current_prolog_flag(emulated_dialect, Dialect), 2396 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2397 -> true 2398 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2399 ) 2400 ; true 2401 ).
2407:- public '$translated_source'/2. 2408'$translated_source'(Old, New) :- 2409 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2410 assertz('$resolved_source_path_db'(File, Dialect, New))).
2417'$register_resource_file'(FullFile) :-
2418 ( sub_atom(FullFile, 0, _, _, 'res://')
2419 -> '$set_source_file'(FullFile, resource, true)
2420 ; true
2421 ).
2434'$already_loaded'(_File, FullFile, Module, Options) :- 2435 '$assert_load_context_module'(FullFile, Module, Options), 2436 '$current_module'(LoadModules, FullFile), 2437 !, 2438 ( atom(LoadModules) 2439 -> LoadModule = LoadModules 2440 ; LoadModules = [LoadModule|_] 2441 ), 2442 '$import_from_loaded_module'(LoadModule, Module, Options). 2443'$already_loaded'(_, _, user, _) :- !. 2444'$already_loaded'(File, FullFile, Module, Options) :- 2445 ( '$load_context_module'(FullFile, Module, CtxOptions), 2446 '$load_ctx_options'(Options, CtxOptions) 2447 -> true 2448 ; '$load_file'(File, Module, [if(true)|Options]) 2449 ).
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.
2464:- dynamic 2465 '$loading_file'/3. % File, Queue, Thread 2466:- volatile 2467 '$loading_file'/3. 2468 2469'$mt_load_file'(File, FullFile, Module, Options) :- 2470 current_prolog_flag(threads, true), 2471 !, 2472 '$sig_atomic'(setup_call_cleanup( 2473 with_mutex('$load_file', 2474 '$mt_start_load'(FullFile, Loading, Options)), 2475 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2476 '$mt_end_load'(Loading))). 2477'$mt_load_file'(File, FullFile, Module, Options) :- 2478 '$option'(if(If), Options, true), 2479 '$noload'(If, FullFile, Options), 2480 !, 2481 '$already_loaded'(File, FullFile, Module, Options). 2482'$mt_load_file'(File, FullFile, Module, Options) :- 2483 '$sig_atomic'('$qdo_load_file'(File, FullFile, Module, Options)). 2484 2485'$mt_start_load'(FullFile, queue(Queue), _) :- 2486 '$loading_file'(FullFile, Queue, LoadThread), 2487 \+ thread_self(LoadThread), 2488 !. 2489'$mt_start_load'(FullFile, already_loaded, Options) :- 2490 '$option'(if(If), Options, true), 2491 '$noload'(If, FullFile, Options), 2492 !. 2493'$mt_start_load'(FullFile, Ref, _) :- 2494 thread_self(Me), 2495 message_queue_create(Queue), 2496 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2497 2498'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2499 !, 2500 catch(thread_get_message(Queue, _), error(_,_), true), 2501 '$already_loaded'(File, FullFile, Module, Options). 2502'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2503 !, 2504 '$already_loaded'(File, FullFile, Module, Options). 2505'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2506 '$assert_load_context_module'(FullFile, Module, Options), 2507 '$qdo_load_file'(File, FullFile, Module, Options). 2508 2509'$mt_end_load'(queue(_)) :- !. 2510'$mt_end_load'(already_loaded) :- !. 2511'$mt_end_load'(Ref) :- 2512 clause('$loading_file'(_, Queue, _), _, Ref), 2513 erase(Ref), 2514 thread_send_message(Queue, done), 2515 message_queue_destroy(Queue).
2522'$qdo_load_file'(File, FullFile, Module, Options) :- 2523 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2524 '$register_resource_file'(FullFile), 2525 '$run_initialization'(FullFile, Action, Options). 2526 2527'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2528 memberchk('$qlf'(QlfOut), Options), 2529 '$stage_file'(QlfOut, StageQlf), 2530 !, 2531 setup_call_catcher_cleanup( 2532 '$qstart'(StageQlf, Module, State), 2533 '$do_load_file'(File, FullFile, Module, Action, Options), 2534 Catcher, 2535 '$qend'(State, Catcher, StageQlf, QlfOut)). 2536'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2537 '$do_load_file'(File, FullFile, Module, Action, Options). 2538 2539'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2540 '$qlf_open'(Qlf), 2541 '$compilation_mode'(OldMode, qlf), 2542 '$set_source_module'(OldModule, Module). 2543 2544'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2545 '$set_source_module'(_, OldModule), 2546 '$set_compilation_mode'(OldMode), 2547 '$qlf_close', 2548 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2549 2550'$set_source_module'(OldModule, Module) :- 2551 '$current_source_module'(OldModule), 2552 '$set_source_module'(Module).
2559'$do_load_file'(File, FullFile, Module, Action, Options) :- 2560 '$option'(derived_from(DerivedFrom), Options, -), 2561 '$register_derived_source'(FullFile, DerivedFrom), 2562 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2563 ( Mode == qcompile 2564 -> qcompile(Module:File, Options) 2565 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2566 ). 2567 2568'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2569 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2570 statistics(cputime, OldTime), 2571 2572 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2573 Options), 2574 2575 '$compilation_level'(Level), 2576 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2577 '$print_message'(StartMsgLevel, 2578 load_file(start(Level, 2579 file(File, Absolute)))), 2580 2581 ( memberchk(stream(FromStream), Options) 2582 -> Input = stream 2583 ; Input = source 2584 ), 2585 2586 ( Input == stream, 2587 ( '$option'(format(qlf), Options, source) 2588 -> set_stream(FromStream, file_name(Absolute)), 2589 '$qload_stream'(FromStream, Module, Action, LM, Options) 2590 ; '$consult_file'(stream(Absolute, FromStream, []), 2591 Module, Action, LM, Options) 2592 ) 2593 -> true 2594 ; Input == source, 2595 file_name_extension(_, Ext, Absolute), 2596 ( user:prolog_file_type(Ext, qlf), 2597 E = error(_,_), 2598 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2599 E, 2600 print_message(warning, E)) 2601 -> true 2602 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2603 ) 2604 -> true 2605 ; '$print_message'(error, load_file(failed(File))), 2606 fail 2607 ), 2608 2609 '$import_from_loaded_module'(LM, Module, Options), 2610 2611 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2612 statistics(cputime, Time), 2613 ClausesCreated is NewClauses - OldClauses, 2614 TimeUsed is Time - OldTime, 2615 2616 '$print_message'(DoneMsgLevel, 2617 load_file(done(Level, 2618 file(File, Absolute), 2619 Action, 2620 LM, 2621 TimeUsed, 2622 ClausesCreated))), 2623 2624 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2625 2626'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2627 Options) :- 2628 '$save_file_scoped_flags'(ScopedFlags), 2629 '$set_sandboxed_load'(Options, OldSandBoxed), 2630 '$set_verbose_load'(Options, OldVerbose), 2631 '$set_optimise_load'(Options), 2632 '$update_autoload_level'(Options, OldAutoLevel), 2633 '$set_no_xref'(OldXRef). 2634 2635'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2636 '$set_autoload_level'(OldAutoLevel), 2637 set_prolog_flag(xref, OldXRef), 2638 set_prolog_flag(verbose_load, OldVerbose), 2639 set_prolog_flag(sandboxed_load, OldSandBoxed), 2640 '$restore_file_scoped_flags'(ScopedFlags).
2648'$save_file_scoped_flags'(State) :- 2649 current_predicate(findall/3), % Not when doing boot compile 2650 !, 2651 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2652'$save_file_scoped_flags'([]). 2653 2654'$save_file_scoped_flag'(Flag-Value) :- 2655 '$file_scoped_flag'(Flag, Default), 2656 ( current_prolog_flag(Flag, Value) 2657 -> true 2658 ; Value = Default 2659 ). 2660 2661'$file_scoped_flag'(generate_debug_info, true). 2662'$file_scoped_flag'(optimise, false). 2663'$file_scoped_flag'(xref, false). 2664 2665'$restore_file_scoped_flags'([]). 2666'$restore_file_scoped_flags'([Flag-Value|T]) :- 2667 set_prolog_flag(Flag, Value), 2668 '$restore_file_scoped_flags'(T).
2675'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2676 LoadedModule \== Module, 2677 atom(LoadedModule), 2678 !, 2679 '$option'(imports(Import), Options, all), 2680 '$option'(reexport(Reexport), Options, false), 2681 '$import_list'(Module, LoadedModule, Import, Reexport). 2682'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2690'$set_verbose_load'(Options, Old) :- 2691 current_prolog_flag(verbose_load, Old), 2692 ( memberchk(silent(Silent), Options) 2693 -> ( '$negate'(Silent, Level0) 2694 -> '$load_msg_compat'(Level0, Level) 2695 ; Level = Silent 2696 ), 2697 set_prolog_flag(verbose_load, Level) 2698 ; true 2699 ). 2700 2701'$negate'(true, false). 2702'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2711'$set_sandboxed_load'(Options, Old) :- 2712 current_prolog_flag(sandboxed_load, Old), 2713 ( memberchk(sandboxed(SandBoxed), Options), 2714 '$enter_sandboxed'(Old, SandBoxed, New), 2715 New \== Old 2716 -> set_prolog_flag(sandboxed_load, New) 2717 ; true 2718 ). 2719 2720'$enter_sandboxed'(Old, New, SandBoxed) :- 2721 ( Old == false, New == true 2722 -> SandBoxed = true, 2723 '$ensure_loaded_library_sandbox' 2724 ; Old == true, New == false 2725 -> throw(error(permission_error(leave, sandbox, -), _)) 2726 ; SandBoxed = Old 2727 ). 2728'$enter_sandboxed'(false, true, true). 2729 2730'$ensure_loaded_library_sandbox' :- 2731 source_file_property(library(sandbox), module(sandbox)), 2732 !. 2733'$ensure_loaded_library_sandbox' :- 2734 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2735 2736'$set_optimise_load'(Options) :- 2737 ( '$option'(optimise(Optimise), Options) 2738 -> set_prolog_flag(optimise, Optimise) 2739 ; true 2740 ). 2741 2742'$set_no_xref'(OldXRef) :- 2743 ( current_prolog_flag(xref, OldXRef) 2744 -> true 2745 ; OldXRef = false 2746 ), 2747 set_prolog_flag(xref, false).
2754:- thread_local 2755 '$autoload_nesting'/1. 2756 2757'$update_autoload_level'(Options, AutoLevel) :- 2758 '$option'(autoload(Autoload), Options, false), 2759 ( '$autoload_nesting'(CurrentLevel) 2760 -> AutoLevel = CurrentLevel 2761 ; AutoLevel = 0 2762 ), 2763 ( Autoload == false 2764 -> true 2765 ; NewLevel is AutoLevel + 1, 2766 '$set_autoload_level'(NewLevel) 2767 ). 2768 2769'$set_autoload_level'(New) :- 2770 retractall('$autoload_nesting'(_)), 2771 asserta('$autoload_nesting'(New)).
2779'$print_message'(Level, Term) :- 2780 current_predicate(system:print_message/2), 2781 !, 2782 print_message(Level, Term). 2783'$print_message'(warning, Term) :- 2784 source_location(File, Line), 2785 !, 2786 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2787'$print_message'(error, Term) :- 2788 !, 2789 source_location(File, Line), 2790 !, 2791 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2792'$print_message'(_Level, _Term). 2793 2794'$print_message_fail'(E) :- 2795 '$print_message'(error, E), 2796 fail.
2804'$consult_file'(Absolute, Module, What, LM, Options) :- 2805 '$current_source_module'(Module), % same module 2806 !, 2807 '$consult_file_2'(Absolute, Module, What, LM, Options). 2808'$consult_file'(Absolute, Module, What, LM, Options) :- 2809 '$set_source_module'(OldModule, Module), 2810 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2811 '$consult_file_2'(Absolute, Module, What, LM, Options), 2812 '$ifcompiling'('$qlf_end_part'), 2813 '$set_source_module'(OldModule). 2814 2815'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2816 '$set_source_module'(OldModule, Module), 2817 '$load_id'(Absolute, Id, Modified, Options), 2818 '$compile_type'(What), 2819 '$save_lex_state'(LexState, Options), 2820 '$set_dialect'(Options), 2821 setup_call_cleanup( 2822 '$start_consult'(Id, Modified), 2823 '$load_file'(Absolute, Id, LM, Options), 2824 '$end_consult'(Id, LexState, OldModule)). 2825 2826'$end_consult'(Id, LexState, OldModule) :- 2827 '$end_consult'(Id), 2828 '$restore_lex_state'(LexState), 2829 '$set_source_module'(OldModule). 2830 2831 2832:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2836'$save_lex_state'(State, Options) :- 2837 memberchk(scope_settings(false), Options), 2838 !, 2839 State = (-). 2840'$save_lex_state'(lexstate(Style, Dialect), _) :- 2841 '$style_check'(Style, Style), 2842 current_prolog_flag(emulated_dialect, Dialect). 2843 2844'$restore_lex_state'(-) :- !. 2845'$restore_lex_state'(lexstate(Style, Dialect)) :- 2846 '$style_check'(_, Style), 2847 set_prolog_flag(emulated_dialect, Dialect). 2848 2849'$set_dialect'(Options) :- 2850 memberchk(dialect(Dialect), Options), 2851 !, 2852 '$expects_dialect'(Dialect). 2853'$set_dialect'(_). 2854 2855'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 2856 !, 2857 '$modified_id'(Id, Modified, Options). 2858'$load_id'(Id, Id, Modified, Options) :- 2859 '$modified_id'(Id, Modified, Options). 2860 2861'$modified_id'(_, Modified, Options) :- 2862 '$option'(modified(Stamp), Options, Def), 2863 Stamp \== Def, 2864 !, 2865 Modified = Stamp. 2866'$modified_id'(Id, Modified, _) :- 2867 catch(time_file(Id, Modified), 2868 error(_, _), 2869 fail), 2870 !. 2871'$modified_id'(_, 0.0, _). 2872 2873 2874'$compile_type'(What) :- 2875 '$compilation_mode'(How), 2876 ( How == database 2877 -> What = compiled 2878 ; How == qlf 2879 -> What = '*qcompiled*' 2880 ; What = 'boot compiled' 2881 ).
2891:- dynamic 2892 '$load_context_module'/3. 2893:- multifile 2894 '$load_context_module'/3. 2895 2896'$assert_load_context_module'(_, _, Options) :- 2897 memberchk(register(false), Options), 2898 !. 2899'$assert_load_context_module'(File, Module, Options) :- 2900 source_location(FromFile, Line), 2901 !, 2902 '$master_file'(FromFile, MasterFile), 2903 '$check_load_non_module'(File, Module), 2904 '$add_dialect'(Options, Options1), 2905 '$load_ctx_options'(Options1, Options2), 2906 '$store_admin_clause'( 2907 system:'$load_context_module'(File, Module, Options2), 2908 _Layout, MasterFile, FromFile:Line). 2909'$assert_load_context_module'(File, Module, Options) :- 2910 '$check_load_non_module'(File, Module), 2911 '$add_dialect'(Options, Options1), 2912 '$load_ctx_options'(Options1, Options2), 2913 ( clause('$load_context_module'(File, Module, _), true, Ref), 2914 \+ clause_property(Ref, file(_)), 2915 erase(Ref) 2916 -> true 2917 ; true 2918 ), 2919 assertz('$load_context_module'(File, Module, Options2)). 2920 2921'$add_dialect'(Options0, Options) :- 2922 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 2923 !, 2924 Options = [dialect(Dialect)|Options0]. 2925'$add_dialect'(Options, Options).
2932'$load_ctx_options'(Options, CtxOptions) :- 2933 '$load_ctx_options2'(Options, CtxOptions0), 2934 sort(CtxOptions0, CtxOptions). 2935 2936'$load_ctx_options2'([], []). 2937'$load_ctx_options2'([H|T0], [H|T]) :- 2938 '$load_ctx_option'(H), 2939 !, 2940 '$load_ctx_options2'(T0, T). 2941'$load_ctx_options2'([_|T0], T) :- 2942 '$load_ctx_options2'(T0, T). 2943 2944'$load_ctx_option'(derived_from(_)). 2945'$load_ctx_option'(dialect(_)). 2946'$load_ctx_option'(encoding(_)). 2947'$load_ctx_option'(imports(_)). 2948'$load_ctx_option'(reexport(_)).
2956'$check_load_non_module'(File, _) :- 2957 '$current_module'(_, File), 2958 !. % File is a module file 2959'$check_load_non_module'(File, Module) :- 2960 '$load_context_module'(File, OldModule, _), 2961 Module \== OldModule, 2962 !, 2963 format(atom(Msg), 2964 'Non-module file already loaded into module ~w; \c 2965 trying to load into ~w', 2966 [OldModule, Module]), 2967 throw(error(permission_error(load, source, File), 2968 context(load_files/2, Msg))). 2969'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
2982'$load_file'(Path, Id, Module, Options) :- 2983 State = state(true, _, true, false, Id, -), 2984 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 2985 _Stream, Options), 2986 '$valid_term'(Term), 2987 ( arg(1, State, true) 2988 -> '$first_term'(Term, Layout, Id, State, Options), 2989 nb_setarg(1, State, false) 2990 ; '$compile_term'(Term, Layout, Id) 2991 ), 2992 arg(4, State, true) 2993 ; '$fixup_reconsult'(Id), 2994 '$end_load_file'(State) 2995 ), 2996 !, 2997 arg(2, State, Module). 2998 2999'$valid_term'(Var) :- 3000 var(Var), 3001 !, 3002 print_message(error, error(instantiation_error, _)). 3003'$valid_term'(Term) :- 3004 Term \== []. 3005 3006'$end_load_file'(State) :- 3007 arg(1, State, true), % empty file 3008 !, 3009 nb_setarg(2, State, Module), 3010 arg(5, State, Id), 3011 '$current_source_module'(Module), 3012 '$ifcompiling'('$qlf_start_file'(Id)), 3013 '$ifcompiling'('$qlf_end_part'). 3014'$end_load_file'(State) :- 3015 arg(3, State, End), 3016 '$end_load_file'(End, State). 3017 3018'$end_load_file'(true, _). 3019'$end_load_file'(end_module, State) :- 3020 arg(2, State, Module), 3021 '$check_export'(Module), 3022 '$ifcompiling'('$qlf_end_part'). 3023'$end_load_file'(end_non_module, _State) :- 3024 '$ifcompiling'('$qlf_end_part'). 3025 3026 3027'$first_term'(?-(Directive), Layout, Id, State, Options) :- 3028 !, 3029 '$first_term'(:-(Directive), Layout, Id, State, Options). 3030'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 3031 nonvar(Directive), 3032 ( ( Directive = module(Name, Public) 3033 -> Imports = [] 3034 ; Directive = module(Name, Public, Imports) 3035 ) 3036 -> !, 3037 '$module_name'(Name, Id, Module, Options), 3038 '$start_module'(Module, Public, State, Options), 3039 '$module3'(Imports) 3040 ; Directive = expects_dialect(Dialect) 3041 -> !, 3042 '$set_dialect'(Dialect, State), 3043 fail % Still consider next term as first 3044 ). 3045'$first_term'(Term, Layout, Id, State, Options) :- 3046 '$start_non_module'(Id, Term, State, Options), 3047 '$compile_term'(Term, Layout, Id). 3048 3049'$compile_term'(Term, Layout, Id) :- 3050 '$compile_term'(Term, Layout, Id, -). 3051 3052'$compile_term'(Var, _Layout, _Id, _Src) :- 3053 var(Var), 3054 !, 3055 '$instantiation_error'(Var). 3056'$compile_term'((?-Directive), _Layout, Id, _) :- 3057 !, 3058 '$execute_directive'(Directive, Id). 3059'$compile_term'((:-Directive), _Layout, Id, _) :- 3060 !, 3061 '$execute_directive'(Directive, Id). 3062'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :- 3063 !, 3064 '$compile_term'(Term, Layout, Id, File:Line). 3065'$compile_term'(Clause, Layout, Id, SrcLoc) :- 3066 E = error(_,_), 3067 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3068 '$print_message'(error, E)). 3069 3070'$start_non_module'(_Id, Term, _State, Options) :- 3071 '$option'(must_be_module(true), Options, false), 3072 !, 3073 '$domain_error'(module_header, Term). 3074'$start_non_module'(Id, _Term, State, _Options) :- 3075 '$current_source_module'(Module), 3076 '$ifcompiling'('$qlf_start_file'(Id)), 3077 '$qset_dialect'(State), 3078 nb_setarg(2, State, Module), 3079 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3092'$set_dialect'(Dialect, State) :- 3093 '$compilation_mode'(qlf, database), 3094 !, 3095 '$expects_dialect'(Dialect), 3096 '$compilation_mode'(_, qlf), 3097 nb_setarg(6, State, Dialect). 3098'$set_dialect'(Dialect, _) :- 3099 '$expects_dialect'(Dialect). 3100 3101'$qset_dialect'(State) :- 3102 '$compilation_mode'(qlf), 3103 arg(6, State, Dialect), Dialect \== (-), 3104 !, 3105 '$add_directive_wic'('$expects_dialect'(Dialect)). 3106'$qset_dialect'(_). 3107 3108'$expects_dialect'(Dialect) :- 3109 Dialect == swi, 3110 !, 3111 set_prolog_flag(emulated_dialect, Dialect). 3112'$expects_dialect'(Dialect) :- 3113 current_predicate(expects_dialect/1), 3114 !, 3115 expects_dialect(Dialect). 3116'$expects_dialect'(Dialect) :- 3117 use_module(library(dialect), [expects_dialect/1]), 3118 expects_dialect(Dialect). 3119 3120 3121 /******************************* 3122 * MODULES * 3123 *******************************/ 3124 3125'$start_module'(Module, _Public, State, _Options) :- 3126 '$current_module'(Module, OldFile), 3127 source_location(File, _Line), 3128 OldFile \== File, OldFile \== [], 3129 same_file(OldFile, File), 3130 !, 3131 nb_setarg(2, State, Module), 3132 nb_setarg(4, State, true). % Stop processing 3133'$start_module'(Module, Public, State, Options) :- 3134 arg(5, State, File), 3135 nb_setarg(2, State, Module), 3136 source_location(_File, Line), 3137 '$option'(redefine_module(Action), Options, false), 3138 '$module_class'(File, Class, Super), 3139 '$reset_dialect'(File, Class), 3140 '$redefine_module'(Module, File, Action), 3141 '$declare_module'(Module, Class, Super, File, Line, false), 3142 '$export_list'(Public, Module, Ops), 3143 '$ifcompiling'('$qlf_start_module'(Module)), 3144 '$export_ops'(Ops, Module, File), 3145 '$qset_dialect'(State), 3146 nb_setarg(3, State, end_module).
swi
dialect.3153'$reset_dialect'(File, library) :- 3154 file_name_extension(_, pl, File), 3155 !, 3156 set_prolog_flag(emulated_dialect, swi). 3157'$reset_dialect'(_, _).
3164'$module3'(Var) :- 3165 var(Var), 3166 !, 3167 '$instantiation_error'(Var). 3168'$module3'([]) :- !. 3169'$module3'([H|T]) :- 3170 !, 3171 '$module3'(H), 3172 '$module3'(T). 3173'$module3'(Id) :- 3174 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.3188'$module_name'(_, _, Module, Options) :- 3189 '$option'(module(Module), Options), 3190 !, 3191 '$current_source_module'(Context), 3192 Context \== Module. % cause '$first_term'/5 to fail. 3193'$module_name'(Var, Id, Module, Options) :- 3194 var(Var), 3195 !, 3196 file_base_name(Id, File), 3197 file_name_extension(Var, _, File), 3198 '$module_name'(Var, Id, Module, Options). 3199'$module_name'(Reserved, _, _, _) :- 3200 '$reserved_module'(Reserved), 3201 !, 3202 throw(error(permission_error(load, module, Reserved), _)). 3203'$module_name'(Module, _Id, Module, _). 3204 3205 3206'$reserved_module'(system). 3207'$reserved_module'(user).
3212'$redefine_module'(_Module, _, false) :- !. 3213'$redefine_module'(Module, File, true) :- 3214 !, 3215 ( module_property(Module, file(OldFile)), 3216 File \== OldFile 3217 -> unload_file(OldFile) 3218 ; true 3219 ). 3220'$redefine_module'(Module, File, ask) :- 3221 ( stream_property(user_input, tty(true)), 3222 module_property(Module, file(OldFile)), 3223 File \== OldFile, 3224 '$rdef_response'(Module, OldFile, File, true) 3225 -> '$redefine_module'(Module, File, true) 3226 ; true 3227 ). 3228 3229'$rdef_response'(Module, OldFile, File, Ok) :- 3230 repeat, 3231 print_message(query, redefine_module(Module, OldFile, File)), 3232 get_single_char(Char), 3233 '$rdef_response'(Char, Ok0), 3234 !, 3235 Ok = Ok0. 3236 3237'$rdef_response'(Char, true) :- 3238 memberchk(Char, `yY`), 3239 format(user_error, 'yes~n', []). 3240'$rdef_response'(Char, false) :- 3241 memberchk(Char, `nN`), 3242 format(user_error, 'no~n', []). 3243'$rdef_response'(Char, _) :- 3244 memberchk(Char, `a`), 3245 format(user_error, 'abort~n', []), 3246 abort. 3247'$rdef_response'(_, _) :- 3248 print_message(help, redefine_module_reply), 3249 fail.
system
, while all normal user modules inherit
from user
.3259'$module_class'(File, Class, system) :- 3260 current_prolog_flag(home, Home), 3261 sub_atom(File, 0, Len, _, Home), 3262 ( sub_atom(File, Len, _, _, '/boot/') 3263 -> Class = system 3264 ; '$lib_prefix'(Prefix), 3265 sub_atom(File, Len, _, _, Prefix) 3266 -> Class = library 3267 ; file_directory_name(File, Home), 3268 file_name_extension(_, rc, File) 3269 -> Class = library 3270 ), 3271 !. 3272'$module_class'(_, user, user). 3273 3274'$lib_prefix'('/library'). 3275'$lib_prefix'('/xpce/prolog/'). 3276 3277'$check_export'(Module) :- 3278 '$undefined_export'(Module, UndefList), 3279 ( '$member'(Undef, UndefList), 3280 strip_module(Undef, _, Local), 3281 print_message(error, 3282 undefined_export(Module, Local)), 3283 fail 3284 ; true 3285 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3294'$import_list'(_, _, Var, _) :- 3295 var(Var), 3296 !, 3297 throw(error(instantitation_error, _)). 3298'$import_list'(Target, Source, all, Reexport) :- 3299 !, 3300 '$exported_ops'(Source, Import, Predicates), 3301 '$module_property'(Source, exports(Predicates)), 3302 '$import_all'(Import, Target, Source, Reexport, weak). 3303'$import_list'(Target, Source, except(Spec), Reexport) :- 3304 !, 3305 '$exported_ops'(Source, Export, Predicates), 3306 '$module_property'(Source, exports(Predicates)), 3307 ( is_list(Spec) 3308 -> true 3309 ; throw(error(type_error(list, Spec), _)) 3310 ), 3311 '$import_except'(Spec, Export, Import), 3312 '$import_all'(Import, Target, Source, Reexport, weak). 3313'$import_list'(Target, Source, Import, Reexport) :- 3314 !, 3315 is_list(Import), 3316 !, 3317 '$import_all'(Import, Target, Source, Reexport, strong). 3318'$import_list'(_, _, Import, _) :- 3319 throw(error(type_error(import_specifier, Import))). 3320 3321 3322'$import_except'([], List, List). 3323'$import_except'([H|T], List0, List) :- 3324 '$import_except_1'(H, List0, List1), 3325 '$import_except'(T, List1, List). 3326 3327'$import_except_1'(Var, _, _) :- 3328 var(Var), 3329 !, 3330 throw(error(instantitation_error, _)). 3331'$import_except_1'(PI as N, List0, List) :- 3332 '$pi'(PI), atom(N), 3333 !, 3334 '$canonical_pi'(PI, CPI), 3335 '$import_as'(CPI, N, List0, List). 3336'$import_except_1'(op(P,A,N), List0, List) :- 3337 !, 3338 '$remove_ops'(List0, op(P,A,N), List). 3339'$import_except_1'(PI, List0, List) :- 3340 '$pi'(PI), 3341 !, 3342 '$canonical_pi'(PI, CPI), 3343 '$select'(P, List0, List), 3344 '$canonical_pi'(CPI, P), 3345 !. 3346'$import_except_1'(Except, _, _) :- 3347 throw(error(type_error(import_specifier, Except), _)). 3348 3349'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3350 '$canonical_pi'(PI2, CPI), 3351 !. 3352'$import_as'(PI, N, [H|T0], [H|T]) :- 3353 !, 3354 '$import_as'(PI, N, T0, T). 3355'$import_as'(PI, _, _, _) :- 3356 throw(error(existence_error(export, PI), _)). 3357 3358'$pi'(N/A) :- atom(N), integer(A), !. 3359'$pi'(N//A) :- atom(N), integer(A). 3360 3361'$canonical_pi'(N//A0, N/A) :- 3362 A is A0 + 2. 3363'$canonical_pi'(PI, PI). 3364 3365'$remove_ops'([], _, []). 3366'$remove_ops'([Op|T0], Pattern, T) :- 3367 subsumes_term(Pattern, Op), 3368 !, 3369 '$remove_ops'(T0, Pattern, T). 3370'$remove_ops'([H|T0], Pattern, [H|T]) :- 3371 '$remove_ops'(T0, Pattern, T).
3376'$import_all'(Import, Context, Source, Reexport, Strength) :-
3377 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3378 ( Reexport == true,
3379 ( '$list_to_conj'(Imported, Conj)
3380 -> export(Context:Conj),
3381 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3382 ; true
3383 ),
3384 source_location(File, _Line),
3385 '$export_ops'(ImpOps, Context, File)
3386 ; true
3387 ).
3391'$import_all2'([], _, _, [], [], _). 3392'$import_all2'([PI as NewName|Rest], Context, Source, 3393 [NewName/Arity|Imported], ImpOps, Strength) :- 3394 !, 3395 '$canonical_pi'(PI, Name/Arity), 3396 length(Args, Arity), 3397 Head =.. [Name|Args], 3398 NewHead =.. [NewName|Args], 3399 ( '$get_predicate_attribute'(Source:Head, transparent, 1) 3400 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3401 ; true 3402 ), 3403 ( source_location(File, Line) 3404 -> E = error(_,_), 3405 catch('$store_admin_clause'((NewHead :- Source:Head), 3406 _Layout, File, File:Line), 3407 E, '$print_message'(error, E)) 3408 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3409 ), % duplicate load 3410 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3411'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3412 [op(P,A,N)|ImpOps], Strength) :- 3413 !, 3414 '$import_ops'(Context, Source, op(P,A,N)), 3415 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3416'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3417 Error = error(_,_), 3418 catch(Context:'$import'(Source:Pred, Strength), Error, 3419 print_message(error, Error)), 3420 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3421 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3422 3423 3424'$list_to_conj'([One], One) :- !. 3425'$list_to_conj'([H|T], (H,Rest)) :- 3426 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3433'$exported_ops'(Module, Ops, Tail) :- 3434 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3435 !, 3436 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3437'$exported_ops'(_, Ops, Ops). 3438 3439'$exported_op'(Module, P, A, N) :- 3440 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3441 Module:'$exported_op'(P, A, N).
3448'$import_ops'(To, From, Pattern) :- 3449 ground(Pattern), 3450 !, 3451 Pattern = op(P,A,N), 3452 op(P,A,To:N), 3453 ( '$exported_op'(From, P, A, N) 3454 -> true 3455 ; print_message(warning, no_exported_op(From, Pattern)) 3456 ). 3457'$import_ops'(To, From, Pattern) :- 3458 ( '$exported_op'(From, Pri, Assoc, Name), 3459 Pattern = op(Pri, Assoc, Name), 3460 op(Pri, Assoc, To:Name), 3461 fail 3462 ; true 3463 ).
3471'$export_list'(Decls, Module, Ops) :- 3472 is_list(Decls), 3473 !, 3474 '$do_export_list'(Decls, Module, Ops). 3475'$export_list'(Decls, _, _) :- 3476 var(Decls), 3477 throw(error(instantiation_error, _)). 3478'$export_list'(Decls, _, _) :- 3479 throw(error(type_error(list, Decls), _)). 3480 3481'$do_export_list'([], _, []) :- !. 3482'$do_export_list'([H|T], Module, Ops) :- 3483 !, 3484 E = error(_,_), 3485 catch('$export1'(H, Module, Ops, Ops1), 3486 E, ('$print_message'(error, E), Ops = Ops1)), 3487 '$do_export_list'(T, Module, Ops1). 3488 3489'$export1'(Var, _, _, _) :- 3490 var(Var), 3491 !, 3492 throw(error(instantiation_error, _)). 3493'$export1'(Op, _, [Op|T], T) :- 3494 Op = op(_,_,_), 3495 !. 3496'$export1'(PI0, Module, Ops, Ops) :- 3497 strip_module(Module:PI0, M, PI), 3498 ( PI = (_//_) 3499 -> non_terminal(M:PI) 3500 ; true 3501 ), 3502 export(M:PI). 3503 3504'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3505 E = error(_,_), 3506 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File), 3507 '$export_op'(Pri, Assoc, Name, Module, File) 3508 ), 3509 E, '$print_message'(error, E)), 3510 '$export_ops'(T, Module, File). 3511'$export_ops'([], _, _). 3512 3513'$export_op'(Pri, Assoc, Name, Module, File) :- 3514 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3515 -> true 3516 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File) 3517 ), 3518 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3524'$execute_directive'(Goal, F) :- 3525 '$execute_directive_2'(Goal, F). 3526 3527'$execute_directive_2'(encoding(Encoding), _F) :- 3528 !, 3529 ( '$load_input'(_F, S) 3530 -> set_stream(S, encoding(Encoding)) 3531 ). 3532'$execute_directive_2'(Goal, _) :- 3533 \+ '$compilation_mode'(database), 3534 !, 3535 '$add_directive_wic2'(Goal, Type), 3536 ( Type == call % suspend compiling into .qlf file 3537 -> '$compilation_mode'(Old, database), 3538 setup_call_cleanup( 3539 '$directive_mode'(OldDir, Old), 3540 '$execute_directive_3'(Goal), 3541 ( '$set_compilation_mode'(Old), 3542 '$set_directive_mode'(OldDir) 3543 )) 3544 ; '$execute_directive_3'(Goal) 3545 ). 3546'$execute_directive_2'(Goal, _) :- 3547 '$execute_directive_3'(Goal). 3548 3549'$execute_directive_3'(Goal) :- 3550 '$current_source_module'(Module), 3551 '$valid_directive'(Module:Goal), 3552 !, 3553 ( '$pattr_directive'(Goal, Module) 3554 -> true 3555 ; Term = error(_,_), 3556 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3557 -> true 3558 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3559 fail 3560 ). 3561'$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.3570:- multifile prolog:sandbox_allowed_directive/1. 3571:- multifile prolog:sandbox_allowed_clause/1. 3572:- meta_predicate '$valid_directive'( ). 3573 3574'$valid_directive'(_) :- 3575 current_prolog_flag(sandboxed_load, false), 3576 !. 3577'$valid_directive'(Goal) :- 3578 Error = error(Formal, _), 3579 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3580 !, 3581 ( var(Formal) 3582 -> true 3583 ; print_message(error, Error), 3584 fail 3585 ). 3586'$valid_directive'(Goal) :- 3587 print_message(error, 3588 error(permission_error(execute, 3589 sandboxed_directive, 3590 Goal), _)), 3591 fail. 3592 3593'$exception_in_directive'(Term) :- 3594 '$print_message'(error, Term), 3595 fail. 3596 3597% Note that the list, consult and ensure_loaded directives are already 3598% handled at compile time and therefore should not go into the 3599% intermediate code file. 3600 3601'$add_directive_wic2'(Goal, Type) :- 3602 '$common_goal_type'(Goal, Type), 3603 !, 3604 ( Type == load 3605 -> true 3606 ; '$current_source_module'(Module), 3607 '$add_directive_wic'(Module:Goal) 3608 ). 3609'$add_directive_wic2'(Goal, _) :- 3610 ( '$compilation_mode'(qlf) % no problem for qlf files 3611 -> true 3612 ; print_message(error, mixed_directive(Goal)) 3613 ). 3614 3615'$common_goal_type'((A,B), Type) :- 3616 !, 3617 '$common_goal_type'(A, Type), 3618 '$common_goal_type'(B, Type). 3619'$common_goal_type'((A;B), Type) :- 3620 !, 3621 '$common_goal_type'(A, Type), 3622 '$common_goal_type'(B, Type). 3623'$common_goal_type'((A->B), Type) :- 3624 !, 3625 '$common_goal_type'(A, Type), 3626 '$common_goal_type'(B, Type). 3627'$common_goal_type'(Goal, Type) :- 3628 '$goal_type'(Goal, Type). 3629 3630'$goal_type'(Goal, Type) :- 3631 ( '$load_goal'(Goal) 3632 -> Type = load 3633 ; Type = call 3634 ). 3635 3636'$load_goal'([_|_]). 3637'$load_goal'(consult(_)). 3638'$load_goal'(load_files(_)). 3639'$load_goal'(load_files(_,Options)) :- 3640 memberchk(qcompile(QlfMode), Options), 3641 '$qlf_part_mode'(QlfMode). 3642'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic). 3643'$load_goal'(use_module(_)) :- '$compilation_mode'(wic). 3644'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic). 3645 3646'$qlf_part_mode'(part). 3647'$qlf_part_mode'(true). % compatibility 3648 3649 3650 /******************************** 3651 * COMPILE A CLAUSE * 3652 *********************************/
3659'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3660 Owner \== (-), 3661 !, 3662 setup_call_cleanup( 3663 '$start_aux'(Owner, Context), 3664 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3665 '$end_aux'(Owner, Context)). 3666'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3667 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3668 3669'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3670 ( '$compilation_mode'(database) 3671 -> '$record_clause'(Clause, File, SrcLoc) 3672 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3673 '$qlf_assert_clause'(Ref, development) 3674 ).
3684'$store_clause'((_, _), _, _, _) :- 3685 !, 3686 print_message(error, cannot_redefine_comma), 3687 fail. 3688'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3689 nonvar(Pre), 3690 Pre = (Head,Cond), 3691 !, 3692 ( '$is_true'(Cond), current_prolog_flag(optimise, true) 3693 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc) 3694 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc) 3695 ). 3696'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3697 '$valid_clause'(Clause), 3698 !, 3699 ( '$compilation_mode'(database) 3700 -> '$record_clause'(Clause, File, SrcLoc) 3701 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3702 '$qlf_assert_clause'(Ref, development) 3703 ). 3704 3705'$is_true'(true) => true. 3706'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B). 3707'$is_true'(_) => fail. 3708 3709'$valid_clause'(_) :- 3710 current_prolog_flag(sandboxed_load, false), 3711 !. 3712'$valid_clause'(Clause) :- 3713 \+ '$cross_module_clause'(Clause), 3714 !. 3715'$valid_clause'(Clause) :- 3716 Error = error(Formal, _), 3717 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3718 !, 3719 ( var(Formal) 3720 -> true 3721 ; print_message(error, Error), 3722 fail 3723 ). 3724'$valid_clause'(Clause) :- 3725 print_message(error, 3726 error(permission_error(assert, 3727 sandboxed_clause, 3728 Clause), _)), 3729 fail. 3730 3731'$cross_module_clause'(Clause) :- 3732 '$head_module'(Clause, Module), 3733 \+ '$current_source_module'(Module). 3734 3735'$head_module'(Var, _) :- 3736 var(Var), !, fail. 3737'$head_module'((Head :- _), Module) :- 3738 '$head_module'(Head, Module). 3739'$head_module'(Module:_, Module). 3740 3741'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3742'$clause_source'(Clause, Clause, -).
3749:- public 3750 '$store_clause'/2. 3751 3752'$store_clause'(Term, Id) :- 3753 '$clause_source'(Term, Clause, SrcLoc), 3754 '$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)
3775compile_aux_clauses(_Clauses) :- 3776 current_prolog_flag(xref, true), 3777 !. 3778compile_aux_clauses(Clauses) :- 3779 source_location(File, _Line), 3780 '$compile_aux_clauses'(Clauses, File). 3781 3782'$compile_aux_clauses'(Clauses, File) :- 3783 setup_call_cleanup( 3784 '$start_aux'(File, Context), 3785 '$store_aux_clauses'(Clauses, File), 3786 '$end_aux'(File, Context)). 3787 3788'$store_aux_clauses'(Clauses, File) :- 3789 is_list(Clauses), 3790 !, 3791 forall('$member'(C,Clauses), 3792 '$compile_term'(C, _Layout, File)). 3793'$store_aux_clauses'(Clause, File) :- 3794 '$compile_term'(Clause, _Layout, File). 3795 3796 3797 /******************************* 3798 * STAGING * 3799 *******************************/
3809'$stage_file'(Target, Stage) :- 3810 file_directory_name(Target, Dir), 3811 file_base_name(Target, File), 3812 current_prolog_flag(pid, Pid), 3813 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 3814 3815'$install_staged_file'(exit, Staged, Target, error) :- 3816 !, 3817 rename_file(Staged, Target). 3818'$install_staged_file'(exit, Staged, Target, OnError) :- 3819 !, 3820 InstallError = error(_,_), 3821 catch(rename_file(Staged, Target), 3822 InstallError, 3823 '$install_staged_error'(OnError, InstallError, Staged, Target)). 3824'$install_staged_file'(_, Staged, _, _OnError) :- 3825 E = error(_,_), 3826 catch(delete_file(Staged), E, true). 3827 3828'$install_staged_error'(OnError, Error, Staged, _Target) :- 3829 E = error(_,_), 3830 catch(delete_file(Staged), E, true), 3831 ( OnError = silent 3832 -> true 3833 ; OnError = fail 3834 -> fail 3835 ; print_message(warning, Error) 3836 ). 3837 3838 3839 /******************************* 3840 * READING * 3841 *******************************/ 3842 3843:- multifile 3844 prolog:comment_hook/3. % hook for read_clause/3 3845 3846 3847 /******************************* 3848 * FOREIGN INTERFACE * 3849 *******************************/ 3850 3851% call-back from PL_register_foreign(). First argument is the module 3852% into which the foreign predicate is loaded and second is a term 3853% describing the arguments. 3854 3855:- dynamic 3856 '$foreign_registered'/2. 3857 3858 /******************************* 3859 * TEMPORARY TERM EXPANSION * 3860 *******************************/ 3861 3862% Provide temporary definitions for the boot-loader. These are replaced 3863% by the real thing in load.pl 3864 3865:- dynamic 3866 '$expand_goal'/2, 3867 '$expand_term'/4. 3868 3869'$expand_goal'(In, In). 3870'$expand_term'(In, Layout, In, Layout). 3871 3872 3873 /******************************* 3874 * TYPE SUPPORT * 3875 *******************************/ 3876 3877'$type_error'(Type, Value) :- 3878 ( var(Value) 3879 -> throw(error(instantiation_error, _)) 3880 ; throw(error(type_error(Type, Value), _)) 3881 ). 3882 3883'$domain_error'(Type, Value) :- 3884 throw(error(domain_error(Type, Value), _)). 3885 3886'$existence_error'(Type, Object) :- 3887 throw(error(existence_error(Type, Object), _)). 3888 3889'$permission_error'(Action, Type, Term) :- 3890 throw(error(permission_error(Action, Type, Term), _)). 3891 3892'$instantiation_error'(_Var) :- 3893 throw(error(instantiation_error, _)). 3894 3895'$uninstantiation_error'(NonVar) :- 3896 throw(error(uninstantiation_error(NonVar), _)). 3897 3898'$must_be'(list, X) :- !, 3899 '$skip_list'(_, X, Tail), 3900 ( Tail == [] 3901 -> true 3902 ; '$type_error'(list, Tail) 3903 ). 3904'$must_be'(options, X) :- !, 3905 ( '$is_options'(X) 3906 -> true 3907 ; '$type_error'(options, X) 3908 ). 3909'$must_be'(atom, X) :- !, 3910 ( atom(X) 3911 -> true 3912 ; '$type_error'(atom, X) 3913 ). 3914'$must_be'(integer, X) :- !, 3915 ( integer(X) 3916 -> true 3917 ; '$type_error'(integer, X) 3918 ). 3919'$must_be'(between(Low,High), X) :- !, 3920 ( integer(X) 3921 -> ( between(Low, High, X) 3922 -> true 3923 ; '$domain_error'(between(Low,High), X) 3924 ) 3925 ; '$type_error'(integer, X) 3926 ). 3927'$must_be'(callable, X) :- !, 3928 ( callable(X) 3929 -> true 3930 ; '$type_error'(callable, X) 3931 ). 3932'$must_be'(acyclic, X) :- !, 3933 ( acyclic_term(X) 3934 -> true 3935 ; '$domain_error'(acyclic_term, X) 3936 ). 3937'$must_be'(oneof(Type, Domain, List), X) :- !, 3938 '$must_be'(Type, X), 3939 ( memberchk(X, List) 3940 -> true 3941 ; '$domain_error'(Domain, X) 3942 ). 3943'$must_be'(boolean, X) :- !, 3944 ( (X == true ; X == false) 3945 -> true 3946 ; '$type_error'(boolean, X) 3947 ). 3948'$must_be'(ground, X) :- !, 3949 ( ground(X) 3950 -> true 3951 ; '$instantiation_error'(X) 3952 ). 3953'$must_be'(filespec, X) :- !, 3954 ( ( atom(X) 3955 ; string(X) 3956 ; compound(X), 3957 compound_name_arity(X, _, 1) 3958 ) 3959 -> true 3960 ; '$type_error'(filespec, X) 3961 ). 3962 3963% Use for debugging 3964%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 3965 3966 3967 /******************************** 3968 * LIST PROCESSING * 3969 *********************************/ 3970 3971'$member'(El, [H|T]) :- 3972 '$member_'(T, El, H). 3973 3974'$member_'(_, El, El). 3975'$member_'([H|T], El, _) :- 3976 '$member_'(T, El, H). 3977 3978 3979'$append'([], L, L). 3980'$append'([H|T], L, [H|R]) :- 3981 '$append'(T, L, R). 3982 3983'$select'(X, [X|Tail], Tail). 3984'$select'(Elem, [Head|Tail], [Head|Rest]) :- 3985 '$select'(Elem, Tail, Rest). 3986 3987'$reverse'(L1, L2) :- 3988 '$reverse'(L1, [], L2). 3989 3990'$reverse'([], List, List). 3991'$reverse'([Head|List1], List2, List3) :- 3992 '$reverse'(List1, [Head|List2], List3). 3993 3994'$delete'([], _, []) :- !. 3995'$delete'([Elem|Tail], Elem, Result) :- 3996 !, 3997 '$delete'(Tail, Elem, Result). 3998'$delete'([Head|Tail], Elem, [Head|Rest]) :- 3999 '$delete'(Tail, Elem, Rest). 4000 4001'$last'([H|T], Last) :- 4002 '$last'(T, H, Last). 4003 4004'$last'([], Last, Last). 4005'$last'([H|T], _, Last) :- 4006 '$last'(T, H, Last).
4013:- '$iso'((length/2)). 4014 4015length(List, Length) :- 4016 var(Length), 4017 !, 4018 '$skip_list'(Length0, List, Tail), 4019 ( Tail == [] 4020 -> Length = Length0 % +,- 4021 ; var(Tail) 4022 -> Tail \== Length, % avoid length(L,L) 4023 '$length3'(Tail, Length, Length0) % -,- 4024 ; throw(error(type_error(list, List), 4025 context(length/2, _))) 4026 ). 4027length(List, Length) :- 4028 integer(Length), 4029 Length >= 0, 4030 !, 4031 '$skip_list'(Length0, List, Tail), 4032 ( Tail == [] % proper list 4033 -> Length = Length0 4034 ; var(Tail) 4035 -> Extra is Length-Length0, 4036 '$length'(Tail, Extra) 4037 ; throw(error(type_error(list, List), 4038 context(length/2, _))) 4039 ). 4040length(_, Length) :- 4041 integer(Length), 4042 !, 4043 throw(error(domain_error(not_less_than_zero, Length), 4044 context(length/2, _))). 4045length(_, Length) :- 4046 throw(error(type_error(integer, Length), 4047 context(length/2, _))). 4048 4049'$length3'([], N, N). 4050'$length3'([_|List], N, N0) :- 4051 N1 is N0+1, 4052 '$length3'(List, N, N1). 4053 4054 4055 /******************************* 4056 * OPTION PROCESSING * 4057 *******************************/
4063'$is_options'(Map) :- 4064 is_dict(Map, _), 4065 !. 4066'$is_options'(List) :- 4067 is_list(List), 4068 ( List == [] 4069 -> true 4070 ; List = [H|_], 4071 '$is_option'(H, _, _) 4072 ). 4073 4074'$is_option'(Var, _, _) :- 4075 var(Var), !, fail. 4076'$is_option'(F, Name, Value) :- 4077 functor(F, _, 1), 4078 !, 4079 F =.. [Name,Value]. 4080'$is_option'(Name=Value, Name, Value).
4084'$option'(Opt, Options) :- 4085 is_dict(Options), 4086 !, 4087 [Opt] :< Options. 4088'$option'(Opt, Options) :- 4089 memberchk(Opt, Options).
4093'$option'(Term, Options, Default) :-
4094 arg(1, Term, Value),
4095 functor(Term, Name, 1),
4096 ( is_dict(Options)
4097 -> ( get_dict(Name, Options, GVal)
4098 -> Value = GVal
4099 ; Value = Default
4100 )
4101 ; functor(Gen, Name, 1),
4102 arg(1, Gen, GVal),
4103 ( memberchk(Gen, Options)
4104 -> Value = GVal
4105 ; Value = Default
4106 )
4107 ).
4115'$select_option'(Opt, Options, Rest) :-
4116 select_dict([Opt], Options, Rest).
4124'$merge_options'(New, Old, Merged) :- 4125 put_dict(New, Old, Merged). 4126 4127 4128 /******************************* 4129 * HANDLE TRACER 'L'-COMMAND * 4130 *******************************/ 4131 4132:- public '$prolog_list_goal'/1. 4133 4134:- multifile 4135 user:prolog_list_goal/1. 4136 4137'$prolog_list_goal'(Goal) :- 4138 user:prolog_list_goal(Goal), 4139 !. 4140'$prolog_list_goal'(Goal) :- 4141 use_module(library(listing), [listing/1]), 4142 @(listing(Goal), user). 4143 4144 4145 /******************************* 4146 * HALT * 4147 *******************************/ 4148 4149:- '$iso'((halt/0)). 4150 4151halt :- 4152 halt(0).
4161:- meta_predicate at_halt( ). 4162:- dynamic system:term_expansion/2, '$at_halt'/2. 4163:- multifile system:term_expansion/2, '$at_halt'/2. 4164 4165systemterm_expansion((:- at_halt(Goal)), 4166 system:'$at_halt'(Module:Goal, File:Line)) :- 4167 \+ current_prolog_flag(xref, true), 4168 source_location(File, Line), 4169 '$current_source_module'(Module). 4170 4171at_halt(Goal) :- 4172 asserta('$at_halt'(Goal, (-):0)). 4173 4174:- public '$run_at_halt'/0. 4175 4176'$run_at_halt' :- 4177 forall(clause('$at_halt'(Goal, Src), true, Ref), 4178 ( '$call_at_halt'(Goal, Src), 4179 erase(Ref) 4180 )). 4181 4182'$call_at_halt'(Goal, _Src) :- 4183 catch(Goal, E, true), 4184 !, 4185 ( var(E) 4186 -> true 4187 ; subsumes_term(cancel_halt(_), E) 4188 -> '$print_message'(informational, E), 4189 fail 4190 ; '$print_message'(error, E) 4191 ). 4192'$call_at_halt'(Goal, _Src) :- 4193 '$print_message'(warning, goal_failed(at_halt, Goal)).
4201cancel_halt(Reason) :- 4202 throw(cancel_halt(Reason)). 4203 4204 4205 /******************************** 4206 * LOAD OTHER MODULES * 4207 *********************************/ 4208 4209:- meta_predicate 4210 '$load_wic_files'( ). 4211 4212'$load_wic_files'(Files) :- 4213 Files = Module:_, 4214 '$execute_directive'('$set_source_module'(OldM, Module), []), 4215 '$save_lex_state'(LexState, []), 4216 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4217 '$compilation_mode'(OldC, wic), 4218 consult(Files), 4219 '$execute_directive'('$set_source_module'(OldM), []), 4220 '$execute_directive'('$restore_lex_state'(LexState), []), 4221 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4229:- public '$load_additional_boot_files'/0. 4230 4231'$load_additional_boot_files' :- 4232 current_prolog_flag(argv, Argv), 4233 '$get_files_argv'(Argv, Files), 4234 ( Files \== [] 4235 -> format('Loading additional boot files~n'), 4236 '$load_wic_files'(user:Files), 4237 format('additional boot files loaded~n') 4238 ; true 4239 ). 4240 4241'$get_files_argv'([], []) :- !. 4242'$get_files_argv'(['-c'|Files], Files) :- !. 4243'$get_files_argv'([_|Rest], Files) :- 4244 '$get_files_argv'(Rest, Files). 4245 4246'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4247 source_location(File, _Line), 4248 file_directory_name(File, Dir), 4249 atom_concat(Dir, '/load.pl', LoadFile), 4250 '$load_wic_files'(system:[LoadFile]), 4251 ( current_prolog_flag(windows, true) 4252 -> atom_concat(Dir, '/menu.pl', MenuFile), 4253 '$load_wic_files'(system:[MenuFile]) 4254 ; true 4255 ), 4256 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4257 '$compilation_mode'(OldC, wic), 4258 '$execute_directive'('$set_source_module'(user), []), 4259 '$set_compilation_mode'(OldC) 4260 ))