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

			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

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





	/*	Predicated to modify Prolog's behaviour		*/


#include "pred.h"
#include <setjmp.h>


static
p_abort PREDICATE
{
	extern jmp_buf env3;

	longjmp(env3, 1);
}


static
p_halt PREDICATE
{
	exit();
}

static
p_prompt PREDICATE
{
	extern pval termb;
	extern atom *read_prompt, *prompt_string;

	if (unify(arg[0], frame[0], read_prompt, 0))
	{
		if (isatom(arg[1]))
		{
			prompt_string = read_prompt = (atom *) arg[1];
			return(TRUE);
		}
		else if (arg[0] == arg[1]) return(TRUE);
		fail("Prompt - second argument must be atom")
	}
	return(FALSE);
}

static
trace PREDICATE
{
	if (isatom(arg[0]))
	{
		arg[0] -> a.traced = TRUE;
		return(TRUE);
	}
	else fail("Cannot trace non-atom!")
}

static
untrace PREDICATE
{
	if (isatom(arg[0]))
	{
		arg[0] -> a.traced = FALSE;
		return(TRUE);
	}
	else fail("Tried to untrace non-atom")
}


static char *ops[] = {"xfx", "xfy", "yfx", "fx", "fy", "xf", "yf"};

static
optype atopt(buff)
char *buff;
{
	register i;

	for (i = XFX; i <= YF; i++)
		if (strcmp(ops[i], buff) == 0) return(i);
	return(-1);
}

static
insert_op(a, precedence, type)
atom *a;
short precedence;
char type;
{
	extern atom* hashtable[];
	register atom *p, **q;

	/*	new define must appear BEFORE existing definition in	*/
	/*	hash bucket. NONOP's must be last in chain.		*/

	for (q = &(hashtable[hash(NAME(a))]); *q != a; q = &((*q) -> link));
	p = (atom *) new(ATOM);
	p -> link = a;
	*q = p;
	p -> name = a -> name;
	p -> pred = precedence;
	p -> op_t = type;
}

static
define_op PREDICATE
{
	extern integer *stack_int;
	optype dtype;
	pval p;

	if (! isatom(arg[2]))
		fail("defop: 3rd argument must be atom")
	if (arg[2] -> a.op_t != NONOP)
	{
		p = (pval) intern(ATOM, ops[arg[2] -> a.op_t],
				strlen(ops[arg[2] -> a.op_t]));
		return(unify(arg[0], frame[0], stack_int, arg[2] -> a.pred)
		    && unify(arg[1], frame[1], p, 0));
	}
	if (! isinteger(arg[0]) || ! isatom(arg[1]))
		return(FALSE);
	if ((dtype = atopt(NAME(arg[1]))) == -1)
		fail("Defop - bad operator type")

	p = arg[2];
	if (((dtype == FX || dtype == FY) && prefix(&p))
	||  ((dtype == XFX || dtype == XFY || dtype == YFX) && infix(&p))
	||  ((dtype == XF || dtype == YF) && postfix(&p)))
	{
		p -> a.op_t = INT_VAL(0);
		return(TRUE);
	}
	else insert_op(p, INT_VAL(0), dtype);
	return(TRUE);
}


static
statistics PREDICATE
{
	trace_stack();
	return(TRUE);
}


do_time PREDICATE
{
	extern int do_timing;

	do_timing = ! do_timing;
}

static
dump PREDICATE
{
	dump_stack();
	dump_env();
}


atom_table p_behave =
{
	SET_PRED(NONOP, 0, 3, "defop", define_op),
	SET_PRED(FX, 700, 1, "spy", trace),
	SET_PRED(FX, 700, 1, "unspy", untrace),
	SET_PRED(NONOP, 0, 2, "prompt", p_prompt),
	SET_PRED(NONOP, 0, 0, "abort", p_abort),
	SET_PRED(NONOP, 0, 0, "halt", p_halt),
	SET_PRED(NONOP, 0, 0, "time", do_time),
	SET_PRED(NONOP, 0, 0, "dump", dump),
	SET_PRED(NONOP, 0, 0, "statistics", statistics),
	END_MARK
};