/******************************************************************************

			UNSW Prolog (version 4)

			Written by Claude Sammut
		     Department of Computer Science
		     University of New South Wales
		   (and St. Joseph's U., Philadelphia)

		   Copyright (c)  1983 - Claude Sammut

******************************************************************************/





/*		predicates for manipulating clauses			*/


#include "pred.h"

extern binding *stack;
extern short sp;
extern integer *stack_int;

static
definition PREDICATE
{
	register clause *rval;
	register binding *rframe;
	extern run;

	if (TYPE(arg[0]) != ATOM)
		fail("Definition - first argument must be an atom")
	if (TYPE(arg[1]) != VAR)
		fail("Definition - second argument must be unbound")
	if ((rval = VAL(arg[0])) == 0)
		return(FALSE);
	rframe = &stack[sp];
	clear_frame(rval -> nvars);
	bind(arg[1], frame[1], rval, rframe);
	return(TRUE);
}


static
next_clause PREDICATE
{
	register clause *rval;
	register binding *rframe;

	if (TYPE(arg[0]) != CLAUSE)
		fail("Next_clause - first argument must be a clause")
	if (TYPE(arg[1]) != VAR)
		fail("Next_clause - second argument must be unbound")
	if ((rval = arg[0] -> g.rest) == 0)
		return(FALSE);
	rframe = &stack[sp];
	clear_frame(rval -> nvars);
	bind(arg[1], frame[1], rval, rframe);
	return(TRUE);
}

static
head PREDICATE
{
	if (TYPE(arg[0]) != CLAUSE)
		fail("Head - first argument must be a clause")
	return(unify(arg[0] -> g.goal[0], frame[0], arg[1], frame[1]));
}


extern atom *_true, *_comma;
extern var _1, _2;

static
struct {
	itemtype type;
	card size;
	atom *fun;
	var *left, *right;
} _conjunction =
{
	FN,
	2,
	0,
	&_1,
	&_2
};

static
body PREDICATE
{
	extern binding *stack;
	extern short sp;
	register pval *b;
	register binding *s, *s1, *s2;

	if (TYPE(arg[0]) != CLAUSE)
		fail("Body - first argument must be a clause")
	_conjunction.fun = _comma;
	b = &(arg[0] -> g.goal[1]);
	if (*b == 0)
		return(unify(arg[1], frame[1], _true, 0));
	if (*(b + 1) == 0)
		return(unify(arg[1], frame[1], *b, frame[0]));
	s = &stack[sp];
	clear_frame(2);
	s1 = s;
	s1[0].termv = *b++;
	s1[0].framev = frame[0];
	while (*(b + 1))
	{
		s2 = &stack[sp];
		clear_frame(2);
		s1[1].termv = (pval) (&_conjunction);
		s1[1].framev = s2;
		s2[0].termv = *b++;
		s2[0].framev = frame[0];
		s1 = s2;
	}
	s1[1].termv = *b;
	s1[1].framev = frame[0];
	return(unify(arg[1], frame[1], &_conjunction, s));
}


static
unl_clause PREDICATE
{
	pval head, p_name;
	register clause **p;

	if (TYPE(arg[0]) != CLAUSE)
		fail("$unlink - argument must be clause")
	head = arg[0] -> g.goal[0];
	if (isatom(head)) p_name = head;
	else p_name = head -> c.term[0];
	p = &VAL(p_name);
	while (*p)
	{
		if (*p == (clause *) arg[0])
		{
			*p = (*p) -> rest;
			return(TRUE);
		}
		else p = &((*p) -> rest);
	}
	fail("$unlink - clause not found")
}


static
p_free PREDICATE
{
	if (isvariable(arg[0]))
		fail("Cannot free unbound term")
	free_term(arg[0]);
	return(TRUE);
}

static
p_free_proc PREDICATE
{
	if (isatom(arg[0]))
	{
		free_proc(VAL(arg[0]));
		VAL(arg[0]) = 0;
		return(TRUE);
	}
	fail("Free proc - argument must be an atom")
}



static
remob PREDICATE
{
	extern atom *hashtable[];
	atom **p;

	if (isatom(arg[0]))
	{
		p = &hashtable[hash(NAME(arg[0]))];
		while (*p)
		{
			if (*p == (atom *) arg[0])
			{
				*p =  (*p) -> link;
				return(TRUE);
			}
			else p = &((*p) -> link);
		}
		fail("Remob - atom not found")
	}
	else fail("Remob - argument must be an atom")
}


atom_table p_clause =
{
	SET_PRED(NONOP, 0, 1, "unlink_clause", unl_clause),
	SET_PRED(NONOP, 0, 1, "free", p_free),
	SET_PRED(NONOP, 0, 1, "free_proc", p_free_proc),
	SET_PRED(NONOP, 0, 1, "remob", remob),
	SET_PRED(NONOP, 0, 2, "head", head),
	SET_PRED(NONOP, 0, 2, "body", body),
	SET_PRED(NONOP, 0, 2, "definition", definition),
	SET_PRED(NONOP, 0, 2, "next_clause", next_clause),
	END_MARK
};