primitives.c

/*******************************************************************
** 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: primitives.c,v 1.4 2010/09/13 18:43:04 asau 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.
*/

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "ficl.h"


/*
** 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";

/*
** 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 dictionary location for later branch resolution.
** The location may be either a branch target or a patch address...
*/
static void markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
{
    ficlStackPushPointer(vm->dataStack, dictionary->here);
    ficlStackPushPointer(vm->dataStack, tag);
    return;
}

static void markControlTag(ficlVm *vm, char *tag)
{
    ficlStackPushPointer(vm->dataStack, tag);
    return;
}

static void matchControlTag(ficlVm *vm, char *wantTag)
{
    char *tag;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    tag = (char *)ficlStackPopPointer(vm->dataStack);
    /*
    ** Changed the code below to compare the pointers first (by popular demand)
    */
    if ( (tag != wantTag) && strcmp(tag, wantTag) )
    {
        ficlVmThrowError(vm, "Error -- unmatched control structure \"%s\"", wantTag);
    }

    return;
}

/*
** Expect a branch target address on the param stack,
** FICL_VM_STATE_COMPILE a literal offset from the current dictionary location
** to the target address
*/
static void resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
{
    ficlInteger offset;
    ficlCell *patchAddr;

    matchControlTag(vm, tag);

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
    offset = patchAddr - dictionary->here;
    ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(offset));

    return;
}


/*
** Expect a branch patch address on the param stack,
** FICL_VM_STATE_COMPILE a literal offset from the patch location
** to the current dictionary location
*/
static void resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
{
    ficlInteger offset;
    ficlCell *patchAddr;

    matchControlTag(vm, tag);

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
    offset = dictionary->here - patchAddr;
    *patchAddr = FICL_LVALUE_TO_CELL(offset);

    return;
}

/*
** Match the tag to the top of the stack. If success,
** sopy "here" address into the ficlCell whose address is next
** on the stack. Used by do..leave..loop.
*/
static void resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag)
{
    ficlCell *patchAddr;
    char *tag;

    FICL_STACK_CHECK(vm->dataStack, 2, 0);

    tag = ficlStackPopPointer(vm->dataStack);
    /*
    ** Changed the comparison below to compare the pointers first (by popular demand)
    */
    if ((tag != wantTag) && strcmp(tag, wantTag))
    {
        ficlVmTextOut(vm, "Warning -- Unmatched control word: ");
        ficlVmTextOut(vm, wantTag);
        ficlVmTextOut(vm, "\n");
    }

    patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
    *patchAddr = FICL_LVALUE_TO_CELL(dictionary->here);

    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 FICL_VM_STATE_COMPILE, then creates a
** new word whose name is the next word in the input stream
** and whose code is colonParen.
**************************************************************************/

static void ficlPrimitiveColon(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    vm->state = FICL_VM_STATE_COMPILE;
    markControlTag(vm, colonTag);
    ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionColonParen, FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
#if FICL_WANT_LOCALS
    vm->callback.system->localsCount = 0;
#endif
    return;
}


       
static void ficlPrimitiveSemicolonCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    matchControlTag(vm, colonTag);

#if FICL_WANT_LOCALS
    if (vm->callback.system->localsCount > 0)
    {
        ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
        ficlDictionaryEmpty(locals, locals->forthWordlist->size);
            ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
    }
    vm->callback.system->localsCount = 0;
#endif

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen);
    vm->state = FICL_VM_STATE_INTERPRET;
    ficlDictionaryUnsmudge(dictionary);
    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 ficlPrimitiveExitCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    FICL_IGNORE(vm);

#if FICL_WANT_LOCALS
    if (vm->callback.system->localsCount > 0)
    {
		ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
    }
#endif
    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen);
    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 ficlPrimitiveConstant(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

	ficlDictionaryAppendConstantInstruction(dictionary, name, ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack));
    return;
}


static void ficlPrimitive2Constant(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);
    
    FICL_STACK_CHECK(vm->dataStack, 2, 0);

	ficlDictionaryAppend2ConstantInstruction(dictionary, name, ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack));
    return;
}


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

static void ficlPrimitiveDot(ficlVm *vm)
{
    ficlCell c;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    c = ficlStackPop(vm->dataStack);
    ficlLtoa((c).i, vm->pad, vm->base);
    strcat(vm->pad, " ");
    ficlVmTextOut(vm, vm->pad);
    return;
}

static void ficlPrimitiveUDot(ficlVm *vm)
{
    ficlUnsigned u;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    u = ficlStackPopUnsigned(vm->dataStack);
    ficlUltoa(u, vm->pad, vm->base);
    strcat(vm->pad, " ");
    ficlVmTextOut(vm, vm->pad);
    return;
}


static void ficlPrimitiveHexDot(ficlVm *vm)
{
    ficlUnsigned u;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    u = ficlStackPopUnsigned(vm->dataStack);
    ficlUltoa(u, vm->pad, 16);
    strcat(vm->pad, " ");
    ficlVmTextOut(vm, vm->pad);
    return;
}


/**************************************************************************
                        s t r l e n
** Ficl   ( c-string -- length )
**
** Returns the length of a C-style (zero-terminated) string.
**
** --lch
**/
static void ficlPrimitiveStrlen(ficlVm *vm)
	{
	char *address = (char *)ficlStackPopPointer(vm->dataStack);
	ficlStackPushInteger(vm->dataStack, 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 ficlCell 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 (FICL_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 ficlPrimitiveSprintf(ficlVm *vm) /*  */
{
	int bufferLength = ficlStackPopInteger(vm->dataStack);
	char *buffer = (char *)ficlStackPopPointer(vm->dataStack);
	char *bufferStart = buffer;

	int formatLength = ficlStackPopInteger(vm->dataStack);
	char *format = (char *)ficlStackPopPointer(vm->dataStack);
	char *formatStop = format + formatLength;

	int base = 10;
	int unsignedInteger = 0; /* false */

	int append = 1; /* 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((unsigned char)*format);
			if (desiredLength)
				{
				desiredLength = strtoul(format, &format, 10);
				if (format == formatStop)
					break;
				}
			else if (*format == '*')
				{
				desiredLength = ficlStackPopInteger(vm->dataStack);
				format++;
				if (format == formatStop)
					break;
				}


			switch (*format)
			{
				case 's':
				case 'S':
				{
					actualLength = ficlStackPopInteger(vm->dataStack);
					source = (char *)ficlStackPopPointer(vm->dataStack);
					break;
				}
				case 'x':
				case 'X':
					base = 16;
				case 'u':
				case 'U':
					unsignedInteger = 1; /* true */
				case 'd':
				case 'D':
				{
					int integer = ficlStackPopInteger(vm->dataStack);
					if (unsignedInteger)
						ficlUltoa(integer, scratch, base);
					else
						ficlLtoa(integer, scratch, base);
					base = 10;
					unsignedInteger = 0; /* false */
					source = scratch;
					actualLength = strlen(scratch);
					break;
				}
				case '%':
					source = format;
					actualLength = 1;
				default:
					continue;
			}
		}

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

		format++;
	}

	ficlStackPushPointer(vm->dataStack, bufferStart);
	ficlStackPushInteger(vm->dataStack, buffer - bufferStart);
	ficlStackPushInteger(vm->dataStack, append && FICL_TRUE);
}


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

static void ficlPrimitiveDepth(ficlVm *vm)
{
    int i;

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    i = ficlStackDepth(vm->dataStack);
    ficlStackPushInteger(vm->dataStack, i);
    return;
}


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

static void ficlPrimitiveEmit(ficlVm *vm)
{
    char *buffer = vm->pad;
    int i;


    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    i = ficlStackPopInteger(vm->dataStack);
    buffer[0] = (char)i;
    buffer[1] = '\0';
    ficlVmTextOut(vm, buffer);
    return;
}


static void ficlPrimitiveCR(ficlVm *vm)
{
    ficlVmTextOut(vm, "\n");
    return;
}


static void ficlPrimitiveBackslash(ficlVm *vm)
{
    char *trace        = ficlVmGetInBuf(vm);
    char *stop      = ficlVmGetInBufEnd(vm);
    char c = *trace;

    while ((trace != stop) && (c != '\r') && (c != '\n'))
    {
        c = *++trace;
    }

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

        if ( (trace != stop) && (c != *trace) 
             && ((*trace == '\r') || (*trace == '\n')) )
            trace++;
    }

    ficlVmUpdateTib(vm, trace);
    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 ficlPrimitiveParenthesis(ficlVm *vm)
{
    ficlVmParseStringEx(vm, ')', 0);
    return;
}


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

/**************************************************************************
                        i f C o I m
** IMMEDIATE
** 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 ficlPrimitiveIfCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
    markBranch(dictionary, vm, origTag);
    ficlDictionaryAppendUnsigned(dictionary, 1);
    return;
}




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

static void ficlPrimitiveElseCoIm(ficlVm *vm)
{
    ficlCell *patchAddr;
    ficlInteger offset;
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

                                            /* (1) FICL_VM_STATE_COMPILE branch runtime */
    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
    matchControlTag(vm, origTag);
    patchAddr = 
        (ficlCell *)ficlStackPopPointer(vm->dataStack);   /* (2) pop "if" patch addr */
    markBranch(dictionary, vm, origTag);           /* (4) push "else" patch addr */
    ficlDictionaryAppendUnsigned(dictionary, 1);                 /* (1) FICL_VM_STATE_COMPILE patch placeholder */
    offset = dictionary->here - patchAddr;
    *patchAddr = FICL_LVALUE_TO_CELL(offset);      /* (3) Patch "if" */

    return;
}


/**************************************************************************
                        e n d i f C o I m
** 
**************************************************************************/

static void ficlPrimitiveEndifCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    resolveForwardBranch(dictionary, vm, origTag);
    return;
}


/**************************************************************************
                        c a s e C o I m
** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
**
**
** At FICL_VM_STATE_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 ficlPrimitiveCaseCoIm(ficlVm *vm)
{
    FICL_STACK_CHECK(vm->dataStack, 0, 2);

	ficlStackPushUnsigned(vm->dataStack, 0);
	markControlTag(vm, caseTag);
    return;
}


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

static void ficlPrimitiveEndcaseCoIm(ficlVm *vm)
{
	ficlUnsigned fixupCount;
    ficlDictionary *dictionary;
    ficlCell *patchAddr;
    ficlInteger offset;

	/*
	** if the last OF ended with FALLTHROUGH,
	** just add the FALLTHROUGH fixup to the
	** ENDOF fixups
	*/
	if (ficlStackGetTop(vm->dataStack).p == fallthroughTag)
	{
		matchControlTag(vm, fallthroughTag);
		patchAddr = ficlStackPopPointer(vm->dataStack);
	    matchControlTag(vm, caseTag);
		fixupCount = ficlStackPopUnsigned(vm->dataStack);
		ficlStackPushPointer(vm->dataStack, patchAddr);
		ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
		markControlTag(vm, caseTag);
	}

    matchControlTag(vm, caseTag);

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

	fixupCount = ficlStackPopUnsigned(vm->dataStack);
    FICL_STACK_CHECK(vm->dataStack, fixupCount, 0);

    dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop);

	while (fixupCount--)
	{
		patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
		offset = dictionary->here - patchAddr;
		*patchAddr = FICL_LVALUE_TO_CELL(offset);
	}
    return;
}


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

static void ficlPrimitiveOfCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
	ficlCell *fallthroughFixup = NULL;

    FICL_STACK_CHECK(vm->dataStack, 1, 3);

	if (ficlStackGetTop(vm->dataStack).p == fallthroughTag)
	{
		matchControlTag(vm, fallthroughTag);
		fallthroughFixup = ficlStackPopPointer(vm->dataStack);
	}

	matchControlTag(vm, caseTag);

	markControlTag(vm, caseTag);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen);
    markBranch(dictionary, vm, ofTag);
    ficlDictionaryAppendUnsigned(dictionary, 2);

	if (fallthroughFixup != NULL)
	{
		ficlInteger offset = dictionary->here - fallthroughFixup;
		*fallthroughFixup = FICL_LVALUE_TO_CELL(offset);
	}

    return;
}


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

static void ficlPrimitiveEndofCoIm(ficlVm *vm)
{
    ficlCell *patchAddr;
    ficlUnsigned fixupCount;
    ficlInteger offset;
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_STACK_CHECK(vm->dataStack, 4, 3);

	/* ensure we're in an OF, */
    matchControlTag(vm, ofTag);
	/* grab the address of the branch location after the OF */
    patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
	/* ensure we're also in a "case" */
    matchControlTag(vm, caseTag);
	/* grab the current number of ENDOF fixups */
	fixupCount = ficlStackPopUnsigned(vm->dataStack);

    /* FICL_VM_STATE_COMPILE branch runtime */
    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);

	/* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
    ficlStackPushPointer(vm->dataStack, dictionary->here);
    ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
	markControlTag(vm, caseTag);

	/* reserve space for the ENDOF fixup */
    ficlDictionaryAppendUnsigned(dictionary, 2);

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

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

static void ficlPrimitiveFallthroughCoIm(ficlVm *vm)
{
    ficlCell *patchAddr;
    ficlInteger offset;
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_STACK_CHECK(vm->dataStack, 4, 3);

	/* ensure we're in an OF, */
    matchControlTag(vm, ofTag);
	/* grab the address of the branch location after the OF */
    patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
	/* ensure we're also in a "case" */
    matchControlTag(vm, caseTag);

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

    /* FICL_VM_STATE_COMPILE branch runtime */
    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);

	/* push a new FALLTHROUGH fixup and the fallthroughTag */
    ficlStackPushPointer(vm->dataStack, dictionary->here);
	markControlTag(vm, fallthroughTag);

	/* reserve space for the FALLTHROUGH fixup */
    ficlDictionaryAppendUnsigned(dictionary, 2);

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

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

static void ficlPrimitiveHash(ficlVm *vm)
{
    ficlString s;
    FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack));
    FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
    ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s));
    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 (ficlVmGetWord)
**     Attempt to find the word in the dictionary (ficlDictionaryLookup)
**     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 ficlPrimitiveInterpret(ficlVm *vm)
{
    ficlString s;
    int i;
    ficlSystem *system;

    FICL_VM_ASSERT(vm, vm);

    system = vm->callback.system;
    s   = ficlVmGetWord0(vm);

    /*
    ** Get next word...if out of text, we're done.
    */
    if (s.length == 0)
    {
        ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT);
    }

    /*
    ** Run the parse chain against the incoming token until somebody eats it.
    ** Otherwise emit an error message and give up.
    */
    for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
    {
        ficlWord *word = system->parseList[i];
           
        if (word == NULL)
            break;

        if (word->code == ficlPrimitiveParseStepParen)
        {
            ficlParseStep pStep;
            pStep = (ficlParseStep)(word->param->fn);
            if ((*pStep)(vm, s))
                return;
        }
        else
        {
            ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
            ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
            ficlVmExecuteXT(vm, word);
            if (ficlStackPopInteger(vm->dataStack))
                return;
        }
    }

    ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s), FICL_STRING_GET_POINTER(s));

    return;                 /* back to inner interpreter */
}


/*
** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in 
** FICL_VM_STATE_INTERPRET)
*/
static void ficlPrimitiveLookup(ficlVm *vm)
{
    ficlString name;
    FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
    FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack));
    ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name));
    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 ficlPrimitiveParseStepParen(ficlVm *vm)
{
    ficlString s;
    ficlWord *word = vm->runningWord;
    ficlParseStep pStep = (ficlParseStep)(word->param->fn);

    FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack));
    FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
    
    ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s));

    return;
}


static void ficlPrimitiveAddParseStep(ficlVm *vm)
{
    ficlWord *pStep;
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p);
    if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep))
        ficlSystemAddParseStep(vm->callback.system, pStep);
    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
**************************************************************************/

void ficlPrimitiveLiteralIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
	ficlInteger value;

	value = ficlStackPopInteger(vm->dataStack);

	switch (value)
	{
		case 1:
		case 2:
		case 3:
		case 4:
		case 5:
		case 6:
		case 7:
		case 8:
		case 9:
		case 10:
		case 11:
		case 12:
		case 13:
		case 14:
		case 15:
		case 16:
			ficlDictionaryAppendUnsigned(dictionary, value);
			break;

		case 0:
		case -1:
		case -2:
		case -3:
		case -4:
		case -5:
		case -6:
		case -7:
		case -8:
		case -9:
		case -10:
		case -11:
		case -12:
		case -13:
		case -14:
		case -15:
		case -16:
			ficlDictionaryAppendUnsigned(dictionary, ficlInstruction0- value);
			break;

		default:
			ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLiteralParen);
			ficlDictionaryAppendUnsigned(dictionary, value);
			break;
	}

    return;
}


static void ficlPrimitive2LiteralIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen);
    ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
    ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));

    return;
}

/**************************************************************************
                               D o  /  L o o p
** do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
**    Compiles code to initialize a loop: FICL_VM_STATE_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 FICL_VM_STATE_COMPILE ONLY
** +loop
**    Compiles code for the test part of a loop:
**    FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and
**    copy "here" address to the "leave" address allotted by "do"
** i,j,k -- FICL_VM_STATE_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 ficlCell after the loop
**    limit and index are the loop control variables.
** leave -- FICL_VM_STATE_COMPILE ONLY
**    Runtime: pop the loop control variables, then pop the
**    "leave" address and jump (absolute) there.
**************************************************************************/

static void ficlPrimitiveDoCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen);
    /*
    ** Allot space for a pointer to the end
    ** of the loop - "leave" uses this...
    */
    markBranch(dictionary, vm, leaveTag);
    ficlDictionaryAppendUnsigned(dictionary, 0);
    /*
    ** Mark location of head of loop...
    */
    markBranch(dictionary, vm, doTag);

    return;
}


static void ficlPrimitiveQDoCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen);
    /*
    ** Allot space for a pointer to the end
    ** of the loop - "leave" uses this...
    */
    markBranch(dictionary, vm, leaveTag);
    ficlDictionaryAppendUnsigned(dictionary, 0);
    /*
    ** Mark location of head of loop...
    */
    markBranch(dictionary, vm, doTag);

    return;
}


static void ficlPrimitiveLoopCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen);
    resolveBackBranch(dictionary, vm, doTag);
    resolveAbsBranch(dictionary, vm, leaveTag);
    return;
}


static void ficlPrimitivePlusLoopCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen);
    resolveBackBranch(dictionary, vm, doTag);
    resolveAbsBranch(dictionary, vm, leaveTag);
    return;
}



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

static void ficlPrimitiveVariable(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
    ficlVmDictionaryAllotCells(vm, dictionary, 1);
    return;
}


static void ficlPrimitive2Variable(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
    ficlVmDictionaryAllotCells(vm, dictionary, 2);
    return;
}


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

static void ficlPrimitiveBase(ficlVm *vm)
{
    ficlCell *pBase;

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    pBase = (ficlCell *)(&vm->base);
    ficlStackPush(vm->dataStack, FICL_LVALUE_TO_CELL(pBase));
    return;
}


static void ficlPrimitiveDecimal(ficlVm *vm)
{
    vm->base = 10;
    return;
}


static void ficlPrimitiveHex(ficlVm *vm)
{
    vm->base = 16;
    return;
}


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

static void ficlPrimitiveAllot(ficlVm *vm)
{
    ficlDictionary *dictionary;
    ficlInteger i;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    dictionary = ficlVmGetDictionary(vm);
    i = ficlStackPopInteger(vm->dataStack);

    FICL_VM_DICTIONARY_CHECK(vm, dictionary, i);

    ficlVmDictionaryAllot(vm, dictionary, i);
    return;
}


static void ficlPrimitiveHere(ficlVm *vm)
{
    ficlDictionary *dictionary;

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    dictionary = ficlVmGetDictionary(vm);
    ficlStackPushPointer(vm->dataStack, dictionary->here);
    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 ficlPrimitiveTick(ficlVm *vm)
{
    ficlWord *word = NULL;
    ficlString name = ficlVmGetWord(vm);

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
    if (!word)
        ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
    ficlStackPushPointer(vm->dataStack, word);
    return;
}


static void ficlPrimitiveBracketTickCoIm(ficlVm *vm)
{
    ficlPrimitiveTick(vm);
    ficlPrimitiveLiteralIm(vm);
    
    return;
}


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

static void ficlPrimitivePostponeCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary  = ficlVmGetDictionary(vm);
    ficlWord *word;
    ficlWord *pComma = ficlSystemLookup(vm->callback.system, ",");
    FICL_VM_ASSERT(vm, pComma);

    ficlPrimitiveTick(vm);
    word = ficlStackGetTop(vm->dataStack).p;
    if (ficlWordIsImmediate(word))
    {
        ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
    }
    else
    {
        ficlPrimitiveLiteralIm(vm);
        ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(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 ficlPrimitiveExecute(ficlVm *vm)
{
    ficlWord *word;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    word = ficlStackPopPointer(vm->dataStack);
    ficlVmExecuteWord(vm, word);

    return;
}


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

static void ficlPrimitiveImmediate(ficlVm *vm)
{
    FICL_IGNORE(vm);
    ficlDictionarySetImmediate(ficlVmGetDictionary(vm));
    return;
}


static void ficlPrimitiveCompileOnly(ficlVm *vm)
{
    FICL_IGNORE(vm);
    ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY);
    return;
}


static void ficlPrimitiveSetObjectFlag(ficlVm *vm)
{
    FICL_IGNORE(vm);
    ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT);
    return;
}

static void ficlPrimitiveIsObject(ficlVm *vm)
{
    int flag;
    ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
    
    flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT)) ? FICL_TRUE : FICL_FALSE;
    ficlStackPushInteger(vm->dataStack, flag);
    return;
}



static void ficlPrimitiveCountedStringQuoteIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    if (vm->state == FICL_VM_STATE_INTERPRET)
    {
        ficlCountedString *counted = (ficlCountedString *) dictionary->here;
        ficlVmGetString(vm, counted, '\"');
        ficlStackPushPointer(vm->dataStack, counted);
		/* move HERE past string so it doesn't get overwritten.  --lch */
		ficlVmDictionaryAllot(vm, dictionary, counted->length + sizeof(ficlUnsigned8));
    }
    else    /* FICL_VM_STATE_COMPILE state */
    {
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionCStringLiteralParen);
        dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
        ficlDictionaryAlign(dictionary);
    }

    return;
}

/**************************************************************************
                        d o t Q u o t e
** IMMEDIATE word that compiles a string literal for later display
** FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the string from the
** TIB to the dictionary. Backpatch the count byte and align the dictionary.
**************************************************************************/

static void ficlPrimitiveDotQuoteCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlWord *pType = ficlSystemLookup(vm->callback.system, "type");
    FICL_VM_ASSERT(vm, pType);
    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
    dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
    ficlDictionaryAlign(dictionary);
    ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(pType));
    return;
}


static void ficlPrimitiveDotParen(ficlVm *vm)
{
    char *from      = ficlVmGetInBuf(vm);
    char *stop      = ficlVmGetInBufEnd(vm);
    char *to     = vm->pad;
    char c;

    /*
    ** Note: the standard does not want leading spaces skipped.
    */
    for (c = *from; (from != stop) && (c != ')'); c = *++from)
        *to++ = c;

    *to = '\0';
    if ((from != stop) && (c == ')'))
        from++;

    ficlVmTextOut(vm, vm->pad);
    ficlVmUpdateTib(vm, from);
        
    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 ficlPrimitiveSLiteralCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary;
    char *from;
	char *to;
    ficlUnsigned length;

    FICL_STACK_CHECK(vm->dataStack, 2, 0);

    dictionary = ficlVmGetDictionary(vm);
    length  = ficlStackPopUnsigned(vm->dataStack);
    from = ficlStackPopPointer(vm->dataStack);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
    to    = (char *) dictionary->here;
    *to++ = (char)   length;

    for (; length > 0; --length)
    {
        *to++ = *from++;
    }

    *to++ = 0;
    dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to));
    return;
}


/**************************************************************************
                        s t a t e
** Return the address of the VM's state member (must be sized the
** same as a ficlCell for this reason)
**************************************************************************/
static void ficlPrimitiveState(ficlVm *vm)
{
    FICL_STACK_CHECK(vm->dataStack, 0, 1);
    ficlStackPushPointer(vm->dataStack, &vm->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 ficlPrimitiveCreate(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT);
    ficlVmDictionaryAllotCells(vm, dictionary, 1);
    return;
}


static void ficlPrimitiveDoesCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
#if FICL_WANT_LOCALS
    if (vm->callback.system->localsCount > 0)
    {
        ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
        ficlDictionaryEmpty(locals, locals->forthWordlist->size);
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
    }

    vm->callback.system->localsCount = 0;
#endif
    FICL_IGNORE(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen);
    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 ficlPrimitiveToBody(ficlVm *vm)
{
    ficlWord *word;
    FICL_STACK_CHECK(vm->dataStack, 1, 1);

    word = ficlStackPopPointer(vm->dataStack);
    ficlStackPushPointer(vm->dataStack, word->param + 1);
    return;
}


/*
** from-body       Ficl ( a-addr -- xt )
** Reverse effect of >body
*/
static void ficlPrimitiveFromBody(ficlVm *vm)
{
    char *ptr;
    FICL_STACK_CHECK(vm->dataStack, 1, 1);

    ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord);
    ficlStackPushPointer(vm->dataStack, ptr);
    return;
}


/*
** >name        Ficl ( xt -- c-addr u )
** Push the address and length of a word's name given its address
** xt. 
*/
static void ficlPrimitiveToName(ficlVm *vm)
{
    ficlWord *word;

    FICL_STACK_CHECK(vm->dataStack, 1, 2);

    word = ficlStackPopPointer(vm->dataStack);
    ficlStackPushPointer(vm->dataStack, word->name);
    ficlStackPushUnsigned(vm->dataStack, word->length);
    return;
}


static void ficlPrimitiveLastWord(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlWord *wp = dictionary->smudge;
    FICL_VM_ASSERT(vm, wp);
    ficlVmPush(vm, FICL_LVALUE_TO_CELL(wp));
    return;
}


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

static void ficlPrimitiveLeftBracketCoIm(ficlVm *vm)
{
    vm->state = FICL_VM_STATE_INTERPRET;
    return;
}


static void ficlPrimitiveRightBracket(ficlVm *vm)
{
    vm->state = FICL_VM_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 ficlPrimitiveLessNumberSign(ficlVm *vm)
{
    ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    counted->length = 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 ficlPrimitiveNumberSign(ficlVm *vm)
{
    ficlCountedString *counted;
    ficl2Unsigned u;
    ficl2UnsignedQR uqr;

    FICL_STACK_CHECK(vm->dataStack, 2, 2);

    counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    u = ficlStackPop2Unsigned(vm->dataStack);
    uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
    counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
    ficlStackPush2Unsigned(vm->dataStack, uqr.quotient);
    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 ficlPrimitiveNumberSignGreater(ficlVm *vm)
{
    ficlCountedString *counted;

    FICL_STACK_CHECK(vm->dataStack, 2, 2);

    counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    counted->text[counted->length] = 0;
    ficlStringReverse(counted->text);
    ficlStackDrop(vm->dataStack, 2);
    ficlStackPushPointer(vm->dataStack, counted->text);
    ficlStackPushUnsigned(vm->dataStack, counted->length);
    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 ficlCell - use it!
*/
static void ficlPrimitiveNumberSignS(ficlVm *vm)
{
    ficlCountedString *counted;
    ficl2Unsigned u;
    ficl2UnsignedQR uqr;

    FICL_STACK_CHECK(vm->dataStack, 2, 2);

    counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    u = ficlStackPop2Unsigned(vm->dataStack);

    do 
    {
        uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
        counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
		u = uqr.quotient;
    }
    while (FICL_2UNSIGNED_NOT_ZERO(u));

    ficlStackPush2Unsigned(vm->dataStack, 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 ficlPrimitiveHold(ficlVm *vm)
{
    ficlCountedString *counted;
    int i;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    i = ficlStackPopInteger(vm->dataStack);
    counted->text[counted->length++] = (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 ficlPrimitiveSign(ficlVm *vm)
{
    ficlCountedString *counted;
    int i;

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
    i = ficlStackPopInteger(vm->dataStack);
    if (i < 0)
        counted->text[counted->length++] = '-';
    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 ficlPrimitiveToNumber(ficlVm *vm)
{
    ficlUnsigned length;
    char *trace;
    ficl2Unsigned accumulator;
    ficlUnsigned base = vm->base;
    ficlUnsigned c;
    ficlUnsigned digit;

    FICL_STACK_CHECK(vm->dataStack,4,4);

    length = ficlStackPopUnsigned(vm->dataStack);
    trace = (char *)ficlStackPopPointer(vm->dataStack);
    accumulator = ficlStackPop2Unsigned(vm->dataStack);

    for (c = *trace; length > 0; c = *++trace, length--)
    {
        if (c < '0')
            break;

        digit = c - '0';

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

        accumulator = ficl2UnsignedMultiplyAccumulate(accumulator, base, digit);
    }

    ficlStackPush2Unsigned(vm->dataStack, accumulator);
    ficlStackPushPointer(vm->dataStack, trace);
    ficlStackPushUnsigned(vm->dataStack, length);

    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 FICL_VM_STATE_INTERPRET. 
**   Display the implementation-defined system prompt if in
**   interpretation state, all processing has been completed, and no
**   ambiguous condition exists. 
**************************************************************************/

static void ficlPrimitiveQuit(ficlVm *vm)
{
    ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
    return;
}


static void ficlPrimitiveAbort(ficlVm *vm)
{
    ficlVmThrow(vm, FICL_VM_STATUS_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 ficlPrimitiveAccept(ficlVm *vm)
{
    ficlUnsigned size;
    char *address;

	ficlUnsigned length;
	char *trace;
	char *end;

    FICL_STACK_CHECK(vm->dataStack, 2, 1);

    trace = ficlVmGetInBuf(vm);
    end = ficlVmGetInBufEnd(vm);
    length = end - trace;
    if (length == 0)
        ficlVmThrow(vm, FICL_VM_STATUS_RESTART);

    /*
    ** Now we have something in the text buffer - use it 
    */
    size = ficlStackPopInteger(vm->dataStack);
    address = ficlStackPopPointer(vm->dataStack);

    length = (size < length) ? size : length;
    strncpy(address, trace, length);
    trace += length;
    ficlVmUpdateTib(vm, trace);
    ficlStackPushInteger(vm->dataStack, length);

    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 ficlPrimitiveAlign(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    FICL_IGNORE(vm);
    ficlDictionaryAlign(dictionary);
    return;
}


/**************************************************************************
                        a l i g n e d
** 
**************************************************************************/
static void ficlPrimitiveAligned(ficlVm *vm)
{
    void *addr;

    FICL_STACK_CHECK(vm->dataStack,1,1);

    addr = ficlStackPopPointer(vm->dataStack);
    ficlStackPushPointer(vm->dataStack, ficlAlignPointer(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 ficlPrimitiveBeginCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    markBranch(dictionary, vm, destTag);
    return;
}

static void ficlPrimitiveUntilCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
    resolveBackBranch(dictionary, vm, destTag);
    return;
}

static void ficlPrimitiveWhileCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_STACK_CHECK(vm->dataStack, 2, 5);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
    markBranch(dictionary, vm, origTag);

	/* equivalent to 2swap */
    ficlStackRoll(vm->dataStack, 3);
    ficlStackRoll(vm->dataStack, 3);

    ficlDictionaryAppendUnsigned(dictionary, 1);
    return;
}

static void ficlPrimitiveRepeatCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
    /* expect "begin" branch marker */
    resolveBackBranch(dictionary, vm, destTag);
    /* expect "while" branch marker */
    resolveForwardBranch(dictionary, vm, origTag);
    return;
}


static void ficlPrimitiveAgainCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
    /* expect "begin" branch marker */
    resolveBackBranch(dictionary, vm, 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 ficlPrimitiveChar(ficlVm *vm)
{
    ficlString s;

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    s = ficlVmGetWord(vm);
    ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0]));
    return;
}

static void ficlPrimitiveCharCoIm(ficlVm *vm)
{
    ficlPrimitiveChar(vm);
    ficlPrimitiveLiteralIm(vm);
    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 ficlPrimitiveCharPlus(ficlVm *vm)
{
    char *p;

    FICL_STACK_CHECK(vm->dataStack,1,1);


    p = ficlStackPopPointer(vm->dataStack);
    ficlStackPushPointer(vm->dataStack, p + 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 ficlPrimitiveChars(ficlVm *vm)
{
    if (sizeof (char) > 1)
    {
        ficlInteger i;

        FICL_STACK_CHECK(vm->dataStack,1,1);

        i = ficlStackPopInteger(vm->dataStack);
        ficlStackPushInteger(vm->dataStack, 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 ficlPrimitiveCount(ficlVm *vm)
{
    ficlCountedString *counted;

    FICL_STACK_CHECK(vm->dataStack,1,2);


    counted = ficlStackPopPointer(vm->dataStack);
    ficlStackPushPointer(vm->dataStack, counted->text);
    ficlStackPushUnsigned(vm->dataStack, counted->length);
    return;
}

/**************************************************************************
                        e n v i r o n m e n t ?
** environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_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 FICL_FALSE; otherwise, the flag
** is FICL_TRUE and the i*x returned is of the type specified in the table for
** the attribute queried. 
**************************************************************************/
static void ficlPrimitiveEnvironmentQ(ficlVm *vm)
{
    ficlDictionary *environment;
    ficlWord *word;
    ficlString name;

    FICL_STACK_CHECK(vm->dataStack, 2, 1);


    environment = vm->callback.system->environment;
    name.length = ficlStackPopUnsigned(vm->dataStack);
    name.text    = ficlStackPopPointer(vm->dataStack);

    word = ficlDictionaryLookup(environment, name);

    if (word != NULL)
    {
        ficlVmExecuteWord(vm, word);
        ficlStackPushInteger(vm->dataStack, FICL_TRUE);
    }
    else
    {
        ficlStackPushInteger(vm->dataStack, 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 FICL_VM_STATE_INTERPRET.
** When the parse area is empty, restore the prior input source
** specification. Other stack effects are due to the words EVALUATEd. 
**
**************************************************************************/
static void ficlPrimitiveEvaluate(ficlVm *vm)
{
    ficlCell id;
    int result;
	ficlString string;

    FICL_STACK_CHECK(vm->dataStack,2,0);


    FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack));
    FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack));

    id = vm->sourceId;
    vm->sourceId.i = -1;
    result = ficlVmExecuteString(vm, string);
    vm->sourceId = id;
    if (result != FICL_VM_STATUS_OUT_OF_TEXT)
        ficlVmThrow(vm, 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: FICL_VM_STATE_COMPILE code to push the address and count of a string
** literal, FICL_VM_STATE_COMPILE the string from the input stream, and align the dictionary
** pointer.
**************************************************************************/
static void ficlPrimitiveStringQuoteIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    if (vm->state == FICL_VM_STATE_INTERPRET)
    {
        ficlCountedString *counted = (ficlCountedString *)dictionary->here;
        ficlVmGetString(vm, counted, '\"');
        ficlStackPushPointer(vm->dataStack, counted->text);
        ficlStackPushUnsigned(vm->dataStack, counted->length);
    }
    else    /* FICL_VM_STATE_COMPILE state */
    {
	    ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
        dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
        ficlDictionaryAlign(dictionary);
    }

    return;
}


/**************************************************************************
                        t y p e
** Pop count and char address from stack and print the designated string.
**************************************************************************/
static void ficlPrimitiveType(ficlVm *vm)
{
    ficlUnsigned length;
    char *s;

    FICL_STACK_CHECK(vm->dataStack, 2, 0);


    length = ficlStackPopUnsigned(vm->dataStack);
    s = ficlStackPopPointer(vm->dataStack);
	
	if ((s == NULL) || (length == 0))
		return;

    /* 
    ** 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 (s[length] != 0)
    {
        char *here = (char *)ficlVmGetDictionary(vm)->here;
        if (s != here)
            strncpy(here, s, length);

        here[length] = '\0';
        s = here;
    }

    ficlVmTextOut(vm, s);
    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 ficlPrimitiveWord(ficlVm *vm)
{
    ficlCountedString *counted;
    char delim;
    ficlString name;

    FICL_STACK_CHECK(vm->dataStack, 1, 1);


    counted = (ficlCountedString *)vm->pad;
    delim = (char)ficlStackPopInteger(vm->dataStack);
    name = ficlVmParseStringEx(vm, delim, 1);

    if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1)
        FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1);

    counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
    strncpy(counted->text, FICL_STRING_GET_POINTER(name), FICL_STRING_GET_LENGTH(name));

	/* store an extra space at the end of the primitive... why? dunno yet.  Guy Carver did it. */
    counted->text[counted->length] = ' ';
    counted->text[counted->length + 1] = 0;

    ficlStackPushPointer(vm->dataStack, counted);
    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 ficlPrimitiveParseNoCopy(ficlVm *vm)
{
    ficlString s;

    FICL_STACK_CHECK(vm->dataStack, 0, 2);


    s = ficlVmGetWord0(vm);
    ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
    ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
    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 ficlPrimitiveParse(ficlVm *vm)
{
    ficlString s;
    char delim;


    FICL_STACK_CHECK(vm->dataStack, 1, 2);


    delim = (char)ficlStackPopInteger(vm->dataStack);

    s = ficlVmParseStringEx(vm, delim, 0);
    ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
    ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
    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(ficlVm *vm, ficlString name, void *returnForFailure)
{
    ficlWord *word;

    word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
    if (word)
    {
        ficlStackPushPointer(vm->dataStack, word);
        ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1));
    }
    else
    {
        ficlStackPushPointer(vm->dataStack, returnForFailure);
        ficlStackPushUnsigned(vm->dataStack, 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 ficlPrimitiveCFind(ficlVm *vm)
{
    ficlCountedString *counted;
    ficlString name;


    FICL_STACK_CHECK(vm->dataStack, 1, 2);

    counted = ficlStackPopPointer(vm->dataStack);
    FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted);
    do_find(vm, name, counted);
}



/**************************************************************************
                        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 ficlPrimitiveSFind(ficlVm *vm)
{
    ficlString name;


    FICL_STACK_CHECK(vm->dataStack, 2, 2);


    name.length = ficlStackPopInteger(vm->dataStack);
    name.text = ficlStackPopPointer(vm->dataStack);

    do_find(vm, name, NULL);
}



/**************************************************************************
                        r e c u r s e
** 
**************************************************************************/
static void ficlPrimitiveRecurseCoIm(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_IGNORE(vm);
    ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(dictionary->smudge));
    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 ficlPrimitiveSource(ficlVm *vm)
{

    FICL_STACK_CHECK(vm->dataStack,0,2);

    ficlStackPushPointer(vm->dataStack, vm->tib.text);
    ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm));
    return;
}


/**************************************************************************
                        v e r s i o n
** non-standard...
**************************************************************************/
static void ficlPrimitiveVersion(ficlVm *vm)
{
    ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n");
    return;
}


/**************************************************************************
                        t o I n
** to-in CORE
**************************************************************************/
static void ficlPrimitiveToIn(ficlVm *vm)
{

    FICL_STACK_CHECK(vm->dataStack,0,1);

    ficlStackPushPointer(vm->dataStack, &vm->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 FICL_VM_STATE_COMPILE.
**************************************************************************/
static void ficlPrimitiveColonNoName(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlWord *word;
    ficlString name;

    FICL_STRING_SET_LENGTH(name, 0);
    FICL_STRING_SET_POINTER(name, NULL);

    vm->state = FICL_VM_STATE_COMPILE;
    word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionColonParen, FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
    ficlStackPushPointer(vm->dataStack, word);
    markControlTag(vm, 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 ficlCell
** 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 ficlCell, and a redefinition
** (also in softcore) of "user" that defines a user word and increments
** nUser.
**************************************************************************/
#if FICL_WANT_USER
static void ficlPrimitiveUser(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);
    ficlCell c;

    c = ficlStackPop(vm->dataStack);
    if (c.i >= FICL_USER_CELLS)
    {
        ficlVmThrowError(vm, "Error - out of user space");
    }

    ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT);
    ficlDictionaryAppendCell(dictionary, c);
    return;
}
#endif


#if FICL_WANT_LOCALS
/*
** 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).
*/
void ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlInteger nLocal = vm->runningWord->param[0].i;

#if !FICL_WANT_FLOAT
	FICL_VM_ASSERT(vm, !isFloat);
	/* get rid of unused parameter warning */
	isFloat = 0;
#endif /* FICL_WANT_FLOAT */

    if (vm->state == FICL_VM_STATE_INTERPRET)
    {
		ficlStack *stack;
#if FICL_WANT_FLOAT
		if (isFloat)
			stack = vm->floatStack;
		else
#endif /* FICL_WANT_FLOAT */
		stack = vm->dataStack;

        ficlStackPush(stack, vm->returnStack->frame[nLocal]);
		if (isDouble)
            ficlStackPush(stack, vm->returnStack->frame[nLocal+1]);
    }
    else
    {
		ficlInstruction instruction;
		ficlInteger appendLocalOffset;
#if FICL_WANT_FLOAT
        if (isFloat)
		{
			instruction = (isDouble) ? ficlInstructionGetF2LocalParen : ficlInstructionGetFLocalParen;
			appendLocalOffset = FICL_TRUE;
		}
		else
#endif /* FICL_WANT_FLOAT */
		if (nLocal == 0)
		{
			instruction = (isDouble) ? ficlInstructionGet2Local0 : ficlInstructionGetLocal0;
			appendLocalOffset = FICL_FALSE;
		}
		else if ((nLocal == 1) && !isDouble)
		{
			instruction = ficlInstructionGetLocal1;
			appendLocalOffset = FICL_FALSE;
		}
		else
		{
			instruction = (isDouble) ? ficlInstructionGet2LocalParen : ficlInstructionGetLocalParen;
			appendLocalOffset = FICL_TRUE;
		}

		ficlDictionaryAppendUnsigned(dictionary, instruction);
		if (appendLocalOffset)
			ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(nLocal));
    }
    return;
}

static void ficlPrimitiveDoLocalIm(ficlVm *vm)
{
    ficlLocalParenIm(vm, 0, 0);
}

static void ficlPrimitiveDo2LocalIm(ficlVm *vm)
{
    ficlLocalParenIm(vm, 1, 0);
}

#if FICL_WANT_FLOAT
static void ficlPrimitiveDoFLocalIm(ficlVm *vm)
{
    ficlLocalParenIm(vm, 0, 1);
}

static void ficlPrimitiveDoF2LocalIm(ficlVm *vm)
{
    ficlLocalParenIm(vm, 1, 1);
}
#endif /* FICL_WANT_FLOAT */



/**************************************************************************
                        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. 
**************************************************************************/
void ficlLocalParen(ficlVm *vm, int isDouble, int isFloat)
{
    ficlDictionary *dictionary;
    ficlString name;

    FICL_STACK_CHECK(vm->dataStack,2,0);  


    dictionary = ficlVmGetDictionary(vm);
    FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
    FICL_STRING_SET_POINTER(name, (char *)ficlStackPopPointer(vm->dataStack));

    if (FICL_STRING_GET_LENGTH(name) > 0)
    {   /* add a local to the **locals** dictionary and update localsCount */
        ficlPrimitive code;
		ficlInstruction instruction;
        ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
        if (vm->callback.system->localsCount >= FICL_MAX_LOCALS)
        {
            ficlVmThrowError(vm, "Error: out of local space");
        }

#if !FICL_WANT_FLOAT
		FICL_VM_ASSERT(vm, !isFloat);
		/* get rid of unused parameter warning */
		isFloat = 0;
#else /* FICL_WANT_FLOAT */
		if (isFloat)
		{
			if (isDouble)
			{
				code = ficlPrimitiveDoF2LocalIm;
				instruction = ficlInstructionToF2LocalParen;
			}
			else
			{
				code = ficlPrimitiveDoFLocalIm;
				instruction = ficlInstructionToFLocalParen;
			}
		}
		else
#endif /* FICL_WANT_FLOAT */
        if (isDouble)
		{
			code = ficlPrimitiveDo2LocalIm;
			instruction = ficlInstructionTo2LocalParen;
		}
		else
		{
			code = ficlPrimitiveDoLocalIm;
			instruction = ficlInstructionToLocalParen;
		}

        ficlDictionaryAppendWord(locals, name, code, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
        ficlDictionaryAppendCell(locals,  FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));

        if (vm->callback.system->localsCount == 0)
        {   /* FICL_VM_STATE_COMPILE code to create a local stack frame */
            ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLinkParen);
            /* save location in dictionary for #locals */
            vm->callback.system->localsFixup = dictionary->here;
            ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));
        }

        ficlDictionaryAppendUnsigned(dictionary, instruction);
        ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));

        vm->callback.system->localsCount += (isDouble) ? 2 : 1;
    }
    else if (vm->callback.system->localsCount > 0)
    {
        /* write localsCount to (link) param area in dictionary */
        *(ficlInteger *)(vm->callback.system->localsFixup) = vm->callback.system->localsCount;
    }

    return;
}


static void ficlPrimitiveLocalParen(ficlVm *vm)
{
   ficlLocalParen(vm, 0, 0);
}

static void ficlPrimitive2LocalParen(ficlVm *vm)
{
   ficlLocalParen(vm, 1, 0);
}


#endif /* FICL_WANT_LOCALS */


/**************************************************************************
                        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 ficlPrimitiveToValue(ficlVm *vm)
{
    ficlString name = ficlVmGetWord(vm);
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlWord *word;
	ficlInstruction instruction = 0;
	ficlStack *stack;
	ficlInteger isDouble;
#if FICL_WANT_LOCALS
	ficlInteger nLocal;
	ficlInteger appendLocalOffset;
	ficlInteger isFloat;
#endif /* FICL_WANT_LOCALS */

#if FICL_WANT_LOCALS
    if ((vm->callback.system->localsCount > 0) && (vm->state == FICL_VM_STATE_COMPILE))
    {
        ficlDictionary *locals;

        locals = ficlSystemGetLocals(vm->callback.system);
        word = ficlDictionaryLookup(locals, name);
		if (!word)
			goto TO_GLOBAL;

		if (word->code == ficlPrimitiveDoLocalIm)
		{
			instruction = ficlInstructionToLocalParen;
			isDouble = isFloat = FICL_FALSE;
		}
		else if (word->code == ficlPrimitiveDo2LocalIm)
		{
			instruction = ficlInstructionTo2LocalParen;
			isDouble = FICL_TRUE;
			isFloat = FICL_FALSE;
		}
#if FICL_WANT_FLOAT
		else if (word->code == ficlPrimitiveDoFLocalIm)
		{
			instruction = ficlInstructionToFLocalParen;
			isDouble = FICL_FALSE;
			isFloat = FICL_TRUE;
		}
		else if (word->code == ficlPrimitiveDoF2LocalIm)
		{
			instruction = ficlInstructionToF2LocalParen;
			isDouble = isFloat = FICL_TRUE;
		}
#endif /* FICL_WANT_FLOAT */
		else
		{
			ficlVmThrowError(vm, "to %.*s : local is of unknown type", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
			return;
		}

		nLocal = word->param[0].i;
		appendLocalOffset = FICL_TRUE;

#if FICL_WANT_FLOAT
		if (!isFloat)
		{
#endif /* FICL_WANT_FLOAT */
		if (nLocal == 0)
		{
			instruction = (isDouble) ? ficlInstructionTo2Local0 : ficlInstructionToLocal0;
			appendLocalOffset = FICL_FALSE;
		}
		else if ((nLocal == 1) && !isDouble)
		{
			instruction = ficlInstructionToLocal1;
			appendLocalOffset = FICL_FALSE;
		}
#if FICL_WANT_FLOAT
		}
#endif /* FICL_WANT_FLOAT */
		
        ficlDictionaryAppendUnsigned(dictionary, instruction);
		if (appendLocalOffset)
			ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(nLocal));
        return;
    }
#endif

#if FICL_WANT_LOCALS
TO_GLOBAL:
#endif /* FICL_WANT_LOCALS */
    word = ficlDictionaryLookup(dictionary, name);
    if (!word)
        ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));

	switch ((ficlInstruction)word->code)
	{
		case ficlInstructionConstantParen:
			instruction = ficlInstructionStore;
			stack = vm->dataStack;
			isDouble = FICL_FALSE;
			break;
		case ficlInstruction2ConstantParen:
			instruction = ficlInstruction2Store;
			stack = vm->dataStack;
			isDouble = FICL_TRUE;
			break;
#if FICL_WANT_FLOAT
		case ficlInstructionFConstantParen:
			instruction = ficlInstructionFStore;
			stack = vm->floatStack;
			isDouble = FICL_FALSE;
			break;
		case ficlInstructionF2ConstantParen:
			instruction = ficlInstructionF2Store;
			stack = vm->floatStack;
			isDouble = FICL_TRUE;
			break;
#endif /* FICL_WANT_FLOAT */
		default:
		{
		    ficlVmThrowError(vm, "to %.*s : value/constant is of unknown type", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
		    return;
		}
	}
	
    if (vm->state == FICL_VM_STATE_INTERPRET)
	{
        word->param[0] = ficlStackPop(stack);
		if (isDouble)
			word->param[1] = ficlStackPop(stack);
	}
    else        /* FICL_VM_STATE_COMPILE code to store to word's param */
    {
        ficlStackPushPointer(vm->dataStack, &word->param[0]);
        ficlPrimitiveLiteralIm(vm);
        ficlDictionaryAppendUnsigned(dictionary, instruction);
    }
    return;
}


/**************************************************************************
						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-ficlCell signed integer. 
**************************************************************************/
static void ficlPrimitiveFMSlashMod(ficlVm *vm)
{
	ficl2Integer d1;
	ficlInteger n1;
	ficl2IntegerQR qr;

	FICL_STACK_CHECK(vm->dataStack, 3, 2);

	n1 = ficlStackPopInteger(vm->dataStack);
	d1 = ficlStackPop2Integer(vm->dataStack);
	qr = ficl2IntegerDivideFloored(d1, n1);
	ficlStackPushInteger(vm->dataStack, qr.remainder);
	ficlStackPushInteger(vm->dataStack, FICL_2UNSIGNED_GET_LOW(qr.quotient));
	return;
}


/**************************************************************************
						s m S l a s h R e m
** s-m-slash-remainder 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-ficlCell signed integer. 
**************************************************************************/
static void ficlPrimitiveSMSlashRem(ficlVm *vm)
{
	ficl2Integer d1;
	ficlInteger n1;
	ficl2IntegerQR qr;
	
	FICL_STACK_CHECK(vm->dataStack, 3, 2);

	n1 = ficlStackPopInteger(vm->dataStack);
	d1 = ficlStackPop2Integer(vm->dataStack);
	qr = ficl2IntegerDivideSymmetric(d1, n1);
	ficlStackPushInteger(vm->dataStack, qr.remainder);
	ficlStackPushInteger(vm->dataStack, FICL_2UNSIGNED_GET_LOW(qr.quotient));
	return;
}


static void ficlPrimitiveMod(ficlVm *vm)
{
	ficl2Integer d1;
	ficlInteger n1;
	ficlInteger i;
	ficl2IntegerQR qr;
	FICL_STACK_CHECK(vm->dataStack, 2, 1);

	n1 = ficlStackPopInteger(vm->dataStack);
	i = ficlStackPopInteger(vm->dataStack);
	FICL_INTEGER_TO_2INTEGER(i, d1);
	qr = ficl2IntegerDivideSymmetric(d1, n1);
	ficlStackPushInteger(vm->dataStack, qr.remainder);
	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-ficlCell unsigned integer. 
*************************************************************************/
static void ficlPrimitiveUMSlashMod(ficlVm *vm)
{
	ficl2Unsigned ud;
	ficlUnsigned u1;
	ficl2UnsignedQR uqr;

	u1    = ficlStackPopUnsigned(vm->dataStack);
	ud    = ficlStackPop2Unsigned(vm->dataStack);
	uqr   = ficl2UnsignedDivide(ud, u1);
	ficlStackPushUnsigned(vm->dataStack, uqr.remainder);
	ficlStackPushUnsigned(vm->dataStack, FICL_2UNSIGNED_GET_LOW(uqr.quotient));
	return;
}



/**************************************************************************
						m S t a r
** m-star CORE ( n1 n2 -- d )
** d is the signed product of n1 times n2. 
**************************************************************************/
static void ficlPrimitiveMStar(ficlVm *vm)
{
	ficlInteger n2;
	ficlInteger n1;
	ficl2Integer d;
	FICL_STACK_CHECK(vm->dataStack, 2, 2);

	n2 = ficlStackPopInteger(vm->dataStack);
	n1 = ficlStackPopInteger(vm->dataStack);

	d = ficl2IntegerMultiply(n1, n2);
	ficlStackPush2Integer(vm->dataStack, d);
	return;
}


static void ficlPrimitiveUMStar(ficlVm *vm)
{
	ficlUnsigned u2;
	ficlUnsigned u1;
	ficl2Unsigned ud;
	FICL_STACK_CHECK(vm->dataStack, 2, 2);

	u2 = ficlStackPopUnsigned(vm->dataStack);
	u1 = ficlStackPopUnsigned(vm->dataStack);

	ud = ficl2UnsignedMultiply(u1, u2);
	ficlStackPush2Unsigned(vm->dataStack, ud);
	return;
}


/**************************************************************************
						d n e g a t e
** DOUBLE   ( d1 -- d2 )
** d2 is the negation of d1. 
**************************************************************************/
static void ficlPrimitiveDNegate(ficlVm *vm)
{
	ficl2Integer i = ficlStackPop2Integer(vm->dataStack);
	i = ficl2IntegerNegate(i);
	ficlStackPush2Integer(vm->dataStack, i);

	return;
}




/**************************************************************************
                        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 ficlPrimitivePad(ficlVm *vm)
{
    ficlStackPushPointer(vm->dataStack, vm->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 ficlPrimitiveSourceID(ficlVm *vm)
{
    ficlStackPushInteger(vm->dataStack, vm->sourceId.i);
    return;
}


/**************************************************************************
                        r e f i l l
** CORE EXT   ( -- flag )
** Attempt to fill the input buffer from the input source, returning a FICL_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 FICL_TRUE. Receipt of a line containing no
** characters is considered successful. If there is no input available from
** the current input source, return FICL_FALSE. 
** When the input source is a string from EVALUATE, return FICL_FALSE and
** perform no other action. 
**************************************************************************/
static void ficlPrimitiveRefill(ficlVm *vm)
{
    ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE;
    if (ret && (vm->restart == 0))
        ficlVmThrow(vm, FICL_VM_STATUS_RESTART);

    ficlStackPushInteger(vm->dataStack, 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 ficlPrimitiveCatch(ficlVm *vm)
{
    int         except;
    jmp_buf     vmState;
    ficlVm     vmCopy;
    ficlStack  dataStackCopy;
    ficlStack  returnStackCopy;
    ficlWord   *word;

    FICL_VM_ASSERT(vm, vm);
    FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
    

    /*
    ** 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. :-)
    */

    FICL_STACK_CHECK(vm->dataStack, 1, 0);

    word = ficlStackPopPointer(vm->dataStack);

    /* 
    ** 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 vm, and vm
    ** "stacks" (a structure containing general information
    ** about it, including the current stack pointer).
    */
    memcpy((void*)&vmCopy, (void*)vm, sizeof(ficlVm));
    memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof(ficlStack));
    memcpy((void*)&returnStackCopy, (void*)vm->returnStack, sizeof(ficlStack));

    /*
    ** Give vm a jmp_buf
    */
    vm->exceptionHandler = &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:
        ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));          /* Open mouth, insert emetic */
        ficlVmExecuteWord(vm, word);
        ficlVmInnerLoop(vm, 0);
        break;

        /*
        ** Normal exit from XT - lose the poison pill, 
        ** restore old setjmp vector and push a zero. 
        */
    case FICL_VM_STATUS_INNER_EXIT:
        ficlVmPopIP(vm);                   /* Gack - hurl poison pill */
        vm->exceptionHandler = vmCopy.exceptionHandler;        /* Restore just the setjmp vector */
        ficlStackPushInteger(vm->dataStack, 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*)vm, (void*)&vmCopy, sizeof(ficlVm));
        memcpy((void*)vm->dataStack, (void*)&dataStackCopy, sizeof(ficlStack));
        memcpy((void*)vm->returnStack, (void*)&returnStackCopy, sizeof(ficlStack));

        ficlStackPushInteger(vm->dataStack, 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 ficlPrimitiveThrow(ficlVm *vm)
{
    int except;
    
    except = ficlStackPopInteger(vm->dataStack);

    if (except)
        ficlVmThrow(vm, except);
}


/**************************************************************************
**                     a l l o c a t e
** MEMORY
**************************************************************************/
static void ficlPrimitiveAllocate(ficlVm *vm)
{
    size_t size;
    void *p;

    size = ficlStackPopInteger(vm->dataStack);
    p = ficlMalloc(size);
    ficlStackPushPointer(vm->dataStack, p);
    if (p)
        ficlStackPushInteger(vm->dataStack, 0);
    else
        ficlStackPushInteger(vm->dataStack, 1);
}


/**************************************************************************
**                     f r e e 
** MEMORY
**************************************************************************/
static void ficlPrimitiveFree(ficlVm *vm)
{
    void *p;

    p = ficlStackPopPointer(vm->dataStack);
    ficlFree(p);
    ficlStackPushInteger(vm->dataStack, 0);
}


/**************************************************************************
**                     r e s i z e
** MEMORY
**************************************************************************/
static void ficlPrimitiveResize(ficlVm *vm)
{
    size_t size;
    void *new, *old;

    size = ficlStackPopInteger(vm->dataStack);
    old = ficlStackPopPointer(vm->dataStack);
    new = ficlRealloc(old, size);
    if (new) 
    {
        ficlStackPushPointer(vm->dataStack, new);
        ficlStackPushInteger(vm->dataStack, 0);
    } 
    else 
    {
        ficlStackPushPointer(vm->dataStack, old);
        ficlStackPushInteger(vm->dataStack, 1);
    }
}


/**************************************************************************
**                     e x i t - i n n e r 
** Signals execXT that an inner loop has completed
**************************************************************************/
static void ficlPrimitiveExitInner(ficlVm *vm)
{
    ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT);
}


#if 0
/**************************************************************************
                        
** 
**************************************************************************/
static void ficlPrimitiveName(ficlVm *vm)
{
    FICL_IGNORE(vm);
    return;
}


#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 ficlSystemCompileCore(ficlSystem *system)
{
	ficlWord *interpret;
    ficlDictionary *dictionary = ficlSystemGetDictionary(system);
    ficlDictionary *environment = ficlSystemGetEnvironment(system);

    FICL_SYSTEM_ASSERT(system, dictionary);
    FICL_SYSTEM_ASSERT(system, environment);


	#define FICL_TOKEN(token, description) 
	#define FICL_INSTRUCTION_TOKEN(token, description, flags) ficlDictionarySetInstruction(dictionary, description, token, flags);
	#include "ficltokens.h"
	#undef FICL_TOKEN
	#undef FICL_INSTRUCTION_TOKEN

    /*
    ** The Core word set
    ** see softcore.c for definitions of: abs bl space spaces abort"
    */
    ficlDictionarySetPrimitive(dictionary, "#",         ficlPrimitiveNumberSign,     FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "#>",        ficlPrimitiveNumberSignGreater,FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "#s",        ficlPrimitiveNumberSignS,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "\'",        ficlPrimitiveTick,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "(",         ficlPrimitiveParenthesis,    FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "+loop",     ficlPrimitivePlusLoopCoIm,   FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, ".",         ficlPrimitiveDot,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ".\"",       ficlPrimitiveDotQuoteCoIm,   FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, ":",         ficlPrimitiveColon,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ";",         ficlPrimitiveSemicolonCoIm,  FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "<#",        ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ">body",     ficlPrimitiveToBody,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ">in",       ficlPrimitiveToIn,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ">number",   ficlPrimitiveToNumber,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "abort",     ficlPrimitiveAbort,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "accept",    ficlPrimitiveAccept,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "align",     ficlPrimitiveAlign,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "aligned",   ficlPrimitiveAligned,        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "allot",     ficlPrimitiveAllot,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "base",      ficlPrimitiveBase,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "begin",     ficlPrimitiveBeginCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "case",      ficlPrimitiveCaseCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "char",      ficlPrimitiveChar,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "char+",     ficlPrimitiveCharPlus,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "chars",     ficlPrimitiveChars,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "constant",  ficlPrimitiveConstant,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "count",     ficlPrimitiveCount,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "cr",        ficlPrimitiveCR,             FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "create",    ficlPrimitiveCreate,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "decimal",   ficlPrimitiveDecimal,        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "depth",     ficlPrimitiveDepth,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "do",        ficlPrimitiveDoCoIm,         FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "does>",     ficlPrimitiveDoesCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "else",      ficlPrimitiveElseCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "emit",      ficlPrimitiveEmit,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "endcase",   ficlPrimitiveEndcaseCoIm,    FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "endof",     ficlPrimitiveEndofCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "environment?", ficlPrimitiveEnvironmentQ,FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "evaluate",  ficlPrimitiveEvaluate,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "execute",   ficlPrimitiveExecute,        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "exit",      ficlPrimitiveExitCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "fallthrough",ficlPrimitiveFallthroughCoIm,FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "find",      ficlPrimitiveCFind,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "fm/mod",    ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "here",      ficlPrimitiveHere,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "hold",      ficlPrimitiveHold,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "if",        ficlPrimitiveIfCoIm,         FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "immediate", ficlPrimitiveImmediate,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "literal",   ficlPrimitiveLiteralIm,      FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "loop",      ficlPrimitiveLoopCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "m*",        ficlPrimitiveMStar,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "mod",       ficlPrimitiveMod,        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "of",        ficlPrimitiveOfCoIm,         FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "postpone",  ficlPrimitivePostponeCoIm,   FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "quit",      ficlPrimitiveQuit,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "recurse",   ficlPrimitiveRecurseCoIm,    FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "repeat",    ficlPrimitiveRepeatCoIm,     FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "s\"",       ficlPrimitiveStringQuoteIm,  FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "sign",      ficlPrimitiveSign,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "sm/rem",    ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "source",    ficlPrimitiveSource,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "state",     ficlPrimitiveState,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "then",      ficlPrimitiveEndifCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "type",      ficlPrimitiveType,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "u.",        ficlPrimitiveUDot,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "um*",       ficlPrimitiveUMStar,     FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "um/mod",    ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "until",     ficlPrimitiveUntilCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "variable",  ficlPrimitiveVariable,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "while",     ficlPrimitiveWhileCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "word",      ficlPrimitiveWord,   FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "[",         ficlPrimitiveLeftBracketCoIm,   FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "[\']",      ficlPrimitiveBracketTickCoIm,FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "[char]",    ficlPrimitiveCharCoIm,       FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "]",         ficlPrimitiveRightBracket,       FICL_WORD_DEFAULT);
    /* 
    ** The Core Extensions word set...
    ** see softcore.fr for other definitions
    */
    /* "#tib" */
    ficlDictionarySetPrimitive(dictionary, ".(",        ficlPrimitiveDotParen,       FICL_WORD_IMMEDIATE);
    /* ".r" */
    ficlDictionarySetPrimitive(dictionary, ":noname",   ficlPrimitiveColonNoName,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "?do",       ficlPrimitiveQDoCoIm,        FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "again",     ficlPrimitiveAgainCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "c\"",       ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "hex",       ficlPrimitiveHex,            FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "pad",       ficlPrimitivePad,            FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "parse",     ficlPrimitiveParse,          FICL_WORD_DEFAULT);
    /* query restore-input save-input tib u.r u> unused [FICL_VM_STATE_COMPILE] */
    ficlDictionarySetPrimitive(dictionary, "refill",    ficlPrimitiveRefill,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "source-id", ficlPrimitiveSourceID,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "to",        ficlPrimitiveToValue,        FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "value",     ficlPrimitiveConstant,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "\\",        ficlPrimitiveBackslash,    FICL_WORD_IMMEDIATE);


    /*
    ** Environment query values for the Core word set
    */
    ficlDictionarySetConstant(environment, "/counted-string",   FICL_COUNTED_STRING_MAX);
    ficlDictionarySetConstant(environment, "/hold",             FICL_PAD_SIZE);
    ficlDictionarySetConstant(environment, "/pad",              FICL_PAD_SIZE);
    ficlDictionarySetConstant(environment, "address-unit-bits", 8);
    ficlDictionarySetConstant(environment, "core",              FICL_TRUE);
    ficlDictionarySetConstant(environment, "core-ext",          FICL_FALSE);
    ficlDictionarySetConstant(environment, "floored",           FICL_FALSE);
    ficlDictionarySetConstant(environment, "max-char",          UCHAR_MAX);
    ficlDictionarySetConstant(environment, "max-n",             0x7fffffff);
    ficlDictionarySetConstant(environment, "max-u",             0xffffffff);
	{
	ficl2Unsigned combined;
	FICL_2UNSIGNED_SET(INT_MAX, UINT_MAX, combined);
    ficlDictionarySet2Constant(environment,"max-d",             FICL_2UNSIGNED_TO_2INTEGER(combined));
	FICL_2UNSIGNED_SET(UINT_MAX, UINT_MAX, combined);
    ficlDictionarySet2Constant(environment,"max-ud",            FICL_2UNSIGNED_TO_2INTEGER(combined));
	}
    ficlDictionarySetConstant(environment, "return-stack-cells",FICL_DEFAULT_STACK_SIZE);
    ficlDictionarySetConstant(environment, "stack-cells",       FICL_DEFAULT_STACK_SIZE);

    /*
    ** The optional Double-Number word set (partial)
    */
    ficlDictionarySetPrimitive(dictionary, "2constant", ficlPrimitive2Constant,    FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "2value",    ficlPrimitive2Constant,    FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "2literal",  ficlPrimitive2LiteralIm,   FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "2variable", ficlPrimitive2Variable,    FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "dnegate",   ficlPrimitiveDNegate,    FICL_WORD_DEFAULT);


    /*
    ** The optional Exception and Exception Extensions word set
    */
    ficlDictionarySetPrimitive(dictionary, "catch",     ficlPrimitiveCatch,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "throw",     ficlPrimitiveThrow,      FICL_WORD_DEFAULT);

    ficlDictionarySetConstant(environment, "exception",         FICL_TRUE);
    ficlDictionarySetConstant(environment, "exception-ext",     FICL_TRUE);

    /*
    ** The optional Locals and Locals Extensions word set
    ** see softcore.c for implementation of locals|
    */
#if FICL_WANT_LOCALS
    ficlDictionarySetPrimitive(dictionary, "doLocal",   ficlPrimitiveDoLocalIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "(local)",   ficlPrimitiveLocalParen,     FICL_WORD_COMPILE_ONLY);
    ficlDictionarySetPrimitive(dictionary, "(2local)",  ficlPrimitive2LocalParen,  FICL_WORD_COMPILE_ONLY);

    ficlDictionarySetConstant(environment, "locals",            FICL_TRUE);
    ficlDictionarySetConstant(environment, "locals-ext",        FICL_TRUE);
    ficlDictionarySetConstant(environment, "#locals",           FICL_MAX_LOCALS);
#endif

    /*
    ** The optional Memory-Allocation word set
    */

    ficlDictionarySetPrimitive(dictionary, "allocate",  ficlPrimitiveAllocate,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "free",      ficlPrimitiveFree,        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "resize",    ficlPrimitiveResize,      FICL_WORD_DEFAULT);
    
    ficlDictionarySetConstant(environment, "memory-alloc",      FICL_TRUE);

    /*
    ** The optional Search-Order word set 
    */
    ficlSystemCompileSearch(system);

    /*
    ** The optional Programming-Tools and Programming-Tools Extensions word set
    */
    ficlSystemCompileTools(system);

    /*
    ** The optional File-Access and File-Access Extensions word set
    */
#if FICL_WANT_FILE
    ficlSystemCompileFile(system);
#endif

    /*
    ** Ficl extras
    */
    ficlDictionarySetPrimitive(dictionary, ".ver",      ficlPrimitiveVersion,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, ">name",     ficlPrimitiveToName,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "add-parse-step",
                                    ficlPrimitiveAddParseStep,   FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "body>",     ficlPrimitiveFromBody,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "compile-only",
                                    ficlPrimitiveCompileOnly,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "endif",     ficlPrimitiveEndifCoIm,      FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "last-word", ficlPrimitiveLastWord,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "hash",      ficlPrimitiveHash,           FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "objectify", ficlPrimitiveSetObjectFlag,  FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "?object",   ficlPrimitiveIsObject,       FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "parse-word",ficlPrimitiveParseNoCopy,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "sfind",     ficlPrimitiveSFind,          FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "sliteral",  ficlPrimitiveSLiteralCoIm,   FICL_WORD_COMPILE_ONLY_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "sprintf",   ficlPrimitiveSprintf,    FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "strlen",    ficlPrimitiveStrlen,     FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "x.",        ficlPrimitiveHexDot,         FICL_WORD_DEFAULT);
#if FICL_WANT_USER
    ficlDictionarySetPrimitive(dictionary, "user",      ficlPrimitiveUser,   FICL_WORD_DEFAULT);
#endif

    /*
    ** internal support words
    */
    interpret =
    ficlDictionarySetPrimitive(dictionary, "interpret", ficlPrimitiveInterpret,      FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "lookup",    ficlPrimitiveLookup,         FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "(parse-step)", 
                                    ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
	system->exitInnerWord =
    ficlDictionarySetPrimitive(dictionary, "exit-inner",ficlPrimitiveExitInner,  FICL_WORD_DEFAULT);

	/*
	** Set constants representing the internal instruction words
	** If you want all of 'em, turn that "#if 0" to "#if 1".
	** By default you only get the numbers (fi0, fiNeg1, etc).
	*/
	#define FICL_TOKEN(token, description) ficlDictionarySetConstant(dictionary, #token, token);
#if 0
	#define FICL_INSTRUCTION_TOKEN(token, description, flags) ficlDictionarySetConstant(dictionary, #token, token);
#else
	#define FICL_INSTRUCTION_TOKEN(token, description, flags) 
#endif /* 0 */
	#include "ficltokens.h"
	#undef FICL_TOKEN
	#undef FICL_INSTRUCTION_TOKEN


    /*
    ** Set up system's outer interpreter loop - maybe this should be in initSystem?
    */
	system->interpreterLoop[0] = interpret;
	system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen;
	system->interpreterLoop[2] = (ficlWord *)(void *)(-2);

    FICL_SYSTEM_ASSERT(system, ficlDictionaryCellsAvailable(dictionary) > 0);

    return;
}