37
52
53 56
57:- '$set_source_module'(system). 58
59'$boot_message'(_Format, _Args) :-
60 current_prolog_flag(verbose, silent),
61 !.
62'$boot_message'(Format, Args) :-
63 format(Format, Args),
64 !.
65
66'$:-'('$boot_message'('Loading boot file ...~n', [])).
67
68
75
76memberchk(E, List) :-
77 '$memberchk'(E, List, Tail),
78 ( nonvar(Tail)
79 -> true
80 ; Tail = [_|_],
81 memberchk(E, Tail)
82 ).
83
84 87
88:- meta_predicate
89 dynamic(:),
90 multifile(:),
91 public(:),
92 module_transparent(:),
93 discontiguous(:),
94 volatile(:),
95 thread_local(:),
96 noprofile(:),
97 non_terminal(:),
98 det(:),
99 '$clausable'(:),
100 '$iso'(:),
101 '$hide'(:),
102 '$notransact'(:). 103
117
122
129
133
134dynamic(Spec) :- '$set_pattr'(Spec, pred, dynamic(true)).
135multifile(Spec) :- '$set_pattr'(Spec, pred, multifile(true)).
136module_transparent(Spec) :- '$set_pattr'(Spec, pred, transparent(true)).
137discontiguous(Spec) :- '$set_pattr'(Spec, pred, discontiguous(true)).
138volatile(Spec) :- '$set_pattr'(Spec, pred, volatile(true)).
139thread_local(Spec) :- '$set_pattr'(Spec, pred, thread_local(true)).
140noprofile(Spec) :- '$set_pattr'(Spec, pred, noprofile(true)).
141public(Spec) :- '$set_pattr'(Spec, pred, public(true)).
142non_terminal(Spec) :- '$set_pattr'(Spec, pred, non_terminal(true)).
143det(Spec) :- '$set_pattr'(Spec, pred, det(true)).
144'$iso'(Spec) :- '$set_pattr'(Spec, pred, iso(true)).
145'$clausable'(Spec) :- '$set_pattr'(Spec, pred, clausable(true)).
146'$hide'(Spec) :- '$set_pattr'(Spec, pred, trace(false)).
147'$notransact'(Spec) :- '$set_pattr'(Spec, pred, transact(false)).
148
149'$set_pattr'(M:Pred, How, Attr) :-
150 '$set_pattr'(Pred, M, How, Attr).
151
155
156'$set_pattr'(X, _, _, _) :-
157 var(X),
158 '$uninstantiation_error'(X).
159'$set_pattr'(as(Spec,Options), M, How, Attr0) :-
160 !,
161 '$attr_options'(Options, Attr0, Attr),
162 '$set_pattr'(Spec, M, How, Attr).
163'$set_pattr'([], _, _, _) :- !.
164'$set_pattr'([H|T], M, How, Attr) :- 165 !,
166 '$set_pattr'(H, M, How, Attr),
167 '$set_pattr'(T, M, How, Attr).
168'$set_pattr'((A,B), M, How, Attr) :- 169 !,
170 '$set_pattr'(A, M, How, Attr),
171 '$set_pattr'(B, M, How, Attr).
172'$set_pattr'(M:T, _, How, Attr) :-
173 !,
174 '$set_pattr'(T, M, How, Attr).
175'$set_pattr'(PI, M, _, []) :-
176 !,
177 '$pi_head'(M:PI, Pred),
178 '$set_table_wrappers'(Pred).
179'$set_pattr'(A, M, How, [O|OT]) :-
180 !,
181 '$set_pattr'(A, M, How, O),
182 '$set_pattr'(A, M, How, OT).
183'$set_pattr'(A, M, pred, Attr) :-
184 !,
185 Attr =.. [Name,Val],
186 '$set_pi_attr'(M:A, Name, Val).
187'$set_pattr'(A, M, directive, Attr) :-
188 !,
189 Attr =.. [Name,Val],
190 catch('$set_pi_attr'(M:A, Name, Val),
191 error(E, _),
192 print_message(error, error(E, context((Name)/1,_)))).
193
194'$set_pi_attr'(PI, Name, Val) :-
195 '$pi_head'(PI, Head),
196 '$set_predicate_attribute'(Head, Name, Val).
197
198'$attr_options'(Var, _, _) :-
199 var(Var),
200 !,
201 '$uninstantiation_error'(Var).
202'$attr_options'((A,B), Attr0, Attr) :-
203 !,
204 '$attr_options'(A, Attr0, Attr1),
205 '$attr_options'(B, Attr1, Attr).
206'$attr_options'(Opt, Attr0, Attrs) :-
207 '$must_be'(ground, Opt),
208 ( '$attr_option'(Opt, AttrX)
209 -> ( is_list(Attr0)
210 -> '$join_attrs'(AttrX, Attr0, Attrs)
211 ; '$join_attrs'(AttrX, [Attr0], Attrs)
212 )
213 ; '$domain_error'(predicate_option, Opt)
214 ).
215
216'$join_attrs'([], Attrs, Attrs) :-
217 !.
218'$join_attrs'([H|T], Attrs0, Attrs) :-
219 !,
220 '$join_attrs'(H, Attrs0, Attrs1),
221 '$join_attrs'(T, Attrs1, Attrs).
222'$join_attrs'(Attr, Attrs, Attrs) :-
223 memberchk(Attr, Attrs),
224 !.
225'$join_attrs'(Attr, Attrs, Attrs) :-
226 Attr =.. [Name,Value],
227 Gen =.. [Name,Existing],
228 memberchk(Gen, Attrs),
229 !,
230 throw(error(conflict_error(Name, Value, Existing), _)).
231'$join_attrs'(Attr, Attrs0, Attrs) :-
232 '$append'(Attrs0, [Attr], Attrs).
233
234'$attr_option'(incremental, [incremental(true),opaque(false)]).
235'$attr_option'(monotonic, monotonic(true)).
236'$attr_option'(lazy, lazy(true)).
237'$attr_option'(opaque, [incremental(false),opaque(true)]).
238'$attr_option'(abstract(Level0), abstract(Level)) :-
239 '$table_option'(Level0, Level).
240'$attr_option'(subgoal_abstract(Level0), subgoal_abstract(Level)) :-
241 '$table_option'(Level0, Level).
242'$attr_option'(answer_abstract(Level0), answer_abstract(Level)) :-
243 '$table_option'(Level0, Level).
244'$attr_option'(max_answers(Level0), max_answers(Level)) :-
245 '$table_option'(Level0, Level).
246'$attr_option'(volatile, volatile(true)).
247'$attr_option'(multifile, multifile(true)).
248'$attr_option'(discontiguous, discontiguous(true)).
249'$attr_option'(shared, thread_local(false)).
250'$attr_option'(local, thread_local(true)).
251'$attr_option'(private, thread_local(true)).
252
253'$table_option'(Value0, _Value) :-
254 var(Value0),
255 !,
256 '$instantiation_error'(Value0).
257'$table_option'(Value0, Value) :-
258 integer(Value0),
259 Value0 >= 0,
260 !,
261 Value = Value0.
262'$table_option'(off, -1) :-
263 !.
264'$table_option'(false, -1) :-
265 !.
266'$table_option'(infinite, -1) :-
267 !.
268'$table_option'(Value, _) :-
269 '$domain_error'(nonneg_or_false, Value).
270
271
278
279'$pattr_directive'(dynamic(Spec), M) :-
280 '$set_pattr'(Spec, M, directive, dynamic(true)).
281'$pattr_directive'(multifile(Spec), M) :-
282 '$set_pattr'(Spec, M, directive, multifile(true)).
283'$pattr_directive'(module_transparent(Spec), M) :-
284 '$set_pattr'(Spec, M, directive, transparent(true)).
285'$pattr_directive'(discontiguous(Spec), M) :-
286 '$set_pattr'(Spec, M, directive, discontiguous(true)).
287'$pattr_directive'(volatile(Spec), M) :-
288 '$set_pattr'(Spec, M, directive, volatile(true)).
289'$pattr_directive'(thread_local(Spec), M) :-
290 '$set_pattr'(Spec, M, directive, thread_local(true)).
291'$pattr_directive'(noprofile(Spec), M) :-
292 '$set_pattr'(Spec, M, directive, noprofile(true)).
293'$pattr_directive'(public(Spec), M) :-
294 '$set_pattr'(Spec, M, directive, public(true)).
295'$pattr_directive'(det(Spec), M) :-
296 '$set_pattr'(Spec, M, directive, det(true)).
297
299
300'$pi_head'(PI, Head) :-
301 var(PI),
302 var(Head),
303 '$instantiation_error'([PI,Head]).
304'$pi_head'(M:PI, M:Head) :-
305 !,
306 '$pi_head'(PI, Head).
307'$pi_head'(Name/Arity, Head) :-
308 !,
309 '$head_name_arity'(Head, Name, Arity).
310'$pi_head'(Name//DCGArity, Head) :-
311 !,
312 ( nonvar(DCGArity)
313 -> Arity is DCGArity+2,
314 '$head_name_arity'(Head, Name, Arity)
315 ; '$head_name_arity'(Head, Name, Arity),
316 DCGArity is Arity - 2
317 ).
318'$pi_head'(PI, _) :-
319 '$type_error'(predicate_indicator, PI).
320
323
324'$head_name_arity'(Goal, Name, Arity) :-
325 ( atom(Goal)
326 -> Name = Goal, Arity = 0
327 ; compound(Goal)
328 -> compound_name_arity(Goal, Name, Arity)
329 ; var(Goal)
330 -> ( Arity == 0
331 -> ( atom(Name)
332 -> Goal = Name
333 ; Name == []
334 -> Goal = Name
335 ; blob(Name, closure)
336 -> Goal = Name
337 ; '$type_error'(atom, Name)
338 )
339 ; compound_name_arity(Goal, Name, Arity)
340 )
341 ; '$type_error'(callable, Goal)
342 ).
343
344:- '$iso'(((dynamic)/1, (multifile)/1, (discontiguous)/1)). 345
346
347 350
351:- noprofile((call/1,
352 catch/3,
353 once/1,
354 ignore/1,
355 call_cleanup/2,
356 setup_call_cleanup/3,
357 setup_call_catcher_cleanup/4,
358 notrace/1)). 359
360:- meta_predicate
361 ';'(0,0),
362 ','(0,0),
363 @(0,+),
364 call(0),
365 call(1,?),
366 call(2,?,?),
367 call(3,?,?,?),
368 call(4,?,?,?,?),
369 call(5,?,?,?,?,?),
370 call(6,?,?,?,?,?,?),
371 call(7,?,?,?,?,?,?,?),
372 not(0),
373 \+(0),
374 $(0),
375 '->'(0,0),
376 '*->'(0,0),
377 once(0),
378 ignore(0),
379 catch(0,?,0),
380 reset(0,?,-),
381 setup_call_cleanup(0,0,0),
382 setup_call_catcher_cleanup(0,0,?,0),
383 call_cleanup(0,0),
384 catch_with_backtrace(0,?,0),
385 notrace(0),
386 '$meta_call'(0). 387
388:- '$iso'((call/1, (\+)/1, once/1, (;)/2, (',')/2, (->)/2, catch/3)). 389
397
398(M0:If ; M0:Then) :- !, call(M0:(If ; Then)).
399(M1:If ; M2:Then) :- call(M1:(If ; M2:Then)).
400(G1 , G2) :- call((G1 , G2)).
401(If -> Then) :- call((If -> Then)).
402(If *-> Then) :- call((If *-> Then)).
403@(Goal,Module) :- @(Goal,Module).
404
416
417'$meta_call'(M:G) :-
418 prolog_current_choice(Ch),
419 '$meta_call'(G, M, Ch).
420
421'$meta_call'(Var, _, _) :-
422 var(Var),
423 !,
424 '$instantiation_error'(Var).
425'$meta_call'((A,B), M, Ch) :-
426 !,
427 '$meta_call'(A, M, Ch),
428 '$meta_call'(B, M, Ch).
429'$meta_call'((I->T;E), M, Ch) :-
430 !,
431 ( prolog_current_choice(Ch2),
432 '$meta_call'(I, M, Ch2)
433 -> '$meta_call'(T, M, Ch)
434 ; '$meta_call'(E, M, Ch)
435 ).
436'$meta_call'((I*->T;E), M, Ch) :-
437 !,
438 ( prolog_current_choice(Ch2),
439 '$meta_call'(I, M, Ch2)
440 *-> '$meta_call'(T, M, Ch)
441 ; '$meta_call'(E, M, Ch)
442 ).
443'$meta_call'((I->T), M, Ch) :-
444 !,
445 ( prolog_current_choice(Ch2),
446 '$meta_call'(I, M, Ch2)
447 -> '$meta_call'(T, M, Ch)
448 ).
449'$meta_call'((I*->T), M, Ch) :-
450 !,
451 prolog_current_choice(Ch2),
452 '$meta_call'(I, M, Ch2),
453 '$meta_call'(T, M, Ch).
454'$meta_call'((A;B), M, Ch) :-
455 !,
456 ( '$meta_call'(A, M, Ch)
457 ; '$meta_call'(B, M, Ch)
458 ).
459'$meta_call'(\+(G), M, _) :-
460 !,
461 prolog_current_choice(Ch),
462 \+ '$meta_call'(G, M, Ch).
463'$meta_call'($(G), M, _) :-
464 !,
465 prolog_current_choice(Ch),
466 $('$meta_call'(G, M, Ch)).
467'$meta_call'(call(G), M, _) :-
468 !,
469 prolog_current_choice(Ch),
470 '$meta_call'(G, M, Ch).
471'$meta_call'(M:G, _, Ch) :-
472 !,
473 '$meta_call'(G, M, Ch).
474'$meta_call'(!, _, Ch) :-
475 prolog_cut_to(Ch).
476'$meta_call'(G, M, _Ch) :-
477 call(M:G).
478
492
493:- '$iso'((call/2,
494 call/3,
495 call/4,
496 call/5,
497 call/6,
498 call/7,
499 call/8)). 500
501call(Goal) :- 502 Goal.
503call(Goal, A) :-
504 call(Goal, A).
505call(Goal, A, B) :-
506 call(Goal, A, B).
507call(Goal, A, B, C) :-
508 call(Goal, A, B, C).
509call(Goal, A, B, C, D) :-
510 call(Goal, A, B, C, D).
511call(Goal, A, B, C, D, E) :-
512 call(Goal, A, B, C, D, E).
513call(Goal, A, B, C, D, E, F) :-
514 call(Goal, A, B, C, D, E, F).
515call(Goal, A, B, C, D, E, F, G) :-
516 call(Goal, A, B, C, D, E, F, G).
517
522
523not(Goal) :-
524 \+ Goal.
525
529
530\+ Goal :-
531 \+ Goal.
532
536
537once(Goal) :-
538 Goal,
539 !.
540
545
546ignore(Goal) :-
547 Goal,
548 !.
549ignore(_Goal).
550
551:- '$iso'((false/0)). 552
556
557false :-
558 fail.
559
563
564catch(_Goal, _Catcher, _Recover) :-
565 '$catch'. 566
570
571prolog_cut_to(_Choice) :-
572 '$cut'. 573
577
578'$' :- '$'.
579
583
584$(Goal) :- $(Goal).
585
589
590:- '$hide'(notrace/1). 591
592notrace(Goal) :-
593 setup_call_cleanup(
594 '$notrace'(Flags, SkipLevel),
595 once(Goal),
596 '$restore_trace'(Flags, SkipLevel)).
597
598
602
603reset(_Goal, _Ball, _Cont) :-
604 '$reset'.
605
612
613shift(Ball) :-
614 '$shift'(Ball).
615
616shift_for_copy(Ball) :-
617 '$shift_for_copy'(Ball).
618
630
631call_continuation([]).
632call_continuation([TB|Rest]) :-
633 ( Rest == []
634 -> '$call_continuation'(TB)
635 ; '$call_continuation'(TB),
636 call_continuation(Rest)
637 ).
638
643
644catch_with_backtrace(Goal, Ball, Recover) :-
645 catch(Goal, Ball, Recover),
646 '$no_lco'.
647
648'$no_lco'.
649
657
658:- public '$recover_and_rethrow'/2. 659
660'$recover_and_rethrow'(Goal, Exception) :-
661 call_cleanup(Goal, throw(Exception)),
662 !.
663
664
675
676setup_call_catcher_cleanup(Setup, _Goal, _Catcher, _Cleanup) :-
677 sig_atomic(Setup),
678 '$call_cleanup'.
679
680setup_call_cleanup(Setup, _Goal, _Cleanup) :-
681 sig_atomic(Setup),
682 '$call_cleanup'.
683
684call_cleanup(_Goal, _Cleanup) :-
685 '$call_cleanup'.
686
687
688 691
692:- meta_predicate
693 initialization(0, +). 694
695:- multifile '$init_goal'/3. 696:- dynamic '$init_goal'/3. 697:- '$notransact'('$init_goal'/3). 698
722
723initialization(Goal, When) :-
724 '$must_be'(oneof(atom, initialization_type,
725 [ now,
726 after_load,
727 restore,
728 restore_state,
729 prepare_state,
730 program,
731 main
732 ]), When),
733 '$initialization_context'(Source, Ctx),
734 '$initialization'(When, Goal, Source, Ctx).
735
736'$initialization'(now, Goal, _Source, Ctx) :-
737 '$run_init_goal'(Goal, Ctx),
738 '$compile_init_goal'(-, Goal, Ctx).
739'$initialization'(after_load, Goal, Source, Ctx) :-
740 ( Source \== (-)
741 -> '$compile_init_goal'(Source, Goal, Ctx)
742 ; throw(error(context_error(nodirective,
743 initialization(Goal, after_load)),
744 _))
745 ).
746'$initialization'(restore, Goal, Source, Ctx) :- 747 '$initialization'(restore_state, Goal, Source, Ctx).
748'$initialization'(restore_state, Goal, _Source, Ctx) :-
749 ( \+ current_prolog_flag(sandboxed_load, true)
750 -> '$compile_init_goal'(-, Goal, Ctx)
751 ; '$permission_error'(register, initialization(restore), Goal)
752 ).
753'$initialization'(prepare_state, Goal, _Source, Ctx) :-
754 ( \+ current_prolog_flag(sandboxed_load, true)
755 -> '$compile_init_goal'(when(prepare_state), Goal, Ctx)
756 ; '$permission_error'(register, initialization(restore), Goal)
757 ).
758'$initialization'(program, Goal, _Source, Ctx) :-
759 ( \+ current_prolog_flag(sandboxed_load, true)
760 -> '$compile_init_goal'(when(program), Goal, Ctx)
761 ; '$permission_error'(register, initialization(restore), Goal)
762 ).
763'$initialization'(main, Goal, _Source, Ctx) :-
764 ( \+ current_prolog_flag(sandboxed_load, true)
765 -> '$compile_init_goal'(when(main), Goal, Ctx)
766 ; '$permission_error'(register, initialization(restore), Goal)
767 ).
768
769
770'$compile_init_goal'(Source, Goal, Ctx) :-
771 atom(Source),
772 Source \== (-),
773 !,
774 '$store_admin_clause'(system:'$init_goal'(Source, Goal, Ctx),
775 _Layout, Source, Ctx).
776'$compile_init_goal'(Source, Goal, Ctx) :-
777 assertz('$init_goal'(Source, Goal, Ctx)).
778
779
788
789'$run_initialization'(_, loaded, _) :- !.
790'$run_initialization'(File, _Action, Options) :-
791 '$run_initialization'(File, Options).
792
793'$run_initialization'(File, Options) :-
794 setup_call_cleanup(
795 '$start_run_initialization'(Options, Restore),
796 '$run_initialization_2'(File),
797 '$end_run_initialization'(Restore)).
798
799'$start_run_initialization'(Options, OldSandBoxed) :-
800 '$push_input_context'(initialization),
801 '$set_sandboxed_load'(Options, OldSandBoxed).
802'$end_run_initialization'(OldSandBoxed) :-
803 set_prolog_flag(sandboxed_load, OldSandBoxed),
804 '$pop_input_context'.
805
806'$run_initialization_2'(File) :-
807 ( '$init_goal'(File, Goal, Ctx),
808 File \= when(_),
809 '$run_init_goal'(Goal, Ctx),
810 fail
811 ; true
812 ).
813
814'$run_init_goal'(Goal, Ctx) :-
815 ( catch_with_backtrace('$run_init_goal'(Goal), E,
816 '$initialization_error'(E, Goal, Ctx))
817 -> true
818 ; '$initialization_failure'(Goal, Ctx)
819 ).
820
821:- multifile prolog:sandbox_allowed_goal/1. 822
823'$run_init_goal'(Goal) :-
824 current_prolog_flag(sandboxed_load, false),
825 !,
826 call(Goal).
827'$run_init_goal'(Goal) :-
828 prolog:sandbox_allowed_goal(Goal),
829 call(Goal).
830
831'$initialization_context'(Source, Ctx) :-
832 ( source_location(File, Line)
833 -> Ctx = File:Line,
834 '$input_context'(Context),
835 '$top_file'(Context, File, Source)
836 ; Ctx = (-),
837 File = (-)
838 ).
839
840'$top_file'([input(include, F1, _, _)|T], _, F) :-
841 !,
842 '$top_file'(T, F1, F).
843'$top_file'(_, F, F).
844
845
846'$initialization_error'(E, Goal, Ctx) :-
847 print_message(error, initialization_error(Goal, E, Ctx)).
848
849'$initialization_failure'(Goal, Ctx) :-
850 print_message(warning, initialization_failure(Goal, Ctx)).
851
857
858:- public '$clear_source_admin'/1. 859
860'$clear_source_admin'(File) :-
861 retractall('$init_goal'(_, _, File:_)),
862 retractall('$load_context_module'(File, _, _)),
863 retractall('$resolved_source_path_db'(_, _, File)).
864
865
866 869
870:- '$iso'(stream_property/2). 871stream_property(Stream, Property) :-
872 nonvar(Stream),
873 nonvar(Property),
874 !,
875 '$stream_property'(Stream, Property).
876stream_property(Stream, Property) :-
877 nonvar(Stream),
878 !,
879 '$stream_properties'(Stream, Properties),
880 '$member'(Property, Properties).
881stream_property(Stream, Property) :-
882 nonvar(Property),
883 !,
884 ( Property = alias(Alias),
885 atom(Alias)
886 -> '$alias_stream'(Alias, Stream)
887 ; '$streams_properties'(Property, Pairs),
888 '$member'(Stream-Property, Pairs)
889 ).
890stream_property(Stream, Property) :-
891 '$streams_properties'(Property, Pairs),
892 '$member'(Stream-Properties, Pairs),
893 '$member'(Property, Properties).
894
895
896 899
902
903'$prefix_module'(Module, Module, Head, Head) :- !.
904'$prefix_module'(Module, _, Head, Module:Head).
905
909
910default_module(Me, Super) :-
911 ( atom(Me)
912 -> ( var(Super)
913 -> '$default_module'(Me, Super)
914 ; '$default_module'(Me, Super), !
915 )
916 ; '$type_error'(module, Me)
917 ).
918
919'$default_module'(Me, Me).
920'$default_module'(Me, Super) :-
921 import_module(Me, S),
922 '$default_module'(S, Super).
923
924
925 928
929:- dynamic user:exception/3. 930:- multifile user:exception/3. 931:- '$hide'(user:exception/3). 932
939
940:- public
941 '$undefined_procedure'/4. 942
943'$undefined_procedure'(Module, Name, Arity, Action) :-
944 '$prefix_module'(Module, user, Name/Arity, Pred),
945 user:exception(undefined_predicate, Pred, Action0),
946 !,
947 Action = Action0.
948'$undefined_procedure'(Module, Name, Arity, Action) :-
949 \+ current_prolog_flag(autoload, false),
950 '$autoload'(Module:Name/Arity),
951 !,
952 Action = retry.
953'$undefined_procedure'(_, _, _, error).
954
955
964
965'$loading'(Library) :-
966 current_prolog_flag(threads, true),
967 ( '$loading_file'(Library, _Queue, _LoadThread)
968 -> true
969 ; '$loading_file'(FullFile, _Queue, _LoadThread),
970 file_name_extension(Library, _, FullFile)
971 -> true
972 ).
973
975
976'$set_debugger_write_options'(write) :-
977 !,
978 create_prolog_flag(debugger_write_options,
979 [ quoted(true),
980 attributes(dots),
981 spacing(next_argument)
982 ], []).
983'$set_debugger_write_options'(print) :-
984 !,
985 create_prolog_flag(debugger_write_options,
986 [ quoted(true),
987 portray(true),
988 max_depth(10),
989 attributes(portray),
990 spacing(next_argument)
991 ], []).
992'$set_debugger_write_options'(Depth) :-
993 current_prolog_flag(debugger_write_options, Options0),
994 ( '$select'(max_depth(_), Options0, Options)
995 -> true
996 ; Options = Options0
997 ),
998 create_prolog_flag(debugger_write_options,
999 [max_depth(Depth)|Options], []).
1000
1001
1002 1005
1012
1013:- multifile
1014 prolog:confirm/2. 1015
1016'$confirm'(Spec) :-
1017 prolog:confirm(Spec, Result),
1018 !,
1019 Result == true.
1020'$confirm'(Spec) :-
1021 print_message(query, Spec),
1022 between(0, 5, _),
1023 get_single_char(Answer),
1024 ( '$in_reply'(Answer, 'yYjJ \n')
1025 -> !,
1026 print_message(query, if_tty([yes-[]]))
1027 ; '$in_reply'(Answer, 'nN')
1028 -> !,
1029 print_message(query, if_tty([no-[]])),
1030 fail
1031 ; print_message(help, query(confirm)),
1032 fail
1033 ).
1034
1035'$in_reply'(Code, Atom) :-
1036 char_code(Char, Code),
1037 sub_atom(Atom, _, _, _, Char),
1038 !.
1039
1040:- dynamic
1041 user:portray/1. 1042:- multifile
1043 user:portray/1. 1044:- '$notransact'(user:portray/1). 1045
1046
1047 1050
1051:- dynamic
1052 user:file_search_path/2,
1053 user:library_directory/1. 1054:- multifile
1055 user:file_search_path/2,
1056 user:library_directory/1. 1057:- '$notransact'((user:file_search_path/2,
1058 user:library_directory/1)). 1059
1060user:(file_search_path(library, Dir) :-
1061 library_directory(Dir)).
1062user:file_search_path(swi, Home) :-
1063 current_prolog_flag(home, Home).
1064user:file_search_path(swi, Home) :-
1065 current_prolog_flag(shared_home, Home).
1066user:file_search_path(library, app_config(lib)).
1067user:file_search_path(library, swi(library)).
1068user:file_search_path(library, swi(library/clp)).
1069user:file_search_path(library, Dir) :-
1070 '$ext_library_directory'(Dir).
1071user:file_search_path(foreign, swi(ArchLib)) :-
1072 current_prolog_flag(apple_universal_binary, true),
1073 ArchLib = 'lib/fat-darwin'.
1074user:file_search_path(path, Dir) :-
1075 getenv('PATH', Path),
1076 current_prolog_flag(path_sep, Sep),
1077 atomic_list_concat(Dirs, Sep, Path),
1078 '$member'(Dir, Dirs).
1079user:file_search_path(user_app_data, Dir) :-
1080 '$xdg_prolog_directory'(data, Dir).
1081user:file_search_path(common_app_data, Dir) :-
1082 '$xdg_prolog_directory'(common_data, Dir).
1083user:file_search_path(user_app_config, Dir) :-
1084 '$xdg_prolog_directory'(config, Dir).
1085user:file_search_path(common_app_config, Dir) :-
1086 '$xdg_prolog_directory'(common_config, Dir).
1087user:file_search_path(app_data, user_app_data('.')).
1088user:file_search_path(app_data, common_app_data('.')).
1089user:file_search_path(app_config, user_app_config('.')).
1090user:file_search_path(app_config, common_app_config('.')).
1092user:file_search_path(app_preferences, user_app_config('.')).
1093user:file_search_path(user_profile, app_preferences('.')).
1094user:file_search_path(app, swi(app)).
1095user:file_search_path(app, app_data(app)).
1096user:file_search_path(working_directory, CWD) :-
1097 working_directory(CWD, CWD).
1098
1099'$xdg_prolog_directory'(Which, Dir) :-
1100 '$xdg_directory'(Which, XDGDir),
1101 '$make_config_dir'(XDGDir),
1102 '$ensure_slash'(XDGDir, XDGDirS),
1103 atom_concat(XDGDirS, 'swi-prolog', Dir),
1104 '$make_config_dir'(Dir).
1105
1106'$xdg_directory'(Which, Dir) :-
1107 '$xdg_directory_search'(Where),
1108 '$xdg_directory'(Which, Where, Dir).
1109
1110'$xdg_directory_search'(xdg) :-
1111 current_prolog_flag(xdg, true),
1112 !.
1113'$xdg_directory_search'(Where) :-
1114 current_prolog_flag(windows, true),
1115 ( current_prolog_flag(xdg, false)
1116 -> Where = windows
1117 ; '$member'(Where, [windows, xdg])
1118 ).
1119
1121'$xdg_directory'(config, windows, Home) :-
1122 catch(win_folder(appdata, Home), _, fail).
1123'$xdg_directory'(config, xdg, Home) :-
1124 getenv('XDG_CONFIG_HOME', Home).
1125'$xdg_directory'(config, xdg, Home) :-
1126 expand_file_name('~/.config', [Home]).
1128'$xdg_directory'(data, windows, Home) :-
1129 catch(win_folder(local_appdata, Home), _, fail).
1130'$xdg_directory'(data, xdg, Home) :-
1131 getenv('XDG_DATA_HOME', Home).
1132'$xdg_directory'(data, xdg, Home) :-
1133 expand_file_name('~/.local', [Local]),
1134 '$make_config_dir'(Local),
1135 atom_concat(Local, '/share', Home),
1136 '$make_config_dir'(Home).
1138'$xdg_directory'(common_data, windows, Dir) :-
1139 catch(win_folder(common_appdata, Dir), _, fail).
1140'$xdg_directory'(common_data, xdg, Dir) :-
1141 '$existing_dir_from_env_path'('XDG_DATA_DIRS',
1142 [ '/usr/local/share',
1143 '/usr/share'
1144 ],
1145 Dir).
1147'$xdg_directory'(common_config, windows, Dir) :-
1148 catch(win_folder(common_appdata, Dir), _, fail).
1149'$xdg_directory'(common_config, xdg, Dir) :-
1150 '$existing_dir_from_env_path'('XDG_CONFIG_DIRS', ['/etc/xdg'], Dir).
1151
1152'$existing_dir_from_env_path'(Env, Defaults, Dir) :-
1153 ( getenv(Env, Path)
1154 -> current_prolog_flag(path_sep, Sep),
1155 atomic_list_concat(Dirs, Sep, Path)
1156 ; Dirs = Defaults
1157 ),
1158 '$member'(Dir, Dirs),
1159 Dir \== '',
1160 exists_directory(Dir).
1161
1162'$make_config_dir'(Dir) :-
1163 exists_directory(Dir),
1164 !.
1165'$make_config_dir'(Dir) :-
1166 nb_current('$create_search_directories', true),
1167 file_directory_name(Dir, Parent),
1168 '$my_file'(Parent),
1169 catch(make_directory(Dir), _, fail).
1170
1171'$ensure_slash'(Dir, DirS) :-
1172 ( sub_atom(Dir, _, _, 0, /)
1173 -> DirS = Dir
1174 ; atom_concat(Dir, /, DirS)
1175 ).
1176
1177:- dynamic '$ext_lib_dirs'/1. 1178:- volatile '$ext_lib_dirs'/1. 1179
1180'$ext_library_directory'(Dir) :-
1181 '$ext_lib_dirs'(Dirs),
1182 !,
1183 '$member'(Dir, Dirs).
1184'$ext_library_directory'(Dir) :-
1185 current_prolog_flag(home, Home),
1186 atom_concat(Home, '/library/ext/*', Pattern),
1187 expand_file_name(Pattern, Dirs0),
1188 '$include'(exists_directory, Dirs0, Dirs),
1189 asserta('$ext_lib_dirs'(Dirs)),
1190 '$member'(Dir, Dirs).
1191
1192
1194
1195'$expand_file_search_path'(Spec, Expanded, Cond) :-
1196 '$option'(access(Access), Cond),
1197 memberchk(Access, [write,append]),
1198 !,
1199 setup_call_cleanup(
1200 nb_setval('$create_search_directories', true),
1201 expand_file_search_path(Spec, Expanded),
1202 nb_delete('$create_search_directories')).
1203'$expand_file_search_path'(Spec, Expanded, _Cond) :-
1204 expand_file_search_path(Spec, Expanded).
1205
1211
1212expand_file_search_path(Spec, Expanded) :-
1213 catch('$expand_file_search_path'(Spec, Expanded, 0, []),
1214 loop(Used),
1215 throw(error(loop_error(Spec), file_search(Used)))).
1216
1217'$expand_file_search_path'(Spec, Expanded, N, Used) :-
1218 functor(Spec, Alias, 1),
1219 !,
1220 user:file_search_path(Alias, Exp0),
1221 NN is N + 1,
1222 ( NN > 16
1223 -> throw(loop(Used))
1224 ; true
1225 ),
1226 '$expand_file_search_path'(Exp0, Exp1, NN, [Alias=Exp0|Used]),
1227 arg(1, Spec, Segments),
1228 '$segments_to_atom'(Segments, File),
1229 '$make_path'(Exp1, File, Expanded).
1230'$expand_file_search_path'(Spec, Path, _, _) :-
1231 '$segments_to_atom'(Spec, Path).
1232
1233'$make_path'(Dir, '.', Path) :-
1234 !,
1235 Path = Dir.
1236'$make_path'(Dir, File, Path) :-
1237 sub_atom(Dir, _, _, 0, /),
1238 !,
1239 atom_concat(Dir, File, Path).
1240'$make_path'(Dir, File, Path) :-
1241 atomic_list_concat([Dir, /, File], Path).
1242
1243
1244 1247
1256
1257absolute_file_name(Spec, Options, Path) :-
1258 '$is_options'(Options),
1259 \+ '$is_options'(Path),
1260 !,
1261 '$absolute_file_name'(Spec, Path, Options).
1262absolute_file_name(Spec, Path, Options) :-
1263 '$absolute_file_name'(Spec, Path, Options).
1264
1265'$absolute_file_name'(Spec, Path, Options0) :-
1266 '$options_dict'(Options0, Options),
1267 1268 ( '$select_option'(extensions(Exts), Options, Options1)
1269 -> '$must_be'(list, Exts)
1270 ; '$option'(file_type(Type), Options)
1271 -> '$must_be'(atom, Type),
1272 '$file_type_extensions'(Type, Exts),
1273 Options1 = Options
1274 ; Options1 = Options,
1275 Exts = ['']
1276 ),
1277 '$canonicalise_extensions'(Exts, Extensions),
1278 1279 ( ( nonvar(Type)
1280 ; '$option'(access(none), Options, none)
1281 )
1282 -> Options2 = Options1
1283 ; '$merge_options'(_{file_type:regular}, Options1, Options2)
1284 ),
1285 1286 ( '$select_option'(solutions(Sols), Options2, Options3)
1287 -> '$must_be'(oneof(atom, solutions, [first,all]), Sols)
1288 ; Sols = first,
1289 Options3 = Options2
1290 ),
1291 1292 ( '$select_option'(file_errors(FileErrors), Options3, Options4)
1293 -> '$must_be'(oneof(atom, file_errors, [error,fail]), FileErrors)
1294 ; FileErrors = error,
1295 Options4 = Options3
1296 ),
1297 1298 ( atomic(Spec),
1299 '$select_option'(expand(Expand), Options4, Options5),
1300 '$must_be'(boolean, Expand)
1301 -> expand_file_name(Spec, List),
1302 '$member'(Spec1, List)
1303 ; Spec1 = Spec,
1304 Options5 = Options4
1305 ),
1306 1307 ( Sols == first
1308 -> ( '$chk_file'(Spec1, Extensions, Options5, true, Path)
1309 -> ! 1310 ; ( FileErrors == fail
1311 -> fail
1312 ; '$current_module'('$bags', _File),
1313 findall(P,
1314 '$chk_file'(Spec1, Extensions, [access(exist)],
1315 false, P),
1316 Candidates),
1317 '$abs_file_error'(Spec, Candidates, Options5)
1318 )
1319 )
1320 ; '$chk_file'(Spec1, Extensions, Options5, false, Path)
1321 ).
1322
1323'$abs_file_error'(Spec, Candidates, Conditions) :-
1324 '$member'(F, Candidates),
1325 '$member'(C, Conditions),
1326 '$file_condition'(C),
1327 '$file_error'(C, Spec, F, E, Comment),
1328 !,
1329 throw(error(E, context(_, Comment))).
1330'$abs_file_error'(Spec, _, _) :-
1331 '$existence_error'(source_sink, Spec).
1332
1333'$file_error'(file_type(directory), Spec, File, Error, Comment) :-
1334 \+ exists_directory(File),
1335 !,
1336 Error = existence_error(directory, Spec),
1337 Comment = not_a_directory(File).
1338'$file_error'(file_type(_), Spec, File, Error, Comment) :-
1339 exists_directory(File),
1340 !,
1341 Error = existence_error(file, Spec),
1342 Comment = directory(File).
1343'$file_error'(access(OneOrList), Spec, File, Error, _) :-
1344 '$one_or_member'(Access, OneOrList),
1345 \+ access_file(File, Access),
1346 Error = permission_error(Access, source_sink, Spec).
1347
1348'$one_or_member'(Elem, List) :-
1349 is_list(List),
1350 !,
1351 '$member'(Elem, List).
1352'$one_or_member'(Elem, Elem).
1353
1354
1355'$file_type_extensions'(source, Exts) :- 1356 !,
1357 '$file_type_extensions'(prolog, Exts).
1358'$file_type_extensions'(Type, Exts) :-
1359 '$current_module'('$bags', _File),
1360 !,
1361 findall(Ext, user:prolog_file_type(Ext, Type), Exts0),
1362 ( Exts0 == [],
1363 \+ '$ft_no_ext'(Type)
1364 -> '$domain_error'(file_type, Type)
1365 ; true
1366 ),
1367 '$append'(Exts0, [''], Exts).
1368'$file_type_extensions'(prolog, [pl, '']). 1369
1370'$ft_no_ext'(txt).
1371'$ft_no_ext'(executable).
1372'$ft_no_ext'(directory).
1373'$ft_no_ext'(regular).
1374
1385
1386:- multifile(user:prolog_file_type/2). 1387:- dynamic(user:prolog_file_type/2). 1388
1389user:prolog_file_type(pl, prolog).
1390user:prolog_file_type(prolog, prolog).
1391user:prolog_file_type(qlf, prolog).
1392user:prolog_file_type(qlf, qlf).
1393user:prolog_file_type(Ext, executable) :-
1394 current_prolog_flag(shared_object_extension, Ext).
1395user:prolog_file_type(dylib, executable) :-
1396 current_prolog_flag(apple, true).
1397
1402
1403'$chk_file'(Spec, _Extensions, _Cond, _Cache, _FullName) :-
1404 \+ ground(Spec),
1405 !,
1406 '$instantiation_error'(Spec).
1407'$chk_file'(Spec, Extensions, Cond, Cache, FullName) :-
1408 compound(Spec),
1409 functor(Spec, _, 1),
1410 !,
1411 '$relative_to'(Cond, cwd, CWD),
1412 '$chk_alias_file'(Spec, Extensions, Cond, Cache, CWD, FullName).
1413'$chk_file'(Segments, Ext, Cond, Cache, FullName) :- 1414 \+ atomic(Segments),
1415 !,
1416 '$segments_to_atom'(Segments, Atom),
1417 '$chk_file'(Atom, Ext, Cond, Cache, FullName).
1418'$chk_file'(File, Exts, Cond, _, FullName) :- 1419 is_absolute_file_name(File),
1420 !,
1421 '$extend_file'(File, Exts, Extended),
1422 '$file_conditions'(Cond, Extended),
1423 '$absolute_file_name'(Extended, FullName).
1424'$chk_file'(File, Exts, Cond, _, FullName) :- 1425 '$option'(relative_to(_), Cond),
1426 !,
1427 '$relative_to'(Cond, none, Dir),
1428 '$chk_file_relative_to'(File, Exts, Cond, Dir, FullName).
1429'$chk_file'(File, Exts, Cond, _Cache, FullName) :- 1430 source_location(ContextFile, _Line),
1431 !,
1432 ( file_directory_name(ContextFile, Dir),
1433 '$chk_file_relative_to'(File, Exts, Cond, Dir, FullName)
1434 -> true
1435 ; current_prolog_flag(source_search_working_directory, true),
1436 '$extend_file'(File, Exts, Extended),
1437 '$file_conditions'(Cond, Extended),
1438 '$absolute_file_name'(Extended, FullName),
1439 '$print_message'(warning,
1440 deprecated(source_search_working_directory(
1441 File, FullName)))
1442 ).
1443'$chk_file'(File, Exts, Cond, _Cache, FullName) :- 1444 '$extend_file'(File, Exts, Extended),
1445 '$file_conditions'(Cond, Extended),
1446 '$absolute_file_name'(Extended, FullName).
1447
1448'$chk_file_relative_to'(File, Exts, Cond, Dir, FullName) :-
1449 atomic_list_concat([Dir, /, File], AbsFile),
1450 '$extend_file'(AbsFile, Exts, Extended),
1451 '$file_conditions'(Cond, Extended),
1452 '$absolute_file_name'(Extended, FullName).
1453
1454
1455'$segments_to_atom'(Atom, Atom) :-
1456 atomic(Atom),
1457 !.
1458'$segments_to_atom'(Segments, Atom) :-
1459 '$segments_to_list'(Segments, List, []),
1460 !,
1461 atomic_list_concat(List, /, Atom).
1462
1463'$segments_to_list'(A/B, H, T) :-
1464 '$segments_to_list'(A, H, T0),
1465 '$segments_to_list'(B, T0, T).
1466'$segments_to_list'(A, [A|T], T) :-
1467 atomic(A).
1468
1469
1476
1477'$relative_to'(Conditions, Default, Dir) :-
1478 ( '$option'(relative_to(FileOrDir), Conditions)
1479 *-> ( exists_directory(FileOrDir)
1480 -> Dir = FileOrDir
1481 ; atom_concat(Dir, /, FileOrDir)
1482 -> true
1483 ; file_directory_name(FileOrDir, Dir)
1484 )
1485 ; Default == cwd
1486 -> working_directory(Dir, Dir)
1487 ; Default == source
1488 -> source_location(ContextFile, _Line),
1489 file_directory_name(ContextFile, Dir)
1490 ).
1491
1494
1495:- dynamic
1496 '$search_path_file_cache'/3, 1497 '$search_path_gc_time'/1. 1498:- volatile
1499 '$search_path_file_cache'/3,
1500 '$search_path_gc_time'/1. 1501:- '$notransact'(('$search_path_file_cache'/3,
1502 '$search_path_gc_time'/1)). 1503
1504:- create_prolog_flag(file_search_cache_time, 10, []). 1505
1506'$chk_alias_file'(Spec, Exts, Cond, true, CWD, FullFile) :-
1507 !,
1508 findall(Exp, '$expand_file_search_path'(Spec, Exp, Cond), Expansions),
1509 current_prolog_flag(emulated_dialect, Dialect),
1510 Cache = cache(Exts, Cond, CWD, Expansions, Dialect),
1511 variant_sha1(Spec+Cache, SHA1),
1512 get_time(Now),
1513 current_prolog_flag(file_search_cache_time, TimeOut),
1514 ( '$search_path_file_cache'(SHA1, CachedTime, FullFile),
1515 CachedTime > Now - TimeOut,
1516 '$file_conditions'(Cond, FullFile)
1517 -> '$search_message'(file_search(cache(Spec, Cond), FullFile))
1518 ; '$member'(Expanded, Expansions),
1519 '$extend_file'(Expanded, Exts, LibFile),
1520 ( '$file_conditions'(Cond, LibFile),
1521 '$absolute_file_name'(LibFile, FullFile),
1522 '$cache_file_found'(SHA1, Now, TimeOut, FullFile)
1523 -> '$search_message'(file_search(found(Spec, Cond), FullFile))
1524 ; '$search_message'(file_search(tried(Spec, Cond), LibFile)),
1525 fail
1526 )
1527 ).
1528'$chk_alias_file'(Spec, Exts, Cond, false, _CWD, FullFile) :-
1529 '$expand_file_search_path'(Spec, Expanded, Cond),
1530 '$extend_file'(Expanded, Exts, LibFile),
1531 '$file_conditions'(Cond, LibFile),
1532 '$absolute_file_name'(LibFile, FullFile).
1533
1534'$cache_file_found'(_, _, TimeOut, _) :-
1535 TimeOut =:= 0,
1536 !.
1537'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1538 '$search_path_file_cache'(SHA1, Saved, FullFile),
1539 !,
1540 ( Now - Saved < TimeOut/2
1541 -> true
1542 ; retractall('$search_path_file_cache'(SHA1, _, _)),
1543 asserta('$search_path_file_cache'(SHA1, Now, FullFile))
1544 ).
1545'$cache_file_found'(SHA1, Now, TimeOut, FullFile) :-
1546 'gc_file_search_cache'(TimeOut),
1547 asserta('$search_path_file_cache'(SHA1, Now, FullFile)).
1548
1549'gc_file_search_cache'(TimeOut) :-
1550 get_time(Now),
1551 '$search_path_gc_time'(Last),
1552 Now-Last < TimeOut/2,
1553 !.
1554'gc_file_search_cache'(TimeOut) :-
1555 get_time(Now),
1556 retractall('$search_path_gc_time'(_)),
1557 assertz('$search_path_gc_time'(Now)),
1558 Before is Now - TimeOut,
1559 ( '$search_path_file_cache'(SHA1, Cached, FullFile),
1560 Cached < Before,
1561 retractall('$search_path_file_cache'(SHA1, Cached, FullFile)),
1562 fail
1563 ; true
1564 ).
1565
1566
1567'$search_message'(Term) :-
1568 current_prolog_flag(verbose_file_search, true),
1569 !,
1570 print_message(informational, Term).
1571'$search_message'(_).
1572
1573
1577
1578'$file_conditions'(List, File) :-
1579 is_list(List),
1580 !,
1581 \+ ( '$member'(C, List),
1582 '$file_condition'(C),
1583 \+ '$file_condition'(C, File)
1584 ).
1585'$file_conditions'(Map, File) :-
1586 \+ ( get_dict(Key, Map, Value),
1587 C =.. [Key,Value],
1588 '$file_condition'(C),
1589 \+ '$file_condition'(C, File)
1590 ).
1591
1592'$file_condition'(file_type(directory), File) :-
1593 !,
1594 exists_directory(File).
1595'$file_condition'(file_type(_), File) :-
1596 !,
1597 \+ exists_directory(File).
1598'$file_condition'(access(Accesses), File) :-
1599 !,
1600 \+ ( '$one_or_member'(Access, Accesses),
1601 \+ access_file(File, Access)
1602 ).
1603
1604'$file_condition'(exists).
1605'$file_condition'(file_type(_)).
1606'$file_condition'(access(_)).
1607
1608'$extend_file'(File, Exts, FileEx) :-
1609 '$ensure_extensions'(Exts, File, Fs),
1610 '$list_to_set'(Fs, FsSet),
1611 '$member'(FileEx, FsSet).
1612
1613'$ensure_extensions'([], _, []).
1614'$ensure_extensions'([E|E0], F, [FE|E1]) :-
1615 file_name_extension(F, E, FE),
1616 '$ensure_extensions'(E0, F, E1).
1617
1622
1623'$list_to_set'(List, Set) :-
1624 '$number_list'(List, 1, Numbered),
1625 sort(1, @=<, Numbered, ONum),
1626 '$remove_dup_keys'(ONum, NumSet),
1627 sort(2, @=<, NumSet, ONumSet),
1628 '$pairs_keys'(ONumSet, Set).
1629
1630'$number_list'([], _, []).
1631'$number_list'([H|T0], N, [H-N|T]) :-
1632 N1 is N+1,
1633 '$number_list'(T0, N1, T).
1634
1635'$remove_dup_keys'([], []).
1636'$remove_dup_keys'([H|T0], [H|T]) :-
1637 H = V-_,
1638 '$remove_same_key'(T0, V, T1),
1639 '$remove_dup_keys'(T1, T).
1640
1641'$remove_same_key'([V1-_|T0], V, T) :-
1642 V1 == V,
1643 !,
1644 '$remove_same_key'(T0, V, T).
1645'$remove_same_key'(L, _, L).
1646
1647'$pairs_keys'([], []).
1648'$pairs_keys'([K-_|T0], [K|T]) :-
1649 '$pairs_keys'(T0, T).
1650
1651'$pairs_values'([], []).
1652'$pairs_values'([_-V|T0], [V|T]) :-
1653 '$pairs_values'(T0, T).
1654
1660
1661'$canonicalise_extensions'([], []) :- !.
1662'$canonicalise_extensions'([H|T], [CH|CT]) :-
1663 !,
1664 '$must_be'(atom, H),
1665 '$canonicalise_extension'(H, CH),
1666 '$canonicalise_extensions'(T, CT).
1667'$canonicalise_extensions'(E, [CE]) :-
1668 '$canonicalise_extension'(E, CE).
1669
1670'$canonicalise_extension'('', '') :- !.
1671'$canonicalise_extension'(DotAtom, DotAtom) :-
1672 sub_atom(DotAtom, 0, _, _, '.'),
1673 !.
1674'$canonicalise_extension'(Atom, DotAtom) :-
1675 atom_concat('.', Atom, DotAtom).
1676
1677
1678 1681
1682:- dynamic
1683 user:library_directory/1,
1684 user:prolog_load_file/2. 1685:- multifile
1686 user:library_directory/1,
1687 user:prolog_load_file/2. 1688
1689:- prompt(_, '|: '). 1690
1691:- thread_local
1692 '$compilation_mode_store'/1, 1693 '$directive_mode_store'/1. 1694:- volatile
1695 '$compilation_mode_store'/1,
1696 '$directive_mode_store'/1. 1697:- '$notransact'(('$compilation_mode_store'/1,
1698 '$directive_mode_store'/1)). 1699
1700'$compilation_mode'(Mode) :-
1701 ( '$compilation_mode_store'(Val)
1702 -> Mode = Val
1703 ; Mode = database
1704 ).
1705
1706'$set_compilation_mode'(Mode) :-
1707 retractall('$compilation_mode_store'(_)),
1708 assertz('$compilation_mode_store'(Mode)).
1709
1710'$compilation_mode'(Old, New) :-
1711 '$compilation_mode'(Old),
1712 ( New == Old
1713 -> true
1714 ; '$set_compilation_mode'(New)
1715 ).
1716
1717'$directive_mode'(Mode) :-
1718 ( '$directive_mode_store'(Val)
1719 -> Mode = Val
1720 ; Mode = database
1721 ).
1722
1723'$directive_mode'(Old, New) :-
1724 '$directive_mode'(Old),
1725 ( New == Old
1726 -> true
1727 ; '$set_directive_mode'(New)
1728 ).
1729
1730'$set_directive_mode'(Mode) :-
1731 retractall('$directive_mode_store'(_)),
1732 assertz('$directive_mode_store'(Mode)).
1733
1734
1739
1740'$compilation_level'(Level) :-
1741 '$input_context'(Stack),
1742 '$compilation_level'(Stack, Level).
1743
1744'$compilation_level'([], 0).
1745'$compilation_level'([Input|T], Level) :-
1746 ( arg(1, Input, see)
1747 -> '$compilation_level'(T, Level)
1748 ; '$compilation_level'(T, Level0),
1749 Level is Level0+1
1750 ).
1751
1752
1757
1758compiling :-
1759 \+ ( '$compilation_mode'(database),
1760 '$directive_mode'(database)
1761 ).
1762
1763:- meta_predicate
1764 '$ifcompiling'(0). 1765
1766'$ifcompiling'(G) :-
1767 ( '$compilation_mode'(database)
1768 -> true
1769 ; call(G)
1770 ).
1771
1772 1775
1777
1778'$load_msg_level'(Action, Nesting, Start, Done) :-
1779 '$update_autoload_level'([], 0),
1780 !,
1781 current_prolog_flag(verbose_load, Type0),
1782 '$load_msg_compat'(Type0, Type),
1783 ( '$load_msg_level'(Action, Nesting, Type, Start, Done)
1784 -> true
1785 ).
1786'$load_msg_level'(_, _, silent, silent).
1787
1788'$load_msg_compat'(true, normal) :- !.
1789'$load_msg_compat'(false, silent) :- !.
1790'$load_msg_compat'(X, X).
1791
1792'$load_msg_level'(load_file, _, full, informational, informational).
1793'$load_msg_level'(include_file, _, full, informational, informational).
1794'$load_msg_level'(load_file, _, normal, silent, informational).
1795'$load_msg_level'(include_file, _, normal, silent, silent).
1796'$load_msg_level'(load_file, 0, brief, silent, informational).
1797'$load_msg_level'(load_file, _, brief, silent, silent).
1798'$load_msg_level'(include_file, _, brief, silent, silent).
1799'$load_msg_level'(load_file, _, silent, silent, silent).
1800'$load_msg_level'(include_file, _, silent, silent, silent).
1801
1822
1823'$source_term'(From, Read, RLayout, Term, TLayout, Stream, Options) :-
1824 '$source_term'(From, Read, RLayout, Term, TLayout, Stream, [], Options),
1825 ( Term == end_of_file
1826 -> !, fail
1827 ; Term \== begin_of_file
1828 ).
1829
1830'$source_term'(Input, _,_,_,_,_,_,_) :-
1831 \+ ground(Input),
1832 !,
1833 '$instantiation_error'(Input).
1834'$source_term'(stream(Id, In, Opts),
1835 Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1836 !,
1837 '$record_included'(Parents, Id, Id, 0.0, Message),
1838 setup_call_cleanup(
1839 '$open_source'(stream(Id, In, Opts), In, State, Parents, Options),
1840 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1841 [Id|Parents], Options),
1842 '$close_source'(State, Message)).
1843'$source_term'(File,
1844 Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1845 absolute_file_name(File, Path,
1846 [ file_type(prolog),
1847 access(read)
1848 ]),
1849 time_file(Path, Time),
1850 '$record_included'(Parents, File, Path, Time, Message),
1851 setup_call_cleanup(
1852 '$open_source'(Path, In, State, Parents, Options),
1853 '$term_in_file'(In, Read, RLayout, Term, TLayout, Stream,
1854 [Path|Parents], Options),
1855 '$close_source'(State, Message)).
1856
1857:- thread_local
1858 '$load_input'/2. 1859:- volatile
1860 '$load_input'/2. 1861:- '$notransact'('$load_input'/2). 1862
1863'$open_source'(stream(Id, In, Opts), In,
1864 restore(In, StreamState, Id, Ref, Opts), Parents, _Options) :-
1865 !,
1866 '$context_type'(Parents, ContextType),
1867 '$push_input_context'(ContextType),
1868 '$prepare_load_stream'(In, Id, StreamState),
1869 asserta('$load_input'(stream(Id), In), Ref).
1870'$open_source'(Path, In, close(In, Path, Ref), Parents, Options) :-
1871 '$context_type'(Parents, ContextType),
1872 '$push_input_context'(ContextType),
1873 '$open_source'(Path, In, Options),
1874 '$set_encoding'(In, Options),
1875 asserta('$load_input'(Path, In), Ref).
1876
1877'$context_type'([], load_file) :- !.
1878'$context_type'(_, include).
1879
1880:- multifile prolog:open_source_hook/3. 1881
1882'$open_source'(Path, In, Options) :-
1883 prolog:open_source_hook(Path, In, Options),
1884 !.
1885'$open_source'(Path, In, _Options) :-
1886 open(Path, read, In).
1887
1888'$close_source'(close(In, _Id, Ref), Message) :-
1889 erase(Ref),
1890 call_cleanup(
1891 close(In),
1892 '$pop_input_context'),
1893 '$close_message'(Message).
1894'$close_source'(restore(In, StreamState, _Id, Ref, Opts), Message) :-
1895 erase(Ref),
1896 call_cleanup(
1897 '$restore_load_stream'(In, StreamState, Opts),
1898 '$pop_input_context'),
1899 '$close_message'(Message).
1900
1901'$close_message'(message(Level, Msg)) :-
1902 !,
1903 '$print_message'(Level, Msg).
1904'$close_message'(_).
1905
1906
1915
1916'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1917 Parents \= [_,_|_],
1918 ( '$load_input'(_, Input)
1919 -> stream_property(Input, file_name(File))
1920 ),
1921 '$set_source_location'(File, 0),
1922 '$expanded_term'(In,
1923 begin_of_file, 0-0, Read, RLayout, Term, TLayout,
1924 Stream, Parents, Options).
1925'$term_in_file'(In, Read, RLayout, Term, TLayout, Stream, Parents, Options) :-
1926 '$skip_script_line'(In, Options),
1927 '$read_clause_options'(Options, ReadOptions),
1928 '$repeat_and_read_error_mode'(ErrorMode),
1929 read_clause(In, Raw,
1930 [ syntax_errors(ErrorMode),
1931 variable_names(Bindings),
1932 term_position(Pos),
1933 subterm_positions(RawLayout)
1934 | ReadOptions
1935 ]),
1936 b_setval('$term_position', Pos),
1937 b_setval('$variable_names', Bindings),
1938 ( Raw == end_of_file
1939 -> !,
1940 ( Parents = [_,_|_] 1941 -> fail
1942 ; '$expanded_term'(In,
1943 Raw, RawLayout, Read, RLayout, Term, TLayout,
1944 Stream, Parents, Options)
1945 )
1946 ; '$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1947 Stream, Parents, Options)
1948 ).
1949
1950'$read_clause_options'([], []).
1951'$read_clause_options'([H|T0], List) :-
1952 ( '$read_clause_option'(H)
1953 -> List = [H|T]
1954 ; List = T
1955 ),
1956 '$read_clause_options'(T0, T).
1957
1958'$read_clause_option'(syntax_errors(_)).
1959'$read_clause_option'(term_position(_)).
1960'$read_clause_option'(process_comment(_)).
1961
1967
1968'$repeat_and_read_error_mode'(Mode) :-
1969 ( current_predicate('$including'/0)
1970 -> repeat,
1971 ( '$including'
1972 -> Mode = dec10
1973 ; Mode = quiet
1974 )
1975 ; Mode = dec10,
1976 repeat
1977 ).
1978
1979
1980'$expanded_term'(In, Raw, RawLayout, Read, RLayout, Term, TLayout,
1981 Stream, Parents, Options) :-
1982 E = error(_,_),
1983 catch('$expand_term'(Raw, RawLayout, Expanded, ExpandedLayout), E,
1984 '$print_message_fail'(E)),
1985 ( Expanded \== []
1986 -> '$expansion_member'(Expanded, ExpandedLayout, Term1, Layout1)
1987 ; Term1 = Expanded,
1988 Layout1 = ExpandedLayout
1989 ),
1990 ( nonvar(Term1), Term1 = (:-Directive), nonvar(Directive)
1991 -> ( Directive = include(File),
1992 '$current_source_module'(Module),
1993 '$valid_directive'(Module:include(File))
1994 -> stream_property(In, encoding(Enc)),
1995 '$add_encoding'(Enc, Options, Options1),
1996 '$source_term'(File, Read, RLayout, Term, TLayout,
1997 Stream, Parents, Options1)
1998 ; Directive = encoding(Enc)
1999 -> set_stream(In, encoding(Enc)),
2000 fail
2001 ; Term = Term1,
2002 Stream = In,
2003 Read = Raw
2004 )
2005 ; Term = Term1,
2006 TLayout = Layout1,
2007 Stream = In,
2008 Read = Raw,
2009 RLayout = RawLayout
2010 ).
2011
2012'$expansion_member'(Var, Layout, Var, Layout) :-
2013 var(Var),
2014 !.
2015'$expansion_member'([], _, _, _) :- !, fail.
2016'$expansion_member'(List, ListLayout, Term, Layout) :-
2017 is_list(List),
2018 !,
2019 ( var(ListLayout)
2020 -> '$member'(Term, List)
2021 ; is_list(ListLayout)
2022 -> '$member_rep2'(Term, Layout, List, ListLayout)
2023 ; Layout = ListLayout,
2024 '$member'(Term, List)
2025 ).
2026'$expansion_member'(X, Layout, X, Layout).
2027
2030
2031'$member_rep2'(H1, H2, [H1|_], [H2|_]).
2032'$member_rep2'(H1, H2, [_|T1], [T2]) :-
2033 !,
2034 '$member_rep2'(H1, H2, T1, [T2]).
2035'$member_rep2'(H1, H2, [_|T1], [_|T2]) :-
2036 '$member_rep2'(H1, H2, T1, T2).
2037
2039
2040'$add_encoding'(Enc, Options0, Options) :-
2041 ( Options0 = [encoding(Enc)|_]
2042 -> Options = Options0
2043 ; Options = [encoding(Enc)|Options0]
2044 ).
2045
2046
2047:- multifile
2048 '$included'/4. 2049:- dynamic
2050 '$included'/4. 2051
2063
2064'$record_included'([Parent|Parents], File, Path, Time,
2065 message(DoneMsgLevel,
2066 include_file(done(Level, file(File, Path))))) :-
2067 source_location(SrcFile, Line),
2068 !,
2069 '$compilation_level'(Level),
2070 '$load_msg_level'(include_file, Level, StartMsgLevel, DoneMsgLevel),
2071 '$print_message'(StartMsgLevel,
2072 include_file(start(Level,
2073 file(File, Path)))),
2074 '$last'([Parent|Parents], Owner),
2075 ( ( '$compilation_mode'(database)
2076 ; '$qlf_current_source'(Owner)
2077 )
2078 -> '$store_admin_clause'(
2079 system:'$included'(Parent, Line, Path, Time),
2080 _, Owner, SrcFile:Line)
2081 ; '$qlf_include'(Owner, Parent, Line, Path, Time)
2082 ).
2083'$record_included'(_, _, _, _, true).
2084
2088
2089'$master_file'(File, MasterFile) :-
2090 '$included'(MasterFile0, _Line, File, _Time),
2091 !,
2092 '$master_file'(MasterFile0, MasterFile).
2093'$master_file'(File, File).
2094
2095
2096'$skip_script_line'(_In, Options) :-
2097 '$option'(check_script(false), Options),
2098 !.
2099'$skip_script_line'(In, _Options) :-
2100 ( peek_char(In, #)
2101 -> skip(In, 10)
2102 ; true
2103 ).
2104
2105'$set_encoding'(Stream, Options) :-
2106 '$option'(encoding(Enc), Options),
2107 !,
2108 Enc \== default,
2109 set_stream(Stream, encoding(Enc)).
2110'$set_encoding'(_, _).
2111
2112
2113'$prepare_load_stream'(In, Id, state(HasName,HasPos)) :-
2114 ( stream_property(In, file_name(_))
2115 -> HasName = true,
2116 ( stream_property(In, position(_))
2117 -> HasPos = true
2118 ; HasPos = false,
2119 set_stream(In, record_position(true))
2120 )
2121 ; HasName = false,
2122 set_stream(In, file_name(Id)),
2123 ( stream_property(In, position(_))
2124 -> HasPos = true
2125 ; HasPos = false,
2126 set_stream(In, record_position(true))
2127 )
2128 ).
2129
2130'$restore_load_stream'(In, _State, Options) :-
2131 memberchk(close(true), Options),
2132 !,
2133 close(In).
2134'$restore_load_stream'(In, state(HasName, HasPos), _Options) :-
2135 ( HasName == false
2136 -> set_stream(In, file_name(''))
2137 ; true
2138 ),
2139 ( HasPos == false
2140 -> set_stream(In, record_position(false))
2141 ; true
2142 ).
2143
2144
2145 2148
2149:- dynamic
2150 '$derived_source_db'/3. 2151
2152'$register_derived_source'(_, '-') :- !.
2153'$register_derived_source'(Loaded, DerivedFrom) :-
2154 retractall('$derived_source_db'(Loaded, _, _)),
2155 time_file(DerivedFrom, Time),
2156 assert('$derived_source_db'(Loaded, DerivedFrom, Time)).
2157
2160
2161'$derived_source'(Loaded, DerivedFrom, Time) :-
2162 '$derived_source_db'(Loaded, DerivedFrom, Time).
2163
2164
2165 2168
2169:- meta_predicate
2170 ensure_loaded(:),
2171 [:|+],
2172 consult(:),
2173 use_module(:),
2174 use_module(:, +),
2175 reexport(:),
2176 reexport(:, +),
2177 load_files(:),
2178 load_files(:, +). 2179
2185
2186ensure_loaded(Files) :-
2187 load_files(Files, [if(not_loaded)]).
2188
2195
2196use_module(Files) :-
2197 load_files(Files, [ if(not_loaded),
2198 must_be_module(true)
2199 ]).
2200
2205
2206use_module(File, Import) :-
2207 load_files(File, [ if(not_loaded),
2208 must_be_module(true),
2209 imports(Import)
2210 ]).
2211
2215
2216reexport(Files) :-
2217 load_files(Files, [ if(not_loaded),
2218 must_be_module(true),
2219 reexport(true)
2220 ]).
2221
2225
2226reexport(File, Import) :-
2227 load_files(File, [ if(not_loaded),
2228 must_be_module(true),
2229 imports(Import),
2230 reexport(true)
2231 ]).
2232
2233
2234[X] :-
2235 !,
2236 consult(X).
2237[M:F|R] :-
2238 consult(M:[F|R]).
2239
2240consult(M:X) :-
2241 X == user,
2242 !,
2243 flag('$user_consult', N, N+1),
2244 NN is N + 1,
2245 atom_concat('user://', NN, Id),
2246 load_files(M:Id, [stream(user_input), check_script(false), silent(false)]).
2247consult(List) :-
2248 load_files(List, [expand(true)]).
2249
2254
2255load_files(Files) :-
2256 load_files(Files, []).
2257load_files(Module:Files, Options) :-
2258 '$must_be'(list, Options),
2259 '$load_files'(Files, Module, Options).
2260
2261'$load_files'(X, _, _) :-
2262 var(X),
2263 !,
2264 '$instantiation_error'(X).
2265'$load_files'([], _, _) :- !.
2266'$load_files'(Id, Module, Options) :- 2267 '$option'(stream(_), Options),
2268 !,
2269 ( atom(Id)
2270 -> '$load_file'(Id, Module, Options)
2271 ; throw(error(type_error(atom, Id), _))
2272 ).
2273'$load_files'(List, Module, Options) :-
2274 List = [_|_],
2275 !,
2276 '$must_be'(list, List),
2277 '$load_file_list'(List, Module, Options).
2278'$load_files'(File, Module, Options) :-
2279 '$load_one_file'(File, Module, Options).
2280
2281'$load_file_list'([], _, _).
2282'$load_file_list'([File|Rest], Module, Options) :-
2283 E = error(_,_),
2284 catch('$load_one_file'(File, Module, Options), E,
2285 '$print_message'(error, E)),
2286 '$load_file_list'(Rest, Module, Options).
2287
2288
2289'$load_one_file'(Spec, Module, Options) :-
2290 atomic(Spec),
2291 '$option'(expand(Expand), Options, false),
2292 Expand == true,
2293 !,
2294 expand_file_name(Spec, Expanded),
2295 ( Expanded = [Load]
2296 -> true
2297 ; Load = Expanded
2298 ),
2299 '$load_files'(Load, Module, [expand(false)|Options]).
2300'$load_one_file'(File, Module, Options) :-
2301 strip_module(Module:File, Into, PlainFile),
2302 '$load_file'(PlainFile, Into, Options).
2303
2304
2308
2309'$noload'(true, _, _) :-
2310 !,
2311 fail.
2312'$noload'(_, FullFile, _Options) :-
2313 '$time_source_file'(FullFile, Time, system),
2314 float(Time),
2315 !.
2316'$noload'(not_loaded, FullFile, _) :-
2317 source_file(FullFile),
2318 !.
2319'$noload'(changed, Derived, _) :-
2320 '$derived_source'(_FullFile, Derived, LoadTime),
2321 time_file(Derived, Modified),
2322 Modified @=< LoadTime,
2323 !.
2324'$noload'(changed, FullFile, Options) :-
2325 '$time_source_file'(FullFile, LoadTime, user),
2326 '$modified_id'(FullFile, Modified, Options),
2327 Modified @=< LoadTime,
2328 !.
2329'$noload'(exists, File, Options) :-
2330 '$noload'(changed, File, Options).
2331
2348
2349'$qlf_file'(Spec, _, Spec, stream, Options) :-
2350 '$option'(stream(_), Options), 2351 !.
2352'$qlf_file'(Spec, FullFile, FullFile, compile, _) :-
2353 '$spec_extension'(Spec, Ext), 2354 user:prolog_file_type(Ext, prolog),
2355 !.
2356'$qlf_file'(Spec, FullFile, LoadFile, Mode, Options) :-
2357 '$compilation_mode'(database),
2358 file_name_extension(Base, PlExt, FullFile),
2359 user:prolog_file_type(PlExt, prolog),
2360 user:prolog_file_type(QlfExt, qlf),
2361 file_name_extension(Base, QlfExt, QlfFile),
2362 ( access_file(QlfFile, read),
2363 ( '$qlf_out_of_date'(FullFile, QlfFile, Why)
2364 -> ( access_file(QlfFile, write)
2365 -> print_message(informational,
2366 qlf(recompile(Spec, FullFile, QlfFile, Why))),
2367 Mode = qcompile,
2368 LoadFile = FullFile
2369 ; Why == old,
2370 ( current_prolog_flag(home, PlHome),
2371 sub_atom(FullFile, 0, _, _, PlHome)
2372 ; sub_atom(QlfFile, 0, _, _, 'res://')
2373 )
2374 -> print_message(silent,
2375 qlf(system_lib_out_of_date(Spec, QlfFile))),
2376 Mode = qload,
2377 LoadFile = QlfFile
2378 ; print_message(warning,
2379 qlf(can_not_recompile(Spec, QlfFile, Why))),
2380 Mode = compile,
2381 LoadFile = FullFile
2382 )
2383 ; Mode = qload,
2384 LoadFile = QlfFile
2385 )
2386 -> !
2387 ; '$qlf_auto'(FullFile, QlfFile, Options)
2388 -> !, Mode = qcompile,
2389 LoadFile = FullFile
2390 ).
2391'$qlf_file'(_, FullFile, FullFile, compile, _).
2392
2393
2398
2399'$qlf_out_of_date'(PlFile, QlfFile, Why) :-
2400 ( access_file(PlFile, read)
2401 -> time_file(PlFile, PlTime),
2402 time_file(QlfFile, QlfTime),
2403 ( PlTime > QlfTime
2404 -> Why = old 2405 ; Error = error(Formal,_),
2406 catch('$qlf_is_compatible'(QlfFile), Error, true),
2407 nonvar(Formal) 2408 -> Why = Error
2409 ; fail 2410 )
2411 ; fail 2412 ).
2413
2419
2420:- create_prolog_flag(qcompile, false, [type(atom)]). 2421
2422'$qlf_auto'(PlFile, QlfFile, Options) :-
2423 ( memberchk(qcompile(QlfMode), Options)
2424 -> true
2425 ; current_prolog_flag(qcompile, QlfMode),
2426 \+ '$in_system_dir'(PlFile)
2427 ),
2428 ( QlfMode == auto
2429 -> true
2430 ; QlfMode == large,
2431 size_file(PlFile, Size),
2432 Size > 100000
2433 ),
2434 access_file(QlfFile, write).
2435
2436'$in_system_dir'(PlFile) :-
2437 current_prolog_flag(home, Home),
2438 sub_atom(PlFile, 0, _, _, Home).
2439
2440'$spec_extension'(File, Ext) :-
2441 atom(File),
2442 file_name_extension(_, Ext, File).
2443'$spec_extension'(Spec, Ext) :-
2444 compound(Spec),
2445 arg(1, Spec, Arg),
2446 '$spec_extension'(Arg, Ext).
2447
2448
2457
2458:- dynamic
2459 '$resolved_source_path_db'/3. 2460:- '$notransact'('$resolved_source_path_db'/3). 2461
2462'$load_file'(File, Module, Options) :-
2463 '$error_count'(E0, W0),
2464 '$load_file_e'(File, Module, Options),
2465 '$error_count'(E1, W1),
2466 Errors is E1-E0,
2467 Warnings is W1-W0,
2468 ( Errors+Warnings =:= 0
2469 -> true
2470 ; '$print_message'(silent, load_file_errors(File, Errors, Warnings))
2471 ).
2472
2473:- if(current_prolog_flag(threads, true)). 2474'$error_count'(Errors, Warnings) :-
2475 current_prolog_flag(threads, true),
2476 !,
2477 thread_self(Me),
2478 thread_statistics(Me, errors, Errors),
2479 thread_statistics(Me, warnings, Warnings).
2480:- endif. 2481'$error_count'(Errors, Warnings) :-
2482 statistics(errors, Errors),
2483 statistics(warnings, Warnings).
2484
2485'$load_file_e'(File, Module, Options) :-
2486 \+ memberchk(stream(_), Options),
2487 user:prolog_load_file(Module:File, Options),
2488 !.
2489'$load_file_e'(File, Module, Options) :-
2490 memberchk(stream(_), Options),
2491 !,
2492 '$assert_load_context_module'(File, Module, Options),
2493 '$qdo_load_file'(File, File, Module, Options).
2494'$load_file_e'(File, Module, Options) :-
2495 ( '$resolved_source_path'(File, FullFile, Options)
2496 -> true
2497 ; '$resolve_source_path'(File, FullFile, Options)
2498 ),
2499 !,
2500 '$mt_load_file'(File, FullFile, Module, Options).
2501'$load_file_e'(_, _, _).
2502
2506
2507'$resolved_source_path'(File, FullFile, Options) :-
2508 current_prolog_flag(emulated_dialect, Dialect),
2509 '$resolved_source_path_db'(File, Dialect, FullFile),
2510 ( '$source_file_property'(FullFile, from_state, true)
2511 ; '$source_file_property'(FullFile, resource, true)
2512 ; '$option'(if(If), Options, true),
2513 '$noload'(If, FullFile, Options)
2514 ),
2515 !.
2516
2521
2522'$resolve_source_path'(File, FullFile, Options) :-
2523 ( '$option'(if(If), Options),
2524 If == exists
2525 -> Extra = [file_errors(fail)]
2526 ; Extra = []
2527 ),
2528 absolute_file_name(File, FullFile,
2529 [ file_type(prolog),
2530 access(read)
2531 | Extra
2532 ]),
2533 '$register_resolved_source_path'(File, FullFile).
2534
2535'$register_resolved_source_path'(File, FullFile) :-
2536 ( compound(File)
2537 -> current_prolog_flag(emulated_dialect, Dialect),
2538 ( '$resolved_source_path_db'(File, Dialect, FullFile)
2539 -> true
2540 ; asserta('$resolved_source_path_db'(File, Dialect, FullFile))
2541 )
2542 ; true
2543 ).
2544
2548
2549:- public '$translated_source'/2. 2550'$translated_source'(Old, New) :-
2551 forall(retract('$resolved_source_path_db'(File, Dialect, Old)),
2552 assertz('$resolved_source_path_db'(File, Dialect, New))).
2553
2558
2559'$register_resource_file'(FullFile) :-
2560 ( sub_atom(FullFile, 0, _, _, 'res://'),
2561 \+ file_name_extension(_, qlf, FullFile)
2562 -> '$set_source_file'(FullFile, resource, true)
2563 ; true
2564 ).
2565
2576
2577'$already_loaded'(_File, FullFile, Module, Options) :-
2578 '$assert_load_context_module'(FullFile, Module, Options),
2579 '$current_module'(LoadModules, FullFile),
2580 !,
2581 ( atom(LoadModules)
2582 -> LoadModule = LoadModules
2583 ; LoadModules = [LoadModule|_]
2584 ),
2585 '$import_from_loaded_module'(LoadModule, Module, Options).
2586'$already_loaded'(_, _, user, _) :- !.
2587'$already_loaded'(File, FullFile, Module, Options) :-
2588 ( '$load_context_module'(FullFile, Module, CtxOptions),
2589 '$load_ctx_options'(Options, CtxOptions)
2590 -> true
2591 ; '$load_file'(File, Module, [if(true)|Options])
2592 ).
2593
2606
2607:- dynamic
2608 '$loading_file'/3. 2609:- volatile
2610 '$loading_file'/3. 2611:- '$notransact'('$loading_file'/3). 2612
2613:- if(current_prolog_flag(threads, true)). 2614'$mt_load_file'(File, FullFile, Module, Options) :-
2615 current_prolog_flag(threads, true),
2616 !,
2617 sig_atomic(setup_call_cleanup(
2618 with_mutex('$load_file',
2619 '$mt_start_load'(FullFile, Loading, Options)),
2620 '$mt_do_load'(Loading, File, FullFile, Module, Options),
2621 '$mt_end_load'(Loading))).
2622:- endif. 2623'$mt_load_file'(File, FullFile, Module, Options) :-
2624 '$option'(if(If), Options, true),
2625 '$noload'(If, FullFile, Options),
2626 !,
2627 '$already_loaded'(File, FullFile, Module, Options).
2628:- if(current_prolog_flag(threads, true)). 2629'$mt_load_file'(File, FullFile, Module, Options) :-
2630 sig_atomic('$qdo_load_file'(File, FullFile, Module, Options)).
2631:- else. 2632'$mt_load_file'(File, FullFile, Module, Options) :-
2633 '$qdo_load_file'(File, FullFile, Module, Options).
2634:- endif. 2635
2636:- if(current_prolog_flag(threads, true)). 2637'$mt_start_load'(FullFile, queue(Queue), _) :-
2638 '$loading_file'(FullFile, Queue, LoadThread),
2639 \+ thread_self(LoadThread),
2640 !.
2641'$mt_start_load'(FullFile, already_loaded, Options) :-
2642 '$option'(if(If), Options, true),
2643 '$noload'(If, FullFile, Options),
2644 !.
2645'$mt_start_load'(FullFile, Ref, _) :-
2646 thread_self(Me),
2647 message_queue_create(Queue),
2648 assertz('$loading_file'(FullFile, Queue, Me), Ref).
2649
2650'$mt_do_load'(queue(Queue), File, FullFile, Module, Options) :-
2651 !,
2652 catch(thread_get_message(Queue, _), error(_,_), true),
2653 '$already_loaded'(File, FullFile, Module, Options).
2654'$mt_do_load'(already_loaded, File, FullFile, Module, Options) :-
2655 !,
2656 '$already_loaded'(File, FullFile, Module, Options).
2657'$mt_do_load'(_Ref, File, FullFile, Module, Options) :-
2658 '$assert_load_context_module'(FullFile, Module, Options),
2659 '$qdo_load_file'(File, FullFile, Module, Options).
2660
2661'$mt_end_load'(queue(_)) :- !.
2662'$mt_end_load'(already_loaded) :- !.
2663'$mt_end_load'(Ref) :-
2664 clause('$loading_file'(_, Queue, _), _, Ref),
2665 erase(Ref),
2666 thread_send_message(Queue, done),
2667 message_queue_destroy(Queue).
2668:- endif. 2669
2673
2674'$qdo_load_file'(File, FullFile, Module, Options) :-
2675 '$qdo_load_file2'(File, FullFile, Module, Action, Options),
2676 '$register_resource_file'(FullFile),
2677 '$run_initialization'(FullFile, Action, Options).
2678
2679'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
2680 memberchk('$qlf'(QlfOut), Options),
2681 '$stage_file'(QlfOut, StageQlf),
2682 !,
2683 setup_call_catcher_cleanup(
2684 '$qstart'(StageQlf, Module, State),
2685 '$do_load_file'(File, FullFile, Module, Action, Options),
2686 Catcher,
2687 '$qend'(State, Catcher, StageQlf, QlfOut)).
2688'$qdo_load_file2'(File, FullFile, Module, Action, Options) :-
2689 '$do_load_file'(File, FullFile, Module, Action, Options).
2690
2691'$qstart'(Qlf, Module, state(OldMode, OldModule)) :-
2692 '$qlf_open'(Qlf),
2693 '$compilation_mode'(OldMode, qlf),
2694 '$set_source_module'(OldModule, Module).
2695
2696'$qend'(state(OldMode, OldModule), Catcher, StageQlf, QlfOut) :-
2697 '$set_source_module'(_, OldModule),
2698 '$set_compilation_mode'(OldMode),
2699 '$qlf_close',
2700 '$install_staged_file'(Catcher, StageQlf, QlfOut, warn).
2701
2702'$set_source_module'(OldModule, Module) :-
2703 '$current_source_module'(OldModule),
2704 '$set_source_module'(Module).
2705
2710
2711'$do_load_file'(File, FullFile, Module, Action, Options) :-
2712 '$option'(derived_from(DerivedFrom), Options, -),
2713 '$register_derived_source'(FullFile, DerivedFrom),
2714 '$qlf_file'(File, FullFile, Absolute, Mode, Options),
2715 ( Mode == qcompile
2716 -> qcompile(Module:File, Options)
2717 ; '$do_load_file_2'(File, Absolute, Module, Action, Options)
2718 ).
2719
2720'$do_load_file_2'(File, Absolute, Module, Action, Options) :-
2721 '$source_file_property'(Absolute, number_of_clauses, OldClauses),
2722 statistics(cputime, OldTime),
2723
2724 '$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
2725 Options),
2726
2727 '$compilation_level'(Level),
2728 '$load_msg_level'(load_file, Level, StartMsgLevel, DoneMsgLevel),
2729 '$print_message'(StartMsgLevel,
2730 load_file(start(Level,
2731 file(File, Absolute)))),
2732
2733 ( memberchk(stream(FromStream), Options)
2734 -> Input = stream
2735 ; Input = source
2736 ),
2737
2738 ( Input == stream,
2739 ( '$option'(format(qlf), Options, source)
2740 -> set_stream(FromStream, file_name(Absolute)),
2741 '$qload_stream'(FromStream, Module, Action, LM, Options)
2742 ; '$consult_file'(stream(Absolute, FromStream, []),
2743 Module, Action, LM, Options)
2744 )
2745 -> true
2746 ; Input == source,
2747 file_name_extension(_, Ext, Absolute),
2748 ( user:prolog_file_type(Ext, qlf),
2749 E = error(_,_),
2750 catch('$qload_file'(Absolute, Module, Action, LM, Options),
2751 E,
2752 print_message(warning, E))
2753 -> true
2754 ; '$consult_file'(Absolute, Module, Action, LM, Options)
2755 )
2756 -> true
2757 ; '$print_message'(error, load_file(failed(File))),
2758 fail
2759 ),
2760
2761 '$import_from_loaded_module'(LM, Module, Options),
2762
2763 '$source_file_property'(Absolute, number_of_clauses, NewClauses),
2764 statistics(cputime, Time),
2765 ClausesCreated is NewClauses - OldClauses,
2766 TimeUsed is Time - OldTime,
2767
2768 '$print_message'(DoneMsgLevel,
2769 load_file(done(Level,
2770 file(File, Absolute),
2771 Action,
2772 LM,
2773 TimeUsed,
2774 ClausesCreated))),
2775
2776 '$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef).
2777
2778'$setup_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef,
2779 Options) :-
2780 '$save_file_scoped_flags'(ScopedFlags),
2781 '$set_sandboxed_load'(Options, OldSandBoxed),
2782 '$set_verbose_load'(Options, OldVerbose),
2783 '$set_optimise_load'(Options),
2784 '$update_autoload_level'(Options, OldAutoLevel),
2785 '$set_no_xref'(OldXRef).
2786
2787'$restore_load'(ScopedFlags, OldSandBoxed, OldVerbose, OldAutoLevel, OldXRef) :-
2788 '$set_autoload_level'(OldAutoLevel),
2789 set_prolog_flag(xref, OldXRef),
2790 set_prolog_flag(verbose_load, OldVerbose),
2791 set_prolog_flag(sandboxed_load, OldSandBoxed),
2792 '$restore_file_scoped_flags'(ScopedFlags).
2793
2794
2799
2800'$save_file_scoped_flags'(State) :-
2801 current_predicate(findall/3), 2802 !,
2803 findall(SavedFlag, '$save_file_scoped_flag'(SavedFlag), State).
2804'$save_file_scoped_flags'([]).
2805
2806'$save_file_scoped_flag'(Flag-Value) :-
2807 '$file_scoped_flag'(Flag, Default),
2808 ( current_prolog_flag(Flag, Value)
2809 -> true
2810 ; Value = Default
2811 ).
2812
2813'$file_scoped_flag'(generate_debug_info, true).
2814'$file_scoped_flag'(optimise, false).
2815'$file_scoped_flag'(xref, false).
2816
2817'$restore_file_scoped_flags'([]).
2818'$restore_file_scoped_flags'([Flag-Value|T]) :-
2819 set_prolog_flag(Flag, Value),
2820 '$restore_file_scoped_flags'(T).
2821
2822
2826
2827'$import_from_loaded_module'(LoadedModule, Module, Options) :-
2828 LoadedModule \== Module,
2829 atom(LoadedModule),
2830 !,
2831 '$option'(imports(Import), Options, all),
2832 '$option'(reexport(Reexport), Options, false),
2833 '$import_list'(Module, LoadedModule, Import, Reexport).
2834'$import_from_loaded_module'(_, _, _).
2835
2836
2841
2842'$set_verbose_load'(Options, Old) :-
2843 current_prolog_flag(verbose_load, Old),
2844 ( memberchk(silent(Silent), Options)
2845 -> ( '$negate'(Silent, Level0)
2846 -> '$load_msg_compat'(Level0, Level)
2847 ; Level = Silent
2848 ),
2849 set_prolog_flag(verbose_load, Level)
2850 ; true
2851 ).
2852
2853'$negate'(true, false).
2854'$negate'(false, true).
2855
2862
2863'$set_sandboxed_load'(Options, Old) :-
2864 current_prolog_flag(sandboxed_load, Old),
2865 ( memberchk(sandboxed(SandBoxed), Options),
2866 '$enter_sandboxed'(Old, SandBoxed, New),
2867 New \== Old
2868 -> set_prolog_flag(sandboxed_load, New)
2869 ; true
2870 ).
2871
2872'$enter_sandboxed'(Old, New, SandBoxed) :-
2873 ( Old == false, New == true
2874 -> SandBoxed = true,
2875 '$ensure_loaded_library_sandbox'
2876 ; Old == true, New == false
2877 -> throw(error(permission_error(leave, sandbox, -), _))
2878 ; SandBoxed = Old
2879 ).
2880'$enter_sandboxed'(false, true, true).
2881
2882'$ensure_loaded_library_sandbox' :-
2883 source_file_property(library(sandbox), module(sandbox)),
2884 !.
2885'$ensure_loaded_library_sandbox' :-
2886 load_files(library(sandbox), [if(not_loaded), silent(true)]).
2887
2888'$set_optimise_load'(Options) :-
2889 ( '$option'(optimise(Optimise), Options)
2890 -> set_prolog_flag(optimise, Optimise)
2891 ; true
2892 ).
2893
2894'$set_no_xref'(OldXRef) :-
2895 ( current_prolog_flag(xref, OldXRef)
2896 -> true
2897 ; OldXRef = false
2898 ),
2899 set_prolog_flag(xref, false).
2900
2901
2905
2906:- thread_local
2907 '$autoload_nesting'/1. 2908:- '$notransact'('$autoload_nesting'/1). 2909
2910'$update_autoload_level'(Options, AutoLevel) :-
2911 '$option'(autoload(Autoload), Options, false),
2912 ( '$autoload_nesting'(CurrentLevel)
2913 -> AutoLevel = CurrentLevel
2914 ; AutoLevel = 0
2915 ),
2916 ( Autoload == false
2917 -> true
2918 ; NewLevel is AutoLevel + 1,
2919 '$set_autoload_level'(NewLevel)
2920 ).
2921
2922'$set_autoload_level'(New) :-
2923 retractall('$autoload_nesting'(_)),
2924 asserta('$autoload_nesting'(New)).
2925
2926
2931
2932'$print_message'(Level, Term) :-
2933 current_predicate(system:print_message/2),
2934 !,
2935 print_message(Level, Term).
2936'$print_message'(warning, Term) :-
2937 source_location(File, Line),
2938 !,
2939 format(user_error, 'WARNING: ~w:~w: ~p~n', [File, Line, Term]).
2940'$print_message'(error, Term) :-
2941 !,
2942 source_location(File, Line),
2943 !,
2944 format(user_error, 'ERROR: ~w:~w: ~p~n', [File, Line, Term]).
2945'$print_message'(_Level, _Term).
2946
2947'$print_message_fail'(E) :-
2948 '$print_message'(error, E),
2949 fail.
2950
2956
2957'$consult_file'(Absolute, Module, What, LM, Options) :-
2958 '$current_source_module'(Module), 2959 !,
2960 '$consult_file_2'(Absolute, Module, What, LM, Options).
2961'$consult_file'(Absolute, Module, What, LM, Options) :-
2962 '$set_source_module'(OldModule, Module),
2963 '$ifcompiling'('$qlf_start_sub_module'(Module)),
2964 '$consult_file_2'(Absolute, Module, What, LM, Options),
2965 '$ifcompiling'('$qlf_end_part'),
2966 '$set_source_module'(OldModule).
2967
2968'$consult_file_2'(Absolute, Module, What, LM, Options) :-
2969 '$set_source_module'(OldModule, Module),
2970 '$load_id'(Absolute, Id, Modified, Options),
2971 '$compile_type'(What),
2972 '$save_lex_state'(LexState, Options),
2973 '$set_dialect'(Options),
2974 setup_call_cleanup(
2975 '$start_consult'(Id, Modified),
2976 '$load_file'(Absolute, Id, LM, Options),
2977 '$end_consult'(Id, LexState, OldModule)).
2978
2979'$end_consult'(Id, LexState, OldModule) :-
2980 '$end_consult'(Id),
2981 '$restore_lex_state'(LexState),
2982 '$set_source_module'(OldModule).
2983
2984
2985:- create_prolog_flag(emulated_dialect, swi, [type(atom)]). 2986
2988
2989'$save_lex_state'(State, Options) :-
2990 memberchk(scope_settings(false), Options),
2991 !,
2992 State = (-).
2993'$save_lex_state'(lexstate(Style, Dialect), _) :-
2994 '$style_check'(Style, Style),
2995 current_prolog_flag(emulated_dialect, Dialect).
2996
2997'$restore_lex_state'(-) :- !.
2998'$restore_lex_state'(lexstate(Style, Dialect)) :-
2999 '$style_check'(_, Style),
3000 set_prolog_flag(emulated_dialect, Dialect).
3001
3002'$set_dialect'(Options) :-
3003 memberchk(dialect(Dialect), Options),
3004 !,
3005 '$expects_dialect'(Dialect).
3006'$set_dialect'(_).
3007
3008'$load_id'(stream(Id, _, _), Id, Modified, Options) :-
3009 !,
3010 '$modified_id'(Id, Modified, Options).
3011'$load_id'(Id, Id, Modified, Options) :-
3012 '$modified_id'(Id, Modified, Options).
3013
3014'$modified_id'(_, Modified, Options) :-
3015 '$option'(modified(Stamp), Options, Def),
3016 Stamp \== Def,
3017 !,
3018 Modified = Stamp.
3019'$modified_id'(Id, Modified, _) :-
3020 catch(time_file(Id, Modified),
3021 error(_, _),
3022 fail),
3023 !.
3024'$modified_id'(_, 0, _).
3025
3026
3027'$compile_type'(What) :-
3028 '$compilation_mode'(How),
3029 ( How == database
3030 -> What = compiled
3031 ; How == qlf
3032 -> What = '*qcompiled*'
3033 ; What = 'boot compiled'
3034 ).
3035
3043
3044:- dynamic
3045 '$load_context_module'/3. 3046:- multifile
3047 '$load_context_module'/3. 3048:- '$notransact'('$load_context_module'/3). 3049
3050'$assert_load_context_module'(_, _, Options) :-
3051 memberchk(register(false), Options),
3052 !.
3053'$assert_load_context_module'(File, Module, Options) :-
3054 source_location(FromFile, Line),
3055 !,
3056 '$master_file'(FromFile, MasterFile),
3057 '$check_load_non_module'(File, Module),
3058 '$add_dialect'(Options, Options1),
3059 '$load_ctx_options'(Options1, Options2),
3060 '$store_admin_clause'(
3061 system:'$load_context_module'(File, Module, Options2),
3062 _Layout, MasterFile, FromFile:Line).
3063'$assert_load_context_module'(File, Module, Options) :-
3064 '$check_load_non_module'(File, Module),
3065 '$add_dialect'(Options, Options1),
3066 '$load_ctx_options'(Options1, Options2),
3067 ( clause('$load_context_module'(File, Module, _), true, Ref),
3068 \+ clause_property(Ref, file(_)),
3069 erase(Ref)
3070 -> true
3071 ; true
3072 ),
3073 assertz('$load_context_module'(File, Module, Options2)).
3074
3075'$add_dialect'(Options0, Options) :-
3076 current_prolog_flag(emulated_dialect, Dialect), Dialect \== swi,
3077 !,
3078 Options = [dialect(Dialect)|Options0].
3079'$add_dialect'(Options, Options).
3080
3085
3086'$load_ctx_options'(Options, CtxOptions) :-
3087 '$load_ctx_options2'(Options, CtxOptions0),
3088 sort(CtxOptions0, CtxOptions).
3089
3090'$load_ctx_options2'([], []).
3091'$load_ctx_options2'([H|T0], [H|T]) :-
3092 '$load_ctx_option'(H),
3093 !,
3094 '$load_ctx_options2'(T0, T).
3095'$load_ctx_options2'([_|T0], T) :-
3096 '$load_ctx_options2'(T0, T).
3097
3098'$load_ctx_option'(derived_from(_)).
3099'$load_ctx_option'(dialect(_)).
3100'$load_ctx_option'(encoding(_)).
3101'$load_ctx_option'(imports(_)).
3102'$load_ctx_option'(reexport(_)).
3103
3104
3109
3110'$check_load_non_module'(File, _) :-
3111 '$current_module'(_, File),
3112 !. 3113'$check_load_non_module'(File, Module) :-
3114 '$load_context_module'(File, OldModule, _),
3115 Module \== OldModule,
3116 !,
3117 format(atom(Msg),
3118 'Non-module file already loaded into module ~w; \c
3119 trying to load into ~w',
3120 [OldModule, Module]),
3121 throw(error(permission_error(load, source, File),
3122 context(load_files/2, Msg))).
3123'$check_load_non_module'(_, _).
3124
3135
3136'$load_file'(Path, Id, Module, Options) :-
3137 State = state(true, _, true, false, Id, -),
3138 ( '$source_term'(Path, _Read, _Layout, Term, Layout,
3139 _Stream, Options),
3140 '$valid_term'(Term),
3141 ( arg(1, State, true)
3142 -> '$first_term'(Term, Layout, Id, State, Options),
3143 nb_setarg(1, State, false)
3144 ; '$compile_term'(Term, Layout, Id, Options)
3145 ),
3146 arg(4, State, true)
3147 ; '$fixup_reconsult'(Id),
3148 '$end_load_file'(State)
3149 ),
3150 !,
3151 arg(2, State, Module).
3152
3153'$valid_term'(Var) :-
3154 var(Var),
3155 !,
3156 print_message(error, error(instantiation_error, _)).
3157'$valid_term'(Term) :-
3158 Term \== [].
3159
3160'$end_load_file'(State) :-
3161 arg(1, State, true), 3162 !,
3163 nb_setarg(2, State, Module),
3164 arg(5, State, Id),
3165 '$current_source_module'(Module),
3166 '$ifcompiling'('$qlf_start_file'(Id)),
3167 '$ifcompiling'('$qlf_end_part').
3168'$end_load_file'(State) :-
3169 arg(3, State, End),
3170 '$end_load_file'(End, State).
3171
3172'$end_load_file'(true, _).
3173'$end_load_file'(end_module, State) :-
3174 arg(2, State, Module),
3175 '$check_export'(Module),
3176 '$ifcompiling'('$qlf_end_part').
3177'$end_load_file'(end_non_module, _State) :-
3178 '$ifcompiling'('$qlf_end_part').
3179
3180
3181'$first_term'(?-(Directive), Layout, Id, State, Options) :-
3182 !,
3183 '$first_term'(:-(Directive), Layout, Id, State, Options).
3184'$first_term'(:-(Directive), _Layout, Id, State, Options) :-
3185 nonvar(Directive),
3186 ( ( Directive = module(Name, Public)
3187 -> Imports = []
3188 ; Directive = module(Name, Public, Imports)
3189 )
3190 -> !,
3191 '$module_name'(Name, Id, Module, Options),
3192 '$start_module'(Module, Public, State, Options),
3193 '$module3'(Imports)
3194 ; Directive = expects_dialect(Dialect)
3195 -> !,
3196 '$set_dialect'(Dialect, State),
3197 fail 3198 ).
3199'$first_term'(Term, Layout, Id, State, Options) :-
3200 '$start_non_module'(Id, Term, State, Options),
3201 '$compile_term'(Term, Layout, Id, Options).
3202
3207
3208'$compile_term'(Term, Layout, SrcId, Options) :-
3209 '$compile_term'(Term, Layout, SrcId, -, Options).
3210
3211'$compile_term'(Var, _Layout, _Id, _SrcLoc, _Options) :-
3212 var(Var),
3213 !,
3214 '$instantiation_error'(Var).
3215'$compile_term'((?-Directive), _Layout, Id, _SrcLoc, Options) :-
3216 !,
3217 '$execute_directive'(Directive, Id, Options).
3218'$compile_term'((:-Directive), _Layout, Id, _SrcLoc, Options) :-
3219 !,
3220 '$execute_directive'(Directive, Id, Options).
3221'$compile_term'('$source_location'(File, Line):Term,
3222 Layout, Id, _SrcLoc, Options) :-
3223 !,
3224 '$compile_term'(Term, Layout, Id, File:Line, Options).
3225'$compile_term'(Clause, Layout, Id, SrcLoc, _Options) :-
3226 E = error(_,_),
3227 catch('$store_clause'(Clause, Layout, Id, SrcLoc), E,
3228 '$print_message'(error, E)).
3229
3230'$start_non_module'(_Id, Term, _State, Options) :-
3231 '$option'(must_be_module(true), Options, false),
3232 !,
3233 '$domain_error'(module_header, Term).
3234'$start_non_module'(Id, _Term, State, _Options) :-
3235 '$current_source_module'(Module),
3236 '$ifcompiling'('$qlf_start_file'(Id)),
3237 '$qset_dialect'(State),
3238 nb_setarg(2, State, Module),
3239 nb_setarg(3, State, end_non_module).
3240
3251
3252'$set_dialect'(Dialect, State) :-
3253 '$compilation_mode'(qlf, database),
3254 !,
3255 '$expects_dialect'(Dialect),
3256 '$compilation_mode'(_, qlf),
3257 nb_setarg(6, State, Dialect).
3258'$set_dialect'(Dialect, _) :-
3259 '$expects_dialect'(Dialect).
3260
3261'$qset_dialect'(State) :-
3262 '$compilation_mode'(qlf),
3263 arg(6, State, Dialect), Dialect \== (-),
3264 !,
3265 '$add_directive_wic'('$expects_dialect'(Dialect)).
3266'$qset_dialect'(_).
3267
3268'$expects_dialect'(Dialect) :-
3269 Dialect == swi,
3270 !,
3271 set_prolog_flag(emulated_dialect, Dialect).
3272'$expects_dialect'(Dialect) :-
3273 current_predicate(expects_dialect/1),
3274 !,
3275 expects_dialect(Dialect).
3276'$expects_dialect'(Dialect) :-
3277 use_module(library(dialect), [expects_dialect/1]),
3278 expects_dialect(Dialect).
3279
3280
3281 3284
3285'$start_module'(Module, _Public, State, _Options) :-
3286 '$current_module'(Module, OldFile),
3287 source_location(File, _Line),
3288 OldFile \== File, OldFile \== [],
3289 same_file(OldFile, File),
3290 !,
3291 nb_setarg(2, State, Module),
3292 nb_setarg(4, State, true). 3293'$start_module'(Module, Public, State, Options) :-
3294 arg(5, State, File),
3295 nb_setarg(2, State, Module),
3296 source_location(_File, Line),
3297 '$option'(redefine_module(Action), Options, false),
3298 '$module_class'(File, Class, Super),
3299 '$reset_dialect'(File, Class),
3300 '$redefine_module'(Module, File, Action),
3301 '$declare_module'(Module, Class, Super, File, Line, false),
3302 '$export_list'(Public, Module, Ops),
3303 '$ifcompiling'('$qlf_start_module'(Module)),
3304 '$export_ops'(Ops, Module, File),
3305 '$qset_dialect'(State),
3306 nb_setarg(3, State, end_module).
3307
3312
3313'$reset_dialect'(File, library) :-
3314 file_name_extension(_, pl, File),
3315 !,
3316 set_prolog_flag(emulated_dialect, swi).
3317'$reset_dialect'(_, _).
3318
3319
3323
3324'$module3'(Var) :-
3325 var(Var),
3326 !,
3327 '$instantiation_error'(Var).
3328'$module3'([]) :- !.
3329'$module3'([H|T]) :-
3330 !,
3331 '$module3'(H),
3332 '$module3'(T).
3333'$module3'(Id) :-
3334 use_module(library(dialect/Id)).
3335
3347
3348'$module_name'(_, _, Module, Options) :-
3349 '$option'(module(Module), Options),
3350 !,
3351 '$current_source_module'(Context),
3352 Context \== Module. 3353'$module_name'(Var, Id, Module, Options) :-
3354 var(Var),
3355 !,
3356 file_base_name(Id, File),
3357 file_name_extension(Var, _, File),
3358 '$module_name'(Var, Id, Module, Options).
3359'$module_name'(Reserved, _, _, _) :-
3360 '$reserved_module'(Reserved),
3361 !,
3362 throw(error(permission_error(load, module, Reserved), _)).
3363'$module_name'(Module, _Id, Module, _).
3364
3365
3366'$reserved_module'(system).
3367'$reserved_module'(user).
3368
3369
3371
3372'$redefine_module'(_Module, _, false) :- !.
3373'$redefine_module'(Module, File, true) :-
3374 !,
3375 ( module_property(Module, file(OldFile)),
3376 File \== OldFile
3377 -> unload_file(OldFile)
3378 ; true
3379 ).
3380'$redefine_module'(Module, File, ask) :-
3381 ( stream_property(user_input, tty(true)),
3382 module_property(Module, file(OldFile)),
3383 File \== OldFile,
3384 '$rdef_response'(Module, OldFile, File, true)
3385 -> '$redefine_module'(Module, File, true)
3386 ; true
3387 ).
3388
3389'$rdef_response'(Module, OldFile, File, Ok) :-
3390 repeat,
3391 print_message(query, redefine_module(Module, OldFile, File)),
3392 get_single_char(Char),
3393 '$rdef_response'(Char, Ok0),
3394 !,
3395 Ok = Ok0.
3396
3397'$rdef_response'(Char, true) :-
3398 memberchk(Char, `yY`),
3399 format(user_error, 'yes~n', []).
3400'$rdef_response'(Char, false) :-
3401 memberchk(Char, `nN`),
3402 format(user_error, 'no~n', []).
3403'$rdef_response'(Char, _) :-
3404 memberchk(Char, `a`),
3405 format(user_error, 'abort~n', []),
3406 abort.
3407'$rdef_response'(_, _) :-
3408 print_message(help, redefine_module_reply),
3409 fail.
3410
3411
3418
3419'$module_class'(File, Class, system) :-
3420 current_prolog_flag(home, Home),
3421 sub_atom(File, 0, Len, _, Home),
3422 ( sub_atom(File, Len, _, _, '/boot/')
3423 -> !, Class = system
3424 ; '$lib_prefix'(Prefix),
3425 sub_atom(File, Len, _, _, Prefix)
3426 -> !, Class = library
3427 ; file_directory_name(File, Home),
3428 file_name_extension(_, rc, File)
3429 -> !, Class = library
3430 ).
3431'$module_class'(_, user, user).
3432
3433'$lib_prefix'('/library').
3434'$lib_prefix'('/xpce/prolog/').
3435
3436'$check_export'(Module) :-
3437 '$undefined_export'(Module, UndefList),
3438 ( '$member'(Undef, UndefList),
3439 strip_module(Undef, _, Local),
3440 print_message(error,
3441 undefined_export(Module, Local)),
3442 fail
3443 ; true
3444 ).
3445
3446
3452
3453'$import_list'(_, _, Var, _) :-
3454 var(Var),
3455 !,
3456 throw(error(instantitation_error, _)).
3457'$import_list'(Target, Source, all, Reexport) :-
3458 !,
3459 '$exported_ops'(Source, Import, Predicates),
3460 '$module_property'(Source, exports(Predicates)),
3461 '$import_all'(Import, Target, Source, Reexport, weak).
3462'$import_list'(Target, Source, except(Spec), Reexport) :-
3463 !,
3464 '$exported_ops'(Source, Export, Predicates),
3465 '$module_property'(Source, exports(Predicates)),
3466 ( is_list(Spec)
3467 -> true
3468 ; throw(error(type_error(list, Spec), _))
3469 ),
3470 '$import_except'(Spec, Source, Export, Import),
3471 '$import_all'(Import, Target, Source, Reexport, weak).
3472'$import_list'(Target, Source, Import, Reexport) :-
3473 !,
3474 is_list(Import),
3475 !,
3476 '$import_all'(Import, Target, Source, Reexport, strong).
3477'$import_list'(_, _, Import, _) :-
3478 '$type_error'(import_specifier, Import).
3479
3480
3481'$import_except'([], _, List, List).
3482'$import_except'([H|T], Source, List0, List) :-
3483 '$import_except_1'(H, Source, List0, List1),
3484 '$import_except'(T, Source, List1, List).
3485
3486'$import_except_1'(Var, _, _, _) :-
3487 var(Var),
3488 !,
3489 '$instantiation_error'(Var).
3490'$import_except_1'(PI as N, _, List0, List) :-
3491 '$pi'(PI), atom(N),
3492 !,
3493 '$canonical_pi'(PI, CPI),
3494 '$import_as'(CPI, N, List0, List).
3495'$import_except_1'(op(P,A,N), _, List0, List) :-
3496 !,
3497 '$remove_ops'(List0, op(P,A,N), List).
3498'$import_except_1'(PI, Source, List0, List) :-
3499 '$pi'(PI),
3500 !,
3501 '$canonical_pi'(PI, CPI),
3502 ( '$select'(P, List0, List),
3503 '$canonical_pi'(CPI, P)
3504 -> true
3505 ; print_message(warning,
3506 error(existence_error(export, PI, module(Source)), _)),
3507 List = List0
3508 ).
3509'$import_except_1'(Except, _, _, _) :-
3510 '$type_error'(import_specifier, Except).
3511
3512'$import_as'(CPI, N, [PI2|T], [CPI as N|T]) :-
3513 '$canonical_pi'(PI2, CPI),
3514 !.
3515'$import_as'(PI, N, [H|T0], [H|T]) :-
3516 !,
3517 '$import_as'(PI, N, T0, T).
3518'$import_as'(PI, _, _, _) :-
3519 '$existence_error'(export, PI).
3520
3521'$pi'(N/A) :- atom(N), integer(A), !.
3522'$pi'(N//A) :- atom(N), integer(A).
3523
3524'$canonical_pi'(N//A0, N/A) :-
3525 A is A0 + 2.
3526'$canonical_pi'(PI, PI).
3527
3528'$remove_ops'([], _, []).
3529'$remove_ops'([Op|T0], Pattern, T) :-
3530 subsumes_term(Pattern, Op),
3531 !,
3532 '$remove_ops'(T0, Pattern, T).
3533'$remove_ops'([H|T0], Pattern, [H|T]) :-
3534 '$remove_ops'(T0, Pattern, T).
3535
3536
3538
3539'$import_all'(Import, Context, Source, Reexport, Strength) :-
3540 '$import_all2'(Import, Context, Source, Imported, ImpOps, Strength),
3541 ( Reexport == true,
3542 ( '$list_to_conj'(Imported, Conj)
3543 -> export(Context:Conj),
3544 '$ifcompiling'('$add_directive_wic'(export(Context:Conj)))
3545 ; true
3546 ),
3547 source_location(File, _Line),
3548 '$export_ops'(ImpOps, Context, File)
3549 ; true
3550 ).
3551
3553
3554'$import_all2'([], _, _, [], [], _).
3555'$import_all2'([PI as NewName|Rest], Context, Source,
3556 [NewName/Arity|Imported], ImpOps, Strength) :-
3557 !,
3558 '$canonical_pi'(PI, Name/Arity),
3559 length(Args, Arity),
3560 Head =.. [Name|Args],
3561 NewHead =.. [NewName|Args],
3562 ( '$get_predicate_attribute'(Source:Head, meta_predicate, Meta)
3563 -> Meta =.. [Name|MetaArgs],
3564 NewMeta =.. [NewName|MetaArgs],
3565 meta_predicate(Context:NewMeta)
3566 ; '$get_predicate_attribute'(Source:Head, transparent, 1)
3567 -> '$set_predicate_attribute'(Context:NewHead, transparent, true)
3568 ; true
3569 ),
3570 ( source_location(File, Line)
3571 -> E = error(_,_),
3572 catch('$store_admin_clause'((NewHead :- Source:Head),
3573 _Layout, File, File:Line),
3574 E, '$print_message'(error, E))
3575 ; assertz((NewHead :- !, Source:Head)) 3576 ), 3577 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
3578'$import_all2'([op(P,A,N)|Rest], Context, Source, Imported,
3579 [op(P,A,N)|ImpOps], Strength) :-
3580 !,
3581 '$import_ops'(Context, Source, op(P,A,N)),
3582 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
3583'$import_all2'([Pred|Rest], Context, Source, [Pred|Imported], ImpOps, Strength) :-
3584 Error = error(_,_),
3585 catch(Context:'$import'(Source:Pred, Strength), Error,
3586 print_message(error, Error)),
3587 '$ifcompiling'('$import_wic'(Source, Pred, Strength)),
3588 '$import_all2'(Rest, Context, Source, Imported, ImpOps, Strength).
3589
3590
3591'$list_to_conj'([One], One) :- !.
3592'$list_to_conj'([H|T], (H,Rest)) :-
3593 '$list_to_conj'(T, Rest).
3594
3599
3600'$exported_ops'(Module, Ops, Tail) :-
3601 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
3602 !,
3603 findall(op(P,A,N), Module:'$exported_op'(P,A,N), Ops, Tail).
3604'$exported_ops'(_, Ops, Ops).
3605
3606'$exported_op'(Module, P, A, N) :-
3607 '$c_current_predicate'(_, Module:'$exported_op'(_,_,_)),
3608 Module:'$exported_op'(P, A, N).
3609
3614
3615'$import_ops'(To, From, Pattern) :-
3616 ground(Pattern),
3617 !,
3618 Pattern = op(P,A,N),
3619 op(P,A,To:N),
3620 ( '$exported_op'(From, P, A, N)
3621 -> true
3622 ; print_message(warning, no_exported_op(From, Pattern))
3623 ).
3624'$import_ops'(To, From, Pattern) :-
3625 ( '$exported_op'(From, Pri, Assoc, Name),
3626 Pattern = op(Pri, Assoc, Name),
3627 op(Pri, Assoc, To:Name),
3628 fail
3629 ; true
3630 ).
3631
3632
3637
3638'$export_list'(Decls, Module, Ops) :-
3639 is_list(Decls),
3640 !,
3641 '$do_export_list'(Decls, Module, Ops).
3642'$export_list'(Decls, _, _) :-
3643 var(Decls),
3644 throw(error(instantiation_error, _)).
3645'$export_list'(Decls, _, _) :-
3646 throw(error(type_error(list, Decls), _)).
3647
3648'$do_export_list'([], _, []) :- !.
3649'$do_export_list'([H|T], Module, Ops) :-
3650 !,
3651 E = error(_,_),
3652 catch('$export1'(H, Module, Ops, Ops1),
3653 E, ('$print_message'(error, E), Ops = Ops1)),
3654 '$do_export_list'(T, Module, Ops1).
3655
3656'$export1'(Var, _, _, _) :-
3657 var(Var),
3658 !,
3659 throw(error(instantiation_error, _)).
3660'$export1'(Op, _, [Op|T], T) :-
3661 Op = op(_,_,_),
3662 !.
3663'$export1'(PI0, Module, Ops, Ops) :-
3664 strip_module(Module:PI0, M, PI),
3665 ( PI = (_//_)
3666 -> non_terminal(M:PI)
3667 ; true
3668 ),
3669 export(M:PI).
3670
3671'$export_ops'([op(Pri, Assoc, Name)|T], Module, File) :-
3672 E = error(_,_),
3673 catch(( '$execute_directive'(op(Pri, Assoc, Module:Name), File, []),
3674 '$export_op'(Pri, Assoc, Name, Module, File)
3675 ),
3676 E, '$print_message'(error, E)),
3677 '$export_ops'(T, Module, File).
3678'$export_ops'([], _, _).
3679
3680'$export_op'(Pri, Assoc, Name, Module, File) :-
3681 ( '$get_predicate_attribute'(Module:'$exported_op'(_,_,_), defined, 1)
3682 -> true
3683 ; '$execute_directive'(discontiguous(Module:'$exported_op'/3), File, [])
3684 ),
3685 '$store_admin_clause'('$exported_op'(Pri, Assoc, Name), _Layout, File, -).
3686
3690
3691'$execute_directive'(Var, _F, _Options) :-
3692 var(Var),
3693 '$instantiation_error'(Var).
3694'$execute_directive'(encoding(Encoding), _F, _Options) :-
3695 !,
3696 ( '$load_input'(_F, S)
3697 -> set_stream(S, encoding(Encoding))
3698 ).
3699'$execute_directive'(Goal, _, Options) :-
3700 \+ '$compilation_mode'(database),
3701 !,
3702 '$add_directive_wic2'(Goal, Type, Options),
3703 ( Type == call 3704 -> '$compilation_mode'(Old, database),
3705 setup_call_cleanup(
3706 '$directive_mode'(OldDir, Old),
3707 '$execute_directive_3'(Goal),
3708 ( '$set_compilation_mode'(Old),
3709 '$set_directive_mode'(OldDir)
3710 ))
3711 ; '$execute_directive_3'(Goal)
3712 ).
3713'$execute_directive'(Goal, _, _Options) :-
3714 '$execute_directive_3'(Goal).
3715
3716'$execute_directive_3'(Goal) :-
3717 '$current_source_module'(Module),
3718 '$valid_directive'(Module:Goal),
3719 !,
3720 ( '$pattr_directive'(Goal, Module)
3721 -> true
3722 ; Term = error(_,_),
3723 catch(Module:Goal, Term, '$exception_in_directive'(Term))
3724 -> true
3725 ; '$print_message'(warning, goal_failed(directive, Module:Goal)),
3726 fail
3727 ).
3728'$execute_directive_3'(_).
3729
3730
3736
3737:- multifile prolog:sandbox_allowed_directive/1. 3738:- multifile prolog:sandbox_allowed_clause/1. 3739:- meta_predicate '$valid_directive'(:). 3740
3741'$valid_directive'(_) :-
3742 current_prolog_flag(sandboxed_load, false),
3743 !.
3744'$valid_directive'(Goal) :-
3745 Error = error(Formal, _),
3746 catch(prolog:sandbox_allowed_directive(Goal), Error, true),
3747 !,
3748 ( var(Formal)
3749 -> true
3750 ; print_message(error, Error),
3751 fail
3752 ).
3753'$valid_directive'(Goal) :-
3754 print_message(error,
3755 error(permission_error(execute,
3756 sandboxed_directive,
3757 Goal), _)),
3758 fail.
3759
3760'$exception_in_directive'(Term) :-
3761 '$print_message'(error, Term),
3762 fail.
3763
3769
3770'$add_directive_wic2'(Goal, Type, Options) :-
3771 '$common_goal_type'(Goal, Type, Options),
3772 !,
3773 ( Type == load
3774 -> true
3775 ; '$current_source_module'(Module),
3776 '$add_directive_wic'(Module:Goal)
3777 ).
3778'$add_directive_wic2'(Goal, _, _) :-
3779 ( '$compilation_mode'(qlf) 3780 -> true
3781 ; print_message(error, mixed_directive(Goal))
3782 ).
3783
3788
3789'$common_goal_type'((A,B), Type, Options) :-
3790 !,
3791 '$common_goal_type'(A, Type, Options),
3792 '$common_goal_type'(B, Type, Options).
3793'$common_goal_type'((A;B), Type, Options) :-
3794 !,
3795 '$common_goal_type'(A, Type, Options),
3796 '$common_goal_type'(B, Type, Options).
3797'$common_goal_type'((A->B), Type, Options) :-
3798 !,
3799 '$common_goal_type'(A, Type, Options),
3800 '$common_goal_type'(B, Type, Options).
3801'$common_goal_type'(Goal, Type, Options) :-
3802 '$goal_type'(Goal, Type, Options).
3803
3804'$goal_type'(Goal, Type, Options) :-
3805 ( '$load_goal'(Goal, Options)
3806 -> Type = load
3807 ; Type = call
3808 ).
3809
3810:- thread_local
3811 '$qlf':qinclude/1. 3812
3813'$load_goal'([_|_], _).
3814'$load_goal'(consult(_), _).
3815'$load_goal'(load_files(_), _).
3816'$load_goal'(load_files(_,Options), _) :-
3817 memberchk(qcompile(QlfMode), Options),
3818 '$qlf_part_mode'(QlfMode).
3819'$load_goal'(ensure_loaded(_), _) :- '$compilation_mode'(wic).
3820'$load_goal'(use_module(_), _) :- '$compilation_mode'(wic).
3821'$load_goal'(use_module(_, _), _) :- '$compilation_mode'(wic).
3822'$load_goal'(reexport(_), _) :- '$compilation_mode'(wic).
3823'$load_goal'(reexport(_, _), _) :- '$compilation_mode'(wic).
3824'$load_goal'(Goal, _Options) :-
3825 '$qlf':qinclude(user),
3826 '$load_goal_file'(Goal, File),
3827 '$all_user_files'(File).
3828
3829
3830'$load_goal_file'(load_files(F), F).
3831'$load_goal_file'(load_files(F, _), F).
3832'$load_goal_file'(ensure_loaded(F), F).
3833'$load_goal_file'(use_module(F), F).
3834'$load_goal_file'(use_module(F, _), F).
3835'$load_goal_file'(reexport(F), F).
3836'$load_goal_file'(reexport(F, _), F).
3837
3838'$all_user_files'([]) :-
3839 !.
3840'$all_user_files'([H|T]) :-
3841 !,
3842 '$is_user_file'(H),
3843 '$all_user_files'(T).
3844'$all_user_files'(F) :-
3845 ground(F),
3846 '$is_user_file'(F).
3847
3848'$is_user_file'(File) :-
3849 absolute_file_name(File, Path,
3850 [ file_type(prolog),
3851 access(read)
3852 ]),
3853 '$module_class'(Path, user, _).
3854
3855'$qlf_part_mode'(part).
3856'$qlf_part_mode'(true). 3857
3858
3859 3862
3867
3868'$store_admin_clause'(Clause, Layout, Owner, SrcLoc) :-
3869 Owner \== (-),
3870 !,
3871 setup_call_cleanup(
3872 '$start_aux'(Owner, Context),
3873 '$store_admin_clause2'(Clause, Layout, Owner, SrcLoc),
3874 '$end_aux'(Owner, Context)).
3875'$store_admin_clause'(Clause, Layout, File, SrcLoc) :-
3876 '$store_admin_clause2'(Clause, Layout, File, SrcLoc).
3877
3878'$store_admin_clause2'(Clause, _Layout, File, SrcLoc) :-
3879 ( '$compilation_mode'(database)
3880 -> '$record_clause'(Clause, File, SrcLoc)
3881 ; '$record_clause'(Clause, File, SrcLoc, Ref),
3882 '$qlf_assert_clause'(Ref, development)
3883 ).
3884
3892
3893'$store_clause'((_, _), _, _, _) :-
3894 !,
3895 print_message(error, cannot_redefine_comma),
3896 fail.
3897'$store_clause'((Pre => Body), _Layout, File, SrcLoc) :-
3898 nonvar(Pre),
3899 Pre = (Head,Cond),
3900 !,
3901 ( '$is_true'(Cond), current_prolog_flag(optimise, true)
3902 -> '$store_clause'((Head=>Body), _Layout, File, SrcLoc)
3903 ; '$store_clause'(?=>(Head,(Cond,!,Body)), _Layout, File, SrcLoc)
3904 ).
3905'$store_clause'(Clause, _Layout, File, SrcLoc) :-
3906 '$valid_clause'(Clause),
3907 !,
3908 ( '$compilation_mode'(database)
3909 -> '$record_clause'(Clause, File, SrcLoc)
3910 ; '$record_clause'(Clause, File, SrcLoc, Ref),
3911 '$qlf_assert_clause'(Ref, development)
3912 ).
3913
3914'$is_true'(true) => true.
3915'$is_true'((A,B)) => '$is_true'(A), '$is_true'(B).
3916'$is_true'(_) => fail.
3917
3918'$valid_clause'(_) :-
3919 current_prolog_flag(sandboxed_load, false),
3920 !.
3921'$valid_clause'(Clause) :-
3922 \+ '$cross_module_clause'(Clause),
3923 !.
3924'$valid_clause'(Clause) :-
3925 Error = error(Formal, _),
3926 catch(prolog:sandbox_allowed_clause(Clause), Error, true),
3927 !,
3928 ( var(Formal)
3929 -> true
3930 ; print_message(error, Error),
3931 fail
3932 ).
3933'$valid_clause'(Clause) :-
3934 print_message(error,
3935 error(permission_error(assert,
3936 sandboxed_clause,
3937 Clause), _)),
3938 fail.
3939
3940'$cross_module_clause'(Clause) :-
3941 '$head_module'(Clause, Module),
3942 \+ '$current_source_module'(Module).
3943
3944'$head_module'(Var, _) :-
3945 var(Var), !, fail.
3946'$head_module'((Head :- _), Module) :-
3947 '$head_module'(Head, Module).
3948'$head_module'(Module:_, Module).
3949
3950'$clause_source'('$source_location'(File,Line):Clause, Clause, File:Line) :- !.
3951'$clause_source'(Clause, Clause, -).
3952
3957
3958:- public
3959 '$store_clause'/2. 3960
3961'$store_clause'(Term, Id) :-
3962 '$clause_source'(Term, Clause, SrcLoc),
3963 '$store_clause'(Clause, _, Id, SrcLoc).
3964
3983
3984compile_aux_clauses(_Clauses) :-
3985 current_prolog_flag(xref, true),
3986 !.
3987compile_aux_clauses(Clauses) :-
3988 source_location(File, _Line),
3989 '$compile_aux_clauses'(Clauses, File).
3990
3991'$compile_aux_clauses'(Clauses, File) :-
3992 setup_call_cleanup(
3993 '$start_aux'(File, Context),
3994 '$store_aux_clauses'(Clauses, File),
3995 '$end_aux'(File, Context)).
3996
3997'$store_aux_clauses'(Clauses, File) :-
3998 is_list(Clauses),
3999 !,
4000 forall('$member'(C,Clauses),
4001 '$compile_term'(C, _Layout, File, [])).
4002'$store_aux_clauses'(Clause, File) :-
4003 '$compile_term'(Clause, _Layout, File, []).
4004
4005
4006 4009
4017
4018'$stage_file'(Target, Stage) :-
4019 file_directory_name(Target, Dir),
4020 file_base_name(Target, File),
4021 current_prolog_flag(pid, Pid),
4022 format(atom(Stage), '~w/.~w.~d', [Dir,File,Pid]).
4023
4024'$install_staged_file'(exit, Staged, Target, error) :-
4025 !,
4026 rename_file(Staged, Target).
4027'$install_staged_file'(exit, Staged, Target, OnError) :-
4028 !,
4029 InstallError = error(_,_),
4030 catch(rename_file(Staged, Target),
4031 InstallError,
4032 '$install_staged_error'(OnError, InstallError, Staged, Target)).
4033'$install_staged_file'(_, Staged, _, _OnError) :-
4034 E = error(_,_),
4035 catch(delete_file(Staged), E, true).
4036
4037'$install_staged_error'(OnError, Error, Staged, _Target) :-
4038 E = error(_,_),
4039 catch(delete_file(Staged), E, true),
4040 ( OnError = silent
4041 -> true
4042 ; OnError = fail
4043 -> fail
4044 ; print_message(warning, Error)
4045 ).
4046
4047
4048 4051
4052:- multifile
4053 prolog:comment_hook/3. 4054
4055
4056 4059
4063
4064:- dynamic
4065 '$foreign_registered'/2. 4066
4067 4070
4073
4074:- dynamic
4075 '$expand_goal'/2,
4076 '$expand_term'/4. 4077
4078'$expand_goal'(In, In).
4079'$expand_term'(In, Layout, In, Layout).
4080
4081
4082 4085
4086'$type_error'(Type, Value) :-
4087 ( var(Value)
4088 -> throw(error(instantiation_error, _))
4089 ; throw(error(type_error(Type, Value), _))
4090 ).
4091
4092'$domain_error'(Type, Value) :-
4093 throw(error(domain_error(Type, Value), _)).
4094
4095'$existence_error'(Type, Object) :-
4096 throw(error(existence_error(Type, Object), _)).
4097
4098'$existence_error'(Type, Object, In) :-
4099 throw(error(existence_error(Type, Object, In), _)).
4100
4101'$permission_error'(Action, Type, Term) :-
4102 throw(error(permission_error(Action, Type, Term), _)).
4103
4104'$instantiation_error'(_Var) :-
4105 throw(error(instantiation_error, _)).
4106
4107'$uninstantiation_error'(NonVar) :-
4108 throw(error(uninstantiation_error(NonVar), _)).
4109
4110'$must_be'(list, X) :- !,
4111 '$skip_list'(_, X, Tail),
4112 ( Tail == []
4113 -> true
4114 ; '$type_error'(list, Tail)
4115 ).
4116'$must_be'(options, X) :- !,
4117 ( '$is_options'(X)
4118 -> true
4119 ; '$type_error'(options, X)
4120 ).
4121'$must_be'(atom, X) :- !,
4122 ( atom(X)
4123 -> true
4124 ; '$type_error'(atom, X)
4125 ).
4126'$must_be'(integer, X) :- !,
4127 ( integer(X)
4128 -> true
4129 ; '$type_error'(integer, X)
4130 ).
4131'$must_be'(between(Low,High), X) :- !,
4132 ( integer(X)
4133 -> ( between(Low, High, X)
4134 -> true
4135 ; '$domain_error'(between(Low,High), X)
4136 )
4137 ; '$type_error'(integer, X)
4138 ).
4139'$must_be'(callable, X) :- !,
4140 ( callable(X)
4141 -> true
4142 ; '$type_error'(callable, X)
4143 ).
4144'$must_be'(acyclic, X) :- !,
4145 ( acyclic_term(X)
4146 -> true
4147 ; '$domain_error'(acyclic_term, X)
4148 ).
4149'$must_be'(oneof(Type, Domain, List), X) :- !,
4150 '$must_be'(Type, X),
4151 ( memberchk(X, List)
4152 -> true
4153 ; '$domain_error'(Domain, X)
4154 ).
4155'$must_be'(boolean, X) :- !,
4156 ( (X == true ; X == false)
4157 -> true
4158 ; '$type_error'(boolean, X)
4159 ).
4160'$must_be'(ground, X) :- !,
4161 ( ground(X)
4162 -> true
4163 ; '$instantiation_error'(X)
4164 ).
4165'$must_be'(filespec, X) :- !,
4166 ( ( atom(X)
4167 ; string(X)
4168 ; compound(X),
4169 compound_name_arity(X, _, 1)
4170 )
4171 -> true
4172 ; '$type_error'(filespec, X)
4173 ).
4174
4177
4178
4179 4182
4183'$member'(El, [H|T]) :-
4184 '$member_'(T, El, H).
4185
4186'$member_'(_, El, El).
4187'$member_'([H|T], El, _) :-
4188 '$member_'(T, El, H).
4189
4190'$append'([], L, L).
4191'$append'([H|T], L, [H|R]) :-
4192 '$append'(T, L, R).
4193
4194'$append'(ListOfLists, List) :-
4195 '$must_be'(list, ListOfLists),
4196 '$append_'(ListOfLists, List).
4197
4198'$append_'([], []).
4199'$append_'([L|Ls], As) :-
4200 '$append'(L, Ws, As),
4201 '$append_'(Ls, Ws).
4202
4203'$select'(X, [X|Tail], Tail).
4204'$select'(Elem, [Head|Tail], [Head|Rest]) :-
4205 '$select'(Elem, Tail, Rest).
4206
4207'$reverse'(L1, L2) :-
4208 '$reverse'(L1, [], L2).
4209
4210'$reverse'([], List, List).
4211'$reverse'([Head|List1], List2, List3) :-
4212 '$reverse'(List1, [Head|List2], List3).
4213
4214'$delete'([], _, []) :- !.
4215'$delete'([Elem|Tail], Elem, Result) :-
4216 !,
4217 '$delete'(Tail, Elem, Result).
4218'$delete'([Head|Tail], Elem, [Head|Rest]) :-
4219 '$delete'(Tail, Elem, Rest).
4220
4221'$last'([H|T], Last) :-
4222 '$last'(T, H, Last).
4223
4224'$last'([], Last, Last).
4225'$last'([H|T], _, Last) :-
4226 '$last'(T, H, Last).
4227
4228:- meta_predicate '$include'(1,+,-). 4229'$include'(_, [], []).
4230'$include'(G, [H|T0], L) :-
4231 ( call(G,H)
4232 -> L = [H|T]
4233 ; T = L
4234 ),
4235 '$include'(G, T0, T).
4236
4237
4241
4242:- '$iso'((length/2)). 4243
4244length(List, Length) :-
4245 var(Length),
4246 !,
4247 '$skip_list'(Length0, List, Tail),
4248 ( Tail == []
4249 -> Length = Length0 4250 ; var(Tail)
4251 -> Tail \== Length, 4252 '$length3'(Tail, Length, Length0) 4253 ; throw(error(type_error(list, List),
4254 context(length/2, _)))
4255 ).
4256length(List, Length) :-
4257 integer(Length),
4258 Length >= 0,
4259 !,
4260 '$skip_list'(Length0, List, Tail),
4261 ( Tail == [] 4262 -> Length = Length0
4263 ; var(Tail)
4264 -> Extra is Length-Length0,
4265 '$length'(Tail, Extra)
4266 ; throw(error(type_error(list, List),
4267 context(length/2, _)))
4268 ).
4269length(_, Length) :-
4270 integer(Length),
4271 !,
4272 throw(error(domain_error(not_less_than_zero, Length),
4273 context(length/2, _))).
4274length(_, Length) :-
4275 throw(error(type_error(integer, Length),
4276 context(length/2, _))).
4277
4278'$length3'([], N, N).
4279'$length3'([_|List], N, N0) :-
4280 N1 is N0+1,
4281 '$length3'(List, N, N1).
4282
4283
4284 4287
4291
4292'$is_options'(Map) :-
4293 is_dict(Map, _),
4294 !.
4295'$is_options'(List) :-
4296 is_list(List),
4297 ( List == []
4298 -> true
4299 ; List = [H|_],
4300 '$is_option'(H, _, _)
4301 ).
4302
4303'$is_option'(Var, _, _) :-
4304 var(Var), !, fail.
4305'$is_option'(F, Name, Value) :-
4306 functor(F, _, 1),
4307 !,
4308 F =.. [Name,Value].
4309'$is_option'(Name=Value, Name, Value).
4310
4312
4313'$option'(Opt, Options) :-
4314 is_dict(Options),
4315 !,
4316 [Opt] :< Options.
4317'$option'(Opt, Options) :-
4318 memberchk(Opt, Options).
4319
4321
4322'$option'(Term, Options, Default) :-
4323 arg(1, Term, Value),
4324 functor(Term, Name, 1),
4325 ( is_dict(Options)
4326 -> ( get_dict(Name, Options, GVal)
4327 -> Value = GVal
4328 ; Value = Default
4329 )
4330 ; functor(Gen, Name, 1),
4331 arg(1, Gen, GVal),
4332 ( memberchk(Gen, Options)
4333 -> Value = GVal
4334 ; Value = Default
4335 )
4336 ).
4337
4343
4344'$select_option'(Opt, Options, Rest) :-
4345 '$options_dict'(Options, Dict),
4346 select_dict([Opt], Dict, Rest).
4347
4353
4354'$merge_options'(New, Old, Merged) :-
4355 '$options_dict'(New, NewDict),
4356 '$options_dict'(Old, OldDict),
4357 put_dict(NewDict, OldDict, Merged).
4358
4363
4364'$options_dict'(Options, Dict) :-
4365 is_list(Options),
4366 !,
4367 '$keyed_options'(Options, Keyed),
4368 sort(1, @<, Keyed, UniqueKeyed),
4369 '$pairs_values'(UniqueKeyed, Unique),
4370 dict_create(Dict, _, Unique).
4371'$options_dict'(Dict, Dict) :-
4372 is_dict(Dict),
4373 !.
4374'$options_dict'(Options, _) :-
4375 '$domain_error'(options, Options).
4376
4377'$keyed_options'([], []).
4378'$keyed_options'([H0|T0], [H|T]) :-
4379 '$keyed_option'(H0, H),
4380 '$keyed_options'(T0, T).
4381
4382'$keyed_option'(Var, _) :-
4383 var(Var),
4384 !,
4385 '$instantiation_error'(Var).
4386'$keyed_option'(Name=Value, Name-(Name-Value)).
4387'$keyed_option'(NameValue, Name-(Name-Value)) :-
4388 compound_name_arguments(NameValue, Name, [Value]),
4389 !.
4390'$keyed_option'(Opt, _) :-
4391 '$domain_error'(option, Opt).
4392
4393
4394 4397
4398:- public '$prolog_list_goal'/1. 4399
4400:- multifile
4401 user:prolog_list_goal/1. 4402
4403'$prolog_list_goal'(Goal) :-
4404 user:prolog_list_goal(Goal),
4405 !.
4406'$prolog_list_goal'(Goal) :-
4407 use_module(library(listing), [listing/1]),
4408 @(listing(Goal), user).
4409
4410
4411 4414
4415:- '$iso'((halt/0)). 4416
4417halt :-
4418 '$exit_code'(Code),
4419 ( Code == 0
4420 -> true
4421 ; print_message(warning, on_error(halt(1)))
4422 ),
4423 halt(Code).
4424
4429
4430'$exit_code'(Code) :-
4431 ( ( current_prolog_flag(on_error, status),
4432 statistics(errors, Count),
4433 Count > 0
4434 ; current_prolog_flag(on_warning, status),
4435 statistics(warnings, Count),
4436 Count > 0
4437 )
4438 -> Code = 1
4439 ; Code = 0
4440 ).
4441
4442
4448
4449:- meta_predicate at_halt(0). 4450:- dynamic system:term_expansion/2, '$at_halt'/2. 4451:- multifile system:term_expansion/2, '$at_halt'/2. 4452
4453system:term_expansion((:- at_halt(Goal)),
4454 system:'$at_halt'(Module:Goal, File:Line)) :-
4455 \+ current_prolog_flag(xref, true),
4456 source_location(File, Line),
4457 '$current_source_module'(Module).
4458
4459at_halt(Goal) :-
4460 asserta('$at_halt'(Goal, (-):0)).
4461
4462:- public '$run_at_halt'/0. 4463
4464'$run_at_halt' :-
4465 forall(clause('$at_halt'(Goal, Src), true, Ref),
4466 ( '$call_at_halt'(Goal, Src),
4467 erase(Ref)
4468 )).
4469
4470'$call_at_halt'(Goal, _Src) :-
4471 catch(Goal, E, true),
4472 !,
4473 ( var(E)
4474 -> true
4475 ; subsumes_term(cancel_halt(_), E)
4476 -> '$print_message'(informational, E),
4477 fail
4478 ; '$print_message'(error, E)
4479 ).
4480'$call_at_halt'(Goal, _Src) :-
4481 '$print_message'(warning, goal_failed(at_halt, Goal)).
4482
4488
4489cancel_halt(Reason) :-
4490 throw(cancel_halt(Reason)).
4491
4496
4497:- multifile prolog:heartbeat/0. 4498
4499
4500 4503
4504:- meta_predicate
4505 '$load_wic_files'(:). 4506
4507'$load_wic_files'(Files) :-
4508 Files = Module:_,
4509 '$execute_directive'('$set_source_module'(OldM, Module), [], []),
4510 '$save_lex_state'(LexState, []),
4511 '$style_check'(_, 0xC7), 4512 '$compilation_mode'(OldC, wic),
4513 consult(Files),
4514 '$execute_directive'('$set_source_module'(OldM), [], []),
4515 '$execute_directive'('$restore_lex_state'(LexState), [], []),
4516 '$set_compilation_mode'(OldC).
4517
4518
4523
4524:- public '$load_additional_boot_files'/0. 4525
4526'$load_additional_boot_files' :-
4527 current_prolog_flag(argv, Argv),
4528 '$get_files_argv'(Argv, Files),
4529 ( Files \== []
4530 -> format('Loading additional boot files~n'),
4531 '$load_wic_files'(user:Files),
4532 format('additional boot files loaded~n')
4533 ; true
4534 ).
4535
4536'$get_files_argv'([], []) :- !.
4537'$get_files_argv'(['-c'|Files], Files) :- !.
4538'$get_files_argv'([_|Rest], Files) :-
4539 '$get_files_argv'(Rest, Files).
4540
4541'$:-'(('$boot_message'('Loading Prolog startup files~n', []),
4542 source_location(File, _Line),
4543 file_directory_name(File, Dir),
4544 atom_concat(Dir, '/load.pl', LoadFile),
4545 '$load_wic_files'(system:[LoadFile]),
4546 ( current_prolog_flag(windows, true)
4547 -> atom_concat(Dir, '/menu.pl', MenuFile),
4548 '$load_wic_files'(system:[MenuFile])
4549 ; true
4550 ),
4551 '$boot_message'('SWI-Prolog boot files loaded~n', []),
4552 '$compilation_mode'(OldC, wic),
4553 '$execute_directive'('$set_source_module'(user), [], []),
4554 '$set_compilation_mode'(OldC)
4555 ))