/*			 SM0RGV Forth
 * Copyright 1990 by Anders Klemets, SM0RGV.  Permission granted for
 * non-commercial distribution only.
 */
#include "global.h"
#ifdef FORTH
#include "ctype.h"
#include "mbuf.h"
#include "proc.h"
#include "forth.h"
#include "socket.h"

static void initforth (struct forth **taskp);
static int goforth (struct forth *task);
static int goword (struct forth *task, struct mbuf *bp);
static int pop (struct mbuf **stack, int32 * valp);
static int push (struct mbuf **stack, int32 val);
#ifdef isnumber
#undef isnumber
#endif
static int isnumber (char *word, char base);
static int32 atoi32 (char *word, char base);
static int errnostack (struct forth *task);
static int dodot (struct forth *task);
static int doaritm (struct forth *task);
static int dounary (struct forth *task);
static int dodup (struct forth *task);
static int dodrop (struct forth *task);
static int doover (struct forth *task);
static int doswap (struct forth *task);
static int dorot (struct forth *task);
static int dopick (struct forth *task);
static int dodepth (struct forth *task);
static int dolist (struct forth *task);
static int dobase (struct forth *task);
static int dovariable (struct forth *task);
static int doconstant (struct forth *task);
static char *varcheck (struct forth *task, int32 addr);
static int dofind (struct forth *task);
static int dofetch (struct forth *task);
static int doquestion (struct forth *task);
static int dostore (struct forth *task);
static int dostkmove (struct forth *task);
static int doforget (struct forth *task);
static int docolon (struct forth *task);
static int doprint (struct forth *task);
static int docr (struct forth *task);
static int doemit (struct forth *task);
static int dospaces (struct forth *task);
static int dokey (struct forth *task);
static int doifelse (struct forth *task);
static int doforthnothing (struct forth *task);
static int doforthuntil (struct forth *task);
static int dodo (struct forth *task);
static int doloop (struct forth *task);
static int doload (struct forth *task);
static int dobuffer (struct forth *task);
static int doexpect (struct forth *task);
static int doquit (struct forth *task);

static struct wordlist Vocabulary[] =
{
	{ ".",		dodot,		0 },
	{ ".\"",	doprint,	'"' },
	{ "\"",		doprint,	'"' },
	{ "(",		doforthnothing,	')' },
	{ ":",		docolon,	-1 },
	{ "+",		doaritm,	0 },
	{ "-",		doaritm,	0 },
	{ "*",		doaritm,	0 },
	{ "/",		doaritm,	0 },
	{ "=",		doaritm,	0 },
	{ "<",		doaritm,	0 },
	{ ">",		doaritm,	0 },
	{ "/MOD",	doaritm,	0 },
	{ "MOD",	doaritm,	0 },
	{ "*/MOD",	doaritm,	0 },
	{ "*/",		doaritm,	0 },
	{ "MAX",	doaritm,	0 },
	{ "MIN",	doaritm,	0 },
	{ "AND",	doaritm,	0 },
	{ "OR",		doaritm,	0 },
	{ "XOR",	doaritm,	0 },
	{ "0<",		dounary,	0 },
	{ "0=",		dounary,	0 },
	{ "0>",		dounary,	0 },
	{ "1+",		dounary,	0 },
	{ "1-",		dounary,	0 },
	{ "2+",		dounary,	0 },
	{ "2-",		dounary,	0 },
	{ "ABS",	dounary,	0 },
	{ "NOT",	dounary,	0 },
	{ "NEGATE",	dounary,	0 },
	{ "@",		dofetch,	0 },
	{ "C@",		dofetch,	0 },
	{ "?",		doquestion,	0 },
	{ "!",		dostore,	0 },
	{ "C!",		dostore,	0 },
	{ ">R",		dostkmove,	0 },
	{ "R>",		dostkmove,	0 },
	{ "'",		dofind,		-1 },
	{ "FIND",	dofind,		-1 },
	{ "?DUP",	dodup,		0 },
	{ "DUP",	dodup,		0 },
	{ "DROP",	dodrop,		0 },
	{ "OVER",	doover,		0 },
	{ "SWAP",	doswap,		0 },
	{ "ROT",	dorot,		0 },
	{ "PICK",	dopick,		0 },
	{ "DEPTH",	dodepth,	0 },
	{ "LIST",	dolist,		0 },
	{ "DECIMAL",	dobase,		0 },
	{ "HEX",	dobase,		0 },
	{ "OCTAL",	dobase,		0 },
	{ "VARIABLE",	dovariable,	-1 },
	{ "CONSTANT",	doconstant,	-1 },
	{ "FORGET",	doforget,	-1 },
	{ "IF",		doifelse,	0 },
	{ "ELSE",	doifelse,	0 },
	{ "THEN",	doforthnothing,	0 },
	{ "BEGIN",	doforthnothing,	0 },
	{ "UNTIL",	doforthuntil,	0 },
	{ "END",	doforthuntil,	0 },
	{ "AGAIN",	doforthuntil,	0 },
	{ "WHILE",	doforthuntil,	0 },
	{ "REPEAT",	doforthuntil,	0 },
	{ "DO",		dodo,		0 },
	{ "LOOP",	doloop,		0 },
	{ "+LOOP",	doloop,		0 },
	{ "LEAVE",	doloop,		0 },
	{ "I",		doloop,		0 },
	{ "J",		doloop,		0 },
	{ "CR",		docr,		0 },
	{ "SPACE",	dospaces,	0 },
	{ "SPACES",	dospaces,	0 },
	{ "EMIT",	doemit,		0 },
	{ "KEY",	dokey,		0 },
	{ "LOAD",	doload,		-1 },
	{ "PAD",	dobuffer,	0 },
	{ "BUFFER",	dobuffer,	0 },
	{ "EXPECT",	doexpect,	0 },
	{ "TYPE",	doexpect,	0 },
	{ "QUIT",	doquit,		0 },
	{ NULLCHAR,	NULLFP ((struct forth *)),
					0 }
};


static struct fvars Fixedvars[] =
{
	{ "CLOCK",	FORTH_VARIABLE,	FORTH_READONLY + FORTH_INDIRECT, (int32) & Clock },
	{ "MSPTICK",	FORTH_CONSTANT,	FORTH_READONLY, MSPTICK },
#if 0
	{ "IPADDR",	FORTH_CONSTANT,	FORTH_READONLY, (int32)Ip_addr },
#endif
	{ "BASE",	FORTH_VARIABLE,	FORTH_INDIRECT,	0 },	/* must be last entry */
	{ NULLCHAR,	0,		0, 0 }
};



static const char *synerr = "SYNTAX ERROR\n";



int
doforth (int argc OPTIONAL, char *argv[] OPTIONAL, void *p OPTIONAL)
{
struct forth *task;
int cnt;
char line[1024];
char *cp;

	initforth (&task);
	tprintf ("SM0RGV Forth 1.1 Ready\n");
	for ( ; ; ) {
		if (task->fp != NULLFILE) {
			if (fgets (line, 1024, task->fp) == NULLCHAR) {
				(void) fclose (task->fp);
				task->fp = NULLFILE;
				tprintf ("OK\n");
				continue;
			} else
				cnt = (int) strlen (line);
		} else if ((cnt = recvline (task->s, (unsigned char *) line, 1024)) == 0)
			return 0;
		if (cnt == 1) {	/* an empty line */
			tprintf ("OK\n");
			continue;
		}
		rip (line);	/* remove eol */
		cnt = (int) strlen (line);
		cp = &line[cnt - 1];
		while (cp != line && *cp == ' ')	/* remove trailing blanks */
			*cp-- = '\0';
		/* convert to upper case */
#if 0
		for (i = 0; line[i] != '\0' && i < 1024; ++i)
			if (islower (line[i]))
				line[i] = toupper(line[i]);
#endif
		task->word = line;
		task->final = 0;
		while (*task->word != '\0') {
			if (task->delimiter == ' ')
				while (*task->word == ' ')	/* remove initial blanks */
					++task->word;
			cp = task->word + 1;
			while (*cp != task->delimiter && *cp != '\0')
				++cp;
			if (*cp == '\0')
				task->final = 1;	/* this is the last word */
			else
				*cp = '\0';
			task->delimiter = ' ';
			if (goforth (task) == -1) {
				free_q (&task->stack->next);	/* empty the stacks */
				task->stack->cnt = 0;
				free_q (&task->retstack->next);
				task->retstack->cnt = 0;
				break;
			}
			if (task->final) {
				*task->word = '\0';
				break;
			}
			task->word = cp + 1;
		}
		if (task->vocabulary == NULLBUF) {	/* QUIT executed */
			(void) free_mbuf (task->stack);
			(void) free_mbuf (task->retstack);
			free ((char *) task);
			return 0;
		}
		if (task->nextfkn == NULLFP((struct forth *)) && *task->word == '\0' &&
		    task->fp == NULLFILE)
			tprintf ("OK\n");
	}
}



static void
initforth (struct forth **taskp)
{
struct fvars *fv;

	*taskp = (struct forth *) callocw (1, sizeof (struct forth));

	(*taskp)->s = Curproc->input;
	(*taskp)->delimiter = ' ';
	(*taskp)->goaddr = -1;
	while (((*taskp)->stack = alloc_mbuf (256)) == NULLBUF)
		kwait (NULL);
	while (((*taskp)->retstack = alloc_mbuf (256)) == NULLBUF)
		kwait (NULL);
	while (((*taskp)->pad = alloc_mbuf (256)) == NULLBUF)
		kwait (NULL);
#if 0
	(int32) & (*taskp)->base;
#endif
	(*taskp)->base = 10;
	fv = Fixedvars;
	while (fv->name != NULLCHAR) {
		(*taskp)->word = (char *) fv->name;
		(void) dovariable (*taskp);
		((struct vocentry *) (*taskp)->vocabulary->data)->type = fv->type;
		*((*taskp)->vocabulary->data + sizeof (struct vocentry)) = uchar(FORTH_SYSTEM + fv->options);
		*(int32 *) ((*taskp)->vocabulary->data + 1 + sizeof (struct vocentry)) = fv->value;
		++fv;
	}
	*(int32 *) ((*taskp)->vocabulary->data + 1 + sizeof (struct vocentry))
		=        (int32) & (*taskp)->base;	/* set the BASE variable */
}



static int
goforth (struct forth *task)
{
int ret;
struct wordlist *wp;
struct vocentry *ve;
struct mbuf *bp;

	if (task->nextfkn != NULLFP((struct forth *))) {
		ret = (*task->nextfkn) (task);
		if (--task->args == 0 || ret == -1)
			task->nextfkn = NULLFP((struct forth *));
		return ret;
	}
	for (bp = task->vocabulary; bp != NULLBUF; bp = bp->anext) {
		ve = (struct vocentry *) bp->data;
		if (ve->length == (char) strlen (task->word) &&
		    strnicmp (task->word, ve->name, min (8, (unsigned int) (int) ve->length)) == 0)
			return goword (task, bp);
	}
	wp = Vocabulary;
	while (wp->name != NULLCHAR) {
		if (stricmp (wp->name, task->word) == 0) {
			if (wp->args > 0) {	/* delimiting character */
				/* do nothing if the rest of the line is empty */
				if (!task->final) {
					task->args = 1;
					task->delimiter = wp->args;
					task->nextfkn = wp->fkn;
				}
				return 0;
			}
			if (wp->args < 0) {	/* this word takes arguments */
				if (task->final) {
					tputs ("MISSING ARGUMENT\n");
					return -1;
				} else {
					task->args = -wp->args;
					task->nextfkn = wp->fkn;
					return 0;
				}
			}
			return (*wp->fkn) (task);	/* a normal word */
		}
		wp++;
	}
	if (isnumber (task->word, (char) task->base))
		return push (&task->stack, atoi32 (task->word, (char) task->base));
	tprintf ("%s?\n", task->word);
	return -1;
}



/* execute a word from the local vocabulary */
static int
goword (struct forth *task, struct mbuf *bp)
{
struct vocentry *ve;
char *oldword, *p;
int ret = 0;

	ve = (struct vocentry *) bp->data;
	p = (char *) (ve + 1);
	if (ve->type == FORTH_VARIABLE)
		return push (&task->stack, (int32) (bp->data +
					     sizeof (struct vocentry) + 1));

	if (ve->type == FORTH_CONSTANT) {
		if (*p & FORTH_INDIRECT)
			return push (&task->stack, **(int32 **) (p + 1));
		else
			return push (&task->stack, *(int32 *) (p + 1));
	}
	oldword = task->word;
	task->final = 0;
	/* now handling FORTH_WORD */
	while (*p != FORTH_END) {
		kwait (NULL);
		switch (*p++) {
			case FORTH_LOCALENTRY:
				task->word = ((struct vocentry *) (*(struct mbuf **) p)->data)->name;
				ret = goword (task, *(struct mbuf **) p);
				p += sizeof (struct mbuf *);

				break;
			case FORTH_FIXEDENTRY:
				task->word = (char *) (*(struct wordlist **) p)->name;
				if ((*(struct wordlist **) p)->args != 0)
					task->nextfkn = (*(struct wordlist **) p)->fkn;
				else
					ret = (*(*(struct wordlist **) p)->fkn) (task);
				if (task->goaddr != -1) {	/* a goto facility */
					/* convert the logical address into a "physical" one */
					p = (char *) (ve + 1) + task->goaddr;
					task->goaddr = -1;
				} else
					p += sizeof (struct wordlist *);

				break;
			case FORTH_INT32:
				ret = push (&task->stack, *(int32 *) p);
				p += sizeof (int32);
				break;
			case FORTH_RETSTACK:
				ret = push (&task->retstack, *(int32 *) p);
				p += sizeof (int32);
				break;
			case FORTH_ARGUMENT:
				task->word = *(char **) p;
				ret = (*task->nextfkn) (task);
				p += sizeof (char *);

				break;
			default:
				break;
		}
		if (ret == -1) {
			task->word = oldword;
			return -1;
		}
	}
	task->word = oldword;
	task->nextfkn = NULLFP((struct forth *));	/* in case it had been changed */
	return 0;
}



static int
isnumber (char *word, char base)
{
char *cp;

	cp = word;
	if (*cp == '\0')
		return 0;
	if (*cp == '-' || *cp == '+')
		++cp;
	while (*cp != '\0') {
		if (base <= 10 && (*cp < '0' || *cp > ('0' + base - 1)))
			return 0;
		if (base > 10 && !isdigit (*cp) && (*cp < 'A' || *cp > ('a' + base - 11)
				 || (*cp > ('A' + base - 11) && *cp < 'a')))
			return 0;
		++cp;
	}
	return 1;
}



static int32
atoi32 (char *word, char base)
{
int32 val = 0;
int cnt, factor = 1;
char *p = word;

	if (*p == '-') {
		factor = -1;
		++p;
	} else if (*p == '+')
		++p;
	for (cnt = (int) strlen (p) - 1; cnt >= 0; --cnt) {
		if (isdigit (p[cnt]))
			val += (p[cnt] - '0') * factor;
		else if (isupper (p[cnt]))
			val += (p[cnt] - 'A' + 10) * factor;
		else
			val += (p[cnt] - 'a' + 10) * factor;
		factor *= base;
	}
	return val;
}



static int
errnostack (struct forth *task)
{
	tprintf ("0 %s STACK EMPTY\n", task->word);
	return -1;
}



static int
pop (struct mbuf **stack, int32 *valp)
{
struct mbuf *bp;

	bp = *stack;
	if (bp->cnt == 0)	{
		if (bp->next == NULLBUF)
			return -1;
		else {
			*stack = bp->next;
			(void) free_mbuf (bp);
			bp = *stack;
		}
	}
	*valp = *((int32 *) bp->data + 64 - bp->cnt--);
	return 0;
}



static int 
push (struct mbuf **stack, int32 val)
{
struct mbuf *bp;

	if ((*stack)->cnt == 64) {
		while ((bp = alloc_mbuf (256)) == NULLBUF)
			kwait (NULL);
		bp->next = *stack;		/*lint !e794 */
		*stack = bp;
	}
	*((int32 *) (*stack)->data + 64 - ++(*stack)->cnt) = val;
	return 0;
}



static int
dodot (struct forth *task)
{
char buf[1024], *cp;
int32 val, tmp;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	if (task->base == 10) {	/* special case */
		tprintf ("%ld ", val);
		return 0;
	}
	if (val < 0) {
		tputc ('-');
		val = ~val + 1;		/*lint !e502 */
	}
	cp = buf;
	while (val != 0) {
		tmp = val % task->base;
		if (tmp < 10)
			*cp = (char) ('0' + tmp);
		else
			*cp = (char) ('A' + tmp - 10);
		val /= task->base;
		++cp;
	}
	if (cp != buf) {
		while (--cp >= buf)
			tputc (uchar(*cp));
		tputc (' ');
	} else
		tprintf ("0 ");
	return 0;
}



static int
doaritm (struct forth *task)
{
int32 val1, val2, val3;

	if (pop (&task->stack, &val1) == -1)
		return errnostack (task);
	if (pop (&task->stack, &val2) == -1)
		return errnostack (task);
	switch (task->word[0]) {
		case '+':
			return push (&task->stack, val2 + val1);
		case '-':
			return push (&task->stack, val2 - val1);
		case '*':
			if (task->word[1] == '\0')
				return push (&task->stack, val2 * val1);	/* pure multiplication */
			else {
				if (pop (&task->stack, &val3) == -1)	/* "* /" operation */
					return errnostack (task);
				if (task->word[2] != '\0')	/* "* /MOD" */
					(void) push (&task->stack, val3 * val2 % val1);
				return push (&task->stack, val3 * val2 / val1);
			}
		case '/':
			if (task->word[1] != '\0')
				(void) push (&task->stack, val2 % val1);	/* /MOD operation */
			return push (&task->stack, val2 / val1);	/* pure division */
		case '<':
			return push (&task->stack, val2 < val1);
		case '>':
			return push (&task->stack, val2 > val1);
		case '=':
			return push (&task->stack, val2 == val1);
		case 'M':
		case 'm':
			if (task->word[1] == 'a' || task->word[1] == 'A')	/* MAX */
				return push (&task->stack, max (val2, val1));
			if (task->word[1] == 'i' || task->word[1] == 'I')	/* MIN */
				return push (&task->stack, min (val2, val1));
			return push (&task->stack, val2 % val1);	/* MOD operation */
		case 'a':
		case 'A':
			return push (&task->stack, val2 & val1);
		case 'o':
		case 'O':
			return push (&task->stack, val2 | val1);
		case 'x':
		case 'X':
			return push (&task->stack, val2 ^ val1);
		default:
			break;
	}
	return 0;
}



static int
dounary (struct forth *task)
{
int32 val;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	switch (task->word[0]) {
		case '1':
			if (task->word[1] == '+')
				return push (&task->stack, val + 1);
			return push (&task->stack, val - 1);
		case '0':
		case 'n':
		case 'N':
			if (task->word[1] == '<')
				return push (&task->stack, val < 0);
			if (task->word[1] == '>')
				return push (&task->stack, val > 0);
			if (task->word[1] == 'e' || task->word[1] == 'E')
				return push (&task->stack, -val);	/* NEGATE */
			return push (&task->stack, !val);	/* NOT, 0= */
		case '2':
			if (task->word[1] == '+')
				return push (&task->stack, val + 2);
			return push (&task->stack, val - 2);
		case 'a':
		case 'A':
			return push (&task->stack, val < 0 ? -val : val);	/* ABS */
		default:
			break;
	}
	return 0;
}



static int
dodup (struct forth *task)
{
int32 val;

	if (task->stack->cnt == 0)
		if (task->stack->next == NULLBUF)
			return errnostack (task);
		else
			val = *(int32 *) task->stack->next->data;
	else
		val = *((int32 *) task->stack->data + 64 - task->stack->cnt);
	if (task->word[0] == '?' && val == 0)	/* ?DUP */
		return 0;
	return push (&task->stack, val);
}



static int
dodrop (struct forth *task)
{
int32 val;

	return pop (&task->stack, &val);
}



static int
doover (struct forth *task)
{
struct mbuf *bp;

	if (task->stack->cnt > 1)
		return push (&task->stack, *((int32 *) task->stack->data + 64 + 1 -
					     task->stack->cnt));
	if ((bp = task->stack->next) == NULLBUF)
		return errnostack (task);
	return push (&task->stack, *((int32 *) bp->data + 64 + 1 - task->stack->cnt -
				     bp->cnt));
}



static int
doswap (struct forth *task)
{
int32 val1, val2;

	if (pop (&task->stack, &val1) == -1)
		return errnostack (task);
	if (task->stack->cnt > 0) {
		val2 = *((int32 *) task->stack->data + 64 - task->stack->cnt);
		*((int32 *) task->stack->data + 64 - task->stack->cnt) = val1;
	} else {
		if (task->stack->next == NULLBUF)
			return errnostack (task);
		val2 = *(int32 *) task->stack->next->data;
		*(int32 *) task->stack->next->data = val1;
	}
	return push (&task->stack, val2);
}



static int
dorot (struct forth *task)
{
int32 val1, val2, val3;

	if (pop (&task->stack, &val1) == -1)
		return errnostack (task);
	if (pop (&task->stack, &val2) == -1)
		return errnostack (task);
	if (task->stack->cnt > 0) {
		val3 = *((int32 *) task->stack->data + 64 - task->stack->cnt);
		*((int32 *) task->stack->data + 64 - task->stack->cnt) = val2;
	} else {
		if (task->stack->next == NULLBUF)
			return errnostack (task);
		val3 = *(int32 *) task->stack->next->data;
		*(int32 *) task->stack->next->data = val2;
	}
	(void) push (&task->stack, val1);
	return push (&task->stack, val3);
}



static int
dopick (struct forth *task)
{
struct mbuf *bp;
int32 val;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	if (val > 0) {
		bp = task->stack;
		while (bp != NULLBUF && bp->cnt < val) {
			val -= bp->cnt;
			bp = bp->next;
		}
		if (bp != NULLBUF)
			return push (&task->stack, *((int32 *) bp->data + 64 - 1 + val
						     - bp->cnt));
	}
	return errnostack (task);
}



static int
dodepth (struct forth *task)
{
	return push (&task->stack, (int32) len_p (task->stack));
}



static int
dolist (struct forth *task)
{
int cnt = 0;
struct wordlist *wp;
struct vocentry *ve;
struct mbuf *bp;

	bp = task->vocabulary;
	while (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		tprintf ("%-8s", ve->name);
		bp = bp->anext;
		++cnt;
		if (cnt % 8 == 0)
			tprintf ("\n");
		else
			tprintf ("  ");
	}
	wp = Vocabulary;
	while (wp->name != NULLCHAR) {
		tprintf ("%-8s", wp->name);
		cnt++;
		if (cnt % 8 == 0)
			tprintf ("\n");
		else
			tprintf ("  ");
		wp++;
	}
	if (cnt % 8 != 0)
		tprintf ("\n");
	return 0;
}



static int
dobase (struct forth *task)
{
	switch (task->word[0]) {
		case 'D':
		case 'd':
			task->base = 10;
			break;
		case 'H':
		case 'h':
			task->base = 16;
			break;
		default:
			task->base = 8;
	}
	return 0;
}



static int
dovariable (struct forth *task)
{
struct vocentry *ve;
struct mbuf *bp;

	while ((bp = alloc_mbuf (sizeof (struct vocentry) + 1 + sizeof (int32))) == NULLBUF)
		kwait (NULL);

	if (bp == NULLBUF)	/* shouldn't happen - to satisfy lint */
		return 0;
	bp->cnt = bp->size;
	ve = (struct vocentry *) bp->data;
	ve->type = FORTH_VARIABLE;
	ve->length = (char) strlen (task->word);
	if (ve->length < 9)
		strcpy (ve->name, task->word);
	else {
		strncpy (ve->name, task->word, 8);
		ve->name[8] = '\0';
	}
	*(bp->data + sizeof (struct vocentry)) = FORTH_NORMAL;

	/* the variable is initialized to zero */
	*(int32 *) (bp->data + sizeof (struct vocentry) + 1) = 0;

	bp->anext = task->vocabulary;
	task->vocabulary = bp;
	return 0;
}



static int
doconstant (struct forth *task)
{
int32 val;
struct vocentry *ve;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	(void) dovariable (task);
	ve = (struct vocentry *) task->vocabulary->data;
	ve->type = FORTH_CONSTANT;
	*(int32 *) (task->vocabulary->data + sizeof (struct vocentry) + 1) = val;

	return 0;
}



/* check if the value on the stack is a pointer to a variable or a constant,
 * and if so return a pointer to the begining of the data area that keeps
 * the object.
 */
static char *
varcheck (struct forth *task, int32 addr)
{
struct mbuf *bp;
struct vocentry *ve;

	bp = task->vocabulary;
	while (bp != NULLBUF)	/* integrity check */
		if (addr >= (int32) (bp->data + sizeof (struct vocentry) + 1) && addr <
		             (int32) (bp->data + sizeof (struct vocentry) + 1 + sizeof (int32)))
			         break;

		else
			bp = bp->anext;
	if (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		if (ve->type != FORTH_VARIABLE && ve->type != FORTH_CONSTANT) {
			tprintf ("WRONG KIND OF OBJECT\n");
			return NULLCHAR;
		}
		return (char *) (bp->data + sizeof (struct vocentry));
	}
	/* try to see if the address is to a buffer */
	bp = task->pad;
	while (bp != NULLBUF)
		if (addr >= (int32) (bp->data + 1) && addr <= (int32) & bp->data[255])
			return (char *) bp->data;
		else
			bp = bp->anext;
	tprintf ("INVALID ARGUMENT\n");
	return NULLCHAR;
}



static int
dofind (struct forth *task)
{
struct mbuf *bp;
struct vocentry *ve;
struct wordlist *wp;

	bp = task->vocabulary;
	while (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		if (ve->length == (char) strlen (task->word) &&
		  strnicmp (ve->name, task->word, (unsigned int) (int) min (ve->length, 8)) == 0)
			return push (&task->stack, (int32) (bp->data +
					     sizeof (struct vocentry) + 1));

		bp = bp->anext;
	}
	wp = Vocabulary;
	while (wp->name != NULLCHAR) {
		if (stricmp (wp->name, task->word) == 0)
			return push (&task->stack, (int32) wp);
		++wp;
	}
	tprintf ("%s?\n", task->word);
	return -1;
}



static int
dofetch (struct forth *task)
{
int32 addr, val;
char *p;

	if (pop (&task->stack, &addr) == -1)
		return errnostack (task);
	if ((p = varcheck (task, addr)) == NULLCHAR)
		return -1;
	if (task->word[1] != '\0') {	/* C@ */
		if (*p & FORTH_INDIRECT)
			val = *(*(char **) (p + 1) + addr - (int) (p + 1));
		else
			val = *(char *) addr;
	} else {
		if ((p = varcheck (task, addr + (int32) sizeof (int32) - 1)) == NULLCHAR)
			return -1;
		if (*p & FORTH_INDIRECT)
			val = *(*(int32 **) (p + 1) + addr - (int) (p + 1));
		else
			val = *(int32 *) addr;
	}
	return push (&task->stack, val);
}



static int
doquestion (struct forth *task)
{
	if (dofetch (task) == -1)
		return -1;
	return dodot (task);
}



static int
dostore (struct forth *task)
{
char *p;
int32 addr, val;

	if (pop (&task->stack, &addr) == -1)
		return errnostack (task);
	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	if ((p = varcheck (task, addr)) == NULLCHAR)
		return -1;
	if (*p & FORTH_READONLY) {
		tprintf ("WRITE PROTECTED ADDRESS\n");
		return -1;
	}
	if (task->word[1] != '\0') {	/* C! word */
		if (*p & FORTH_INDIRECT)
			*(*(char **) (p + 1) + addr - (int) (p + 1)) = (char) val;
		else
			*(char *) addr = (char) val;
	} else {
		if ((p = varcheck (task, addr + (int32) sizeof (int32) - 1)) == NULLCHAR)	/* ! */
			return -1;
		if (*p & FORTH_INDIRECT)
			*(*(int32 **) (p + 1) + addr - (int) (p + 1)) = val;
		else
			*(int32 *) addr = val;
	}
	return 0;
}



static int
dostkmove (struct forth *task)
{
int32 val;

	if (task->word[0] == '>') {	/* >R */
		if (pop (&task->stack, &val) == -1)
			return errnostack (task);
		return push (&task->retstack, val);
	}
	if (pop (&task->retstack, &val) == -1)	/* R> */
		return errnostack (task);
	return push (&task->stack, val);
}



static int
doforget (struct forth *task)
{
struct mbuf *bp, *bp2, *bp3;
char c, *p;
int noway = 0;
struct wordlist *wp;
struct vocentry *ve;

	bp = task->vocabulary;
	while (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		if (ve->type == FORTH_VARIABLE || ve->type == FORTH_CONSTANT)
			if (*(bp->data + sizeof (struct vocentry)) != FORTH_NORMAL)
				         noway = 1;

		if (ve->length == (char) strlen (task->word) &&
		  strnicmp (ve->name, task->word, (unsigned int) (int) min (ve->length, 8)) == 0)
			break;
		bp = bp->anext;
	}
	if (noway) {
		tprintf ("CANNOT FORGET %s\n", task->word);
		return -1;
	}
	if (bp == NULLBUF) {	/* no match */
		for (wp = Vocabulary; wp->name != NULLCHAR; ++wp)
			if (stricmp (wp->name, task->word) == 0) {
				tprintf ("CANNOT FORGET %s\n", wp->name);
				return -1;
			}
		tprintf ("%s?\n", task->word);
		return -1;
	}
	bp2 = bp->anext;
	bp->anext = NULLBUF;
	bp = task->vocabulary;
	/* the list must be searched for FORTH_ARGUMENT entries,
	 * since they have pointers to areas that must be freed.
	 */
	while (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		if (ve->type != FORTH_WORD) {
			bp = free_p (bp);
			continue;
		}
		bp3 = bp->anext;
		(void) pullup (&bp, (unsigned char *)0, sizeof (struct vocentry));

		c = (char) pullchar (&bp);
		while (c != FORTH_END) {
			switch (c) {
				case FORTH_LOCALENTRY:
					(void) pullup (&bp, (unsigned char *)0, sizeof (struct mbuf *));

					break;
				case FORTH_FIXEDENTRY:
					(void) pullup (&bp, (unsigned char *)0, sizeof (struct wordlist *));

					break;
				case FORTH_INT32:
				case FORTH_RETSTACK:
					(void) pullup (&bp, (unsigned char *)0, sizeof (int32));
					break;
				case FORTH_ARGUMENT:
					(void) pullup (&bp, (unsigned char *) &p, sizeof (char *));

					free (p);
					break;
				default:
					break;
			}
			c = (char) pullchar (&bp);
		}
		free_p (bp);	/* in case there's something left */
		bp = bp3;
	}
	task->vocabulary = bp2;
	return 0;
}



static int
docolon (struct forth *task)
{
char *cp;
struct mbuf *bp;
struct wordlist *wp;
struct vocentry *ve;
int32 val;

	if (task->fc == (struct fcompiler *) 0) {
		task->fc = (struct fcompiler *) mallocw (sizeof (struct fcompiler));

		task->fc->arg = 0;
		task->fc->first = 1;
		task->fc->base = (char) task->base;
		task->fc->p = task->fc->buf;
	}
	if (task->final && strcmp (task->word, ";") == 0) {
		*task->fc->p++ = FORTH_END;
		while ((bp = alloc_mbuf ((int16) (sizeof (task->fc->v) + task->fc->p -
					 task->fc->buf))) == NULLBUF)
			kwait (NULL);
		if (bp == NULLBUF)
			return 0;
		bp->cnt = bp->size;
		memcpy (bp->data, (char *) &task->fc->v, sizeof (task->fc->v));
		memcpy (bp->data + sizeof (task->fc->v), task->fc->buf,
			(unsigned int) (task->fc->p - task->fc->buf));
		free ((char *) task->fc);
		bp->anext = task->vocabulary;
		task->vocabulary = bp;
		return 0;
	} else
		++task->args;
	if (task->fc->first) {	/* set the name */
		task->fc->v.type = FORTH_WORD;
		task->fc->v.length = (char) strlen (task->word);
		if (task->fc->v.length < 9)
			strcpy (task->fc->v.name, task->word);
		else {
			strncpy (task->fc->v.name, task->word, 8);
			task->fc->v.name[8] = '\0';
		}
		task->fc->first = 0;
		return 0;
	}
	if (task->fc->arg == 0) {	/* we are expecting no arguments */
		bp = task->vocabulary;
		while (bp != NULLBUF) {
			ve = (struct vocentry *) bp->data;
			if (ve->length == (char) strlen (task->word) &&
			    strnicmp (ve->name, task->word, min (8, (unsigned int) (int) ve->length)) == 0) {
				*task->fc->p++ = FORTH_LOCALENTRY;
				*(struct mbuf **) task->fc->p = bp;
				task->fc->p += sizeof (bp);
				return 0;
			}
			bp = bp->anext;
		}
		wp = Vocabulary;
		while (wp->name != NULLCHAR) {
			if (stricmp (wp->name, task->word) == 0) {
				/* treat some special cases */
				if (stricmp (wp->name, "DO") == 0) {
					*task->fc->p++ = FORTH_RETSTACK;
					*(int32 *) task->fc->p = (int32) sizeof (int32) + (int32) sizeof (wp)
						+ 1 + (int32) (task->fc->p - task->fc->buf);
					task->fc->p += sizeof (int32);
				}
				if (stricmp (wp->name, "BEGIN") == 0) {
					*task->fc->p++ = FORTH_RETSTACK;
					*(int32 *) task->fc->p = (int32) (task->fc->p - 1 -
							     task->fc->buf);
					task->fc->p += sizeof (int32);
					return 0;
				}
				if (stricmp (wp->name, "WHILE") == 0) {
					*task->fc->p++ = FORTH_RETSTACK;
					(void) push (&task->retstack, (int32) task->fc->p);
					task->fc->p += sizeof (int32);
				}
				if (stricmp (wp->name, "REPEAT") == 0) {
					if (pop (&task->retstack, &val) == -1) {
						tputs (synerr);
						free ((char *) task->fc);
						return -1;
					}
					*(int32 *) val = (int32) (task->fc->p - task->fc->buf)
						+ 1 + (int32) sizeof (wp);
				}
				if (stricmp (wp->name, "IF") == 0) {
					*task->fc->p++ = FORTH_RETSTACK;
					(void) push (&task->retstack, (int32) task->fc->p);
					task->fc->p += sizeof (int32);
					*task->fc->p++ = FORTH_RETSTACK;
					(void) push (&task->retstack, (int32) task->fc->p);
					task->fc->p += sizeof (int32);
					(void) push (&task->retstack, 0);
				}
				if (stricmp (wp->name, "ELSE") == 0 ||
				    stricmp (wp->name, "THEN") == 0) {
					if (pop (&task->retstack, &val) == -1) {
						tputs (synerr);
						free ((char *) task->fc);
						return -1;
					}
					if (stricmp (wp->name, "THEN") == 0) {
						if (val == 0) {	/* there was no ELSE word */
							if (pop (&task->retstack, &val) == -1) {
								tputs (synerr);
								free ((char *) task->fc);
								return -1;
							}
							val = -1;	/* signal no ELSE */
							if (pop (&task->retstack, &val) == -1) {
								tputs (synerr);
								free ((char *) task->fc);
								return -1;
							}
						}
					} else if (pop (&task->retstack, &val) == -1) {
						tputs (synerr);
						free ((char *) task->fc);
						return -1;
					}
					val = (int32) (task->fc->p - task->fc->buf)
						+ 1 + (int32) sizeof (wp);
				}
				*task->fc->p++ = FORTH_FIXEDENTRY;
				*(struct wordlist **) task->fc->p = wp;
				task->fc->p += sizeof (wp);
				if (wp->args < 0) {	/* this word takes arguments */
					task->fc->arg = -wp->args;
					return 0;
				}
				/* a string is delivered as one single word */
				if (wp->args > 0) {
					task->delimiter = wp->args;
					task->fc->arg = 1;
					return 0;
				}
				/* some special cases */
				if (stricmp (wp->name, "DECIMAL") == 0)
					task->fc->base = 10;
				else if (stricmp (wp->name, "HEX") == 0)
					task->fc->base = 16;
				else if (stricmp (wp->name, "OCTAL") == 0)
					task->fc->base = 8;
				return 0;
			}
			wp++;
		}
		if (isnumber (task->word, task->fc->base)) {
			*task->fc->p++ = FORTH_INT32;
			*(int32 *) task->fc->p = atoi32 (task->word, task->fc->base);
			task->fc->p += sizeof (int32);
			return 0;
		}
		tprintf ("%s?\n", task->word);	/* no match */
		task->args = 1;
		free ((char *) task->fc);
		return -1;
	} else {		/* this word is an argument */
		cp = mallocw (strlen (task->word) + 1);
		strcpy (cp, task->word);
		*task->fc->p++ = FORTH_ARGUMENT;
		*(char **) task->fc->p = cp;
		task->fc->p += sizeof (cp);
		task->fc->arg--;
	}
	return 0;
}



static int
doprint (struct forth *task)
{
	tputs (task->word);
	return 0;
}



static int
docr (struct forth *task OPTIONAL)
{
	tputc ('\n');
	return 0;
}



static int
doemit (struct forth *task)
{
int32 val;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	tputc ((unsigned char) val);
	return 0;
}



static int
dospaces (struct forth *task)
{
int32 val;

	if (strlen (task->word) == 5)
		val = 1;
	else if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	while (val--)
		tputc (' ');
	return 0;
}



static int
dokey (struct forth *task)
{
int32 val;

	if ((val = recvchar (task->s)) == EOF)
		return -1;
	return push (&task->stack, val);
}



static int
doifelse (struct forth *task)
{
int32 offset, val;

	if (pop (&task->retstack, &offset) == -1)
		return errnostack (task);
	if (task->word[0] == 'i' || task->word[0] == 'I') {	/* IF word */
		if (pop (&task->stack, &val) == -1)
			return errnostack (task);
		if (val == 0) {
			task->goaddr = offset;	/* jump past the ELSE word */
			if (pop (&task->retstack, &offset) == -1)	/* the THEN offset */
				return errnostack (task);
			if (task->goaddr == -1)	/* there is no ELSE word */
				task->goaddr = offset;	/* go directly past THEN */
		}
	} else			/* ELSE word */
		task->goaddr = offset;	/* jump past the THEN word */
	return 0;
}



static int
doforthnothing (struct forth *task OPTIONAL)
{
	return 0;
}



static int
doforthuntil (struct forth *task)
{
int32 val, offset;

	if (pop (&task->retstack, &offset) == -1)
		return errnostack (task);
	if (task->word[0] == 'a' || task->word[0] == 'A' ||
	    task->word[0] == 'r' || task->word[0] == 'R')	/* AGAIN, REPEAT */
		task->goaddr = offset;
	else {			/* UNTIL, END, WHILE */
		if (pop (&task->stack, &val) == -1)
			return errnostack (task);
		if (val == 0)
			task->goaddr = offset;
	}
	return 0;
}



static int
dodo (struct forth *task)
{
int32 val1, val2;

	if (pop (&task->stack, &val1) == -1)
		return errnostack (task);
	if (pop (&task->stack, &val2) == -1)
		return errnostack (task);
	(void) push (&task->retstack, val2);
	return push (&task->retstack, val1);
}



static int
doloop (struct forth *task)
{
int32 i, j, fin, step = 1, offset;

	if (task->word[0] == '+')
		if (pop (&task->stack, &step) == -1)
			return errnostack (task);
	if (pop (&task->retstack, &i) == -1)
		return errnostack (task);
	if (task->word[0] == 'i' || task->word[0] == 'I') {	/* I */
		(void) push (&task->retstack, i);
		return push (&task->stack, i);
	}
	if (pop (&task->retstack, &fin) == -1)
		return errnostack (task);
	if (task->word[1] == 'e' || task->word[1] == 'E') {	/* LEAVE */
		fin = i;
		(void) push (&task->retstack, fin);
		return push (&task->retstack, i);
	}
	if (pop (&task->retstack, &offset) == -1)
		return errnostack (task);
	if (task->word[0] == 'j' || task->word[0] == 'J') {	/* J */
		if (pop (&task->retstack, &j) == -1)
			return errnostack (task);
		(void) push (&task->retstack, j);
		(void) push (&task->retstack, offset);
		(void) push (&task->retstack, fin);
		(void) push (&task->retstack, i);
		return push (&task->stack, j);
	}
	i += step;		/* LOOP, +LOOP */
	if (i >= fin)
		return 0;
	task->goaddr = offset;
	(void) push (&task->retstack, offset);
	(void) push (&task->retstack, fin);
	return push (&task->retstack, i);
}



/* load FORTH words from a file */
static int
doload (struct forth *task)
{
	if ((task->fp = fopen (task->word, READ_TEXT)) == NULLFILE) {
		tprintf ("CANNOT OPEN %s\n", task->word);
		return -1;
	}
	return 0;
}



static int
doquit (struct forth *task)
{
struct mbuf *bp, *bprev;
char buf[9];
struct vocentry *ve;

	bp = task->vocabulary;
	bprev = NULLBUF;
	while (bp != NULLBUF) {
		ve = (struct vocentry *) bp->data;
		if ((ve->type == FORTH_VARIABLE || ve->type == FORTH_CONSTANT) &&
		    *(bp->data + sizeof (struct vocentry)) != FORTH_NORMAL)
			         break;

		bprev = bp;
		bp = bp->anext;
	}
	if (bprev != NULLBUF) {
		ve = (struct vocentry *) bprev->data;
		task->final = 0;
		task->word = buf;
		strcpy (buf, ve->name);
		(void) doforget (task);
	}
	free_q (&task->vocabulary);
	if (task->fp != NULLFILE)
		(void) fclose (task->fp);
	free_q (&task->pad);
	return -1;
}



/* "n BUFFER addr" where addr is the address of buffer #n. If the buffer
 * is non-existent, but buffer no #n-1 exists, a new buffer is allocated,
 * otherwise an error message is printed. The PAD area is buffer #1.
 */
static int
dobuffer (struct forth *task)
{
struct mbuf *bp;
int32 val, cnt = 1;

	if (task->word[0] == 'P' || task->word[0] == 'p')	/* PAD word */
		val = 1;
	else if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	bp = task->pad;
	while (bp != NULLBUF) {
		if (cnt++ == val)
			return push (&task->stack, (int32) (bp->data + 1));
		bp = bp->anext;
	}
	if (cnt == val) {
		while ((bp = alloc_mbuf (256)) == NULLBUF)
			kwait (NULL);
		if (bp == NULLBUF)
			return -1;
		*bp->data = FORTH_NORMAL;
		enqueue (&task->pad, bp);
		return push (&task->stack, (int32) (bp->data + 1));
	}
	tprintf ("NO SUCH BUFFER\n");
	return -1;
}

static int
doexpect (struct forth *task)
{
int32 val, addr;
int cnt;
char *p;

	if (pop (&task->stack, &val) == -1)
		return errnostack (task);
	if (pop (&task->stack, &addr) == -1)
		return errnostack (task);
	if ((p = varcheck (task, addr)) == NULLCHAR)
		return -1;
	if (*p & FORTH_READONLY) {
		tprintf ("WRITE PROTECTED ADDRESS\n");
		return -1;
	}
	if (varcheck (task, addr + val - 1) == NULLCHAR)
		return -1;
	if (*p & FORTH_INDIRECT)
		p = (char *) (*(int32 **) (p + 1)) + addr - (int) (p + 1);
	else
		p = (char *) addr;
	if (task->word[0] == 'E' || task->word[0] == 'e') {	/* EXPECT */
		(void) recvline (task->s, (unsigned char *) p, (int16) val);
#if 0
		rip (addr);
#else
		rip (p);
#endif
	} else
		for (cnt = 0; cnt < val; ++cnt)	/* TYPE */
			tputc (uchar(p[cnt]));
	return 0;
}

#endif /* FORTH */
