Prolog "transpiler"
/**
* 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.
*/
/**
* Mimicry of sys_clause_ossify/5 and sys_goal_ossify/3.
*
* - Detect anonymous variables via numberanon/1
* - Detect non-anonymous variables via numbervars/3
* - Detect frozen compounds via transpiled
* - Unpack monomorphic caches via native
* - Unpack anoynmous predicates via native
*/
:- ensure_loaded(library(hiord)).
:- op(200, fy, 'new Object[]').
% make_print_static(+Term, +Stream)
make_print_static(T, OutStream) :- nonvar(T), T = (:- _), !,
sys_trans_horn(T, Help, 1),
sys_encode_horn(Help, Encode, 1),
make_print(Encode, Printable),
write(OutStream, ' '),
write(OutStream, 'run'(Printable)),
write(OutStream, ';\n').
make_print_static(T, OutStream) :- (nonvar(T), T = (H :- _); T = H), !,
functor(H, F, N),
cross_pred_type(F, N, O),
sys_trans_horn(T, Help, O),
sys_encode_horn(Help, Encode, O),
make_print(Encode, Printable),
write(OutStream, ' '),
write(OutStream, 'add'(Printable)),
write(OutStream, ';\n'),
cross_touch_static(F, N).
/*******************************************************************/
/* Make Printable */
/*******************************************************************/
% make_print(+IRClauseOrGoal, -JObject)
make_print(T, _) :- var(T),
throw(error(instantiation_error,_)).
make_print(tr_clause(M,R,L), 'new Clause'(N,G,'new Object[]'(S),
'new Object[]'(T),K)) :- U = tr_clause(M,R,L), !,
numberanon(U),
numbervars(U, 0, N),
R =.. [F|H],
make_print_const(F, G),
make_print_instrs(H, X),
make_print_instrs(L, Y),
make_print_list(X, S),
make_print_list(Y, T),
make_print_cutvar(M, K).
make_print(tr_goal(M,R), 'new Goal'(N,'new Object[]'(S),K)) :- U = tr_goal(M,R), !,
numberanon(U),
numbervars(U, 0, N),
make_print_instrs(R, X),
make_print_list(X, S),
make_print_cutvar(M, K).
make_print(T, _) :-
throw(error(type_error(ir_clause_or_goal, T),_)).
% make_print_cutvar(+IROption, -JObject)
make_print_cutvar(T, _) :- var(T),
throw(error(instantiation_error,_)).
make_print_cutvar(nothing, -1) :- !.
make_print_cutvar(just('$VAR'(K)), K) :- integer(K), !.
make_print_cutvar(T, _) :-
throw(error(type_error(ir_option, T),_)).
/*******************************************************************/
/* Make Compound */
/*******************************************************************/
% make_print_instr(+IRInstr, -JInstr)
make_print_instr(V, _) :- var(V),
throw(error(instantiation_error,_)).
make_print_instr('$ANON', 'UNDEF_OBJ') :- !.
make_print_instr('$VAR'(K), 'new Place'(K)) :- integer(K), !.
make_print_instr(C, R) :- compound(C), !,
C =.. [F|L],
make_print_const(F, G),
make_print_instrs(L, X),
make_print_frozen(G, X, R).
make_print_instr(F, G) :-
make_print_const(F, G).
% make_print_instrs(+IRList, -JList)
make_print_instrs(V, _) :- var(V),
throw(error(instantiation_error,_)).
make_print_instrs([], []) :- !.
make_print_instrs([X|L], [Y|R]) :- !,
make_print_instr(X, Y),
make_print_instrs(L, R).
make_print_instrs(T, _) :-
throw(error(type_error(ir_list, T),_)).
% make_print_frozen(-JAtom, -JList, -JInstr)
make_print_frozen(G, X, 'new Skeleton'(G, 'new Object[]'(S))) :-
member(A, X), cross_fever(A), !,
make_print_list(X, S).
make_print_frozen(G, X, 'new Frozen'(G, 'new Object[]'(S))) :-
make_print_list(X, S).
/*******************************************************************/
/* Make Const */
/*******************************************************************/
% make_print_const(+Atomic, -JAtomic)
make_print_const(X, 'new Cache'(G)) :- ir_is_site(X), !,
ir_site_name(X, F),
make_print_atom(F, G).
make_print_const(X, 'make_defined'('new Object[]'(R))) :- ir_is_link(X), !,
findall(C, kb_clause_ref(X, 0, C), L),
make_print_disj(L, H),
make_print_list(H, R).
make_print_const(A, B) :-
make_print_atomic(A, B).
% make_print_disj(+List, -JList)
make_print_disj([], []).
make_print_disj([C|P], [Y|Q]) :-
kb_clause_data(C, R, M, L),
make_print(tr_clause(M,R,L), Y),
make_print_disj(P, Q).
% cross_fever(+JInstr)
cross_fever('UNDEF_OBJ').
cross_fever('new Place'(_)).
cross_fever('new Skeleton'(_,_)).
/**
* Create Java source text for
*
* - Lists
* - References
* - Numbers
* - Atoms
*/
% make_print_atomic(+Atomic, -JAtomic)
make_print_atomic(A, B) :- atom(A), !,
make_print_atom(A, B).
make_print_atomic(A, B) :- number(A), !,
make_print_number(A, B).
make_print_atomic(A, B) :-
make_print_reference(A, B).
/*******************************************************************/
/* List Utility */
/*******************************************************************/
% make_print_list(+List, -Set)
make_print_list([], {}).
make_print_list([X|Y], {Z}) :- make_print_comma(Y, X, Z).
% make_print_comma(+List, +Term -Comma)
make_print_comma([], X, X).
make_print_comma([X|Y], Z, (Z,T)) :- make_print_comma(Y, X, T).
/*******************************************************************/
/* Reference Utility */
/*******************************************************************/
% make_print_reference(+Reference, -JReference)
make_print_reference(0rNone, null) :- !.
make_print_reference(0rFalse, false) :- !.
make_print_reference(0rTrue, true) :- !.
make_print_reference(A, _) :-
throw(error(domain_error(printable,A),_)).
/*******************************************************************/
/* Number Utility */
/*******************************************************************/
% make_print_number(+Number, -Term)
make_print_number(0rInf, 'Double.POSITIVE_INFINITY') :- !.
make_print_number(-0rInf, 'Double.NEGATIVE_INFINITY') :- !.
make_print_number(0rNaN, 'Double.NaN') :- !.
make_print_number(A, B) :- integer(A), !, cross_esc_integer(A, B).
make_print_number(A, A) :- float(A), !.
make_print_number(A, _) :-
throw(error(domain_error(printable,A),_)).
% cross_esc_integer(+Integer, -JInteger)
cross_esc_integer(A, A) :- -2147483648 =< A, A =< 2147483647, !.
cross_esc_integer(A, 'new BigInteger'(B)) :-
atom_integer(H, 10, A),
atom_join(['"', H, '"'], B).
/*******************************************************************/
/* Atom Utility */
/*******************************************************************/
% make_print_atom(+Atom, -Atom)
make_print_atom(X, Y) :-
atom_codes(X, L),
cross_esc_codes(L, R, [0'"]),
atom_codes(Y, [0'"|R]).
% cross_esc_codes(+List, -List, +List)
cross_esc_codes([X|L]) -->
cross_esc_code(X),
cross_esc_codes(L).
cross_esc_codes([]) --> [].
% cross_esc_code(+Integer, -List, +List)
cross_esc_code(X) --> {cross_is_escape(Y, X)}, !, [0'\\, Y].
cross_esc_code(X) --> {cross_is_meta(X)}, !, [0'\\, X].
cross_esc_code(X) --> {cross_is_cntrl(X)}, !, cross_esc_code2(X).
cross_esc_code(X) --> {cross_is_invalid(X)}, !, cross_esc_code2(X).
cross_esc_code(X) --> [X].
% cross_esc_code2(+Integer, -List, +List)
cross_esc_code2(X) --> {X =< 0xFFFF}, !,
{atom_integer(J, 16, X), atom_codes(J, H), length(H, N), M is 4-N},
[0'\\, 0'u], cross_esc_zeros(M), cross_esc_codes2(H).
cross_esc_code2(X) --> {cross_high_surrogate(X, Y), cross_low_surrogate(X, Z)},
cross_esc_code2(Y), cross_esc_code2(Z).
% cross_is_escape(+Code, -Code)
cross_is_escape(0'n, 0'\n).
cross_is_escape(0't, 0'\t).
cross_is_escape(0'b, 0'\b).
cross_is_escape(0'f, 0'\f).
cross_is_escape(0'r, 0'\r).
% cross_is_meta(+Code)
cross_is_meta(0'\').
cross_is_meta(0'\").
cross_is_meta(0'\\).