Heimseite
Seitenübersicht
An/abmeldung
Anschlagbrett
Herunterladen(c) 2005-2024 XLOG Technologies AG
/**
* Modern Albufeira Prolog Interpreter
*
* 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.
*/
/***************************************************************/
/* Stream Util */
/***************************************************************/
/**
* open(P, M, S): [ISO 8.11.5.4]
* The built-in succeeds in S with a new stream for the path P
* and the mode M.
*/
% open(+Atom, +Atom, -Stream)
open(P, read, S) :- current_prolog_flag(read_async, on), !,
os_open_promise(P, S, Q),
'$YIELD'(Q).
open(P, M, S) :-
os_open_sync(P, M, S).
/**
* close(S): [ISO 8.11.6]
* The built-in succeeds. As a side effect, the stream S is closed.
*/
% close(+Stream)
close(S) :- os_stream_flags(S, F), F /\ 2 =\= 0, !,
os_close_promise(S, P), '$YIELD'(P).
close(S) :-
os_close_sync(S).
/**
* stream_property(S, P): [ISO 8.11.8]
* The predicate succeeds with the properties of the stream
* S that unify with P.
*/
% stream_property(+Stream, -Prop)
stream_property(S, P) :-
os_stream_list(S, L),
member(P, L).
/***************************************************************/
/* Term Util */
/***************************************************************/
/**
* term_variables(T, L): [TC2 8.5.5]
* term_variables(T, L, E):
* The predicate succeeds in L with the variables of T. The ternary
* predicate allows specifying a list end E.
*/
% term_variables(+Term, -List)
term_variables(T, L) :-
term_variables(T, L, []).
% term_variables(+Term, -List, +List)
% defined in special.mjs respectively special.py
/***************************************************************/
/* Goal Util */
/***************************************************************/
/**
* X is Y: [ISO 8.6.1]
* The predicate succeeds in X with the evaluation of Y.
*/
V is E :- V is E.
/**
* call(A): [ISO 7.8.3]
* The predicate succeeds whenever the goal A succeeds.
*/
% call(+Goal)
call(A) :- A.
/**
* true: [ISO 7.8.1]
* The predicate succeeds.
*/
% true
true :- true.
/**
* !: [ISO 7.8.4]
* The predicate removes choice points created in the current clause.
*/
% !
! :- !.
/**
* A, B: [ISO 7.8.5]
* The predicate succeeds whenever A and B succeed.
*/
% +Goal, +Goal
A, B :-
sys_trans_body(A, nothing, J, R, H),
sys_trans_body(B, J, M, H, []),
'$SEQ'(M, R).
/**
* A; B: [ISO 7.8.6]
* The predicate succeeds whenever A or B succeed.
*/
% +Goal; +Goal
A; B :-
sys_trans_alternative(A, nothing, J, R, F),
sys_trans_disj(B, F, J, M, H),
'$SEQ'(M, ['$ALT'([R|H])]).
/**
* A -> B: [ISO 7.8.7]
* The predicate succeeds when A succeeds and then whenever B succeed.
*/
% +Goal -> +Goal
A -> B :-
sys_trans_body(A, nothing, Q, R, ['$CUT'(X)|H]),
sys_trans_body(B, nothing, M, H, []),
sys_trans_mark(Q, S, R),
'$SEQ'(M, ['$ALT'(['$SEQ'(just(X),S)])]).
/***************************************************************/
/* Bootstrapped */
/***************************************************************/
/**
* S \= T: [ISO 8.2.3]
* The built-in succeeds when the Prolog terms S and T do not unify,
* otherwise the built-in fails.
*/
X \= Y :- X = Y, !, fail.
_ \= _.
/**
* \+ A: [ISO 8.15.1]
* The predicate succeeds when A fails.
*/
% \+(+Goal)
\+ A :- A, !, fail.
\+ _.
/**
* once(A): [ISO 8.15.2]
* The predicate succeeds once if A succeeds.
* Otherwise the predicate fails.
*/
% once(+Goal)
once(A) :- A, !.
/**
* repeat: [ISO 8.15.3]
* The predicate succeeds repeatedly indefinitely.
*/
% repeat
repeat.
repeat :- repeat.
/********************************************************************/
/* catch/3 and throw/1 */
/********************************************************************/
/**
* catch(G, E, F): [ISO 7.8.9]
* The built-in succeeds whenever G succeeds. If
* there was a non-urgent exception that unifies with E, the
* built-in further succeeds whenever F succeeds.
*/
% catch(+Goal, -Error, +Goal)
catch(A, Pattern, B) :-
sys_trap(A, Error, sys_error_handler(Error, Pattern, B)).
% sys_error_handler(+Error, +Goal)
sys_error_handler(Error, _, _) :-
sys_chain_head(Error, error(system_error(_),_)), sys_raise(Error).
sys_error_handler(Error, Pattern, B) :-
sys_chain_head(Error, Pattern), !, B.
sys_error_handler(Error, _, _) :-
sys_raise(Error).
/**
* sys_chain_head(E, F):
* The predicate succeeds in F with the chain head of E.
*/
% sys_chain_head(+Error, -Error)
sys_chain_head(cause(E, _), F) :- !, E = F.
sys_chain_head(E, E).
/**
* throw(E): [ISO 7.8.9]
* The predicate possibly fills the stack trace and then
* raises the exception B.
*/
% throw(+Error)
throw(B) :-
sys_fill_stack(B),
sys_raise(B).
% sys_fill_stack(+Term)
sys_fill_stack(Error) :-
var(Error), throw(error(instantiation_error, _)).
sys_fill_stack(error(_,Trace)) :- var(Trace), !,
sys_fetch_stack(Trace).
sys_fill_stack(warning(_,Trace)) :- var(Trace), !,
sys_fetch_stack(Trace).
sys_fill_stack(_).
% sys_fetch_stack(-List)
sys_fetch_stack(Trace) :-
os_task_current(Task),
findall(sys_including(F, S), sys_including(F, Task, S), Trace).
/********************************************************************/
/* ignore/1 and chain/2 */
/********************************************************************/
/**
* ignore(A):
* The predicate succeeds once if A succeeds.
* Otherwise the predicate succeeds.
*/
% ignore(Goal)
ignore(X) :- X, !.
ignore(_).
/**
* chain(A, B):
* The predicate succeeds whenever A and B succeed. If A throws
* an exception, then B is called once and an exception is chained.
*/
% chain(+Goal, +Goal)
chain(A, B) :-
sys_trap(A, E, sys_chain_error(E, B)), B.
% sys_chain_error(+Error, +Goal)
sys_chain_error(E, B) :-
sys_trap(B, F, sys_chain_raise(E, F)), sys_raise(E).
sys_chain_error(E, _) :-
sys_raise(E).
% sys_chain_raise(+Error, +Error)
sys_chain_raise(E, B) :-
sys_chain_concat(E, B, C), sys_raise(C).
% sys_chain_concat(+Error, +Error, -Error)
sys_chain_concat(cause(E, F), B, cause(E, C)) :- !, sys_chain_concat(F, B, C).
sys_chain_concat(E, B, cause(E, B)).
/********************************************************************/
/* abort/0 */
/********************************************************************/
/**
* abort:
* The predicate throws a system error of type user abort.
*/
% abort
abort :- throw(error(system_error(user_abort), _)).
/********************************************************************/
/* once_cleanup/2 and setup_once_cleanup/3 */
/********************************************************************/
/**
* once_cleanup(G, C):
* setup_once_cleanup(S, G, C):
* The predicate succeeds once if G succeeds. The clean-up C is called
* when G fails, succeeds or throws an exception. The ternary predicate
* permits an initial shielded call of a setup S.
*/
% once_cleanup(+Goal, +Goal, +Goal)
once_cleanup(G, C) :-
current_prolog_flag(async_mode, on), !,
shield(sys_once_cleanup(unshield(G), C)).
once_cleanup(G, C) :-
sys_once_cleanup(G, C).
% setup_once_cleanup(+Goal, +Goal, +Goal)
setup_once_cleanup(S, G, C) :-
current_prolog_flag(async_mode, on), !,
shield(sys_setup_once_cleanup(S, unshield(G), C)).
setup_once_cleanup(S, G, C) :-
sys_setup_once_cleanup(S, G, C).
% sys_setup_once_cleanup(+Goal, +Goal, +Goal)
sys_setup_once_cleanup(S, G, C) :-
S,
sys_once_cleanup(G, C).
% sys_once_cleanup(+Goal, +Goal)
sys_once_cleanup(G, C) :-
chain(G, ignore(C)), !.
sys_once_cleanup(_, C) :-
ignore(C), fail.
/****************************************************************/
/* Error Printing */
/****************************************************************/
% sys_print_error(+Error)
sys_print_error(Error) :-
current_error(Stream),
sys_print_error(Error, Stream).
% sys_print_error(+Error, +Stream)
sys_print_error(Error, Stream) :- var(Error), !,
sys_print_message('exception_unknown', Stream),
writeq(Stream, Error),
nl(Stream).
sys_print_error(cause(Primary, Secondary), Stream) :- !,
sys_print_error(Primary, Stream),
sys_print_error(Secondary, Stream).
sys_print_error(error(Message, Trace), Stream) :- !,
sys_print_message('exception_error', Stream),
sys_print_message(Message, Stream), nl(Stream),
sys_print_trace(Trace, Stream).
sys_print_error(warning(Message, Trace), Stream) :- !,
sys_print_message('exception_warning', Stream),
sys_print_message(Message, Stream), nl(Stream),
sys_print_trace(Trace, Stream).
sys_print_error(Error, Stream) :-
sys_print_message('exception_unknown', Stream),
writeq(Stream, Error),
nl(Stream).
% sys_print_trace(+List, +Stream)
sys_print_trace(Trace, Stream) :- var(Trace), !,
sys_print_message('exception_context', Stream),
writeq(Stream, Trace),
nl(Stream).
sys_print_trace([Frame|Trace], Stream) :- !,
sys_print_frame(Frame, Stream),
sys_print_trace(Trace, Stream).
sys_print_trace([], _) :- !.
sys_print_trace(Trace, Stream) :-
sys_print_message('exception_context', Stream),
writeq(Stream, Trace),
nl(Stream).
% sys_print_frame(+Term, +Stream)
sys_print_frame(sys_including(File, Include), Stream) :- atom(File), !,
file_base_name(File, Name),
stream_property(Include, line_no(Line)),
sys_print_message(file_line(Name, Line), Stream), nl(Stream).
sys_print_frame(Frame, Stream) :-
sys_print_message(Frame, Stream), nl(Stream).
/****************************************************************/
/* Message Printing */
/****************************************************************/
% sys_print_message(+Term)
sys_print_message(Message) :-
current_error(Stream),
sys_print_message(Message, Stream).
% sys_print_message(+Term, +Stream)
sys_print_message(Message, Stream) :-
current_prolog_flag(sys_locale, Locale),
sys_print_message(Message, Stream, Locale).
% sys_print_message(+Term, +Stream, +Atom)
sys_print_message(Message, Stream, Locale) :- var(Message), !,
sys_print_message('exception_template', Stream, Locale),
writeq(Stream, Message).
sys_print_message(Message, Stream, Locale) :- Message =.. [Fun|Args],
atom(Fun),
get_string(Fun, Locale, Template), !,
sys_inter_polate(Stream, Template, Args).
sys_print_message(Message, Stream, Locale) :- Message =.. [Fun, Type|Args],
atom(Fun), atom(Type),
atom_split(Key, '.', [Fun,Type]),
get_string(Key, Locale, Template), !,
sys_inter_polate(Stream, Template, Args).
sys_print_message(Message, Stream, Locale) :- Message =.. [Fun, Type1, Type2|Args],
atom(Fun), atom(Type1), atom(Type2),
atom_split(Key, '.', [Fun,Type1,Type2]),
get_string(Key, Locale, Template), !,
sys_inter_polate(Stream, Template, Args).
sys_print_message(Message, Stream, Locale) :-
sys_print_message('exception_template', Stream, Locale),
writeq(Stream, Message).
% sys_inter_polate(+Stream, +Atom, +List)
sys_inter_polate(Stream, Template, Args) :-
atom_split(Template, '~', [Head|Tail]),
put_atom(Stream, Head),
sys_zipper_output(Args, Tail, Stream).
% sys_zipper_output(+List, +List, +Stream)
sys_zipper_output([Arg|Args], ['',Head|Tail], Stream) :- !,
write(Stream, Arg),
put_atom(Stream, Head),
sys_zipper_output(Args, Tail, Stream).
sys_zipper_output([Arg|Args], [Head|Tail], Stream) :-
writeq(Stream, Arg),
put_atom(Stream, Head),
sys_zipper_output(Args, Tail, Stream).
sys_zipper_output([], [], _).
/****************************************************************/
/* Multilingual Strings */
/****************************************************************/
/**
* get_string(K, V):
* get_string(K, L, V):
* The predicate succeeds in V with the value for the key K. The
* ternary predicate allows overriding the current locale by L.
*/
% get_string(+Atom, -Atom)
get_string(Key, Value) :-
current_prolog_flag(sys_locale, Locale),
get_string(Key, Locale, Value).
% get_string(+Atom, +Atom, -Atom)
get_string(Key, Locale, Value) :-
sys_locale_ancestor(Locale, Parent),
strings(Key, Parent, Res), !,
Value = Res.
% sys_locale_ancestor(+Atom, -Atom)
sys_locale_ancestor(L, L).
sys_locale_ancestor(L, M) :-
last_sub_atom(L, P, _, _, '_'),
sub_atom(L, 0, P, _, M).
sys_locale_ancestor(L, '') :- L \== ''.
/**
* strings(K, L, V):
* The predicate succeeds in the key K, the value V and the locale L.
* The predicate can be extended by libraries and applications.
*/
% strings(+Atom, +Atom, -Atom)
:- multifile strings/3.
/****************************************************************/
/* Type Checks */
/****************************************************************/
% sys_check_atom(+Term)
sys_check_atom(V) :- var(V),
throw(error(instantiation_error,_)).
sys_check_atom(A) :- atom(A), !.
sys_check_atom(A) :-
throw(error(type_error(atom,A),_)).
% sys_check_integer(+Term)
sys_check_integer(V) :- var(V),
throw(error(instantiation_error,_)).
sys_check_integer(I) :- integer(I), !.
sys_check_integer(I) :-
throw(error(type_error(integer,I),_)).
/***************************************************************/
/* Callback and Task */
/***************************************************************/
/**
* call_later(G, D):
* The built-in schedules the goal G to be executed after D milliseconds.
*/
% call_later(+Goal, +Integer)
call_later(Goal, Delay) :-
sys_frost_horn((:- sys_call_print(Goal)), Native),
os_call_later(Native, Delay, _).
% sys_frost_horn(+Horn, -Native)
sys_frost_horn(Horn, Native) :-
sys_trans_horn(Horn, Help),
sys_encode_horn(Help, Encode, 0),
sys_host_make(Encode, Native).
% sys_call_print(+Goal)
sys_call_print(Goal) :-
sys_trap(Goal, Error, sys_print_error(Error)).
/**
* create_task(G):
* The built-in schedules the goal G to be executed. The goal is
* run with auto-yield enabled and promises are accepted.
*/
% create_task(+Goal)
create_task(Goal) :-
sys_frost_horn((:- sys_call_print(Goal)), Native),
os_task_create(Native, _).
/**
* sleep(D):
* The predicate suspends execution for D milliseconds.
*/
% sleep(+Integer)
sleep(Delay) :-
os_sleep_promise(Delay, Prom),
'$YIELD'(Prom).
/**
* time_out(G, D):
* The predicate succeeds once if G succeeds. If the goal
* has not terminated after D milliseconds a time limit
* system error is signalled to the goal.
*/
% time_out(+Goal, +Integer)
time_out(Goal, Delay) :-
current_prolog_flag(allow_yield, on), !,
os_task_current(Task),
sys_frost_horn((:- sys_timeout(Task)), Native),
setup_once_cleanup(
os_call_later(Native, Delay, Timer),
Goal,
os_call_cancel(Timer)).
time_out(_, _) :-
throw(error(system_error(illegal_yield),_)).
% sys_timeout
sys_timeout(Task) :-
os_task_abort(Task, system_error(timelimit_exceeded)).
/***************************************************************/
/* Lists */
/***************************************************************/
/**
* member(E, L): [PTP 1]
* The predicate succeeds for every member E of the list L.
*/
% member(-Term, +List)
member(X, [Y|Z]) :- sys_member(Z, X, Y).
% Gertjan van Noord trick
% sys_member(+List, +Term, -Term)
sys_member(_, X, X).
sys_member([Y|Z], X, _) :- sys_member(Z, X, Y).
/**
* select(E, L, R): [PTP 5]
* The predicate succeeds for every member E of the L with remainder list R.
*/
% select(-Term, +List, -List)
select(X, [Y|Z], T) :- sys_select(Z, X, Y, T).
% Gertjan van Noord trick
% sys_select(+List, +Term, -Term, -List)
sys_select(Y, X, X, Y).
sys_select([Y|Z], X, W, [W|T]) :- sys_select(Z, X, Y, T).
/**
* findall(T, G, L): [ISO 8.10.1]
* The predicate succeeds in L with all T such that G succeeds.
*/
% findall(+Term, +Goal, -List)
findall(T, Goal, L) :-
Cell = [-|_],
Holder = v(_),
change_arg(1, Holder, Cell),
sys_findall(Holder, T, Goal),
arg(2, Cell, L).
% sys_findall(+Holder, +Term, +Goal)
sys_findall(Holder, T, Goal) :-
Goal,
copy_term([T|_], Cell),
arg(1, Holder, Back),
change_arg(2, Back, Cell),
change_arg(1, Holder, Cell),
fail.
sys_findall(Holder, _, _) :-
arg(1, Holder, Back),
change_arg(2, Back, []).
/**
* list_to_set(L, S):
* The predicate succeeds in S with the deduplication of L.
*/
% list_to_set(+List, -List)
list_to_set(L, R) :-
sys_list_to_set(L, [], R).
% sys_list_to_set(+List, +List, -List)
sys_list_to_set([], _, []).
sys_list_to_set([X|L], R, H) :-
member(X, R), !,
sys_list_to_set(L, R, H).
sys_list_to_set([X|L], R, [X|H]) :-
sys_list_to_set(L, [X|R], H).
/**
* reverse(L, R):
* The predicate succeeds in R with the reverse of L.
*/
% reverse(+list, -List)
reverse(X, Y) :- sys_reverse(X, [], Y).
% sys_reverse(+list, +List, -List)
sys_reverse([], X, X).
sys_reverse([X|Y], Z, T) :- sys_reverse(Y, [X|Z], T).
/**
* append(L, R, S): [PTP 2]
* The predicate succeeds whenever S unifies with
* the concatenation of L and R.
*/
% append(+List, +List, -List)
append([], X, X).
append([X|Y], Z, [X|T]) :- append(Y, Z, T).
/**
* length(L, N): [PTP 3]
* The predicate succeeds with N being the length of the list L.
*/
% length(+List, -Integer)
length(L, N) :- var(N), !, sys_length(L, 0, N).
length(L, N) :- sys_check_integer(N), N >= 0, sys_length(N, L).
% sys_length(+List, +Integer, -Integer)
sys_length([], N, N).
sys_length([_|Y], N, M) :- H is N+1, sys_length(Y, H, M).
% sys_length(+Integer, -List)
sys_length(0, R) :- !, R = [].
sys_length(N, [_|Y]) :- M is N-1, sys_length(M, Y).
/***************************************************************/
/* Miscellaneous */
/***************************************************************/
/**
* number_codes(A, B): [ISO 8.16.8]
* If A is a variable, then the predicate succeeds in A with the
* number from the Prolog list B. Otherwise the predicate succeeds
* in B with the Prolog list for the number A.
*/
% number_codes(+Number, -List)
% number_codes(-Number, +List)
number_codes(Number, Codes) :- ground(Codes), !,
atom_codes(H, Codes),
atom_number(H, Number).
number_codes(Number, Codes) :-
atom_number(H, Number),
atom_codes(H, Codes).
/**
* between(L, H, X): [PTP 4]
* The predicate succeeds for every integer X between L and H.
*/
% between(+Integer, +Integer, -Integer)
between(Lo, Hi, X) :- var(X), !,
sys_check_integer(Lo),
sys_check_integer(Hi),
Lo =< Hi,
sys_between(Lo, Hi, X).
between(Lo, Hi, X) :-
sys_check_integer(Lo),
sys_check_integer(Hi),
sys_check_integer(X),
Lo =< X, X =< Hi.
% sys_between(+Integer, +Integer, -Integer)
sys_between(Lo, Lo, Lo) :- !.
sys_between(Lo, _, Lo).
sys_between(Lo, Hi, X) :- Lo2 is Lo+1, sys_between(Lo2, Hi, X).
/****************************************************************/
/* Style Check */
/****************************************************************/
% sys_lastpred(+Task, -Atom, -Integer)
:- dynamic sys_lastpred/3.
% sys_update_last(+Atom, +Integer)
sys_update_last(F, N) :-
os_task_current(Task),
retractall(sys_lastpred(Task, _, _)),
assertz(sys_lastpred(Task, F, N)).
% sys_style_static(+Clause)
sys_style_static(V) :- var(V), !.
sys_style_static((:- _)) :- !.
sys_style_static((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) :-
os_task_current(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))).
/**
* discontiguous I: [ISO 7.4.2.3]
* The predicate sets the predicate I to discontiguous.
*/
% discontiguous(+Indicator)
discontiguous(V) :- var(V),
throw(error(instantiation_error,_)).
discontiguous(F/N) :- !,
sys_check_atom(F),
sys_check_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.
* Dummy implementation, property not yet supported.
*/
% multifile(+Indicator)
multifile(V) :- var(V),
throw(error(instantiation_error,_)).
multifile(F/N) :- !,
sys_check_atom(F),
sys_check_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))).