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

			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

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





/*		built-in predicates for simple I/O			*/


#include "pred.h"
#include "in.h"


extern int bind(), unbind(), isbound(), prin(), _prin();

extern FILE *output;
extern chartype chtype[];
extern integer *stack_int;



static
p_write PREDICATE
{
	prin(arg[0],1200, frame[0]);
	return(TRUE);
}


static
p_getc PREDICATE
{
	pval rval;
	extern pval inchar();

	rval = inchar();
	if (isvariable(arg[0]))
	{
		bind(arg[0], frame[0], rval, 0);
		return(TRUE);
	}
	else return(arg[0] == rval);
}


static
p_skip PREDICATE
{
	register ch;

	if (isatom(arg[0]))
	{
		ch = NAME(arg[0])[0];
		while (ch != readch)
			if (feof(input)) return(FALSE);
		return(TRUE);
	}
	else fail("Skip - argument must be atom")
}

static
ratom PREDICATE
{
	pval rval;
	extern int readatom;
	extern pval getatom();

	readatom = TRUE;
	rval = getatom();
	readatom = FALSE;
	if (isvariable(arg[0]))
	{
		bind(arg[0], frame[0], rval, 0);
		return(TRUE);
	}
	else return(arg[0] == rval);
}



static
p_read PREDICATE
{
	extern pval expression();
	extern int pushed_back;
	extern atom *_dot, *_rpren;
	extern int p_read_on;
	register pval p, expr;

	p_read_on = TRUE;
	p = expression(_rpren);
	p_read_on = FALSE;
	if (p -> c.term[0] == (pval) _dot)
	{
		expr = p -> c.term[1];
		p -> c.term[1] = 0;
		free_term(p);
	}
	else expr = p;
	if (feof(input)) pushed_back = -1;
	return(unify(arg[0], frame[0], expr, frame[0]));
}

static
message NPREDICATE
{
	register int i = 0;

	for (i = 0; i < argc; i++)
	{
		if (TYPE(arg[i]) == STRING)
			fprintf(output, "%s", NAME(arg[i]));
		else
			prin(arg[i], 1200, frame[i]);
	}
	return(TRUE);
}

static
mess_ln NPREDICATE
{
	message(arg, frame, argc);
	putc('\n', output);
	return(TRUE);
}

list_proc PREDICATE
{
	clause *clist;
	int i;
	extern run;
	extern FILE *output;

	if (TYPE(arg[0]) != ATOM) return(FALSE);
	run = FALSE;
	putc('\n', output);
	for (clist = VAL(arg[0]); clist != 0; clist = clist -> rest)
	{
		_prin(clist -> goal[0],1200);
		if (clist -> goal[1])
		{
			if (clist -> goal[2]) fprintf(output, " :-\n\t");
			else fprintf(output, " :- ");
			for (i = 1; clist -> goal[i + 1]; i++)
			{
				_prin(clist -> goal[i], 999);
				fprintf(output, ",\n\t");
			}
			_prin(clist -> goal[i], 999);
		}
		fprintf(output, ".\n");
	}
	run = TRUE;
	return(TRUE);
}


listing PREDICATE
{
	register i;
	atom *p;
	extern atom *hashtable[];

	for (i = 0; i < HASHSIZE; i++)
	{
		p = hashtable[i];
		while (p)
		{
			if (! p -> lib && p -> val) list_proc(&p);
			p = p -> link;
		}
	}
}




static
p_putc PREDICATE
{
	if (! isatom(arg[0]))
		fail("Putc - argument must be an atom")
	putc(NAME(arg[0])[0], output);
	return(TRUE);
}


static
ascii PREDICATE
{
	register i;
	char buf[2];

	if (isatom(arg[0]))
		if (isinteger(arg[1]))
			return(((int) NAME(arg[0])[0]) == INT_VAL(1));
		else if (variable(arg[1]))
		{
			bind_num(1, ((int) NAME(arg[0])[0]));
			return(TRUE);
		}
		else fail("Ascii - bad argument")
	else if (variable(arg[0]))
		if (isinteger(arg[1]))
		{
			i = INT_VAL(1);
			if (i < 0 || i > 127)
				fail("Ascii - number out of range")
			buf[0] = (char) i;
			buf[1] = 0;
			bind(arg[0], frame[0], intern(ATOM, buf, 2), 0, isfunny((char)	i));
			return(TRUE);
		}
	else fail("Ascii - bad argument")
}


static
tab PREDICATE
{
	extern arith_failure;
	register i;

	i = arith(arg[0], frame[0]);
	if (arith_failure)
	{
		warning("Tab - argument must be arithmetic expression");
		return(FALSE);
	}
	while (i--) putc(' ', output);
	return(TRUE);
}


static
newline PREDICATE
{
	putc('\n', output); return(TRUE);
}




atom_table p_IO =
{
	SET_PRED(NONOP, 0, 1, "write", p_write),
	SET_PRED(NONOP, 0, 1, "getc", p_getc),
	SET_PRED(NONOP, 0, 1, "skip", p_skip),
	SET_PRED(NONOP, 0, 1, "putc", p_putc),
	SET_PRED(NONOP, 0, 2, "ascii", ascii),
	SET_PRED(NONOP, 0, 1, "tab", tab),
	SET_PRED(NONOP, 0, 1, "ratom", ratom),
	SET_PRED(NONOP, 0, 1, "read", p_read),
	SET_PRED(NONOP, 0, NPRED, "prin", message),
	SET_PRED(NONOP, 0, NPRED, "print", mess_ln),
	SET_PRED(FX, 700, 1, "pp", list_proc),
	SET_PRED(NONOP, 0, 0, "listing", listing),
	SET_PRED(NONOP, 0, 0, "nl", newline),
	END_MARK
};
