/**
* Warranty & Liability
* To the extent permitted by applicable law and unless explicitly
* otherwise agreed upon, XLOG Technologies AG makes no warranties
* regarding the provided information. XLOG Technologies AG assumes
* no liability that any problems might be solved with the information
* provided by XLOG Technologies AG.
*
* Rights & License
* All industrial property rights regarding the information - copyright
* and patent rights in particular - are the sole property of XLOG
* Technologies AG. If the company was not the originator of some
* excerpts, XLOG Technologies AG has at least obtained the right to
* reproduce, change and translate the information.
*
* Reproduction is restricted to the whole unaltered document. Reproduction
* of the information is only allowed for non-commercial uses. Selling,
* giving away or letting of the execution of the library is prohibited.
* The library can be distributed as part of your applications and libraries
* for execution provided this comment remains unchanged.
*
* Restrictions
* Only to be distributed with programs that add significant and primary
* functionality to the library. Not to be distributed with additional
* software intended to replace any components of the library.
*
* Trademarks
* Jekejeke is a registered trademark of XLOG Technologies AG.
*/
/***************************************************************/
/* Source Property */
/***************************************************************/
% sys_source(-Atom, -Integer, -Integer)
:- dynamic(sys_source/3).
% sys_srcprop(-Atom, -Term)
:- dynamic(sys_srcprop/2).
/**
* current_source(S):
* The predicate succeeds in S with the current source paths.
*/
% current_source(-Atom)
current_source(RealPath) :- sys_source(RealPath, _, _).
/**
* source_property(S, P):
* The predicate succeeds in P with the properties of the source path S.
*/
% source_property(+Atom, -Term)
source_property(RealPath, P) :- sys_srcprop(RealPath, P).
/***************************************************************/
/* Style Checks */
/***************************************************************/
/**
* discontiguous(I): [ISO 7.4.2.3]
* The predicate sets the predicate I to discontiguous.
*/
% discontiguous(+Indicator)
discontiguous(F/N) :- !,
must_be(atom, F),
must_be(integer, N),
dg_get_partition(S),
assertz(sys_predprop(F, N, sys_discontiguous(S))).
discontiguous(I) :-
throw(error(type_error(predicate_indicator,I),_)).
/**
* multifile(I): [ISO 7.4.2.2]
* The predicate sets the predicate I to multi-file.
*/
% multifile(+Indicator)
multifile(F/N) :- !,
must_be(atom, F),
must_be(integer, N),
sys_multifile_safe(F, N).
multifile(I) :-
throw(error(type_error(predicate_indicator,I),_)).
% sys_multifile_safe(+Atom, +Integer)
sys_multifile_safe(F, N) :-
dg_get_partition(S),
(sys_predprop(F, N, sys_usage(D)),
S \== D,
\+ sys_predprop(F, N, sys_multifile(D)) ->
throw(error(permission_error(promote, multifile, F/N), _));
true),
assertz(sys_predprop(F, N, sys_multifile(S))).
/***************************************************************/
/* Include Command */
/***************************************************************/
/**
* include(P): [ISO 7.4.2.7]
* The predicate succeeds. As a side effect, the path P is included.
*/
% include(+Term)
include(Spec) :-
sys_file_relative(Spec, Path),
file_property(Path, absolute_path(Path2)),
sys_include_file(Path2).
% sys_include_file(+Atom)
sys_include_file(user) :- !,
current_input(Stream),
sys_include_stream(user, Stream).
sys_include_file(Path) :-
current_prolog_flag(foreign_ext, Ext),
sub_atom(Path, _, _, 0, Ext), !,
sys_include_native(Path, Map),
ir_object_current(Map, 'module', Module),
os_invoke_main(Module).
sys_include_file(Path) :-
setup_once_cleanup(
open(Path, read, Stream),
sys_include_stream(Path, Stream),
close(Stream)).
% sys_include_native(+Atom, -Map)
sys_include_native(Path, Map) :-
current_prolog_flag(import_async, on), !,
os_import_promise(Path, Map, Prom),
'$YIELD'(Prom).
sys_include_native(Path, Map) :-
os_import_sync(Path, Map).
/***************************************************************/
/* Ensure Commands */
/***************************************************************/
/**
* [P1, .., Pn]:
* The predicate succeeds. As a side effect, the paths P1, .., Pn
* are ensure loaded.
*/
% [+Path|+Paths]
[H|T] :-
member(Path, [H|T]),
ensure_loaded(Path),
fail.
[_|_] :-
true.
/**
* ensure_loaded(P): [ISO 7.4.2.8]
* The predicate succeeds. As a side effect, the path P is ensure loaded.
*/
% ensure_loaded(+Atom)
ensure_loaded(V) :- var(V),
throw(error(instantiation_error,_)).
ensure_loaded(user) :- !,
sys_include_file(user).
ensure_loaded(Spec) :-
sys_file_relative(Spec, Path),
dg_get_partition(Parent),
sys_prop_map(Path, Map),
ir_object_current(Map, absolute_path, Path2),
(sys_srcprop(Parent, sys_link(Path2)) -> true;
assertz(sys_srcprop(Parent, sys_link(Path2)))),
sys_check_file(Path2, Map).
/***************************************************************/
/* Lastmodified Check */
/***************************************************************/
% sys_check_file(+Atom, +Map)
sys_check_file(Path, Map) :-
shield(sys_action_file(Path, Map, Action)), !,
(Action = replay ->
sys_replay_file(Path);
Action = clear_load ->
sys_clear_file(Path),
sys_load_file(Path);
true).
sys_check_file(Path, _) :-
sys_load_file(Path).
% sys_action_file(+Atom, +Map, -Atom)
sys_action_file(Path, Map, Action) :-
sys_source(Path, LastModified2, Visited), !,
(Visited = 1 -> Action = none;
(var(Map) -> sys_prop_map(Path, Map); true),
ir_object_current(Map, last_modified, LastModified),
(LastModified = LastModified2 -> Action = replay,
retractall(sys_source(Path, _, _)),
assertz(sys_source(Path, LastModified2, 1));
Action = clear_load,
retractall(sys_source(Path, _, _)),
assertz(sys_source(Path, LastModified, 1)))).
sys_action_file(Path, Map, _) :-
(var(Map) -> sys_prop_map(Path, Map); true),
ir_object_current(Map, last_modified, LastModified),
assertz(sys_source(Path, LastModified, 1)), fail.
/***************************************************************/
/* Loading Parenthesis */
/***************************************************************/
% sys_lastpred(+Task, -Atom, -Integer)
:- dynamic(sys_lastpred/3).
% sys_load_file(+Atom)
sys_load_file(Path) :-
setup_once_cleanup(
sys_loading_begin(Path, Parent, LastPred),
sys_include_file(Path),
sys_loading_end(Parent, LastPred)).
% sys_loading_begin(+Atom, -Atom, -Either)
sys_loading_begin(S, T, just(F, N)) :-
current_task(Task),
retract(sys_lastpred(Task, F, N)), !,
dg_get_partition(T),
dg_set_partition(S).
sys_loading_begin(S, T, nothing) :-
dg_get_partition(T),
dg_set_partition(S).
% sys_loading_end(+Atom, -Either)
sys_loading_end(T, just(F, N)) :-
dg_get_partition(S),
retractall(sys_predprop(_, _, sys_discontiguous(S))),
dg_set_partition(T),
sys_update_last(F, N).
sys_loading_end(T, nothing) :-
dg_get_partition(S),
retractall(sys_predprop(_, _, sys_discontiguous(S))),
dg_set_partition(T),
current_task(Task),
retractall(sys_lastpred(Task, _, _)).
% sys_update_last(+Atom, +Integer)
sys_update_last(F, N) :-
current_task(Task),
retractall(sys_lastpred(Task, _, _)),
assertz(sys_lastpred(Task, F, N)).
/****************************************************************/
/* Style Check */
/****************************************************************/
% sys_style_static(+Clause)
sys_style_static(T) :- nonvar(T), T = (:- _), !.
sys_style_static(T) :- nonvar(T), T = (H :- _), !,
sys_style_head(H).
sys_style_static(H) :-
sys_style_head(H).
% sys_style_head(+Term)
sys_style_head(H) :- callable(H), !,
functor(H, F, N),
sys_style_indicator(F, N).
sys_style_head(_).
% sys_style_indicator(+Atom, +Integer)
sys_style_indicator(F, N) :-
current_task(Task),
sys_lastpred(Task, F, N), !.
sys_style_indicator(F, N) :-
dg_get_partition(S),
sys_predprop(F, N, sys_usage(S)), !,
(sys_predprop(F, N, sys_discontiguous(S)) -> true;
Error = warning(syntax_error(discontiguous_pred,F/N), _),
sys_fill_stack(Error),
sys_print_error(Error)),
sys_update_last(F, N).
sys_style_indicator(F, N) :-
sys_usage_predicate(F, N),
sys_update_last(F, N).
% sys_usage_predicate(+Atom, +Integer)
sys_usage_predicate(F, N) :-
dg_get_partition(S),
(\+ sys_predprop(F, N, sys_multifile(S)),
sys_predprop(F, N, sys_usage(D)),
S \== D ->
throw(error(permission_error(redefine, procedure, F/N), _));
true),
assertz(sys_predprop(F, N, sys_usage(S))).
/****************************************************************/
/* Consult Loop */
/****************************************************************/
% sys_include_stream(+Atom, +Stream)
sys_include_stream(Path, Stream) :-
current_task(Task),
setup_once_cleanup(
asserta(sys_including(Path, Task, Stream)),
sys_include_lines(Stream),
once(retract(sys_including(Path, Task, Stream)))).
% sys_include_lines(+Stream)
sys_include_lines(Stream) :-
repeat,
catch(sys_next_term(Stream), Error,
(sys_print_error(Error), fail)), !.
% sys_next_term(+Stream)
sys_next_term(Stream) :-
read_term(Stream, Term, [variable_names(Map), singletons(Map2)]),
(Term == end_of_file -> true;
nonvar(Term), Term = (?- Query) ->
sys_expand_unattended(Query, Map, Query2),
sys_query_unattended(Query2, Map),
fail;
sys_multiton_keys(Map, Map2, Keys),
sys_multiton_check(Keys),
sys_singleton_keys(Map2, Keys2),
sys_singleton_check(Keys2),
expand_term(Term, Term2),
sys_handle_clump(Term2),
fail).
/****************************************************************/
/* Handle Clump */
/****************************************************************/
% sys_handle_clump(+Term)
sys_handle_clump(T) :- nonvar(T), T = [Term|Rest], !,
sys_handle_clump(Term),
sys_handle_clump(Rest).
sys_handle_clump(T) :- nonvar(T), T = [], !.
sys_handle_clump(T) :-
sys_style_static(T),
sys_handle_static(T).
% sys_handle_static(+Term)
sys_handle_static(T) :- nonvar(T), T = (:- _), !,
sys_frost_horn(T, 1, Native),
(sys_goal_call(Native) -> true;
throw(error(syntax_error(directive_failed),_))).
sys_handle_static(T) :- nonvar(T), T = (H :- _), !,
functor(H, F, N),
sys_load_type(F, N, O),
sys_frost_horn(T, O, Native),
sys_clause_add(Native, 2).
sys_handle_static(T) :-
functor(T, F, N),
sys_load_type(F, N, O),
sys_frost_horn(T, O, Native),
sys_clause_add(Native, 2).
% sys_load_type(+Atom, +Integer, -Integer)
sys_load_type(F, N, 0) :-
kb_pred_link(F, N, P),
kb_link_flags(P, D),
D /\ 1 =\= 0, !.
sys_load_type(_, _, 1).
/****************************************************************/
/* Error Texts */
/****************************************************************/
% strings(+Atom, +Atom, -Atom)
:- multifile(strings/3).
strings('syntax_error.discontiguous_pred', de, 'Unterbrochenes Prädikat ~q, entsprechend deklarieren.').
strings('syntax_error.bad_module', de, 'Fehlerhaftes Modul.').
strings('permission_error.modify.static_procedure', de, 'Kann Prädikat ~q nicht aktualisieren.').
strings('permission_error.coerce.procedure', de, 'Kann Prädikat ~q nicht zu anderen Delegiertentyp zwingen.').
strings('permission_error.access.private_procedure', de, 'Kann auf Prädikat ~q nicht zugreifen.').
strings('permission_error.redefine.procedure', de, 'Kann Prädikat ~q nicht umdefinieren, nicht als Mehrdateien markiert.').
strings('permission_error.promote.multifile', de, 'Kann Funktion ~q nicht zu Mehrdateien heben.').
strings('permission_error.create.operator', de, 'Kann Operator ~q nicht erstellen.').
strings('permission_error.invoke.method', de, 'Kann Methode ~q nicht aufrufen.').
strings('permission_error.modify.field', de, 'Kann Feld ~q nicht aktualisieren.').
strings('permission_error.access.source_sink', de, 'Kann auf Strom ~q nicht zugreifen.').
strings('resource_error.unknown_host', de, 'Dienst nicht gefunden, Verzeichnisdienst aktivieren.').
strings('resource_error.connect_failed', de, 'Verbindung zu Dienst fehlgeschlagen, Verbindungsfähigkeit sicherstellen.').
strings('resource_error.illegal_method', de, 'Methode nicht zugelassen.').
strings('resource_error.internal_error', de, 'Interner Fehler, Administrator kontaktieren.').
strings('resource_error.service_unavailable', de, 'Dienst nicht verfügbar, später wieder versuchen.').
strings('resource_error.state_error', de, 'Übergang nicht erlaubt.').
strings('existence_error.method', de, 'Methode ~q undefiniert.').
strings('existence_error.procedure', de, 'Prädikat ~q undefiniert.').
strings('syntax_error.discontiguous_pred', '', 'Discontiguous predicate ~q, declare accordingly.').
strings('syntax_error.bad_module', '', 'Faulty module.').
strings('permission_error.modify.static_procedure', '', 'Can\'t modify predicate ~q.').
strings('permission_error.coerce.procedure', '', 'Can\'t coerce predicate ~q into other delegate type.').
strings('permission_error.access.private_procedure', '', 'Can\'t access predicate ~q.').
strings('permission_error.redefine.procedure', '', 'Can\'t redefine predicate ~q, not marked multfile.').
strings('permission_error.promote.multifile', '', 'Can\'t promote predicate ~q to multi-file.').
strings('permission_error.create.operator', '', 'Can\'t create operator ~q.').
strings('permission_error.invoke.method', '', 'Can\'t invoke method ~q.').
strings('permission_error.modify.field', '', 'Can\'t modify field ~q.').
strings('permission_error.access.source_sink', '', 'Can\'t access stream ~q.').
strings('resource_error.unknown_host', '', 'Service lookup failed, enable directory service.').
strings('resource_error.connect_failed', '', 'Service connect failed, assure connectivity.').
strings('resource_error.illegal_method', '', 'Method not allowed.').
strings('resource_error.internal_error', '', 'Internal error, contact administrator.').
strings('resource_error.service_unavailable', '', 'Service unavailable, try again later.').
strings('resource_error.state_error', '', 'Transition not permitted.').
strings('existence_error.method', '', 'Undefined method ~q.').
strings('existence_error.procedure', '', 'Undefined predicate ~q.').