xref: /freebsd/stand/ficl/words.c (revision 2a63c3be158216222d89a073dcbd6a72ee4aab5a)

/*******************************************************************
** w o r d s . c
** Forth Inspired Command Language
** ANS Forth CORE word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
** All rights reserved.
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
** I am interested in hearing from anyone who uses ficl. If you have
** a problem, a success story, a defect, an enhancement request, or
** if you would like to contribute to the ficl release, please
** contact me by email at the address above.
**
** L I C E N S E  and  D I S C L A I M E R
**
** Redistribution and use in source and binary forms, with or without
** modification, are permitted provided that the following conditions
** are met:
** 1. Redistributions of source code must retain the above copyright
**    notice, this list of conditions and the following disclaimer.
** 2. Redistributions in binary form must reproduce the above copyright
**    notice, this list of conditions and the following disclaimer in the
**    documentation and/or other materials provided with the distribution.
**
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
** SUCH DAMAGE.
*/


#ifdef TESTMAIN
#include <stdlib.h>
#include <stdio.h>
#include <ctype.h>
#include <fcntl.h>
#else
#include <stand.h>
#endif
#include <string.h>
#include "ficl.h"
#include "math64.h"

static void colonParen(FICL_VM *pVM);
static void literalIm(FICL_VM *pVM);
static int  ficlParseWord(FICL_VM *pVM, STRINGINFO si);

/*
** Control structure building words use these
** strings' addresses as markers on the stack to
** check for structure completion.
*/
static char doTag[]    = "do";
static char colonTag[] = "colon";
static char leaveTag[] = "leave";

static char destTag[]  = "target";
static char origTag[]  = "origin";

static char caseTag[]  = "case";
static char ofTag[]  = "of";
static char fallthroughTag[]  = "fallthrough";

#if FICL_WANT_LOCALS
static void doLocalIm(FICL_VM *pVM);
static void do2LocalIm(FICL_VM *pVM);
#endif


/*
** C O N T R O L   S T R U C T U R E   B U I L D E R S
**
** Push current dict location for later branch resolution.
** The location may be either a branch target or a patch address...
*/
static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
{
    PUSHPTR(dp->here);
    PUSHPTR(tag);
    return;
}

static void markControlTag(FICL_VM *pVM, char *tag)
{
    PUSHPTR(tag);
    return;
}

static void matchControlTag(FICL_VM *pVM, char *tag)
{
    char *cp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    cp = (char *)stackPopPtr(pVM->pStack);
    /*
    ** Changed the code below to compare the pointers first (by popular demand)
    */
    if ( (cp != tag) && strcmp(cp, tag) )
    {
        vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
    }

    return;
}

/*
** Expect a branch target address on the param stack,
** compile a literal offset from the current dict location
** to the target address
*/
static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
{
    FICL_INT offset;
    CELL *patchAddr;

    matchControlTag(pVM, tag);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    patchAddr = (CELL *)stackPopPtr(pVM->pStack);
    offset = patchAddr - dp->here;
    dictAppendCell(dp, LVALUEtoCELL(offset));

    return;
}


/*
** Expect a branch patch address on the param stack,
** compile a literal offset from the patch location
** to the current dict location
*/
static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
{
    FICL_INT offset;
    CELL *patchAddr;

    matchControlTag(pVM, tag);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    patchAddr = (CELL *)stackPopPtr(pVM->pStack);
    offset = dp->here - patchAddr;
    *patchAddr = LVALUEtoCELL(offset);

    return;
}

/*
** Match the tag to the top of the stack. If success,
** sopy "here" address into the cell whose address is next
** on the stack. Used by do..leave..loop.
*/
static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
{
    CELL *patchAddr;
    char *cp;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    cp = stackPopPtr(pVM->pStack);
    /*
    ** Changed the comparison below to compare the pointers first (by popular demand)
    */
    if ((cp != tag) && strcmp(cp, tag))
    {
        vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
        vmTextOut(pVM, tag, 1);
    }

    patchAddr = (CELL *)stackPopPtr(pVM->pStack);
    *patchAddr = LVALUEtoCELL(dp->here);

    return;
}


/**************************************************************************
                        f i c l P a r s e N u m b e r
** Attempts to convert the NULL terminated string in the VM's pad to
** a number using the VM's current base. If successful, pushes the number
** onto the param stack and returns TRUE. Otherwise, returns FALSE.
** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
** the standard for DOUBLE wordset.
**************************************************************************/

int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
{
    FICL_INT accum  = 0;
    char isNeg      = FALSE;
	char hasDP      = FALSE;
    unsigned base   = pVM->base;
    char *cp        = SI_PTR(si);
    FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
    unsigned ch;
    unsigned digit;

    if (count > 1)
    {
        switch (*cp)
        {
        case '-':
            cp++;
            count--;
            isNeg = TRUE;
            break;
        case '+':
            cp++;
            count--;
            isNeg = FALSE;
            break;
        default:
            break;
        }
    }

    if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
    {
        hasDP = TRUE;
        count--;
    }

    if (count == 0)        /* detect "+", "-", ".", "+." etc */
        return FALSE;

    while ((count--) && ((ch = *cp++) != '\0'))
    {
        if (!isalnum(ch))
            return FALSE;

        digit = ch - '0';

        if (digit > 9)
            digit = tolower(ch) - 'a' + 10;

        if (digit >= base)
            return FALSE;

        accum = accum * base + digit;
    }

	if (hasDP)		/* simple (required) DOUBLE support */
		PUSHINT(0);

    if (isNeg)
        accum = -accum;

    PUSHINT(accum);
    if (pVM->state == COMPILE)
        literalIm(pVM);

    return TRUE;
}


/**************************************************************************
                        a d d   &   f r i e n d s
**
**************************************************************************/

static void add(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    i = stackPopINT(pVM->pStack);
    i += stackGetTop(pVM->pStack).i;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void sub(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    i = stackPopINT(pVM->pStack);
    i = stackGetTop(pVM->pStack).i - i;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void mul(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    i = stackPopINT(pVM->pStack);
    i *= stackGetTop(pVM->pStack).i;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void negate(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    i = -stackPopINT(pVM->pStack);
    PUSHINT(i);
    return;
}

static void ficlDiv(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    i = stackPopINT(pVM->pStack);
    i = stackGetTop(pVM->pStack).i / i;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

/*
** slash-mod        CORE ( n1 n2 -- n3 n4 )
** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
** differ in sign, the implementation-defined result returned will be the
** same as that returned by either the phrase
** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
** NOTE: Ficl complies with the second phrase (symmetric division)
*/
static void slashMod(FICL_VM *pVM)
{
    DPINT n1;
    FICL_INT n2;
    INTQR qr;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 2);
#endif
    n2    = stackPopINT(pVM->pStack);
    n1.lo = stackPopINT(pVM->pStack);
    i64Extend(n1);

    qr = m64SymmetricDivI(n1, n2);
    PUSHINT(qr.rem);
    PUSHINT(qr.quot);
    return;
}

static void onePlus(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    i = stackGetTop(pVM->pStack).i;
    i += 1;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void oneMinus(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    i = stackGetTop(pVM->pStack).i;
    i -= 1;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void twoMul(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    i = stackGetTop(pVM->pStack).i;
    i *= 2;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void twoDiv(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    i = stackGetTop(pVM->pStack).i;
    i >>= 1;
    stackSetTop(pVM->pStack, LVALUEtoCELL(i));
    return;
}

static void mulDiv(FICL_VM *pVM)
{
    FICL_INT x, y, z;
    DPINT prod;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 3, 1);
#endif
    z = stackPopINT(pVM->pStack);
    y = stackPopINT(pVM->pStack);
    x = stackPopINT(pVM->pStack);

    prod = m64MulI(x,y);
    x    = m64SymmetricDivI(prod, z).quot;

    PUSHINT(x);
    return;
}


static void mulDivRem(FICL_VM *pVM)
{
    FICL_INT x, y, z;
    DPINT prod;
    INTQR qr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 3, 2);
#endif
    z = stackPopINT(pVM->pStack);
    y = stackPopINT(pVM->pStack);
    x = stackPopINT(pVM->pStack);

    prod = m64MulI(x,y);
    qr   = m64SymmetricDivI(prod, z);

    PUSHINT(qr.rem);
    PUSHINT(qr.quot);
    return;
}


/**************************************************************************
                        c o l o n   d e f i n i t i o n s
** Code to begin compiling a colon definition
** This function sets the state to COMPILE, then creates a
** new word whose name is the next word in the input stream
** and whose code is colonParen.
**************************************************************************/

static void colon(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);

    dictCheckThreshold(dp);

    pVM->state = COMPILE;
    markControlTag(pVM, colonTag);
    dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
#if FICL_WANT_LOCALS
    pVM->pSys->nLocals = 0;
#endif
    return;
}


/**************************************************************************
                        c o l o n P a r e n
** This is the code that executes a colon definition. It assumes that the
** virtual machine is running a "next" loop (See the vm.c
** for its implementation of member function vmExecute()). The colon
** code simply copies the address of the first word in the list of words
** to interpret into IP after saving its old value. When we return to the
** "next" loop, the virtual machine will call the code for each word in
** turn.
**
**************************************************************************/

static void colonParen(FICL_VM *pVM)
{
    IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
    vmPushIP(pVM, tempIP);

    return;
}


/**************************************************************************
                        s e m i c o l o n C o I m
**
** IMMEDIATE code for ";". This function sets the state to INTERPRET and
** terminates a word under compilation by appending code for "(;)" to
** the definition. TO DO: checks for leftover branch target tags on the
** return stack and complains if any are found.
**************************************************************************/
static void semiParen(FICL_VM *pVM)
{
    vmPopIP(pVM);
    return;
}


static void semicolonCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pSemiParen);
    matchControlTag(pVM, colonTag);

#if FICL_WANT_LOCALS
    assert(pVM->pSys->pUnLinkParen);
    if (pVM->pSys->nLocals > 0)
    {
        FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
        dictEmpty(pLoc, pLoc->pForthWords->size);
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
    }
    pVM->pSys->nLocals = 0;
#endif

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
    pVM->state = INTERPRET;
    dictUnsmudge(dp);
    return;
}


/**************************************************************************
                        e x i t
** CORE
** This function simply pops the previous instruction
** pointer and returns to the "next" loop. Used for exiting from within
** a definition. Note that exitParen is identical to semiParen - they
** are in two different functions so that "see" can correctly identify
** the end of a colon definition, even if it uses "exit".
**************************************************************************/
static void exitParen(FICL_VM *pVM)
{
    vmPopIP(pVM);
    return;
}

static void exitCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    assert(pVM->pSys->pExitParen);
    IGNORE(pVM);

#if FICL_WANT_LOCALS
    if (pVM->pSys->nLocals > 0)
    {
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
    }
#endif
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
    return;
}


/**************************************************************************
                        c o n s t a n t P a r e n
** This is the run-time code for "constant". It simply returns the
** contents of its word's first data cell.
**
**************************************************************************/

void constantParen(FICL_VM *pVM)
{
    FICL_WORD *pFW = pVM->runningWord;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif
    stackPush(pVM->pStack, pFW->param[0]);
    return;
}

void twoConstParen(FICL_VM *pVM)
{
    FICL_WORD *pFW = pVM->runningWord;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif
    stackPush(pVM->pStack, pFW->param[0]); /* lo */
    stackPush(pVM->pStack, pFW->param[1]); /* hi */
    return;
}


/**************************************************************************
                        c o n s t a n t
** IMMEDIATE
** Compiles a constant into the dictionary. Constants return their
** value when invoked. Expects a value on top of the parm stack.
**************************************************************************/

static void constant(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
    dictAppendCell(dp, stackPop(pVM->pStack));
    return;
}


static void twoConstant(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);
    CELL c;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    c = stackPop(pVM->pStack);
    dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
    dictAppendCell(dp, stackPop(pVM->pStack));
    dictAppendCell(dp, c);
    return;
}


/**************************************************************************
                        d i s p l a y C e l l
** Drop and print the contents of the cell at the top of the param
** stack
**************************************************************************/

static void displayCell(FICL_VM *pVM)
{
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    c = stackPop(pVM->pStack);
    ltoa((c).i, pVM->pad, pVM->base);
    strcat(pVM->pad, " ");
    vmTextOut(pVM, pVM->pad, 0);
    return;
}

static void uDot(FICL_VM *pVM)
{
    FICL_UNS u;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    u = stackPopUNS(pVM->pStack);
    ultoa(u, pVM->pad, pVM->base);
    strcat(pVM->pad, " ");
    vmTextOut(pVM, pVM->pad, 0);
    return;
}


static void hexDot(FICL_VM *pVM)
{
    FICL_UNS u;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    u = stackPopUNS(pVM->pStack);
    ultoa(u, pVM->pad, 16);
    strcat(pVM->pad, " ");
    vmTextOut(pVM, pVM->pad, 0);
    return;
}


/**************************************************************************
                        s t r l e n
** FICL   ( c-string -- length )
**
** Returns the length of a C-style (zero-terminated) string.
**
** --lch
**/
static void ficlStrlen(FICL_VM *ficlVM)
	{
	char *address = (char *)stackPopPtr(ficlVM->pStack);
	stackPushINT(ficlVM->pStack, strlen(address));
	}


/**************************************************************************
                        s p r i n t f
** FICL   ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
** Similar to the C sprintf() function.  It formats into a buffer based on
** a "format" string.  Each character in the format string is copied verbatim
** to the output buffer, until SPRINTF encounters a percent sign ("%").
** SPRINTF then skips the percent sign, and examines the next character
** (the "format character").  Here are the valid format characters:
**    s - read a C-ADDR U-LENGTH string from the stack and copy it to
**        the buffer
**    d - read a cell from the stack, format it as a string (base-10,
**        signed), and copy it to the buffer
**    x - same as d, except in base-16
**    u - same as d, but unsigned
**    % - output a literal percent-sign to the buffer
** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
** written, and a flag indicating whether or not it ran out of space while
** writing to the output buffer (TRUE if it ran out of space).
**
** If SPRINTF runs out of space in the buffer to store the formatted string,
** it still continues parsing, in an effort to preserve your stack (otherwise
** it might leave uneaten arguments behind).
**
** --lch
**************************************************************************/
static void ficlSprintf(FICL_VM *pVM) /*  */
{
	int bufferLength = stackPopINT(pVM->pStack);
	char *buffer = (char *)stackPopPtr(pVM->pStack);
	char *bufferStart = buffer;

	int formatLength = stackPopINT(pVM->pStack);
	char *format = (char *)stackPopPtr(pVM->pStack);
	char *formatStop = format + formatLength;

	int base = 10;
	int unsignedInteger = FALSE;

	FICL_INT append = FICL_TRUE;

	while (format < formatStop)
	{
		char scratch[64];
		char *source;
		int actualLength;
		int desiredLength;
		int leadingZeroes;


		if (*format != '%')
		{
			source = format;
			actualLength = desiredLength = 1;
			leadingZeroes = 0;
		}
		else
		{
			format++;
			if (format == formatStop)
				break;

			leadingZeroes = (*format == '0');
			if (leadingZeroes)
				{
				format++;
				if (format == formatStop)
					break;
				}

			desiredLength = isdigit(*format);
			if (desiredLength)
				{
				desiredLength = strtol(format, &format, 10);
				if (format == formatStop)
					break;
				}
			else if (*format == '*')
				{
				desiredLength = stackPopINT(pVM->pStack);
				format++;
				if (format == formatStop)
					break;
				}


			switch (*format)
			{
				case 's':
				case 'S':
				{
					actualLength = stackPopINT(pVM->pStack);
					source = (char *)stackPopPtr(pVM->pStack);
					break;
				}
				case 'x':
				case 'X':
					base = 16;
				case 'u':
				case 'U':
					unsignedInteger = TRUE;
				case 'd':
				case 'D':
				{
					int integer = stackPopINT(pVM->pStack);
					if (unsignedInteger)
						ultoa(integer, scratch, base);
					else
						ltoa(integer, scratch, base);
					base = 10;
					unsignedInteger = FALSE;
					source = scratch;
					actualLength = strlen(scratch);
					break;
				}
				case '%':
					source = format;
					actualLength = 1;
				default:
					continue;
			}
		}

		if (append != FICL_FALSE)
		{
			if (!desiredLength)
				desiredLength = actualLength;
			if (desiredLength > bufferLength)
			{
				append = FICL_FALSE;
				desiredLength = bufferLength;
			}
			while (desiredLength > actualLength)
				{
				*buffer++ = (char)((leadingZeroes) ? '0' : ' ');
				bufferLength--;
				desiredLength--;
				}
			memcpy(buffer, source, actualLength);
			buffer += actualLength;
			bufferLength -= actualLength;
		}

		format++;
	}

	stackPushPtr(pVM->pStack, bufferStart);
	stackPushINT(pVM->pStack, buffer - bufferStart);
	stackPushINT(pVM->pStack, append);
}


/**************************************************************************
                        d u p   &   f r i e n d s
**
**************************************************************************/

static void depth(FICL_VM *pVM)
{
    int i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif
    i = stackDepth(pVM->pStack);
    PUSHINT(i);
    return;
}


static void drop(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    stackDrop(pVM->pStack, 1);
    return;
}


static void twoDrop(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    stackDrop(pVM->pStack, 2);
    return;
}


static void dup(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 2);
#endif
    stackPick(pVM->pStack, 0);
    return;
}


static void twoDup(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 4);
#endif
    stackPick(pVM->pStack, 1);
    stackPick(pVM->pStack, 1);
    return;
}


static void over(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 3);
#endif
    stackPick(pVM->pStack, 1);
    return;
}

static void twoOver(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 4, 6);
#endif
    stackPick(pVM->pStack, 3);
    stackPick(pVM->pStack, 3);
    return;
}


static void pick(FICL_VM *pVM)
{
    CELL c = stackPop(pVM->pStack);
#if FICL_ROBUST > 1
    vmCheckStack(pVM, c.i+1, c.i+2);
#endif
    stackPick(pVM->pStack, c.i);
    return;
}


static void questionDup(FICL_VM *pVM)
{
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 2);
#endif
    c = stackGetTop(pVM->pStack);

    if (c.i != 0)
        stackPick(pVM->pStack, 0);

    return;
}


static void roll(FICL_VM *pVM)
{
    int i = stackPop(pVM->pStack).i;
    i = (i > 0) ? i : 0;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, i+1, i+1);
#endif
    stackRoll(pVM->pStack, i);
    return;
}


static void minusRoll(FICL_VM *pVM)
{
    int i = stackPop(pVM->pStack).i;
    i = (i > 0) ? i : 0;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, i+1, i+1);
#endif
    stackRoll(pVM->pStack, -i);
    return;
}


static void rot(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 3, 3);
#endif
    stackRoll(pVM->pStack, 2);
    return;
}


static void swap(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 2);
#endif
    stackRoll(pVM->pStack, 1);
    return;
}


static void twoSwap(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 4, 4);
#endif
    stackRoll(pVM->pStack, 3);
    stackRoll(pVM->pStack, 3);
    return;
}


/**************************************************************************
                        e m i t   &   f r i e n d s
**
**************************************************************************/

static void emit(FICL_VM *pVM)
{
    char cp[2];
    int i;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    i = stackPopINT(pVM->pStack);
    cp[0] = (char)i;
    cp[1] = '\0';
    vmTextOut(pVM, cp, 0);
    return;
}


static void cr(FICL_VM *pVM)
{
    vmTextOut(pVM, "", 1);
    return;
}


static void commentLine(FICL_VM *pVM)
{
    char *cp        = vmGetInBuf(pVM);
    char *pEnd      = vmGetInBufEnd(pVM);
    char ch = *cp;

    while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
    {
        ch = *++cp;
    }

    /*
    ** Cope with DOS or UNIX-style EOLs -
    ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
    ** and point cp to next char. If EOL is \0, we're done.
    */
    if (cp != pEnd)
    {
        cp++;

        if ( (cp != pEnd) && (ch != *cp)
             && ((*cp == '\r') || (*cp == '\n')) )
            cp++;
    }

    vmUpdateTib(pVM, cp);
    return;
}


/*
** paren CORE
** Compilation: Perform the execution semantics given below.
** Execution: ( "ccc<paren>" -- )
** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
** The number of characters in ccc may be zero to the number of characters
** in the parse area.
**
*/
static void commentHang(FICL_VM *pVM)
{
    vmParseStringEx(pVM, ')', 0);
    return;
}


/**************************************************************************
                        F E T C H   &   S T O R E
**
**************************************************************************/

static void fetch(FICL_VM *pVM)
{
    CELL *pCell;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    pCell = (CELL *)stackPopPtr(pVM->pStack);
    stackPush(pVM->pStack, *pCell);
    return;
}

/*
** two-fetch    CORE ( a-addr -- x1 x2 )
** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
** x1 at the next consecutive cell. It is equivalent to the sequence
** DUP CELL+ @ SWAP @ .
*/
static void twoFetch(FICL_VM *pVM)
{
    CELL *pCell;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 2);
#endif
    pCell = (CELL *)stackPopPtr(pVM->pStack);
    stackPush(pVM->pStack, *pCell++);
    stackPush(pVM->pStack, *pCell);
    swap(pVM);
    return;
}

/*
** store        CORE ( x a-addr -- )
** Store x at a-addr.
*/
static void store(FICL_VM *pVM)
{
    CELL *pCell;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    pCell = (CELL *)stackPopPtr(pVM->pStack);
    *pCell = stackPop(pVM->pStack);
}

/*
** two-store    CORE ( x1 x2 a-addr -- )
** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
** next consecutive cell. It is equivalent to the sequence
** SWAP OVER ! CELL+ ! .
*/
static void twoStore(FICL_VM *pVM)
{
    CELL *pCell;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 3, 0);
#endif
    pCell = (CELL *)stackPopPtr(pVM->pStack);
    *pCell++    = stackPop(pVM->pStack);
    *pCell      = stackPop(pVM->pStack);
}

static void plusStore(FICL_VM *pVM)
{
    CELL *pCell;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    pCell = (CELL *)stackPopPtr(pVM->pStack);
    pCell->i += stackPop(pVM->pStack).i;
}


static void quadFetch(FICL_VM *pVM)
{
    UNS32 *pw;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    pw = (UNS32 *)stackPopPtr(pVM->pStack);
    PUSHUNS((FICL_UNS)*pw);
    return;
}

static void quadStore(FICL_VM *pVM)
{
    UNS32 *pw;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    pw = (UNS32 *)stackPopPtr(pVM->pStack);
    *pw = (UNS32)(stackPop(pVM->pStack).u);
}

static void wFetch(FICL_VM *pVM)
{
    UNS16 *pw;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    pw = (UNS16 *)stackPopPtr(pVM->pStack);
    PUSHUNS((FICL_UNS)*pw);
    return;
}

static void wStore(FICL_VM *pVM)
{
    UNS16 *pw;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    pw = (UNS16 *)stackPopPtr(pVM->pStack);
    *pw = (UNS16)(stackPop(pVM->pStack).u);
}

static void cFetch(FICL_VM *pVM)
{
    UNS8 *pc;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    pc = (UNS8 *)stackPopPtr(pVM->pStack);
    PUSHUNS((FICL_UNS)*pc);
    return;
}

static void cStore(FICL_VM *pVM)
{
    UNS8 *pc;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    pc = (UNS8 *)stackPopPtr(pVM->pStack);
    *pc = (UNS8)(stackPop(pVM->pStack).u);
}


/**************************************************************************
                        b r a n c h P a r e n
**
** Runtime for "(branch)" -- expects a literal offset in the next
** compilation address, and branches to that location.
**************************************************************************/

static void branchParen(FICL_VM *pVM)
{
    vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
    return;
}


/**************************************************************************
                        b r a n c h 0
** Runtime code for "(branch0)"; pop a flag from the stack,
** branch if 0. fall through otherwise.  The heart of "if" and "until".
**************************************************************************/

static void branch0(FICL_VM *pVM)
{
    FICL_UNS flag;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    flag = stackPopUNS(pVM->pStack);

    if (flag)
    {                           /* fall through */
        vmBranchRelative(pVM, 1);
    }
    else
    {                           /* take branch (to else/endif/begin) */
        vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
    }

    return;
}


/**************************************************************************
                        i f C o I m
** IMMEDIATE COMPILE-ONLY
** Compiles code for a conditional branch into the dictionary
** and pushes the branch patch address on the stack for later
** patching by ELSE or THEN/ENDIF.
**************************************************************************/

static void ifCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranch0);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
    markBranch(dp, pVM, origTag);
    dictAppendUNS(dp, 1);
    return;
}


/**************************************************************************
                        e l s e C o I m
**
** IMMEDIATE COMPILE-ONLY
** compiles an "else"...
** 1) Compile a branch and a patch address; the address gets patched
**    by "endif" to point past the "else" code.
** 2) Pop the "if" patch address
** 3) Patch the "if" branch to point to the current compile address.
** 4) Push the "else" patch address. ("endif" patches this to jump past
**    the "else" code.
**************************************************************************/

static void elseCoIm(FICL_VM *pVM)
{
    CELL *patchAddr;
    FICL_INT offset;
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranchParen);
                                            /* (1) compile branch runtime */
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
    matchControlTag(pVM, origTag);
    patchAddr =
        (CELL *)stackPopPtr(pVM->pStack);   /* (2) pop "if" patch addr */
    markBranch(dp, pVM, origTag);           /* (4) push "else" patch addr */
    dictAppendUNS(dp, 1);                 /* (1) compile patch placeholder */
    offset = dp->here - patchAddr;
    *patchAddr = LVALUEtoCELL(offset);      /* (3) Patch "if" */

    return;
}


/**************************************************************************
                        e n d i f C o I m
** IMMEDIATE COMPILE-ONLY
**************************************************************************/

static void endifCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    resolveForwardBranch(dp, pVM, origTag);
    return;
}


/**************************************************************************
                        c a s e C o I m
** IMMEDIATE COMPILE-ONLY
**
**
** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this:
**			i*addr i caseTag
** and an OF-SYS (see DPANS94 6.2.1950) looks like this:
**			i*addr i caseTag addr ofTag
** The integer under caseTag is the count of fixup addresses that branch
** to ENDCASE.
**************************************************************************/

static void caseCoIm(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif

	PUSHUNS(0);
	markControlTag(pVM, caseTag);
    return;
}


/**************************************************************************
                        e n d c a s eC o I m
** IMMEDIATE COMPILE-ONLY
**************************************************************************/

static void endcaseCoIm(FICL_VM *pVM)
{
	FICL_UNS fixupCount;
    FICL_DICT *dp;
    CELL *patchAddr;
    FICL_INT offset;

    assert(pVM->pSys->pDrop);

	/*
	** if the last OF ended with FALLTHROUGH,
	** just add the FALLTHROUGH fixup to the
	** ENDOF fixups
	*/
	if (stackGetTop(pVM->pStack).p == fallthroughTag)
	{
		matchControlTag(pVM, fallthroughTag);
		patchAddr = POPPTR();
	    matchControlTag(pVM, caseTag);
		fixupCount = POPUNS();
		PUSHPTR(patchAddr);
		PUSHUNS(fixupCount + 1);
		markControlTag(pVM, caseTag);
	}

    matchControlTag(pVM, caseTag);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
	fixupCount = POPUNS();
#if FICL_ROBUST > 1
    vmCheckStack(pVM, fixupCount, 0);
#endif

    dp = vmGetDict(pVM);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop));

	while (fixupCount--)
	{
		patchAddr = (CELL *)stackPopPtr(pVM->pStack);
		offset = dp->here - patchAddr;
		*patchAddr = LVALUEtoCELL(offset);
	}
    return;
}


static void ofParen(FICL_VM *pVM)
{
	FICL_UNS a, b;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif

	a = POPUNS();
	b = stackGetTop(pVM->pStack).u;

    if (a == b)
    {                           /* fall through */
		stackDrop(pVM->pStack, 1);
        vmBranchRelative(pVM, 1);
    }
    else
    {                           /* take branch to next of or endswitch */
        vmBranchRelative(pVM, *(int *)(pVM->ip));
    }

    return;
}


/**************************************************************************
                        o f C o I m
** IMMEDIATE COMPILE-ONLY
**************************************************************************/

static void ofCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
	CELL *fallthroughFixup = NULL;

    assert(pVM->pSys->pBranch0);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 3);
#endif

	if (stackGetTop(pVM->pStack).p == fallthroughTag)
	{
		matchControlTag(pVM, fallthroughTag);
		fallthroughFixup = POPPTR();
	}

	matchControlTag(pVM, caseTag);

	markControlTag(pVM, caseTag);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen));
    markBranch(dp, pVM, ofTag);
    dictAppendUNS(dp, 2);

	if (fallthroughFixup != NULL)
	{
		FICL_INT offset = dp->here - fallthroughFixup;
		*fallthroughFixup = LVALUEtoCELL(offset);
	}

    return;
}


/**************************************************************************
                    e n d o f C o I m
** IMMEDIATE COMPILE-ONLY
**************************************************************************/

static void endofCoIm(FICL_VM *pVM)
{
    CELL *patchAddr;
    FICL_UNS fixupCount;
    FICL_INT offset;
    FICL_DICT *dp = vmGetDict(pVM);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 4, 3);
#endif

    assert(pVM->pSys->pBranchParen);

	/* ensure we're in an OF, */
    matchControlTag(pVM, ofTag);
	/* grab the address of the branch location after the OF */
    patchAddr = (CELL *)stackPopPtr(pVM->pStack);
	/* ensure we're also in a "case" */
    matchControlTag(pVM, caseTag);
	/* grab the current number of ENDOF fixups */
	fixupCount = POPUNS();

    /* compile branch runtime */
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));

	/* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
    PUSHPTR(dp->here);
    PUSHUNS(fixupCount + 1);
	markControlTag(pVM, caseTag);

	/* reserve space for the ENDOF fixup */
    dictAppendUNS(dp, 2);

	/* and patch the original OF */
    offset = dp->here - patchAddr;
    *patchAddr = LVALUEtoCELL(offset);
}


/**************************************************************************
                    f a l l t h r o u g h C o I m
** IMMEDIATE COMPILE-ONLY
**************************************************************************/

static void fallthroughCoIm(FICL_VM *pVM)
{
    CELL *patchAddr;
    FICL_INT offset;
    FICL_DICT *dp = vmGetDict(pVM);

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 4, 3);
#endif

	/* ensure we're in an OF, */
    matchControlTag(pVM, ofTag);
	/* grab the address of the branch location after the OF */
    patchAddr = (CELL *)stackPopPtr(pVM->pStack);
	/* ensure we're also in a "case" */
    matchControlTag(pVM, caseTag);

	/* okay, here we go.  put the case tag back. */
	markControlTag(pVM, caseTag);

    /* compile branch runtime */
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));

	/* push a new FALLTHROUGH fixup and the fallthroughTag */
    PUSHPTR(dp->here);
	markControlTag(pVM, fallthroughTag);

	/* reserve space for the FALLTHROUGH fixup */
    dictAppendUNS(dp, 2);

	/* and patch the original OF */
    offset = dp->here - patchAddr;
    *patchAddr = LVALUEtoCELL(offset);
}

/**************************************************************************
                        h a s h
** hash ( c-addr u -- code)
** calculates hashcode of specified string and leaves it on the stack
**************************************************************************/

static void hash(FICL_VM *pVM)
{
    STRINGINFO si;
    SI_SETLEN(si, stackPopUNS(pVM->pStack));
    SI_SETPTR(si, stackPopPtr(pVM->pStack));
    PUSHUNS(hashHashCode(si));
    return;
}


/**************************************************************************
                        i n t e r p r e t
** This is the "user interface" of a Forth. It does the following:
**   while there are words in the VM's Text Input Buffer
**     Copy next word into the pad (vmGetWord)
**     Attempt to find the word in the dictionary (dictLookup)
**     If successful, execute the word.
**     Otherwise, attempt to convert the word to a number (isNumber)
**     If successful, push the number onto the parameter stack.
**     Otherwise, print an error message and exit loop...
**   End Loop
**
** From the standard, section 3.4
** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
** repeat the following steps until either the parse area is empty or an
** ambiguous condition exists:
** a) Skip leading spaces and parse a name (see 3.4.1);
**************************************************************************/

static void interpret(FICL_VM *pVM)
{
    STRINGINFO si;
    int i;
    FICL_SYSTEM *pSys;

    assert(pVM);

    pSys = pVM->pSys;
    si   = vmGetWord0(pVM);

    /*
    ** Get next word...if out of text, we're done.
    */
    if (si.count == 0)
    {
        vmThrow(pVM, VM_OUTOFTEXT);
    }

    /*
    ** Attempt to find the incoming token in the dictionary. If that fails...
    ** run the parse chain against the incoming token until somebody eats it.
    ** Otherwise emit an error message and give up.
    ** Although ficlParseWord could be part of the parse list, I've hard coded it
    ** in for robustness. ficlInitSystem adds the other default steps to the list.
    */
    if (ficlParseWord(pVM, si))
        return;

    for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
    {
        FICL_WORD *pFW = pSys->parseList[i];

        if (pFW == NULL)
            break;

        if (pFW->code == parseStepParen)
        {
            FICL_PARSE_STEP pStep;
            pStep = (FICL_PARSE_STEP)(pFW->param->fn);
            if ((*pStep)(pVM, si))
                return;
        }
        else
        {
            stackPushPtr(pVM->pStack, SI_PTR(si));
            stackPushUNS(pVM->pStack, SI_COUNT(si));
            ficlExecXT(pVM, pFW);
            if (stackPopINT(pVM->pStack))
                return;
        }
    }

    i = SI_COUNT(si);
    vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));

    return;                 /* back to inner interpreter */
}


/**************************************************************************
                        f i c l P a r s e W o r d
** From the standard, section 3.4
** b) Search the dictionary name space (see 3.4.2). If a definition name
** matching the string is found:
**  1.if interpreting, perform the interpretation semantics of the definition
**  (see 3.4.3.2), and continue at a);
**  2.if compiling, perform the compilation semantics of the definition
**  (see 3.4.3.3), and continue at a).
**
** c) If a definition name matching the string is not found, attempt to
** convert the string to a number (see 3.4.1.3). If successful:
**  1.if interpreting, place the number on the data stack, and continue at a);
**  2.if compiling, compile code that when executed will place the number on
**  the stack (see 6.1.1780 LITERAL), and continue at a);
**
** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
**
** (jws 4/01) Modified to be a FICL_PARSE_STEP
**************************************************************************/
static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
{
    FICL_DICT *dp = vmGetDict(pVM);
    FICL_WORD *tempFW;

#if FICL_ROBUST
    dictCheck(dp, pVM, 0);
    vmCheckStack(pVM, 0, 0);
#endif

#if FICL_WANT_LOCALS
    if (pVM->pSys->nLocals > 0)
    {
        tempFW = ficlLookupLoc(pVM->pSys, si);
    }
    else
#endif
    tempFW = dictLookup(dp, si);

    if (pVM->state == INTERPRET)
    {
        if (tempFW != NULL)
        {
            if (wordIsCompileOnly(tempFW))
            {
                vmThrowErr(pVM, "Error: Compile only!");
            }

            vmExecute(pVM, tempFW);
            return (int)FICL_TRUE;
        }
    }

    else /* (pVM->state == COMPILE) */
    {
        if (tempFW != NULL)
        {
            if (wordIsImmediate(tempFW))
            {
                vmExecute(pVM, tempFW);
            }
            else
            {
                dictAppendCell(dp, LVALUEtoCELL(tempFW));
            }
            return (int)FICL_TRUE;
        }
    }

    return FICL_FALSE;
}


/*
** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
** INTERPRET)
*/
static void lookup(FICL_VM *pVM)
{
    STRINGINFO si;
    SI_SETLEN(si, stackPopUNS(pVM->pStack));
    SI_SETPTR(si, stackPopPtr(pVM->pStack));
    stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
    return;
}


/**************************************************************************
                        p a r e n P a r s e S t e p
** (parse-step)  ( c-addr u -- flag )
** runtime for a precompiled parse step - pop a counted string off the
** stack, run the parse step against it, and push the result flag (FICL_TRUE
** if success, FICL_FALSE otherwise).
**************************************************************************/

void parseStepParen(FICL_VM *pVM)
{
    STRINGINFO si;
    FICL_WORD *pFW = pVM->runningWord;
    FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);

    SI_SETLEN(si, stackPopINT(pVM->pStack));
    SI_SETPTR(si, stackPopPtr(pVM->pStack));

    PUSHINT((*pStep)(pVM, si));

    return;
}


static void addParseStep(FICL_VM *pVM)
{
    FICL_WORD *pStep;
    FICL_DICT *pd = vmGetDict(pVM);
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
    if ((pStep != NULL) && isAFiclWord(pd, pStep))
        ficlAddParseStep(pVM->pSys, pStep);
    return;
}


/**************************************************************************
                        l i t e r a l P a r e n
**
** This is the runtime for (literal). It assumes that it is part of a colon
** definition, and that the next CELL contains a value to be pushed on the
** parameter stack at runtime. This code is compiled by "literal".
**
**************************************************************************/

static void literalParen(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif
    PUSHINT(*(FICL_INT *)(pVM->ip));
    vmBranchRelative(pVM, 1);
    return;
}

static void twoLitParen(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif
    PUSHINT(*((FICL_INT *)(pVM->ip)+1));
    PUSHINT(*(FICL_INT *)(pVM->ip));
    vmBranchRelative(pVM, 2);
    return;
}


/**************************************************************************
                        l i t e r a l I m
**
** IMMEDIATE code for "literal". This function gets a value from the stack
** and compiles it into the dictionary preceded by the code for "(literal)".
** IMMEDIATE
**************************************************************************/

static void literalIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    assert(pVM->pSys->pLitParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
    dictAppendCell(dp, stackPop(pVM->pStack));

    return;
}


static void twoLiteralIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    assert(pVM->pSys->pTwoLitParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
    dictAppendCell(dp, stackPop(pVM->pStack));
    dictAppendCell(dp, stackPop(pVM->pStack));

    return;
}

/**************************************************************************
                        l o g i c   a n d   c o m p a r i s o n s
**
**************************************************************************/

static void zeroEquals(FICL_VM *pVM)
{
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
    stackPush(pVM->pStack, c);
    return;
}

static void zeroLess(FICL_VM *pVM)
{
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
    stackPush(pVM->pStack, c);
    return;
}

static void zeroGreater(FICL_VM *pVM)
{
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
    stackPush(pVM->pStack, c);
    return;
}

static void isEqual(FICL_VM *pVM)
{
    CELL x, y;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    x = stackPop(pVM->pStack);
    y = stackPop(pVM->pStack);
    PUSHINT(FICL_BOOL(x.i == y.i));
    return;
}

static void isLess(FICL_VM *pVM)
{
    CELL x, y;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    y = stackPop(pVM->pStack);
    x = stackPop(pVM->pStack);
    PUSHINT(FICL_BOOL(x.i < y.i));
    return;
}

static void uIsLess(FICL_VM *pVM)
{
    FICL_UNS u1, u2;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    u2 = stackPopUNS(pVM->pStack);
    u1 = stackPopUNS(pVM->pStack);
    PUSHINT(FICL_BOOL(u1 < u2));
    return;
}

static void isGreater(FICL_VM *pVM)
{
    CELL x, y;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    y = stackPop(pVM->pStack);
    x = stackPop(pVM->pStack);
    PUSHINT(FICL_BOOL(x.i > y.i));
    return;
}

static void uIsGreater(FICL_VM *pVM)
{
    FICL_UNS u1, u2;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    u2 = stackPopUNS(pVM->pStack);
    u1 = stackPopUNS(pVM->pStack);
    PUSHINT(FICL_BOOL(u1 > u2));
    return;
}

static void bitwiseAnd(FICL_VM *pVM)
{
    CELL x, y;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    x = stackPop(pVM->pStack);
    y = stackPop(pVM->pStack);
    PUSHINT(x.i & y.i);
    return;
}

static void bitwiseOr(FICL_VM *pVM)
{
    CELL x, y;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    x = stackPop(pVM->pStack);
    y = stackPop(pVM->pStack);
    PUSHINT(x.i | y.i);
    return;
}

static void bitwiseXor(FICL_VM *pVM)
{
    CELL x, y;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 1);
#endif
    x = stackPop(pVM->pStack);
    y = stackPop(pVM->pStack);
    PUSHINT(x.i ^ y.i);
    return;
}

static void bitwiseNot(FICL_VM *pVM)
{
    CELL x;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif
    x = stackPop(pVM->pStack);
    PUSHINT(~x.i);
    return;
}


/**************************************************************************
                               D o  /  L o o p
** do -- IMMEDIATE COMPILE ONLY
**    Compiles code to initialize a loop: compile (do),
**    allot space to hold the "leave" address, push a branch
**    target address for the loop.
** (do) -- runtime for "do"
**    pops index and limit from the p stack and moves them
**    to the r stack, then skips to the loop body.
** loop -- IMMEDIATE COMPILE ONLY
** +loop
**    Compiles code for the test part of a loop:
**    compile (loop), resolve forward branch from "do", and
**    copy "here" address to the "leave" address allotted by "do"
** i,j,k -- COMPILE ONLY
**    Runtime: Push loop indices on param stack (i is innermost loop...)
**    Note: each loop has three values on the return stack:
**    ( R: leave limit index )
**    "leave" is the absolute address of the next cell after the loop
**    limit and index are the loop control variables.
** leave -- COMPILE ONLY
**    Runtime: pop the loop control variables, then pop the
**    "leave" address and jump (absolute) there.
**************************************************************************/

static void doCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pDoParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
    /*
    ** Allot space for a pointer to the end
    ** of the loop - "leave" uses this...
    */
    markBranch(dp, pVM, leaveTag);
    dictAppendUNS(dp, 0);
    /*
    ** Mark location of head of loop...
    */
    markBranch(dp, pVM, doTag);

    return;
}


static void doParen(FICL_VM *pVM)
{
    CELL index, limit;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    index = stackPop(pVM->pStack);
    limit = stackPop(pVM->pStack);

    /* copy "leave" target addr to stack */
    stackPushPtr(pVM->rStack, *(pVM->ip++));
    stackPush(pVM->rStack, limit);
    stackPush(pVM->rStack, index);

    return;
}


static void qDoCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pQDoParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
    /*
    ** Allot space for a pointer to the end
    ** of the loop - "leave" uses this...
    */
    markBranch(dp, pVM, leaveTag);
    dictAppendUNS(dp, 0);
    /*
    ** Mark location of head of loop...
    */
    markBranch(dp, pVM, doTag);

    return;
}


static void qDoParen(FICL_VM *pVM)
{
    CELL index, limit;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    index = stackPop(pVM->pStack);
    limit = stackPop(pVM->pStack);

    /* copy "leave" target addr to stack */
    stackPushPtr(pVM->rStack, *(pVM->ip++));

    if (limit.u == index.u)
    {
        vmPopIP(pVM);
    }
    else
    {
        stackPush(pVM->rStack, limit);
        stackPush(pVM->rStack, index);
    }

    return;
}


/*
** Runtime code to break out of a do..loop construct
** Drop the loop control variables; the branch address
** past "loop" is next on the return stack.
*/
static void leaveCo(FICL_VM *pVM)
{
    /* almost unloop */
    stackDrop(pVM->rStack, 2);
    /* exit */
    vmPopIP(pVM);
    return;
}


static void unloopCo(FICL_VM *pVM)
{
    stackDrop(pVM->rStack, 3);
    return;
}


static void loopCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pLoopParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
    resolveBackBranch(dp, pVM, doTag);
    resolveAbsBranch(dp, pVM, leaveTag);
    return;
}


static void plusLoopCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pPLoopParen);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
    resolveBackBranch(dp, pVM, doTag);
    resolveAbsBranch(dp, pVM, leaveTag);
    return;
}


static void loopParen(FICL_VM *pVM)
{
    FICL_INT index = stackGetTop(pVM->rStack).i;
    FICL_INT limit = stackFetch(pVM->rStack, 1).i;

    index++;

    if (index >= limit)
    {
        stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
        vmBranchRelative(pVM, 1);  /* fall through the loop */
    }
    else
    {                       /* update index, branch to loop head */
        stackSetTop(pVM->rStack, LVALUEtoCELL(index));
        vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
    }

    return;
}


static void plusLoopParen(FICL_VM *pVM)
{
    FICL_INT index,limit,increment;
    int flag;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    index = stackGetTop(pVM->rStack).i;
    limit = stackFetch(pVM->rStack, 1).i;
    increment = POP().i;

    index += increment;

    if (increment < 0)
        flag = (index < limit);
    else
        flag = (index >= limit);

    if (flag)
    {
        stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
        vmBranchRelative(pVM, 1);  /* fall through the loop */
    }
    else
    {                       /* update index, branch to loop head */
        stackSetTop(pVM->rStack, LVALUEtoCELL(index));
        vmBranchRelative(pVM, (uintptr_t)*(pVM->ip));
    }

    return;
}


static void loopICo(FICL_VM *pVM)
{
    CELL index = stackGetTop(pVM->rStack);
    stackPush(pVM->pStack, index);

    return;
}


static void loopJCo(FICL_VM *pVM)
{
    CELL index = stackFetch(pVM->rStack, 3);
    stackPush(pVM->pStack, index);

    return;
}


static void loopKCo(FICL_VM *pVM)
{
    CELL index = stackFetch(pVM->rStack, 6);
    stackPush(pVM->pStack, index);

    return;
}


/**************************************************************************
                        r e t u r n   s t a c k
**
**************************************************************************/
static void toRStack(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    stackPush(pVM->rStack, POP());
}

static void fromRStack(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    PUSH(stackPop(pVM->rStack));
}

static void fetchRStack(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    PUSH(stackGetTop(pVM->rStack));
}

static void twoToR(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif
    stackRoll(pVM->pStack, 1);
    stackPush(pVM->rStack, stackPop(pVM->pStack));
    stackPush(pVM->rStack, stackPop(pVM->pStack));
    return;
}

static void twoRFrom(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif
    stackPush(pVM->pStack, stackPop(pVM->rStack));
    stackPush(pVM->pStack, stackPop(pVM->rStack));
    stackRoll(pVM->pStack, 1);
    return;
}

static void twoRFetch(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif
    stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
    stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
    return;
}


/**************************************************************************
                        v a r i a b l e
**
**************************************************************************/

static void variableParen(FICL_VM *pVM)
{
    FICL_WORD *fw;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    fw = pVM->runningWord;
    PUSHPTR(fw->param);
}


static void variable(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);

    dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
    dictAllotCells(dp, 1);
    return;
}


static void twoVariable(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);

    dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
    dictAllotCells(dp, 2);
    return;
}


/**************************************************************************
                        b a s e   &   f r i e n d s
**
**************************************************************************/

static void base(FICL_VM *pVM)
{
    CELL *pBase;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    pBase = (CELL *)(&pVM->base);
    stackPush(pVM->pStack, LVALUEtoCELL(pBase));
    return;
}


static void decimal(FICL_VM *pVM)
{
    pVM->base = 10;
    return;
}


static void hex(FICL_VM *pVM)
{
    pVM->base = 16;
    return;
}


/**************************************************************************
                        a l l o t   &   f r i e n d s
**
**************************************************************************/

static void allot(FICL_VM *pVM)
{
    FICL_DICT *dp;
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    dp = vmGetDict(pVM);
    i = POPINT();

#if FICL_ROBUST
    dictCheck(dp, pVM, i);
#endif

    dictAllot(dp, i);
    return;
}


static void here(FICL_VM *pVM)
{
    FICL_DICT *dp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    dp = vmGetDict(pVM);
    PUSHPTR(dp->here);
    return;
}

static void comma(FICL_VM *pVM)
{
    FICL_DICT *dp;
    CELL c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    dp = vmGetDict(pVM);
    c = POP();
    dictAppendCell(dp, c);
    return;
}

static void cComma(FICL_VM *pVM)
{
    FICL_DICT *dp;
    char c;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    dp = vmGetDict(pVM);
    c = (char)POPINT();
    dictAppendChar(dp, c);
    return;
}

static void cells(FICL_VM *pVM)
{
    FICL_INT i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif

    i = POPINT();
    PUSHINT(i * (FICL_INT)sizeof (CELL));
    return;
}

static void cellPlus(FICL_VM *pVM)
{
    char *cp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif

    cp = POPPTR();
    PUSHPTR(cp + sizeof (CELL));
    return;
}



/**************************************************************************
                        t i c k
** tick         CORE ( "<spaces>name" -- xt )
** Skip leading space delimiters. Parse name delimited by a space. Find
** name and return xt, the execution token for name. An ambiguous condition
** exists if name is not found.
**************************************************************************/
void ficlTick(FICL_VM *pVM)
{
    FICL_WORD *pFW = NULL;
    STRINGINFO si = vmGetWord(pVM);
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    pFW = dictLookup(vmGetDict(pVM), si);
    if (!pFW)
    {
        int i = SI_COUNT(si);
        vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
    }
    PUSHPTR(pFW);
    return;
}


static void bracketTickCoIm(FICL_VM *pVM)
{
    ficlTick(pVM);
    literalIm(pVM);

    return;
}


/**************************************************************************
                        p o s t p o n e
** Lookup the next word in the input stream and compile code to
** insert it into definitions created by the resulting word
** (defers compilation, even of immediate words)
**************************************************************************/

static void postponeCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp  = vmGetDict(pVM);
    FICL_WORD *pFW;
    FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
    assert(pComma);

    ficlTick(pVM);
    pFW = stackGetTop(pVM->pStack).p;
    if (wordIsImmediate(pFW))
    {
        dictAppendCell(dp, stackPop(pVM->pStack));
    }
    else
    {
        literalIm(pVM);
        dictAppendCell(dp, LVALUEtoCELL(pComma));
    }

    return;
}



/**************************************************************************
                        e x e c u t e
** Pop an execution token (pointer to a word) off the stack and
** run it
**************************************************************************/

static void execute(FICL_VM *pVM)
{
    FICL_WORD *pFW;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    pFW = stackPopPtr(pVM->pStack);
    vmExecute(pVM, pFW);

    return;
}


/**************************************************************************
                        i m m e d i a t e
** Make the most recently compiled word IMMEDIATE -- it executes even
** in compile state (most often used for control compiling words
** such as IF, THEN, etc)
**************************************************************************/

static void immediate(FICL_VM *pVM)
{
    IGNORE(pVM);
    dictSetImmediate(vmGetDict(pVM));
    return;
}


static void compileOnly(FICL_VM *pVM)
{
    IGNORE(pVM);
    dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
    return;
}


static void setObjectFlag(FICL_VM *pVM)
{
    IGNORE(pVM);
    dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
    return;
}

static void isObject(FICL_VM *pVM)
{
    FICL_INT flag;
    FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);

    flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
    stackPushINT(pVM->pStack, flag);
    return;
}

static void cstringLit(FICL_VM *pVM)
{
    FICL_STRING *sp = (FICL_STRING *)(pVM->ip);

    char *cp = sp->text;
    cp += sp->count + 1;
    cp = alignPtr(cp);
    pVM->ip = (IPTYPE)(void *)cp;

    stackPushPtr(pVM->pStack, sp);
    return;
}


static void cstringQuoteIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    if (pVM->state == INTERPRET)
    {
        FICL_STRING *sp = (FICL_STRING *) dp->here;
        vmGetString(pVM, sp, '\"');
        stackPushPtr(pVM->pStack, sp);
		/* move HERE past string so it doesn't get overwritten.  --lch */
		dictAllot(dp, sp->count + sizeof(FICL_COUNT));
    }
    else    /* COMPILE state */
    {
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
        dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
        dictAlign(dp);
    }

    return;
}

/**************************************************************************
                        d o t Q u o t e
** IMMEDIATE word that compiles a string literal for later display
** Compile stringLit, then copy the bytes of the string from the TIB
** to the dictionary. Backpatch the count byte and align the dictionary.
**
** stringlit: Fetch the count from the dictionary, then push the address
** and count on the stack. Finally, update ip to point to the first
** aligned address after the string text.
**************************************************************************/

static void stringLit(FICL_VM *pVM)
{
    FICL_STRING *sp;
    FICL_COUNT count;
    char *cp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 2);
#endif

    sp = (FICL_STRING *)(pVM->ip);
    count = sp->count;
    cp = sp->text;
    PUSHPTR(cp);
    PUSHUNS(count);
    cp += count + 1;
    cp = alignPtr(cp);
    pVM->ip = (IPTYPE)(void *)cp;
}

static void dotQuoteCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
    assert(pType);
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
    dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
    dictAlign(dp);
    dictAppendCell(dp, LVALUEtoCELL(pType));
    return;
}


static void dotParen(FICL_VM *pVM)
{
    char *pSrc      = vmGetInBuf(pVM);
    char *pEnd      = vmGetInBufEnd(pVM);
    char *pDest     = pVM->pad;
    char ch;

    /*
    ** Note: the standard does not want leading spaces skipped (apparently)
    */
    for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
        *pDest++ = ch;

    *pDest = '\0';
    if ((pEnd != pSrc) && (ch == ')'))
        pSrc++;

    vmTextOut(pVM, pVM->pad, 0);
    vmUpdateTib(pVM, pSrc);

    return;
}


/**************************************************************************
                        s l i t e r a l
** STRING
** Interpretation: Interpretation semantics for this word are undefined.
** Compilation: ( c-addr1 u -- )
** Append the run-time semantics given below to the current definition.
** Run-time:       ( -- c-addr2 u )
** Return c-addr2 u describing a string consisting of the characters
** specified by c-addr1 u during compilation. A program shall not alter
** the returned string.
**************************************************************************/
static void sLiteralCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp;
    char *cp, *cpDest;
    FICL_UNS u;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 0);
#endif

    dp = vmGetDict(pVM);
    u  = POPUNS();
    cp = POPPTR();

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
    cpDest    = (char *) dp->here;
    *cpDest++ = (char)   u;

    for (; u > 0; --u)
    {
        *cpDest++ = *cp++;
    }

    *cpDest++ = 0;
    dp->here = PTRtoCELL alignPtr(cpDest);
    return;
}


/**************************************************************************
                        s t a t e
** Return the address of the VM's state member (must be sized the
** same as a CELL for this reason)
**************************************************************************/
static void state(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif
    PUSHPTR(&pVM->state);
    return;
}


/**************************************************************************
                        c r e a t e . . . d o e s >
** Make a new word in the dictionary with the run-time effect of
** a variable (push my address), but with extra space allotted
** for use by does> .
**************************************************************************/

static void createParen(FICL_VM *pVM)
{
    CELL *pCell;

#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    pCell = pVM->runningWord->param;
    PUSHPTR(pCell+1);
    return;
}


static void create(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);

    dictCheckThreshold(dp);

    dictAppendWord2(dp, si, createParen, FW_DEFAULT);
    dictAllotCells(dp, 1);
    return;
}


static void doDoes(FICL_VM *pVM)
{
    CELL *pCell;
    IPTYPE tempIP;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 0, 1);
#endif

    pCell = pVM->runningWord->param;
    tempIP = (IPTYPE)((*pCell).p);
    PUSHPTR(pCell+1);
    vmPushIP(pVM, tempIP);
    return;
}


static void doesParen(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    dp->smudge->code = doDoes;
    dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
    vmPopIP(pVM);
    return;
}


static void doesCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
#if FICL_WANT_LOCALS
    assert(pVM->pSys->pUnLinkParen);
    if (pVM->pSys->nLocals > 0)
    {
        FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
        dictEmpty(pLoc, pLoc->pForthWords->size);
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
    }

    pVM->pSys->nLocals = 0;
#endif
    IGNORE(pVM);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
    return;
}


/**************************************************************************
                        t o   b o d y
** to-body      CORE ( xt -- a-addr )
** a-addr is the data-field address corresponding to xt. An ambiguous
** condition exists if xt is not for a word defined via CREATE.
**************************************************************************/
static void toBody(FICL_VM *pVM)
{
    FICL_WORD *pFW;
/*#$-GUY CHANGE: Added robustness.-$#*/
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif

    pFW = POPPTR();
    PUSHPTR(pFW->param + 1);
    return;
}


/*
** from-body       ficl ( a-addr -- xt )
** Reverse effect of >body
*/
static void fromBody(FICL_VM *pVM)
{
    char *ptr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 1);
#endif

    ptr = (char *)POPPTR() - sizeof (FICL_WORD);
    PUSHPTR(ptr);
    return;
}


/*
** >name        ficl ( xt -- c-addr u )
** Push the address and length of a word's name given its address
** xt.
*/
static void toName(FICL_VM *pVM)
{
    FICL_WORD *pFW;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 2);
#endif

    pFW = POPPTR();
    PUSHPTR(pFW->name);
    PUSHUNS(pFW->nName);
    return;
}


static void getLastWord(FICL_VM *pVM)
{
    FICL_DICT *pDict = vmGetDict(pVM);
    FICL_WORD *wp = pDict->smudge;
    assert(wp);
    vmPush(pVM, LVALUEtoCELL(wp));
    return;
}


/**************************************************************************
                        l b r a c k e t   e t c
**
**************************************************************************/

static void lbracketCoIm(FICL_VM *pVM)
{
    pVM->state = INTERPRET;
    return;
}


static void rbracket(FICL_VM *pVM)
{
    pVM->state = COMPILE;
    return;
}


/**************************************************************************
                        p i c t u r e d   n u m e r i c   w o r d s
**
** less-number-sign CORE ( -- )
** Initialize the pictured numeric output conversion process.
** (clear the pad)
**************************************************************************/
static void lessNumberSign(FICL_VM *pVM)
{
    FICL_STRING *sp = PTRtoSTRING pVM->pad;
    sp->count = 0;
    return;
}

/*
** number-sign      CORE ( ud1 -- ud2 )
** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
** n. (n is the least-significant digit of ud1.) Convert n to external form
** and add the resulting character to the beginning of the pictured numeric
** output  string. An ambiguous condition exists if # executes outside of a
** <# #> delimited number conversion.
*/
static void numberSign(FICL_VM *pVM)
{
    FICL_STRING *sp;
    DPUNS u;
    UNS16 rem;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 2);
#endif

    sp = PTRtoSTRING pVM->pad;
    u = u64Pop(pVM->pStack);
    rem = m64UMod(&u, (UNS16)(pVM->base));
    sp->text[sp->count++] = digit_to_char(rem);
    u64Push(pVM->pStack, u);
    return;
}

/*
** number-sign-greater CORE ( xd -- c-addr u )
** Drop xd. Make the pictured numeric output string available as a character
** string. c-addr and u specify the resulting character string. A program
** may replace characters within the string.
*/
static void numberSignGreater(FICL_VM *pVM)
{
    FICL_STRING *sp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 2);
#endif

    sp = PTRtoSTRING pVM->pad;
    sp->text[sp->count] = 0;
    strrev(sp->text);
    DROP(2);
    PUSHPTR(sp->text);
    PUSHUNS(sp->count);
    return;
}

/*
** number-sign-s    CORE ( ud1 -- ud2 )
** Convert one digit of ud1 according to the rule for #. Continue conversion
** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
** #S executes outside of a <# #> delimited number conversion.
** TO DO: presently does not use ud1 hi cell - use it!
*/
static void numberSignS(FICL_VM *pVM)
{
    FICL_STRING *sp;
    DPUNS u;
    UNS16 rem;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 2, 2);
#endif

    sp = PTRtoSTRING pVM->pad;
    u = u64Pop(pVM->pStack);

    do
    {
        rem = m64UMod(&u, (UNS16)(pVM->base));
        sp->text[sp->count++] = digit_to_char(rem);
    }
    while (u.hi || u.lo);

    u64Push(pVM->pStack, u);
    return;
}

/*
** HOLD             CORE ( char -- )
** Add char to the beginning of the pictured numeric output string. An ambiguous
** condition exists if HOLD executes outside of a <# #> delimited number conversion.
*/
static void hold(FICL_VM *pVM)
{
    FICL_STRING *sp;
    int i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    sp = PTRtoSTRING pVM->pad;
    i = POPINT();
    sp->text[sp->count++] = (char) i;
    return;
}

/*
** SIGN             CORE ( n -- )
** If n is negative, add a minus sign to the beginning of the pictured
** numeric output string. An ambiguous condition exists if SIGN
** executes outside of a <# #> delimited number conversion.
*/
static void sign(FICL_VM *pVM)
{
    FICL_STRING *sp;
    int i;
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif

    sp = PTRtoSTRING pVM->pad;
    i = POPINT();
    if (i < 0)
        sp->text[sp->count++] = '-';
    return;
}


/**************************************************************************
                        t o   N u m b e r
** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
** ud2 is the unsigned result of converting the characters within the
** string specified by c-addr1 u1 into digits, using the number in BASE,
** and adding each into ud1 after multiplying ud1 by the number in BASE.
** Conversion continues left-to-right until a character that is not
** convertible, including any + or -, is encountered or the string is
** entirely converted. c-addr2 is the location of the first unconverted
** character or the first character past the end of the string if the string
** was entirely converted. u2 is the number of unconverted characters in the
** string. An ambiguous condition exists if ud2 overflows during the
** conversion.
**************************************************************************/
static void toNumber(FICL_VM *pVM)
{
    FICL_UNS count;
    char *cp;
    DPUNS accum;
    FICL_UNS base = pVM->base;
    FICL_UNS ch;
    FICL_UNS digit;

#if FICL_ROBUST > 1
    vmCheckStack(pVM,4,4);
#endif

    count = POPUNS();
    cp = (char *)POPPTR();
    accum = u64Pop(pVM->pStack);

    for (ch = *cp; count > 0; ch = *++cp, count--)
    {
        if (ch < '0')
            break;

        digit = ch - '0';

        if (digit > 9)
            digit = tolower(ch) - 'a' + 10;
        /*
        ** Note: following test also catches chars between 9 and a
        ** because 'digit' is unsigned!
        */
        if (digit >= base)
            break;

        accum = m64Mac(accum, base, digit);
    }

    u64Push(pVM->pStack, accum);
    PUSHPTR(cp);
    PUSHUNS(count);

    return;
}



/**************************************************************************
                        q u i t   &   a b o r t
** quit CORE   ( -- )  ( R:  i*x -- )
** Empty the return stack, store zero in SOURCE-ID if it is present, make
** the user input device the input source, and enter interpretation state.
** Do not display a message. Repeat the following:
**
**   Accept a line from the input source into the input buffer, set >IN to
**   zero, and interpret.
**   Display the implementation-defined system prompt if in
**   interpretation state, all processing has been completed, and no
**   ambiguous condition exists.
**************************************************************************/

static void quit(FICL_VM *pVM)
{
    vmThrow(pVM, VM_QUIT);
    return;
}


static void ficlAbort(FICL_VM *pVM)
{
    vmThrow(pVM, VM_ABORT);
    return;
}


/**************************************************************************
                        a c c e p t
** accept       CORE ( c-addr +n1 -- +n2 )
** Receive a string of at most +n1 characters. An ambiguous condition
** exists if +n1 is zero or greater than 32,767. Display graphic characters
** as they are received. A program that depends on the presence or absence
** of non-graphic characters in the string has an environmental dependency.
** The editing functions, if any, that the system performs in order to
** construct the string are implementation-defined.
**
** (Although the standard text doesn't say so, I assume that the intent
** of 'accept' is to store the string at the address specified on
** the stack.)
** Implementation: if there's more text in the TIB, use it. Otherwise
** throw out for more text. Copy characters up to the max count into the
** address given, and return the number of actual characters copied.
**
** Note (sobral) this may not be the behavior you'd expect if you're
** trying to get user input at load time!
**************************************************************************/
static void accept(FICL_VM *pVM)
{
    FICL_UNS count, len;
    char *cp;
    char *pBuf, *pEnd;

#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    pBuf = vmGetInBuf(pVM);
    pEnd = vmGetInBufEnd(pVM);
    len = pEnd - pBuf;
    if (len == 0)
        vmThrow(pVM, VM_RESTART);

    /*
    ** Now we have something in the text buffer - use it
    */
    count = stackPopINT(pVM->pStack);
    cp    = stackPopPtr(pVM->pStack);

    len = (count < len) ? count : len;
    strncpy(cp, vmGetInBuf(pVM), len);
    pBuf += len;
    vmUpdateTib(pVM, pBuf);
    PUSHINT(len);

    return;
}


/**************************************************************************
                        a l i g n
** 6.1.0705 ALIGN       CORE ( -- )
** If the data-space pointer is not aligned, reserve enough space to
** align it.
**************************************************************************/
static void align(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    IGNORE(pVM);
    dictAlign(dp);
    return;
}


/**************************************************************************
                        a l i g n e d
**
**************************************************************************/
static void aligned(FICL_VM *pVM)
{
    void *addr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,1);
#endif

    addr = POPPTR();
    PUSHPTR(alignPtr(addr));
    return;
}


/**************************************************************************
                        b e g i n   &   f r i e n d s
** Indefinite loop control structures
** A.6.1.0760 BEGIN
** Typical use:
**      : X ... BEGIN ... test UNTIL ;
** or
**      : X ... BEGIN ... test WHILE ... REPEAT ;
**************************************************************************/
static void beginCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    markBranch(dp, pVM, destTag);
    return;
}

static void untilCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranch0);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
    resolveBackBranch(dp, pVM, destTag);
    return;
}

static void whileCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranch0);

    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
    markBranch(dp, pVM, origTag);
    twoSwap(pVM);
    dictAppendUNS(dp, 1);
    return;
}

static void repeatCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranchParen);
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));

    /* expect "begin" branch marker */
    resolveBackBranch(dp, pVM, destTag);
    /* expect "while" branch marker */
    resolveForwardBranch(dp, pVM, origTag);
    return;
}


static void againCoIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    assert(pVM->pSys->pBranchParen);
    dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));

    /* expect "begin" branch marker */
    resolveBackBranch(dp, pVM, destTag);
    return;
}


/**************************************************************************
                        c h a r   &   f r i e n d s
** 6.1.0895 CHAR    CORE ( "<spaces>name" -- char )
** Skip leading space delimiters. Parse name delimited by a space.
** Put the value of its first character onto the stack.
**
** bracket-char     CORE
** Interpretation: Interpretation semantics for this word are undefined.
** Compilation: ( "<spaces>name" -- )
** Skip leading space delimiters. Parse name delimited by a space.
** Append the run-time semantics given below to the current definition.
** Run-time: ( -- char )
** Place char, the value of the first character of name, on the stack.
**************************************************************************/
static void ficlChar(FICL_VM *pVM)
{
    STRINGINFO si;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,0,1);
#endif

    si = vmGetWord(pVM);
    PUSHUNS((FICL_UNS)(si.cp[0]));
    return;
}

static void charCoIm(FICL_VM *pVM)
{
    ficlChar(pVM);
    literalIm(pVM);
    return;
}

/**************************************************************************
                        c h a r P l u s
** char-plus        CORE ( c-addr1 -- c-addr2 )
** Add the size in address units of a character to c-addr1, giving c-addr2.
**************************************************************************/
static void charPlus(FICL_VM *pVM)
{
    char *cp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,1);
#endif

    cp = POPPTR();
    PUSHPTR(cp + 1);
    return;
}

/**************************************************************************
                        c h a r s
** chars        CORE ( n1 -- n2 )
** n2 is the size in address units of n1 characters.
** For most processors, this function can be a no-op. To guarantee
** portability, we'll multiply by sizeof (char).
**************************************************************************/
#if defined (_M_IX86)
#pragma warning(disable: 4127)
#endif
static void ficlChars(FICL_VM *pVM)
{
    if (sizeof (char) > 1)
    {
        FICL_INT i;
#if FICL_ROBUST > 1
        vmCheckStack(pVM,1,1);
#endif
        i = POPINT();
        PUSHINT(i * sizeof (char));
    }
    /* otherwise no-op! */
    return;
}
#if defined (_M_IX86)
#pragma warning(default: 4127)
#endif


/**************************************************************************
                        c o u n t
** COUNT    CORE ( c-addr1 -- c-addr2 u )
** Return the character string specification for the counted string stored
** at c-addr1. c-addr2 is the address of the first character after c-addr1.
** u is the contents of the character at c-addr1, which is the length in
** characters of the string at c-addr2.
**************************************************************************/
static void count(FICL_VM *pVM)
{
    FICL_STRING *sp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,2);
#endif

    sp = POPPTR();
    PUSHPTR(sp->text);
    PUSHUNS(sp->count);
    return;
}

/**************************************************************************
                        e n v i r o n m e n t ?
** environment-query CORE ( c-addr u -- false | i*x true )
** c-addr is the address of a character string and u is the string's
** character count. u may have a value in the range from zero to an
** implementation-defined maximum which shall not be less than 31. The
** character string should contain a keyword from 3.2.6 Environmental
** queries or the optional word sets to be checked for correspondence
** with an attribute of the present environment. If the system treats the
** attribute as unknown, the returned flag is false; otherwise, the flag
** is true and the i*x returned is of the type specified in the table for
** the attribute queried.
**************************************************************************/
static void environmentQ(FICL_VM *pVM)
{
    FICL_DICT *envp;
    FICL_WORD *pFW;
    STRINGINFO si;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    envp = pVM->pSys->envp;
    si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
    si.cp    = stackPopPtr(pVM->pStack);

    pFW = dictLookup(envp, si);

    if (pFW != NULL)
    {
        vmExecute(pVM, pFW);
        PUSHINT(FICL_TRUE);
    }
    else
    {
        PUSHINT(FICL_FALSE);
    }
    return;
}

/**************************************************************************
                        e v a l u a t e
** EVALUATE CORE ( i*x c-addr u -- j*x )
** Save the current input source specification. Store minus-one (-1) in
** SOURCE-ID if it is present. Make the string described by c-addr and u
** both the input source and input buffer, set >IN to zero, and interpret.
** When the parse area is empty, restore the prior input source
** specification. Other stack effects are due to the words EVALUATEd.
**
**************************************************************************/
static void evaluate(FICL_VM *pVM)
{
    FICL_UNS count;
    char *cp;
    CELL id;
    int result;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,0);
#endif

    count = POPUNS();
    cp = POPPTR();

    IGNORE(count);
    id = pVM->sourceID;
    pVM->sourceID.i = -1;
    result = ficlExecC(pVM, cp, count);
    pVM->sourceID = id;
    if (result != VM_OUTOFTEXT)
        vmThrow(pVM, result);

    return;
}


/**************************************************************************
                        s t r i n g   q u o t e
** Interpreting: get string delimited by a quote from the input stream,
** copy to a scratch area, and put its count and address on the stack.
** Compiling: compile code to push the address and count of a string
** literal, compile the string from the input stream, and align the dict
** pointer.
**************************************************************************/
static void stringQuoteIm(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);

    if (pVM->state == INTERPRET)
    {
        FICL_STRING *sp = (FICL_STRING *) dp->here;
        vmGetString(pVM, sp, '\"');
        PUSHPTR(sp->text);
        PUSHUNS(sp->count);
    }
    else    /* COMPILE state */
    {
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
        dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
        dictAlign(dp);
    }

    return;
}


/**************************************************************************
                        t y p e
** Pop count and char address from stack and print the designated string.
**************************************************************************/
static void type(FICL_VM *pVM)
{
    FICL_UNS count = stackPopUNS(pVM->pStack);
    char *cp    = stackPopPtr(pVM->pStack);
    char *pDest = (char *)ficlMalloc(count + 1);

    /*
    ** Since we don't have an output primitive for a counted string
    ** (oops), make sure the string is null terminated. If not, copy
    ** and terminate it.
    */
    if (!pDest)
	vmThrowErr(pVM, "Error: out of memory");

    strncpy(pDest, cp, count);
    pDest[count] = '\0';

    vmTextOut(pVM, pDest, 0);

    ficlFree(pDest);
    return;
}

/**************************************************************************
                        w o r d
** word CORE ( char "<chars>ccc<char>" -- c-addr )
** Skip leading delimiters. Parse characters ccc delimited by char. An
** ambiguous condition exists if the length of the parsed string is greater
** than the implementation-defined length of a counted string.
**
** c-addr is the address of a transient region containing the parsed word
** as a counted string. If the parse area was empty or contained no
** characters other than the delimiter, the resulting string has a zero
** length. A space, not included in the length, follows the string. A
** program may replace characters within the string.
** NOTE! Ficl also NULL-terminates the dest string.
**************************************************************************/
static void ficlWord(FICL_VM *pVM)
{
    FICL_STRING *sp;
    char delim;
    STRINGINFO   si;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,1);
#endif

    sp = (FICL_STRING *)pVM->pad;
    delim = (char)POPINT();
    si = vmParseStringEx(pVM, delim, 1);

    if (SI_COUNT(si) > nPAD-1)
        SI_SETLEN(si, nPAD-1);

    sp->count = (FICL_COUNT)SI_COUNT(si);
    strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
    /*#$-GUY CHANGE: I added this.-$#*/
    sp->text[sp->count] = 0;
    strcat(sp->text, " ");

    PUSHPTR(sp);
    return;
}


/**************************************************************************
                        p a r s e - w o r d
** ficl   PARSE-WORD  ( <spaces>name -- c-addr u )
** Skip leading spaces and parse name delimited by a space. c-addr is the
** address within the input buffer and u is the length of the selected
** string. If the parse area is empty, the resulting string has a zero length.
**************************************************************************/
static void parseNoCopy(FICL_VM *pVM)
{
    STRINGINFO si;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,0,2);
#endif

    si = vmGetWord0(pVM);
    PUSHPTR(SI_PTR(si));
    PUSHUNS(SI_COUNT(si));
    return;
}


/**************************************************************************
                        p a r s e
** CORE EXT  ( char "ccc<char>" -- c-addr u )
** Parse ccc delimited by the delimiter char.
** c-addr is the address (within the input buffer) and u is the length of
** the parsed string. If the parse area was empty, the resulting string has
** a zero length.
** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
**************************************************************************/
static void parse(FICL_VM *pVM)
{
    STRINGINFO si;
    char delim;

#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,2);
#endif

    delim = (char)POPINT();

    si = vmParseStringEx(pVM, delim, 0);
    PUSHPTR(SI_PTR(si));
    PUSHUNS(SI_COUNT(si));
    return;
}


/**************************************************************************
                        f i l l
** CORE ( c-addr u char -- )
** If u is greater than zero, store char in each of u consecutive
** characters of memory beginning at c-addr.
**************************************************************************/
static void fill(FICL_VM *pVM)
{
    char ch;
    FICL_UNS u;
    char *cp;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,3,0);
#endif
    ch = (char)POPINT();
    u = POPUNS();
    cp = (char *)POPPTR();

    while (u > 0)
    {
        *cp++ = ch;
        u--;
    }
    return;
}


/**************************************************************************
                        f i n d
** FIND CORE ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
** Find the definition named in the counted string at c-addr. If the
** definition is not found, return c-addr and zero. If the definition is
** found, return its execution token xt. If the definition is immediate,
** also return one (1), otherwise also return minus-one (-1). For a given
** string, the values returned by FIND while compiling may differ from
** those returned while not compiling.
**************************************************************************/
static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
{
    FICL_WORD *pFW;

    pFW = dictLookup(vmGetDict(pVM), si);
    if (pFW)
    {
        PUSHPTR(pFW);
        PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
    }
    else
    {
        PUSHPTR(returnForFailure);
        PUSHUNS(0);
    }
    return;
}



/**************************************************************************
                        f i n d
** FIND CORE ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
** Find the definition named in the counted string at c-addr. If the
** definition is not found, return c-addr and zero. If the definition is
** found, return its execution token xt. If the definition is immediate,
** also return one (1), otherwise also return minus-one (-1). For a given
** string, the values returned by FIND while compiling may differ from
** those returned while not compiling.
**************************************************************************/
static void cFind(FICL_VM *pVM)
{
    FICL_STRING *sp;
    STRINGINFO si;

#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,2);
#endif
    sp = POPPTR();
    SI_PFS(si, sp);
    do_find(pVM, si, sp);
}



/**************************************************************************
                        s f i n d
** FICL   ( c-addr u -- 0 0  |  xt 1  |  xt -1 )
** Like FIND, but takes "c-addr u" for the string.
**************************************************************************/
static void sFind(FICL_VM *pVM)
{
    STRINGINFO si;

#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,2);
#endif

    si.count = stackPopINT(pVM->pStack);
    si.cp = stackPopPtr(pVM->pStack);

    do_find(pVM, si, NULL);
}



/**************************************************************************
                        f m S l a s h M o d
** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
** Input and output stack arguments are signed. An ambiguous condition
** exists if n1 is zero or if the quotient lies outside the range of a
** single-cell signed integer.
**************************************************************************/
static void fmSlashMod(FICL_VM *pVM)
{
    DPINT d1;
    FICL_INT n1;
    INTQR qr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,3,2);
#endif

    n1 = POPINT();
    d1 = i64Pop(pVM->pStack);
    qr = m64FlooredDivI(d1, n1);
    PUSHINT(qr.rem);
    PUSHINT(qr.quot);
    return;
}


/**************************************************************************
                        s m S l a s h R e m
** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
** Input and output stack arguments are signed. An ambiguous condition
** exists if n1 is zero or if the quotient lies outside the range of a
** single-cell signed integer.
**************************************************************************/
static void smSlashRem(FICL_VM *pVM)
{
    DPINT d1;
    FICL_INT n1;
    INTQR qr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,3,2);
#endif

    n1 = POPINT();
    d1 = i64Pop(pVM->pStack);
    qr = m64SymmetricDivI(d1, n1);
    PUSHINT(qr.rem);
    PUSHINT(qr.quot);
    return;
}


static void ficlMod(FICL_VM *pVM)
{
    DPINT d1;
    FICL_INT n1;
    INTQR qr;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    n1 = POPINT();
    d1.lo = POPINT();
    i64Extend(d1);
    qr = m64SymmetricDivI(d1, n1);
    PUSHINT(qr.rem);
    return;
}


/**************************************************************************
                        u m S l a s h M o d
** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
** Divide ud by u1, giving the quotient u3 and the remainder u2.
** All values and arithmetic are unsigned. An ambiguous condition
** exists if u1 is zero or if the quotient lies outside the range of a
** single-cell unsigned integer.
*************************************************************************/
static void umSlashMod(FICL_VM *pVM)
{
    DPUNS ud;
    FICL_UNS u1;
    UNSQR qr;

    u1    = stackPopUNS(pVM->pStack);
    ud    = u64Pop(pVM->pStack);
    qr    = ficlLongDiv(ud, u1);
    PUSHUNS(qr.rem);
    PUSHUNS(qr.quot);
    return;
}


/**************************************************************************
                        l s h i f t
** l-shift CORE ( x1 u -- x2 )
** Perform a logical left shift of u bit-places on x1, giving x2.
** Put zeroes into the least significant bits vacated by the shift.
** An ambiguous condition exists if u is greater than or equal to the
** number of bits in a cell.
**
** r-shift CORE ( x1 u -- x2 )
** Perform a logical right shift of u bit-places on x1, giving x2.
** Put zeroes into the most significant bits vacated by the shift. An
** ambiguous condition exists if u is greater than or equal to the
** number of bits in a cell.
**************************************************************************/
static void lshift(FICL_VM *pVM)
{
    FICL_UNS nBits;
    FICL_UNS x1;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    nBits = POPUNS();
    x1 = POPUNS();
    PUSHUNS(x1 << nBits);
    return;
}


static void rshift(FICL_VM *pVM)
{
    FICL_UNS nBits;
    FICL_UNS x1;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    nBits = POPUNS();
    x1 = POPUNS();

    PUSHUNS(x1 >> nBits);
    return;
}


/**************************************************************************
                        m S t a r
** m-star CORE ( n1 n2 -- d )
** d is the signed product of n1 times n2.
**************************************************************************/
static void mStar(FICL_VM *pVM)
{
    FICL_INT n2;
    FICL_INT n1;
    DPINT d;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,2);
#endif

    n2 = POPINT();
    n1 = POPINT();

    d = m64MulI(n1, n2);
    i64Push(pVM->pStack, d);
    return;
}


static void umStar(FICL_VM *pVM)
{
    FICL_UNS u2;
    FICL_UNS u1;
    DPUNS ud;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,2);
#endif

    u2 = POPUNS();
    u1 = POPUNS();

    ud = ficlLongMul(u1, u2);
    u64Push(pVM->pStack, ud);
    return;
}


/**************************************************************************
                        m a x   &   m i n
**
**************************************************************************/
static void ficlMax(FICL_VM *pVM)
{
    FICL_INT n2;
    FICL_INT n1;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    n2 = POPINT();
    n1 = POPINT();

    PUSHINT((n1 > n2) ? n1 : n2);
    return;
}

static void ficlMin(FICL_VM *pVM)
{
    FICL_INT n2;
    FICL_INT n1;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,1);
#endif

    n2 = POPINT();
    n1 = POPINT();

    PUSHINT((n1 < n2) ? n1 : n2);
    return;
}


/**************************************************************************
                        m o v e
** CORE ( addr1 addr2 u -- )
** If u is greater than zero, copy the contents of u consecutive address
** units at addr1 to the u consecutive address units at addr2. After MOVE
** completes, the u consecutive address units at addr2 contain exactly
** what the u consecutive address units at addr1 contained before the move.
** NOTE! This implementation assumes that a char is the same size as
**       an address unit.
**************************************************************************/
static void move(FICL_VM *pVM)
{
    FICL_UNS u;
    char *addr2;
    char *addr1;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,3,0);
#endif

    u = POPUNS();
    addr2 = POPPTR();
    addr1 = POPPTR();

    if (u == 0)
        return;
    /*
    ** Do the copy carefully, so as to be
    ** correct even if the two ranges overlap
    */
    if (addr1 >= addr2)
    {
        for (; u > 0; u--)
            *addr2++ = *addr1++;
    }
    else
    {
        addr2 += u-1;
        addr1 += u-1;
        for (; u > 0; u--)
            *addr2-- = *addr1--;
    }

    return;
}


/**************************************************************************
                        r e c u r s e
**
**************************************************************************/
static void recurseCoIm(FICL_VM *pVM)
{
    FICL_DICT *pDict = vmGetDict(pVM);

    IGNORE(pVM);
    dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
    return;
}


/**************************************************************************
                        s t o d
** s-to-d CORE ( n -- d )
** Convert the number n to the double-cell number d with the same
** numerical value.
**************************************************************************/
static void sToD(FICL_VM *pVM)
{
    FICL_INT s;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,1,2);
#endif

    s = POPINT();

    /* sign extend to 64 bits.. */
    PUSHINT(s);
    PUSHINT((s < 0) ? -1 : 0);
    return;
}


/**************************************************************************
                        s o u r c e
** CORE ( -- c-addr u )
** c-addr is the address of, and u is the number of characters in, the
** input buffer.
**************************************************************************/
static void source(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM,0,2);
#endif
    PUSHPTR(pVM->tib.cp);
    PUSHINT(vmGetInBufLen(pVM));
    return;
}


/**************************************************************************
                        v e r s i o n
** non-standard...
**************************************************************************/
static void ficlVersion(FICL_VM *pVM)
{
    vmTextOut(pVM, "ficl Version " FICL_VER, 1);
    return;
}


/**************************************************************************
                        t o I n
** to-in CORE
**************************************************************************/
static void toIn(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
    vmCheckStack(pVM,0,1);
#endif
    PUSHPTR(&pVM->tib.index);
    return;
}


/**************************************************************************
                        c o l o n N o N a m e
** CORE EXT ( C:  -- colon-sys )  ( S:  -- xt )
** Create an unnamed colon definition and push its address.
** Change state to compile.
**************************************************************************/
static void colonNoName(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    FICL_WORD *pFW;
    STRINGINFO si;

    SI_SETLEN(si, 0);
    SI_SETPTR(si, NULL);

    pVM->state = COMPILE;
    pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
    PUSHPTR(pFW);
    markControlTag(pVM, colonTag);
    return;
}


/**************************************************************************
                        u s e r   V a r i a b l e
** user  ( u -- )  "<spaces>name"
** Get a name from the input stream and create a user variable
** with the name and the index supplied. The run-time effect
** of a user variable is to push the address of the indexed cell
** in the running vm's user array.
**
** User variables are vm local cells. Each vm has an array of
** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
** Ficl's user facility is implemented with two primitives,
** "user" and "(user)", a variable ("nUser") (in softcore.c) that
** holds the index of the next free user cell, and a redefinition
** (also in softcore) of "user" that defines a user word and increments
** nUser.
**************************************************************************/
#if FICL_WANT_USER
static void userParen(FICL_VM *pVM)
{
    FICL_INT i = pVM->runningWord->param[0].i;
    PUSHPTR(&pVM->user[i]);
    return;
}


static void userVariable(FICL_VM *pVM)
{
    FICL_DICT *dp = vmGetDict(pVM);
    STRINGINFO si = vmGetWord(pVM);
    CELL c;

    c = stackPop(pVM->pStack);
    if (c.i >= FICL_USER_CELLS)
    {
        vmThrowErr(pVM, "Error - out of user space");
    }

    dictAppendWord2(dp, si, userParen, FW_DEFAULT);
    dictAppendCell(dp, c);
    return;
}
#endif


/**************************************************************************
                        t o V a l u e
** CORE EXT
** Interpretation: ( x "<spaces>name" -- )
** Skip leading spaces and parse name delimited by a space. Store x in
** name. An ambiguous condition exists if name was not defined by VALUE.
** NOTE: In ficl, VALUE is an alias of CONSTANT
**************************************************************************/
static void toValue(FICL_VM *pVM)
{
    STRINGINFO si = vmGetWord(pVM);
    FICL_DICT *dp = vmGetDict(pVM);
    FICL_WORD *pFW;

#if FICL_WANT_LOCALS
    if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
    {
        FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
        pFW = dictLookup(pLoc, si);
        if (pFW && (pFW->code == doLocalIm))
        {
            dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
            dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
            return;
        }
        else if (pFW && pFW->code == do2LocalIm)
        {
            dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
            dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
            return;
        }
    }
#endif

    assert(pVM->pSys->pStore);

    pFW = dictLookup(dp, si);
    if (!pFW)
    {
        int i = SI_COUNT(si);
        vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
    }

    if (pVM->state == INTERPRET)
        pFW->param[0] = stackPop(pVM->pStack);
    else        /* compile code to store to word's param */
    {
        PUSHPTR(&pFW->param[0]);
        literalIm(pVM);
        dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
    }
    return;
}


#if FICL_WANT_LOCALS
/**************************************************************************
                        l i n k P a r e n
** ( -- )
** Link a frame on the return stack, reserving nCells of space for
** locals - the value of nCells is the next cell in the instruction
** stream.
**************************************************************************/
static void linkParen(FICL_VM *pVM)
{
    FICL_INT nLink = *(FICL_INT *)(pVM->ip);
    vmBranchRelative(pVM, 1);
    stackLink(pVM->rStack, nLink);
    return;
}


static void unlinkParen(FICL_VM *pVM)
{
    stackUnlink(pVM->rStack);
    return;
}


/**************************************************************************
                        d o L o c a l I m
** Immediate - cfa of a local while compiling - when executed, compiles
** code to fetch the value of a local given the local's index in the
** word's pfa
**************************************************************************/
static void getLocalParen(FICL_VM *pVM)
{
    FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
    stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
    return;
}


static void toLocalParen(FICL_VM *pVM)
{
    FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
    pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
    return;
}


static void getLocal0(FICL_VM *pVM)
{
    stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
    return;
}


static void toLocal0(FICL_VM *pVM)
{
    pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
    return;
}


static void getLocal1(FICL_VM *pVM)
{
    stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
    return;
}


static void toLocal1(FICL_VM *pVM)
{
    pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
    return;
}


/*
** Each local is recorded in a private locals dictionary as a
** word that does doLocalIm at runtime. DoLocalIm compiles code
** into the client definition to fetch the value of the
** corresponding local variable from the return stack.
** The private dictionary gets initialized at the end of each block
** that uses locals (in ; and does> for example).
*/
static void doLocalIm(FICL_VM *pVM)
{
    FICL_DICT *pDict = vmGetDict(pVM);
    FICL_INT nLocal = pVM->runningWord->param[0].i;

    if (pVM->state == INTERPRET)
    {
        stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
    }
    else
    {

        if (nLocal == 0)
        {
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
        }
        else if (nLocal == 1)
        {
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
        }
        else
        {
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
            dictAppendCell(pDict, LVALUEtoCELL(nLocal));
        }
    }
    return;
}


/**************************************************************************
                        l o c a l P a r e n
** paren-local-paren LOCAL
** Interpretation: Interpretation semantics for this word are undefined.
** Execution: ( c-addr u -- )
** When executed during compilation, (LOCAL) passes a message to the
** system that has one of two meanings. If u is non-zero,
** the message identifies a new local whose definition name is given by
** the string of characters identified by c-addr u. If u is zero,
** the message is last local and c-addr has no significance.
**
** The result of executing (LOCAL) during compilation of a definition is
** to create a set of named local identifiers, each of which is
** a definition name, that only have execution semantics within the scope
** of that definition's source.
**
** local Execution: ( -- x )
**
** Push the local's value, x, onto the stack. The local's value is
** initialized as described in 13.3.3 Processing locals and may be
** changed by preceding the local's name with TO. An ambiguous condition
** exists when local is executed while in interpretation state.
**************************************************************************/
static void localParen(FICL_VM *pVM)
{
    FICL_DICT *pDict;
    STRINGINFO si;
#if FICL_ROBUST > 1
    vmCheckStack(pVM,2,0);
#endif

    pDict = vmGetDict(pVM);
    SI_SETLEN(si, POPUNS());
    SI_SETPTR(si, (char *)POPPTR());

    if (SI_COUNT(si) > 0)
    {   /* add a local to the **locals** dict and update nLocals */
        FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
        if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
        {
            vmThrowErr(pVM, "Error: out of local space");
        }

        dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
        dictAppendCell(pLoc,  LVALUEtoCELL(pVM->pSys->nLocals));

        if (pVM->pSys->nLocals == 0)
        {   /* compile code to create a local stack frame */
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
            /* save location in dictionary for #locals */
            pVM->pSys->pMarkLocals = pDict->here;
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
            /* compile code to initialize first local */
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
        }
        else if (pVM->pSys->nLocals == 1)
        {
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
        }
        else
        {
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
        }

        (pVM->pSys->nLocals)++;
    }
    else if (pVM->pSys->nLocals > 0)
    {       /* write nLocals to (link) param area in dictionary */
        *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
    }

    return;
}


static void get2LocalParen(FICL_VM *pVM)
{
    FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
    stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
    stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
    return;
}


static void do2LocalIm(FICL_VM *pVM)
{
    FICL_DICT *pDict = vmGetDict(pVM);
    FICL_INT nLocal = pVM->runningWord->param[0].i;

    if (pVM->state == INTERPRET)
    {
        stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
        stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
    }
    else
    {
        dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
        dictAppendCell(pDict, LVALUEtoCELL(nLocal));
    }
    return;
}


static void to2LocalParen(FICL_VM *pVM)
{
    FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
    pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
    pVM->rStack->pFrame[nLocal]   = stackPop(pVM->pStack);
    return;
}


static void twoLocalParen(FICL_VM *pVM)
{
    FICL_DICT *pDict = vmGetDict(pVM);
    STRINGINFO si;
    SI_SETLEN(si, stackPopUNS(pVM->pStack));
    SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));

    if (SI_COUNT(si) > 0)
    {   /* add a local to the **locals** dict and update nLocals */
        FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
        if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
        {
            vmThrowErr(pVM, "Error: out of local space");
        }

        dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
        dictAppendCell(pLoc,  LVALUEtoCELL(pVM->pSys->nLocals));

        if (pVM->pSys->nLocals == 0)
        {   /* compile code to create a local stack frame */
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
            /* save location in dictionary for #locals */
            pVM->pSys->pMarkLocals = pDict->here;
            dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
        }

        dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
        dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));

        pVM->pSys->nLocals += 2;
    }
    else if (pVM->pSys->nLocals > 0)
    {       /* write nLocals to (link) param area in dictionary */
        *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
    }

    return;
}


#endif
/**************************************************************************
                        c o m p a r e
** STRING ( c-addr1 u1 c-addr2 u2 -- n )
** Compare the string specified by c-addr1 u1 to the string specified by
** c-addr2 u2. The strings are compared, beginning at the given addresses,
** character by character, up to the length of the shorter string or until a
** difference is found. If the two strings are identical, n is zero. If the two
** strings are identical up to the length of the shorter string, n is minus-one
** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
** identical up to the length of the shorter string, n is minus-one (-1) if the
** first non-matching character in the string specified by c-addr1 u1 has a
** lesser numeric value than the corresponding character in the string specified
** by c-addr2 u2 and one (1) otherwise.
**************************************************************************/
static void compareInternal(FICL_VM *pVM, int caseInsensitive)
{
    char *cp1, *cp2;
    FICL_UNS u1, u2, uMin;
    int n = 0;

    vmCheckStack(pVM, 4, 1);
    u2  = stackPopUNS(pVM->pStack);
    cp2 = (char *)stackPopPtr(pVM->pStack);
    u1  = stackPopUNS(pVM->pStack);
    cp1 = (char *)stackPopPtr(pVM->pStack);

    uMin = (u1 < u2)? u1 : u2;
    for ( ; (uMin > 0) && (n == 0); uMin--)
    {
		char c1 = *cp1++;
		char c2 = *cp2++;
		if (caseInsensitive)
		{
			c1 = (char)tolower(c1);
			c2 = (char)tolower(c2);
		}
        n = (int)(c1 - c2);
    }

    if (n == 0)
        n = (int)(u1 - u2);

    if (n < 0)
        n = -1;
    else if (n > 0)
        n = 1;

    PUSHINT(n);
    return;
}


static void compareString(FICL_VM *pVM)
{
	compareInternal(pVM, FALSE);
}


static void compareStringInsensitive(FICL_VM *pVM)
{
	compareInternal(pVM, TRUE);
}


/**************************************************************************
                        p a d
** CORE EXT  ( -- c-addr )
** c-addr is the address of a transient region that can be used to hold
** data for intermediate processing.
**************************************************************************/
static void pad(FICL_VM *pVM)
{
    stackPushPtr(pVM->pStack, pVM->pad);
}


/**************************************************************************
                        s o u r c e - i d
** CORE EXT, FILE   ( -- 0 | -1 | fileid )
**    Identifies the input source as follows:
**
** SOURCE-ID       Input source
** ---------       ------------
** fileid          Text file fileid
** -1              String (via EVALUATE)
** 0               User input device
**************************************************************************/
static void sourceid(FICL_VM *pVM)
{
    PUSHINT(pVM->sourceID.i);
    return;
}


/**************************************************************************
                        r e f i l l
** CORE EXT   ( -- flag )
** Attempt to fill the input buffer from the input source, returning a true
** flag if successful.
** When the input source is the user input device, attempt to receive input
** into the terminal input buffer. If successful, make the result the input
** buffer, set >IN to zero, and return true. Receipt of a line containing no
** characters is considered successful. If there is no input available from
** the current input source, return false.
** When the input source is a string from EVALUATE, return false and
** perform no other action.
**************************************************************************/
static void refill(FICL_VM *pVM)
{
    FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
    if (ret && (pVM->fRestart == 0))
        vmThrow(pVM, VM_RESTART);

    PUSHINT(ret);
    return;
}


/**************************************************************************
                        freebsd exception handling words
** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
** the word in ToS. If an exception happens, restore the state to what
** it was before, and pushes the exception value on the stack. If not,
** push zero.
**
** Notice that Catch implements an inner interpreter. This is ugly,
** but given how ficl works, it cannot be helped. The problem is that
** colon definitions will be executed *after* the function returns,
** while "code" definitions will be executed immediately. I considered
** other solutions to this problem, but all of them shared the same
** basic problem (with added disadvantages): if ficl ever changes it's
** inner thread modus operandi, one would have to fix this word.
**
** More comments can be found throughout catch's code.
**
** Daniel C. Sobral Jan 09/1999
** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
**************************************************************************/

static void ficlCatch(FICL_VM *pVM)
{
    int         except;
    jmp_buf     vmState;
    FICL_VM     VM;
    FICL_STACK  pStack;
    FICL_STACK  rStack;
    FICL_WORD   *pFW;

    assert(pVM);
    assert(pVM->pSys->pExitInner);


    /*
    ** Get xt.
    ** We need this *before* we save the stack pointer, or
    ** we'll have to pop one element out of the stack after
    ** an exception. I prefer to get done with it up front. :-)
    */
#if FICL_ROBUST > 1
    vmCheckStack(pVM, 1, 0);
#endif
    pFW = stackPopPtr(pVM->pStack);

    /*
    ** Save vm's state -- a catch will not back out environmental
    ** changes.
    **
    ** We are *not* saving dictionary state, since it is
    ** global instead of per vm, and we are not saving
    ** stack contents, since we are not required to (and,
    ** thus, it would be useless). We save pVM, and pVM
    ** "stacks" (a structure containing general information
    ** about it, including the current stack pointer).
    */
    memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
    memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
    memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));

    /*
    ** Give pVM a jmp_buf
    */
    pVM->pState = &vmState;

    /*
    ** Safety net
    */
    except = setjmp(vmState);

    switch (except)
    {
        /*
        ** Setup condition - push poison pill so that the VM throws
        ** VM_INNEREXIT if the XT terminates normally, then execute
        ** the XT
        */
    case 0:
        vmPushIP(pVM, &(pVM->pSys->pExitInner));          /* Open mouth, insert emetic */
        vmExecute(pVM, pFW);
        vmInnerLoop(pVM);
        break;

        /*
        ** Normal exit from XT - lose the poison pill,
        ** restore old setjmp vector and push a zero.
        */
    case VM_INNEREXIT:
        vmPopIP(pVM);                   /* Gack - hurl poison pill */
        pVM->pState = VM.pState;        /* Restore just the setjmp vector */
        PUSHINT(0);   /* Push 0 -- everything is ok */
        break;

        /*
        ** Some other exception got thrown - restore pre-existing VM state
        ** and push the exception code
        */
    default:
        /* Restore vm's state */
        memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
        memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
        memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));

        PUSHINT(except);/* Push error */
        break;
    }
}

/**************************************************************************
**                     t h r o w
** EXCEPTION
** Throw --  From ANS Forth standard.
**
** Throw takes the ToS and, if that's different from zero,
** returns to the last executed catch context. Further throws will
** unstack previously executed "catches", in LIFO mode.
**
** Daniel C. Sobral Jan 09/1999
**************************************************************************/
static void ficlThrow(FICL_VM *pVM)
{
    int except;

    except = stackPopINT(pVM->pStack);

    if (except)
        vmThrow(pVM, except);
}


/**************************************************************************
**                     a l l o c a t e
** MEMORY
**************************************************************************/
static void ansAllocate(FICL_VM *pVM)
{
    size_t size;
    void *p;

    size = stackPopINT(pVM->pStack);
    p = ficlMalloc(size);
    PUSHPTR(p);
    if (p)
        PUSHINT(0);
    else
        PUSHINT(1);
}


/**************************************************************************
**                     f r e e
** MEMORY
**************************************************************************/
static void ansFree(FICL_VM *pVM)
{
    void *p;

    p = stackPopPtr(pVM->pStack);
    ficlFree(p);
    PUSHINT(0);
}


/**************************************************************************
**                     r e s i z e
** MEMORY
**************************************************************************/
static void ansResize(FICL_VM *pVM)
{
    size_t size;
    void *new, *old;

    size = stackPopINT(pVM->pStack);
    old = stackPopPtr(pVM->pStack);
    new = ficlRealloc(old, size);
    if (new)
    {
        PUSHPTR(new);
        PUSHINT(0);
    }
    else
    {
        PUSHPTR(old);
        PUSHINT(1);
    }
}


/**************************************************************************
**                     e x i t - i n n e r
** Signals execXT that an inner loop has completed
**************************************************************************/
static void ficlExitInner(FICL_VM *pVM)
{
    vmThrow(pVM, VM_INNEREXIT);
}


/**************************************************************************
                        d n e g a t e
** DOUBLE   ( d1 -- d2 )
** d2 is the negation of d1.
**************************************************************************/
static void dnegate(FICL_VM *pVM)
{
    DPINT i = i64Pop(pVM->pStack);
    i = m64Negate(i);
    i64Push(pVM->pStack, i);

    return;
}


#if 0
/**************************************************************************

**
**************************************************************************/
static void funcname(FICL_VM *pVM)
{
    IGNORE(pVM);
    return;
}


#endif
/**************************************************************************
                        f i c l W o r d C l a s s i f y
** This public function helps to classify word types for SEE
** and the deugger in tools.c. Given a pointer to a word, it returns
** a member of WOR
**************************************************************************/
WORDKIND ficlWordClassify(FICL_WORD *pFW)
{
    typedef struct
    {
        WORDKIND kind;
        FICL_CODE code;
    } CODEtoKIND;

    static CODEtoKIND codeMap[] =
    {
        {BRANCH,     branchParen},
        {COLON,       colonParen},
        {CONSTANT, constantParen},
        {CREATE,     createParen},
        {DO,             doParen},
        {DOES,            doDoes},
        {IF,             branch0},
        {LITERAL,   literalParen},
        {LOOP,         loopParen},
        {OF,             ofParen},
        {PLOOP,    plusLoopParen},
        {QDO,           qDoParen},
        {CSTRINGLIT,  cstringLit},
        {STRINGLIT,    stringLit},
#if FICL_WANT_USER
        {USER,         userParen},
#endif
        {VARIABLE, variableParen},
    };

#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))

    FICL_CODE code = pFW->code;
    int i;

    for (i=0; i < nMAP; i++)
    {
        if (codeMap[i].code == code)
            return codeMap[i].kind;
    }

    return PRIMITIVE;
}


#ifdef TESTMAIN
/**************************************************************************
**                     r a n d o m
** FICL-specific
**************************************************************************/
static void ficlRandom(FICL_VM *pVM)
{
    PUSHUNS(random());
}


/**************************************************************************
**                     s e e d - r a n d o m
** FICL-specific
**************************************************************************/
static void ficlSeedRandom(FICL_VM *pVM)
{
    srandom(POPUNS());
}
#endif


/**************************************************************************
                        f i c l C o m p i l e C o r e
** Builds the primitive wordset and the environment-query namespace.
**************************************************************************/

void ficlCompileCore(FICL_SYSTEM *pSys)
{
    FICL_DICT *dp = pSys->dp;
    assert (dp);


    /*
    ** CORE word set
    ** see softcore.c for definitions of: abs bl space spaces abort"
    */
    pSys->pStore =
    dictAppendWord(dp, "!",         store,          FW_DEFAULT);
    dictAppendWord(dp, "#",         numberSign,     FW_DEFAULT);
    dictAppendWord(dp, "#>",        numberSignGreater,FW_DEFAULT);
    dictAppendWord(dp, "#s",        numberSignS,    FW_DEFAULT);
    dictAppendWord(dp, "\'",        ficlTick,       FW_DEFAULT);
    dictAppendWord(dp, "(",         commentHang,    FW_IMMEDIATE);
    dictAppendWord(dp, "*",         mul,            FW_DEFAULT);
    dictAppendWord(dp, "*/",        mulDiv,         FW_DEFAULT);
    dictAppendWord(dp, "*/mod",     mulDivRem,      FW_DEFAULT);
    dictAppendWord(dp, "+",         add,            FW_DEFAULT);
    dictAppendWord(dp, "+!",        plusStore,      FW_DEFAULT);
    dictAppendWord(dp, "+loop",     plusLoopCoIm,   FW_COMPIMMED);
    dictAppendWord(dp, ",",         comma,          FW_DEFAULT);
    dictAppendWord(dp, "-",         sub,            FW_DEFAULT);
    dictAppendWord(dp, ".",         displayCell,    FW_DEFAULT);
    dictAppendWord(dp, ".\"",       dotQuoteCoIm,   FW_COMPIMMED);
    dictAppendWord(dp, "/",         ficlDiv,        FW_DEFAULT);
    dictAppendWord(dp, "/mod",      slashMod,       FW_DEFAULT);
    dictAppendWord(dp, "0<",        zeroLess,       FW_DEFAULT);
    dictAppendWord(dp, "0=",        zeroEquals,     FW_DEFAULT);
    dictAppendWord(dp, "1+",        onePlus,        FW_DEFAULT);
    dictAppendWord(dp, "1-",        oneMinus,       FW_DEFAULT);
    dictAppendWord(dp, "2!",        twoStore,       FW_DEFAULT);
    dictAppendWord(dp, "2*",        twoMul,         FW_DEFAULT);
    dictAppendWord(dp, "2/",        twoDiv,         FW_DEFAULT);
    dictAppendWord(dp, "2@",        twoFetch,       FW_DEFAULT);
    dictAppendWord(dp, "2drop",     twoDrop,        FW_DEFAULT);
    dictAppendWord(dp, "2dup",      twoDup,         FW_DEFAULT);
    dictAppendWord(dp, "2over",     twoOver,        FW_DEFAULT);
    dictAppendWord(dp, "2swap",     twoSwap,        FW_DEFAULT);
    dictAppendWord(dp, ":",         colon,          FW_DEFAULT);
    dictAppendWord(dp, ";",         semicolonCoIm,  FW_COMPIMMED);
    dictAppendWord(dp, "<",         isLess,         FW_DEFAULT);
    dictAppendWord(dp, "<#",        lessNumberSign, FW_DEFAULT);
    dictAppendWord(dp, "=",         isEqual,        FW_DEFAULT);
    dictAppendWord(dp, ">",         isGreater,      FW_DEFAULT);
    dictAppendWord(dp, ">body",     toBody,         FW_DEFAULT);
    dictAppendWord(dp, ">in",       toIn,           FW_DEFAULT);
    dictAppendWord(dp, ">number",   toNumber,       FW_DEFAULT);
    dictAppendWord(dp, ">r",        toRStack,       FW_COMPILE);
    dictAppendWord(dp, "?dup",      questionDup,    FW_DEFAULT);
    dictAppendWord(dp, "@",         fetch,          FW_DEFAULT);
    dictAppendWord(dp, "abort",     ficlAbort,      FW_DEFAULT);
    dictAppendWord(dp, "accept",    accept,         FW_DEFAULT);
    dictAppendWord(dp, "align",     align,          FW_DEFAULT);
    dictAppendWord(dp, "aligned",   aligned,        FW_DEFAULT);
    dictAppendWord(dp, "allot",     allot,          FW_DEFAULT);
    dictAppendWord(dp, "and",       bitwiseAnd,     FW_DEFAULT);
    dictAppendWord(dp, "base",      base,           FW_DEFAULT);
    dictAppendWord(dp, "begin",     beginCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "c!",        cStore,         FW_DEFAULT);
    dictAppendWord(dp, "c,",        cComma,         FW_DEFAULT);
    dictAppendWord(dp, "c@",        cFetch,         FW_DEFAULT);
    dictAppendWord(dp, "case",      caseCoIm,       FW_COMPIMMED);
    dictAppendWord(dp, "cell+",     cellPlus,       FW_DEFAULT);
    dictAppendWord(dp, "cells",     cells,          FW_DEFAULT);
    dictAppendWord(dp, "char",      ficlChar,       FW_DEFAULT);
    dictAppendWord(dp, "char+",     charPlus,       FW_DEFAULT);
    dictAppendWord(dp, "chars",     ficlChars,      FW_DEFAULT);
    dictAppendWord(dp, "constant",  constant,       FW_DEFAULT);
    dictAppendWord(dp, "count",     count,          FW_DEFAULT);
    dictAppendWord(dp, "cr",        cr,             FW_DEFAULT);
    dictAppendWord(dp, "create",    create,         FW_DEFAULT);
    dictAppendWord(dp, "decimal",   decimal,        FW_DEFAULT);
    dictAppendWord(dp, "depth",     depth,          FW_DEFAULT);
    dictAppendWord(dp, "do",        doCoIm,         FW_COMPIMMED);
    dictAppendWord(dp, "does>",     doesCoIm,       FW_COMPIMMED);
    pSys->pDrop =
    dictAppendWord(dp, "drop",      drop,           FW_DEFAULT);
    dictAppendWord(dp, "dup",       dup,            FW_DEFAULT);
    dictAppendWord(dp, "else",      elseCoIm,       FW_COMPIMMED);
    dictAppendWord(dp, "emit",      emit,           FW_DEFAULT);
    dictAppendWord(dp, "endcase",   endcaseCoIm,    FW_COMPIMMED);
    dictAppendWord(dp, "endof",     endofCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
    dictAppendWord(dp, "evaluate",  evaluate,       FW_DEFAULT);
    dictAppendWord(dp, "execute",   execute,        FW_DEFAULT);
    dictAppendWord(dp, "exit",      exitCoIm,       FW_COMPIMMED);
    dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED);
    dictAppendWord(dp, "fill",      fill,           FW_DEFAULT);
    dictAppendWord(dp, "find",      cFind,          FW_DEFAULT);
    dictAppendWord(dp, "fm/mod",    fmSlashMod,     FW_DEFAULT);
    dictAppendWord(dp, "here",      here,           FW_DEFAULT);
    dictAppendWord(dp, "hold",      hold,           FW_DEFAULT);
    dictAppendWord(dp, "i",         loopICo,        FW_COMPILE);
    dictAppendWord(dp, "if",        ifCoIm,         FW_COMPIMMED);
    dictAppendWord(dp, "immediate", immediate,      FW_DEFAULT);
    dictAppendWord(dp, "invert",    bitwiseNot,     FW_DEFAULT);
    dictAppendWord(dp, "j",         loopJCo,        FW_COMPILE);
    dictAppendWord(dp, "k",         loopKCo,        FW_COMPILE);
    dictAppendWord(dp, "leave",     leaveCo,        FW_COMPILE);
    dictAppendWord(dp, "literal",   literalIm,      FW_IMMEDIATE);
    dictAppendWord(dp, "loop",      loopCoIm,       FW_COMPIMMED);
    dictAppendWord(dp, "lshift",    lshift,         FW_DEFAULT);
    dictAppendWord(dp, "m*",        mStar,          FW_DEFAULT);
    dictAppendWord(dp, "max",       ficlMax,        FW_DEFAULT);
    dictAppendWord(dp, "min",       ficlMin,        FW_DEFAULT);
    dictAppendWord(dp, "mod",       ficlMod,        FW_DEFAULT);
    dictAppendWord(dp, "move",      move,           FW_DEFAULT);
    dictAppendWord(dp, "negate",    negate,         FW_DEFAULT);
    dictAppendWord(dp, "of",        ofCoIm,         FW_COMPIMMED);
    dictAppendWord(dp, "or",        bitwiseOr,      FW_DEFAULT);
    dictAppendWord(dp, "over",      over,           FW_DEFAULT);
    dictAppendWord(dp, "postpone",  postponeCoIm,   FW_COMPIMMED);
    dictAppendWord(dp, "quit",      quit,           FW_DEFAULT);
    dictAppendWord(dp, "r>",        fromRStack,     FW_COMPILE);
    dictAppendWord(dp, "r@",        fetchRStack,    FW_COMPILE);
    dictAppendWord(dp, "recurse",   recurseCoIm,    FW_COMPIMMED);
    dictAppendWord(dp, "repeat",    repeatCoIm,     FW_COMPIMMED);
    dictAppendWord(dp, "rot",       rot,            FW_DEFAULT);
    dictAppendWord(dp, "rshift",    rshift,         FW_DEFAULT);
    dictAppendWord(dp, "s\"",       stringQuoteIm,  FW_IMMEDIATE);
    dictAppendWord(dp, "s>d",       sToD,           FW_DEFAULT);
    dictAppendWord(dp, "sign",      sign,           FW_DEFAULT);
    dictAppendWord(dp, "sm/rem",    smSlashRem,     FW_DEFAULT);
    dictAppendWord(dp, "source",    source,         FW_DEFAULT);
    dictAppendWord(dp, "state",     state,          FW_DEFAULT);
    dictAppendWord(dp, "swap",      swap,           FW_DEFAULT);
    dictAppendWord(dp, "then",      endifCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "type",      type,           FW_DEFAULT);
    dictAppendWord(dp, "u.",        uDot,           FW_DEFAULT);
    dictAppendWord(dp, "u<",        uIsLess,        FW_DEFAULT);
    dictAppendWord(dp, "u>",        uIsGreater,     FW_DEFAULT);
    dictAppendWord(dp, "um*",       umStar,         FW_DEFAULT);
    dictAppendWord(dp, "um/mod",    umSlashMod,     FW_DEFAULT);
    dictAppendWord(dp, "unloop",    unloopCo,       FW_COMPILE);
    dictAppendWord(dp, "until",     untilCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "variable",  variable,       FW_DEFAULT);
    dictAppendWord(dp, "while",     whileCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "word",      ficlWord,       FW_DEFAULT);
    dictAppendWord(dp, "xor",       bitwiseXor,     FW_DEFAULT);
    dictAppendWord(dp, "[",         lbracketCoIm,   FW_COMPIMMED);
    dictAppendWord(dp, "[\']",      bracketTickCoIm,FW_COMPIMMED);
    dictAppendWord(dp, "[char]",    charCoIm,       FW_COMPIMMED);
    dictAppendWord(dp, "]",         rbracket,       FW_DEFAULT);
    /*
    ** CORE EXT word set...
    ** see softcore.fr for other definitions
    */
    /* "#tib" */
    dictAppendWord(dp, ".(",        dotParen,       FW_IMMEDIATE);
    /* ".r" */
    dictAppendWord(dp, "0>",        zeroGreater,    FW_DEFAULT);
    dictAppendWord(dp, "2>r",       twoToR,         FW_COMPILE);
    dictAppendWord(dp, "2r>",       twoRFrom,       FW_COMPILE);
    dictAppendWord(dp, "2r@",       twoRFetch,      FW_COMPILE);
    dictAppendWord(dp, ":noname",   colonNoName,    FW_DEFAULT);
    dictAppendWord(dp, "?do",       qDoCoIm,        FW_COMPIMMED);
    dictAppendWord(dp, "again",     againCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "c\"",       cstringQuoteIm, FW_IMMEDIATE);
    dictAppendWord(dp, "hex",       hex,            FW_DEFAULT);
    dictAppendWord(dp, "pad",       pad,            FW_DEFAULT);
    dictAppendWord(dp, "parse",     parse,          FW_DEFAULT);
    dictAppendWord(dp, "pick",      pick,           FW_DEFAULT);
    /* query restore-input save-input tib u.r u> unused [compile] */
    dictAppendWord(dp, "roll",      roll,           FW_DEFAULT);
    dictAppendWord(dp, "refill",    refill,         FW_DEFAULT);
    dictAppendWord(dp, "source-id", sourceid,       FW_DEFAULT);
    dictAppendWord(dp, "to",        toValue,        FW_IMMEDIATE);
    dictAppendWord(dp, "value",     constant,       FW_DEFAULT);
    dictAppendWord(dp, "\\",        commentLine,    FW_IMMEDIATE);


    /*
    ** Set CORE environment query values
    */
    ficlSetEnv(pSys, "/counted-string",   FICL_STRING_MAX);
    ficlSetEnv(pSys, "/hold",             nPAD);
    ficlSetEnv(pSys, "/pad",              nPAD);
    ficlSetEnv(pSys, "address-unit-bits", 8);
    ficlSetEnv(pSys, "core",              FICL_TRUE);
    ficlSetEnv(pSys, "core-ext",          FICL_FALSE);
    ficlSetEnv(pSys, "floored",           FICL_FALSE);
    ficlSetEnv(pSys, "max-char",          UCHAR_MAX);
    ficlSetEnvD(pSys,"max-d",             0x7fffffff, 0xffffffff);
    ficlSetEnv(pSys, "max-n",             0x7fffffff);
    ficlSetEnv(pSys, "max-u",             0xffffffff);
    ficlSetEnvD(pSys,"max-ud",            0xffffffff, 0xffffffff);
    ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
    ficlSetEnv(pSys, "stack-cells",       FICL_DEFAULT_STACK);

    /*
    ** DOUBLE word set (partial)
    */
    dictAppendWord(dp, "2constant", twoConstant,    FW_IMMEDIATE);
    dictAppendWord(dp, "2literal",  twoLiteralIm,   FW_IMMEDIATE);
    dictAppendWord(dp, "2variable", twoVariable,    FW_IMMEDIATE);
    dictAppendWord(dp, "dnegate",   dnegate,        FW_DEFAULT);


    /*
    ** EXCEPTION word set
    */
    dictAppendWord(dp, "catch",     ficlCatch,      FW_DEFAULT);
    dictAppendWord(dp, "throw",     ficlThrow,      FW_DEFAULT);

    ficlSetEnv(pSys, "exception",         FICL_TRUE);
    ficlSetEnv(pSys, "exception-ext",     FICL_TRUE);

    /*
    ** LOCAL and LOCAL EXT
    ** see softcore.c for implementation of locals|
    */
#if FICL_WANT_LOCALS
    pSys->pLinkParen =
    dictAppendWord(dp, "(link)",    linkParen,      FW_COMPILE);
    pSys->pUnLinkParen =
    dictAppendWord(dp, "(unlink)",  unlinkParen,    FW_COMPILE);
    dictAppendWord(dp, "doLocal",   doLocalIm,      FW_COMPIMMED);
    pSys->pGetLocalParen =
    dictAppendWord(dp, "(@local)",  getLocalParen,  FW_COMPILE);
    pSys->pToLocalParen =
    dictAppendWord(dp, "(toLocal)", toLocalParen,   FW_COMPILE);
    pSys->pGetLocal0 =
    dictAppendWord(dp, "(@local0)", getLocal0,      FW_COMPILE);
    pSys->pToLocal0 =
    dictAppendWord(dp, "(toLocal0)",toLocal0,       FW_COMPILE);
    pSys->pGetLocal1 =
    dictAppendWord(dp, "(@local1)", getLocal1,      FW_COMPILE);
    pSys->pToLocal1 =
    dictAppendWord(dp, "(toLocal1)",toLocal1,       FW_COMPILE);
    dictAppendWord(dp, "(local)",   localParen,     FW_COMPILE);

    pSys->pGet2LocalParen =
    dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
    pSys->pTo2LocalParen =
    dictAppendWord(dp, "(to2Local)",to2LocalParen,  FW_COMPILE);
    dictAppendWord(dp, "(2local)",  twoLocalParen,  FW_COMPILE);

    ficlSetEnv(pSys, "locals",            FICL_TRUE);
    ficlSetEnv(pSys, "locals-ext",        FICL_TRUE);
    ficlSetEnv(pSys, "#locals",           FICL_MAX_LOCALS);
#endif

    /*
    ** Optional MEMORY-ALLOC word set
    */

    dictAppendWord(dp, "allocate",  ansAllocate,    FW_DEFAULT);
    dictAppendWord(dp, "free",      ansFree,        FW_DEFAULT);
    dictAppendWord(dp, "resize",    ansResize,      FW_DEFAULT);

    ficlSetEnv(pSys, "memory-alloc",      FICL_TRUE);

    /*
    ** optional SEARCH-ORDER word set
    */
    ficlCompileSearch(pSys);

    /*
    ** TOOLS and TOOLS EXT
    */
    ficlCompileTools(pSys);

    /*
    ** FILE and FILE EXT
    */
#if FICL_WANT_FILE
    ficlCompileFile(pSys);
#endif

    /*
    ** Ficl extras
    */
#if FICL_WANT_FLOAT
    dictAppendWord(dp, ".hash",     dictHashSummary,FW_DEFAULT);
#endif
    dictAppendWord(dp, ".ver",      ficlVersion,    FW_DEFAULT);
    dictAppendWord(dp, "-roll",     minusRoll,      FW_DEFAULT);
    dictAppendWord(dp, ">name",     toName,         FW_DEFAULT);
    dictAppendWord(dp, "add-parse-step",
                                    addParseStep,   FW_DEFAULT);
    dictAppendWord(dp, "body>",     fromBody,       FW_DEFAULT);
    dictAppendWord(dp, "compare",   compareString,  FW_DEFAULT);   /* STRING */
    dictAppendWord(dp, "compare-insensitive",   compareStringInsensitive,  FW_DEFAULT);   /* STRING */
    dictAppendWord(dp, "compile-only",
                                    compileOnly,    FW_DEFAULT);
    dictAppendWord(dp, "endif",     endifCoIm,      FW_COMPIMMED);
    dictAppendWord(dp, "last-word", getLastWord,    FW_DEFAULT);
    dictAppendWord(dp, "hash",      hash,           FW_DEFAULT);
    dictAppendWord(dp, "objectify", setObjectFlag,  FW_DEFAULT);
    dictAppendWord(dp, "?object",   isObject,       FW_DEFAULT);
    dictAppendWord(dp, "parse-word",parseNoCopy,    FW_DEFAULT);
    dictAppendWord(dp, "sfind",     sFind,          FW_DEFAULT);
    dictAppendWord(dp, "sliteral",  sLiteralCoIm,   FW_COMPIMMED); /* STRING */
    dictAppendWord(dp, "sprintf",   ficlSprintf,    FW_DEFAULT);
    dictAppendWord(dp, "strlen",    ficlStrlen,     FW_DEFAULT);
    dictAppendWord(dp, "q@",        quadFetch,      FW_DEFAULT);
    dictAppendWord(dp, "q!",        quadStore,      FW_DEFAULT);
    dictAppendWord(dp, "w@",        wFetch,         FW_DEFAULT);
    dictAppendWord(dp, "w!",        wStore,         FW_DEFAULT);
    dictAppendWord(dp, "x.",        hexDot,         FW_DEFAULT);
#if FICL_WANT_USER
    dictAppendWord(dp, "(user)",    userParen,      FW_DEFAULT);
    dictAppendWord(dp, "user",      userVariable,   FW_DEFAULT);
#endif
#ifdef TESTMAIN
    dictAppendWord(dp, "random",    ficlRandom,     FW_DEFAULT);
    dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT);
#endif

    /*
    ** internal support words
    */
    dictAppendWord(dp, "(create)",  createParen,    FW_COMPILE);
    pSys->pExitParen =
    dictAppendWord(dp, "(exit)",    exitParen,      FW_COMPILE);
    pSys->pSemiParen =
    dictAppendWord(dp, "(;)",       semiParen,      FW_COMPILE);
    pSys->pLitParen =
    dictAppendWord(dp, "(literal)", literalParen,   FW_COMPILE);
    pSys->pTwoLitParen =
    dictAppendWord(dp, "(2literal)",twoLitParen,    FW_COMPILE);
    pSys->pStringLit =
    dictAppendWord(dp, "(.\")",     stringLit,      FW_COMPILE);
    pSys->pCStringLit =
    dictAppendWord(dp, "(c\")",     cstringLit,     FW_COMPILE);
    pSys->pBranch0 =
    dictAppendWord(dp, "(branch0)",      branch0,        FW_COMPILE);
    pSys->pBranchParen =
    dictAppendWord(dp, "(branch)",  branchParen,    FW_COMPILE);
    pSys->pDoParen =
    dictAppendWord(dp, "(do)",      doParen,        FW_COMPILE);
    pSys->pDoesParen =
    dictAppendWord(dp, "(does>)",   doesParen,      FW_COMPILE);
    pSys->pQDoParen =
    dictAppendWord(dp, "(?do)",     qDoParen,       FW_COMPILE);
    pSys->pLoopParen =
    dictAppendWord(dp, "(loop)",    loopParen,      FW_COMPILE);
    pSys->pPLoopParen =
    dictAppendWord(dp, "(+loop)",   plusLoopParen,  FW_COMPILE);
    pSys->pInterpret =
    dictAppendWord(dp, "interpret", interpret,      FW_DEFAULT);
    dictAppendWord(dp, "lookup",    lookup,         FW_DEFAULT);
    pSys->pOfParen =
    dictAppendWord(dp, "(of)",      ofParen,        FW_DEFAULT);
    dictAppendWord(dp, "(variable)",variableParen,  FW_COMPILE);
    dictAppendWord(dp, "(constant)",constantParen,  FW_COMPILE);
    dictAppendWord(dp, "(parse-step)",
                                    parseStepParen, FW_DEFAULT);
	pSys->pExitInner =
    dictAppendWord(dp, "exit-inner",ficlExitInner,  FW_DEFAULT);

    /*
    ** Set up system's outer interpreter loop - maybe this should be in initSystem?
    */
    pSys->pInterp[0] = pSys->pInterpret;
    pSys->pInterp[1] = pSys->pBranchParen;
    pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);

    assert(dictCellsAvail(dp) > 0);

    return;
}