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-2020, University of Amsterdam 7 VU University Amsterdam 8 CWI, Amsterdam 9 All rights reserved. 10 11 Redistribution and use in source and binary forms, with or without 12 modification, are permitted provided that the following conditions 13 are met: 14 15 1. Redistributions of source code must retain the above copyright 16 notice, this list of conditions and the following disclaimer. 17 18 2. Redistributions in binary form must reproduce the above copyright 19 notice, this list of conditions and the following disclaimer in 20 the documentation and/or other materials provided with the 21 distribution. 22 23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 POSSIBILITY OF SUCH DAMAGE. 35*/ 36 37/* 38Consult, derivates and basic things. This module is loaded by the 39C-written bootstrap compiler. 40 41The $:- directive is executed by the bootstrap compiler, but not 42inserted in the intermediate code file. Used to print diagnostic 43messages and start the Prolog defined compiler for the remaining boot 44modules. 45 46If you want to debug this module, put a '$:-'(trace). directive 47somewhere. The tracer will work properly under boot compilation as it 48will use the C defined write predicate to print goals and does not 49attempt to call the Prolog defined trace interceptor. 50*/ 51 52 /******************************** 53 * LOAD INTO MODULE SYSTEM * 54 ********************************/ 55 56:- '$set_source_module'(system). 57 58'$boot_message'(_Format, _Args) :- 59 current_prolog_flag(verbose, silent), 60 !. 61'$boot_message'(Format, Args) :- 62 format(Format, Args), 63 !. 64 65'$:-'('$boot_message'('Loading boot file ...~n', [])). 66 67 68 /******************************** 69 * DIRECTIVES * 70 *********************************/ 71 72:- meta_predicate 73 dynamic( ), 74 multifile( ), 75 public( ), 76 module_transparent( ), 77 discontiguous( ), 78 volatile( ), 79 thread_local( ), 80 noprofile( ), 81 non_terminal( ), 82 '$clausable'( ), 83 '$iso'( ), 84 '$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.116dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)). 117multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)). 118module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)). 119discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)). 120volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)). 121thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)). 122noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)). 123public(Spec) :- '$set_pattr'(Spec, pred, public(true)). 124non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)). 125'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)). 126'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)). 127'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)). 128 129'$set_pattr'(M:Pred, How, Attr) :- 130 '$set_pattr'(Pred, M, How, Attr).
pred
or directive
.136'$set_pattr'(X, _, _, _) :- 137 var(X), 138 '$uninstantiation_error'(X). 139'$set_pattr'(as(Spec,Options), M, How, Attr0) :- 140 !, 141 '$attr_options'(Options, Attr0, Attr), 142 '$set_pattr'(Spec, M, How, Attr). 143'$set_pattr'([], _, _, _) :- !. 144'$set_pattr'([H|T], M, How, Attr) :- % ISO 145 !, 146 '$set_pattr'(H, M, How, Attr), 147 '$set_pattr'(T, M, How, Attr). 148'$set_pattr'((A,B), M, How, Attr) :- % ISO and traditional 149 !, 150 '$set_pattr'(A, M, How, Attr), 151 '$set_pattr'(B, M, How, Attr). 152'$set_pattr'(M:T, _, How, Attr) :- 153 !, 154 '$set_pattr'(T, M, How, Attr). 155'$set_pattr'(PI, M, _, []) :- 156 !, 157 '$pi_head'(M:PI, Pred), 158 '$set_table_wrappers'(Pred). 159'$set_pattr'(A, M, How, [O|OT]) :- 160 !, 161 '$set_pattr'(A, M, How, O), 162 '$set_pattr'(A, M, How, OT). 163'$set_pattr'(A, M, pred, Attr) :- 164 !, 165 Attr =.. [Name,Val], 166 '$set_pi_attr'(M:A, Name, Val). 167'$set_pattr'(A, M, directive, Attr) :- 168 !, 169 Attr =.. [Name,Val], 170 catch('$set_pi_attr'(M:A, Name, Val), 171 error(E, _), 172 print_message(error, error(E, context((Name)/1,_)))). 173 174'$set_pi_attr'(PI, Name, Val) :- 175 '$pi_head'(PI, Head), 176 '$set_predicate_attribute'(Head, Name, Val). 177 178'$attr_options'(Var, _, _) :- 179 var(Var), 180 !, 181 '$uninstantiation_error'(Var). 182'$attr_options'((A,B), Attr0, Attr) :- 183 !, 184 '$attr_options'(A, Attr0, Attr1), 185 '$attr_options'(B, Attr1, Attr). 186'$attr_options'(Opt, Attr0, Attrs) :- 187 '$must_be'(ground, Opt), 188 ( '$attr_option'(Opt, AttrX) 189 -> ( is_list(Attr0) 190 -> '$join_attrs'(AttrX, Attr0, Attrs) 191 ; '$join_attrs'(AttrX, [Attr0], Attrs) 192 ) 193 ; '$domain_error'(predicate_option, Opt) 194 ). 195 196'$join_attrs'([], Attrs, Attrs) :- 197 !. 198'$join_attrs'([H|T], Attrs0, Attrs) :- 199 !, 200 '$join_attrs'(H, Attrs0, Attrs1), 201 '$join_attrs'(T, Attrs1, Attrs). 202'$join_attrs'(Attr, Attrs, Attrs) :- 203 memberchk(Attr, Attrs), 204 !. 205'$join_attrs'(Attr, Attrs, Attrs) :- 206 Attr =.. [Name,Value], 207 Gen =.. [Name,Existing], 208 memberchk(Gen, Attrs), 209 !, 210 throw(error(conflict_error(Name, Value, Existing), _)). 211'$join_attrs'(Attr, Attrs0, Attrs) :- 212 '$append'(Attrs0, [Attr], Attrs). 213 214'$attr_option'(incremental, [incremental(true),opaque(false)]). 215'$attr_option'(monotonic, monotonic(true)). 216'$attr_option'(lazy, lazy(true)). 217'$attr_option'(opaque, [incremental(false),opaque(true)]). 218'$attr_option'(abstract(Level0), abstract(Level)) :- 219 '$table_option'(Level0, Level). 220'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :- 221 '$table_option'(Level0, Level). 222'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :- 223 '$table_option'(Level0, Level). 224'$attr_option'(max_answers(Level0), max_answers(Level)) :- 225 '$table_option'(Level0, Level). 226'$attr_option'(volatile, volatile(true)). 227'$attr_option'(multifile, multifile(true)). 228'$attr_option'(discontiguous, discontiguous(true)). 229'$attr_option'(shared, thread_local(false)). 230'$attr_option'(local, thread_local(true)). 231'$attr_option'(private, thread_local(true)). 232 233'$table_option'(Value0, _Value) :- 234 var(Value0), 235 !, 236 '$instantiation_error'(Value0). 237'$table_option'(Value0, Value) :- 238 integer(Value0), 239 Value0 >= 0, 240 !, 241 Value = Value0. 242'$table_option'(off, -1) :- 243 !. 244'$table_option'(false, -1) :- 245 !. 246'$table_option'(infinite, -1) :- 247 !. 248'$table_option'(Value, _) :- 249 '$domain_error'(nonneg_or_false, Value).
259'$pattr_directive'(dynamic(Spec), M) :- 260 '$set_pattr'(Spec, M, directive, dynamic(true)). 261'$pattr_directive'(multifile(Spec), M) :- 262 '$set_pattr'(Spec, M, directive, multifile(true)). 263'$pattr_directive'(module_transparent(Spec), M) :- 264 '$set_pattr'(Spec, M, directive, transparent(true)). 265'$pattr_directive'(discontiguous(Spec), M) :- 266 '$set_pattr'(Spec, M, directive, discontiguous(true)). 267'$pattr_directive'(volatile(Spec), M) :- 268 '$set_pattr'(Spec, M, directive, volatile(true)). 269'$pattr_directive'(thread_local(Spec), M) :- 270 '$set_pattr'(Spec, M, directive, thread_local(true)). 271'$pattr_directive'(noprofile(Spec), M) :- 272 '$set_pattr'(Spec, M, directive, noprofile(true)). 273'$pattr_directive'(public(Spec), M) :- 274 '$set_pattr'(Spec, M, directive, public(true)).
278'$pi_head'(PI, Head) :- 279 var(PI), 280 var(Head), 281 '$instantiation_error'([PI,Head]). 282'$pi_head'(M:PI, M:Head) :- 283 !, 284 '$pi_head'(PI, Head). 285'$pi_head'(Name/Arity, Head) :- 286 !, 287 '$head_name_arity'(Head, Name, Arity). 288'$pi_head'(Name//DCGArity, Head) :- 289 !, 290 ( nonvar(DCGArity) 291 -> Arity is DCGArity+2, 292 '$head_name_arity'(Head, Name, Arity) 293 ; '$head_name_arity'(Head, Name, Arity), 294 DCGArity is Arity - 2 295 ). 296'$pi_head'(PI, _) :- 297 '$type_error'(predicate_indicator, PI).
302'$head_name_arity'(Goal, Name, Arity) :- 303 ( atom(Goal) 304 -> Name = Goal, Arity = 0 305 ; compound(Goal) 306 -> compound_name_arity(Goal, Name, Arity) 307 ; var(Goal) 308 -> ( Arity == 0 309 -> ( atom(Name) 310 -> Goal = Name 311 ; Name == [] 312 -> Goal = Name 313 ; blob(Name, closure) 314 -> Goal = Name 315 ; '$type_error'(atom, Name) 316 ) 317 ; compound_name_arity(Goal, Name, Arity) 318 ) 319 ; '$type_error'(callable, Goal) 320 ). 321 322:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 323 324 325 /******************************** 326 * CALLING, CONTROL * 327 *********************************/ 328 329:- noprofile((call/1, 330 catch/3, 331 once/1, 332 ignore/1, 333 call_cleanup/2, 334 call_cleanup/3, 335 setup_call_cleanup/3, 336 setup_call_catcher_cleanup/4)). 337 338:- meta_predicate 339 ';'( , ), 340 ','( , ), 341 @( , ), 342 call( ), 343 call( , ), 344 call( , , ), 345 call( , , , ), 346 call( , , , , ), 347 call( , , , , , ), 348 call( , , , , , , ), 349 call( , , , , , , , ), 350 not( ), 351 \+( ), 352 '->'( , ), 353 '*->'( , ), 354 once( ), 355 ignore( ), 356 catch( , , ), 357 reset( , , ), 358 setup_call_cleanup( , , ), 359 setup_call_catcher_cleanup( , , , ), 360 call_cleanup( , ), 361 call_cleanup( , , ), 362 catch_with_backtrace( , , ), 363 '$meta_call'( ). 364 365:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 366 367% The control structures are always compiled, both if they appear in a 368% clause body and if they are handed to call/1. The only way to call 369% these predicates is by means of call/2.. In that case, we call the 370% hole control structure again to get it compiled by call/1 and properly 371% deal with !, etc. Another reason for having these things as 372% predicates is to be able to define properties for them, helping code 373% analyzers. 374 375(M0:If ; M0:Then) :- !, call(M0:(If ; Then)). 376(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)). 377(G1 , G2) :- call((G1 , G2)). 378(If -> Then) :- call((If -> Then)). 379(If *-> Then) :- call((If *-> Then)). 380@(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.
394'$meta_call'(M:G) :- 395 prolog_current_choice(Ch), 396 '$meta_call'(G, M, Ch). 397 398'$meta_call'(Var, _, _) :- 399 var(Var), 400 !, 401 '$instantiation_error'(Var). 402'$meta_call'((A,B), M, Ch) :- 403 !, 404 '$meta_call'(A, M, Ch), 405 '$meta_call'(B, M, Ch). 406'$meta_call'((I->T;E), M, Ch) :- 407 !, 408 ( prolog_current_choice(Ch2), 409 '$meta_call'(I, M, Ch2) 410 -> '$meta_call'(T, M, Ch) 411 ; '$meta_call'(E, M, Ch) 412 ). 413'$meta_call'((I*->T;E), M, Ch) :- 414 !, 415 ( prolog_current_choice(Ch2), 416 '$meta_call'(I, M, Ch2) 417 *-> '$meta_call'(T, M, Ch) 418 ; '$meta_call'(E, M, Ch) 419 ). 420'$meta_call'((I->T), M, Ch) :- 421 !, 422 ( prolog_current_choice(Ch2), 423 '$meta_call'(I, M, Ch2) 424 -> '$meta_call'(T, M, Ch) 425 ). 426'$meta_call'((I*->T), M, Ch) :- 427 !, 428 prolog_current_choice(Ch2), 429 '$meta_call'(I, M, Ch2), 430 '$meta_call'(T, M, Ch). 431'$meta_call'((A;B), M, Ch) :- 432 !, 433 ( '$meta_call'(A, M, Ch) 434 ; '$meta_call'(B, M, Ch) 435 ). 436'$meta_call'(\+(G), M, _) :- 437 !, 438 prolog_current_choice(Ch), 439 \+ '$meta_call'(G, M, Ch). 440'$meta_call'(call(G), M, _) :- 441 !, 442 prolog_current_choice(Ch), 443 '$meta_call'(G, M, Ch). 444'$meta_call'(M:G, _, Ch) :- 445 !, 446 '$meta_call'(G, M, Ch). 447'$meta_call'(!, _, Ch) :- 448 prolog_cut_to(Ch). 449'$meta_call'(G, M, _Ch) :- 450 call(M:G).
466:- '$iso'((call/2, 467 call/3, 468 call/4, 469 call/5, 470 call/6, 471 call/7, 472 call/8)). 473 474call(Goal) :- % make these available as predicates 475 . 476call(Goal, A) :- 477 call(Goal, A). 478call(Goal, A, B) :- 479 call(Goal, A, B). 480call(Goal, A, B, C) :- 481 call(Goal, A, B, C). 482call(Goal, A, B, C, D) :- 483 call(Goal, A, B, C, D). 484call(Goal, A, B, C, D, E) :- 485 call(Goal, A, B, C, D, E). 486call(Goal, A, B, C, D, E, F) :- 487 call(Goal, A, B, C, D, E, F). 488call(Goal, A, B, C, D, E, F, G) :- 489 call(Goal, A, B, C, D, E, F, G).
496not(Goal) :-
497 \+ .
503\+ Goal :-
504 \+ .
call((Goal, !))
.
510once(Goal) :-
511 ,
512 !.
519ignore(Goal) :- 520 , 521 !. 522ignore(_Goal). 523 524:- '$iso'((false/0)).
530false :-
531 fail.
537catch(_Goal, _Catcher, _Recover) :- 538 '$catch'. % Maps to I_CATCH, I_EXITCATCH
544prolog_cut_to(_Choice) :- 545 '$cut'. % Maps to I_CUTCHP
551reset(_Goal, _Ball, _Cont) :-
552 '$reset'.
558shift(Ball) :-
559 '$shift'(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.
573call_continuation([]). 574call_continuation([TB|Rest]) :- 575 ( Rest == [] 576 -> '$call_continuation'(TB) 577 ; '$call_continuation'(TB), 578 call_continuation(Rest) 579 ).
586catch_with_backtrace(Goal, Ball, Recover) :- 587 catch(Goal, Ball, Recover), 588 '$no_lco'. 589 590'$no_lco'.
600:- public '$recover_and_rethrow'/2. 601 602'$recover_and_rethrow'(Goal, Exception) :- 603 call_cleanup(Goal, throw(Exception)), 604 !.
619setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :- 620 '$sig_atomic'(Setup), 621 '$call_cleanup'. 622 623setup_call_cleanup(Setup, Goal, Cleanup) :- 624 setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup). 625 626call_cleanup(Goal, Cleanup) :- 627 setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup). 628 629call_cleanup(Goal, Catcher, Cleanup) :- 630 setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup). 631 632 /******************************* 633 * INITIALIZATION * 634 *******************************/ 635 636:- meta_predicate 637 initialization( , ). 638 639:- multifile '$init_goal'/3. 640:- dynamic '$init_goal'/3.
-g goal
goals.Note that all goals are executed when a program is restored.
666initialization(Goal, When) :- 667 '$must_be'(oneof(atom, initialization_type, 668 [ now, 669 after_load, 670 restore, 671 restore_state, 672 prepare_state, 673 program, 674 main 675 ]), When), 676 '$initialization_context'(Source, Ctx), 677 '$initialization'(When, Goal, Source, Ctx). 678 679'$initialization'(now, Goal, _Source, Ctx) :- 680 '$run_init_goal'(Goal, Ctx), 681 '$compile_init_goal'(-, Goal, Ctx). 682'$initialization'(after_load, Goal, Source, Ctx) :- 683 ( Source \== (-) 684 -> '$compile_init_goal'(Source, Goal, Ctx) 685 ; throw(error(context_error(nodirective, 686 initialization(Goal, after_load)), 687 _)) 688 ). 689'$initialization'(restore, Goal, Source, Ctx) :- % deprecated 690 '$initialization'(restore_state, Goal, Source, Ctx). 691'$initialization'(restore_state, Goal, _Source, Ctx) :- 692 ( \+ current_prolog_flag(sandboxed_load, true) 693 -> '$compile_init_goal'(-, Goal, Ctx) 694 ; '$permission_error'(register, initialization(restore), Goal) 695 ). 696'$initialization'(prepare_state, Goal, _Source, Ctx) :- 697 ( \+ current_prolog_flag(sandboxed_load, true) 698 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx) 699 ; '$permission_error'(register, initialization(restore), Goal) 700 ). 701'$initialization'(program, Goal, _Source, Ctx) :- 702 ( \+ current_prolog_flag(sandboxed_load, true) 703 -> '$compile_init_goal'(when(program), Goal, Ctx) 704 ; '$permission_error'(register, initialization(restore), Goal) 705 ). 706'$initialization'(main, Goal, _Source, Ctx) :- 707 ( \+ current_prolog_flag(sandboxed_load, true) 708 -> '$compile_init_goal'(when(main), Goal, Ctx) 709 ; '$permission_error'(register, initialization(restore), Goal) 710 ). 711 712 713'$compile_init_goal'(Source, Goal, Ctx) :- 714 atom(Source), 715 Source \== (-), 716 !, 717 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx), 718 _Layout, Source, Ctx). 719'$compile_init_goal'(Source, Goal, Ctx) :- 720 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.732'$run_initialization'(_, loaded, _) :- !. 733'$run_initialization'(File, _Action, Options) :- 734 '$run_initialization'(File, Options). 735 736'$run_initialization'(File, Options) :- 737 setup_call_cleanup( 738 '$start_run_initialization'(Options, Restore), 739 '$run_initialization_2'(File), 740 '$end_run_initialization'(Restore)). 741 742'$start_run_initialization'(Options, OldSandBoxed) :- 743 '$push_input_context'(initialization), 744 '$set_sandboxed_load'(Options, OldSandBoxed). 745'$end_run_initialization'(OldSandBoxed) :- 746 set_prolog_flag(sandboxed_load, OldSandBoxed), 747 '$pop_input_context'. 748 749'$run_initialization_2'(File) :- 750 ( '$init_goal'(File, Goal, Ctx), 751 File \= when(_), 752 '$run_init_goal'(Goal, Ctx), 753 fail 754 ; true 755 ). 756 757'$run_init_goal'(Goal, Ctx) :- 758 ( catch_with_backtrace('$run_init_goal'(Goal), E, 759 '$initialization_error'(E, Goal, Ctx)) 760 -> true 761 ; '$initialization_failure'(Goal, Ctx) 762 ). 763 764:- multifile prolog:sandbox_allowed_goal/1. 765 766'$run_init_goal'(Goal) :- 767 current_prolog_flag(sandboxed_load, false), 768 !, 769 call(Goal). 770'$run_init_goal'(Goal) :- 771 prolog:sandbox_allowed_goal(Goal), 772 call(Goal). 773 774'$initialization_context'(Source, Ctx) :- 775 ( source_location(File, Line) 776 -> Ctx = File:Line, 777 '$input_context'(Context), 778 '$top_file'(Context, File, Source) 779 ; Ctx = (-), 780 File = (-) 781 ). 782 783'$top_file'([input(include, F1, _, _)|T], _, F) :- 784 !, 785 '$top_file'(T, F1, F). 786'$top_file'(_, F, F). 787 788 789'$initialization_error'(E, Goal, Ctx) :- 790 print_message(error, initialization_error(Goal, E, Ctx)). 791 792'$initialization_failure'(Goal, Ctx) :- 793 print_message(warning, initialization_failure(Goal, Ctx)).
801:- public '$clear_source_admin'/1. 802 803'$clear_source_admin'(File) :- 804 retractall('$init_goal'(_, _, File:_)), 805 retractall('$load_context_module'(File, _, _)), 806 retractall('$resolved_source_path_db'(_, _, File)). 807 808 809 /******************************* 810 * STREAM * 811 *******************************/ 812 813:- '$iso'(stream_property/2). 814stream_property(Stream, Property) :- 815 nonvar(Stream), 816 nonvar(Property), 817 !, 818 '$stream_property'(Stream, Property). 819stream_property(Stream, Property) :- 820 nonvar(Stream), 821 !, 822 '$stream_properties'(Stream, Properties), 823 '$member'(Property, Properties). 824stream_property(Stream, Property) :- 825 nonvar(Property), 826 !, 827 ( Property = alias(Alias), 828 atom(Alias) 829 -> '$alias_stream'(Alias, Stream) 830 ; '$streams_properties'(Property, Pairs), 831 '$member'(Stream-Property, Pairs) 832 ). 833stream_property(Stream, Property) :- 834 '$streams_properties'(Property, Pairs), 835 '$member'(Stream-Properties, Pairs), 836 '$member'(Property, Properties). 837 838 839 /******************************** 840 * MODULES * 841 *********************************/ 842 843% '$prefix_module'(+Module, +Context, +Term, -Prefixed) 844% Tags `Term' with `Module:' if `Module' is not the context module. 845 846'$prefix_module'(Module, Module, Head, Head) :- !. 847'$prefix_module'(Module, _, Head, Module:Head).
853default_module(Me, Super) :- 854 ( atom(Me) 855 -> ( var(Super) 856 -> '$default_module'(Me, Super) 857 ; '$default_module'(Me, Super), ! 858 ) 859 ; '$type_error'(module, Me) 860 ). 861 862'$default_module'(Me, Me). 863'$default_module'(Me, Super) :- 864 import_module(Me, S), 865 '$default_module'(S, Super). 866 867 868 /******************************** 869 * TRACE AND EXCEPTIONS * 870 *********************************/ 871 872:- dynamic user:exception/3. 873:- multifile user:exception/3. 874:- '$hide'(user:exception/3).
883:- public 884 '$undefined_procedure'/4. 885 886'$undefined_procedure'(Module, Name, Arity, Action) :- 887 '$prefix_module'(Module, user, Name/Arity, Pred), 888 user:exception(undefined_predicate, Pred, Action0), 889 !, 890 Action = Action0. 891'$undefined_procedure'(Module, Name, Arity, Action) :- 892 \+ current_prolog_flag(autoload, false), 893 '$autoload'(Module:Name/Arity), 894 !, 895 Action = retry. 896'$undefined_procedure'(_, _, _, error).
908'$loading'(Library) :- 909 current_prolog_flag(threads, true), 910 ( '$loading_file'(Library, _Queue, _LoadThread) 911 -> true 912 ; '$loading_file'(FullFile, _Queue, _LoadThread), 913 file_name_extension(Library, _, FullFile) 914 -> true 915 ). 916 917% handle debugger 'w', 'p' and <N> depth options. 918 919'$set_debugger_write_options'(write) :- 920 !, 921 create_prolog_flag(debugger_write_options, 922 [ quoted(true), 923 attributes(dots), 924 spacing(next_argument) 925 ], []). 926'$set_debugger_write_options'(print) :- 927 !, 928 create_prolog_flag(debugger_write_options, 929 [ quoted(true), 930 portray(true), 931 max_depth(10), 932 attributes(portray), 933 spacing(next_argument) 934 ], []). 935'$set_debugger_write_options'(Depth) :- 936 current_prolog_flag(debugger_write_options, Options0), 937 ( '$select'(max_depth(_), Options0, Options) 938 -> true 939 ; Options = Options0 940 ), 941 create_prolog_flag(debugger_write_options, 942 [max_depth(Depth)|Options], []). 943 944 945 /******************************** 946 * SYSTEM MESSAGES * 947 *********************************/
954'$confirm'(Spec) :- 955 print_message(query, Spec), 956 between(0, 5, _), 957 get_single_char(Answer), 958 ( '$in_reply'(Answer, 'yYjJ \n') 959 -> !, 960 print_message(query, if_tty([yes-[]])) 961 ; '$in_reply'(Answer, 'nN') 962 -> !, 963 print_message(query, if_tty([no-[]])), 964 fail 965 ; print_message(help, query(confirm)), 966 fail 967 ). 968 969'$in_reply'(Code, Atom) :- 970 char_code(Char, Code), 971 sub_atom(Atom, _, _, _, Char), 972 !. 973 974:- dynamic 975 user:portray/1. 976:- multifile 977 user:portray/1. 978 979 980 /******************************* 981 * FILE_SEARCH_PATH * 982 *******************************/ 983 984:- dynamic 985 user:file_search_path/2, 986 user:library_directory/1. 987:- multifile 988 user:file_search_path/2, 989 user:library_directory/1. 990 991user(file_search_path(library, Dir) :- 992 library_directory(Dir)). 993user:file_search_path(swi, Home) :- 994 current_prolog_flag(home, Home). 995user:file_search_path(swi, Home) :- 996 current_prolog_flag(shared_home, Home). 997user:file_search_path(library, app_config(lib)). 998user:file_search_path(library, swi(library)). 999user:file_search_path(library, swi(library/clp)). 1000user:file_search_path(foreign, swi(ArchLib)) :- 1001 \+ current_prolog_flag(windows, true), 1002 current_prolog_flag(arch, Arch), 1003 atom_concat('lib/', Arch, ArchLib). 1004user:file_search_path(foreign, swi(SoLib)) :- 1005 ( current_prolog_flag(windows, true) 1006 -> SoLib = bin 1007 ; SoLib = lib 1008 ). 1009user:file_search_path(path, Dir) :- 1010 getenv('PATH', Path), 1011 ( current_prolog_flag(windows, true) 1012 -> atomic_list_concat(Dirs, (;), Path) 1013 ; atomic_list_concat(Dirs, :, Path) 1014 ), 1015 '$member'(Dir, Dirs). 1016user:file_search_path(user_app_data, Dir) :- 1017 '$xdg_prolog_directory'(data, Dir). 1018user:file_search_path(common_app_data, Dir) :- 1019 '$xdg_prolog_directory'(common_data, Dir). 1020user:file_search_path(user_app_config, Dir) :- 1021 '$xdg_prolog_directory'(config, Dir). 1022user:file_search_path(common_app_config, Dir) :- 1023 '$xdg_prolog_directory'(common_config, Dir). 1024user:file_search_path(app_data, user_app_data('.')). 1025user:file_search_path(app_data, common_app_data('.')). 1026user:file_search_path(app_config, user_app_config('.')). 1027user:file_search_path(app_config, common_app_config('.')). 1028% backward compatibility 1029user:file_search_path(app_preferences, user_app_config('.')). 1030user:file_search_path(user_profile, app_preferences('.')). 1031 1032'$xdg_prolog_directory'(Which, Dir) :- 1033 '$xdg_directory'(Which, XDGDir), 1034 '$make_config_dir'(XDGDir), 1035 '$ensure_slash'(XDGDir, XDGDirS), 1036 atom_concat(XDGDirS, 'swi-prolog', Dir), 1037 '$make_config_dir'(Dir). 1038 1039% config 1040'$xdg_directory'(config, Home) :- 1041 current_prolog_flag(windows, true), 1042 catch(win_folder(appdata, Home), _, fail), 1043 !. 1044'$xdg_directory'(config, Home) :- 1045 getenv('XDG_CONFIG_HOME', Home). 1046'$xdg_directory'(config, Home) :- 1047 expand_file_name('~/.config', [Home]). 1048% data 1049'$xdg_directory'(data, Home) :- 1050 current_prolog_flag(windows, true), 1051 catch(win_folder(local_appdata, Home), _, fail), 1052 !. 1053'$xdg_directory'(data, Home) :- 1054 getenv('XDG_DATA_HOME', Home). 1055'$xdg_directory'(data, Home) :- 1056 expand_file_name('~/.local', [Local]), 1057 '$make_config_dir'(Local), 1058 atom_concat(Local, '/share', Home), 1059 '$make_config_dir'(Home). 1060% common data 1061'$xdg_directory'(common_data, Dir) :- 1062 current_prolog_flag(windows, true), 1063 catch(win_folder(common_appdata, Dir), _, fail), 1064 !. 1065'$xdg_directory'(common_data, Dir) :- 1066 '$existing_dir_from_env_path'('XDG_DATA_DIRS', 1067 [ '/usr/local/share', 1068 '/usr/share' 1069 ], 1070 Dir). 1071% common config 1072'$xdg_directory'(common_config, Dir) :- 1073 current_prolog_flag(windows, true), 1074 catch(win_folder(common_appdata, Dir), _, fail), 1075 !. 1076'$xdg_directory'(common_config, Dir) :- 1077 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir). 1078 1079'$existing_dir_from_env_path'(Env, Defaults, Dir) :- 1080 ( getenv(Env, Path) 1081 -> '$path_sep'(Sep), 1082 atomic_list_concat(Dirs, Sep, Path) 1083 ; Dirs = Defaults 1084 ), 1085 '$member'(Dir, Dirs), 1086 Dir \== '', 1087 exists_directory(Dir). 1088 1089'$path_sep'(Char) :- 1090 ( current_prolog_flag(windows, true) 1091 -> Char = ';' 1092 ; Char = ':' 1093 ). 1094 1095'$make_config_dir'(Dir) :- 1096 exists_directory(Dir), 1097 !. 1098'$make_config_dir'(Dir) :- 1099 nb_current('$create_search_directories', true), 1100 file_directory_name(Dir, Parent), 1101 '$my_file'(Parent), 1102 catch(make_directory(Dir), _, fail). 1103 1104'$ensure_slash'(Dir, DirS) :- 1105 ( sub_atom(Dir, _, _, 0, /) 1106 -> DirS = Dir 1107 ; atom_concat(Dir, /, DirS) 1108 ).
1113'$expand_file_search_path'(Spec, Expanded, Cond) :- 1114 '$option'(access(Access), Cond), 1115 memberchk(Access, [write,append]), 1116 !, 1117 setup_call_cleanup( 1118 nb_setval('$create_search_directories', true), 1119 expand_file_search_path(Spec, Expanded), 1120 nb_delete('$create_search_directories')). 1121'$expand_file_search_path'(Spec, Expanded, _Cond) :- 1122 expand_file_search_path(Spec, Expanded).
1130expand_file_search_path(Spec, Expanded) :- 1131 catch('$expand_file_search_path'(Spec, Expanded, 0, []), 1132 loop(Used), 1133 throw(error(loop_error(Spec), file_search(Used)))). 1134 1135'$expand_file_search_path'(Spec, Expanded, N, Used) :- 1136 functor(Spec, Alias, 1), 1137 !, 1138 user:file_search_path(Alias, Exp0), 1139 NN is N + 1, 1140 ( NN > 16 1141 -> throw(loop(Used)) 1142 ; true 1143 ), 1144 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]), 1145 arg(1, Spec, Segments), 1146 '$segments_to_atom'(Segments, File), 1147 '$make_path'(Exp1, File, Expanded). 1148'$expand_file_search_path'(Spec, Path, _, _) :- 1149 '$segments_to_atom'(Spec, Path). 1150 1151'$make_path'(Dir, '.', Path) :- 1152 !, 1153 Path = Dir. 1154'$make_path'(Dir, File, Path) :- 1155 sub_atom(Dir, _, _, 0, /), 1156 !, 1157 atom_concat(Dir, File, Path). 1158'$make_path'(Dir, File, Path) :- 1159 atomic_list_concat([Dir, /, File], Path). 1160 1161 1162 /******************************** 1163 * FILE CHECKING * 1164 *********************************/
1175absolute_file_name(Spec, Options, Path) :- 1176 '$is_options'(Options), 1177 \+ '$is_options'(Path), 1178 !, 1179 absolute_file_name(Spec, Path, Options). 1180absolute_file_name(Spec, Path, Options) :- 1181 '$must_be'(options, Options), 1182 % get the valid extensions 1183 ( '$select_option'(extensions(Exts), Options, Options1) 1184 -> '$must_be'(list, Exts) 1185 ; '$option'(file_type(Type), Options) 1186 -> '$must_be'(atom, Type), 1187 '$file_type_extensions'(Type, Exts), 1188 Options1 = Options 1189 ; Options1 = Options, 1190 Exts = [''] 1191 ), 1192 '$canonicalise_extensions'(Exts, Extensions), 1193 % unless specified otherwise, ask regular file 1194 ( nonvar(Type) 1195 -> Options2 = Options1 1196 ; '$merge_options'(_{file_type:regular}, Options1, Options2) 1197 ), 1198 % Det or nondet? 1199 ( '$select_option'(solutions(Sols), Options2, Options3) 1200 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols) 1201 ; Sols = first, 1202 Options3 = Options2 1203 ), 1204 % Errors or not? 1205 ( '$select_option'(file_errors(FileErrors), Options3, Options4) 1206 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors) 1207 ; FileErrors = error, 1208 Options4 = Options3 1209 ), 1210 % Expand shell patterns? 1211 ( atomic(Spec), 1212 '$select_option'(expand(Expand), Options4, Options5), 1213 '$must_be'(boolean, Expand) 1214 -> expand_file_name(Spec, List), 1215 '$member'(Spec1, List) 1216 ; Spec1 = Spec, 1217 Options5 = Options4 1218 ), 1219 % Search for files 1220 ( Sols == first 1221 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path) 1222 -> ! % also kill choice point of expand_file_name/2 1223 ; ( FileErrors == fail 1224 -> fail 1225 ; '$current_module'('$bags', _File), 1226 findall(P, 1227 '$chk_file'(Spec1, Extensions, [access(exist)], 1228 false, P), 1229 Candidates), 1230 '$abs_file_error'(Spec, Candidates, Options5) 1231 ) 1232 ) 1233 ; '$chk_file'(Spec1, Extensions, Options5, false, Path) 1234 ). 1235 1236'$abs_file_error'(Spec, Candidates, Conditions) :- 1237 '$member'(F, Candidates), 1238 '$member'(C, Conditions), 1239 '$file_condition'(C), 1240 '$file_error'(C, Spec, F, E, Comment), 1241 !, 1242 throw(error(E, context(_, Comment))). 1243'$abs_file_error'(Spec, _, _) :- 1244 '$existence_error'(source_sink, Spec). 1245 1246'$file_error'(file_type(directory), Spec, File, Error, Comment) :- 1247 \+ exists_directory(File), 1248 !, 1249 Error = existence_error(directory, Spec), 1250 Comment = not_a_directory(File). 1251'$file_error'(file_type(_), Spec, File, Error, Comment) :- 1252 exists_directory(File), 1253 !, 1254 Error = existence_error(file, Spec), 1255 Comment = directory(File). 1256'$file_error'(access(OneOrList), Spec, File, Error, _) :- 1257 '$one_or_member'(Access, OneOrList), 1258 \+ access_file(File, Access), 1259 Error = permission_error(Access, source_sink, Spec). 1260 1261'$one_or_member'(Elem, List) :- 1262 is_list(List), 1263 !, 1264 '$member'(Elem, List). 1265'$one_or_member'(Elem, Elem). 1266 1267 1268'$file_type_extensions'(source, Exts) :- % SICStus 3.9 compatibility 1269 !, 1270 '$file_type_extensions'(prolog, Exts). 1271'$file_type_extensions'(Type, Exts) :- 1272 '$current_module'('$bags', _File), 1273 !, 1274 findall(Ext, user:prolog_file_type(Ext, Type), Exts0), 1275 ( Exts0 == [], 1276 \+ '$ft_no_ext'(Type) 1277 -> '$domain_error'(file_type, Type) 1278 ; true 1279 ), 1280 '$append'(Exts0, [''], Exts). 1281'$file_type_extensions'(prolog, [pl, '']). % findall is not yet defined ... 1282 1283'$ft_no_ext'(txt). 1284'$ft_no_ext'(executable). 1285'$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.
1298:- multifile(user:prolog_file_type/2). 1299:- dynamic(user:prolog_file_type/2). 1300 1301userprolog_file_type(pl, prolog). 1302userprolog_file_type(prolog, prolog). 1303userprolog_file_type(qlf, prolog). 1304userprolog_file_type(qlf, qlf). 1305userprolog_file_type(Ext, executable) :- 1306 current_prolog_flag(shared_object_extension, Ext). 1307userprolog_file_type(dylib, executable) :- 1308 current_prolog_flag(apple, true).
1315'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :- 1316 \+ ground(Spec), 1317 !, 1318 '$instantiation_error'(Spec). 1319'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :- 1320 compound(Spec), 1321 functor(Spec, _, 1), 1322 !, 1323 '$relative_to'(Cond, cwd, CWD), 1324 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName). 1325'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- % allow a/b/... 1326 \+ atomic(Segments), 1327 !, 1328 '$segments_to_atom'(Segments, Atom), 1329 '$chk_file'(Atom, Ext, Cond, Cache, FullName). 1330'$chk_file'(File, Exts, Cond, _, FullName) :- 1331 is_absolute_file_name(File), 1332 !, 1333 '$extend_file'(File, Exts, Extended), 1334 '$file_conditions'(Cond, Extended), 1335 '$absolute_file_name'(Extended, FullName). 1336'$chk_file'(File, Exts, Cond, _, FullName) :- 1337 '$relative_to'(Cond, source, Dir), 1338 atomic_list_concat([Dir, /, File], AbsFile), 1339 '$extend_file'(AbsFile, Exts, Extended), 1340 '$file_conditions'(Cond, Extended), 1341 !, 1342 '$absolute_file_name'(Extended, FullName). 1343'$chk_file'(File, Exts, Cond, _, FullName) :- 1344 '$extend_file'(File, Exts, Extended), 1345 '$file_conditions'(Cond, Extended), 1346 '$absolute_file_name'(Extended, FullName). 1347 1348'$segments_to_atom'(Atom, Atom) :- 1349 atomic(Atom), 1350 !. 1351'$segments_to_atom'(Segments, Atom) :- 1352 '$segments_to_list'(Segments, List, []), 1353 !, 1354 atomic_list_concat(List, /, Atom). 1355 1356'$segments_to_list'(A/B, H, T) :- 1357 '$segments_to_list'(A, H, T0), 1358 '$segments_to_list'(B, T0, T). 1359'$segments_to_list'(A, [A|T], T) :- 1360 atomic(A).
relative_to(FileOrDir)
options
or implicitely relative to the working directory or current
source-file.
1370'$relative_to'(Conditions, Default, Dir) :-
1371 ( '$option'(relative_to(FileOrDir), Conditions)
1372 *-> ( exists_directory(FileOrDir)
1373 -> Dir = FileOrDir
1374 ; atom_concat(Dir, /, FileOrDir)
1375 -> true
1376 ; file_directory_name(FileOrDir, Dir)
1377 )
1378 ; Default == cwd
1379 -> '$cwd'(Dir)
1380 ; Default == source
1381 -> source_location(ContextFile, _Line),
1382 file_directory_name(ContextFile, Dir)
1383 ).
1388:- dynamic 1389 '$search_path_file_cache'/3, % SHA1, Time, Path 1390 '$search_path_gc_time'/1. % Time 1391:- volatile 1392 '$search_path_file_cache'/3, 1393 '$search_path_gc_time'/1. 1394 1395:- create_prolog_flag(file_search_cache_time, 10, []). 1396 1397'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :- 1398 !, 1399 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions), 1400 current_prolog_flag(emulated_dialect, Dialect), 1401 Cache = cache(Exts, Cond, CWD, Expansions, Dialect), 1402 variant_sha1(Spec+Cache, SHA1), 1403 get_time(Now), 1404 current_prolog_flag(file_search_cache_time, TimeOut), 1405 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile), 1406 CachedTime > Now - TimeOut, 1407 '$file_conditions'(Cond, FullFile) 1408 -> '$search_message'(file_search(cache(Spec, Cond), FullFile)) 1409 ; '$member'(Expanded, Expansions), 1410 '$extend_file'(Expanded, Exts, LibFile), 1411 ( '$file_conditions'(Cond, LibFile), 1412 '$absolute_file_name'(LibFile, FullFile), 1413 '$cache_file_found'(SHA1, Now, TimeOut, FullFile) 1414 -> '$search_message'(file_search(found(Spec, Cond), FullFile)) 1415 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)), 1416 fail 1417 ) 1418 ). 1419'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :- 1420 '$expand_file_search_path'(Spec, Expanded, Cond), 1421 '$extend_file'(Expanded, Exts, LibFile), 1422 '$file_conditions'(Cond, LibFile), 1423 '$absolute_file_name'(LibFile, FullFile). 1424 1425'$cache_file_found'(_, _, TimeOut, _) :- 1426 TimeOut =:= 0, 1427 !. 1428'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1429 '$search_path_file_cache'(SHA1, Saved, FullFile), 1430 !, 1431 ( Now - Saved < TimeOut/2 1432 -> true 1433 ; retractall('$search_path_file_cache'(SHA1, _, _)), 1434 asserta('$search_path_file_cache'(SHA1, Now, FullFile)) 1435 ). 1436'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :- 1437 'gc_file_search_cache'(TimeOut), 1438 asserta('$search_path_file_cache'(SHA1, Now, FullFile)). 1439 1440'gc_file_search_cache'(TimeOut) :- 1441 get_time(Now), 1442 '$search_path_gc_time'(Last), 1443 Now-Last < TimeOut/2, 1444 !. 1445'gc_file_search_cache'(TimeOut) :- 1446 get_time(Now), 1447 retractall('$search_path_gc_time'(_)), 1448 assertz('$search_path_gc_time'(Now)), 1449 Before is Now - TimeOut, 1450 ( '$search_path_file_cache'(SHA1, Cached, FullFile), 1451 Cached < Before, 1452 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)), 1453 fail 1454 ; true 1455 ). 1456 1457 1458'$search_message'(Term) :- 1459 current_prolog_flag(verbose_file_search, true), 1460 !, 1461 print_message(informational, Term). 1462'$search_message'(_).
1469'$file_conditions'(List, File) :- 1470 is_list(List), 1471 !, 1472 \+ ( '$member'(C, List), 1473 '$file_condition'(C), 1474 \+ '$file_condition'(C, File) 1475 ). 1476'$file_conditions'(Map, File) :- 1477 \+ ( get_dict(Key, Map, Value), 1478 C =.. [Key,Value], 1479 '$file_condition'(C), 1480 \+ '$file_condition'(C, File) 1481 ). 1482 1483'$file_condition'(file_type(directory), File) :- 1484 !, 1485 exists_directory(File). 1486'$file_condition'(file_type(_), File) :- 1487 !, 1488 \+ exists_directory(File). 1489'$file_condition'(access(Accesses), File) :- 1490 !, 1491 \+ ( '$one_or_member'(Access, Accesses), 1492 \+ access_file(File, Access) 1493 ). 1494 1495'$file_condition'(exists). 1496'$file_condition'(file_type(_)). 1497'$file_condition'(access(_)). 1498 1499'$extend_file'(File, Exts, FileEx) :- 1500 '$ensure_extensions'(Exts, File, Fs), 1501 '$list_to_set'(Fs, FsSet), 1502 '$member'(FileEx, FsSet). 1503 1504'$ensure_extensions'([], _, []). 1505'$ensure_extensions'([E|E0], F, [FE|E1]) :- 1506 file_name_extension(F, E, FE), 1507 '$ensure_extensions'(E0, F, E1).
log(N)
)
version, but sets of file name extensions should be short enough
for this not to matter.1516'$list_to_set'(List, Set) :- 1517 '$list_to_set'(List, [], Set). 1518 1519'$list_to_set'([], _, []). 1520'$list_to_set'([H|T], Seen, R) :- 1521 memberchk(H, Seen), 1522 !, 1523 '$list_to_set'(T, R). 1524'$list_to_set'([H|T], Seen, [H|R]) :- 1525 '$list_to_set'(T, [H|Seen], R). 1526 1527/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1528Canonicalise the extension list. Old SWI-Prolog require `.pl', etc, which 1529the Quintus compatibility requests `pl'. This layer canonicalises all 1530extensions to .ext 1531- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 1532 1533'$canonicalise_extensions'([], []) :- !. 1534'$canonicalise_extensions'([H|T], [CH|CT]) :- 1535 !, 1536 '$must_be'(atom, H), 1537 '$canonicalise_extension'(H, CH), 1538 '$canonicalise_extensions'(T, CT). 1539'$canonicalise_extensions'(E, [CE]) :- 1540 '$canonicalise_extension'(E, CE). 1541 1542'$canonicalise_extension'('', '') :- !. 1543'$canonicalise_extension'(DotAtom, DotAtom) :- 1544 sub_atom(DotAtom, 0, _, _, '.'), 1545 !. 1546'$canonicalise_extension'(Atom, DotAtom) :- 1547 atom_concat('.', Atom, DotAtom). 1548 1549 1550 /******************************** 1551 * CONSULT * 1552 *********************************/ 1553 1554:- dynamic 1555 user:library_directory/1, 1556 user:prolog_load_file/2. 1557:- multifile 1558 user:library_directory/1, 1559 user:prolog_load_file/2. 1560 1561:- prompt(_, '|: '). 1562 1563:- thread_local 1564 '$compilation_mode_store'/1, % database, wic, qlf 1565 '$directive_mode_store'/1. % database, wic, qlf 1566:- volatile 1567 '$compilation_mode_store'/1, 1568 '$directive_mode_store'/1. 1569 1570'$compilation_mode'(Mode) :- 1571 ( '$compilation_mode_store'(Val) 1572 -> Mode = Val 1573 ; Mode = database 1574 ). 1575 1576'$set_compilation_mode'(Mode) :- 1577 retractall('$compilation_mode_store'(_)), 1578 assertz('$compilation_mode_store'(Mode)). 1579 1580'$compilation_mode'(Old, New) :- 1581 '$compilation_mode'(Old), 1582 ( New == Old 1583 -> true 1584 ; '$set_compilation_mode'(New) 1585 ). 1586 1587'$directive_mode'(Mode) :- 1588 ( '$directive_mode_store'(Val) 1589 -> Mode = Val 1590 ; Mode = database 1591 ). 1592 1593'$directive_mode'(Old, New) :- 1594 '$directive_mode'(Old), 1595 ( New == Old 1596 -> true 1597 ; '$set_directive_mode'(New) 1598 ). 1599 1600'$set_directive_mode'(Mode) :- 1601 retractall('$directive_mode_store'(_)), 1602 assertz('$directive_mode_store'(Mode)).
1610'$compilation_level'(Level) :- 1611 '$input_context'(Stack), 1612 '$compilation_level'(Stack, Level). 1613 1614'$compilation_level'([], 0). 1615'$compilation_level'([Input|T], Level) :- 1616 ( arg(1, Input, see) 1617 -> '$compilation_level'(T, Level) 1618 ; '$compilation_level'(T, Level0), 1619 Level is Level0+1 1620 ).
1628compiling :- 1629 \+ ( '$compilation_mode'(database), 1630 '$directive_mode'(database) 1631 ). 1632 1633:- meta_predicate 1634 '$ifcompiling'( ). 1635 1636'$ifcompiling'(G) :- 1637 ( '$compilation_mode'(database) 1638 -> true 1639 ; call(G) 1640 ). 1641 1642 /******************************** 1643 * READ SOURCE * 1644 *********************************/
1648'$load_msg_level'(Action, Nesting, Start, Done) :- 1649 '$update_autoload_level'([], 0), 1650 !, 1651 current_prolog_flag(verbose_load, Type0), 1652 '$load_msg_compat'(Type0, Type), 1653 ( '$load_msg_level'(Action, Nesting, Type, Start, Done) 1654 -> true 1655 ). 1656'$load_msg_level'(_, _, silent, silent). 1657 1658'$load_msg_compat'(true, normal) :- !. 1659'$load_msg_compat'(false, silent) :- !. 1660'$load_msg_compat'(X, X). 1661 1662'$load_msg_level'(load_file, _, full, informational, informational). 1663'$load_msg_level'(include_file, _, full, informational, informational). 1664'$load_msg_level'(load_file, _, normal, silent, informational). 1665'$load_msg_level'(include_file, _, normal, silent, silent). 1666'$load_msg_level'(load_file, 0, brief, silent, informational). 1667'$load_msg_level'(load_file, _, brief, silent, silent). 1668'$load_msg_level'(include_file, _, brief, silent, silent). 1669'$load_msg_level'(load_file, _, silent, silent, silent). 1670'$load_msg_level'(include_file, _, silent, silent, silent).
1693'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :- 1694 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options), 1695 ( Term == end_of_file 1696 -> !, fail 1697 ; Term \== begin_of_file 1698 ). 1699 1700'$source_term'(Input, _,_,_,_,_,_,_) :- 1701 \+ ground(Input), 1702 !, 1703 '$instantiation_error'(Input). 1704'$source_term'(stream(Id, In, Opts), 1705 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1706 !, 1707 '$record_included'(Parents, Id, Id, 0.0, Message), 1708 setup_call_cleanup( 1709 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options), 1710 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1711 [Id|Parents], Options), 1712 '$close_source'(State, Message)). 1713'$source_term'(File, 1714 Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1715 absolute_file_name(File, Path, 1716 [ file_type(prolog), 1717 access(read) 1718 ]), 1719 time_file(Path, Time), 1720 '$record_included'(Parents, File, Path, Time, Message), 1721 setup_call_cleanup( 1722 '$open_source'(Path, In, State, Parents, Options), 1723 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, 1724 [Path|Parents], Options), 1725 '$close_source'(State, Message)). 1726 1727:- thread_local 1728 '$load_input'/2. 1729:- volatile 1730 '$load_input'/2. 1731 1732'$open_source'(stream(Id, In, Opts), In, 1733 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :- 1734 !, 1735 '$context_type'(Parents, ContextType), 1736 '$push_input_context'(ContextType), 1737 '$prepare_load_stream'(In, Id, StreamState), 1738 asserta('$load_input'(stream(Id), In), Ref). 1739'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :- 1740 '$context_type'(Parents, ContextType), 1741 '$push_input_context'(ContextType), 1742 '$open_source'(Path, In, Options), 1743 '$set_encoding'(In, Options), 1744 asserta('$load_input'(Path, In), Ref). 1745 1746'$context_type'([], load_file) :- !. 1747'$context_type'(_, include). 1748 1749:- multifile prolog:open_source_hook/3. 1750 1751'$open_source'(Path, In, Options) :- 1752 prolog:open_source_hook(Path, In, Options), 1753 !. 1754'$open_source'(Path, In, _Options) :- 1755 open(Path, read, In). 1756 1757'$close_source'(close(In, _Id, Ref), Message) :- 1758 erase(Ref), 1759 call_cleanup( 1760 close(In), 1761 '$pop_input_context'), 1762 '$close_message'(Message). 1763'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :- 1764 erase(Ref), 1765 call_cleanup( 1766 '$restore_load_stream'(In, StreamState, Opts), 1767 '$pop_input_context'), 1768 '$close_message'(Message). 1769 1770'$close_message'(message(Level, Msg)) :- 1771 !, 1772 '$print_message'(Level, Msg). 1773'$close_message'(_).
1785'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1786 Parents \= [_,_|_], 1787 ( '$load_input'(_, Input) 1788 -> stream_property(Input, file_name(File)) 1789 ), 1790 '$set_source_location'(File, 0), 1791 '$expanded_term'(In, 1792 begin_of_file, 0-0, Read, RLayout, Term, TLayout, 1793 Stream, Parents, Options). 1794'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :- 1795 '$skip_script_line'(In, Options), 1796 '$read_clause_options'(Options, ReadOptions), 1797 repeat, 1798 read_clause(In, Raw, 1799 [ variable_names(Bindings), 1800 term_position(Pos), 1801 subterm_positions(RawLayout) 1802 | ReadOptions 1803 ]), 1804 b_setval('$term_position', Pos), 1805 b_setval('$variable_names', Bindings), 1806 ( Raw == end_of_file 1807 -> !, 1808 ( Parents = [_,_|_] % Included file 1809 -> fail 1810 ; '$expanded_term'(In, 1811 Raw, RawLayout, Read, RLayout, Term, TLayout, 1812 Stream, Parents, Options) 1813 ) 1814 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1815 Stream, Parents, Options) 1816 ). 1817 1818'$read_clause_options'([], []). 1819'$read_clause_options'([H|T0], List) :- 1820 ( '$read_clause_option'(H) 1821 -> List = [H|T] 1822 ; List = T 1823 ), 1824 '$read_clause_options'(T0, T). 1825 1826'$read_clause_option'(syntax_errors(_)). 1827'$read_clause_option'(term_position(_)). 1828'$read_clause_option'(process_comment(_)). 1829 1830'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout, 1831 Stream, Parents, Options) :- 1832 E = error(_,_), 1833 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E, 1834 '$print_message_fail'(E)), 1835 ( Expanded \== [] 1836 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1) 1837 ; Term1 = Expanded, 1838 Layout1 = ExpandedLayout 1839 ), 1840 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive) 1841 -> ( Directive = include(File), 1842 '$current_source_module'(Module), 1843 '$valid_directive'(Module:include(File)) 1844 -> stream_property(In, encoding(Enc)), 1845 '$add_encoding'(Enc, Options, Options1), 1846 '$source_term'(File, Read, RLayout, Term, TLayout, 1847 Stream, Parents, Options1) 1848 ; Directive = encoding(Enc) 1849 -> set_stream(In, encoding(Enc)), 1850 fail 1851 ; Term = Term1, 1852 Stream = In, 1853 Read = Raw 1854 ) 1855 ; Term = Term1, 1856 TLayout = Layout1, 1857 Stream = In, 1858 Read = Raw, 1859 RLayout = RawLayout 1860 ). 1861 1862'$expansion_member'(Var, Layout, Var, Layout) :- 1863 var(Var), 1864 !. 1865'$expansion_member'([], _, _, _) :- !, fail. 1866'$expansion_member'(List, ListLayout, Term, Layout) :- 1867 is_list(List), 1868 !, 1869 ( var(ListLayout) 1870 -> '$member'(Term, List) 1871 ; is_list(ListLayout) 1872 -> '$member_rep2'(Term, Layout, List, ListLayout) 1873 ; Layout = ListLayout, 1874 '$member'(Term, List) 1875 ). 1876'$expansion_member'(X, Layout, X, Layout). 1877 1878% pairwise member, repeating last element of the second 1879% list. 1880 1881'$member_rep2'(H1, H2, [H1|_], [H2|_]). 1882'$member_rep2'(H1, H2, [_|T1], [T2]) :- 1883 !, 1884 '$member_rep2'(H1, H2, T1, [T2]). 1885'$member_rep2'(H1, H2, [_|T1], [_|T2]) :- 1886 '$member_rep2'(H1, H2, T1, T2).
1890'$add_encoding'(Enc, Options0, Options) :- 1891 ( Options0 = [encoding(Enc)|_] 1892 -> Options = Options0 1893 ; Options = [encoding(Enc)|Options0] 1894 ). 1895 1896 1897:- multifile 1898 '$included'/4. % Into, Line, File, LastModified 1899:- dynamic 1900 '$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'.
1914'$record_included'([Parent|Parents], File, Path, Time, 1915 message(DoneMsgLevel, 1916 include_file(done(Level, file(File, Path))))) :- 1917 source_location(SrcFile, Line), 1918 !, 1919 '$compilation_level'(Level), 1920 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel), 1921 '$print_message'(StartMsgLevel, 1922 include_file(start(Level, 1923 file(File, Path)))), 1924 '$last'([Parent|Parents], Owner), 1925 ( ( '$compilation_mode'(database) 1926 ; '$qlf_current_source'(Owner) 1927 ) 1928 -> '$store_admin_clause'( 1929 system:'$included'(Parent, Line, Path, Time), 1930 _, Owner, SrcFile:Line) 1931 ; '$qlf_include'(Owner, Parent, Line, Path, Time) 1932 ). 1933'$record_included'(_, _, _, _, true).
1939'$master_file'(File, MasterFile) :- 1940 '$included'(MasterFile0, _Line, File, _Time), 1941 !, 1942 '$master_file'(MasterFile0, MasterFile). 1943'$master_file'(File, File). 1944 1945 1946'$skip_script_line'(_In, Options) :- 1947 '$option'(check_script(false), Options), 1948 !. 1949'$skip_script_line'(In, _Options) :- 1950 ( peek_char(In, #) 1951 -> skip(In, 10) 1952 ; true 1953 ). 1954 1955'$set_encoding'(Stream, Options) :- 1956 '$option'(encoding(Enc), Options), 1957 !, 1958 Enc \== default, 1959 set_stream(Stream, encoding(Enc)). 1960'$set_encoding'(_, _). 1961 1962 1963'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :- 1964 ( stream_property(In, file_name(_)) 1965 -> HasName = true, 1966 ( stream_property(In, position(_)) 1967 -> HasPos = true 1968 ; HasPos = false, 1969 set_stream(In, record_position(true)) 1970 ) 1971 ; HasName = false, 1972 set_stream(In, file_name(Id)), 1973 ( stream_property(In, position(_)) 1974 -> HasPos = true 1975 ; HasPos = false, 1976 set_stream(In, record_position(true)) 1977 ) 1978 ). 1979 1980'$restore_load_stream'(In, _State, Options) :- 1981 memberchk(close(true), Options), 1982 !, 1983 close(In). 1984'$restore_load_stream'(In, state(HasName, HasPos), _Options) :- 1985 ( HasName == false 1986 -> set_stream(In, file_name('')) 1987 ; true 1988 ), 1989 ( HasPos == false 1990 -> set_stream(In, record_position(false)) 1991 ; true 1992 ). 1993 1994 1995 /******************************* 1996 * DERIVED FILES * 1997 *******************************/ 1998 1999:- dynamic 2000 '$derived_source_db'/3. % Loaded, DerivedFrom, Time 2001 2002'$register_derived_source'(_, '-') :- !. 2003'$register_derived_source'(Loaded, DerivedFrom) :- 2004 retractall('$derived_source_db'(Loaded, _, _)), 2005 time_file(DerivedFrom, Time), 2006 assert('$derived_source_db'(Loaded, DerivedFrom, Time)). 2007 2008% Auto-importing dynamic predicates is not very elegant and 2009% leads to problems with qsave_program/[1,2] 2010 2011'$derived_source'(Loaded, DerivedFrom, Time) :- 2012 '$derived_source_db'(Loaded, DerivedFrom, Time). 2013 2014 2015 /******************************** 2016 * LOAD PREDICATES * 2017 *********************************/ 2018 2019:- meta_predicate 2020 ensure_loaded( ), 2021 [, | ] 2022 consult( ), 2023 use_module( ), 2024 use_module( , ), 2025 reexport( ), 2026 reexport( , ), 2027 load_files( ), 2028 load_files( , ).
2036ensure_loaded(Files) :-
2037 load_files(Files, [if(not_loaded)]).
2046use_module(Files) :-
2047 load_files(Files, [ if(not_loaded),
2048 must_be_module(true)
2049 ]).
2056use_module(File, Import) :-
2057 load_files(File, [ if(not_loaded),
2058 must_be_module(true),
2059 imports(Import)
2060 ]).
2066reexport(Files) :-
2067 load_files(Files, [ if(not_loaded),
2068 must_be_module(true),
2069 reexport(true)
2070 ]).
2076reexport(File, Import) :- 2077 load_files(File, [ if(not_loaded), 2078 must_be_module(true), 2079 imports(Import), 2080 reexport(true) 2081 ]). 2082 2083 2084[X] :- 2085 !, 2086 consult(X). 2087[M:F|R] :- 2088 consult(M:[F|R]). 2089 2090consult(M:X) :- 2091 X == user, 2092 !, 2093 flag('$user_consult', N, N+1), 2094 NN is N + 1, 2095 atom_concat('user://', NN, Id), 2096 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]). 2097consult(List) :- 2098 load_files(List, [expand(true)]).
2105load_files(Files) :- 2106 load_files(Files, []). 2107load_files(Module:Files, Options) :- 2108 '$must_be'(list, Options), 2109 '$load_files'(Files, Module, Options). 2110 2111'$load_files'(X, _, _) :- 2112 var(X), 2113 !, 2114 '$instantiation_error'(X). 2115'$load_files'([], _, _) :- !. 2116'$load_files'(Id, Module, Options) :- % load_files(foo, [stream(In)]) 2117 '$option'(stream(_), Options), 2118 !, 2119 ( atom(Id) 2120 -> '$load_file'(Id, Module, Options) 2121 ; throw(error(type_error(atom, Id), _)) 2122 ). 2123'$load_files'(List, Module, Options) :- 2124 List = [_|_], 2125 !, 2126 '$must_be'(list, List), 2127 '$load_file_list'(List, Module, Options). 2128'$load_files'(File, Module, Options) :- 2129 '$load_one_file'(File, Module, Options). 2130 2131'$load_file_list'([], _, _). 2132'$load_file_list'([File|Rest], Module, Options) :- 2133 E = error(_,_), 2134 catch('$load_one_file'(File, Module, Options), E, 2135 '$print_message'(error, E)), 2136 '$load_file_list'(Rest, Module, Options). 2137 2138 2139'$load_one_file'(Spec, Module, Options) :- 2140 atomic(Spec), 2141 '$option'(expand(Expand), Options, false), 2142 Expand == true, 2143 !, 2144 expand_file_name(Spec, Expanded), 2145 ( Expanded = [Load] 2146 -> true 2147 ; Load = Expanded 2148 ), 2149 '$load_files'(Load, Module, [expand(false)|Options]). 2150'$load_one_file'(File, Module, Options) :- 2151 strip_module(Module:File, Into, PlainFile), 2152 '$load_file'(PlainFile, Into, Options).
2159'$noload'(true, _, _) :- 2160 !, 2161 fail. 2162'$noload'(_, FullFile, _Options) :- 2163 '$time_source_file'(FullFile, Time, system), 2164 Time > 0.0, 2165 !. 2166'$noload'(not_loaded, FullFile, _) :- 2167 source_file(FullFile), 2168 !. 2169'$noload'(changed, Derived, _) :- 2170 '$derived_source'(_FullFile, Derived, LoadTime), 2171 time_file(Derived, Modified), 2172 Modified @=< LoadTime, 2173 !. 2174'$noload'(changed, FullFile, Options) :- 2175 '$time_source_file'(FullFile, LoadTime, user), 2176 '$modified_id'(FullFile, Modified, Options), 2177 Modified @=< LoadTime, 2178 !.
2197'$qlf_file'(Spec, _, Spec, stream, Options) :- 2198 '$option'(stream(_), Options), % stream: no choice 2199 !. 2200'$qlf_file'(Spec, FullFile, FullFile, compile, _) :- 2201 '$spec_extension'(Spec, Ext), % user explicitly specified 2202 user:prolog_file_type(Ext, prolog), 2203 !. 2204'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :- 2205 '$compilation_mode'(database), 2206 file_name_extension(Base, PlExt, FullFile), 2207 user:prolog_file_type(PlExt, prolog), 2208 user:prolog_file_type(QlfExt, qlf), 2209 file_name_extension(Base, QlfExt, QlfFile), 2210 ( access_file(QlfFile, read), 2211 ( '$qlf_out_of_date'(FullFile, QlfFile, Why) 2212 -> ( access_file(QlfFile, write) 2213 -> print_message(informational, 2214 qlf(recompile(Spec, FullFile, QlfFile, Why))), 2215 Mode = qcompile, 2216 LoadFile = FullFile 2217 ; Why == old, 2218 current_prolog_flag(home, PlHome), 2219 sub_atom(FullFile, 0, _, _, PlHome) 2220 -> print_message(silent, 2221 qlf(system_lib_out_of_date(Spec, QlfFile))), 2222 Mode = qload, 2223 LoadFile = QlfFile 2224 ; print_message(warning, 2225 qlf(can_not_recompile(Spec, QlfFile, Why))), 2226 Mode = compile, 2227 LoadFile = FullFile 2228 ) 2229 ; Mode = qload, 2230 LoadFile = QlfFile 2231 ) 2232 -> ! 2233 ; '$qlf_auto'(FullFile, QlfFile, Options) 2234 -> !, Mode = qcompile, 2235 LoadFile = FullFile 2236 ). 2237'$qlf_file'(_, FullFile, FullFile, compile, _).
2245'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2246 ( access_file(PlFile, read)
2247 -> time_file(PlFile, PlTime),
2248 time_file(QlfFile, QlfTime),
2249 ( PlTime > QlfTime
2250 -> Why = old % PlFile is newer
2251 ; Error = error(Formal,_),
2252 catch('$qlf_sources'(QlfFile, _Files), Error, true),
2253 nonvar(Formal) % QlfFile is incompatible
2254 -> Why = Error
2255 ; fail % QlfFile is up-to-date and ok
2256 )
2257 ; fail % can not read .pl; try .qlf
2258 ).
qcompile(QlfMode)
or, if this is not present, by
the prolog_flag qcompile.2266:- create_prolog_flag(qcompile, false, [type(atom)]). 2267 2268'$qlf_auto'(PlFile, QlfFile, Options) :- 2269 ( memberchk(qcompile(QlfMode), Options) 2270 -> true 2271 ; current_prolog_flag(qcompile, QlfMode), 2272 \+ '$in_system_dir'(PlFile) 2273 ), 2274 ( QlfMode == auto 2275 -> true 2276 ; QlfMode == large, 2277 size_file(PlFile, Size), 2278 Size > 100000 2279 ), 2280 access_file(QlfFile, write). 2281 2282'$in_system_dir'(PlFile) :- 2283 current_prolog_flag(home, Home), 2284 sub_atom(PlFile, 0, _, _, Home). 2285 2286'$spec_extension'(File, Ext) :- 2287 atom(File), 2288 file_name_extension(_, Ext, File). 2289'$spec_extension'(Spec, Ext) :- 2290 compound(Spec), 2291 arg(1, Spec, Arg), 2292 '$spec_extension'(Arg, Ext).
2304:- dynamic 2305 '$resolved_source_path_db'/3. % ?Spec, ?Dialect, ?Path 2306 2307'$load_file'(File, Module, Options) :- 2308 \+ memberchk(stream(_), Options), 2309 user:prolog_load_file(Module:File, Options), 2310 !. 2311'$load_file'(File, Module, Options) :- 2312 memberchk(stream(_), Options), 2313 !, 2314 '$assert_load_context_module'(File, Module, Options), 2315 '$qdo_load_file'(File, File, Module, Options). 2316'$load_file'(File, Module, Options) :- 2317 ( '$resolved_source_path'(File, FullFile, Options) 2318 -> true 2319 ; '$resolve_source_path'(File, FullFile, Options) 2320 ), 2321 '$mt_load_file'(File, FullFile, Module, Options).
2327'$resolved_source_path'(File, FullFile, Options) :-
2328 current_prolog_flag(emulated_dialect, Dialect),
2329 '$resolved_source_path_db'(File, Dialect, FullFile),
2330 ( '$source_file_property'(FullFile, from_state, true)
2331 ; '$source_file_property'(FullFile, resource, true)
2332 ; '$option'(if(If), Options, true),
2333 '$noload'(If, FullFile, Options)
2334 ),
2335 !.
2342'$resolve_source_path'(File, FullFile, _Options) :- 2343 absolute_file_name(File, FullFile, 2344 [ file_type(prolog), 2345 access(read) 2346 ]), 2347 '$register_resolved_source_path'(File, FullFile). 2348 2349 2350'$register_resolved_source_path'(File, FullFile) :- 2351 ( compound(File) 2352 -> current_prolog_flag(emulated_dialect, Dialect), 2353 ( '$resolved_source_path_db'(File, Dialect, FullFile) 2354 -> true 2355 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile)) 2356 ) 2357 ; true 2358 ).
2364:- public '$translated_source'/2. 2365'$translated_source'(Old, New) :- 2366 forall(retract('$resolved_source_path_db'(File, Dialect, Old)), 2367 assertz('$resolved_source_path_db'(File, Dialect, New))).
2374'$register_resource_file'(FullFile) :-
2375 ( sub_atom(FullFile, 0, _, _, 'res://')
2376 -> '$set_source_file'(FullFile, resource, true)
2377 ; true
2378 ).
2391'$already_loaded'(_File, FullFile, Module, Options) :- 2392 '$assert_load_context_module'(FullFile, Module, Options), 2393 '$current_module'(LoadModules, FullFile), 2394 !, 2395 ( atom(LoadModules) 2396 -> LoadModule = LoadModules 2397 ; LoadModules = [LoadModule|_] 2398 ), 2399 '$import_from_loaded_module'(LoadModule, Module, Options). 2400'$already_loaded'(_, _, user, _) :- !. 2401'$already_loaded'(File, FullFile, Module, Options) :- 2402 ( '$load_context_module'(FullFile, Module, CtxOptions), 2403 '$load_ctx_options'(Options, CtxOptions) 2404 -> true 2405 ; '$load_file'(File, Module, [if(true)|Options]) 2406 ).
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.
2421:- dynamic 2422 '$loading_file'/3. % File, Queue, Thread 2423:- volatile 2424 '$loading_file'/3. 2425 2426'$mt_load_file'(File, FullFile, Module, Options) :- 2427 current_prolog_flag(threads, true), 2428 !, 2429 '$sig_atomic'(setup_call_cleanup( 2430 with_mutex('$load_file', 2431 '$mt_start_load'(FullFile, Loading, Options)), 2432 '$mt_do_load'(Loading, File, FullFile, Module, Options), 2433 '$mt_end_load'(Loading))). 2434'$mt_load_file'(File, FullFile, Module, Options) :- 2435 '$option'(if(If), Options, true), 2436 '$noload'(If, FullFile, Options), 2437 !, 2438 '$already_loaded'(File, FullFile, Module, Options). 2439'$mt_load_file'(File, FullFile, Module, Options) :- 2440 '$sig_atomic'('$qdo_load_file'(File, FullFile, Module, Options)). 2441 2442'$mt_start_load'(FullFile, queue(Queue), _) :- 2443 '$loading_file'(FullFile, Queue, LoadThread), 2444 \+ thread_self(LoadThread), 2445 !. 2446'$mt_start_load'(FullFile, already_loaded, Options) :- 2447 '$option'(if(If), Options, true), 2448 '$noload'(If, FullFile, Options), 2449 !. 2450'$mt_start_load'(FullFile, Ref, _) :- 2451 thread_self(Me), 2452 message_queue_create(Queue), 2453 assertz('$loading_file'(FullFile, Queue, Me), Ref). 2454 2455'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :- 2456 !, 2457 catch(thread_get_message(Queue, _), error(_,_), true), 2458 '$already_loaded'(File, FullFile, Module, Options). 2459'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :- 2460 !, 2461 '$already_loaded'(File, FullFile, Module, Options). 2462'$mt_do_load'(_Ref, File, FullFile, Module, Options) :- 2463 '$assert_load_context_module'(FullFile, Module, Options), 2464 '$qdo_load_file'(File, FullFile, Module, Options). 2465 2466'$mt_end_load'(queue(_)) :- !. 2467'$mt_end_load'(already_loaded) :- !. 2468'$mt_end_load'(Ref) :- 2469 clause('$loading_file'(_, Queue, _), _, Ref), 2470 erase(Ref), 2471 thread_send_message(Queue, done), 2472 message_queue_destroy(Queue).
2479'$qdo_load_file'(File, FullFile, Module, Options) :- 2480 '$qdo_load_file2'(File, FullFile, Module, Action, Options), 2481 '$register_resource_file'(FullFile), 2482 '$run_initialization'(FullFile, Action, Options). 2483 2484'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2485 memberchk('$qlf'(QlfOut), Options), 2486 '$stage_file'(QlfOut, StageQlf), 2487 !, 2488 setup_call_catcher_cleanup( 2489 '$qstart'(StageQlf, Module, State), 2490 '$do_load_file'(File, FullFile, Module, Action, Options), 2491 Catcher, 2492 '$qend'(State, Catcher, StageQlf, QlfOut)). 2493'$qdo_load_file2'(File, FullFile, Module, Action, Options) :- 2494 '$do_load_file'(File, FullFile, Module, Action, Options). 2495 2496'$qstart'(Qlf, Module, state(OldMode, OldModule)) :- 2497 '$qlf_open'(Qlf), 2498 '$compilation_mode'(OldMode, qlf), 2499 '$set_source_module'(OldModule, Module). 2500 2501'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :- 2502 '$set_source_module'(_, OldModule), 2503 '$set_compilation_mode'(OldMode), 2504 '$qlf_close', 2505 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn). 2506 2507'$set_source_module'(OldModule, Module) :- 2508 '$current_source_module'(OldModule), 2509 '$set_source_module'(Module).
2516'$do_load_file'(File, FullFile, Module, Action, Options) :- 2517 '$option'(derived_from(DerivedFrom), Options, -), 2518 '$register_derived_source'(FullFile, DerivedFrom), 2519 '$qlf_file'(File, FullFile, Absolute, Mode, Options), 2520 ( Mode == qcompile 2521 -> qcompile(Module:File, Options) 2522 ; '$do_load_file_2'(File, Absolute, Module, Action, Options) 2523 ). 2524 2525'$do_load_file_2'(File, Absolute, Module, Action, Options) :- 2526 '$source_file_property'(Absolute, number_of_clauses, OldClauses), 2527 statistics(cputime, OldTime), 2528 2529 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2530 Options), 2531 2532 '$compilation_level'(Level), 2533 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel), 2534 '$print_message'(StartMsgLevel, 2535 load_file(start(Level, 2536 file(File, Absolute)))), 2537 2538 ( memberchk(stream(FromStream), Options) 2539 -> Input = stream 2540 ; Input = source 2541 ), 2542 2543 ( Input == stream, 2544 ( '$option'(format(qlf), Options, source) 2545 -> set_stream(FromStream, file_name(Absolute)), 2546 '$qload_stream'(FromStream, Module, Action, LM, Options) 2547 ; '$consult_file'(stream(Absolute, FromStream, []), 2548 Module, Action, LM, Options) 2549 ) 2550 -> true 2551 ; Input == source, 2552 file_name_extension(_, Ext, Absolute), 2553 ( user:prolog_file_type(Ext, qlf), 2554 E = error(_,_), 2555 catch('$qload_file'(Absolute, Module, Action, LM, Options), 2556 E, 2557 print_message(warning, E)) 2558 -> true 2559 ; '$consult_file'(Absolute, Module, Action, LM, Options) 2560 ) 2561 -> true 2562 ; '$print_message'(error, load_file(failed(File))), 2563 fail 2564 ), 2565 2566 '$import_from_loaded_module'(LM, Module, Options), 2567 2568 '$source_file_property'(Absolute, number_of_clauses, NewClauses), 2569 statistics(cputime, Time), 2570 ClausesCreated is NewClauses - OldClauses, 2571 TimeUsed is Time - OldTime, 2572 2573 '$print_message'(DoneMsgLevel, 2574 load_file(done(Level, 2575 file(File, Absolute), 2576 Action, 2577 LM, 2578 TimeUsed, 2579 ClausesCreated))), 2580 2581 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef). 2582 2583'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef, 2584 Options) :- 2585 '$save_file_scoped_flags'(ScopedFlags), 2586 '$set_sandboxed_load'(Options, OldSandBoxed), 2587 '$set_verbose_load'(Options, OldVerbose), 2588 '$set_optimise_load'(Options), 2589 '$update_autoload_level'(Options, OldAutoLevel), 2590 '$set_no_xref'(OldXRef). 2591 2592'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :- 2593 '$set_autoload_level'(OldAutoLevel), 2594 set_prolog_flag(xref, OldXRef), 2595 set_prolog_flag(verbose_load, OldVerbose), 2596 set_prolog_flag(sandboxed_load, OldSandBoxed), 2597 '$restore_file_scoped_flags'(ScopedFlags).
2605'$save_file_scoped_flags'(State) :- 2606 current_predicate(findall/3), % Not when doing boot compile 2607 !, 2608 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State). 2609'$save_file_scoped_flags'([]). 2610 2611'$save_file_scoped_flag'(Flag-Value) :- 2612 '$file_scoped_flag'(Flag, Default), 2613 ( current_prolog_flag(Flag, Value) 2614 -> true 2615 ; Value = Default 2616 ). 2617 2618'$file_scoped_flag'(generate_debug_info, true). 2619'$file_scoped_flag'(optimise, false). 2620'$file_scoped_flag'(xref, false). 2621 2622'$restore_file_scoped_flags'([]). 2623'$restore_file_scoped_flags'([Flag-Value|T]) :- 2624 set_prolog_flag(Flag, Value), 2625 '$restore_file_scoped_flags'(T).
2632'$import_from_loaded_module'(LoadedModule, Module, Options) :- 2633 LoadedModule \== Module, 2634 atom(LoadedModule), 2635 !, 2636 '$option'(imports(Import), Options, all), 2637 '$option'(reexport(Reexport), Options, false), 2638 '$import_list'(Module, LoadedModule, Import, Reexport). 2639'$import_from_loaded_module'(_, _, _).
verbose_load
flag according to Options and unify Old
with the old value.2647'$set_verbose_load'(Options, Old) :- 2648 current_prolog_flag(verbose_load, Old), 2649 ( memberchk(silent(Silent), Options) 2650 -> ( '$negate'(Silent, Level0) 2651 -> '$load_msg_compat'(Level0, Level) 2652 ; Level = Silent 2653 ), 2654 set_prolog_flag(verbose_load, Level) 2655 ; true 2656 ). 2657 2658'$negate'(true, false). 2659'$negate'(false, true).
sandboxed_load
from Options. Old is
unified with the old flag.
2668'$set_sandboxed_load'(Options, Old) :- 2669 current_prolog_flag(sandboxed_load, Old), 2670 ( memberchk(sandboxed(SandBoxed), Options), 2671 '$enter_sandboxed'(Old, SandBoxed, New), 2672 New \== Old 2673 -> set_prolog_flag(sandboxed_load, New) 2674 ; true 2675 ). 2676 2677'$enter_sandboxed'(Old, New, SandBoxed) :- 2678 ( Old == false, New == true 2679 -> SandBoxed = true, 2680 '$ensure_loaded_library_sandbox' 2681 ; Old == true, New == false 2682 -> throw(error(permission_error(leave, sandbox, -), _)) 2683 ; SandBoxed = Old 2684 ). 2685'$enter_sandboxed'(false, true, true). 2686 2687'$ensure_loaded_library_sandbox' :- 2688 source_file_property(library(sandbox), module(sandbox)), 2689 !. 2690'$ensure_loaded_library_sandbox' :- 2691 load_files(library(sandbox), [if(not_loaded), silent(true)]). 2692 2693'$set_optimise_load'(Options) :- 2694 ( '$option'(optimise(Optimise), Options) 2695 -> set_prolog_flag(optimise, Optimise) 2696 ; true 2697 ). 2698 2699'$set_no_xref'(OldXRef) :- 2700 ( current_prolog_flag(xref, OldXRef) 2701 -> true 2702 ; OldXRef = false 2703 ), 2704 set_prolog_flag(xref, false).
2711:- thread_local 2712 '$autoload_nesting'/1. 2713 2714'$update_autoload_level'(Options, AutoLevel) :- 2715 '$option'(autoload(Autoload), Options, false), 2716 ( '$autoload_nesting'(CurrentLevel) 2717 -> AutoLevel = CurrentLevel 2718 ; AutoLevel = 0 2719 ), 2720 ( Autoload == false 2721 -> true 2722 ; NewLevel is AutoLevel + 1, 2723 '$set_autoload_level'(NewLevel) 2724 ). 2725 2726'$set_autoload_level'(New) :- 2727 retractall('$autoload_nesting'(_)), 2728 asserta('$autoload_nesting'(New)).
2736'$print_message'(Level, Term) :- 2737 current_predicate(system:print_message/2), 2738 !, 2739 print_message(Level, Term). 2740'$print_message'(warning, Term) :- 2741 source_location(File, Line), 2742 !, 2743 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]). 2744'$print_message'(error, Term) :- 2745 !, 2746 source_location(File, Line), 2747 !, 2748 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]). 2749'$print_message'(_Level, _Term). 2750 2751'$print_message_fail'(E) :- 2752 '$print_message'(error, E), 2753 fail.
2761'$consult_file'(Absolute, Module, What, LM, Options) :- 2762 '$current_source_module'(Module), % same module 2763 !, 2764 '$consult_file_2'(Absolute, Module, What, LM, Options). 2765'$consult_file'(Absolute, Module, What, LM, Options) :- 2766 '$set_source_module'(OldModule, Module), 2767 '$ifcompiling'('$qlf_start_sub_module'(Module)), 2768 '$consult_file_2'(Absolute, Module, What, LM, Options), 2769 '$ifcompiling'('$qlf_end_part'), 2770 '$set_source_module'(OldModule). 2771 2772'$consult_file_2'(Absolute, Module, What, LM, Options) :- 2773 '$set_source_module'(OldModule, Module), 2774 '$load_id'(Absolute, Id, Modified, Options), 2775 '$compile_type'(What), 2776 '$save_lex_state'(LexState, Options), 2777 '$set_dialect'(Options), 2778 setup_call_cleanup( 2779 '$start_consult'(Id, Modified), 2780 '$load_file'(Absolute, Id, LM, Options), 2781 '$end_consult'(Id, LexState, OldModule)). 2782 2783'$end_consult'(Id, LexState, OldModule) :- 2784 '$end_consult'(Id), 2785 '$restore_lex_state'(LexState), 2786 '$set_source_module'(OldModule). 2787 2788 2789:- create_prolog_flag(emulated_dialect, swi, [type(atom)]).
2793'$save_lex_state'(State, Options) :- 2794 memberchk(scope_settings(false), Options), 2795 !, 2796 State = (-). 2797'$save_lex_state'(lexstate(Style, Dialect), _) :- 2798 '$style_check'(Style, Style), 2799 current_prolog_flag(emulated_dialect, Dialect). 2800 2801'$restore_lex_state'(-) :- !. 2802'$restore_lex_state'(lexstate(Style, Dialect)) :- 2803 '$style_check'(_, Style), 2804 set_prolog_flag(emulated_dialect, Dialect). 2805 2806'$set_dialect'(Options) :- 2807 memberchk(dialect(Dialect), Options), 2808 !, 2809 '$expects_dialect'(Dialect). 2810'$set_dialect'(_). 2811 2812'$load_id'(stream(Id, _, _), Id, Modified, Options) :- 2813 !, 2814 '$modified_id'(Id, Modified, Options). 2815'$load_id'(Id, Id, Modified, Options) :- 2816 '$modified_id'(Id, Modified, Options). 2817 2818'$modified_id'(_, Modified, Options) :- 2819 '$option'(modified(Stamp), Options, Def), 2820 Stamp \== Def, 2821 !, 2822 Modified = Stamp. 2823'$modified_id'(Id, Modified, _) :- 2824 catch(time_file(Id, Modified), 2825 error(_, _), 2826 fail), 2827 !. 2828'$modified_id'(_, 0.0, _). 2829 2830 2831'$compile_type'(What) :- 2832 '$compilation_mode'(How), 2833 ( How == database 2834 -> What = compiled 2835 ; How == qlf 2836 -> What = '*qcompiled*' 2837 ; What = 'boot compiled' 2838 ).
2848:- dynamic 2849 '$load_context_module'/3. 2850:- multifile 2851 '$load_context_module'/3. 2852 2853'$assert_load_context_module'(_, _, Options) :- 2854 memberchk(register(false), Options), 2855 !. 2856'$assert_load_context_module'(File, Module, Options) :- 2857 source_location(FromFile, Line), 2858 !, 2859 '$master_file'(FromFile, MasterFile), 2860 '$check_load_non_module'(File, Module), 2861 '$add_dialect'(Options, Options1), 2862 '$load_ctx_options'(Options1, Options2), 2863 '$store_admin_clause'( 2864 system:'$load_context_module'(File, Module, Options2), 2865 _Layout, MasterFile, FromFile:Line). 2866'$assert_load_context_module'(File, Module, Options) :- 2867 '$check_load_non_module'(File, Module), 2868 '$add_dialect'(Options, Options1), 2869 '$load_ctx_options'(Options1, Options2), 2870 ( clause('$load_context_module'(File, Module, _), true, Ref), 2871 \+ clause_property(Ref, file(_)), 2872 erase(Ref) 2873 -> true 2874 ; true 2875 ), 2876 assertz('$load_context_module'(File, Module, Options2)). 2877 2878'$add_dialect'(Options0, Options) :- 2879 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi, 2880 !, 2881 Options = [dialect(Dialect)|Options0]. 2882'$add_dialect'(Options, Options).
2889'$load_ctx_options'(Options, CtxOptions) :- 2890 '$load_ctx_options2'(Options, CtxOptions0), 2891 sort(CtxOptions0, CtxOptions). 2892 2893'$load_ctx_options2'([], []). 2894'$load_ctx_options2'([H|T0], [H|T]) :- 2895 '$load_ctx_option'(H), 2896 !, 2897 '$load_ctx_options2'(T0, T). 2898'$load_ctx_options2'([_|T0], T) :- 2899 '$load_ctx_options2'(T0, T). 2900 2901'$load_ctx_option'(derived_from(_)). 2902'$load_ctx_option'(dialect(_)). 2903'$load_ctx_option'(encoding(_)). 2904'$load_ctx_option'(imports(_)). 2905'$load_ctx_option'(reexport(_)).
2913'$check_load_non_module'(File, _) :- 2914 '$current_module'(_, File), 2915 !. % File is a module file 2916'$check_load_non_module'(File, Module) :- 2917 '$load_context_module'(File, OldModule, _), 2918 Module \== OldModule, 2919 !, 2920 format(atom(Msg), 2921 'Non-module file already loaded into module ~w; \c 2922 trying to load into ~w', 2923 [OldModule, Module]), 2924 throw(error(permission_error(load, source, File), 2925 context(load_files/2, Msg))). 2926'$check_load_non_module'(_, _).
state(FirstTerm:boolean,
Module:atom,
AtEnd:atom,
Stop:boolean,
Id:atom,
Dialect:atom)
2939'$load_file'(Path, Id, Module, Options) :- 2940 State = state(true, _, true, false, Id, -), 2941 ( '$source_term'(Path, _Read, _Layout, Term, Layout, 2942 _Stream, Options), 2943 '$valid_term'(Term), 2944 ( arg(1, State, true) 2945 -> '$first_term'(Term, Layout, Id, State, Options), 2946 nb_setarg(1, State, false) 2947 ; '$compile_term'(Term, Layout, Id) 2948 ), 2949 arg(4, State, true) 2950 ; '$fixup_reconsult'(Id), 2951 '$end_load_file'(State) 2952 ), 2953 !, 2954 arg(2, State, Module). 2955 2956'$valid_term'(Var) :- 2957 var(Var), 2958 !, 2959 print_message(error, error(instantiation_error, _)). 2960'$valid_term'(Term) :- 2961 Term \== []. 2962 2963'$end_load_file'(State) :- 2964 arg(1, State, true), % empty file 2965 !, 2966 nb_setarg(2, State, Module), 2967 arg(5, State, Id), 2968 '$current_source_module'(Module), 2969 '$ifcompiling'('$qlf_start_file'(Id)), 2970 '$ifcompiling'('$qlf_end_part'). 2971'$end_load_file'(State) :- 2972 arg(3, State, End), 2973 '$end_load_file'(End, State). 2974 2975'$end_load_file'(true, _). 2976'$end_load_file'(end_module, State) :- 2977 arg(2, State, Module), 2978 '$check_export'(Module), 2979 '$ifcompiling'('$qlf_end_part'). 2980'$end_load_file'(end_non_module, _State) :- 2981 '$ifcompiling'('$qlf_end_part'). 2982 2983 2984'$first_term'(?-(Directive), Layout, Id, State, Options) :- 2985 !, 2986 '$first_term'(:-(Directive), Layout, Id, State, Options). 2987'$first_term'(:-(Directive), _Layout, Id, State, Options) :- 2988 nonvar(Directive), 2989 ( ( Directive = module(Name, Public) 2990 -> Imports = [] 2991 ; Directive = module(Name, Public, Imports) 2992 ) 2993 -> !, 2994 '$module_name'(Name, Id, Module, Options), 2995 '$start_module'(Module, Public, State, Options), 2996 '$module3'(Imports) 2997 ; Directive = expects_dialect(Dialect) 2998 -> !, 2999 '$set_dialect'(Dialect, State), 3000 fail % Still consider next term as first 3001 ). 3002'$first_term'(Term, Layout, Id, State, Options) :- 3003 '$start_non_module'(Id, Term, State, Options), 3004 '$compile_term'(Term, Layout, Id). 3005 3006'$compile_term'(Term, Layout, Id) :- 3007 '$compile_term'(Term, Layout, Id, -). 3008 3009'$compile_term'(Var, _Layout, _Id, _Src) :- 3010 var(Var), 3011 !, 3012 '$instantiation_error'(Var). 3013'$compile_term'((?-Directive), _Layout, Id, _) :- 3014 !, 3015 '$execute_directive'(Directive, Id). 3016'$compile_term'((:-Directive), _Layout, Id, _) :- 3017 !, 3018 '$execute_directive'(Directive, Id). 3019'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :- 3020 !, 3021 '$compile_term'(Term, Layout, Id, File:Line). 3022'$compile_term'(Clause, Layout, Id, SrcLoc) :- 3023 E = error(_,_), 3024 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E, 3025 '$print_message'(error, E)). 3026 3027'$start_non_module'(_Id, Term, _State, Options) :- 3028 '$option'(must_be_module(true), Options, false), 3029 !, 3030 '$domain_error'(module_header, Term). 3031'$start_non_module'(Id, _Term, State, _Options) :- 3032 '$current_source_module'(Module), 3033 '$ifcompiling'('$qlf_start_file'(Id)), 3034 '$qset_dialect'(State), 3035 nb_setarg(2, State, Module), 3036 nb_setarg(3, State, end_non_module).
Note that expects_dialect/1 itself may be autoloaded from the library.
3049'$set_dialect'(Dialect, State) :- 3050 '$compilation_mode'(qlf, database), 3051 !, 3052 '$expects_dialect'(Dialect), 3053 '$compilation_mode'(_, qlf), 3054 nb_setarg(6, State, Dialect). 3055'$set_dialect'(Dialect, _) :- 3056 '$expects_dialect'(Dialect). 3057 3058'$qset_dialect'(State) :- 3059 '$compilation_mode'(qlf), 3060 arg(6, State, Dialect), Dialect \== (-), 3061 !, 3062 '$add_directive_wic'('$expects_dialect'(Dialect)). 3063'$qset_dialect'(_). 3064 3065'$expects_dialect'(Dialect) :- 3066 Dialect == swi, 3067 !, 3068 set_prolog_flag(emulated_dialect, Dialect). 3069'$expects_dialect'(Dialect) :- 3070 current_predicate(expects_dialect/1), 3071 !, 3072 expects_dialect(Dialect). 3073'$expects_dialect'(Dialect) :- 3074 use_module(library(dialect), [expects_dialect/1]), 3075 expects_dialect(Dialect). 3076 3077 3078 /******************************* 3079 * MODULES * 3080 *******************************/ 3081 3082'$start_module'(Module, _Public, State, _Options) :- 3083 '$current_module'(Module, OldFile), 3084 source_location(File, _Line), 3085 OldFile \== File, OldFile \== [], 3086 same_file(OldFile, File), 3087 !, 3088 nb_setarg(2, State, Module), 3089 nb_setarg(4, State, true). % Stop processing 3090'$start_module'(Module, Public, State, Options) :- 3091 arg(5, State, File), 3092 nb_setarg(2, State, Module), 3093 source_location(_File, Line), 3094 '$option'(redefine_module(Action), Options, false), 3095 '$module_class'(File, Class, Super), 3096 '$reset_dialect'(File, Class), 3097 '$redefine_module'(Module, File, Action), 3098 '$declare_module'(Module, Class, Super, File, Line, false), 3099 '$export_list'(Public, Module, Ops), 3100 '$ifcompiling'('$qlf_start_module'(Module)), 3101 '$export_ops'(Ops, Module, File), 3102 '$qset_dialect'(State), 3103 nb_setarg(3, State, end_module).
swi
dialect.3110'$reset_dialect'(File, library) :- 3111 file_name_extension(_, pl, File), 3112 !, 3113 set_prolog_flag(emulated_dialect, swi). 3114'$reset_dialect'(_, _).
3121'$module3'(Var) :- 3122 var(Var), 3123 !, 3124 '$instantiation_error'(Var). 3125'$module3'([]) :- !. 3126'$module3'([H|T]) :- 3127 !, 3128 '$module3'(H), 3129 '$module3'(T). 3130'$module3'(Id) :- 3131 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.3145'$module_name'(_, _, Module, Options) :- 3146 '$option'(module(Module), Options), 3147 !, 3148 '$current_source_module'(Context), 3149 Context \== Module. % cause '$first_term'/5 to fail. 3150'$module_name'(Var, Id, Module, Options) :- 3151 var(Var), 3152 !, 3153 file_base_name(Id, File), 3154 file_name_extension(Var, _, File), 3155 '$module_name'(Var, Id, Module, Options). 3156'$module_name'(Reserved, _, _, _) :- 3157 '$reserved_module'(Reserved), 3158 !, 3159 throw(error(permission_error(load, module, Reserved), _)). 3160'$module_name'(Module, _Id, Module, _). 3161 3162 3163'$reserved_module'(system). 3164'$reserved_module'(user).
3169'$redefine_module'(_Module, _, false) :- !. 3170'$redefine_module'(Module, File, true) :- 3171 !, 3172 ( module_property(Module, file(OldFile)), 3173 File \== OldFile 3174 -> unload_file(OldFile) 3175 ; true 3176 ). 3177'$redefine_module'(Module, File, ask) :- 3178 ( stream_property(user_input, tty(true)), 3179 module_property(Module, file(OldFile)), 3180 File \== OldFile, 3181 '$rdef_response'(Module, OldFile, File, true) 3182 -> '$redefine_module'(Module, File, true) 3183 ; true 3184 ). 3185 3186'$rdef_response'(Module, OldFile, File, Ok) :- 3187 repeat, 3188 print_message(query, redefine_module(Module, OldFile, File)), 3189 get_single_char(Char), 3190 '$rdef_response'(Char, Ok0), 3191 !, 3192 Ok = Ok0. 3193 3194'$rdef_response'(Char, true) :- 3195 memberchk(Char, `yY`), 3196 format(user_error, 'yes~n', []). 3197'$rdef_response'(Char, false) :- 3198 memberchk(Char, `nN`), 3199 format(user_error, 'no~n', []). 3200'$rdef_response'(Char, _) :- 3201 memberchk(Char, `a`), 3202 format(user_error, 'abort~n', []), 3203 abort. 3204'$rdef_response'(_, _) :- 3205 print_message(help, redefine_module_reply), 3206 fail.
system
, while all normal user modules inherit
from user
.3216'$module_class'(File, Class, system) :- 3217 current_prolog_flag(home, Home), 3218 sub_atom(File, 0, Len, _, Home), 3219 ( sub_atom(File, Len, _, _, '/boot/') 3220 -> Class = system 3221 ; '$lib_prefix'(Prefix), 3222 sub_atom(File, Len, _, _, Prefix) 3223 -> Class = library 3224 ; file_directory_name(File, Home), 3225 file_name_extension(_, rc, File) 3226 -> Class = library 3227 ), 3228 !. 3229'$module_class'(_, user, user). 3230 3231'$lib_prefix'('/library'). 3232'$lib_prefix'('/xpce/prolog/'). 3233 3234'$check_export'(Module) :- 3235 '$undefined_export'(Module, UndefList), 3236 ( '$member'(Undef, UndefList), 3237 strip_module(Undef, _, Local), 3238 print_message(error, 3239 undefined_export(Module, Local)), 3240 fail 3241 ; true 3242 ).
all
,
a list of optionally mapped predicate indicators or a term
except(Import)
.3251'$import_list'(_, _, Var, _) :- 3252 var(Var), 3253 !, 3254 throw(error(instantitation_error, _)). 3255'$import_list'(Target, Source, all, Reexport) :- 3256 !, 3257 '$exported_ops'(Source, Import, Predicates), 3258 '$module_property'(Source, exports(Predicates)), 3259 '$import_all'(Import, Target, Source, Reexport, weak). 3260'$import_list'(Target, Source, except(Spec), Reexport) :- 3261 !, 3262 '$exported_ops'(Source, Export, Predicates), 3263 '$module_property'(Source, exports(Predicates)), 3264 ( is_list(Spec) 3265 -> true 3266 ; throw(error(type_error(list, Spec), _)) 3267 ), 3268 '$import_except'(Spec, Export, Import), 3269 '$import_all'(Import, Target, Source, Reexport, weak). 3270'$import_list'(Target, Source, Import, Reexport) :- 3271 !, 3272 is_list(Import), 3273 !, 3274 '$import_all'(Import, Target, Source, Reexport, strong). 3275'$import_list'(_, _, Import, _) :- 3276 throw(error(type_error(import_specifier, Import))). 3277 3278 3279'$import_except'([], List, List). 3280'$import_except'([H|T], List0, List) :- 3281 '$import_except_1'(H, List0, List1), 3282 '$import_except'(T, List1, List). 3283 3284'$import_except_1'(Var, _, _) :- 3285 var(Var), 3286 !, 3287 throw(error(instantitation_error, _)). 3288'$import_except_1'(PI as N, List0, List) :- 3289 '$pi'(PI), atom(N), 3290 !, 3291 '$canonical_pi'(PI, CPI), 3292 '$import_as'(CPI, N, List0, List). 3293'$import_except_1'(op(P,A,N), List0, List) :- 3294 !, 3295 '$remove_ops'(List0, op(P,A,N), List). 3296'$import_except_1'(PI, List0, List) :- 3297 '$pi'(PI), 3298 !, 3299 '$canonical_pi'(PI, CPI), 3300 '$select'(P, List0, List), 3301 '$canonical_pi'(CPI, P), 3302 !. 3303'$import_except_1'(Except, _, _) :- 3304 throw(error(type_error(import_specifier, Except), _)). 3305 3306'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :- 3307 '$canonical_pi'(PI2, CPI), 3308 !. 3309'$import_as'(PI, N, [H|T0], [H|T]) :- 3310 !, 3311 '$import_as'(PI, N, T0, T). 3312'$import_as'(PI, _, _, _) :- 3313 throw(error(existence_error(export, PI), _)). 3314 3315'$pi'(N/A) :- atom(N), integer(A), !. 3316'$pi'(N//A) :- atom(N), integer(A). 3317 3318'$canonical_pi'(N//A0, N/A) :- 3319 A is A0 + 2. 3320'$canonical_pi'(PI, PI). 3321 3322'$remove_ops'([], _, []). 3323'$remove_ops'([Op|T0], Pattern, T) :- 3324 subsumes_term(Pattern, Op), 3325 !, 3326 '$remove_ops'(T0, Pattern, T). 3327'$remove_ops'([H|T0], Pattern, [H|T]) :- 3328 '$remove_ops'(T0, Pattern, T).
3333'$import_all'(Import, Context, Source, Reexport, Strength) :-
3334 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3335 ( Reexport == true,
3336 ( '$list_to_conj'(Imported, Conj)
3337 -> export(Context:Conj),
3338 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3339 ; true
3340 ),
3341 source_location(File, _Line),
3342 '$export_ops'(ImpOps, Context, File)
3343 ; true
3344 ).
3348'$import_all2'([], _, _, [], [], _). 3349'$import_all2'([PI as NewName|Rest], Context, Source, 3350 [NewName/Arity|Imported], ImpOps, Strength) :- 3351 !, 3352 '$canonical_pi'(PI, Name/Arity), 3353 length(Args, Arity), 3354 Head =.. [Name|Args], 3355 NewHead =.. [NewName|Args], 3356 ( '$get_predicate_attribute'(Source:Head, transparent, 1) 3357 -> '$set_predicate_attribute'(Context:NewHead, transparent, true) 3358 ; true 3359 ), 3360 ( source_location(File, Line) 3361 -> E = error(_,_), 3362 catch('$store_admin_clause'((NewHead :- Source:Head), 3363 _Layout, File, File:Line), 3364 E, '$print_message'(error, E)) 3365 ; assertz(( :- !, Source:Head)) % ! avoids problems with 3366 ), % duplicate load 3367 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3368'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported, 3369 [op(P,A,N)|ImpOps], Strength) :- 3370 !, 3371 '$import_ops'(Context, Source, op(P,A,N)), 3372 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3373'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :- 3374 Error = error(_,_), 3375 catch(Context:'$import'(Source:Pred, Strength), Error, 3376 print_message(error, Error)), 3377 '$ifcompiling'('$import_wic'(Source, Pred, Strength)), 3378 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength). 3379 3380 3381'$list_to_conj'([One], One) :- !. 3382'$list_to_conj'([H|T], (H,Rest)) :- 3383 '$list_to_conj'(T, Rest).
op(P,A,N)
terms representing the operators
exported from Module.3390'$exported_ops'(Module, Ops, Tail) :- 3391 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3392 !, 3393 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail). 3394'$exported_ops'(_, Ops, Ops). 3395 3396'$exported_op'(Module, P, A, N) :- 3397 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)), 3398 Module:'$exported_op'(P, A, N).
3405'$import_ops'(To, From, Pattern) :- 3406 ground(Pattern), 3407 !, 3408 Pattern = op(P,A,N), 3409 op(P,A,To:N), 3410 ( '$exported_op'(From, P, A, N) 3411 -> true 3412 ; print_message(warning, no_exported_op(From, Pattern)) 3413 ). 3414'$import_ops'(To, From, Pattern) :- 3415 ( '$exported_op'(From, Pri, Assoc, Name), 3416 Pattern = op(Pri, Assoc, Name), 3417 op(Pri, Assoc, To:Name), 3418 fail 3419 ; true 3420 ).
3428'$export_list'(Decls, Module, Ops) :- 3429 is_list(Decls), 3430 !, 3431 '$do_export_list'(Decls, Module, Ops). 3432'$export_list'(Decls, _, _) :- 3433 var(Decls), 3434 throw(error(instantiation_error, _)). 3435'$export_list'(Decls, _, _) :- 3436 throw(error(type_error(list, Decls), _)). 3437 3438'$do_export_list'([], _, []) :- !. 3439'$do_export_list'([H|T], Module, Ops) :- 3440 !, 3441 E = error(_,_), 3442 catch('$export1'(H, Module, Ops, Ops1), 3443 E, ('$print_message'(error, E), Ops = Ops1)), 3444 '$do_export_list'(T, Module, Ops1). 3445 3446'$export1'(Var, _, _, _) :- 3447 var(Var), 3448 !, 3449 throw(error(instantiation_error, _)). 3450'$export1'(Op, _, [Op|T], T) :- 3451 Op = op(_,_,_), 3452 !. 3453'$export1'(PI0, Module, Ops, Ops) :- 3454 strip_module(Module:PI0, M, PI), 3455 ( PI = (_//_) 3456 -> non_terminal(M:PI) 3457 ; true 3458 ), 3459 export(M:PI). 3460 3461'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :- 3462 E = error(_,_), 3463 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File), 3464 '$export_op'(Pri, Assoc, Name, Module, File) 3465 ), 3466 E, '$print_message'(error, E)), 3467 '$export_ops'(T, Module, File). 3468'$export_ops'([], _, _). 3469 3470'$export_op'(Pri, Assoc, Name, Module, File) :- 3471 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1) 3472 -> true 3473 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File) 3474 ), 3475 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3481'$execute_directive'(Goal, F) :- 3482 '$execute_directive_2'(Goal, F). 3483 3484'$execute_directive_2'(encoding(Encoding), _F) :- 3485 !, 3486 ( '$load_input'(_F, S) 3487 -> set_stream(S, encoding(Encoding)) 3488 ). 3489'$execute_directive_2'(Goal, _) :- 3490 \+ '$compilation_mode'(database), 3491 !, 3492 '$add_directive_wic2'(Goal, Type), 3493 ( Type == call % suspend compiling into .qlf file 3494 -> '$compilation_mode'(Old, database), 3495 setup_call_cleanup( 3496 '$directive_mode'(OldDir, Old), 3497 '$execute_directive_3'(Goal), 3498 ( '$set_compilation_mode'(Old), 3499 '$set_directive_mode'(OldDir) 3500 )) 3501 ; '$execute_directive_3'(Goal) 3502 ). 3503'$execute_directive_2'(Goal, _) :- 3504 '$execute_directive_3'(Goal). 3505 3506'$execute_directive_3'(Goal) :- 3507 '$current_source_module'(Module), 3508 '$valid_directive'(Module:Goal), 3509 !, 3510 ( '$pattr_directive'(Goal, Module) 3511 -> true 3512 ; Term = error(_,_), 3513 catch(Module:Goal, Term, '$exception_in_directive'(Term)) 3514 -> true 3515 ; '$print_message'(warning, goal_failed(directive, Module:Goal)), 3516 fail 3517 ). 3518'$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.3527:- multifile prolog:sandbox_allowed_directive/1. 3528:- multifile prolog:sandbox_allowed_clause/1. 3529:- meta_predicate '$valid_directive'( ). 3530 3531'$valid_directive'(_) :- 3532 current_prolog_flag(sandboxed_load, false), 3533 !. 3534'$valid_directive'(Goal) :- 3535 Error = error(Formal, _), 3536 catch(prolog:sandbox_allowed_directive(Goal), Error, true), 3537 !, 3538 ( var(Formal) 3539 -> true 3540 ; print_message(error, Error), 3541 fail 3542 ). 3543'$valid_directive'(Goal) :- 3544 print_message(error, 3545 error(permission_error(execute, 3546 sandboxed_directive, 3547 Goal), _)), 3548 fail. 3549 3550'$exception_in_directive'(Term) :- 3551 '$print_message'(error, Term), 3552 fail. 3553 3554% Note that the list, consult and ensure_loaded directives are already 3555% handled at compile time and therefore should not go into the 3556% intermediate code file. 3557 3558'$add_directive_wic2'(Goal, Type) :- 3559 '$common_goal_type'(Goal, Type), 3560 !, 3561 ( Type == load 3562 -> true 3563 ; '$current_source_module'(Module), 3564 '$add_directive_wic'(Module:Goal) 3565 ). 3566'$add_directive_wic2'(Goal, _) :- 3567 ( '$compilation_mode'(qlf) % no problem for qlf files 3568 -> true 3569 ; print_message(error, mixed_directive(Goal)) 3570 ). 3571 3572'$common_goal_type'((A,B), Type) :- 3573 !, 3574 '$common_goal_type'(A, Type), 3575 '$common_goal_type'(B, Type). 3576'$common_goal_type'((A;B), Type) :- 3577 !, 3578 '$common_goal_type'(A, Type), 3579 '$common_goal_type'(B, Type). 3580'$common_goal_type'((A->B), Type) :- 3581 !, 3582 '$common_goal_type'(A, Type), 3583 '$common_goal_type'(B, Type). 3584'$common_goal_type'(Goal, Type) :- 3585 '$goal_type'(Goal, Type). 3586 3587'$goal_type'(Goal, Type) :- 3588 ( '$load_goal'(Goal) 3589 -> Type = load 3590 ; Type = call 3591 ). 3592 3593'$load_goal'([_|_]). 3594'$load_goal'(consult(_)). 3595'$load_goal'(load_files(_)). 3596'$load_goal'(load_files(_,Options)) :- 3597 memberchk(qcompile(QlfMode), Options), 3598 '$qlf_part_mode'(QlfMode). 3599'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic). 3600'$load_goal'(use_module(_)) :- '$compilation_mode'(wic). 3601'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic). 3602 3603'$qlf_part_mode'(part). 3604'$qlf_part_mode'(true). % compatibility 3605 3606 3607 /******************************** 3608 * COMPILE A CLAUSE * 3609 *********************************/
3616'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :- 3617 Owner \== (-), 3618 !, 3619 setup_call_cleanup( 3620 '$start_aux'(Owner, Context), 3621 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc), 3622 '$end_aux'(Owner, Context)). 3623'$store_admin_clause'(Clause, Layout, File, SrcLoc) :- 3624 '$store_admin_clause2'(Clause, Layout, File, SrcLoc). 3625 3626'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :- 3627 ( '$compilation_mode'(database) 3628 -> '$record_clause'(Clause, File, SrcLoc) 3629 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3630 '$qlf_assert_clause'(Ref, development) 3631 ).
3641'$store_clause'((_, _), _, _, _) :- 3642 !, 3643 print_message(error, cannot_redefine_comma), 3644 fail. 3645'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :- 3646 nonvar(Pre), 3647 Pre = (Head,Cond), 3648 !, 3649 '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc). 3650'$store_clause'(Clause, _Layout, File, SrcLoc) :- 3651 '$valid_clause'(Clause), 3652 !, 3653 ( '$compilation_mode'(database) 3654 -> '$record_clause'(Clause, File, SrcLoc) 3655 ; '$record_clause'(Clause, File, SrcLoc, Ref), 3656 '$qlf_assert_clause'(Ref, development) 3657 ). 3658 3659'$valid_clause'(_) :- 3660 current_prolog_flag(sandboxed_load, false), 3661 !. 3662'$valid_clause'(Clause) :- 3663 \+ '$cross_module_clause'(Clause), 3664 !. 3665'$valid_clause'(Clause) :- 3666 Error = error(Formal, _), 3667 catch(prolog:sandbox_allowed_clause(Clause), Error, true), 3668 !, 3669 ( var(Formal) 3670 -> true 3671 ; print_message(error, Error), 3672 fail 3673 ). 3674'$valid_clause'(Clause) :- 3675 print_message(error, 3676 error(permission_error(assert, 3677 sandboxed_clause, 3678 Clause), _)), 3679 fail. 3680 3681'$cross_module_clause'(Clause) :- 3682 '$head_module'(Clause, Module), 3683 \+ '$current_source_module'(Module). 3684 3685'$head_module'(Var, _) :- 3686 var(Var), !, fail. 3687'$head_module'((Head :- _), Module) :- 3688 '$head_module'(Head, Module). 3689'$head_module'(Module:_, Module). 3690 3691'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !. 3692'$clause_source'(Clause, Clause, -).
3699:- public 3700 '$store_clause'/2. 3701 3702'$store_clause'(Term, Id) :- 3703 '$clause_source'(Term, Clause, SrcLoc), 3704 '$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)
3725compile_aux_clauses(_Clauses) :- 3726 current_prolog_flag(xref, true), 3727 !. 3728compile_aux_clauses(Clauses) :- 3729 source_location(File, _Line), 3730 '$compile_aux_clauses'(Clauses, File). 3731 3732'$compile_aux_clauses'(Clauses, File) :- 3733 setup_call_cleanup( 3734 '$start_aux'(File, Context), 3735 '$store_aux_clauses'(Clauses, File), 3736 '$end_aux'(File, Context)). 3737 3738'$store_aux_clauses'(Clauses, File) :- 3739 is_list(Clauses), 3740 !, 3741 forall('$member'(C,Clauses), 3742 '$compile_term'(C, _Layout, File)). 3743'$store_aux_clauses'(Clause, File) :- 3744 '$compile_term'(Clause, _Layout, File). 3745 3746 3747 /******************************* 3748 * STAGING * 3749 *******************************/
3759'$stage_file'(Target, Stage) :- 3760 file_directory_name(Target, Dir), 3761 file_base_name(Target, File), 3762 current_prolog_flag(pid, Pid), 3763 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]). 3764 3765'$install_staged_file'(exit, Staged, Target, error) :- 3766 !, 3767 rename_file(Staged, Target). 3768'$install_staged_file'(exit, Staged, Target, OnError) :- 3769 !, 3770 InstallError = error(_,_), 3771 catch(rename_file(Staged, Target), 3772 InstallError, 3773 '$install_staged_error'(OnError, InstallError, Staged, Target)). 3774'$install_staged_file'(_, Staged, _, _OnError) :- 3775 E = error(_,_), 3776 catch(delete_file(Staged), E, true). 3777 3778'$install_staged_error'(OnError, Error, Staged, _Target) :- 3779 E = error(_,_), 3780 catch(delete_file(Staged), E, true), 3781 ( OnError = silent 3782 -> true 3783 ; OnError = fail 3784 -> fail 3785 ; print_message(warning, Error) 3786 ). 3787 3788 3789 /******************************* 3790 * READING * 3791 *******************************/ 3792 3793:- multifile 3794 prolog:comment_hook/3. % hook for read_clause/3 3795 3796 3797 /******************************* 3798 * FOREIGN INTERFACE * 3799 *******************************/ 3800 3801% call-back from PL_register_foreign(). First argument is the module 3802% into which the foreign predicate is loaded and second is a term 3803% describing the arguments. 3804 3805:- dynamic 3806 '$foreign_registered'/2. 3807 3808 /******************************* 3809 * TEMPORARY TERM EXPANSION * 3810 *******************************/ 3811 3812% Provide temporary definitions for the boot-loader. These are replaced 3813% by the real thing in load.pl 3814 3815:- dynamic 3816 '$expand_goal'/2, 3817 '$expand_term'/4. 3818 3819'$expand_goal'(In, In). 3820'$expand_term'(In, Layout, In, Layout). 3821 3822 3823 /******************************* 3824 * TYPE SUPPORT * 3825 *******************************/ 3826 3827'$type_error'(Type, Value) :- 3828 ( var(Value) 3829 -> throw(error(instantiation_error, _)) 3830 ; throw(error(type_error(Type, Value), _)) 3831 ). 3832 3833'$domain_error'(Type, Value) :- 3834 throw(error(domain_error(Type, Value), _)). 3835 3836'$existence_error'(Type, Object) :- 3837 throw(error(existence_error(Type, Object), _)). 3838 3839'$permission_error'(Action, Type, Term) :- 3840 throw(error(permission_error(Action, Type, Term), _)). 3841 3842'$instantiation_error'(_Var) :- 3843 throw(error(instantiation_error, _)). 3844 3845'$uninstantiation_error'(NonVar) :- 3846 throw(error(uninstantiation_error(NonVar), _)). 3847 3848'$must_be'(list, X) :- !, 3849 '$skip_list'(_, X, Tail), 3850 ( Tail == [] 3851 -> true 3852 ; '$type_error'(list, Tail) 3853 ). 3854'$must_be'(options, X) :- !, 3855 ( '$is_options'(X) 3856 -> true 3857 ; '$type_error'(options, X) 3858 ). 3859'$must_be'(atom, X) :- !, 3860 ( atom(X) 3861 -> true 3862 ; '$type_error'(atom, X) 3863 ). 3864'$must_be'(integer, X) :- !, 3865 ( integer(X) 3866 -> true 3867 ; '$type_error'(integer, X) 3868 ). 3869'$must_be'(between(Low,High), X) :- !, 3870 ( integer(X) 3871 -> ( between(Low, High, X) 3872 -> true 3873 ; '$domain_error'(between(Low,High), X) 3874 ) 3875 ; '$type_error'(integer, X) 3876 ). 3877'$must_be'(callable, X) :- !, 3878 ( callable(X) 3879 -> true 3880 ; '$type_error'(callable, X) 3881 ). 3882'$must_be'(acyclic, X) :- !, 3883 ( acyclic_term(X) 3884 -> true 3885 ; '$domain_error'(acyclic_term, X) 3886 ). 3887'$must_be'(oneof(Type, Domain, List), X) :- !, 3888 '$must_be'(Type, X), 3889 ( memberchk(X, List) 3890 -> true 3891 ; '$domain_error'(Domain, X) 3892 ). 3893'$must_be'(boolean, X) :- !, 3894 ( (X == true ; X == false) 3895 -> true 3896 ; '$type_error'(boolean, X) 3897 ). 3898'$must_be'(ground, X) :- !, 3899 ( ground(X) 3900 -> true 3901 ; '$instantiation_error'(X) 3902 ). 3903'$must_be'(filespec, X) :- !, 3904 ( ( atom(X) 3905 ; string(X) 3906 ; compound(X), 3907 compound_name_arity(X, _, 1) 3908 ) 3909 -> true 3910 ; '$type_error'(filespec, X) 3911 ). 3912 3913% Use for debugging 3914%'$must_be'(Type, _X) :- format('Unknown $must_be type: ~q~n', [Type]). 3915 3916 3917 /******************************** 3918 * LIST PROCESSING * 3919 *********************************/ 3920 3921'$member'(El, [H|T]) :- 3922 '$member_'(T, El, H). 3923 3924'$member_'(_, El, El). 3925'$member_'([H|T], El, _) :- 3926 '$member_'(T, El, H). 3927 3928 3929'$append'([], L, L). 3930'$append'([H|T], L, [H|R]) :- 3931 '$append'(T, L, R). 3932 3933'$select'(X, [X|Tail], Tail). 3934'$select'(Elem, [Head|Tail], [Head|Rest]) :- 3935 '$select'(Elem, Tail, Rest). 3936 3937'$reverse'(L1, L2) :- 3938 '$reverse'(L1, [], L2). 3939 3940'$reverse'([], List, List). 3941'$reverse'([Head|List1], List2, List3) :- 3942 '$reverse'(List1, [Head|List2], List3). 3943 3944'$delete'([], _, []) :- !. 3945'$delete'([Elem|Tail], Elem, Result) :- 3946 !, 3947 '$delete'(Tail, Elem, Result). 3948'$delete'([Head|Tail], Elem, [Head|Rest]) :- 3949 '$delete'(Tail, Elem, Rest). 3950 3951'$last'([H|T], Last) :- 3952 '$last'(T, H, Last). 3953 3954'$last'([], Last, Last). 3955'$last'([H|T], _, Last) :- 3956 '$last'(T, H, Last).
3963:- '$iso'((length/2)). 3964 3965length(List, Length) :- 3966 var(Length), 3967 !, 3968 '$skip_list'(Length0, List, Tail), 3969 ( Tail == [] 3970 -> Length = Length0 % +,- 3971 ; var(Tail) 3972 -> Tail \== Length, % avoid length(L,L) 3973 '$length3'(Tail, Length, Length0) % -,- 3974 ; throw(error(type_error(list, List), 3975 context(length/2, _))) 3976 ). 3977length(List, Length) :- 3978 integer(Length), 3979 Length >= 0, 3980 !, 3981 '$skip_list'(Length0, List, Tail), 3982 ( Tail == [] % proper list 3983 -> Length = Length0 3984 ; var(Tail) 3985 -> Extra is Length-Length0, 3986 '$length'(Tail, Extra) 3987 ; throw(error(type_error(list, List), 3988 context(length/2, _))) 3989 ). 3990length(_, Length) :- 3991 integer(Length), 3992 !, 3993 throw(error(domain_error(not_less_than_zero, Length), 3994 context(length/2, _))). 3995length(_, Length) :- 3996 throw(error(type_error(integer, Length), 3997 context(length/2, _))). 3998 3999'$length3'([], N, N). 4000'$length3'([_|List], N, N0) :- 4001 N1 is N0+1, 4002 '$length3'(List, N, N1). 4003 4004 4005 /******************************* 4006 * OPTION PROCESSING * 4007 *******************************/
4013'$is_options'(Map) :- 4014 is_dict(Map, _), 4015 !. 4016'$is_options'(List) :- 4017 is_list(List), 4018 ( List == [] 4019 -> true 4020 ; List = [H|_], 4021 '$is_option'(H, _, _) 4022 ). 4023 4024'$is_option'(Var, _, _) :- 4025 var(Var), !, fail. 4026'$is_option'(F, Name, Value) :- 4027 functor(F, _, 1), 4028 !, 4029 F =.. [Name,Value]. 4030'$is_option'(Name=Value, Name, Value).
4034'$option'(Opt, Options) :- 4035 is_dict(Options), 4036 !, 4037 [Opt] :< Options. 4038'$option'(Opt, Options) :- 4039 memberchk(Opt, Options).
4043'$option'(Term, Options, Default) :-
4044 arg(1, Term, Value),
4045 functor(Term, Name, 1),
4046 ( is_dict(Options)
4047 -> ( get_dict(Name, Options, GVal)
4048 -> Value = GVal
4049 ; Value = Default
4050 )
4051 ; functor(Gen, Name, 1),
4052 arg(1, Gen, GVal),
4053 ( memberchk(Gen, Options)
4054 -> Value = GVal
4055 ; Value = Default
4056 )
4057 ).
4065'$select_option'(Opt, Options, Rest) :-
4066 select_dict([Opt], Options, Rest).
4074'$merge_options'(New, Old, Merged) :- 4075 put_dict(New, Old, Merged). 4076 4077 4078 /******************************* 4079 * HANDLE TRACER 'L'-COMMAND * 4080 *******************************/ 4081 4082:- public '$prolog_list_goal'/1. 4083 4084:- multifile 4085 user:prolog_list_goal/1. 4086 4087'$prolog_list_goal'(Goal) :- 4088 user:prolog_list_goal(Goal), 4089 !. 4090'$prolog_list_goal'(Goal) :- 4091 use_module(library(listing), [listing/1]), 4092 @(listing(Goal), user). 4093 4094 4095 /******************************* 4096 * HALT * 4097 *******************************/ 4098 4099:- '$iso'((halt/0)). 4100 4101halt :- 4102 halt(0).
4111:- meta_predicate at_halt( ). 4112:- dynamic system:term_expansion/2, '$at_halt'/2. 4113:- multifile system:term_expansion/2, '$at_halt'/2. 4114 4115systemterm_expansion((:- at_halt(Goal)), 4116 system:'$at_halt'(Module:Goal, File:Line)) :- 4117 \+ current_prolog_flag(xref, true), 4118 source_location(File, Line), 4119 '$current_source_module'(Module). 4120 4121at_halt(Goal) :- 4122 asserta('$at_halt'(Goal, (-):0)). 4123 4124:- public '$run_at_halt'/0. 4125 4126'$run_at_halt' :- 4127 forall(clause('$at_halt'(Goal, Src), true, Ref), 4128 ( '$call_at_halt'(Goal, Src), 4129 erase(Ref) 4130 )). 4131 4132'$call_at_halt'(Goal, _Src) :- 4133 catch(Goal, E, true), 4134 !, 4135 ( var(E) 4136 -> true 4137 ; subsumes_term(cancel_halt(_), E) 4138 -> '$print_message'(informational, E), 4139 fail 4140 ; '$print_message'(error, E) 4141 ). 4142'$call_at_halt'(Goal, _Src) :- 4143 '$print_message'(warning, goal_failed(at_halt, Goal)).
4151cancel_halt(Reason) :- 4152 throw(cancel_halt(Reason)). 4153 4154 4155 /******************************** 4156 * LOAD OTHER MODULES * 4157 *********************************/ 4158 4159:- meta_predicate 4160 '$load_wic_files'( ). 4161 4162'$load_wic_files'(Files) :- 4163 Files = Module:_, 4164 '$execute_directive'('$set_source_module'(OldM, Module), []), 4165 '$save_lex_state'(LexState, []), 4166 '$style_check'(_, 0xC7), % see style_name/2 in syspred.pl 4167 '$compilation_mode'(OldC, wic), 4168 consult(Files), 4169 '$execute_directive'('$set_source_module'(OldM), []), 4170 '$execute_directive'('$restore_lex_state'(LexState), []), 4171 '$set_compilation_mode'(OldC).
compileFileList()
in pl-wic.c. Gets the files from
"-c file ..." and loads them into the module user.4179:- public '$load_additional_boot_files'/0. 4180 4181'$load_additional_boot_files' :- 4182 current_prolog_flag(argv, Argv), 4183 '$get_files_argv'(Argv, Files), 4184 ( Files \== [] 4185 -> format('Loading additional boot files~n'), 4186 '$load_wic_files'(user:Files), 4187 format('additional boot files loaded~n') 4188 ; true 4189 ). 4190 4191'$get_files_argv'([], []) :- !. 4192'$get_files_argv'(['-c'|Files], Files) :- !. 4193'$get_files_argv'([_|Rest], Files) :- 4194 '$get_files_argv'(Rest, Files). 4195 4196'$:-'(('$boot_message'('Loading Prolog startup files~n', []), 4197 source_location(File, _Line), 4198 file_directory_name(File, Dir), 4199 atom_concat(Dir, '/load.pl', LoadFile), 4200 '$load_wic_files'(system:[LoadFile]), 4201 ( current_prolog_flag(windows, true) 4202 -> atom_concat(Dir, '/menu.pl', MenuFile), 4203 '$load_wic_files'(system:[MenuFile]) 4204 ; true 4205 ), 4206 '$boot_message'('SWI-Prolog boot files loaded~n', []), 4207 '$compilation_mode'(OldC, wic), 4208 '$execute_directive'('$set_source_module'(user), []), 4209 '$set_compilation_mode'(OldC) 4210 ))