builtins.c

/*
 * plang logic programming language
 * Copyright (C) 2011  Southern Storm Software, Pty Ltd.
 *
 * The plang package is free software: you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation, either version 3 of
 * the License, or (at your option) any later version.
 *
 * The plang package is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with the libcompiler library.  If not,
 * see <http://www.gnu.org/licenses/>.
 */

#include <plang/database.h>
#include <plang/errors.h>
#include <errno.h>
#include "term-priv.h"
#include "database-priv.h"
#include "context-priv.h"

/*\@{*/

/*\@}*/

/* Destructively sets a variable to a value */
P_INLINE void p_builtin_set_variable(p_term *var, p_term *value)
{
    if (!var || (var->header.type & P_TERM_VARIABLE) == 0)
        return;
    var->var.value = value;
}

/* Unbinds a list of local loop variables: $$unbind() predicate */
static p_goal_result p_builtin_unbind
    (p_context *context, p_term **args, p_term **error)
{
    p_term *list = p_term_deref(args[0]);
    while (list && list->header.type == P_TERM_LIST) {
        p_builtin_set_variable(list->list.head, 0);
        list = p_term_deref(list->list.tail);
    }
    return P_RESULT_TRUE;
}

/*\@{*/
/* Predicates and functions for this group are defined in arith.c */
/*\@}*/

/*\@{*/

static void p_builtin_add_member_predicate
    (p_context *context, p_term *class_object,
     p_term *member_name, p_term *predicate)
{
    p_term *list;
    p_term *property = p_term_own_property
        (context, class_object, member_name);
    if (property && property != predicate) {
        /* Search the existing predicate list and add this
         * predicate if it does not currently exist.  We need
         * a list of predicates to support arity overloading */
        if (property->header.type == P_TERM_LIST) {
            list = property;
            while (list && list->header.type == P_TERM_LIST) {
                if (list->list.head == predicate)
                    return;     /* Predicate is already in the list */
                list = list->list.tail;
            }
        } else {
            /* Convert a single predicate reference into a list */
            property = p_term_create_list
                (context, property, context->nil_atom);
        }
        property = p_term_create_list(context, predicate, property);
        p_term_set_own_property
            (context, class_object, member_name, property);
    } else if (!property) {
        /* First time predicate was added to this property */
        p_term_add_property
            (context, class_object, member_name, predicate);
    }
}

static p_goal_result p_builtin_new_class
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    p_term *parent = p_term_deref_member(context, args[1]);
    p_term *vars = p_term_deref_member(context, args[2]);
    p_term *clauses = p_term_deref_member(context, args[3]);
    p_database_info *info;
    p_database_info *info2;
    p_class_info *class_info;
    p_class_info *parent_info;
    p_term *class_object;
    p_term *prototype;
    p_term *list;
    p_term *var_name;
    p_term *member_name;
    p_term *kind;
    p_term *clause_term;
    p_term *clause_body;
    p_term *clause_atom;
    p_term *member_atom;
    p_term *predicate;

    /* Validate the class name - must be an atom and not yet a class */
    if (!name || (name->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (name->header.type != P_TERM_ATOM) {
        *error = p_create_type_error(context, "atom", name);
        return P_RESULT_ERROR;
    }
    info = _p_db_create_arity(name, 0);
    if (!info)
        return P_RESULT_FAIL;
    if (info->class_info) {
        /* There already exists a class with this name */
        *error = p_create_permission_error
            (context, "create", "class", name);
        return P_RESULT_ERROR;
    }

    /* Locate the prototype for the parent class */
    if (!parent || (parent->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (parent && parent != context->nil_atom) {
        if (parent->header.type != P_TERM_ATOM) {
            *error = p_create_type_error(context, "atom", parent);
            return P_RESULT_ERROR;
        }
        info2 = _p_db_find_arity(parent, 0);
        if (!info2 || !info2->class_info) {
            /* Parent class does not exist */
            *error = p_create_existence_error(context, "class", parent);
            return P_RESULT_ERROR;
        }
        parent_info = info2->class_info;
        prototype = parent_info->class_object;
    } else {
        parent_info = 0;
        prototype = 0;
    }

    /* Validate the member variable list */
    list = vars;
    if (!list || (list->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    for (;;) {
        if (list == context->nil_atom)
            break;
        if (!list || list->header.type != P_TERM_LIST) {
            *error = p_create_type_error(context, "atom_list", vars);
            return P_RESULT_ERROR;
        }
        var_name = p_term_deref_member(context, list->list.head);
        if (!var_name ||
                (var_name->header.type & P_TERM_VARIABLE) != 0) {
            *error = p_create_instantiation_error(context);
            return P_RESULT_ERROR;
        }
        if (var_name->header.type != P_TERM_ATOM) {
            *error = p_create_type_error(context, "atom_list", vars);
            return P_RESULT_ERROR;
        }
        if(var_name == context->class_name_atom ||
                var_name == context->prototype_atom) {
            *error = p_create_type_error
                (context, "member_name", var_name);
            return P_RESULT_ERROR;
        }
        list = p_term_deref_member(context, list->list.tail);
    }

    /* Create the class information block and the object */
    class_info = GC_NEW(p_class_info);
    if (!class_info)
        return P_RESULT_FAIL;
    class_object = p_term_create_class_object(context, name, prototype);
    if (!class_object)
        return P_RESULT_FAIL;
    class_info->class_object = class_object;
    class_info->parent = parent_info;
    class_info->var_list = vars;

    /* Define the clauses into the database and attach
     * them to the class object */
    list = clauses;
    clause_atom = p_term_create_atom(context, "clause");
    member_atom = p_term_create_atom(context, "member");
    while (list && list->header.type == P_TERM_LIST) {
        /* Extract clause(MemberName, Kind, ClauseBody) from the list */
        clause_term = p_term_deref_member(context, list->list.head);
        if (!clause_term ||
                (clause_term->header.type & P_TERM_VARIABLE) != 0) {
            *error = p_create_instantiation_error(context);
            return P_RESULT_ERROR;
        }
        if (clause_term->header.type == P_TERM_FUNCTOR &&
                clause_term->header.size == 3 &&
                clause_term->functor.functor_name == context->line_atom)
            clause_term = p_term_deref_member
                (context, clause_term->functor.arg[2]);
        if (clause_term->header.type != P_TERM_FUNCTOR ||
                clause_term->header.size != 3 ||
                clause_term->functor.functor_name != clause_atom) {
            break;
        }
        member_name = p_term_deref_member
            (context, clause_term->functor.arg[0]);
        kind = p_term_deref_member
            (context, clause_term->functor.arg[1]);
        clause_body = p_term_deref_member
            (context, clause_term->functor.arg[2]);
        if (!member_name || member_name->header.type != P_TERM_ATOM)
            break;
        if (!kind || kind->header.type != P_TERM_ATOM)
            break;
        if (!clause_body ||
                clause_body->header.type != P_TERM_FUNCTOR ||
                clause_body->header.size != 2 ||
                clause_body->functor.functor_name
                        != context->clause_atom)
            break;

        /* Validate the member name */
        if(member_name == context->class_name_atom ||
                member_name == context->prototype_atom) {
            *error = p_create_type_error
                (context, "member_name", member_name);
            return P_RESULT_ERROR;
        }

        /* Define the clause into the database */
        predicate = _p_db_clause_assert_last(context, clause_body);
        if (!predicate) {
            /* Predicate is compiled or builtin */
            p_term *pred, *head;
            pred = p_term_create_functor
                (context, context->slash_atom, 2);
            head = p_term_deref_member
                (context, clause_body->functor.arg[0]);
            if (head->header.type == P_TERM_FUNCTOR) {
                p_term_bind_functor_arg
                    (pred, 0, head->functor.functor_name);
                p_term_bind_functor_arg
                    (pred, 1,
                     p_term_create_integer(context, head->header.size));
            } else {
                p_term_bind_functor_arg(pred, 0, head);
                p_term_bind_functor_arg(pred, 1, 0);
            }
            *error = p_create_permission_error
                (context, "modify", "static_procedure", pred);
            return P_RESULT_ERROR;
        }
        if (kind == member_atom) {
            /* Add this predicate to the member_name class property */
            p_builtin_add_member_predicate
                (context, class_object, member_name, predicate);
        }

        /* Move on to the next clause in the list */
        list = p_term_deref_member
            (context, list->list.tail);
    }
    if (!list || (list->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (list != context->nil_atom) {
        *error = p_create_type_error(context, "clause_list", clauses);
        return P_RESULT_ERROR;
    }

    /* Class object is ready to go */
    info->class_info = class_info;
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_univ
    (p_context *context, p_term **args, p_term **error);

static p_goal_result p_builtin_new
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    p_term *var = p_term_deref_member(context, args[1]);
    p_term *obj;
    p_database_info *info;
    p_class_info *class_info;
    p_term *vars;
    p_term *var_name;

    /* Validate the parameters */
    if (!name || !var || (name->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (name->header.type != P_TERM_ATOM) {
        *error = p_create_type_error(context, "atom", name);
        return P_RESULT_ERROR;
    }
    if ((var->header.type & P_TERM_VARIABLE) == 0) {
        *error = p_create_type_error(context, "variable", var);
        return P_RESULT_ERROR;
    }

    /* Find the class information for creating the object */
    info = _p_db_find_arity(name, 0);
    if (!info || !(info->class_info)) {
        *error = p_create_existence_error(context, "class", name);
        return P_RESULT_ERROR;
    }

    /* Create the bare object term */
    class_info = info->class_info;
    obj = p_term_create_object(context, class_info->class_object);
    if (!obj)
        return P_RESULT_FAIL;

    /* Create unbound variable property slots for all declared fields */
    do {
        vars = p_term_deref_member(context, class_info->var_list);
        while (vars && vars->header.type == P_TERM_LIST) {
            var_name = p_term_deref_member(context, vars->list.head);
            if (!p_term_own_property(context, obj, var_name)) {
                p_term_add_property
                    (context, obj, var_name,
                     p_term_create_variable(context));
            }
            vars = p_term_deref_member(context, vars->list.tail);
        }
        class_info = class_info->parent;
    } while (class_info);

    /* Unify the object with the variable */
    if (p_term_unify(context, var, obj, P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}
static p_goal_result p_builtin_new_object
    (p_context *context, p_term **args, p_term **error)
{
    p_goal_result result;
    p_term *name;
    p_term *list;
    p_term *univ_args[2];

    /* Create the basic object instance */
    result = p_builtin_new(context, args, error);
    if (result != P_RESULT_TRUE)
        return result;

    /* Use the "=.." operator to build a call to the constructor */
    name = p_term_create_member_name
        (context, args[0], p_term_create_atom(context, "new"));
    list = p_term_create_list(context, args[1], args[2]);
    list = p_term_create_list(context, name, list);
    univ_args[0] = p_term_create_variable(context);
    univ_args[1] = list;
    result = p_builtin_univ(context, args, error);
    if (result != P_RESULT_TRUE)
        return result;

    /* Replace the current goal with the constructor call */
    context->current_node->goal = univ_args[0];
    return P_RESULT_TREE_CHANGE;
}

static p_term *p_create_member_existence_error
    (p_context *context, p_term *object, p_term *name, p_term *arg_head)
{
    p_term *class_name = p_term_property
        (context, object, context->class_name_atom);
    p_term *full_name = p_term_create_member_name
        (context, class_name, name);
    p_term *pred = p_term_create_functor
        (context, context->slash_atom, 2);
    p_term_bind_functor_arg(pred, 0, full_name);
    p_term_bind_functor_arg
        (pred, 1, p_term_create_integer
            (context, (int)(arg_head->header.size)));
    return p_create_existence_error(context, "member_predicate", pred);
}

/* Implementation of '$$call_member'(X.name, '$$'(X, args)) */
static p_goal_result p_builtin_call_member
    (p_context *context, p_term **args, p_term **error)
{
    p_term *member = p_term_deref(args[0]);
    p_term *arg_head = p_term_deref(args[1]);
    p_term *object;
    p_term *predicate;
    p_term *list;
    p_term_clause_iter clause_iter;
    p_term *clause;
    p_term *body;
    p_exec_node *current;
    p_exec_node *new_current;
    p_exec_clause_node *next;
    int arity;

    /* Validate the parameters */
    if (!member || member->header.type != P_TERM_MEMBER_VARIABLE)
        return P_RESULT_FAIL;
    if (!arg_head || arg_head->header.type != P_TERM_FUNCTOR)
        return P_RESULT_FAIL;
    object = p_term_deref_member(context, member->member_var.object);
    if (!object || object->header.type != P_TERM_OBJECT) {
        *error = p_create_type_error(context, "object", object);
        return P_RESULT_ERROR;
    }

    /* Find the predicate to be executed via this member */
    predicate = p_term_property
        (context, object, member->member_var.name);
    if (!predicate) {
        *error = p_create_member_existence_error
            (context, object, member->member_var.name, arg_head);
        return P_RESULT_ERROR;
    }
    if (predicate->header.type == P_TERM_LIST) {
        /* Overloaded predicate member: search for the correct arity */
        list = predicate;
        arity = -1;
        do {
            predicate = p_term_deref(list->list.head);
            if (predicate &&
                    predicate->header.type == P_TERM_PREDICATE &&
                    predicate->header.size == arg_head->header.size) {
                arity = (int)(arg_head->header.size);
                break;
            }
            list = p_term_deref(list->list.tail);
        } while (list && list->header.type == P_TERM_LIST);
    } else if (predicate->header.type == P_TERM_PREDICATE) {
        /* Single predicate associated with the member name */
        arity = (int)(predicate->header.size);
    } else {
        *error = p_create_type_error(context, "predicate", predicate);
        return P_RESULT_ERROR;
    }
    if (arity != (int)(arg_head->header.size)) {
        *error = p_create_member_existence_error
            (context, object, member->member_var.name, arg_head);
        return P_RESULT_ERROR;
    }

    /* Search for the first predicate clause that matches */
    p_term_clauses_begin(predicate, arg_head, &clause_iter);
    while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
        body = p_term_unify_clause(context, arg_head, clause);
        if (body) {
            current = context->current_node;
            if (p_term_clauses_has_more(&clause_iter)) {
                next = GC_NEW(p_exec_clause_node);
                new_current = GC_NEW(p_exec_node);
                if (!next || !new_current)
                    return P_RESULT_FAIL;
                next->parent.parent.goal = arg_head;
                next->parent.parent.success_node = current->success_node;
                next->parent.parent.cut_node = context->fail_node;
                _p_context_init_fail_node
                    (context, &(next->parent), _p_context_clause_fail_func);
                next->clause_iter = clause_iter;
                new_current->goal = body;
                new_current->success_node = current->success_node;
                new_current->cut_node = context->fail_node;
                context->current_node = new_current;
                context->fail_node = &(next->parent);
            } else {
                new_current = GC_NEW(p_exec_node);
                if (!new_current)
                    return P_RESULT_FAIL;
                new_current->goal = body;
                new_current->success_node = current->success_node;
                new_current->cut_node = context->fail_node;
                context->current_node = new_current;
            }
            return P_RESULT_TREE_CHANGE;
        }
    }
    return P_RESULT_FAIL;
}

/*\@}*/

/*\@{*/

static p_term *p_builtin_parse_indicator
    (p_context *context, p_term *pred, int *arity, p_term **error)
{
    p_term *name_term;
    p_term *arity_term;
    pred = p_term_deref_member(context, pred);
    if (!pred || (pred->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return 0;
    } else if (pred->header.type != P_TERM_FUNCTOR ||
               pred->header.size != 2 ||
               pred->functor.functor_name != context->slash_atom) {
        *error = p_create_type_error
            (context, "predicate_indicator", pred);
        return 0;
    }
    name_term = p_term_deref_member(context, pred->functor.arg[0]);
    arity_term = p_term_deref_member(context, pred->functor.arg[1]);
    if (!name_term || (name_term->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return 0;
    }
    if (!arity_term || (arity_term->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return 0;
    }
    if (arity_term->header.type != P_TERM_INTEGER) {
        *error = p_create_type_error(context, "integer", arity_term);
        return 0;
    }
    if (name_term->header.type != P_TERM_ATOM) {
        *error = p_create_type_error(context, "atom", name_term);
        return 0;
    }
    *arity = p_term_integer_value(arity_term);
    if (*arity < 0) {
        *error = p_create_domain_error
            (context, "not_less_than_zero", arity_term);
        return 0;
    }
    return name_term;
}

static p_goal_result p_builtin_abolish
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name;
    int arity;
    name = p_builtin_parse_indicator(context, args[0], &arity, error);
    if (!name)
        return P_RESULT_ERROR;
    if (!p_db_clause_abolish(context, name, arity)) {
        *error = p_create_permission_error
            (context, "modify", "static_procedure", args[0]);
        return P_RESULT_ERROR;
    }
    return P_RESULT_TRUE;
}

static p_term *p_builtin_verify_database
    (p_context *context, p_term *arg, p_term **error)
{
    p_term *database = p_term_deref_member(context, arg);
    if (!database || (database->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return 0;
    }
    if (database->header.type != P_TERM_DATABASE) {
        *error = p_create_type_error(context, "database", database);
        return 0;
    }
    return database;
}

static p_goal_result p_builtin_abolish_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *database;
    p_term *name;
    int arity;
    database = p_builtin_verify_database(context, args[1], error);
    if (!database)
        return P_RESULT_ERROR;
    name = p_builtin_parse_indicator(context, args[0], &arity, error);
    if (!name)
        return P_RESULT_ERROR;
    p_db_local_clause_abolish(context, database, name, arity);
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_abolish_database
    (p_context *context, p_term **args, p_term **error)
{
    /* Validate the database argument */
    p_term *database = p_builtin_verify_database(context, args[0], error);
    if (!database)
        return P_RESULT_ERROR;

    /* Null out the predicate tree, and let the garbage collector
     * clean up all of the associated nodes and predicates */
    database->database.predicates.root = 0;
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_assert
    (p_context *context, p_term **args, p_term **error,
     int at_start, p_term *database)
{
    p_term *clause = p_term_deref_member(context, args[0]);
    p_term *head;
    p_term *pred;
    if (!clause || (clause->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (clause->header.type == P_TERM_FUNCTOR &&
            clause->header.size == 2 &&
            clause->functor.functor_name == context->dcg_atom) {
        /* Expand DCG rules into their normal clause form */
        clause = p_term_expand_dcg(context, clause);
    }
    if (clause->header.type == P_TERM_FUNCTOR &&
            clause->header.size == 2 &&
            clause->functor.functor_name == context->clause_atom) {
        head = p_term_deref_member(context, clause->functor.arg[0]);
    } else {
        head = clause;
        clause = p_term_create_functor
            (context, context->clause_atom, 2);
        p_term_bind_functor_arg(clause, 0, head);
        p_term_bind_functor_arg(clause, 1, context->true_atom);
    }
    if (!head || (head->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (head->header.type != P_TERM_ATOM &&
            head->header.type != P_TERM_FUNCTOR) {
        *error = p_create_type_error(context, "callable", head);
        return P_RESULT_ERROR;
    }
    clause = p_term_clone(context, clause);
    if (database) {
        if (at_start) {
            if (p_db_local_clause_assert_first(context, database, clause))
                return P_RESULT_TRUE;
        } else {
            if (p_db_local_clause_assert_last(context, database, clause))
                return P_RESULT_TRUE;
        }
    } else {
        if (at_start) {
            if (p_db_clause_assert_first(context, clause))
                return P_RESULT_TRUE;
        } else {
            if (p_db_clause_assert_last(context, clause))
                return P_RESULT_TRUE;
        }
    }
    pred = p_term_create_functor(context, context->slash_atom, 2);
    if (head->header.type == P_TERM_ATOM) {
        p_term_bind_functor_arg(pred, 0, head);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer(context, 0));
    } else {
        p_term_bind_functor_arg(pred, 0, head->functor.functor_name);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer
                            (context, (int)(head->header.size)));
    }
    *error = p_create_permission_error
        (context, "modify", "static_procedure", pred);
    return P_RESULT_ERROR;
}
static p_goal_result p_builtin_asserta
    (p_context *context, p_term **args, p_term **error)
{
    return p_builtin_assert(context, args, error, 1, 0);
}
static p_goal_result p_builtin_assertz
    (p_context *context, p_term **args, p_term **error)
{
    return p_builtin_assert(context, args, error, 0, 0);
}

static p_goal_result p_builtin_asserta_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *database = p_builtin_verify_database(context, args[1], error);
    if (!database)
        return P_RESULT_ERROR;
    return p_builtin_assert(context, args, error, 1, database);
}
static p_goal_result p_builtin_assertz_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *database = p_builtin_verify_database(context, args[1], error);
    if (!database)
        return P_RESULT_ERROR;
    return p_builtin_assert(context, args, error, 0, database);
}

typedef struct p_exec_clause_fetch_node p_exec_clause_fetch_node;
struct p_exec_clause_fetch_node
{
    p_exec_fail_node parent;
    p_term *head;
    p_term *body;
    p_term_clause_iter clause_iter;
};
/* Find the next matching clause for clause/2 */
static void _p_context_fetch_clause_fail_func
    (p_context *context, p_exec_fail_node *node)
{
    p_exec_clause_fetch_node *current = (p_exec_clause_fetch_node *)node;
    p_term_clause_iter clause_iter = current->clause_iter;
    p_term *clause;
    p_term *body;
    p_exec_node *next;
    p_exec_clause_fetch_node *retry;
    void *marker;
    _p_context_basic_fail_func(context, node);
    while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
        marker = p_context_mark_trail(context);
        body = p_term_unify_clause(context, current->head, clause);
        if (body && p_term_unify(context, current->body, body, P_BIND_DEFAULT)) {
            if (p_term_clauses_has_more(&clause_iter)) {
                next = GC_NEW(p_exec_node);
                retry = GC_NEW(p_exec_clause_fetch_node);
                if (!next || !retry) {
                    current->parent.parent.goal = context->fail_atom;
                    return;
                }
                next->goal = context->true_atom;
                next->success_node = current->parent.parent.success_node;
                next->cut_node = current->parent.parent.cut_node;
                retry->parent.parent.goal = current->parent.parent.goal;
                retry->parent.parent.success_node =
                        current->parent.parent.success_node;
                retry->parent.parent.cut_node =
                        current->parent.parent.cut_node;
                retry->head = current->head;
                retry->body = current->body;
                retry->clause_iter = clause_iter;
                _p_context_init_fail_node
                    (context, &(retry->parent),
                     _p_context_fetch_clause_fail_func);
                retry->parent.fail_marker = marker;
                context->current_node = next;
                context->fail_node = &(retry->parent);
            } else {
                next = GC_NEW(p_exec_node);
                if (next) {
                    next->goal = context->true_atom;
                    next->success_node = current->parent.parent.success_node;
                    next->cut_node = current->parent.parent.cut_node;
                    context->current_node = next;
                } else {
                    current->parent.parent.goal = context->true_atom;
                }
            }
            return;
        }
        p_context_backtrack_trail(context, marker);
    }
    next = GC_NEW(p_exec_node);
    if (next) {
        next->goal = context->fail_atom;
        next->success_node = current->parent.parent.success_node;
        next->cut_node = current->parent.parent.cut_node;
                context->current_node = next;
        context->current_node = next;
    } else {
        current->parent.parent.goal = context->fail_atom;
    }
}

static p_goal_result p_builtin_clause
    (p_context *context, p_term **args, p_term **error)
{
    p_term *head = p_term_deref_member(context, args[0]);
    p_term *name;
    unsigned int arity;
    p_database_info *info;
    p_term *pred;
    p_term_clause_iter clause_iter;
    p_term *clause;
    p_term *body;
    void *marker;
    p_exec_node *current;
    p_exec_node *next;
    p_exec_clause_fetch_node *retry;

    /* Validate the head */
    if (!head || (head->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (head->header.type == P_TERM_ATOM) {
        name = head;
        arity = 0;
    } else if (head->header.type == P_TERM_FUNCTOR) {
        name = head->functor.functor_name;
        arity = head->header.size;
    } else {
        *error = p_create_type_error(context, "callable", head);
        return P_RESULT_ERROR;
    }

    /* Find the predicate associated with the head */
    info = _p_db_find_arity(name, arity);
    if (!info || !info->predicate)
        return P_RESULT_FAIL;

    /* If the predicate is builtin or compiled, then throw an error */
    if (info->flags & (P_PREDICATE_BUILTIN | P_PREDICATE_COMPILED)) {
        pred = p_term_create_functor(context, context->slash_atom, 2);
        p_term_bind_functor_arg(pred, 0, name);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer(context, (int)arity));
        *error = p_create_permission_error
            (context, "access", "private_procedure", pred);
        return P_RESULT_ERROR;
    }

    /* Find the first clause that matches */
    p_term_clauses_begin(info->predicate, head, &clause_iter);
    while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
        marker = p_context_mark_trail(context);
        body = p_term_unify_clause(context, head, clause);
        if (body && p_term_unify(context, args[1], body, P_BIND_DEFAULT)) {
            if (p_term_clauses_has_more(&clause_iter)) {
                current = context->current_node;
                next = GC_NEW(p_exec_node);
                retry = GC_NEW(p_exec_clause_fetch_node);
                if (!next || !retry)
                    return P_RESULT_FAIL;
                next->goal = context->true_atom;
                next->success_node = current->success_node;
                next->cut_node = context->fail_node;
                retry->parent.parent.goal = current->goal;
                retry->parent.parent.success_node =
                        current->success_node;
                retry->parent.parent.cut_node = context->fail_node;
                retry->head = head;
                retry->body = args[1];
                retry->clause_iter = clause_iter;
                _p_context_init_fail_node
                    (context, &(retry->parent),
                     _p_context_fetch_clause_fail_func);
                context->current_node = next;
                context->fail_node = &(retry->parent);
                return P_RESULT_TREE_CHANGE;
            }
            return P_RESULT_TRUE;
        }
        p_context_backtrack_trail(context, marker);
    }
    return P_RESULT_FAIL;
}

static p_goal_result p_builtin_clause_3
    (p_context *context, p_term **args, p_term **error)
{
    p_term *database;
    p_term *head = p_term_deref_member(context, args[0]);
    p_term *name;
    unsigned int arity;
    p_term_clause_iter clause_iter;
    p_term *clause;
    p_term *body;
    p_term *predicate;
    void *marker;
    p_exec_node *current;
    p_exec_node *next;
    p_exec_clause_fetch_node *retry;

    /* Validate the local database */
    database = p_builtin_verify_database(context, args[2], error);
    if (!database)
        return P_RESULT_ERROR;

    /* Validate the head */
    if (!head || (head->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (head->header.type == P_TERM_ATOM) {
        name = head;
        arity = 0;
    } else if (head->header.type == P_TERM_FUNCTOR) {
        name = head->functor.functor_name;
        arity = head->header.size;
    } else {
        *error = p_create_type_error(context, "callable", head);
        return P_RESULT_ERROR;
    }

    /* Find the predicate associated with the head */
    predicate = p_term_database_lookup_predicate
        (database, name, arity);
    if (!predicate)
        return P_RESULT_FAIL;

    /* Find the first clause that matches */
    p_term_clauses_begin(predicate, head, &clause_iter);
    while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
        marker = p_context_mark_trail(context);
        body = p_term_unify_clause(context, head, clause);
        if (body && p_term_unify(context, args[1], body, P_BIND_DEFAULT)) {
            if (p_term_clauses_has_more(&clause_iter)) {
                current = context->current_node;
                next = GC_NEW(p_exec_node);
                retry = GC_NEW(p_exec_clause_fetch_node);
                if (!next || !retry)
                    return P_RESULT_FAIL;
                next->goal = context->true_atom;
                next->success_node = current->success_node;
                next->cut_node = context->fail_node;
                retry->parent.parent.goal = current->goal;
                retry->parent.parent.success_node =
                        current->success_node;
                retry->parent.parent.cut_node = context->fail_node;
                retry->head = head;
                retry->body = args[1];
                retry->clause_iter = clause_iter;
                _p_context_init_fail_node
                    (context, &(retry->parent),
                     _p_context_fetch_clause_fail_func);
                context->current_node = next;
                context->fail_node = &(retry->parent);
                return P_RESULT_TREE_CHANGE;
            }
            return P_RESULT_TRUE;
        }
        p_context_backtrack_trail(context, marker);
    }
    return P_RESULT_FAIL;
}

static p_goal_result p_builtin_new_database
    (p_context *context, p_term **args, p_term **error)
{
    p_term *var = p_term_deref_member(context, args[0]);
    p_term *database;
    if (!var || (var->header.type & P_TERM_VARIABLE) == 0) {
        *error = p_create_type_error(context, "variable", var);
        return P_RESULT_ERROR;
    }
    database = p_term_create_database(context);
    if (p_term_unify(context, var, database, P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_retract
    (p_context *context, p_term **args, p_term **error,
     p_term *database)
{
    p_term *clause = p_term_deref_member(context, args[0]);
    p_term *head;
    p_term *pred;
    int result;
    if (!clause || (clause->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (clause->header.type == P_TERM_FUNCTOR &&
            clause->header.size == 2 &&
            clause->functor.functor_name == context->dcg_atom) {
        /* Expand DCG rules into their normal clause form */
        clause = p_term_expand_dcg(context, clause);
    }
    if (clause->header.type == P_TERM_FUNCTOR &&
            clause->header.size == 2 &&
            clause->functor.functor_name == context->clause_atom) {
        head = p_term_deref_member(context, clause->functor.arg[0]);
    } else {
        head = clause;
        clause = p_term_create_functor
            (context, context->clause_atom, 2);
        p_term_bind_functor_arg(clause, 0, head);
        p_term_bind_functor_arg(clause, 1, context->true_atom);
    }
    if (!head || (head->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (head->header.type != P_TERM_ATOM &&
            head->header.type != P_TERM_FUNCTOR) {
        *error = p_create_type_error(context, "callable", head);
        return P_RESULT_ERROR;
    }
    if (database)
        result = p_db_local_clause_retract(context, database, clause);
    else
        result = p_db_clause_retract(context, clause);
    if (result > 0)
        return P_RESULT_TRUE;
    else if (result < 0)
        return P_RESULT_FAIL;
    pred = p_term_create_functor(context, context->slash_atom, 2);
    if (head->header.type == P_TERM_ATOM) {
        p_term_bind_functor_arg(pred, 0, head);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer(context, 0));
    } else {
        p_term_bind_functor_arg(pred, 0, head->functor.functor_name);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer
                            (context, (int)(head->header.size)));
    }
    *error = p_create_permission_error
        (context, "modify", "static_procedure", pred);
    return P_RESULT_ERROR;
}
static p_goal_result p_builtin_retract_1
    (p_context *context, p_term **args, p_term **error)
{
    return p_builtin_retract(context, args, error, 0);
}

static p_goal_result p_builtin_retract_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *database = p_builtin_verify_database(context, args[1], error);
    if (!database)
        return P_RESULT_ERROR;
    return p_builtin_retract(context, args, error, database);
}

/*\@}*/

/*\@{*/

static p_goal_result p_builtin_consult
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    int result;
    if (!name || (name->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    } else if (name->header.type != P_TERM_ATOM &&
               name->header.type != P_TERM_STRING) {
        *error = p_create_type_error(context, "atom_or_string", name);
        return P_RESULT_ERROR;
    }
    result = p_context_consult_file
        (context, p_term_name(name), P_CONSULT_DEFAULT);
    if (!result) {
        return P_RESULT_TRUE;
    } else if (result != EINVAL) {
        *error = p_create_existence_error(context, "file", name);
        return P_RESULT_ERROR;
    } else {
        return P_RESULT_TRUE;
    }
}

static p_goal_result p_builtin_dynamic
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name;
    int arity;
    p_predicate_flags flags;
    name = p_builtin_parse_indicator(context, args[0], &arity, error);
    if (!name)
        return P_RESULT_ERROR;
    flags = p_db_predicate_flags(context, name, arity);
    if (flags & (P_PREDICATE_COMPILED | P_PREDICATE_BUILTIN)) {
        *error = p_create_permission_error
            (context, "modify", "static_procedure", args[0]);
        return P_RESULT_ERROR;
    }
    p_db_set_predicate_flag
        (context, name, arity, P_PREDICATE_DYNAMIC, 1);
    return P_RESULT_TRUE;
}

/* Defined in parser.y */
int p_context_builtin_import(p_context *context, const char *name);

static p_goal_result p_builtin_import
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    int result;
    if (!name || (name->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    } else if (name->header.type != P_TERM_ATOM &&
               name->header.type != P_TERM_STRING) {
        *error = p_create_type_error(context, "atom_or_string", name);
        return P_RESULT_ERROR;
    }
    result = p_context_builtin_import(context, p_term_name(name));
    if (!result) {
        return P_RESULT_FAIL;
    } else if (result < 0) {
        *error = p_create_existence_error(context, "import", name);
        return P_RESULT_ERROR;
    } else {
        return P_RESULT_TRUE;
    }
}

static p_goal_result p_builtin_load_library
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    if (!name || (name->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (name->header.type != P_TERM_ATOM &&
            name->header.type != P_TERM_STRING) {
        *error = p_create_type_error(context, "atom_or_string", name);
        return P_RESULT_ERROR;
    }
    return _p_context_load_library(context, name, error);
}

/*\@}*/

/*\@{*/

static p_goal_result p_builtin_logical_and
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_node *current = context->current_node;
    p_exec_node *next = GC_NEW(p_exec_node);
    p_exec_node *new_current = GC_NEW(p_exec_node);
    if (!next || !new_current)
        return P_RESULT_FAIL;
    new_current->goal = args[0];
    new_current->success_node = next;
    new_current->cut_node = current->cut_node;
    next->goal = args[1];
    next->success_node = current->success_node;
    next->cut_node = current->cut_node;
    context->current_node = new_current;
    return P_RESULT_TREE_CHANGE;
}

static p_goal_result p_builtin_logical_or
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    p_exec_node *current;
    p_exec_fail_node *retry;
    p_exec_node *commit;
    p_exec_node *then;
    p_exec_node *if_node;
    if (term->header.type == P_TERM_FUNCTOR &&
            term->header.size == 2 &&
            term->functor.functor_name == context->if_atom) {
        /* The term has the form (A -> B || C) */
        current = context->current_node;
        if_node = GC_NEW(p_exec_node);
        retry = GC_NEW(p_exec_fail_node);
        commit = GC_NEW(p_exec_node);
        then = GC_NEW(p_exec_node);
        if (!if_node || !retry || !commit || !then)
            return P_RESULT_FAIL;
        retry->parent.goal = args[1];
        retry->parent.success_node = current->success_node;
        retry->parent.cut_node = context->fail_node;
        _p_context_init_fail_node
            (context, retry, _p_context_basic_fail_func);
        commit->goal = context->commit_atom;
        commit->success_node = then;
        commit->cut_node = context->fail_node;
        then->goal = p_term_arg(term, 1);
        then->success_node = current->success_node;
        then->cut_node = context->fail_node;
        if_node->goal = p_term_arg(term, 0);
        if_node->success_node = commit;
        if_node->cut_node = context->fail_node;
        context->current_node = if_node;
        context->fail_node = retry;
        return P_RESULT_TREE_CHANGE;
    } else {
        /* Regular disjunction */
        current = context->current_node;
        if_node = GC_NEW(p_exec_node);
        retry = GC_NEW(p_exec_fail_node);
        if (!if_node || !retry)
            return P_RESULT_FAIL;
        retry->parent.goal = args[1];
        retry->parent.success_node = current->success_node;
        retry->parent.cut_node = context->fail_node;
        _p_context_init_fail_node
            (context, retry, _p_context_basic_fail_func);
        if_node->goal = term;
        if_node->success_node = current->success_node;
        if_node->cut_node = context->fail_node;
        context->current_node = if_node;
        context->fail_node = retry;
        return P_RESULT_TREE_CHANGE;
    }
}

static char const p_builtin_logical_implies[] =
    "'=>'(A, B)\n"
    "{\n"
    "    if (call(A))\n"
    "        call(B);\n"
    "}\n";

static char const p_builtin_logical_equiv[] =
    "'<=>'(A, B)\n"
    "{\n"
    "    if (call(A))\n"
    "        call((B, commit));\n" // Match once-only call in next line.
    "    else if (call(B))\n"
    "        fail;\n"
    "}\n";

static p_goal_result p_builtin_call
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_node *current = context->current_node;
    p_exec_node *new_current = GC_NEW(p_exec_node);
    if (!new_current)
        return P_RESULT_FAIL;
    new_current->goal = args[0];
    new_current->success_node = current->success_node;
    new_current->cut_node = context->fail_node;
    context->current_node = new_current;
    return P_RESULT_TREE_CHANGE;
}

static p_goal_result p_builtin_call_2
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_node *current = context->current_node;
    p_exec_node *new_current;
    p_exec_pop_database_node *pop_database;
    p_term *database = p_builtin_verify_database(context, args[1], error);
    if (!database)
        return P_RESULT_ERROR;
    new_current = GC_NEW(p_exec_node);
    pop_database = GC_NEW(p_exec_pop_database_node);
    if (!new_current || !pop_database)
        return P_RESULT_FAIL;
    new_current->goal = args[0];
    new_current->success_node = &(pop_database->parent);
    new_current->cut_node = context->fail_node;
    pop_database->parent.goal = context->pop_database_atom;
    pop_database->parent.success_node = current->success_node;
    pop_database->parent.cut_node = context->fail_node;
    pop_database->database = context->database;
    context->current_node = new_current;
    context->database = database;
    return P_RESULT_TREE_CHANGE;
}

/* $$pop_database predicate - pops the current database context
 * when a success continuation occurs */
static p_goal_result p_builtin_pop_database
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_pop_database_node *pop_database;
    pop_database = (p_exec_pop_database_node *)(context->current_node);
    context->database = pop_database->database;
    return P_RESULT_TRUE;
}

int p_builtin_handle_catch(p_context *context, p_term *error)
{
    p_exec_catch_node *catcher = context->catch_node;
    p_term *catch_atom = p_term_create_atom(context, "catch");
    p_term *catch_clause_atom = p_term_create_atom(context, "$$catch");
    p_term *goal;
    while (catcher != 0) {
        _p_context_basic_fail_func(context, &(catcher->parent));
        goal = p_term_deref_member(context, catcher->parent.parent.goal);
        if (goal->functor.functor_name == catch_atom) {
            /* "catch" block */
            if (p_term_unify(context, error,
                             goal->functor.arg[1], P_BIND_DEFAULT)) {
                catcher->parent.parent.goal = goal->functor.arg[2];
                context->current_node = &(catcher->parent.parent);
                context->fail_node = catcher->parent.parent.cut_node;
                context->catch_node = catcher->catch_parent;
                return 1;
            }
        } else {
            /* "try" block */
            p_term *list = p_term_deref_member(context, goal->functor.arg[1]);
            while (list && list->header.type == P_TERM_LIST) {
                p_term *head = p_term_deref_member
                    (context, p_term_head(list));
                if (head->header.type == P_TERM_FUNCTOR &&
                        head->header.size == 2 &&
                        head->functor.functor_name
                                == catch_clause_atom) {
                    if (p_term_unify(context, p_term_arg(head, 0),
                                     error, P_BIND_DEFAULT)) {
                        catcher->parent.parent.goal = p_term_arg(head, 1);
                        context->current_node = &(catcher->parent.parent);
                        context->fail_node = catcher->parent.parent.cut_node;
                        context->catch_node = catcher->catch_parent;
                        return 1;
                    }
                }
                list = p_term_deref_member(context, p_term_tail(list));
            }
        }
        catcher = catcher->catch_parent;
    }
    context->current_node = 0;
    context->fail_node = 0;
    return 0;
}
static p_goal_result p_builtin_catch
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_node *current = context->current_node;
    p_exec_catch_node *catcher = GC_NEW(p_exec_catch_node);
    p_exec_node *new_current = GC_NEW(p_exec_node);
    p_exec_pop_catch_node *pop_catch = GC_NEW(p_exec_pop_catch_node);
    if (!catcher || !new_current || !pop_catch)
        return P_RESULT_FAIL;
    catcher->parent.parent.goal = current->goal;
    catcher->parent.parent.success_node = current->success_node;
    catcher->parent.parent.cut_node = context->fail_node;
    catcher->catch_parent = context->catch_node;
    _p_context_init_fail_node
        (context, &(catcher->parent), _p_context_basic_fail_func);
    new_current->goal = args[0];
    new_current->success_node = &(pop_catch->parent);
    new_current->cut_node = context->fail_node;
    pop_catch->parent.goal = context->pop_catch_atom;
    pop_catch->parent.success_node = current->success_node;
    pop_catch->parent.cut_node = context->fail_node;
    pop_catch->catch_node = context->catch_node;
    context->current_node = new_current;
    context->catch_node = catcher;
    return P_RESULT_TREE_CHANGE;
}

/* $$pop_catch predicate - pops the current catch context
 * when a success continuation occurs */
static p_goal_result p_builtin_pop_catch
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_pop_catch_node *pop_catch;
    pop_catch = (p_exec_pop_catch_node *)(context->current_node);
    context->catch_node = pop_catch->catch_node;
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_commit
    (p_context *context, p_term **args, p_term **error)
{
    context->fail_node = context->current_node->cut_node;
    return P_RESULT_TRUE;
}

static char const p_builtin_do[] =
    "'$$do'(Vars, Body, Cond)\n"
    "{\n"
    "    '$$unbind'(Vars);\n"
    "    call(Body);\n"
    "    commit;\n"
    "    if (call(Cond))\n"
    "        '$$do'(Vars, Body, Cond);\n"
    "}\n"
    "'$$do'(Body, Cond)\n"
    "{\n"
    "    call(Body);\n"
    "    commit;\n"
    "    if (call(Cond))\n"
    "        '$$do'(Body, Cond);\n"
    "}\n";

static char const p_builtin_not_provable[] =
    "'!'(Goal)\n"
    "{\n"
    "    if (call(Goal))\n"
    "        fail;\n"
    "}\n"
    "'\\\\+'(Goal)\n"
    "{\n"
    "    if (call(Goal))\n"
    "        fail;\n"
    "}\n";

static p_goal_result p_builtin_fail
    (p_context *context, p_term **args, p_term **error)
{
    return P_RESULT_FAIL;
}

static p_goal_result p_builtin_set_loop_var
    (p_context *context, p_term **args, p_term **error)
{
    /* We expect the first argument to have the form $$loopvar(X) */
    p_builtin_set_variable(p_term_arg(args[0], 0), args[1]);
    return P_RESULT_TRUE;
}
static char const p_builtin_for[] =
    "'$$for'(Vars, LoopVar, List, Body)\n"
    "{\n"
    "    var(List);\n"
    "    commit;\n"
    "    throw(error(instantiation_error, 'for'/2));\n"
    "}\n"
    "'$$for'(Vars, LoopVar, [], Body)\n"
    "{\n"
    "    commit;\n"
    "}\n"
    "'$$for'(Vars, LoopVar, [H|T], Body)\n"
    "{\n"
    "    commit;\n"
    "    '$$unbind'(Vars);\n"
    "    '$$set_loop_var'(LoopVar, H);\n"
    "    call(Body);\n"
    "    commit;\n"
    "    '$$for'(Vars, LoopVar, T, Body);\n"
    "}\n"
    "'$$for'(Vars, LoopVar, List, Body)\n"
    "{\n"
    "    throw(error(type_error(list, List), 'for'/2));\n"
    "}\n";

static p_goal_result p_builtin_halt_0
    (p_context *context, p_term **args, p_term **error)
{
    *error = p_term_create_integer(context, 0);
    return P_RESULT_HALT;
}

static p_goal_result p_builtin_halt_1
    (p_context *context, p_term **args, p_term **error)
{
    p_term *exitval = p_term_deref_member(context, args[0]);
    if (!exitval || (exitval->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (exitval->header.type != P_TERM_INTEGER) {
        *error = p_create_type_error(context, "integer", exitval);
        return P_RESULT_ERROR;
    }
    *error = exitval;
    return P_RESULT_HALT;
}

static p_goal_result p_builtin_if
    (p_context *context, p_term **args, p_term **error)
{
    p_exec_node *current = context->current_node;
    p_exec_node *commit = GC_NEW(p_exec_node);
    p_exec_node *then = GC_NEW(p_exec_node);
    p_exec_node *if_node = GC_NEW(p_exec_node);
    if (!commit || !then || !if_node)
        return P_RESULT_FAIL;
    commit->goal = context->commit_atom;
    commit->success_node = then;
    commit->cut_node = context->fail_node;
    then->goal = args[1];
    then->success_node = current->success_node;
    then->cut_node = context->fail_node;
    if_node->goal = args[0];
    if_node->success_node = commit;
    if_node->cut_node = context->fail_node;
    context->current_node = if_node;
    return P_RESULT_TREE_CHANGE;
}

static char const p_builtin_in[] =
    "'in'(Term, List)\n"
    "{\n"
    "    var(List);\n"
    "    commit;\n"
    "    throw(error(instantiation_error, 'in'/2));\n"
    "}\n"
    "'in'(Term, [Term|Tail]).\n"
    "'in'(Term, [Head|Tail])\n"
    "{\n"
    "    'in'(Term, Tail);\n"
    "}\n";

static char const p_builtin_once[] =
    "once(Goal) { call((Goal, commit)); }";

static char const p_builtin_repeat[] =
    "repeat() {}"
    "repeat() { repeat(); }";

static char const p_builtin_switch[] =
    "'$$switch'(Value, [], Default)\n"
    "{\n"
    "    commit;\n"
    "    call(Default);\n"
    "}\n"
    "'$$switch'(Value, ['$$case'(Cases, Body)|Tail], Default)\n"
    "{\n"
    "    '$$switch_case_match'(Value, Cases);\n"
    "    commit;\n"
    "    call(Body);\n"
    "}\n"
    "'$$switch'(Value, [Head|Tail], Default)\n"
    "{\n"
    "    '$$switch'(Value, Tail, Default);\n"
    "}\n"
    "'$$switch_case_match'(Value, [])\n"
    "{\n"
    "    commit;\n"
    "    fail;\n"
    "}\n"
    "'$$switch_case_match'(Value, [Value|Tail])\n"
    "{\n"
    "    commit;\n"
    "}\n"
    "'$$switch_case_match'(Value, [Head|Tail])\n"
    "{\n"
    "    '$$switch_case_match'(Value, Tail);\n"
    "}\n";

static p_goal_result p_builtin_throw
    (p_context *context, p_term **args, p_term **error)
{
    *error = p_term_clone(context, args[0]);
    return P_RESULT_ERROR;
}

static p_goal_result p_builtin_true
    (p_context *context, p_term **args, p_term **error)
{
    return P_RESULT_TRUE;
}

static char const p_builtin_while[] =
    "'$$while'(Vars, Cond, Body)\n"
    "{\n"
    "    '$$unbind'(Vars);\n"
    "    if (call(Cond)) {\n"
    "        call(Body);\n"
    "        commit;\n"
    "        '$$while'(Vars, Cond, Body);\n"
    "    }\n"
    "}\n"
    "'$$while'(Cond, Body)\n"
    "{\n"
    "    if (call(Cond)) {\n"
    "        call(Body);\n"
    "        commit;\n"
    "        '$$while'(Cond, Body);\n"
    "    }\n"
    "}\n";

/*\@}*/

/*\@{*/
/* Defined in sort.c */
/*\@}*/

/*\@{*/

static p_goal_result p_builtin_term_eq
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_unify(context, args[0], args[1], P_BIND_EQUALITY))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_term_ne
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_unify(context, args[0], args[1], P_BIND_EQUALITY))
        return P_RESULT_FAIL;
    else
        return P_RESULT_TRUE;
}

static p_goal_result p_builtin_term_lt
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_precedes(context, args[0], args[1]) < 0)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_term_le
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_precedes(context, args[0], args[1]) <= 0)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_term_gt
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_precedes(context, args[0], args[1]) > 0)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_term_ge
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_precedes(context, args[0], args[1]) >= 0)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

/*\@}*/

/*\@{*/

static p_goal_result p_builtin_univ
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    p_term *list = p_term_deref_member(context, args[1]);
    p_term *new_term;
    p_term *functor;
    p_term *member;
    p_term *list_args;
    int index, length;
    if ((term->header.type & P_TERM_VARIABLE) == 0) {
        if (list->header.type != P_TERM_VARIABLE &&
                list->header.type != P_TERM_LIST) {
            *error = p_create_type_error(context, "list", list);
            return P_RESULT_ERROR;
        }
        switch (term->header.type) {
        case P_TERM_ATOM:
        case P_TERM_INTEGER:
        case P_TERM_REAL:
        case P_TERM_STRING:
        case P_TERM_OBJECT:
        case P_TERM_PREDICATE:
        case P_TERM_CLAUSE:
        case P_TERM_DATABASE:
            new_term = p_term_create_list
                (context, term, context->nil_atom);
            break;
        case P_TERM_FUNCTOR:
            new_term = context->nil_atom;
            for (index = (int)(term->header.size - 1); index >= 0; --index) {
                new_term = p_term_create_list
                    (context, term->functor.arg[index], new_term);
            }
            new_term = p_term_create_list
                (context, term->functor.functor_name, new_term);
            break;
        case P_TERM_LIST:
            new_term = p_term_create_list
                (context, context->dot_atom,
                    p_term_create_list
                        (context, term->list.head,
                         p_term_create_list
                            (context, term->list.tail,
                             context->nil_atom)));
            break;
        default: return P_RESULT_FAIL;
        }
        if (p_term_unify(context, list, new_term, P_BIND_DEFAULT))
            return P_RESULT_TRUE;
        else
            return P_RESULT_FAIL;
    } else {
        if (list == context->nil_atom) {
            *error = p_create_domain_error
                (context, "non_empty_list", list);
            return P_RESULT_ERROR;
        }
        if (list->header.type != P_TERM_LIST) {
            *error = p_create_instantiation_error(context);
            return P_RESULT_ERROR;
        }
        length = 1;
        member = p_term_deref_member(context, list->list.tail);
        while (member != context->nil_atom) {
            if (!member || member->header.type != P_TERM_LIST) {
                *error = p_create_instantiation_error(context);
                return P_RESULT_ERROR;
            }
            ++length;
            member = p_term_deref_member(context, member->list.tail);
        }
        functor = p_term_deref_member(context, list->list.head);
        if ((functor->header.type & P_TERM_VARIABLE) != 0) {
            *error = p_create_instantiation_error(context);
            return P_RESULT_ERROR;
        }
        list_args = p_term_deref_member(context, list->list.tail);
        if (length == 1) {
            switch (functor->header.type) {
            case P_TERM_ATOM:
            case P_TERM_INTEGER:
            case P_TERM_REAL:
            case P_TERM_STRING:
            case P_TERM_OBJECT:
            case P_TERM_PREDICATE:
            case P_TERM_CLAUSE:
            case P_TERM_DATABASE:
                new_term = functor;
                break;
            default:
                *error = p_create_type_error
                    (context, "atomic", functor);
                return P_RESULT_ERROR;
            }
        } else if (functor == context->dot_atom && length == 3) {
            new_term = p_term_create_list
                (context, list_args->list.head,
                 p_term_deref_member
                    (context, list_args->list.tail)->list.head);
        } else if (functor->header.type != P_TERM_ATOM) {
            *error = p_create_type_error(context, "atom", functor);
            return P_RESULT_ERROR;
        } else {
            new_term = p_term_create_functor
                (context, functor, length - 1);
            for (index = 0; index < (length - 1); ++index) {
                p_term_bind_functor_arg
                    (new_term, index, list_args->list.head);
                list_args = p_term_deref_member
                    (context, list_args->list.tail);
            }
        }
        if (p_term_unify(context, term, new_term, P_BIND_DEFAULT))
            return P_RESULT_TRUE;
        else
            return P_RESULT_FAIL;
    }
}

static p_goal_result p_builtin_arg
    (p_context *context, p_term **args, p_term **error)
{
    p_term *number = p_term_deref_member(context, args[0]);
    p_term *term = p_term_deref_member(context, args[1]);
    p_term *arg;
    int num;
    if (!number || (number->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (!term || (term->header.type & P_TERM_VARIABLE) != 0) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if (number->header.type != P_TERM_INTEGER) {
        *error = p_create_type_error(context, "integer", number);
        return P_RESULT_ERROR;
    }
    num = p_term_integer_value(number);
    if (num < 0) {
        *error = p_create_domain_error
            (context, "not_less_than_zero", number);
        return P_RESULT_ERROR;
    }
    if (term->header.type == P_TERM_FUNCTOR) {
        if (num > 0 && num <= (int)(term->header.size))
            arg = term->functor.arg[num - 1];
        else
            return P_RESULT_FAIL;
    } else if (term->header.type == P_TERM_LIST) {
        if (num == 1)
            arg = term->list.head;
        else if (num == 2)
            arg = term->list.tail;
        else
            return P_RESULT_FAIL;
    } else {
        *error = p_create_type_error(context, "compound", term);
        return P_RESULT_ERROR;
    }
    if (p_term_unify(context, args[2], arg, P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_copy_term
    (p_context *context, p_term **args, p_term **error)
{
    p_term *renamed = p_term_clone(context, args[0]);
    if (p_term_unify(context, renamed, args[1], P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_functor
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    p_term *name = p_term_deref_member(context, args[1]);
    p_term *arity = p_term_deref_member(context, args[2]);
    p_term *new_term;
    int arity_value, index;
    if (!term || !name || !arity) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if ((term->header.type & P_TERM_VARIABLE) == 0) {
        /* Existing term to be split into name and arity */
        switch (term->header.type) {
        case P_TERM_ATOM:
        case P_TERM_INTEGER:
        case P_TERM_REAL:
        case P_TERM_STRING:
        case P_TERM_OBJECT:
        case P_TERM_PREDICATE:
        case P_TERM_CLAUSE:
        case P_TERM_DATABASE:
            if (!p_term_unify(context, name, term, P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            if (!p_term_unify(context, arity,
                              p_term_create_integer(context, 0),
                              P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            return P_RESULT_TRUE;
        case P_TERM_FUNCTOR:
            if (!p_term_unify(context, name,
                              term->functor.functor_name,
                              P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            if (!p_term_unify(context, arity,
                              p_term_create_integer
                                (context, (int)(term->header.size)),
                              P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            return P_RESULT_TRUE;
        case P_TERM_LIST:
            if (!p_term_unify(context, name, context->dot_atom,
                              P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            if (!p_term_unify(context, arity,
                              p_term_create_integer(context, 2),
                              P_BIND_DEFAULT))
                return P_RESULT_FAIL;
            return P_RESULT_TRUE;
        default: break;
        }
        return P_RESULT_FAIL;
    } else {
        /* Construct a term from name and arity */
        if ((name->header.type & P_TERM_VARIABLE) != 0 ||
                (arity->header.type & P_TERM_VARIABLE) != 0) {
            *error = p_create_instantiation_error(context);
            return P_RESULT_ERROR;
        }
        switch (name->header.type) {
        case P_TERM_ATOM:
        case P_TERM_INTEGER:
        case P_TERM_REAL:
        case P_TERM_STRING:
        case P_TERM_OBJECT:
        case P_TERM_PREDICATE:
        case P_TERM_CLAUSE:
        case P_TERM_DATABASE:
            break;
        default:
            *error = p_create_type_error(context, "atomic", name);
            return P_RESULT_ERROR;
        }
        if (arity->header.type != P_TERM_INTEGER) {
            *error = p_create_type_error(context, "integer", arity);
            return P_RESULT_ERROR;
        }
        arity_value = p_term_integer_value(arity);
        if (arity_value < 0) {
            *error = p_create_domain_error
                (context, "not_less_than_zero", arity);
            return P_RESULT_ERROR;
        }
        if (arity_value == 0) {
            new_term = name;
        } else if (name->header.type != P_TERM_ATOM) {
            *error = p_create_type_error(context, "atom", name);
            return P_RESULT_ERROR;
        } else if (name == context->dot_atom && arity_value == 2) {
            new_term = p_term_create_list
                (context, p_term_create_variable(context),
                 p_term_create_variable(context));
        } else {
            new_term = p_term_create_functor
                (context, name, arity_value);
            for (index = 0; index < arity_value; ++index) {
                p_term_bind_functor_arg
                    (new_term, index, p_term_create_variable(context));
            }
        }
        if (!p_term_unify(context, term, new_term, P_BIND_DEFAULT))
            return P_RESULT_FAIL;
        return P_RESULT_TRUE;
    }
}

/*\@}*/

/*\@{*/

static p_goal_result p_builtin_unify
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_unify(context, args[0], args[1], P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_not_unifiable
    (p_context *context, p_term **args, p_term **error)
{
    void *marker = p_context_mark_trail(context);
    if (p_term_unify(context, args[0], args[1], P_BIND_DEFAULT)) {
        p_context_backtrack_trail(context, marker);
        return P_RESULT_FAIL;
    } else {
        return P_RESULT_TRUE;
    }
}

static p_goal_result p_builtin_unifiable
    (p_context *context, p_term **args, p_term **error)
{
    void *marker = p_context_mark_trail(context);
    if (p_term_unify(context, args[0], args[1], P_BIND_DEFAULT)) {
        p_context_backtrack_trail(context, marker);
        return P_RESULT_TRUE;
    } else {
        return P_RESULT_FAIL;
    }
}

static p_goal_result p_builtin_unifiable_one_way
    (p_context *context, p_term **args, p_term **error)
{
    void *marker = p_context_mark_trail(context);
    if (p_term_unify(context, args[0], args[1], P_BIND_ONE_WAY)) {
        p_context_backtrack_trail(context, marker);
        return P_RESULT_TRUE;
    } else {
        return P_RESULT_FAIL;
    }
}

static p_goal_result p_builtin_unify_one_way
    (p_context *context, p_term **args, p_term **error)
{
    if (p_term_unify(context, args[0], args[1], P_BIND_ONE_WAY))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

/*\@}*/

/*\@{*/

static p_goal_result p_builtin_atom
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_ATOM)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_atomic
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    int type = p_term_type(term);
    if (type == P_TERM_ATOM || type == P_TERM_INTEGER ||
            type == P_TERM_REAL || type == P_TERM_STRING)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_class_1
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_is_class_object(context, term)) {
        return P_RESULT_TRUE;
    } else if (p_term_type(term) == P_TERM_ATOM) {
        p_database_info *db_info = term->atom.db_info;
        if (!db_info || !(db_info->class_info))
            return P_RESULT_FAIL;
        return P_RESULT_TRUE;
    } else {
        return P_RESULT_FAIL;
    }
}

static p_goal_result p_builtin_class_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *name = p_term_deref_member(context, args[0]);
    p_term *class_object = p_term_deref_member(context, args[1]);
    int type = p_term_type(name);
    if (type == P_TERM_ATOM) {
        p_database_info *db_info = name->atom.db_info;
        if (!db_info || !(db_info->class_info))
            return P_RESULT_FAIL;
        if (p_term_unify(context, class_object,
                         db_info->class_info->class_object,
                         P_BIND_DEFAULT))
            return P_RESULT_TRUE;
    } else if ((type & P_TERM_VARIABLE) &&
               p_term_is_class_object(context, class_object)) {
        p_term *class_name = p_term_property
            (context, args[1], p_term_class_name_atom(context));
        if (p_term_unify(context, name, class_name, P_BIND_DEFAULT))
            return P_RESULT_TRUE;
    }
    return P_RESULT_FAIL;
}

static p_goal_result p_builtin_compound
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    int type = p_term_type(term);
    if (type == P_TERM_FUNCTOR || type == P_TERM_LIST)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_database
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_DATABASE)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_float
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_REAL)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_integer
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_INTEGER)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_nonvar
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) & P_TERM_VARIABLE)
        return P_RESULT_FAIL;
    else
        return P_RESULT_TRUE;
}

static p_goal_result p_builtin_number
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    int type = p_term_type(term);
    if (type == P_TERM_INTEGER || type == P_TERM_REAL)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_object_1
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_is_instance_object(context, term))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_object_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    p_term *class_object = p_term_deref_member(context, args[1]);
    if (p_term_type(class_object) == P_TERM_ATOM) {
        p_database_info *db_info = class_object->atom.db_info;
        if (!db_info || !(db_info->class_info))
            return P_RESULT_FAIL;
        class_object = db_info->class_info->class_object;
    }
    if (p_term_is_instance_of(context, term, class_object))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_predicate_1
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_PREDICATE)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_predicate_2
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (!term) {
        *error = p_create_instantiation_error(context);
        return P_RESULT_ERROR;
    }
    if ((term->header.type & P_TERM_VARIABLE) != 0) {
        p_term *name;
        int arity;
        p_database_info *info;
        name = p_builtin_parse_indicator
            (context, args[1], &arity, error);
        if (!name)
            return P_RESULT_ERROR;
        info = _p_db_find_arity(name, arity);
        if (info && info->predicate) {
            if (p_term_unify(context, term, info->predicate,
                             P_BIND_DEFAULT))
                return P_RESULT_TRUE;
        } else if (info && info->builtin_func) {
            /* Create a predicate term for the builtin */
            p_term *pred = p_term_create_predicate
                (context, name, arity);
            info->predicate = pred;
            if (p_term_unify(context, term, pred, P_BIND_DEFAULT))
                return P_RESULT_TRUE;
        }
        return P_RESULT_FAIL;
    } else {
        p_term *pred = p_term_create_functor
            (context, context->slash_atom, 2);
        p_term_bind_functor_arg(pred, 0, term->predicate.name);
        p_term_bind_functor_arg
            (pred, 1, p_term_create_integer
                (context, (int)(term->header.size)));
        if (p_term_unify(context, args[1], pred, P_BIND_DEFAULT))
            return P_RESULT_TRUE;
        else
            return P_RESULT_FAIL;
    }
}

static p_goal_result p_builtin_string
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) == P_TERM_STRING)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

static p_goal_result p_builtin_var
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    if (p_term_type(term) & P_TERM_VARIABLE)
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

/*\@}*/

/*\@{*/

int p_term_occurs_in(const p_term *var, const p_term *value);
p_goal_result p_arith_eval
    (p_context *context, p_arith_value *result,
     p_term *expr, p_term **error);

/* Resolve a variable reference down to its basic form.
 * Returns null if not a variable */
P_INLINE p_term *p_term_resolve_variable(p_context *context, p_term *var)
{
    p_term *value;
    if (!var || var->header.type == P_TERM_VARIABLE)
        return var;
    if (var->header.type != P_TERM_MEMBER_VARIABLE)
        return 0;
    p_term_deref_own_member(context, var);
    value = var->var.value;
    if (value && value->header.type == P_TERM_VARIABLE)
        return value;
    return 0;
}

static p_goal_result p_builtin_assign
    (p_context *context, p_term **args, p_term **error)
{
    p_term *var;
    var = p_term_resolve_variable(context, args[0]);
    if (!var) {
        *error = p_create_type_error(context, "variable", args[0]);
        return P_RESULT_ERROR;
    }
    var->var.value = p_term_clone(context, args[1]);
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_num_assign
    (p_context *context, p_term **args, p_term **error)
{
    p_term *var;
    p_arith_value value;
    p_goal_result result;
    var = p_term_resolve_variable(context, args[0]);
    if (!var) {
        *error = p_create_type_error(context, "variable", args[0]);
        return P_RESULT_ERROR;
    }
    result = p_arith_eval(context, &value, args[1], error);
    if (result != P_RESULT_TRUE)
        return result;
    switch (value.type) {
    case P_TERM_INTEGER:
        var->var.value =
            p_term_create_integer(context, value.integer_value);
        break;
    case P_TERM_REAL:
        var->var.value =
            p_term_create_real(context, value.real_value);
        break;
    case P_TERM_STRING:
        var->var.value = value.string_value;
        break;
    default: return P_RESULT_FAIL;
    }
    return P_RESULT_TRUE;
}

static p_goal_result p_builtin_bt_assign
    (p_context *context, p_term **args, p_term **error)
{
    p_term *var;
    p_term *prev;
    var = p_term_resolve_variable(context, args[0]);
    if (!var) {
        *error = p_create_type_error(context, "variable", args[0]);
        return P_RESULT_ERROR;
    }
    prev = var->var.value;
    var->var.value = 0;
    if (!p_term_occurs_in(var, args[1])) {
        _p_context_record_contents_in_trail
            (context, (void **)&(var->var.value), prev);
        var->var.value = args[1];
        return P_RESULT_TRUE;
    }
    var->var.value = prev;
    return P_RESULT_FAIL;
}

static p_goal_result p_builtin_bt_num_assign
    (p_context *context, p_term **args, p_term **error)
{
    p_term *var;
    p_arith_value value;
    p_goal_result result;
    var = p_term_resolve_variable(context, args[0]);
    if (!var) {
        *error = p_create_type_error(context, "variable", args[0]);
        return P_RESULT_ERROR;
    }
    result = p_arith_eval(context, &value, args[1], error);
    if (result != P_RESULT_TRUE)
        return result;
    _p_context_record_contents_in_trail
        (context, (void **)&(var->var.value), var->var.value);
    switch (value.type) {
    case P_TERM_INTEGER:
        var->var.value =
            p_term_create_integer(context, value.integer_value);
        break;
    case P_TERM_REAL:
        var->var.value =
            p_term_create_real(context, value.real_value);
        break;
    case P_TERM_STRING:
        var->var.value = value.string_value;
        break;
    default: return P_RESULT_FAIL;
    }
    return P_RESULT_TRUE;
}

/*\@}*/

/* $$line(filename, number, goal) encountered in the code */
static p_goal_result p_builtin_line
    (p_context *context, p_term **args, p_term **error)
{
    /* Replace the current goal with the nested goal and retry */
    context->current_node->goal = args[2];
    return P_RESULT_TREE_CHANGE;
}

/* $$unique(Value) to generate a (fairly) unique integer value */
static p_goal_result p_builtin_unique
    (p_context *context, p_term **args, p_term **error)
{
    p_term *value = p_term_create_integer
        (context, (context->unique_num)++);
    if (p_term_unify(context, args[0], value, P_BIND_DEFAULT))
        return P_RESULT_TRUE;
    else
        return P_RESULT_FAIL;
}

/* $$witness(Term, List, Subgoal) helper predicate */
static p_goal_result p_builtin_witness
    (p_context *context, p_term **args, p_term **error)
{
    p_term *term = p_term_deref_member(context, args[0]);
    p_term *subgoal = 0;
    p_term *list = p_term_witness(context, term, &subgoal);
    if (!p_term_unify(context, args[1], list, P_BIND_DEFAULT))
        return P_RESULT_FAIL;
    if (!p_term_unify(context, args[2], subgoal, P_BIND_DEFAULT))
        return P_RESULT_FAIL;
    return P_RESULT_TRUE;
}

void _p_db_init_builtins(p_context *context)
{
    static struct p_builtin const builtins[] = {
        {"=", 2, p_builtin_unify},
        {"!=", 2, p_builtin_not_unifiable},
        {"\\=", 2, p_builtin_not_unifiable},
        {"==", 2, p_builtin_term_eq},
        {"!==", 2, p_builtin_term_ne},
        {"\\==", 2, p_builtin_term_ne},
        {"@<", 2, p_builtin_term_lt},
        {"@<=", 2, p_builtin_term_le},
        {"@=<", 2, p_builtin_term_le},
        {"@>", 2, p_builtin_term_gt},
        {"@>=", 2, p_builtin_term_ge},
        {"!", 0, p_builtin_commit},
        {",", 2, p_builtin_logical_and},
        {"&&", 2, p_builtin_logical_and},
        {"||", 2, p_builtin_logical_or},
        {"->", 2, p_builtin_if},
        {"?-", 1, p_builtin_call},
        {":-", 1, p_builtin_call},
        {"=..", 2, p_builtin_univ},
        {":=", 2, p_builtin_assign},
        {"::=", 2, p_builtin_num_assign},
        {":==", 2, p_builtin_bt_assign},
        {"::==", 2, p_builtin_bt_num_assign},
        {"abolish", 1, p_builtin_abolish},
        {"abolish", 2, p_builtin_abolish_2},
        {"abolish_database", 1, p_builtin_abolish_database},
        {"arg", 3, p_builtin_arg},
        {"asserta", 1, p_builtin_asserta},
        {"asserta", 2, p_builtin_asserta_2},
        {"assertz", 1, p_builtin_assertz},
        {"assertz", 2, p_builtin_assertz_2},
        {"atom", 1, p_builtin_atom},
        {"atomic", 1, p_builtin_atomic},
        {"call", 1, p_builtin_call},
        {"call", 2, p_builtin_call_2},
        {"$$call_member", 2, p_builtin_call_member},
        {"catch", 3, p_builtin_catch},
        {"class", 1, p_builtin_class_1},
        {"class", 2, p_builtin_class_2},
        {"clause", 2, p_builtin_clause},
        {"clause", 3, p_builtin_clause_3},
        {"commit", 0, p_builtin_commit},
        {"compound", 1, p_builtin_compound},
        {"consult", 1, p_builtin_consult},
        {"copy_term", 2, p_builtin_copy_term},
        {"database", 1, p_builtin_database},
        {"dynamic", 1, p_builtin_dynamic},
        {"fail", 0, p_builtin_fail},
        {"false", 0, p_builtin_fail},
        {"float", 1, p_builtin_float},
        {"functor", 3, p_builtin_functor},
        {"halt", 0, p_builtin_halt_0},
        {"halt", 1, p_builtin_halt_1},
        {"import", 1, p_builtin_import},
        {"initialization", 1, p_builtin_call},
        {"integer", 1, p_builtin_integer},
        {"$$line", 3, p_builtin_line},
        {"load_library", 1, p_builtin_load_library},
        {"$$new", 2, p_builtin_new},
        {"new_class", 4, p_builtin_new_class},
        {"new_database", 1, p_builtin_new_database},
        {"new_object", 3, p_builtin_new_object},
        {"nonvar", 1, p_builtin_nonvar},
        {"number", 1, p_builtin_number},
        {"object", 1, p_builtin_object_1},
        {"object", 2, p_builtin_object_2},
        {"$$pop_catch", 0, p_builtin_pop_catch},
        {"$$pop_database", 0, p_builtin_pop_database},
        {"predicate", 1, p_builtin_predicate_1},
        {"predicate", 2, p_builtin_predicate_2},
        {"retract", 1, p_builtin_retract_1},
        {"retract", 2, p_builtin_retract_2},
        {"$$set_loop_var", 2, p_builtin_set_loop_var},
        {"string", 1, p_builtin_string},
        {"throw", 1, p_builtin_throw},
        {"true", 0, p_builtin_true},
        {"$$try", 2, p_builtin_catch},
        {"$$unbind", 1, p_builtin_unbind},
        {"unifiable", 2, p_builtin_unifiable},
        {"unifiable_one_way", 2, p_builtin_unifiable_one_way},
        {"unify_one_way", 2, p_builtin_unify_one_way},
        {"unify_with_occurs_check", 2, p_builtin_unify},
        {"$$unique", 1, p_builtin_unique},
        {"var", 1, p_builtin_var},
        {"$$witness", 3, p_builtin_witness},
        {0, 0, 0}
    };
    static const char * const builtin_sources[] = {
        p_builtin_logical_equiv,
        p_builtin_logical_implies,
        p_builtin_do,
        p_builtin_for,
        p_builtin_in,
        p_builtin_not_provable,
        p_builtin_once,
        p_builtin_repeat,
        p_builtin_switch,
        p_builtin_while,
        0
    };
    _p_db_register_builtins(context, builtins);
    _p_db_register_sources(context, builtin_sources);
}

---