35
50
51'$:-'(format('Loading boot file ...~n', [])).
52
53 56
57:- '$set_source_module'(system). 58
59 62
63:- meta_predicate
64 dynamic(:),
65 multifile(:),
66 public(:),
67 module_transparent(:),
68 discontiguous(:),
69 volatile(:),
70 thread_local(:),
71 noprofile(:),
72 '$clausable'(:),
73 '$iso'(:),
74 '$hide'(:). 75
88
89dynamic(Spec) :- '$set_pattr'(Spec, pred, (dynamic)).
90multifile(Spec) :- '$set_pattr'(Spec, pred, (multifile)).
91module_transparent(Spec) :- '$set_pattr'(Spec, pred, (transparent)).
92discontiguous(Spec) :- '$set_pattr'(Spec, pred, (discontiguous)).
93volatile(Spec) :- '$set_pattr'(Spec, pred, (volatile)).
94thread_local(Spec) :- '$set_pattr'(Spec, pred, (thread_local)).
95noprofile(Spec) :- '$set_pattr'(Spec, pred, (noprofile)).
96public(Spec) :- '$set_pattr'(Spec, pred, (public)).
97'$iso'(Spec) :- '$set_pattr'(Spec, pred, (iso)).
98'$clausable'(Spec) :- '$set_pattr'(Spec, pred, (clausable)).
99
100'$set_pattr'(M:Pred, How, Attr) :-
101 '$set_pattr'(Pred, M, How, Attr).
102
103'$set_pattr'(X, _, _, _) :-
104 var(X),
105 throw(error(instantiation_error, _)).
106'$set_pattr'([], _, _, _) :- !.
107'$set_pattr'([H|T], M, How, Attr) :- 108 !,
109 '$set_pattr'(H, M, How, Attr),
110 '$set_pattr'(T, M, How, Attr).
111'$set_pattr'((A,B), M, How, Attr) :- 112 !,
113 '$set_pattr'(A, M, How, Attr),
114 '$set_pattr'(B, M, How, Attr).
115'$set_pattr'(M:T, _, How, Attr) :-
116 !,
117 '$set_pattr'(T, M, How, Attr).
118'$set_pattr'(A, M, pred, Attr) :-
119 !,
120 '$set_predicate_attribute'(M:A, Attr, true).
121'$set_pattr'(A, M, directive, Attr) :-
122 !,
123 catch('$set_predicate_attribute'(M:A, Attr, true),
124 error(E, _),
125 print_message(error, error(E, context((Attr)/1,_)))).
126
133
134'$pattr_directive'(dynamic(Spec), M) :-
135 '$set_pattr'(Spec, M, directive, (dynamic)).
136'$pattr_directive'(multifile(Spec), M) :-
137 '$set_pattr'(Spec, M, directive, (multifile)).
138'$pattr_directive'(module_transparent(Spec), M) :-
139 '$set_pattr'(Spec, M, directive, (transparent)).
140'$pattr_directive'(discontiguous(Spec), M) :-
141 '$set_pattr'(Spec, M, directive, (discontiguous)).
142'$pattr_directive'(volatile(Spec), M) :-
143 '$set_pattr'(Spec, M, directive, (volatile)).
144'$pattr_directive'(thread_local(Spec), M) :-
145 '$set_pattr'(Spec, M, directive, (thread_local)).
146'$pattr_directive'(noprofile(Spec), M) :-
147 '$set_pattr'(Spec, M, directive, (noprofile)).
148'$pattr_directive'(public(Spec), M) :-
149 '$set_pattr'(Spec, M, directive, (public)).
150
151
155
156'$hide'(Pred) :-
157 '$set_predicate_attribute'(Pred, trace, false).
158
159
160 163
164:- noprofile((call/1,
165 catch/3,
166 once/1,
167 ignore/1,
168 call_cleanup/2,
169 call_cleanup/3,
170 setup_call_cleanup/3,
171 setup_call_catcher_cleanup/4)). 172
173:- meta_predicate
174 ';'(0,0),
175 ','(0,0),
176 @(0,+),
177 call(0),
178 call(1,?),
179 call(2,?,?),
180 call(3,?,?,?),
181 call(4,?,?,?,?),
182 call(5,?,?,?,?,?),
183 call(6,?,?,?,?,?,?),
184 call(7,?,?,?,?,?,?,?),
185 not(0),
186 \+(0),
187 '->'(0,0),
188 '*->'(0,0),
189 once(0),
190 ignore(0),
191 catch(0,?,0),
192 reset(0,-,?),
193 setup_call_cleanup(0,0,0),
194 setup_call_catcher_cleanup(0,0,?,0),
195 call_cleanup(0,0),
196 call_cleanup(0,?,0),
197 '$meta_call'(0). 198
199:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 200
208
209(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
210(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)).
211(G1 , G2) :- call((G1 , G2)).
212(If -> Then) :- call((If -> Then)).
213(If *-> Then) :- call((If *-> Then)).
214@(Goal,Module) :- @(Goal,Module).
215
227
228'$meta_call'(M:G) :-
229 prolog_current_choice(Ch),
230 '$meta_call'(G, M, Ch).
231
232'$meta_call'(Var, _, _) :-
233 var(Var),
234 !,
235 '$instantiation_error'(Var).
236'$meta_call'((A,B), M, Ch) :-
237 !,
238 '$meta_call'(A, M, Ch),
239 '$meta_call'(B, M, Ch).
240'$meta_call'((I->T;E), M, Ch) :-
241 !,
242 ( prolog_current_choice(Ch2),
243 '$meta_call'(I, M, Ch2)
244 -> '$meta_call'(T, M, Ch)
245 ; '$meta_call'(E, M, Ch)
246 ).
247'$meta_call'((I*->T;E), M, Ch) :-
248 !,
249 ( prolog_current_choice(Ch2),
250 '$meta_call'(I, M, Ch2)
251 *-> '$meta_call'(T, M, Ch)
252 ; '$meta_call'(E, M, Ch)
253 ).
254'$meta_call'((I->T), M, Ch) :-
255 !,
256 ( prolog_current_choice(Ch2),
257 '$meta_call'(I, M, Ch2)
258 -> '$meta_call'(T, M, Ch)
259 ).
260'$meta_call'((I*->T), M, Ch) :-
261 !,
262 prolog_current_choice(Ch2),
263 '$meta_call'(I, M, Ch2),
264 '$meta_call'(T, M, Ch).
265'$meta_call'((A;B), M, Ch) :-
266 !,
267 ( '$meta_call'(A, M, Ch)
268 ; '$meta_call'(B, M, Ch)
269 ).
270'$meta_call'(\+(G), M, _) :-
271 !,
272 prolog_current_choice(Ch),
273 \+ '$meta_call'(G, M, Ch).
274'$meta_call'(call(G), M, _) :-
275 !,
276 prolog_current_choice(Ch),
277 '$meta_call'(G, M, Ch).
278'$meta_call'(M:G, _, Ch) :-
279 !,
280 '$meta_call'(G, M, Ch).
281'$meta_call'(!, _, Ch) :-
282 prolog_cut_to(Ch).
283'$meta_call'(G, M, _Ch) :-
284 call(M:G).
285
299
300:- '$iso'((call/2,
301 call/3,
302 call/4,
303 call/5,
304 call/6,
305 call/7,
306 call/8)). 307
308call(Goal) :- 309 Goal.
310call(Goal, A) :-
311 call(Goal, A).
312call(Goal, A, B) :-
313 call(Goal, A, B).
314call(Goal, A, B, C) :-
315 call(Goal, A, B, C).
316call(Goal, A, B, C, D) :-
317 call(Goal, A, B, C, D).
318call(Goal, A, B, C, D, E) :-
319 call(Goal, A, B, C, D, E).
320call(Goal, A, B, C, D, E, F) :-
321 call(Goal, A, B, C, D, E, F).
322call(Goal, A, B, C, D, E, F, G) :-
323 call(Goal, A, B, C, D, E, F, G).
324
329
330not(Goal) :-
331 \+ Goal.
332
336
337\+ Goal :-
338 \+ Goal.
339
343
344once(Goal) :-
345 Goal,
346 !.
347
352
353ignore(Goal) :-
354 Goal,
355 !.
356ignore(_Goal).
357
358:- '$iso'((false/0)). 359
363
364false :-
365 fail.
366
370
371catch(_Goal, _Catcher, _Recover) :-
372 '$catch'. 373
377
378prolog_cut_to(_Choice) :-
379 '$cut'. 380
384
385reset(_Goal, _Ball, _Cont) :-
386 '$reset'.
387
391
392shift(Ball) :-
393 '$shift'(Ball).
394
406
407call_continuation([]).
408call_continuation([TB|Rest]) :-
409 ( Rest == []
410 -> '$call_continuation'(TB)
411 ; '$call_continuation'(TB),
412 call_continuation(Rest)
413 ).
414
415
423
424:- public '$recover_and_rethrow'/2. 425
426'$recover_and_rethrow'(Goal, Exception) :-
427 call_cleanup(Goal, throw(Exception)),
428 !.
429
430
442
443setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
444 '$sig_atomic'(Setup),
445 '$call_cleanup'.
446
447setup_call_cleanup(Setup, Goal, Cleanup) :-
448 setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
449
450call_cleanup(Goal, Cleanup) :-
451 setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
452
453call_cleanup(Goal, Catcher, Cleanup) :-
454 setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
455
456 459
460:- meta_predicate
461 initialization(0, +). 462
463:- multifile '$init_goal'/3. 464:- dynamic '$init_goal'/3. 465
480
481initialization(Goal, When) :-
482 '$must_be'(oneof(atom, initialization_type,
483 [ now,
484 after_load,
485 restore,
486 program,
487 main
488 ]), When),
489 '$initialization_context'(Source, Ctx),
490 '$initialization'(When, Goal, Source, Ctx).
491
492'$initialization'(now, Goal, _Source, Ctx) :-
493 '$run_init_goal'(Goal, Ctx),
494 '$compile_init_goal'(-, Goal, Ctx).
495'$initialization'(after_load, Goal, Source, Ctx) :-
496 ( Source \== (-)
497 -> '$compile_init_goal'(Source, Goal, Ctx)
498 ; throw(error(context_error(nodirective,
499 initialization(Goal, after_load)),
500 _))
501 ).
502'$initialization'(restore, Goal, _Source, Ctx) :-
503 ( \+ current_prolog_flag(sandboxed_load, true)
504 -> '$compile_init_goal'(-, Goal, Ctx)
505 ; '$permission_error'(register, initialization(restore), Goal)
506 ).
507'$initialization'(program, Goal, _Source, Ctx) :-
508 ( \+ current_prolog_flag(sandboxed_load, true)
509 -> '$compile_init_goal'(when(program), Goal, Ctx)
510 ; '$permission_error'(register, initialization(restore), Goal)
511 ).
512'$initialization'(main, Goal, _Source, Ctx) :-
513 ( \+ current_prolog_flag(sandboxed_load, true)
514 -> '$compile_init_goal'(when(main), Goal, Ctx)
515 ; '$permission_error'(register, initialization(restore), Goal)
516 ).
517
518
519'$compile_init_goal'(Source, Goal, Ctx) :-
520 atom(Source),
521 Source \== (-),
522 !,
523 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
524 _Layout, Source, Ctx).
525'$compile_init_goal'(Source, Goal, Ctx) :-
526 assertz('$init_goal'(Source, Goal, Ctx)).
527
528
537
538'$run_initialization'(_, loaded, _) :- !.
539'$run_initialization'(File, _Action, Options) :-
540 '$run_initialization'(File, Options).
541
542'$run_initialization'(File, Options) :-
543 setup_call_cleanup(
544 '$start_run_initialization'(Options, Restore),
545 '$run_initialization_2'(File),
546 '$end_run_initialization'(Restore)).
547
548'$start_run_initialization'(Options, OldSandBoxed) :-
549 '$push_input_context'(initialization),
550 '$set_sandboxed_load'(Options, OldSandBoxed).
551'$end_run_initialization'(OldSandBoxed) :-
552 set_prolog_flag(sandboxed_load, OldSandBoxed),
553 '$pop_input_context'.
554
555'$run_initialization_2'(File) :-
556 ( '$init_goal'(File, Goal, Ctx),
557 File \= when(_),
558 '$run_init_goal'(Goal, Ctx),
559 fail
560 ; true
561 ).
562
563'$run_init_goal'(Goal, Ctx) :-
564 ( catch('$run_init_goal'(Goal), E,
565 '$initialization_error'(E, Goal, Ctx))
566 -> true
567 ; '$initialization_failure'(Goal, Ctx)
568 ).
569
570:- multifile prolog:sandbox_allowed_goal/1. 571
572'$run_init_goal'(Goal) :-
573 current_prolog_flag(sandboxed_load, false),
574 !,
575 call(Goal).
576'$run_init_goal'(Goal) :-
577 prolog:sandbox_allowed_goal(Goal),
578 call(Goal).
579
580'$initialization_context'(Source, Ctx) :-
581 ( source_location(File, Line)
582 -> Ctx = File:Line,
583 '$input_context'(Context),
584 '$top_file'(Context, File, Source)
585 ; Ctx = (-),
586 File = (-)
587 ).
588
589'$top_file'([input(include, F1, _, _)|T], _, F) :-
590 !,
591 '$top_file'(T, F1, F).
592'$top_file'(_, F, F).
593
594
595'$initialization_error'(E, Goal, Ctx) :-
596 print_message(error, initialization_error(Goal, E, Ctx)).
597
598'$initialization_failure'(Goal, Ctx) :-
599 print_message(warning, initialization_failure(Goal, Ctx)).
600
606
607:- public '$clear_source_admin'/1. 608
609'$clear_source_admin'(File) :-
610 retractall('$init_goal'(_, _, File:_)),
611 retractall('$load_context_module'(File, _, _)).
612
613
614 617
618:- '$iso'(stream_property/2). 619stream_property(Stream, Property) :-
620 nonvar(Stream),
621 nonvar(Property),
622 !,
623 '$stream_property'(Stream, Property).
624stream_property(Stream, Property) :-
625 nonvar(Stream),
626 !,
627 '$stream_properties'(Stream, Properties),
628 '$member'(Property, Properties).
629stream_property(Stream, Property) :-
630 nonvar(Property),
631 !,
632 ( Property = alias(Alias),
633 atom(Alias)
634 -> '$alias_stream'(Alias, Stream)
635 ; '$streams_properties'(Property, Pairs),
636 '$member'(Stream-Property, Pairs)
637 ).
638stream_property(Stream, Property) :-
639 '$streams_properties'(Property, Pairs),
640 '$member'(Stream-Properties, Pairs),
641 '$member'(Property, Properties).
642
643
644 647
650
651'$prefix_module'(Module, Module, Head, Head) :- !.
652'$prefix_module'(Module, _, Head, Module:Head).
653
657
658default_module(Me, Super) :-
659 ( atom(Me)
660 -> ( var(Super)
661 -> '$default_module'(Me, Super)
662 ; '$default_module'(Me, Super), !
663 )
664 ; '$type_error'(module, Me)
665 ).
666
667'$default_module'(Me, Me).
668'$default_module'(Me, Super) :-
669 import_module(Me, S),
670 '$default_module'(S, Super).
671
672
673 676
677:- user:dynamic((exception/3,
678 prolog_event_hook/1)). 679:- user:multifile((exception/3,
680 prolog_event_hook/1)). 681
688
689:- public
690 '$undefined_procedure'/4. 691
692'$undefined_procedure'(Module, Name, Arity, Action) :-
693 '$prefix_module'(Module, user, Name/Arity, Pred),
694 user:exception(undefined_predicate, Pred, Action0),
695 !,
696 Action = Action0.
697'$undefined_procedure'(Module, Name, Arity, Action) :-
698 current_prolog_flag(autoload, true),
699 '$autoload'(Module, Name, Arity),
700 !,
701 Action = retry.
702'$undefined_procedure'(_, _, _, error).
703
704'$autoload'(Module, Name, Arity) :-
705 source_location(File, _Line),
706 !,
707 setup_call_cleanup(
708 '$start_aux'(File, Context),
709 '$autoload2'(Module, Name, Arity),
710 '$end_aux'(File, Context)).
711'$autoload'(Module, Name, Arity) :-
712 '$autoload2'(Module, Name, Arity).
713
714'$autoload2'(Module, Name, Arity) :-
715 '$find_library'(Module, Name, Arity, LoadModule, Library),
716 functor(Head, Name, Arity),
717 '$update_autoload_level'([autoload(true)], Old),
718 ( current_prolog_flag(verbose_autoload, true)
719 -> Level = informational
720 ; Level = silent
721 ),
722 print_message(Level, autoload(Module:Name/Arity, Library)),
723 '$compilation_mode'(OldComp, database),
724 ( Module == LoadModule
725 -> ensure_loaded(Module:Library)
726 ; ( '$get_predicate_attribute'(LoadModule:Head, defined, 1),
727 \+ '$loading'(Library)
728 -> Module:import(LoadModule:Name/Arity)
729 ; use_module(Module:Library, [Name/Arity])
730 )
731 ),
732 '$set_compilation_mode'(OldComp),
733 '$set_autoload_level'(Old),
734 '$c_current_predicate'(_, Module:Head).
735
744
745'$loading'(Library) :-
746 current_prolog_flag(threads, true),
747 '$loading_file'(FullFile, _Queue, _LoadThread),
748 file_name_extension(Library, _, FullFile),
749 !.
750
752
753'$set_debugger_write_options'(write) :-
754 !,
755 create_prolog_flag(debugger_write_options,
756 [ quoted(true),
757 attributes(dots),
758 spacing(next_argument)
759 ], []).
760'$set_debugger_write_options'(print) :-
761 !,
762 create_prolog_flag(debugger_write_options,
763 [ quoted(true),
764 portray(true),
765 max_depth(10),
766 attributes(portray),
767 spacing(next_argument)
768 ], []).
769'$set_debugger_write_options'(Depth) :-
770 current_prolog_flag(debugger_write_options, Options0),
771 ( '$select'(max_depth(_), Options0, Options)
772 -> true
773 ; Options = Options0
774 ),
775 create_prolog_flag(debugger_write_options,
776 [max_depth(Depth)|Options], []).
777
778
779 782
787
788'$confirm'(Spec) :-
789 print_message(query, Spec),
790 between(0, 5, _),
791 get_single_char(Answer),
792 ( '$in_reply'(Answer, 'yYjJ \n')
793 -> !,
794 print_message(query, if_tty([yes-[]]))
795 ; '$in_reply'(Answer, 'nN')
796 -> !,
797 print_message(query, if_tty([no-[]])),
798 fail
799 ; print_message(help, query(confirm)),
800 fail
801 ).
802
803'$in_reply'(Code, Atom) :-
804 char_code(Char, Code),
805 sub_atom(Atom, _, _, _, Char),
806 !.
807
808:- dynamic
809 user:portray/1. 810:- multifile
811 user:portray/1. 812
813
814 817
818:- dynamic user:file_search_path/2. 819:- multifile user:file_search_path/2. 820
821user:(file_search_path(library, Dir) :-
822 library_directory(Dir)).
823user:file_search_path(swi, Home) :-
824 current_prolog_flag(home, Home).
825user:file_search_path(foreign, swi(ArchLib)) :-
826 current_prolog_flag(arch, Arch),
827 atom_concat('lib/', Arch, ArchLib).
828user:file_search_path(foreign, swi(SoLib)) :-
829 ( current_prolog_flag(windows, true)
830 -> SoLib = bin
831 ; SoLib = lib
832 ).
833user:file_search_path(path, Dir) :-
834 getenv('PATH', Path),
835 ( current_prolog_flag(windows, true)
836 -> atomic_list_concat(Dirs, (;), Path)
837 ; atomic_list_concat(Dirs, :, Path)
838 ),
839 '$member'(Dir, Dirs),
840 '$no-null-bytes'(Dir).
841
842'$no-null-bytes'(Dir) :-
843 sub_atom(Dir, _, _, _, '\u0000'),
844 !,
845 print_message(warning, null_byte_in_path(Dir)),
846 fail.
847'$no-null-bytes'(_).
848
854
855expand_file_search_path(Spec, Expanded) :-
856 catch('$expand_file_search_path'(Spec, Expanded, 0, []),
857 loop(Used),
858 throw(error(loop_error(Spec), file_search(Used)))).
859
860'$expand_file_search_path'(Spec, Expanded, N, Used) :-
861 functor(Spec, Alias, 1),
862 !,
863 user:file_search_path(Alias, Exp0),
864 NN is N + 1,
865 ( NN > 16
866 -> throw(loop(Used))
867 ; true
868 ),
869 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
870 arg(1, Spec, Segments),
871 '$segments_to_atom'(Segments, File),
872 '$make_path'(Exp1, File, Expanded).
873'$expand_file_search_path'(Spec, Path, _, _) :-
874 '$segments_to_atom'(Spec, Path).
875
876'$make_path'(Dir, File, Path) :-
877 atom_concat(_, /, Dir),
878 !,
879 atom_concat(Dir, File, Path).
880'$make_path'(Dir, File, Path) :-
881 atomic_list_concat([Dir, /, File], Path).
882
883
884 887
896
897absolute_file_name(Spec, Options, Path) :-
898 '$is_options'(Options),
899 \+ '$is_options'(Path),
900 !,
901 absolute_file_name(Spec, Path, Options).
902absolute_file_name(Spec, Path, Options) :-
903 '$must_be'(options, Options),
904 905 ( '$select_option'(extensions(Exts), Options, Options1)
906 -> '$must_be'(list, Exts)
907 ; '$option'(file_type(Type), Options)
908 -> '$must_be'(atom, Type),
909 '$file_type_extensions'(Type, Exts),
910 Options1 = Options
911 ; Options1 = Options,
912 Exts = ['']
913 ),
914 '$canonicalise_extensions'(Exts, Extensions),
915 916 ( nonvar(Type)
917 -> Options2 = Options1
918 ; '$merge_options'(_{file_type:regular}, Options1, Options2)
919 ),
920 921 ( '$select_option'(solutions(Sols), Options2, Options3)
922 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols)
923 ; Sols = first,
924 Options3 = Options2
925 ),
926 927 ( '$select_option'(file_errors(FileErrors), Options3, Options4)
928 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
929 ; FileErrors = error,
930 Options4 = Options3
931 ),
932 933 ( atomic(Spec),
934 '$select_option'(expand(Expand), Options4, Options5),
935 '$must_be'(boolean, Expand)
936 -> expand_file_name(Spec, List),
937 '$member'(Spec1, List)
938 ; Spec1 = Spec,
939 Options5 = Options4
940 ),
941 942 ( Sols == first
943 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path)
944 -> ! 945 ; ( FileErrors == fail
946 -> fail
947 ; findall(P,
948 '$chk_file'(Spec1, Extensions, [access(exist)],
949 false, P),
950 Candidates),
951 '$abs_file_error'(Spec, Candidates, Options5)
952 )
953 )
954 ; '$chk_file'(Spec1, Extensions, Options5, false, Path)
955 ).
956
957'$abs_file_error'(Spec, Candidates, Conditions) :-
958 '$member'(F, Candidates),
959 '$member'(C, Conditions),
960 '$file_condition'(C),
961 '$file_error'(C, Spec, F, E, Comment),
962 !,
963 throw(error(E, context(_, Comment))).
964'$abs_file_error'(Spec, _, _) :-
965 '$existence_error'(source_sink, Spec).
966
967'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
968 \+ exists_directory(File),
969 !,
970 Error = existence_error(directory, Spec),
971 Comment = not_a_directory(File).
972'$file_error'(file_type(_), Spec, File, Error, Comment) :-
973 exists_directory(File),
974 !,
975 Error = existence_error(file, Spec),
976 Comment = directory(File).
977'$file_error'(access(OneOrList), Spec, File, Error, _) :-
978 '$one_or_member'(Access, OneOrList),
979 \+ access_file(File, Access),
980 Error = permission_error(Access, source_sink, Spec).
981
982'$one_or_member'(Elem, List) :-
983 is_list(List),
984 !,
985 '$member'(Elem, List).
986'$one_or_member'(Elem, Elem).
987
988
989'$file_type_extensions'(source, Exts) :- 990 !,
991 '$file_type_extensions'(prolog, Exts).
992'$file_type_extensions'(Type, Exts) :-
993 '$current_module'('$bags', _File),
994 !,
995 findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
996 ( Exts0 == [],
997 \+ '$ft_no_ext'(Type)
998 -> '$domain_error'(file_type, Type)
999 ; true
1000 ),
1001 '$append'(Exts0, [''], Exts).
1002'$file_type_extensions'(prolog, [pl, '']). 1003
1004'$ft_no_ext'(txt).
1005'$ft_no_ext'(executable).
1006'$ft_no_ext'(directory).
1007
1018
1019:- multifile(user:prolog_file_type/2). 1020:- dynamic(user:prolog_file_type/2). 1021
1022user:prolog_file_type(pl, prolog).
1023user:prolog_file_type(prolog, prolog).
1024user:prolog_file_type(qlf, prolog).
1025user:prolog_file_type(qlf, qlf).
1026user:prolog_file_type(Ext, executable) :-
1027 current_prolog_flag(shared_object_extension, Ext).
1028
1033
1034'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
1035 \+ ground(Spec),
1036 !,
1037 '$instantiation_error'(Spec).
1038'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
1039 compound(Spec),
1040 functor(Spec, _, 1),
1041 !,
1042 '$relative_to'(Cond, cwd, CWD),
1043 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
1044'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- 1045 \+ atomic(Segments),
1046 !,
1047 '$segments_to_atom'(Segments, Atom),
1048 '$chk_file'(Atom, Ext, Cond, Cache, FullName).
1049'$chk_file'(File, Exts, Cond, _, FullName) :-
1050 is_absolute_file_name(File),
1051 !,
1052 '$extend_file'(File, Exts, Extended),
1053 '$file_conditions'(Cond, Extended),
1054 '$absolute_file_name'(Extended, FullName).
1055'$chk_file'(File, Exts, Cond, _, FullName) :-
1056 '$relative_to'(Cond, source, Dir),
1057 atomic_list_concat([Dir, /, File], AbsFile),
1058 '$extend_file'(AbsFile, Exts, Extended),
1059 '$file_conditions'(Cond, Extended),
1060 !,
1061 '$absolute_file_name'(Extended, FullName).
1062'$chk_file'(File, Exts, Cond, _, FullName) :-
1063 '$extend_file'(File, Exts, Extended),
1064 '$file_conditions'(Cond, Extended),
1065 '$absolute_file_name'(Extended, FullName).
1066
1067'$segments_to_atom'(Atom, Atom) :-
1068 atomic(Atom),
1069 !.
1070'$segments_to_atom'(Segments, Atom) :-
1071 '$segments_to_list'(Segments, List, []),
1072 !,
1073 atomic_list_concat(List, /, Atom).
1074
1075'$segments_to_list'(A/B, H, T) :-
1076 '$segments_to_list'(A, H, T0),
1077 '$segments_to_list'(B, T0, T).
1078'$segments_to_list'(A, [A|T], T) :-
1079 atomic(A).
1080
1081
1088
1089'$relative_to'(Conditions, Default, Dir) :-
1090 ( '$option'(relative_to(FileOrDir), Conditions)
1091 *-> ( exists_directory(FileOrDir)
1092 -> Dir = FileOrDir
1093 ; atom_concat(Dir, /, FileOrDir)
1094 -> true
1095 ; file_directory_name(FileOrDir, Dir)
1096 )
1097 ; Default == cwd
1098 -> '$cwd'(Dir)
1099 ; Default == source
1100 -> source_location(ContextFile, _Line),
1101 file_directory_name(ContextFile, Dir)
1102 ).
1103
1106
1107:- dynamic
1108 '$search_path_file_cache'/3, 1109 '$search_path_gc_time'/1. 1110:- volatile
1111 '$search_path_file_cache'/3,
1112 '$search_path_gc_time'/1. 1113
1114:- create_prolog_flag(file_search_cache_time, 10, []). 1115
1116'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
1117 !,
1118 findall(Exp, expand_file_search_path(Spec, Exp), Expansions),
1119 Cache = cache(Exts, Cond, CWD, Expansions),
1120 variant_sha1(Spec+Cache, SHA1),
1121 get_time(Now),
1122 current_prolog_flag(file_search_cache_time, TimeOut),
1123 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile),
1124 CachedTime > Now - TimeOut,
1125 '$file_conditions'(Cond, FullFile)
1126 -> '$search_message'(file_search(cache(Spec, Cond), FullFile))
1127 ; '$member'(Expanded, Expansions),
1128 '$extend_file'(Expanded, Exts, LibFile),
1129 ( '$file_conditions'(Cond, LibFile),
1130 '$absolute_file_name'(LibFile, FullFile),
1131 '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
1132 -> '$search_message'(file_search(found(Spec, Cond), FullFile))
1133 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)),
1134 fail
1135 )
1136 ).
1137'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
1138 expand_file_search_path(Spec, Expanded),
1139 '$extend_file'(Expanded, Exts, LibFile),
1140 '$file_conditions'(Cond, LibFile),
1141 '$absolute_file_name'(LibFile, FullFile).
1142
1143'$cache_file_found'(_, _, TimeOut, _) :-
1144 TimeOut =:= 0,
1145 !.
1146'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1147 '$search_path_file_cache'(SHA1, Saved, FullFile),
1148 !,
1149 ( Now - Saved < TimeOut/2
1150 -> true
1151 ; retractall('$search_path_file_cache'(SHA1, _, _)),
1152 asserta('$search_path_file_cache'(SHA1, Now, FullFile))
1153 ).
1154'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1155 'gc_file_search_cache'(TimeOut),
1156 asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
1157
1158'gc_file_search_cache'(TimeOut) :-
1159 get_time(Now),
1160 '$search_path_gc_time'(Last),
1161 Now-Last < TimeOut/2,
1162 !.
1163'gc_file_search_cache'(TimeOut) :-
1164 get_time(Now),
1165 retractall('$search_path_gc_time'(_)),
1166 assertz('$search_path_gc_time'(Now)),
1167 Before is Now - TimeOut,
1168 ( '$search_path_file_cache'(SHA1, Cached, FullFile),
1169 Cached < Before,
1170 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
1171 fail
1172 ; true
1173 ).
1174
1175
1176'$search_message'(Term) :-
1177 current_prolog_flag(verbose_file_search, true),
1178 !,
1179 print_message(informational, Term).
1180'$search_message'(_).
1181
1182
1186
1187'$file_conditions'(List, File) :-
1188 is_list(List),
1189 !,
1190 \+ ( '$member'(C, List),
1191 '$file_condition'(C),
1192 \+ '$file_condition'(C, File)
1193 ).
1194'$file_conditions'(Map, File) :-
1195 \+ ( get_dict(Key, Map, Value),
1196 C =.. [Key,Value],
1197 '$file_condition'(C),
1198 \+ '$file_condition'(C, File)
1199 ).
1200
1201'$file_condition'(file_type(directory), File) :-
1202 !,
1203 exists_directory(File).
1204'$file_condition'(file_type(_), File) :-
1205 !,
1206 \+ exists_directory(File).
1207'$file_condition'(access(Accesses), File) :-
1208 !,
1209 \+ ( '$one_or_member'(Access, Accesses),
1210 \+ access_file(File, Access)
1211 ).
1212
1213'$file_condition'(exists).
1214'$file_condition'(file_type(_)).
1215'$file_condition'(access(_)).
1216
1217'$extend_file'(File, Exts, FileEx) :-
1218 '$ensure_extensions'(Exts, File, Fs),
1219 '$list_to_set'(Fs, FsSet),
1220 '$member'(FileEx, FsSet).
1221
1222'$ensure_extensions'([], _, []).
1223'$ensure_extensions'([E|E0], F, [FE|E1]) :-
1224 file_name_extension(F, E, FE),
1225 '$ensure_extensions'(E0, F, E1).
1226
1233
1234'$list_to_set'(List, Set) :-
1235 '$list_to_set'(List, [], Set).
1236
1237'$list_to_set'([], _, []).
1238'$list_to_set'([H|T], Seen, R) :-
1239 memberchk(H, Seen),
1240 !,
1241 '$list_to_set'(T, R).
1242'$list_to_set'([H|T], Seen, [H|R]) :-
1243 '$list_to_set'(T, [H|Seen], R).
1244
1250
1251'$canonicalise_extensions'([], []) :- !.
1252'$canonicalise_extensions'([H|T], [CH|CT]) :-
1253 !,
1254 '$must_be'(atom, H),
1255 '$canonicalise_extension'(H, CH),
1256 '$canonicalise_extensions'(T, CT).
1257'$canonicalise_extensions'(E, [CE]) :-
1258 '$canonicalise_extension'(E, CE).
1259
1260'$canonicalise_extension'('', '') :- !.
1261'$canonicalise_extension'(DotAtom, DotAtom) :-
1262 sub_atom(DotAtom, 0, _, _, '.'),
1263 !.
1264'$canonicalise_extension'(Atom, DotAtom) :-
1265 atom_concat('.', Atom, DotAtom).
1266
1267
1268 1271
1272:- dynamic
1273 user:library_directory/1,
1274 user:prolog_load_file/2. 1275:- multifile
1276 user:library_directory/1,
1277 user:prolog_load_file/2. 1278
1279:- prompt(_, '|: '). 1280
1281:- thread_local
1282 '$compilation_mode_store'/1, 1283 '$directive_mode_store'/1. 1284:- volatile
1285 '$compilation_mode_store'/1,
1286 '$directive_mode_store'/1. 1287
1288'$compilation_mode'(Mode) :-
1289 ( '$compilation_mode_store'(Val)
1290 -> Mode = Val
1291 ; Mode = database
1292 ).
1293
1294'$set_compilation_mode'(Mode) :-
1295 retractall('$compilation_mode_store'(_)),
1296 assertz('$compilation_mode_store'(Mode)).
1297
1298'$compilation_mode'(Old, New) :-
1299 '$compilation_mode'(Old),
1300 ( New == Old
1301 -> true
1302 ; '$set_compilation_mode'(New)
1303 ).
1304
1305'$directive_mode'(Mode) :-
1306 ( '$directive_mode_store'(Val)
1307 -> Mode = Val
1308 ; Mode = database
1309 ).
1310
1311'$directive_mode'(Old, New) :-
1312 '$directive_mode'(Old),
1313 ( New == Old
1314 -> true
1315 ; '$set_directive_mode'(New)
1316 ).
1317
1318'$set_directive_mode'(Mode) :-
1319 retractall('$directive_mode_store'(_)),
1320 assertz('$directive_mode_store'(Mode)).
1321
1322
1327
1328'$compilation_level'(Level) :-
1329 '$input_context'(Stack),
1330 '$compilation_level'(Stack, Level).
1331
1332'$compilation_level'([], 0).
1333'$compilation_level'([Input|T], Level) :-
1334 ( arg(1, Input, see)
1335 -> '$compilation_level'(T, Level)
1336 ; '$compilation_level'(T, Level0),
1337 Level is Level0+1
1338 ).
1339
1340
1345
1346compiling :-
1347 \+ ( '$compilation_mode'(database),
1348 '$directive_mode'(database)
1349 ).
1350
1351:- meta_predicate
1352 '$ifcompiling'(0). 1353
1354'$ifcompiling'(G) :-
1355 ( '$compilation_mode'(database)
1356 -> true
1357 ; call(G)
1358 ).
1359
1360 1363
1365
1366'$load_msg_level'(Action, Nesting, Start, Done) :-
1367 '$update_autoload_level'([], 0),
1368 !,
1369 current_prolog_flag(verbose_load, Type0),
1370 '$load_msg_compat'(Type0, Type),
1371 ( '$load_msg_level'(Action, Nesting, Type, Start, Done)
1372 -> true
1373 ).
1374'$load_msg_level'(_, _, silent, silent).
1375
1376'$load_msg_compat'(true, normal) :- !.
1377'$load_msg_compat'(false, silent) :- !.
1378'$load_msg_compat'(X, X).
1379
1380'$load_msg_level'(load_file, _, full, informational, informational).
1381'$load_msg_level'(include_file, _, full, informational, informational).
1382'$load_msg_level'(load_file, _, normal, silent, informational).
1383'$load_msg_level'(include_file, _, normal, silent, silent).
1384'$load_msg_level'(load_file, 0, brief, silent, informational).
1385'$load_msg_level'(load_file, _, brief, silent, silent).
1386'$load_msg_level'(include_file, _, brief, silent, silent).
1387'$load_msg_level'(load_file, _, silent, silent, silent).
1388'$load_msg_level'(include_file, _, silent, silent, silent).
1389
1410
1411'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
1412 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
1413 ( Term == end_of_file
1414 -> !, fail
1415 ; true
1416 ).
1417
1418'$source_term'(Input, _,_,_,_,_,_,_) :-
1419 \+ ground(Input),
1420 !,
1421 '$instantiation_error'(Input).
1422'$source_term'(stream(Id, In, Opts),
1423 Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1424 !,
1425 '$record_included'(Parents, Id, Id, 0.0, Message),
1426 setup_call_cleanup(
1427 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
1428 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1429 [Id|Parents], Options),
1430 '$close_source'(State, Message)).
1431'$source_term'(File,
1432 Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1433 absolute_file_name(File, Path,
1434 [ file_type(prolog),
1435 access(read)
1436 ]),
1437 time_file(Path, Time),
1438 '$record_included'(Parents, File, Path, Time, Message),
1439 setup_call_cleanup(
1440 '$open_source'(Path, In, State, Parents, Options),
1441 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1442 [Path|Parents], Options),
1443 '$close_source'(State, Message)).
1444
1445:- thread_local
1446 '$load_input'/2. 1447:- volatile
1448 '$load_input'/2. 1449
1450'$open_source'(stream(Id, In, Opts), In,
1451 restore(In, StreamState, Id, Ref, Opts), Parents, Options) :-
1452 !,
1453 '$context_type'(Parents, ContextType),
1454 '$push_input_context'(ContextType),
1455 '$set_encoding'(In, Options),
1456 '$prepare_load_stream'(In, Id, StreamState),
1457 asserta('$load_input'(stream(Id), In), Ref).
1458'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
1459 '$context_type'(Parents, ContextType),
1460 '$push_input_context'(ContextType),
1461 open(Path, read, In),
1462 '$set_encoding'(In, Options),
1463 asserta('$load_input'(Path, In), Ref).
1464
1465'$context_type'([], load_file) :- !.
1466'$context_type'(_, include).
1467
1468'$close_source'(close(In, Id, Ref), Message) :-
1469 erase(Ref),
1470 '$end_consult'(Id),
1471 call_cleanup(
1472 close(In),
1473 '$pop_input_context'),
1474 '$close_message'(Message).
1475'$close_source'(restore(In, StreamState, Id, Ref, Opts), Message) :-
1476 erase(Ref),
1477 '$end_consult'(Id),
1478 call_cleanup(
1479 '$restore_load_stream'(In, StreamState, Opts),
1480 '$pop_input_context'),
1481 '$close_message'(Message).
1482
1483'$close_message'(message(Level, Msg)) :-
1484 !,
1485 '$print_message'(Level, Msg).
1486'$close_message'(_).
1487
1488
1497
1498'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1499 '$skip_script_line'(In),
1500 '$read_clause_options'(Options, ReadOptions),
1501 repeat,
1502 read_clause(In, Raw,
1503 [ variable_names(Bindings),
1504 term_position(Pos),
1505 subterm_positions(RawLayout)
1506 | ReadOptions
1507 ]),
1508 b_setval('$term_position', Pos),
1509 b_setval('$variable_names', Bindings),
1510 ( Raw == end_of_file
1511 -> !,
1512 ( Parents = [_,_|_] 1513 -> fail
1514 ; '$expanded_term'(In,
1515 Raw, RawLayout, Read, RLayout, Term, TLayout,
1516 Stream, Parents, Options)
1517 )
1518 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1519 Stream, Parents, Options)
1520 ).
1521
1522'$read_clause_options'([], []).
1523'$read_clause_options'([H|T0], List) :-
1524 ( '$read_clause_option'(H)
1525 -> List = [H|T]
1526 ; List = T
1527 ),
1528 '$read_clause_options'(T0, T).
1529
1530'$read_clause_option'(syntax_errors(_)).
1531'$read_clause_option'(term_position(_)).
1532'$read_clause_option'(process_comment(_)).
1533
1534'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1535 Stream, Parents, Options) :-
1536 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
1537 '$print_message_fail'(E)),
1538 ( Expanded \== []
1539 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
1540 ; Term1 = Expanded,
1541 Layout1 = ExpandedLayout
1542 ),
1543 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
1544 -> ( Directive = include(File),
1545 '$current_source_module'(Module),
1546 '$valid_directive'(Module:include(File))
1547 -> stream_property(In, encoding(Enc)),
1548 '$add_encoding'(Enc, Options, Options1),
1549 '$source_term'(File, Read, RLayout, Term, TLayout,
1550 Stream, Parents, Options1)
1551 ; Directive = encoding(Enc)
1552 -> set_stream(In, encoding(Enc)),
1553 fail
1554 ; Term = Term1,
1555 Stream = In,
1556 Read = Raw
1557 )
1558 ; Term = Term1,
1559 TLayout = Layout1,
1560 Stream = In,
1561 Read = Raw,
1562 RLayout = RawLayout
1563 ).
1564
1565'$expansion_member'(Var, Layout, Var, Layout) :-
1566 var(Var),
1567 !.
1568'$expansion_member'([], _, _, _) :- !, fail.
1569'$expansion_member'(List, ListLayout, Term, Layout) :-
1570 is_list(List),
1571 !,
1572 ( var(ListLayout)
1573 -> '$member'(Term, List)
1574 ; is_list(ListLayout)
1575 -> '$member_rep2'(Term, Layout, List, ListLayout)
1576 ; Layout = ListLayout,
1577 '$member'(Term, List)
1578 ).
1579'$expansion_member'(X, Layout, X, Layout).
1580
1583
1584'$member_rep2'(H1, H2, [H1|_], [H2|_]).
1585'$member_rep2'(H1, H2, [_|T1], [T2]) :-
1586 !,
1587 '$member_rep2'(H1, H2, T1, [T2]).
1588'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
1589 '$member_rep2'(H1, H2, T1, T2).
1590
1592
1593'$add_encoding'(Enc, Options0, Options) :-
1594 ( Options0 = [encoding(Enc)|_]
1595 -> Options = Options0
1596 ; Options = [encoding(Enc)|Options0]
1597 ).
1598
1599
1600:- multifile
1601 '$included'/4. 1602:- dynamic
1603 '$included'/4. 1604
1616
1617'$record_included'([Parent|Parents], File, Path, Time,
1618 message(DoneMsgLevel,
1619 include_file(done(Level, file(File, Path))))) :-
1620 source_location(SrcFile, Line),
1621 !,
1622 '$compilation_level'(Level),
1623 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
1624 '$print_message'(StartMsgLevel,
1625 include_file(start(Level,
1626 file(File, Path)))),
1627 '$last'([Parent|Parents], Owner),
1628 ( ( '$compilation_mode'(database)
1629 ; '$qlf_current_source'(Owner)
1630 )
1631 -> '$store_admin_clause'(
1632 system:'$included'(Parent, Line, Path, Time),
1633 _, Owner, SrcFile:Line)
1634 ; '$qlf_include'(Owner, Parent, Line, Path, Time)
1635 ).
1636'$record_included'(_, _, _, _, true).
1637
1641
1642'$master_file'(File, MasterFile) :-
1643 '$included'(MasterFile0, _Line, File, _Time),
1644 !,
1645 '$master_file'(MasterFile0, MasterFile).
1646'$master_file'(File, File).
1647
1648
1649'$skip_script_line'(In) :-
1650 ( peek_char(In, #)
1651 -> skip(In, 10)
1652 ; true
1653 ).
1654
1655'$set_encoding'(Stream, Options) :-
1656 '$option'(encoding(Enc), Options),
1657 !,
1658 Enc \== default,
1659 set_stream(Stream, encoding(Enc)).
1660'$set_encoding'(_, _).
1661
1662
1663'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
1664 ( stream_property(In, file_name(_))
1665 -> HasName = true,
1666 ( stream_property(In, position(_))
1667 -> HasPos = true
1668 ; HasPos = false,
1669 set_stream(In, record_position(true))
1670 )
1671 ; HasName = false,
1672 set_stream(In, file_name(Id)),
1673 ( stream_property(In, position(_))
1674 -> HasPos = true
1675 ; HasPos = false,
1676 set_stream(In, record_position(true))
1677 )
1678 ).
1679
1680'$restore_load_stream'(In, _State, Options) :-
1681 memberchk(close(true), Options),
1682 !,
1683 close(In).
1684'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
1685 ( HasName == false
1686 -> set_stream(In, file_name(''))
1687 ; true
1688 ),
1689 ( HasPos == false
1690 -> set_stream(In, record_position(false))
1691 ; true
1692 ).
1693
1694
1695 1698
1699:- dynamic
1700 '$derived_source_db'/3. 1701
1702'$register_derived_source'(_, '-') :- !.
1703'$register_derived_source'(Loaded, DerivedFrom) :-
1704 retractall('$derived_source_db'(Loaded, _, _)),
1705 time_file(DerivedFrom, Time),
1706 assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
1707
1710
1711'$derived_source'(Loaded, DerivedFrom, Time) :-
1712 '$derived_source_db'(Loaded, DerivedFrom, Time).
1713
1714
1715 1718
1719:- meta_predicate
1720 ensure_loaded(:),
1721 [:|+],
1722 consult(:),
1723 use_module(:),
1724 use_module(:, +),
1725 reexport(:),
1726 reexport(:, +),
1727 load_files(:),
1728 load_files(:, +). 1729
1735
1736ensure_loaded(Files) :-
1737 load_files(Files, [if(not_loaded)]).
1738
1745
1746use_module(Files) :-
1747 load_files(Files, [ if(not_loaded),
1748 must_be_module(true)
1749 ]).
1750
1755
1756use_module(File, Import) :-
1757 load_files(File, [ if(not_loaded),
1758 must_be_module(true),
1759 imports(Import)
1760 ]).
1761
1765
1766reexport(Files) :-
1767 load_files(Files, [ if(not_loaded),
1768 must_be_module(true),
1769 reexport(true)
1770 ]).
1771
1775
1776reexport(File, Import) :-
1777 load_files(File, [ if(not_loaded),
1778 must_be_module(true),
1779 imports(Import),
1780 reexport(true)
1781 ]).
1782
1783
1784[X] :-
1785 !,
1786 consult(X).
1787[M:F|R] :-
1788 consult(M:[F|R]).
1789
1790consult(M:X) :-
1791 X == user,
1792 !,
1793 flag('$user_consult', N, N+1),
1794 NN is N + 1,
1795 atom_concat('user://', NN, Id),
1796 load_files(M:Id, [stream(user_input)]).
1797consult(List) :-
1798 load_files(List, [expand(true)]).
1799
1804
1805load_files(Files) :-
1806 load_files(Files, []).
1807load_files(Module:Files, Options) :-
1808 '$must_be'(list, Options),
1809 '$load_files'(Files, Module, Options).
1810
1811'$load_files'(X, _, _) :-
1812 var(X),
1813 !,
1814 '$instantiation_error'(X).
1815'$load_files'([], _, _) :- !.
1816'$load_files'(Id, Module, Options) :- 1817 '$option'(stream(_), Options),
1818 !,
1819 ( atom(Id)
1820 -> '$load_file'(Id, Module, Options)
1821 ; throw(error(type_error(atom, Id), _))
1822 ).
1823'$load_files'(List, Module, Options) :-
1824 List = [_|_],
1825 !,
1826 '$must_be'(list, List),
1827 '$load_file_list'(List, Module, Options).
1828'$load_files'(File, Module, Options) :-
1829 '$load_one_file'(File, Module, Options).
1830
1831'$load_file_list'([], _, _).
1832'$load_file_list'([File|Rest], Module, Options) :-
1833 catch('$load_one_file'(File, Module, Options), E,
1834 print_message(error, E)),
1835 '$load_file_list'(Rest, Module, Options).
1836
1837
1838'$load_one_file'(Spec, Module, Options) :-
1839 atomic(Spec),
1840 '$option'(expand(Expand), Options, false),
1841 Expand == true,
1842 !,
1843 expand_file_name(Spec, Expanded),
1844 ( Expanded = [Load]
1845 -> true
1846 ; Load = Expanded
1847 ),
1848 '$load_files'(Load, Module, [expand(false)|Options]).
1849'$load_one_file'(File, Module, Options) :-
1850 strip_module(Module:File, Into, PlainFile),
1851 '$load_file'(PlainFile, Into, Options).
1852
1853
1857
1858'$noload'(true, _, _) :-
1859 !,
1860 fail.
1861'$noload'(not_loaded, FullFile, _) :-
1862 source_file(FullFile),
1863 !.
1864'$noload'(changed, Derived, _) :-
1865 '$derived_source'(_FullFile, Derived, LoadTime),
1866 time_file(Derived, Modified),
1867 Modified @=< LoadTime,
1868 !.
1869'$noload'(changed, FullFile, Options) :-
1870 '$time_source_file'(FullFile, LoadTime, user),
1871 '$modified_id'(FullFile, Modified, Options),
1872 Modified @=< LoadTime,
1873 !.
1874
1882
1883'$qlf_file'(Spec, _, Spec, stream, Options) :-
1884 '$option'(stream(_), Options),
1885 !.
1886'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
1887 '$spec_extension'(Spec, Ext),
1888 user:prolog_file_type(Ext, prolog),
1889 !.
1890'$qlf_file'(_, FullFile, QlfFile, Mode, Options) :-
1891 '$compilation_mode'(database),
1892 file_name_extension(Base, PlExt, FullFile),
1893 user:prolog_file_type(PlExt, prolog),
1894 user:prolog_file_type(QlfExt, qlf),
1895 file_name_extension(Base, QlfExt, QlfFile),
1896 ( access_file(QlfFile, read),
1897 ( '$qlf_up_to_date'(FullFile, QlfFile)
1898 -> Mode = qload
1899 ; access_file(QlfFile, write)
1900 -> Mode = qcompile
1901 )
1902 -> !
1903 ; '$qlf_auto'(FullFile, QlfFile, Options)
1904 -> !, Mode = qcompile
1905 ).
1906'$qlf_file'(_, FullFile, FullFile, compile, _).
1907
1908
1914
1915'$qlf_up_to_date'(PlFile, QlfFile) :-
1916 ( exists_file(PlFile)
1917 -> time_file(PlFile, PlTime),
1918 time_file(QlfFile, QlfTime),
1919 QlfTime >= PlTime
1920 ; true
1921 ).
1922
1928
1929:- create_prolog_flag(qcompile, false, [type(atom)]). 1930
1931'$qlf_auto'(PlFile, QlfFile, Options) :-
1932 ( memberchk(qcompile(QlfMode), Options)
1933 -> true
1934 ; current_prolog_flag(qcompile, QlfMode),
1935 \+ '$in_system_dir'(PlFile)
1936 ),
1937 ( QlfMode == auto
1938 -> true
1939 ; QlfMode == large,
1940 size_file(PlFile, Size),
1941 Size > 100000
1942 ),
1943 access_file(QlfFile, write).
1944
1945'$in_system_dir'(PlFile) :-
1946 current_prolog_flag(home, Home),
1947 sub_atom(PlFile, 0, _, _, Home).
1948
1949'$spec_extension'(File, Ext) :-
1950 atom(File),
1951 file_name_extension(_, Ext, File).
1952'$spec_extension'(Spec, Ext) :-
1953 compound(Spec),
1954 arg(1, Spec, Arg),
1955 '$spec_extension'(Arg, Ext).
1956
1957
1966
1967'$load_file'(File, Module, Options) :-
1968 \+ memberchk(stream(_), Options),
1969 user:prolog_load_file(Module:File, Options),
1970 !.
1971'$load_file'(File, Module, Options) :-
1972 memberchk(stream(_), Options),
1973 !,
1974 '$assert_load_context_module'(File, Module, Options),
1975 '$qdo_load_file'(File, File, Module, Action, Options),
1976 '$run_initialization'(File, Action, Options).
1977'$load_file'(File, Module, Options) :-
1978 absolute_file_name(File,
1979 [ file_type(prolog),
1980 access(read)
1981 ],
1982 FullFile),
1983 '$mt_load_file'(File, FullFile, Module, Options).
1984
1985
1996
1997'$already_loaded'(_File, FullFile, Module, Options) :-
1998 '$assert_load_context_module'(FullFile, Module, Options),
1999 '$current_module'(LoadModules, FullFile),
2000 !,
2001 ( atom(LoadModules)
2002 -> LoadModule = LoadModules
2003 ; LoadModules = [LoadModule|_]
2004 ),
2005 '$import_from_loaded_module'(LoadModule, Module, Options).
2006'$already_loaded'(_, _, user, _) :- !.
2007'$already_loaded'(File, _, Module, Options) :-
2008 '$load_file'(File, Module, [if(true)|Options]).
2009
2022
2023:- dynamic
2024 '$loading_file'/3. 2025:- volatile
2026 '$loading_file'/3. 2027
2028'$mt_load_file'(File, FullFile, Module, Options) :-
2029 current_prolog_flag(threads, true),
2030 !,
2031 setup_call_cleanup(
2032 with_mutex('$load_file',
2033 '$mt_start_load'(FullFile, Loading, Options)),
2034 '$mt_do_load'(Loading, File, FullFile, Module, Options),
2035 '$mt_end_load'(Loading)).
2036'$mt_load_file'(File, FullFile, Module, Options) :-
2037 '$option'(if(If), Options, true),
2038 '$noload'(If, FullFile, Options),
2039 !,
2040 '$already_loaded'(File, FullFile, Module, Options).
2041'$mt_load_file'(File, FullFile, Module, Options) :-
2042 '$qdo_load_file'(File, FullFile, Module, Action, Options),
2043 '$run_initialization'(FullFile, Action, Options).
2044
2045'$mt_start_load'(FullFile, queue(Queue), _) :-
2046 '$loading_file'(FullFile, Queue, LoadThread),
2047 \+ thread_self(LoadThread),
2048 !.
2049'$mt_start_load'(FullFile, already_loaded, Options) :-
2050 '$option'(if(If), Options, true),
2051 '$noload'(If, FullFile, Options),
2052 !.
2053'$mt_start_load'(FullFile, Ref, _) :-
2054 thread_self(Me),
2055 message_queue_create(Queue),
2056 assertz('$loading_file'(FullFile, Queue, Me), Ref).
2057
2058'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
2059 !,
2060 catch(thread_get_message(Queue, _), _, true),
2061 '$already_loaded'(File, FullFile, Module, Options).
2062'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
2063 !,
2064 '$already_loaded'(File, FullFile, Module, Options).
2065'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
2066 '$assert_load_context_module'(FullFile, Module, Options),
2067 '$qdo_load_file'(File, FullFile, Module, Action, Options),
2068 '$run_initialization'(FullFile, Action, Options).
2069
2070'$mt_end_load'(queue(_)) :- !.
2071'$mt_end_load'(already_loaded) :- !.
2072'$mt_end_load'(Ref) :-
2073 clause('$loading_file'(_, Queue, _), _, Ref),
2074 erase(Ref),
2075 thread_send_message(Queue, done),
2076 message_queue_destroy(Queue).
2077
2078
2082
2083'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
2084 memberchk('$qlf'(QlfOut), Options),
2085 !,
2086 setup_call_cleanup(
2087 '$qstart'(QlfOut, Module, State),
2088 '$do_load_file'(File, FullFile, Module, Action, Options),
2089 '$qend'(State)).
2090'$qdo_load_file'(File, FullFile, Module, Action, Options) :-
2091 '$do_load_file'(File, FullFile, Module, Action, Options).
2092
2093'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
2094 '$qlf_open'(Qlf),
2095 '$compilation_mode'(OldMode, qlf),
2096 '$set_source_module'(OldModule, Module).
2097
2098'$qend'(state(OldMode, OldModule)) :-
2099 '$set_source_module'(_, OldModule),
2100 '$set_compilation_mode'(OldMode),
2101 '$qlf_close'.
2102
2103'$set_source_module'(OldModule, Module) :-
2104 '$current_source_module'(OldModule),
2105 '$set_source_module'(Module).
2106
2111
2112'$do_load_file'(File, FullFile, Module, Action, Options) :-
2113 '$option'(derived_from(DerivedFrom), Options, -),
2114 '$register_derived_source'(FullFile, DerivedFrom),
2115 '$qlf_file'(File, FullFile, Absolute, Mode, Options),
2116 ( Mode == qcompile
2117 -> qcompile(Module:File, Options)
2118 ; '$do_load_file_2'(File, Absolute, Module, Action, Options)
2119 ).
2120
2121'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
2122 '$source_file_property'(Absolute, number_of_clauses, OldClauses),
2123 statistics(cputime, OldTime),
2124
2125 '$set_sandboxed_load'(Options, OldSandBoxed),
2126 '$set_verbose_load'(Options, OldVerbose),
2127 '$update_autoload_level'(Options, OldAutoLevel),
2128 '$save_file_scoped_flags'(ScopedFlags),
2129 set_prolog_flag(xref, false),
2130
2131 '$compilation_level'(Level),
2132 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
2133 '$print_message'(StartMsgLevel,
2134 load_file(start(Level,
2135 file(File, Absolute)))),
2136
2137 ( memberchk(stream(FromStream), Options)
2138 -> Input = stream
2139 ; Input = source
2140 ),
2141
2142 ( Input == stream,
2143 ( '$option'(format(qlf), Options, source)
2144 -> set_stream(FromStream, file_name(Absolute)),
2145 '$qload_stream'(FromStream, Module, Action, LM, Options)
2146 ; '$consult_file'(stream(Absolute, FromStream, []),
2147 Module, Action, LM, Options)
2148 )
2149 -> true
2150 ; Input == source,
2151 file_name_extension(_, Ext, Absolute),
2152 ( user:prolog_file_type(Ext, qlf)
2153 -> '$qload_file'(Absolute, Module, Action, LM, Options)
2154 ; '$consult_file'(Absolute, Module, Action, LM, Options)
2155 )
2156 -> true
2157 ; print_message(error, load_file(failed(File))),
2158 fail
2159 ),
2160
2161 '$import_from_loaded_module'(LM, Module, Options),
2162
2163 '$source_file_property'(Absolute, number_of_clauses, NewClauses),
2164 statistics(cputime, Time),
2165 ClausesCreated is NewClauses - OldClauses,
2166 TimeUsed is Time - OldTime,
2167
2168 '$print_message'(DoneMsgLevel,
2169 load_file(done(Level,
2170 file(File, Absolute),
2171 Action,
2172 LM,
2173 TimeUsed,
2174 ClausesCreated))),
2175 '$set_autoload_level'(OldAutoLevel),
2176 set_prolog_flag(verbose_load, OldVerbose),
2177 set_prolog_flag(sandboxed_load, OldSandBoxed),
2178 '$restore_file_scoped_flags'(ScopedFlags).
2179
2184
2185'$save_file_scoped_flags'(State) :-
2186 current_predicate(findall/3), 2187 !,
2188 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
2189'$save_file_scoped_flags'([]).
2190
2191'$save_file_scoped_flag'(Flag-Value) :-
2192 '$file_scoped_flag'(Flag, Default),
2193 ( current_prolog_flag(Flag, Value)
2194 -> true
2195 ; Value = Default
2196 ).
2197
2198'$file_scoped_flag'(generate_debug_info, true).
2199'$file_scoped_flag'(optimise, false).
2200'$file_scoped_flag'(xref, false).
2201
2202'$restore_file_scoped_flags'([]).
2203'$restore_file_scoped_flags'([Flag-Value|T]) :-
2204 set_prolog_flag(Flag, Value),
2205 '$restore_file_scoped_flags'(T).
2206
2207
2211
2212'$import_from_loaded_module'(LoadedModule, Module, Options) :-
2213 LoadedModule \== Module,
2214 atom(LoadedModule),
2215 !,
2216 '$option'(imports(Import), Options, all),
2217 '$option'(reexport(Reexport), Options, false),
2218 '$import_list'(Module, LoadedModule, Import, Reexport).
2219'$import_from_loaded_module'(_, _, _).
2220
2221
2226
2227'$set_verbose_load'(Options, Old) :-
2228 current_prolog_flag(verbose_load, Old),
2229 ( memberchk(silent(Silent), Options)
2230 -> ( '$negate'(Silent, Level0)
2231 -> '$load_msg_compat'(Level0, Level)
2232 ; Level = Silent
2233 ),
2234 set_prolog_flag(verbose_load, Level)
2235 ; true
2236 ).
2237
2238'$negate'(true, false).
2239'$negate'(false, true).
2240
2247
2248'$set_sandboxed_load'(Options, Old) :-
2249 current_prolog_flag(sandboxed_load, Old),
2250 ( memberchk(sandboxed(SandBoxed), Options),
2251 '$enter_sandboxed'(Old, SandBoxed, New),
2252 New \== Old
2253 -> set_prolog_flag(sandboxed_load, New)
2254 ; true
2255 ).
2256
2257'$enter_sandboxed'(Old, New, SandBoxed) :-
2258 ( Old == false, New == true
2259 -> SandBoxed = true,
2260 '$ensure_loaded_library_sandbox'
2261 ; Old == true, New == false
2262 -> throw(error(permission_error(leave, sandbox, -), _))
2263 ; SandBoxed = Old
2264 ).
2265'$enter_sandboxed'(false, true, true).
2266
2267'$ensure_loaded_library_sandbox' :-
2268 source_file_property(library(sandbox), module(sandbox)),
2269 !.
2270'$ensure_loaded_library_sandbox' :-
2271 load_files(library(sandbox), [if(not_loaded), silent(true)]).
2272
2273
2277
2278:- thread_local
2279 '$autoload_nesting'/1. 2280
2281'$update_autoload_level'(Options, AutoLevel) :-
2282 '$option'(autoload(Autoload), Options, false),
2283 ( '$autoload_nesting'(CurrentLevel)
2284 -> AutoLevel = CurrentLevel
2285 ; AutoLevel = 0
2286 ),
2287 ( Autoload == false
2288 -> true
2289 ; NewLevel is AutoLevel + 1,
2290 '$set_autoload_level'(NewLevel)
2291 ).
2292
2293'$set_autoload_level'(New) :-
2294 retractall('$autoload_nesting'(_)),
2295 asserta('$autoload_nesting'(New)).
2296
2297
2302
2303'$print_message'(Level, Term) :-
2304 current_predicate(system:print_message/2),
2305 !,
2306 print_message(Level, Term).
2307'$print_message'(warning, Term) :-
2308 source_location(File, Line),
2309 !,
2310 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
2311'$print_message'(error, Term) :-
2312 !,
2313 source_location(File, Line),
2314 !,
2315 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
2316'$print_message'(_Level, _Term).
2317
2318'$print_message_fail'(E) :-
2319 '$print_message'(error, E),
2320 fail.
2321
2327
2328'$consult_file'(Absolute, Module, What, LM, Options) :-
2329 '$current_source_module'(Module), 2330 !,
2331 '$consult_file_2'(Absolute, Module, What, LM, Options).
2332'$consult_file'(Absolute, Module, What, LM, Options) :-
2333 '$set_source_module'(OldModule, Module),
2334 '$ifcompiling'('$qlf_start_sub_module'(Module)),
2335 '$consult_file_2'(Absolute, Module, What, LM, Options),
2336 '$ifcompiling'('$qlf_end_part'),
2337 '$set_source_module'(OldModule).
2338
2339'$consult_file_2'(Absolute, Module, What, LM, Options) :-
2340 '$set_source_module'(OldModule, Module),
2341 '$load_id'(Absolute, Id, Modified, Options),
2342 '$start_consult'(Id, Modified),
2343 ( '$derived_source'(Absolute, DerivedFrom, _)
2344 -> '$modified_id'(DerivedFrom, DerivedModified, Options),
2345 '$start_consult'(DerivedFrom, DerivedModified)
2346 ; true
2347 ),
2348 '$compile_type'(What),
2349 '$save_lex_state'(LexState, Options),
2350 '$set_dialect'(Options),
2351 call_cleanup('$load_file'(Absolute, Id, LM, Options),
2352 '$end_consult'(LexState, OldModule)).
2353
2354'$end_consult'(LexState, OldModule) :-
2355 '$restore_lex_state'(LexState),
2356 '$set_source_module'(OldModule).
2357
2358
2359:- create_prolog_flag(emulated_dialect, swi, [type(atom)]). 2360
2362
2363'$save_lex_state'(State, Options) :-
2364 memberchk(scope_settings(false), Options),
2365 !,
2366 State = (-).
2367'$save_lex_state'(lexstate(Style, Dialect), _) :-
2368 '$style_check'(Style, Style),
2369 current_prolog_flag(emulated_dialect, Dialect).
2370
2371'$restore_lex_state'(-) :- !.
2372'$restore_lex_state'(lexstate(Style, Dialect)) :-
2373 '$style_check'(_, Style),
2374 set_prolog_flag(emulated_dialect, Dialect).
2375
2376'$set_dialect'(Options) :-
2377 memberchk(dialect(Dialect), Options),
2378 !,
2379 expects_dialect(Dialect). 2380'$set_dialect'(_).
2381
2382'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
2383 !,
2384 '$modified_id'(Id, Modified, Options).
2385'$load_id'(Id, Id, Modified, Options) :-
2386 '$modified_id'(Id, Modified, Options).
2387
2388'$modified_id'(_, Modified, Options) :-
2389 '$option'(modified(Stamp), Options, Def),
2390 Stamp \== Def,
2391 !,
2392 Modified = Stamp.
2393'$modified_id'(Id, Modified, _) :-
2394 exists_file(Id),
2395 !,
2396 time_file(Id, Modified).
2397'$modified_id'(_, 0.0, _).
2398
2399
2400'$compile_type'(What) :-
2401 '$compilation_mode'(How),
2402 ( How == database
2403 -> What = compiled
2404 ; How == qlf
2405 -> What = '*qcompiled*'
2406 ; What = 'boot compiled'
2407 ).
2408
2416
2417:- dynamic
2418 '$load_context_module'/3. 2419:- multifile
2420 '$load_context_module'/3. 2421
2422'$assert_load_context_module'(_, _, Options) :-
2423 memberchk(register(false), Options),
2424 !.
2425'$assert_load_context_module'(File, Module, Options) :-
2426 source_location(FromFile, Line),
2427 !,
2428 '$master_file'(FromFile, MasterFile),
2429 '$check_load_non_module'(File, Module),
2430 '$add_dialect'(Options, Options1),
2431 '$load_ctx_options'(Options1, Options2),
2432 '$store_admin_clause'(
2433 system:'$load_context_module'(File, Module, Options2),
2434 _Layout, MasterFile, FromFile:Line).
2435'$assert_load_context_module'(File, Module, Options) :-
2436 '$check_load_non_module'(File, Module),
2437 '$add_dialect'(Options, Options1),
2438 '$load_ctx_options'(Options1, Options2),
2439 ( clause('$load_context_module'(File, Module, _), true, Ref),
2440 \+ clause_property(Ref, file(_)),
2441 erase(Ref)
2442 -> true
2443 ; true
2444 ),
2445 assertz('$load_context_module'(File, Module, Options2)).
2446
2447'$add_dialect'(Options0, Options) :-
2448 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
2449 !,
2450 Options = [dialect(Dialect)|Options0].
2451'$add_dialect'(Options, Options).
2452
2457
2458'$load_ctx_options'([], []).
2459'$load_ctx_options'([H|T0], [H|T]) :-
2460 '$load_ctx_option'(H),
2461 !,
2462 '$load_ctx_options'(T0, T).
2463'$load_ctx_options'([_|T0], T) :-
2464 '$load_ctx_options'(T0, T).
2465
2466'$load_ctx_option'(derived_from(_)).
2467'$load_ctx_option'(dialect(_)).
2468'$load_ctx_option'(encoding(_)).
2469'$load_ctx_option'(imports(_)).
2470'$load_ctx_option'(reexport(_)).
2471
2472
2477
2478'$check_load_non_module'(File, _) :-
2479 '$current_module'(_, File),
2480 !. 2481'$check_load_non_module'(File, Module) :-
2482 '$load_context_module'(File, OldModule, _),
2483 Module \== OldModule,
2484 !,
2485 format(atom(Msg),
2486 'Non-module file already loaded into module ~w; \c
2487 trying to load into ~w',
2488 [OldModule, Module]),
2489 throw(error(permission_error(load, source, File),
2490 context(load_files/2, Msg))).
2491'$check_load_non_module'(_, _).
2492
2503
2504'$load_file'(Path, Id, Module, Options) :-
2505 State = state(true, _, true, false, Id, -),
2506 ( '$source_term'(Path, _Read, _Layout, Term, Layout,
2507 _Stream, Options),
2508 '$valid_term'(Term),
2509 ( arg(1, State, true)
2510 -> '$first_term'(Term, Layout, Id, State, Options),
2511 nb_setarg(1, State, false)
2512 ; '$compile_term'(Term, Layout, Id)
2513 ),
2514 arg(4, State, true)
2515 ; '$end_load_file'(State)
2516 ),
2517 !,
2518 arg(2, State, Module).
2519
2520'$valid_term'(Var) :-
2521 var(Var),
2522 !,
2523 print_message(error, error(instantiation_error, _)).
2524'$valid_term'(Term) :-
2525 Term \== [].
2526
2527'$end_load_file'(State) :-
2528 arg(1, State, true), 2529 !,
2530 nb_setarg(2, State, Module),
2531 arg(5, State, Id),
2532 '$current_source_module'(Module),
2533 '$ifcompiling'('$qlf_start_file'(Id)),
2534 '$ifcompiling'('$qlf_end_part').
2535'$end_load_file'(State) :-
2536 arg(3, State, End),
2537 '$end_load_file'(End, State).
2538
2539'$end_load_file'(true, _).
2540'$end_load_file'(end_module, State) :-
2541 arg(2, State, Module),
2542 '$check_export'(Module),
2543 '$ifcompiling'('$qlf_end_part').
2544'$end_load_file'(end_non_module, _State) :-
2545 '$ifcompiling'('$qlf_end_part').
2546
2547
2548'$first_term'(?-(Directive), Layout, Id, State, Options) :-
2549 !,
2550 '$first_term'(:-(Directive), Layout, Id, State, Options).
2551'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
2552 nonvar(Directive),
2553 ( ( Directive = module(Name, Public)
2554 -> Imports = []
2555 ; Directive = module(Name, Public, Imports)
2556 )
2557 -> !,
2558 '$module_name'(Name, Id, Module, Options),
2559 '$start_module'(Module, Public, State, Options),
2560 '$module3'(Imports)
2561 ; Directive = expects_dialect(Dialect)
2562 -> !,
2563 '$set_dialect'(Dialect, State),
2564 fail 2565 ).
2566'$first_term'(Term, Layout, Id, State, Options) :-
2567 '$start_non_module'(Id, State, Options),
2568 '$compile_term'(Term, Layout, Id).
2569
2570'$compile_term'(Term, Layout, Id) :-
2571 '$compile_term'(Term, Layout, Id, -).
2572
2573'$compile_term'(Var, _Layout, _Id, _Src) :-
2574 var(Var),
2575 !,
2576 '$instantiation_error'(Var).
2577'$compile_term'((?-Directive), _Layout, Id, _) :-
2578 !,
2579 '$execute_directive'(Directive, Id).
2580'$compile_term'((:-Directive), _Layout, Id, _) :-
2581 !,
2582 '$execute_directive'(Directive, Id).
2583'$compile_term'('$source_location'(File, Line):Term, Layout, Id, _) :-
2584 !,
2585 '$compile_term'(Term, Layout, Id, File:Line).
2586'$compile_term'(Clause, Layout, Id, SrcLoc) :-
2587 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
2588 '$print_message'(error, E)).
2589
2590'$start_non_module'(Id, _State, Options) :-
2591 '$option'(must_be_module(true), Options, false),
2592 !,
2593 throw(error(domain_error(module_file, Id), _)).
2594'$start_non_module'(Id, State, _Options) :-
2595 '$current_source_module'(Module),
2596 '$ifcompiling'('$qlf_start_file'(Id)),
2597 '$qset_dialect'(State),
2598 nb_setarg(2, State, Module),
2599 nb_setarg(3, State, end_non_module).
2600
2611
2612'$set_dialect'(Dialect, State) :-
2613 '$compilation_mode'(qlf, database),
2614 !,
2615 expects_dialect(Dialect),
2616 '$compilation_mode'(_, qlf),
2617 nb_setarg(6, State, Dialect).
2618'$set_dialect'(Dialect, _) :-
2619 expects_dialect(Dialect).
2620
2621'$qset_dialect'(State) :-
2622 '$compilation_mode'(qlf),
2623 arg(6, State, Dialect), Dialect \== (-),
2624 !,
2625 '$add_directive_wic'(expects_dialect(Dialect)).
2626'$qset_dialect'(_).
2627
2628
2629 2632
2633'$start_module'(Module, _Public, State, _Options) :-
2634 '$current_module'(Module, OldFile),
2635 source_location(File, _Line),
2636 OldFile \== File, OldFile \== [],
2637 same_file(OldFile, File),
2638 !,
2639 nb_setarg(2, State, Module),
2640 nb_setarg(4, State, true). 2641'$start_module'(Module, Public, State, Options) :-
2642 arg(5, State, File),
2643 nb_setarg(2, State, Module),
2644 source_location(_File, Line),
2645 '$option'(redefine_module(Action), Options, false),
2646 '$module_class'(File, Class, Super),
2647 '$redefine_module'(Module, File, Action),
2648 '$declare_module'(Module, Class, Super, File, Line, false),
2649 '$export_list'(Public, Module, Ops),
2650 '$ifcompiling'('$qlf_start_module'(Module)),
2651 '$export_ops'(Ops, Module, File),
2652 '$qset_dialect'(State),
2653 nb_setarg(3, State, end_module).
2654
2655
2659
2660'$module3'(Var) :-
2661 var(Var),
2662 !,
2663 '$instantiation_error'(Var).
2664'$module3'([]) :- !.
2665'$module3'([H|T]) :-
2666 !,
2667 '$module3'(H),
2668 '$module3'(T).
2669'$module3'(Id) :-
2670 use_module(library(dialect/Id)).
2671
2683
2684'$module_name'(_, _, Module, Options) :-
2685 '$option'(module(Module), Options),
2686 !,
2687 '$current_source_module'(Context),
2688 Context \== Module. 2689'$module_name'(Var, Id, Module, Options) :-
2690 var(Var),
2691 !,
2692 file_base_name(Id, File),
2693 file_name_extension(Var, _, File),
2694 '$module_name'(Var, Id, Module, Options).
2695'$module_name'(Reserved, _, _, _) :-
2696 '$reserved_module'(Reserved),
2697 !,
2698 throw(error(permission_error(load, module, Reserved), _)).
2699'$module_name'(Module, _Id, Module, _).
2700
2701
2702'$reserved_module'(system).
2703'$reserved_module'(user).
2704
2705
2707
2708'$redefine_module'(_Module, _, false) :- !.
2709'$redefine_module'(Module, File, true) :-
2710 !,
2711 ( module_property(Module, file(OldFile)),
2712 File \== OldFile
2713 -> unload_file(OldFile)
2714 ; true
2715 ).
2716'$redefine_module'(Module, File, ask) :-
2717 ( stream_property(user_input, tty(true)),
2718 module_property(Module, file(OldFile)),
2719 File \== OldFile,
2720 '$rdef_response'(Module, OldFile, File, true)
2721 -> '$redefine_module'(Module, File, true)
2722 ; true
2723 ).
2724
2725'$rdef_response'(Module, OldFile, File, Ok) :-
2726 repeat,
2727 print_message(query, redefine_module(Module, OldFile, File)),
2728 get_single_char(Char),
2729 '$rdef_response'(Char, Ok0),
2730 !,
2731 Ok = Ok0.
2732
2733'$rdef_response'(Char, true) :-
2734 memberchk(Char, "yY"),
2735 format(user_error, 'yes~n', []).
2736'$rdef_response'(Char, false) :-
2737 memberchk(Char, "nN"),
2738 format(user_error, 'no~n', []).
2739'$rdef_response'(Char, _) :-
2740 memberchk(Char, "a"),
2741 format(user_error, 'abort~n', []),
2742 abort.
2743'$rdef_response'(_, _) :-
2744 print_message(help, redefine_module_reply),
2745 fail.
2746
2747
2753
2754'$module_class'(File, Class, system) :-
2755 current_prolog_flag(home, Home),
2756 sub_atom(File, 0, Len, _, Home),
2757 !,
2758 ( sub_atom(File, Len, _, _, '/boot/')
2759 -> Class = system
2760 ; Class = library
2761 ).
2762'$module_class'(_, user, user).
2763
2764'$check_export'(Module) :-
2765 '$undefined_export'(Module, UndefList),
2766 ( '$member'(Undef, UndefList),
2767 strip_module(Undef, _, Local),
2768 print_message(error,
2769 undefined_export(Module, Local)),
2770 fail
2771 ; true
2772 ).
2773
2774
2780
2781'$import_list'(_, _, Var, _) :-
2782 var(Var),
2783 !,
2784 throw(error(instantitation_error, _)).
2785'$import_list'(Target, Source, all, Reexport) :-
2786 !,
2787 '$exported_ops'(Source, Import, Predicates),
2788 '$module_property'(Source, exports(Predicates)),
2789 '$import_all'(Import, Target, Source, Reexport, weak).
2790'$import_list'(Target, Source, except(Spec), Reexport) :-
2791 !,
2792 '$exported_ops'(Source, Export, Predicates),
2793 '$module_property'(Source, exports(Predicates)),
2794 ( is_list(Spec)
2795 -> true
2796 ; throw(error(type_error(list, Spec), _))
2797 ),
2798 '$import_except'(Spec, Export, Import),
2799 '$import_all'(Import, Target, Source, Reexport, weak).
2800'$import_list'(Target, Source, Import, Reexport) :-
2801 !,
2802 is_list(Import),
2803 !,
2804 '$import_all'(Import, Target, Source, Reexport, strong).
2805'$import_list'(_, _, Import, _) :-
2806 throw(error(type_error(import_specifier, Import))).
2807
2808
2809'$import_except'([], List, List).
2810'$import_except'([H|T], List0, List) :-
2811 '$import_except_1'(H, List0, List1),
2812 '$import_except'(T, List1, List).
2813
2814'$import_except_1'(Var, _, _) :-
2815 var(Var),
2816 !,
2817 throw(error(instantitation_error, _)).
2818'$import_except_1'(PI as N, List0, List) :-
2819 '$pi'(PI), atom(N),
2820 !,
2821 '$canonical_pi'(PI, CPI),
2822 '$import_as'(CPI, N, List0, List).
2823'$import_except_1'(op(P,A,N), List0, List) :-
2824 !,
2825 '$remove_ops'(List0, op(P,A,N), List).
2826'$import_except_1'(PI, List0, List) :-
2827 '$pi'(PI),
2828 !,
2829 '$canonical_pi'(PI, CPI),
2830 '$select'(P, List0, List),
2831 '$canonical_pi'(CPI, P),
2832 !.
2833'$import_except_1'(Except, _, _) :-
2834 throw(error(type_error(import_specifier, Except), _)).
2835
2836'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
2837 '$canonical_pi'(PI2, CPI),
2838 !.
2839'$import_as'(PI, N, [H|T0], [H|T]) :-
2840 !,
2841 '$import_as'(PI, N, T0, T).
2842'$import_as'(PI, _, _, _) :-
2843 throw(error(existence_error(export, PI), _)).
2844
2845'$pi'(N/A) :- atom(N), integer(A), !.
2846'$pi'(N//A) :- atom(N), integer(A).
2847
2848'$canonical_pi'(N//A0, N/A) :-
2849 A is A0 + 2.
2850'$canonical_pi'(PI, PI).
2851
2852'$remove_ops'([], _, []).
2853'$remove_ops'([Op|T0], Pattern, T) :-
2854 subsumes_term(Pattern, Op),
2855 !,
2856 '$remove_ops'(T0, Pattern, T).
2857'$remove_ops'([H|T0], Pattern, [H|T]) :-
2858 '$remove_ops'(T0, Pattern, T).
2859
2860
2862
2863'$import_all'(Import, Context, Source, Reexport, Strength) :-
2864 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
2865 ( Reexport == true,
2866 ( '$list_to_conj'(Imported, Conj)
2867 -> export(Context:Conj),
2868 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
2869 ; true
2870 ),
2871 source_location(File, _Line),
2872 '$export_ops'(ImpOps, Context, File)
2873 ; true
2874 ).
2875
2877
2878'$import_all2'([], _, _, [], [], _).
2879'$import_all2'([PI as NewName|Rest], Context, Source,
2880 [NewName/Arity|Imported], ImpOps, Strength) :-
2881 !,
2882 '$canonical_pi'(PI, Name/Arity),
2883 length(Args, Arity),
2884 Head =.. [Name|Args],
2885 NewHead =.. [NewName|Args],
2886 ( '$get_predicate_attribute'(Source:Head, transparent, 1)
2887 -> '$set_predicate_attribute'(Context:NewHead, transparent, true)
2888 ; true
2889 ),
2890 ( source_location(File, Line)
2891 -> catch('$store_admin_clause'((NewHead :- Source:Head),
2892 _Layout, File, File:Line),
2893 E, '$print_message'(error, E))
2894 ; assertz((NewHead :- !, Source:Head)) 2895 ), 2896 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2897'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
2898 [op(P,A,N)|ImpOps], Strength) :-
2899 !,
2900 '$import_ops'(Context, Source, op(P,A,N)),
2901 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2902'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
2903 catch(Context:'$import'(Source:Pred, Strength), Error,
2904 print_message(error, Error)),
2905 '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
2906 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
2907
2908
2909'$list_to_conj'([One], One) :- !.
2910'$list_to_conj'([H|T], (H,Rest)) :-
2911 '$list_to_conj'(T, Rest).
2912
2917
2918'$exported_ops'(Module, Ops, Tail) :-
2919 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
2920 !,
2921 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
2922'$exported_ops'(_, Ops, Ops).
2923
2924'$exported_op'(Module, P, A, N) :-
2925 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
2926 Module:'$exported_op'(P, A, N).
2927
2932
2933'$import_ops'(To, From, Pattern) :-
2934 ground(Pattern),
2935 !,
2936 Pattern = op(P,A,N),
2937 op(P,A,To:N),
2938 ( '$exported_op'(From, P, A, N)
2939 -> true
2940 ; print_message(warning, no_exported_op(From, Pattern))
2941 ).
2942'$import_ops'(To, From, Pattern) :-
2943 ( '$exported_op'(From, Pri, Assoc, Name),
2944 Pattern = op(Pri, Assoc, Name),
2945 op(Pri, Assoc, To:Name),
2946 fail
2947 ; true
2948 ).
2949
2950
2955
2956'$export_list'(Decls, Module, Ops) :-
2957 is_list(Decls),
2958 !,
2959 '$do_export_list'(Decls, Module, Ops).
2960'$export_list'(Decls, _, _) :-
2961 var(Decls),
2962 throw(error(instantiation_error, _)).
2963'$export_list'(Decls, _, _) :-
2964 throw(error(type_error(list, Decls), _)).
2965
2966'$do_export_list'([], _, []) :- !.
2967'$do_export_list'([H|T], Module, Ops) :-
2968 !,
2969 catch('$export1'(H, Module, Ops, Ops1),
2970 E, ('$print_message'(error, E), Ops = Ops1)),
2971 '$do_export_list'(T, Module, Ops1).
2972
2973'$export1'(Var, _, _, _) :-
2974 var(Var),
2975 !,
2976 throw(error(instantiation_error, _)).
2977'$export1'(Op, _, [Op|T], T) :-
2978 Op = op(_,_,_),
2979 !.
2980'$export1'(PI, Module, Ops, Ops) :-
2981 export(Module:PI).
2982
2983'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
2984 catch(( op(Pri, Assoc, Module:Name),
2985 '$export_op'(Pri, Assoc, Name, Module, File)
2986 ),
2987 E, '$print_message'(error, E)),
2988 '$export_ops'(T, Module, File).
2989'$export_ops'([], _, _).
2990
2991'$export_op'(Pri, Assoc, Name, Module, File) :-
2992 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
2993 -> true
2994 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File)
2995 ),
2996 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
2997
3001
3002'$execute_directive'(Goal, F) :-
3003 '$execute_directive_2'(Goal, F).
3004
3005'$execute_directive_2'(encoding(Encoding), _F) :-
3006 !,
3007 ( '$load_input'(_F, S)
3008 -> set_stream(S, encoding(Encoding))
3009 ).
3010'$execute_directive_2'(ISO, F) :-
3011 '$expand_directive'(ISO, Normal),
3012 !,
3013 '$execute_directive'(Normal, F).
3014'$execute_directive_2'(Goal, _) :-
3015 \+ '$compilation_mode'(database),
3016 !,
3017 '$add_directive_wic2'(Goal, Type),
3018 ( Type == call 3019 -> '$compilation_mode'(Old, database),
3020 setup_call_cleanup(
3021 '$directive_mode'(OldDir, Old),
3022 '$execute_directive_3'(Goal),
3023 ( '$set_compilation_mode'(Old),
3024 '$set_directive_mode'(OldDir)
3025 ))
3026 ; '$execute_directive_3'(Goal)
3027 ).
3028'$execute_directive_2'(Goal, _) :-
3029 '$execute_directive_3'(Goal).
3030
3031'$execute_directive_3'(Goal) :-
3032 '$current_source_module'(Module),
3033 '$valid_directive'(Module:Goal),
3034 !,
3035 ( '$pattr_directive'(Goal, Module)
3036 -> true
3037 ; catch(Module:Goal, Term, '$exception_in_directive'(Term))
3038 -> true
3039 ; print_message(warning, goal_failed(directive, Module:Goal)),
3040 fail
3041 ).
3042'$execute_directive_3'(_).
3043
3044
3050
3051:- multifile prolog:sandbox_allowed_directive/1. 3052:- multifile prolog:sandbox_allowed_clause/1. 3053:- meta_predicate '$valid_directive'(:). 3054
3055'$valid_directive'(_) :-
3056 current_prolog_flag(sandboxed_load, false),
3057 !.
3058'$valid_directive'(Goal) :-
3059 catch(prolog:sandbox_allowed_directive(Goal), Error, true),
3060 !,
3061 ( var(Error)
3062 -> true
3063 ; print_message(error, Error),
3064 fail
3065 ).
3066'$valid_directive'(Goal) :-
3067 print_message(error,
3068 error(permission_error(execute,
3069 sandboxed_directive,
3070 Goal), _)),
3071 fail.
3072
3073'$exception_in_directive'(Term) :-
3074 print_message(error, Term),
3075 fail.
3076
3081
3082'$expand_directive'(Directive, Expanded) :-
3083 functor(Directive, Name, Arity),
3084 Arity > 1,
3085 '$iso_property_directive'(Name),
3086 Directive =.. [Name|Args],
3087 '$mk_normal_args'(Args, Normal),
3088 Expanded =.. [Name, Normal].
3089
3090'$iso_property_directive'(dynamic).
3091'$iso_property_directive'(multifile).
3092'$iso_property_directive'(discontiguous).
3093
3094'$mk_normal_args'([One], One).
3095'$mk_normal_args'([H|T0], (H,T)) :-
3096 '$mk_normal_args'(T0, T).
3097
3098
3102
3103'$add_directive_wic2'(Goal, Type) :-
3104 '$common_goal_type'(Goal, Type),
3105 !,
3106 ( Type == load
3107 -> true
3108 ; '$current_source_module'(Module),
3109 '$add_directive_wic'(Module:Goal)
3110 ).
3111'$add_directive_wic2'(Goal, _) :-
3112 ( '$compilation_mode'(qlf) 3113 -> true
3114 ; print_message(error, mixed_directive(Goal))
3115 ).
3116
3117'$common_goal_type'((A,B), Type) :-
3118 !,
3119 '$common_goal_type'(A, Type),
3120 '$common_goal_type'(B, Type).
3121'$common_goal_type'((A;B), Type) :-
3122 !,
3123 '$common_goal_type'(A, Type),
3124 '$common_goal_type'(B, Type).
3125'$common_goal_type'((A->B), Type) :-
3126 !,
3127 '$common_goal_type'(A, Type),
3128 '$common_goal_type'(B, Type).
3129'$common_goal_type'(Goal, Type) :-
3130 '$goal_type'(Goal, Type).
3131
3132'$goal_type'(Goal, Type) :-
3133 ( '$load_goal'(Goal)
3134 -> Type = load
3135 ; Type = call
3136 ).
3137
3138'$load_goal'([_|_]).
3139'$load_goal'(consult(_)).
3140'$load_goal'(load_files(_)).
3141'$load_goal'(load_files(_,Options)) :-
3142 memberchk(qcompile(QlfMode), Options),
3143 '$qlf_part_mode'(QlfMode).
3144'$load_goal'(ensure_loaded(_)) :- '$compilation_mode'(wic).
3145'$load_goal'(use_module(_)) :- '$compilation_mode'(wic).
3146'$load_goal'(use_module(_, _)) :- '$compilation_mode'(wic).
3147
3148'$qlf_part_mode'(part).
3149'$qlf_part_mode'(true). 3150
3151
3152 3155
3160
3161'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :-
3162 Owner \== (-),
3163 !,
3164 setup_call_cleanup(
3165 '$start_aux'(Owner, Context),
3166 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc),
3167 '$end_aux'(Owner, Context)).
3168'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
3169 '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
3170
3171'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
3172 ( '$compilation_mode'(database)
3173 -> '$record_clause'(Clause, File, SrcLoc)
3174 ; '$record_clause'(Clause, File, SrcLoc, Ref),
3175 '$qlf_assert_clause'(Ref, development)
3176 ).
3177
3185
3186'$store_clause'((_, _), _, _, _) :-
3187 !,
3188 print_message(error, cannot_redefine_comma),
3189 fail.
3190'$store_clause'(Clause, _Layout, File, SrcLoc) :-
3191 '$valid_clause'(Clause),
3192 !,
3193 ( '$compilation_mode'(database)
3194 -> '$record_clause'(Clause, File, SrcLoc)
3195 ; '$record_clause'(Clause, File, SrcLoc, Ref),
3196 '$qlf_assert_clause'(Ref, development)
3197 ).
3198
3199'$valid_clause'(_) :-
3200 current_prolog_flag(sandboxed_load, false),
3201 !.
3202'$valid_clause'(Clause) :-
3203 \+ '$cross_module_clause'(Clause),
3204 !.
3205'$valid_clause'(Clause) :-
3206 catch(prolog:sandbox_allowed_clause(Clause), Error, true),
3207 !,
3208 ( var(Error)
3209 -> true
3210 ; print_message(error, Error),
3211 fail
3212 ).
3213'$valid_clause'(Clause) :-
3214 print_message(error,
3215 error(permission_error(assert,
3216 sandboxed_clause,
3217 Clause), _)),
3218 fail.
3219
3220'$cross_module_clause'(Clause) :-
3221 '$head_module'(Clause, Module),
3222 \+ '$current_source_module'(Module).
3223
3224'$head_module'(Var, _) :-
3225 var(Var), !, fail.
3226'$head_module'((Head :- _), Module) :-
3227 '$head_module'(Head, Module).
3228'$head_module'(Module:_, Module).
3229
3230'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
3231'$clause_source'(Clause, Clause, -).
3232
3237
3238:- public
3239 '$store_clause'/2. 3240
3241'$store_clause'(Term, Id) :-
3242 '$clause_source'(Term, Clause, SrcLoc),
3243 '$store_clause'(Clause, _, Id, SrcLoc).
3244
3263
3264compile_aux_clauses(_Clauses) :-
3265 current_prolog_flag(xref, true),
3266 !.
3267compile_aux_clauses(Clauses) :-
3268 source_location(File, _Line),
3269 '$compile_aux_clauses'(Clauses, File).
3270
3271'$compile_aux_clauses'(Clauses, File) :-
3272 setup_call_cleanup(
3273 '$start_aux'(File, Context),
3274 '$store_aux_clauses'(Clauses, File),
3275 '$end_aux'(File, Context)).
3276
3277'$store_aux_clauses'(Clauses, File) :-
3278 is_list(Clauses),
3279 !,
3280 forall('$member'(C,Clauses),
3281 '$compile_term'(C, _Layout, File)).
3282'$store_aux_clauses'(Clause, File) :-
3283 '$compile_term'(Clause, _Layout, File).
3284
3285
3286 3289
3290:- multifile
3291 prolog:comment_hook/3. 3292
3293
3294 3297
3301
3302:- dynamic
3303 '$foreign_registered'/2. 3304
3305 3308
3311
3312:- dynamic
3313 '$expand_goal'/2,
3314 '$expand_term'/4. 3315
3316'$expand_goal'(In, In).
3317'$expand_term'(In, Layout, In, Layout).
3318
3319
3320 3323
3329
3330:- public '$compile_wic'/0. 3331
3332'$compile_wic' :-
3333 current_prolog_flag(os_argv, Argv),
3334 '$get_files_argv'(Argv, Files),
3335 '$translate_options'(Argv, Options),
3336 '$cmd_option_val'(compileout, Out),
3337 attach_packs,
3338 user:consult(Files),
3339 user:qsave_program(Out, Options).
3340
3341'$get_files_argv'([], []) :- !.
3342'$get_files_argv'(['-c'|Files], Files) :- !.
3343'$get_files_argv'([_|Rest], Files) :-
3344 '$get_files_argv'(Rest, Files).
3345
3346'$translate_options'([], []).
3347'$translate_options'([O|T0], [Opt|T]) :-
3348 atom_chars(O, [-,-|Rest]),
3349 '$split'(Rest, [=], Head, Tail),
3350 !,
3351 atom_chars(Name, Head),
3352 '$compile_option_type'(Name, Type),
3353 '$convert_option_value'(Type, Tail, Value),
3354 Opt =.. [Name, Value],
3355 '$translate_options'(T0, T).
3356'$translate_options'([_|T0], T) :-
3357 '$translate_options'(T0, T).
3358
3359'$split'(List, Split, [], Tail) :-
3360 '$append'(Split, Tail, List),
3361 !.
3362'$split'([H|T0], Split, [H|T], Tail) :-
3363 '$split'(T0, Split, T, Tail).
3364
3365'$compile_option_type'(argument, integer).
3366'$compile_option_type'(autoload, atom).
3367'$compile_option_type'(class, atom).
3368'$compile_option_type'(emulator, atom).
3369'$compile_option_type'(global, integer).
3370'$compile_option_type'(goal, callable).
3371'$compile_option_type'(init_file, atom).
3372'$compile_option_type'(local, integer).
3373'$compile_option_type'(map, atom).
3374'$compile_option_type'(op, atom).
3375'$compile_option_type'(stand_alone, atom).
3376'$compile_option_type'(toplevel, callable).
3377'$compile_option_type'(foreign, atom).
3378'$compile_option_type'(trail, integer).
3379
3380'$convert_option_value'(integer, Chars, Value) :-
3381 number_chars(Value, Chars).
3382'$convert_option_value'(atom, Chars, Value) :-
3383 atom_chars(Value, Chars).
3384'$convert_option_value'(callable, Chars, Value) :-
3385 atom_chars(Atom, Chars),
3386 term_to_atom(Value, Atom).
3387
3388
3389 3392
3393'$type_error'(Type, Value) :-
3394 ( var(Value)
3395 -> throw(error(instantiation_error, _))
3396 ; throw(error(type_error(Type, Value), _))
3397 ).
3398
3399'$domain_error'(Type, Value) :-
3400 throw(error(domain_error(Type, Value), _)).
3401
3402'$existence_error'(Type, Object) :-
3403 throw(error(existence_error(Type, Object), _)).
3404
3405'$permission_error'(Action, Type, Term) :-
3406 throw(error(permission_error(Action, Type, Term), _)).
3407
3408'$instantiation_error'(_Var) :-
3409 throw(error(instantiation_error, _)).
3410
3411'$must_be'(list, X) :-
3412 '$skip_list'(_, X, Tail),
3413 ( Tail == []
3414 -> true
3415 ; '$type_error'(list, Tail)
3416 ).
3417'$must_be'(options, X) :-
3418 ( '$is_options'(X)
3419 -> true
3420 ; '$type_error'(options, X)
3421 ).
3422'$must_be'(atom, X) :-
3423 ( atom(X)
3424 -> true
3425 ; '$type_error'(atom, X)
3426 ).
3427'$must_be'(callable, X) :-
3428 ( callable(X)
3429 -> true
3430 ; '$type_error'(callable, X)
3431 ).
3432'$must_be'(oneof(Type, Domain, List), X) :-
3433 '$must_be'(Type, X),
3434 ( memberchk(X, List)
3435 -> true
3436 ; '$domain_error'(Domain, X)
3437 ).
3438'$must_be'(boolean, X) :-
3439 ( (X == true ; X == false)
3440 -> true
3441 ; '$type_error'(boolean, X)
3442 ).
3443
3444
3445 3448
3449'$member'(El, [H|T]) :-
3450 '$member_'(T, El, H).
3451
3452'$member_'(_, El, El).
3453'$member_'([H|T], El, _) :-
3454 '$member_'(T, El, H).
3455
3456
3457'$append'([], L, L).
3458'$append'([H|T], L, [H|R]) :-
3459 '$append'(T, L, R).
3460
3461'$select'(X, [X|Tail], Tail).
3462'$select'(Elem, [Head|Tail], [Head|Rest]) :-
3463 '$select'(Elem, Tail, Rest).
3464
3465'$reverse'(L1, L2) :-
3466 '$reverse'(L1, [], L2).
3467
3468'$reverse'([], List, List).
3469'$reverse'([Head|List1], List2, List3) :-
3470 '$reverse'(List1, [Head|List2], List3).
3471
3472'$delete'([], _, []) :- !.
3473'$delete'([Elem|Tail], Elem, Result) :-
3474 !,
3475 '$delete'(Tail, Elem, Result).
3476'$delete'([Head|Tail], Elem, [Head|Rest]) :-
3477 '$delete'(Tail, Elem, Rest).
3478
3479'$last'([H|T], Last) :-
3480 '$last'(T, H, Last).
3481
3482'$last'([], Last, Last).
3483'$last'([H|T], _, Last) :-
3484 '$last'(T, H, Last).
3485
3486
3490
3491:- '$iso'((length/2)). 3492
3493length(List, Length) :-
3494 var(Length),
3495 !,
3496 '$skip_list'(Length0, List, Tail),
3497 ( Tail == []
3498 -> Length = Length0 3499 ; var(Tail)
3500 -> Tail \== Length, 3501 '$length3'(Tail, Length, Length0) 3502 ; throw(error(type_error(list, List),
3503 context(length/2, _)))
3504 ).
3505length(List, Length) :-
3506 integer(Length),
3507 Length >= 0,
3508 !,
3509 '$skip_list'(Length0, List, Tail),
3510 ( Tail == [] 3511 -> Length = Length0
3512 ; var(Tail)
3513 -> Extra is Length-Length0,
3514 '$length'(Tail, Extra)
3515 ; throw(error(type_error(list, List),
3516 context(length/2, _)))
3517 ).
3518length(_, Length) :-
3519 integer(Length),
3520 !,
3521 throw(error(domain_error(not_less_than_zero, Length),
3522 context(length/2, _))).
3523length(_, Length) :-
3524 throw(error(type_error(integer, Length),
3525 context(length/2, _))).
3526
3527'$length3'([], N, N).
3528'$length3'([_|List], N, N0) :-
3529 N1 is N0+1,
3530 '$length3'(List, N, N1).
3531
3532
3533 3536
3540
3541'$is_options'(Map) :-
3542 is_dict(Map, _),
3543 !.
3544'$is_options'(List) :-
3545 is_list(List),
3546 ( List == []
3547 -> true
3548 ; List = [H|_],
3549 '$is_option'(H, _, _)
3550 ).
3551
3552'$is_option'(Var, _, _) :-
3553 var(Var), !, fail.
3554'$is_option'(F, Name, Value) :-
3555 functor(F, _, 1),
3556 !,
3557 F =.. [Name,Value].
3558'$is_option'(Name=Value, Name, Value).
3559
3561
3562'$option'(Opt, Options) :-
3563 is_dict(Options),
3564 !,
3565 [Opt] :< Options.
3566'$option'(Opt, Options) :-
3567 memberchk(Opt, Options).
3568
3570
3571'$option'(Term, Options, Default) :-
3572 arg(1, Term, Value),
3573 functor(Term, Name, 1),
3574 ( is_dict(Options)
3575 -> ( get_dict(Name, Options, GVal)
3576 -> Value = GVal
3577 ; Value = Default
3578 )
3579 ; functor(Gen, Name, 1),
3580 arg(1, Gen, GVal),
3581 ( memberchk(Gen, Options)
3582 -> Value = GVal
3583 ; Value = Default
3584 )
3585 ).
3586
3592
3593'$select_option'(Opt, Options, Rest) :-
3594 select_dict([Opt], Options, Rest).
3595
3601
3602'$merge_options'(New, Old, Merged) :-
3603 put_dict(New, Old, Merged).
3604
3605
3606 3609
3610:- public '$prolog_list_goal'/1. 3611
3612:- multifile
3613 user:prolog_list_goal/1. 3614
3615'$prolog_list_goal'(Goal) :-
3616 user:prolog_list_goal(Goal),
3617 !.
3618'$prolog_list_goal'(Goal) :-
3619 user:listing(Goal).
3620
3621
3622 3625
3626:- '$iso'((halt/0)). 3627
3628halt :-
3629 halt(0).
3630
3631
3637
3638:- meta_predicate at_halt(0). 3639:- dynamic system:term_expansion/2, '$at_halt'/2. 3640:- multifile system:term_expansion/2, '$at_halt'/2. 3641
3642system:term_expansion((:- at_halt(Goal)),
3643 system:'$at_halt'(Module:Goal, File:Line)) :-
3644 \+ current_prolog_flag(xref, true),
3645 source_location(File, Line),
3646 '$current_source_module'(Module).
3647
3648at_halt(Goal) :-
3649 asserta('$at_halt'(Goal, (-):0)).
3650
3651:- public '$run_at_halt'/0. 3652
3653'$run_at_halt' :-
3654 forall(clause('$at_halt'(Goal, Src), true, Ref),
3655 ( '$call_at_halt'(Goal, Src),
3656 erase(Ref)
3657 )).
3658
3659'$call_at_halt'(Goal, _Src) :-
3660 catch(Goal, E, true),
3661 !,
3662 ( var(E)
3663 -> true
3664 ; subsumes_term(cancel_halt(_), E)
3665 -> '$print_message'(informational, E),
3666 fail
3667 ; '$print_message'(error, E)
3668 ).
3669'$call_at_halt'(Goal, _Src) :-
3670 '$print_message'(warning, goal_failed(at_halt, Goal)).
3671
3677
3678cancel_halt(Reason) :-
3679 throw(cancel_halt(Reason)).
3680
3681
3682 3685
3686:- meta_predicate
3687 '$load_wic_files'(:). 3688
3689'$load_wic_files'(Files) :-
3690 Files = Module:_,
3691 '$execute_directive'('$set_source_module'(OldM, Module), []),
3692 '$save_lex_state'(LexState, []),
3693 '$style_check'(_, 0xC7), 3694 '$compilation_mode'(OldC, wic),
3695 consult(Files),
3696 '$execute_directive'('$set_source_module'(OldM), []),
3697 '$execute_directive'('$restore_lex_state'(LexState), []),
3698 '$set_compilation_mode'(OldC).
3699
3700
3705
3706:- public '$load_additional_boot_files'/0. 3707
3708'$load_additional_boot_files' :-
3709 current_prolog_flag(argv, Argv),
3710 '$get_files_argv'(Argv, Files),
3711 ( Files \== []
3712 -> format('Loading additional boot files~n'),
3713 '$load_wic_files'(user:Files),
3714 format('additional boot files loaded~n')
3715 ; true
3716 ).
3717
3718'$:-'((format('Loading Prolog startup files~n', []),
3719 source_location(File, _Line),
3720 file_directory_name(File, Dir),
3721 atom_concat(Dir, '/load.pl', LoadFile),
3722 '$load_wic_files'(system:[LoadFile]),
3723 ( current_prolog_flag(windows, true)
3724 -> atom_concat(Dir, '/menu.pl', MenuFile),
3725 '$load_wic_files'(system:[MenuFile])
3726 ; true
3727 ),
3728 format('SWI-Prolog boot files loaded~n', []),
3729 '$compilation_mode'(OldC, wic),
3730 '$execute_directive'('$set_source_module'(user), []),
3731 '$set_compilation_mode'(OldC)
3732 ))