/**
* 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.
*/
import {
Provable, set, MASK_PRED_TEST, engine, VAR_MASK_SERNO,
MASK_PRED_ARITH, Variable, MASK_PRED_SPECIAL, Goal,
is_skeleton, Clause, check_nonvar, add_clause,
VAR_MASK_SEEN, VAR_MASK_STATE, Place, Skeleton, is_goal,
is_variable, Compound, is_structure, deref, copy_term,
stack_push, stack_pop, stack_peek, is_compound, is_clause
} from "./store.mjs";
import {
bind, call, gc_mask, Choice,
cont, snap_setup, solve, snap_cleanup, is_bigint,
is_atom, exec_build, exec_unify, is_frozen,
is_float, is_integer, is_number, exec_deref, is_pending,
make_error, more, redo, trail, unify, melt_directive,
solve_signal, SYS_MASK_ASYNC_MODE, SYS_MASK_ALLOW_YIELD,
fs, VOID_ARGS, ctx, register_interrupt, Frozen,
setDelay, url, mark2_term, register_signal, is_special
} from "./machine.mjs";
import {
code_category, code_numeric
} from "./unicode.mjs";
export const MAX_ARITY = 2147483647;
/*********************************************************************/
/* Special Predicate */
/*********************************************************************/
/**
* Return a built-in for a special.
*
* @param func The special.
* @return Provable The built-in.
*/
export function make_special(func) {
let peek = new Provable();
peek.flags |= MASK_PRED_SPECIAL;
peek.func = func;
return peek;
}
/**
* Return a built-in for a check.
*
* @param func The check.
* @return Provable The built-in.
*/
export function make_check(func) {
let peek = new Provable();
peek.flags |= MASK_PRED_TEST;
peek.func = func;
return peek;
}
/**
* Return a built-in for an arithmetic.
*
* @param func The arithmetic.
* @return Provable The built-in.
*/
export function make_arithmetic(func) {
let peek = new Provable();
peek.flags |= MASK_PRED_ARITH;
peek.func = func;
return peek;
}
/*********************************************************************/
/* fail/0, '$CUT'/1 and '$MARK'/1 */
/*********************************************************************/
/**
* fail: [ISO 7.8.2]
* The built-in fails.
*/
function test_fail(args) {
return false;
}
/**
* '$CUT'(R): internal only
* The built-in removes the choice points up to R and succeeds.
*/
function test_cut(args) {
let choice = exec_build(args[0]);
more(choice);
return true;
}
/**
* '$MARK'(R): Internal only
* The built-in binds R to the top choice point.
*/
function test_mark(args) {
let choice = redo;
return exec_unify(args[0], choice);
}
/*********************************************************************/
/* '$SEQ'/2 and '$ALT'/1 */
/*********************************************************************/
/**
* '$SEQ'(O, L): internal only
* The built-in first matches the option O with the top choice point.
* The built-in then sequentially adds the goals L to the continuation.
*/
function special_seq(args) {
let temp = deref(args[0]);
solve_mark(temp);
temp = deref(args[1]);
solve_seq(temp);
return true;
}
/**
* If temp is just(R) bind R the top choice point. If temp is
* nothing do nothing. Otherwise throw an exception.
*
* @param temp The Prolog term.
*/
function solve_mark(temp) {
if (temp === "nothing") {
/* */
} else if (is_structure(temp) &&
temp.functor === "just" &&
temp.args.length === 1) {
temp = deref(temp.args[0]);
bind(redo, temp);
} else {
check_nonvar(temp);
temp = copy_term(temp);
throw make_error(new Compound("type_error", ["maybe", temp]));
}
}
/**
* Sequentially adds the literals L to the continuation.
*
* @param peek The literals.
*/
export function solve_seq(peek) {
let back = null;
let res = null;
while (is_structure(peek) &&
peek.functor === "." &&
peek.args.length === 2) {
let goal = deref(peek.args[0]);
goal = new Compound(".", [goal, undefined]);
if (back === null) {
res = goal;
} else {
back.args[1] = goal;
}
back = goal;
peek = deref(peek.args[1]);
}
check_nil(peek);
if (back === null) {
res = call.args[1];
} else {
back.args[1] = call.args[1];
}
cont(res);
}
/**
* '$ALT'(L): internal only
* The built-in alternatively adds the variants L to the
* continuation and succeeds.
*/
function special_alt(args) {
let goal = deref(args[0]);
return solve_alt(goal, -1, null);
}
/**
* Alternatively adds the variants to the continuation.
*
* @param peek The variants.
* @param at This argument is ignored.
* @param choice The choice point for reuse or null.
* @return boolean True if a variant could be added, otherwise false.
*/
function solve_alt(peek, at, choice) {
if (is_structure(peek) &&
peek.functor === "." &&
peek.args.length === 2) {
let mark = trail;
let goal = deref(peek.args[0]);
solve_mark(deref(goal.args[0]));
peek = deref(peek.args[1]);
if (is_structure(peek) &&
peek.functor === "." &&
peek.args.length === 2) {
if (choice === null) {
choice = new Choice(solve_alt, peek, -1, mark);
} else {
choice.data = peek;
}
more(choice);
}
solve_seq(deref(goal.args[1]));
return true;
} else {
return false;
}
}
/*********************************************************************/
/* sys_raise/1 and sys_trap/3 */
/*********************************************************************/
/**
* sys_raise(E): internal only
* The predicate raises the exception E.
*/
function test_sys_raise(args) {
let problem = exec_build(args[0]);
throw copy_term(problem);
}
/**
* sys_trap(G, E, F): internal only
* The built-in succeeds whenever G succeeds. If
* there was an exception that unifies with E, the
* built-in further succeeds whenever F succeeds.
*/
function special_sys_trap(args) {
let goal = deref(args[0]);
let snap = snap_setup();
goal = new Compound(".", [goal, "[]"]);
cont(goal);
return solve_catch(snap, true, null);
}
/**
* Call, redo or resume a goal.
* If there is an exception put the handler on the continuation.
*
* @param snap The surrounding choice point.
* @param found The call or redo flag.
* @param choice The choice point for reuse or null.
* @return boolean True if goal succeeded, otherwise false.
*/
function solve_catch(snap, found, choice) {
if (choice !== null) {
choice.mark = null;
choice.cont = "[]";
choice.tail = null;
}
try {
found = solve(snap, found);
} catch (err) {
snap_cleanup(snap);
let goal = deref(call.args[0]);
err = map_throwable(err);
if (!unify(goal.args[1], err))
throw err;
goal = deref(goal.args[2]);
goal = new Compound(".", [goal, call.args[1]]);
cont(goal);
return true;
}
if (found === false)
return false;
if (redo !== snap) {
if (choice === null) {
choice = new Choice(solve_catch, snap, false, trail);
} else {
choice.mark = trail;
choice.cont = call;
choice.tail = redo;
}
more(choice);
} else {
more(snap.tail);
}
if (found === true)
cont(snap.cont.args[1]);
return found;
}
function map_throwable(err) {
if (err instanceof RangeError && err.message.includes("stack"))
err = make_error(new Compound("system_error", ["stack_overflow"]));
return err;
}
/*********************************************************************/
/* os_sleep_promise/2 and os_import_promise/3 */
/*********************************************************************/
/**
* os_sleep_promise(D, P):
* The predicate succeeds in P with a promise for a delay D.
*/
function test_os_sleep_promise(args) {
let delay = exec_build(args[0]);
check_integer(delay);
if (delay < 0)
throw make_error(new Compound("domain_error",
["not_less_than_zero", delay]));
let buf = ctx;
return exec_unify(args[1], sleep_promise(buf, delay));
}
function sleep_promise(buf, delay) {
return new Promise(resolve => {
function handler() {
register_interrupt(buf, () => {});
resolve();
}
let timer = setDelay(handler, delay);
register_interrupt(buf, () => {
clearTimeout(timer);
register_interrupt(buf, () => {});
resolve()
});
});
}
/**
* os_import_promise(F, M, Q): internal only
* The predicate succeeds in Q with with a promise for the
* import M of the file F.
*/
function test_os_import_promise(args) {
let url = exec_build(args[0]);
check_atom(url);
let res = {};
if (!exec_unify(args[1], res))
return false;
let buf = ctx;
return exec_unify(args[2], import_promise(buf, url, res));
}
async function import_promise(buf, path, res) {
try {
let path2;
if (fs !== undefined) {
path2 = url.pathToFileURL(path);
} else {
path2 = path;
}
res.module = await import(path2);
} catch (err) {
if (err instanceof SyntaxError) {
register_signal(buf,
new Compound("syntax_error", ["bad_module"]));
} else {
register_signal(buf,
new Compound("existence_error", ["module", path]));
}
}
}
/**
* os_invoke_main(M): internal only
* Invoke the main method of the module M.
*/
function test_os_invoke_main(args) {
let module = exec_build(args[0]);
let val = module.main;
if (val === undefined) {
throw make_error(new Compound("existence_error",
["method", "main"]));
} else if (typeof val !== "function") {
throw make_error(new Compound("permission_error",
["invoke", "method", "main"]));
} else {
val();
}
return true;
}
/*********************************************************************/
/* '$YIELD'/1, shield/1 and unshield/1 */
/*********************************************************************/
/**
* '$YIELD'(R): Internal only
* The built-in stops the interpreter loop with return value R.
*/
function special_yield(args) {
if ((engine.flags & SYS_MASK_ALLOW_YIELD) === 0)
throw make_error(new Compound("system_error", ["illegal_yield"]));
cont(call.args[1]);
more(new Choice(solve_signal, null, 0, trail));
return deref(args[0]);
}
/**
* shield(G):
* The predicate succeeds whenever the goal G succeeds.
* The goal is executed without auto-yield.
*/
function special_shield(args) {
let goal = deref(args[0]);
let snap = snap_setup();
goal = new Compound(".", [goal, "[]"]);
cont(goal);
return solve_shield(snap, true, null);
}
/**
* Call, redo or resume a goal.
* The goal is executed without auto-yield.
*
* @param snap The surrounding choice point.
* @param found The call or redo flag.
* @param choice The choice point for reuse or null.
* @return boolean True if goal succeeded, otherwise false.
*/
function solve_shield(snap, found, choice) {
if (choice !== null) {
choice.mark = null;
choice.cont = "[]";
choice.tail = null;
}
let back = engine.flags & SYS_MASK_ASYNC_MODE;
engine.flags &= ~SYS_MASK_ASYNC_MODE;
try {
found = solve(snap, found);
} catch (x) {
engine.flags &= ~SYS_MASK_ASYNC_MODE;
engine.flags |= back;
snap_cleanup(snap);
throw x;
}
engine.flags &= ~SYS_MASK_ASYNC_MODE;
engine.flags |= back;
if (found === false)
return false;
if (redo !== snap) {
if (choice === null) {
choice = new Choice(solve_shield, snap, false, trail);
} else {
choice.mark = trail;
choice.cont = call;
choice.tail = redo;
}
more(choice);
} else {
more(snap.tail);
}
if (found === true)
cont(snap.cont.args[1]);
return found;
}
/**
* unshield(G):
* The predicate succeeds whenever the goal G succeeds.
* The goal is executed with auto-yield.
*/
function special_unshield(args) {
let goal = deref(args[0]);
let snap = snap_setup();
goal = new Compound(".", [goal, "[]"]);
cont(goal);
return solve_unshield(snap, true, null);
}
/**
* Call, redo or resume a goal.
* The goal is executed without auto-yield.
*
* @param snap The surrounding choice point.
* @param found The call or redo flag.
* @param choice The choice point for reuse or null.
* @return boolean True if goal succeeded, otherwise false.
*/
function solve_unshield(snap, found, choice) {
if (choice !== null) {
choice.mark = null;
choice.cont = "[]";
choice.tail = null;
}
let back = engine.flags & SYS_MASK_ASYNC_MODE;
engine.flags |= SYS_MASK_ASYNC_MODE;
try {
found = solve(snap, found);
} catch (x) {
engine.flags &= ~SYS_MASK_ASYNC_MODE;
engine.flags |= back;
snap_cleanup(snap);
throw x;
}
engine.flags &= ~SYS_MASK_ASYNC_MODE;
engine.flags |= back;
if (found === false)
return false;
if (redo !== snap) {
if (choice === null) {
choice = new Choice(solve_unshield, snap, false, trail);
} else {
choice.mark = trail;
choice.cont = call;
choice.tail = redo;
}
more(choice);
} else {
more(snap.tail);
}
if (found === true)
cont(snap.cont.args[1]);
return found;
}
/**
* call(A): [ISO 7.8.3]
* The predicate succeeds whenever the goal A succeeds.
*/
function special_call(args) {
let goal = deref(args[0]);
goal = new Compound(".", [goal, call.args[1]]);
cont(goal);
return true;
}
/*********************************************************************/
/* Type Assertions */
/*********************************************************************/
/**
* Assure that the object is an atom.
*
* @param beta The object.
*/
export function check_atom(beta) {
if (!is_atom(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["atom", beta]));
}
}
/**
* Assure that the object is a number.
*
* @param beta The object.
*/
export function check_number(beta) {
if (!is_number(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["number", beta]));
}
}
/**
* Assure that the object is an integer.
*
* @param beta The object.
*/
export function check_integer(beta) {
if (!is_integer(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["integer", beta]));
}
}
/**
* Assure that the object is atomic.
*
* @param beta The object.
*/
export function check_atomic(beta) {
if (is_variable(beta) || is_structure(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["atomic", beta]));
}
}
/**
* Assure that the Prolog term is nil.
*
* @param beta The Prolog term.
*/
export function check_nil(beta) {
if (beta === "[]")
return;
if (is_structure(beta) && beta.functor === "."
&& beta.args.length === 2) {
throw make_error(new Compound("representation_error",
["max_arity"]));
} else {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error",
["list", beta]));
}
}
/*********************************************************************/
/* =/2 and copy_term/2 */
/*********************************************************************/
/**
* S = T: [ISO 8.2.1]
* The built-in succeeds when the Prolog terms S and T unify,
* otherwise the built-in fails.
*/
function test_unify(args) {
let alpha = exec_build(args[0]);
return exec_unify(args[1], alpha);
}
/**
* copy_term(S, T): [ISO 8.5.4]
* The built-in succeeds in T with a copy of S.
*/
function test_copy_term(args) {
let alpha = exec_build(args[0]);
alpha = copy_term(alpha);
return exec_unify(args[1], alpha);
}
/*********************************************************************/
/* =../2, functor/3 and arg/3 */
/*********************************************************************/
/**
* T =.. [F|L]: [ISO 8.5.3]
* If T is a variable, the built-in succeeds in T with the Prolog term
* from the functor F and arguments L. Otherwise the built-in succeeds in
* F and L with the functor and arguments of the Prolog term T.
*/
function test_univ(args) {
let alpha = exec_deref(args[0]);
if (is_variable(alpha) || is_pending(alpha)) {
let beta = exec_build(args[1]);
beta = special_univ_pack(beta);
return exec_unify(alpha, beta);
} else {
alpha = exec_build(alpha);
alpha = special_univ_unpack(alpha);
return exec_unify(args[1], alpha);
}
}
function special_univ_pack(beta) {
if (is_structure(beta) &&
"." === beta.functor &&
beta.args.length === 2) {
/* */
} else {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["list", beta]));
}
let functor = deref(beta.args[0]);
check_atomic(functor);
beta = deref(beta.args[1]);
let args = list_objects(beta);
if (args.length === 0) {
/* */
} else {
if (is_number(functor))
throw make_error(new Compound("type_error", ["atom", functor]));
functor = new Compound(functor, args);
}
return functor;
}
export function list_objects(obj) {
let peek = obj;
let i = 0;
while (is_structure(peek) &&
"." === peek.functor &&
peek.args.length === 2 &&
i < MAX_ARITY) {
i++;
peek = deref(peek.args[1]);
}
check_nil(peek);
if (i === 0) {
return VOID_ARGS;
} else {
let args = new Array(i);
peek = obj;
i = 0;
while (is_structure(peek) &&
"." === peek.functor &&
peek.args.length === 2) {
args[i++] = deref(peek.args[0]);
peek = deref(peek.args[1]);
}
return args;
}
}
function special_univ_unpack(alpha) {
if (is_structure(alpha)) {
let temp = alpha.args;
alpha = alpha.functor;
return new Compound(".", [alpha,
objects_list(temp, 0, temp.length)]);
} else {
return new Compound(".", [alpha, "[]"]);
}
}
export function objects_list(args, off, count) {
let res = "[]";
for (let i = off + count - 1; i >= off; i--)
res = new Compound(".", [args[i], res]);
return res;
}
/**
* functor(T, F, A): [ISO 8.5.1]
* If T is a variable, the built-in succeeds in T with a new Prolog term
* from the functor F and the arity A. Otherwise the built-in succeeds in
* F and L with the functor and arguments of the Prolog term T.
*/
function test_functor(args) {
let alpha = exec_deref(args[0]);
if (is_variable(alpha) || is_pending(alpha)) {
let functor = exec_build(args[1]);
check_atomic(functor);
let arity = exec_build(args[2]);
check_integer(arity);
if (arity < 0)
throw make_error(new Compound("domain_error",
["not_less_than_zero", arity]));
if (arity > MAX_ARITY)
throw make_error(new Compound("representation_error",
["max_arity"]));
arity = narrow_float(arity);
if (arity === 0) {
/* */
} else {
if (is_number(functor))
throw make_error(new Compound("type_error", ["atom", functor]));
let temp = new Array(arity);
for (let i = 0; i < arity; i++)
temp[i] = new Variable();
functor = new Compound(functor, temp);
}
return exec_unify(alpha, functor);
} else {
alpha = exec_build(alpha);
let functor;
let arity;
if (is_structure(alpha)) {
functor = alpha.functor;
arity = alpha.args.length;
} else {
functor = alpha;
arity = 0;
}
if (!exec_unify(args[1], functor))
return false;
return exec_unify(args[2], norm_smallint(arity));
}
}
/**
* arg(K, X, Y): [ISO 8.5.2]
* The predicate succeeds in Y with the K-th argument of X.
*/
function test_arg(args) {
let alpha = exec_build(args[0]);
check_integer(alpha);
let beta = exec_build(args[1]);
check_callable(beta);
let arity;
if (is_structure(beta)) {
arity = beta.args.length;
} else {
arity = 0;
}
if (alpha < 1 || arity < alpha)
return false;
beta = beta.args[alpha - 1];
return exec_unify(args[2], beta);
}
/**
* Assure that the object is a callable.
*
* @param beta The object.
*/
export function check_callable(beta) {
if (is_variable(beta) || is_number(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["callable", beta]));
}
}
/*********************************************************************/
/* change_arg/3 */
/*********************************************************************/
/**
* change_arg(K, X, Y):
* The predicate succeeds. As a side-effect the K-th argument of X is set to Y.
*/
function test_change_arg(args) {
let alpha = exec_build(args[0]);
check_integer(alpha);
let beta = exec_build(args[1]);
check_callable(beta);
let gamma = exec_build(args[2]);
let arity;
if (is_structure(beta)) {
arity = beta.args.length;
} else {
arity = 0;
}
if (alpha < 1 || arity < alpha)
return false;
linkarg(gamma, beta, alpha);
return true;
}
function linkarg(source, term, pos) {
if (is_frozen(term))
throw make_error(new Compound("permission_error",
["modify", "compound", term]));
if ((term.walk & VAR_MASK_STATE) === gc_mask)
mark2_term(source);
term.args[pos-1] = source;
}
/*********************************************************************/
/* term_variables/2 */
/*********************************************************************/
/**
* term_variables(T, L): [TC2 8.5.5]
* The built-in succeeds in L with a list of the variables of T.
*/
function test_term_variables(args) {
let alpha = exec_build(args[0]);
let res = null;
let back = null;
function term_variables2(node) {
let peek = new Compound(".", [node, undefined]);
if (back === null) {
res = peek;
} else {
back.args[1] = peek;
}
back = peek;
return false;
}
walk_vars(alpha, term_variables2, VAR_MASK_SEEN);
if (back === null) {
res = "[]";
} else {
back.args[1] = "[]";
}
walk_vars(alpha, node => false, 0);
return exec_unify(args[1], res);
}
export function walk_vars(first, acceptor, state) {
let stack = null;
for (; ; ) {
first = deref(first);
if (is_variable(first)) {
if ((first.flags & VAR_MASK_SEEN) !== state) {
if (acceptor(first))
return true;
first.flags = (first.flags & ~VAR_MASK_SEEN) | state;
}
} else if (is_compound(first)) {
if ((first.walk & VAR_MASK_SEEN) !== state) {
first.walk = (first.walk & ~VAR_MASK_SEEN) | state;
if (0 !== first.args.length - 1) {
first.walk &= ~VAR_MASK_SERNO;
stack = stack_push(stack, first);
}
first = first.args[0];
continue;
}
}
let item = stack_peek(stack);
if (item === null) {
return false;
} else {
item.walk++;
first = item.args[item.walk & VAR_MASK_SERNO];
if ((item.walk & VAR_MASK_SERNO) === item.args.length - 1)
stack_pop(stack);
}
}
}
/*********************************************************************/
/* var/1, compound/1 and nonvar/1 */
/*********************************************************************/
/**
* var(V): [ISO 8.3.1]
* The built-in succeeds if V is a Prolog variable. Otherwise, it fails.
*/
function test_var(args) {
let alpha = exec_build(args[0]);
return is_variable(alpha);
}
/**
* compound(C): [ISO 8.3.6]
* The built-in succeeds if C is a Prolog compound. Otherwise, it fails.
*/
function test_compound(args) {
let alpha = exec_build(args[0]);
return is_structure(alpha);
}
/**
* nonvar(V): [ISO 8.3.7]
* The built-in succeeds if V is not a Prolog variable. Otherwise, it fails.
*/
function test_nonvar(args) {
let alpha = exec_build(args[0]);
return !is_variable(alpha);
}
/*********************************************************************/
/* atomic/1, number/1 and float/1 */
/*********************************************************************/
/**
* atomic(A): [ISO 8.3.5]
* The built-in succeeds if A is a Prolog symbol or number. Otherwise, it fails.
*/
function test_atomic(args) {
let alpha = exec_build(args[0]);
if (is_structure(alpha) || is_variable(alpha))
return false;
return true;
}
/**
* number(A): [ISO 8.3.8]
* The built-in succeeds if A is a Prolog number. Otherwise, it fails.
*/
function test_number(args) {
let alpha = exec_build(args[0]);
return is_number(alpha);
}
/**
* float(A): [ISO 8.3.4]
* The built-in succeeds if A is a Prolog float. Otherwise, it fails.
*/
function test_float(args) {
let alpha = exec_build(args[0]);
return is_float(alpha) && !is_special(alpha);
}
/*********************************************************************/
/* integer/1, atom/1, callable/1 and must_be/2 */
/*********************************************************************/
/**
* integer(A): [ISO 8.3.3]
* The built-in succeeds if A is a Prolog integer. Otherwise, it fails.
*/
function test_integer(args) {
let alpha = exec_build(args[0]);
return is_integer(alpha);
}
/**
* atom(A): [ISO 8.3.2]
* The built-in succeeds if A is a Prolog atom. Otherwise, it fails.
*/
function test_atom(args) {
let alpha = exec_build(args[0]);
return is_atom(alpha);
}
/**
* callable(C): [TC2 8.3.9]
* The built-in succeeds if C is a Prolog compound or symbol. Otherwise, it fails.
*/
function test_callable(args) {
let alpha = exec_build(args[0]);
if (is_variable(alpha) || is_number(alpha))
return false;
return true;
}
/**
* must_be(T, A):
* The built-in succeeds if A is of type T. Otherwise, an exception is thrown.
*/
function test_must_be(args) {
let alpha = exec_build(args[0]);
check_atom(alpha);
let beta = exec_build(args[1]);
if ("integer" === alpha) {
check_integer(beta);
} else if ("atom" === alpha) {
check_atom(beta);
} else if ("callable" === alpha) {
check_callable(beta);
} else {
throw make_error(new Compound("type_error",
["type", alpha]));
}
return true;
}
/*********************************************************************/
/* Number Utilities */
/*********************************************************************/
/**
* Normalize a JavaScript smallint. We do not check type obj === "number"
* and Number.isInteger(obj), but this is assumed. The later assumption
* is deliberately violated in truncate/1, etc.. implementation.
*
* @param alpha The smallint.
* @return The Prolog integer.
*/
export function norm_smallint(alpha) {
if ((-94906266 <= alpha) && (alpha <= 94906266)) {
return alpha;
} else {
return BigInt(alpha);
}
}
/**
* Normalize a JavaScript bigint. We do not check type obj === "biginteger",
* but this is assumed.
*
* @param alpha The bigint.
* @return The Prolog integer.
*/
export function norm_bigint(alpha) {
if ((-94906266 <= alpha) && (alpha <= 94906266)) {
return Number(alpha);
} else {
return alpha;
}
}
/**
* Widen a Prolog integer.
*
* @param alpha The Prolog integer.
* @return The JavaScript bigint.
*/
export function widen_bigint(alpha) {
if (!is_bigint(alpha)) {
return BigInt(alpha);
} else {
return alpha;
}
}
/**
* Narrow a Prolog number to a JavaScript float.
*
* @param alpha The Prolog number.
* @return The JavaScript float.
*/
export function narrow_float(alpha) {
if (!is_bigint(alpha)) {
if (!Number.isFinite(alpha))
throw make_error(new Compound("evaluation_error", ["undefined"]));
} else {
alpha = Number(alpha);
if (!Number.isFinite(alpha))
throw make_error(new Compound("evaluation_error", ["float_overflow"]));
}
return alpha;
}
/**
* Norm a JavaScript float to a Prolog float.
*
* @param alpha The JavaScript float.
* @return The Prolog float.
*/
export function norm_float(alpha) {
if (Number.isNaN(alpha))
throw make_error(new Compound("evaluation_error", ["undefined"]));
if (!Number.isFinite(alpha))
throw make_error(new Compound("evaluation_error", ["float_overflow"]));
if ((-94906266 <= alpha) && (alpha <= 94906266)
&& Number.isInteger(alpha))
return BigInt(alpha);
return alpha;
}
/*********************************************************************/
/* code_category/2 and code_numeric/2 */
/*********************************************************************/
/**
* code_category(C, T):
* The predicate succeeds in T with the Unicode general category of C.
* Otherwise, the predicate succeeds in T with 0.
*/
function test_code_category(args) {
let alpha = exec_build(args[0]);
check_integer(alpha);
if (alpha < 0 || alpha > 0x10FFFF) {
alpha = 0; // UNASSIGNED
} else {
alpha = code_category(alpha);
}
return exec_unify(args[1], alpha);
}
/**
* code_numeric(C, V):
* The predicate succeeds in V with the Unicode numeric value of C,
* in case it is integer and between 0 and 35. Otherwise, the predicate
* succeeds in V with -1.
*/
function test_code_numeric(args) {
let alpha = exec_build(args[0]);
check_integer(alpha);
if (alpha < 0 || alpha > 0x10FFFF) {
alpha = -1; // UNASSIGNED
} else {
alpha = code_numeric(alpha);
}
return exec_unify(args[1], alpha);
}
/*********************************************************************/
/* atom_integer/3 */
/*********************************************************************/
/**
* atom_integer(A, R, N):
* If A is a variable, then the built-in succeeds in A with the
* atom for the Prolog integer N in radix R. Otherwise the
* built-in succeeds in N with the Prolog number from the
* atom A in radix R.
*/
function test_atom_integer(args) {
let radix = exec_build(args[1]);
check_integer(radix);
if (radix < 2 || radix > 36)
throw make_error(new Compound("domain_error", ["radix", radix]));
let text = exec_deref(args[0]);
if (is_variable(text) || is_pending(text)) {
let beta = exec_build(args[2]);
check_integer(beta);
beta = beta.toString(radix);
return exec_unify(text, beta);
} else {
text = exec_build(text);
check_atom(text);
text = atom_integer_decode(text, radix);
return exec_unify(args[2], text);
}
}
/**
* Decode a Prolog integer from a string.
*
* @param text The string
* @param radix The radix.
* @return The Prolog integer.
*/
function atom_integer_decode(text, radix) {
text = ascii_replace(text, radix, false);
let res;
let step = (52 / (32 - Math.clz32(radix - 1))) | 0;
if (text.length <= step) {
res = Number.parseInt(text, radix);
if (isNaN(res))
throw make_error(new Compound("syntax_error", ["illegal_number"]));
res = norm_smallint(res);
} else {
if (0 < text.length && text.charCodeAt(0) === 45) {
res = -bigint_parse(text, 1, step, radix);
} else {
res = bigint_parse(text, 0, step, radix);
}
res = norm_bigint(res);
}
return res;
}
/**
* Parse a bigint in some radix.
*
* @param str The string.
* @param help The start position.
* @param step The chunk size.
* @param radix The radix.
* @return The bigint.
*/
function bigint_parse(str, help, step, radix) {
if (help === str.length)
throw make_error(new Compound("syntax_error", ["illegal_number"]));
let res = BigInt(0);
while (help + step < str.length) {
let temp = Number.parseInt(str.slice(help, help + step), radix);
if (isNaN(temp) || temp < 0)
throw make_error(new Compound("syntax_error", ["illegal_number"]));
res = res * BigInt(radix ** step) + BigInt(temp);
help += step;
}
let temp = Number.parseInt(str.slice(help), radix);
if (isNaN(temp) || temp < 0)
throw make_error(new Compound("syntax_error", ["illegal_number"]));
return res * BigInt(radix ** (str.length - help)) + BigInt(temp);
}
/**
* Convert and validate Unicode number values
* into capital ASCII number value.
*
* @param text The string.
* @param radix The radix.
* @param expo The float flag.
* @return The The new string.
*/
function ascii_replace(text, radix, expo) {
let buf = "";
let last = 0;
let pos = 0;
while (pos < text.length) {
let ch = text.codePointAt(pos);
let val = code_numeric(ch);
if (val >= 0 && val < radix) {
if (ch <= 127) { // ASCII
/* */
} else {
if (val < 10) {
val += 48; // '0'
} else {
val += 55; // 'A'-10
}
buf += text.slice(last, pos) + String.fromCodePoint(val);
last = pos + char_count(ch);
}
} else if ((ch===43 || ch===45) && (pos===0 ||
(expo && (text.charCodeAt(pos-1)===101 || text.charCodeAt(pos-1)===69)))) {
/* */
} else if (expo && (ch===46 || ch===101 || ch===69)) {
/* */
} else {
throw make_error(new Compound("syntax_error", ["illegal_number"]));
}
pos += char_count(ch);
}
if (last !== 0) {
buf += text.slice(last);
return buf;
} else {
return text;
}
}
/**
* Return the 16-bit char count of a Unicode code point.
*
* @param ch The code point.
* @return The char count.
*/
export function char_count(ch) {
if (ch <= 0xFFFF) {
return 1;
} else {
return 2;
}
}
/*********************************************************************/
/* atom_number/2 */
/*********************************************************************/
/**
* atom_number(A, N):
* If A is a variable, then the built-in succeeds in A with the
* atom for the Prolog number N. Otherwise the built-in succeeds in N
* with the Prolog number from the atom A.
*/
function test_atom_number(args) {
let text = exec_deref(args[0]);
if (is_variable(text) || is_pending(text)) {
let beta = exec_build(args[1]);
check_number(beta);
beta = atom_number_encode(beta);
return exec_unify(text, beta);
} else {
text = exec_build(text);
check_atom(text);
text = atom_number_decode(text);
return exec_unify(args[1], text);
}
}
/**
* Encode a Prolog number to a string.
*
* @param num The Prolog number.
* @return The string.
*/
function atom_number_encode(num) {
if (is_integer(num)) {
return num.toString();
} else {
num = narrow_float(num);
let res = num.toPrecision(16);
if (Number(res) !== num)
res = num.toPrecision(17);
return shape_number(res);
}
}
/**
* Shape the number string so that it has no trailing
* zeros after the period, always a period, no exponent
* positive sign and lower case exponent.
*
* @param res The ascii number string
* @return The shaped number string.
*/
function shape_number(res) {
let peek = res.indexOf("e");
if (peek !== -1) {
res = shape_number_mantissa(res.slice(0, peek)) +
"e" + shape_number_exponent(res.slice(peek + 1));
} else {
res = shape_number_mantissa(res);
}
return res;
}
function shape_number_mantissa(res) {
if (res.indexOf(".") !== -1) {
let pos = res.length;
while (res.charCodeAt(pos - 1) === 48) // '0'
pos--;
if (res.charCodeAt(pos - 1) === 46) // '.'
pos++;
if (pos !== res.length)
res = res.slice(0, pos);
} else {
res += ".0";
}
return res;
}
function shape_number_exponent(res) {
if (res.startsWith("+"))
res = res.slice(1);
return res;
}
/**
* Decode a Prolog number from a string. Unlike the ISO
* core standard and numbers without a period but with
* an exponent are accepted as float.
*
* @param text The string
* @return The Prolog number.
*/
function atom_number_decode(text) {
text = ascii_replace(text, 10, true);
let res;
if ((text.indexOf(".") !== -1) ||
(text.indexOf("e") !== -1) ||
(text.indexOf("E") !== -1)) {
res = Number(text);
if (isNaN(res))
throw make_error(new Compound("syntax_error", ["illegal_number"]));
res = norm_float(res);
} else {
if (text.length <= 8) {
res = Number(text);
if (isNaN(res))
throw make_error(new Compound("syntax_error", ["illegal_number"]));
res = norm_smallint(res);
} else {
try {
res = BigInt(text);
} catch (e) {
throw make_error(new Compound("syntax_error", ["illegal_number"]));
}
res = norm_bigint(res);
}
}
return res;
}
/******************************************************************/
/* sys_goal_ossify/3 and sys_clause_ossify/6 */
/******************************************************************/
/**
* sys_goal_ossify(B, R, G): internal only
* The built-in succeeds in G with a JavaScript object representing
* a goal with body instructions B and the cut option R.
*/
function test_sys_goal_ossify(args) {
let alpha = exec_build(args[0]);
let body = list_objects(alpha);
let beta = exec_build(args[1]);
let cutvar;
let size = 0;
try {
size = number_term(beta, size);
size = number_objects(body, size);
cutvar = ossify_cutvar(beta);
ossify_objects(body);
} finally {
unossify_term(beta);
unossify_objects(alpha);
}
return exec_unify(args[2],
new Goal(size, body, cutvar));
}
/**
* sys_clause_ossify(H, B, R, W, C): internal only
* The built-in succeeds in C with a JavaScript object representing
* a clause with head instructions H, body instructions B,
* cut option R and head functor W.
*/
function test_sys_clause_ossify(args) {
let alpha = exec_build(args[0]);
let head = list_objects(alpha);
let beta = exec_build(args[1]);
let body = list_objects(beta);
let gamma = exec_build(args[2]);
let mue = exec_build(args[3]);
let cutvar;
let size = 0;
try {
size = number_term(gamma, size);
size = number_objects(head, size);
size = number_objects(body, size);
cutvar = ossify_cutvar(gamma);
ossify_objects(head);
ossify_objects(body);
} finally {
unossify_term(gamma);
unossify_objects(alpha);
unossify_objects(beta);
}
return exec_unify(args[4],
new Clause(size, mue, head, body, cutvar));
}
/******************************************************************/
/* Object Lists */
/******************************************************************/
function number_objects(peek, size) {
for (let i = 0; i < peek.length; i++)
size = number_term(peek[i], size);
return size;
}
function ossify_objects(peek) {
for (let i = 0; i < peek.length; i++)
peek[i] = ossify_term(peek[i]);
}
function unossify_objects(peek) {
while (is_structure(peek) &&
"." === peek.functor &&
peek.args.length === 2) {
unossify_term(peek.args[0]);
peek = deref(peek.args[1]);
}
}
/******************************************************************/
/* Cut Variable */
/******************************************************************/
function ossify_cutvar(peek) {
if (is_structure(peek) &&
"just" === peek.functor &&
peek.args.length === 1) {
let res = ossify_term(peek.args[0]);
return res.index;
} else {
return -1;
}
}
/******************************************************************/
/* Term Ossify */
/******************************************************************/
function number_term(alpha, size) {
function number_term2(first) {
for (; ;) {
first = deref(first);
if (is_variable(first)) {
if (first.tail === null) {
first.tail = undefined;
} else if (first.tail === undefined) {
first.tail = new Place(size);
size++;
}
} else if (is_compound(first)) {
let i = 0;
for (; i < first.args.length - 1; i++)
number_term2(first.args[i]);
first = first.args[i];
continue;
}
break;
}
}
number_term2(alpha);
return size;
}
function ossify_term(first) {
let back = null;
for (;;) {
first = deref(first);
if (is_variable(first)) {
first = first.tail;
} else if (is_compound(first)) {
let args = new Array(first.args.length);
let i = 0;
for (; i < first.args.length-1; i++)
args[i] = ossify_term(first.args[i]);
args[i] = back;
back = new Skeleton(first.functor, args);
first = first.args[i];
continue;
}
while (back !== null) {
let peek = back.args[back.args.length-1];
back.args[back.args.length-1] = first;
first = try_freeze(back);
back = peek;
}
return first;
}
}
function try_freeze(alpha) {
for (let i = 0; i < alpha.args.length; i++) {
let temp = alpha.args[i];
if (is_pending(temp))
return alpha;
if (is_skeleton(temp))
return alpha;
}
return new Frozen(alpha.functor, alpha.args);
}
function unossify_term(first) {
for (;;) {
first = deref(first);
if (is_variable(first)) {
if (first.tail != null)
first.tail = null;
} else if (is_compound(first)) {
let i = 0;
for (; i < first.args.length-1; i++)
unossify_term(first.args[i]);
first = first.args[i];
continue;
}
break;
}
}
/*********************************************************************/
/* sys_clause_add/2 and sys_goal_call/1 */
/*********************************************************************/
/**
* sys_clause_add(C, O): internal only
* The built-in succeeds. As a side effect the JavaScript object clause C
* is added according to options O to the knowledge base.
*/
function test_sys_clause_add(args) {
let gamma = exec_build(args[0]);
check_clause(gamma);
let flags = exec_build(args[1]);
check_integer(flags);
add_clause(gamma, flags);
return true;
}
export function check_clause(beta) {
if (!is_clause(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["clause", beta]));
}
}
/**
* sys_goal_call(A):
* The predicate succeeds whenever the compiled goal A succeeds.
*/
function special_sys_goal_call(args) {
let goal = deref(args[0]);
check_goal(goal);
goal = melt_directive(goal);
solve_seq(goal);
return true;
}
export function check_goal(beta) {
if (!is_goal(beta)) {
check_nonvar(beta);
beta = copy_term(beta);
throw make_error(new Compound("type_error", ["goal", beta]));
}
}
/*********************************************************************/
/* Special Init */
/*********************************************************************/
// Albufeira compiler, control flow
set("fail", 0, make_check(test_fail));
set("$CUT", 1, make_check(test_cut));
set("$MARK", 1, make_check(test_mark));
set("$SEQ", 2, make_special(special_seq));
set("$ALT", 1, make_special(special_alt));
set("sys_raise", 1, make_check(test_sys_raise));
set("sys_trap", 3, make_special(special_sys_trap));
// Albufeira compiler, async flow
set("os_sleep_promise", 2, make_check(test_os_sleep_promise));
set("os_import_promise", 3, make_check(test_os_import_promise));
set("os_invoke_main", 1, make_check(test_os_invoke_main));
set("$YIELD", 1, make_special(special_yield));
set("shield", 1, make_special(special_shield));
set("unshield", 1, make_special(special_unshield));
set("call", 1, make_special(special_call));
// term specials
set("=", 2, make_check(test_unify));
set("copy_term", 2, make_check(test_copy_term));
set("=..", 2, make_check(test_univ));
set("functor", 3, make_check(test_functor));
set("arg", 3, make_check(test_arg));
set("change_arg", 3, make_check(test_change_arg));
set("term_variables", 2, make_check(test_term_variables));
// type specials
set("var", 1, make_check(test_var));
set("compound", 1, make_check(test_compound));
set("nonvar", 1, make_check(test_nonvar));
set("atomic", 1, make_check(test_atomic));
set("number", 1, make_check(test_number));
set("float", 1, make_check(test_float));
// must specials
set("integer", 1, make_check(test_integer));
set("atom", 1, make_check(test_atom));
set("callable", 1, make_check(test_callable));
set("must_be", 2, make_check(test_must_be));
// atom specials
set("code_category", 2, make_check(test_code_category));
set("code_numeric", 2, make_check(test_code_numeric));
set("atom_integer", 3, make_check(test_atom_integer));
set("atom_number", 2, make_check(test_atom_number));
// clause specials
set("sys_goal_ossify", 3, make_check(test_sys_goal_ossify));
set("sys_clause_ossify", 5, make_check(test_sys_clause_ossify));
set("sys_clause_add", 2, make_check(test_sys_clause_add));
set("sys_goal_call", 1, make_special(special_sys_goal_call));