xref: /illumos-gate/usr/src/common/ficl/primitives.c (revision 78801af7286cd73dbc996d470f789e75993cf15d)

/*
 * 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 "ficl.h"
#include <limits.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);
}

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

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);
	}
}

/*
 * 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)
{
	ficlCell *patchAddr, c;

	matchControlTag(vm, tag);

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

	patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
	c.i = patchAddr - dictionary->here;

	ficlDictionaryAppendCell(dictionary, c);
}

/*
 * 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).i = offset;
}

/*
 * 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).p = dictionary->here;
}

/*
 * 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);
	(void) ficlDictionaryAppendWord(dictionary, name,
	    (ficlPrimitive)ficlInstructionColonParen,
	    FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);

#if FICL_WANT_LOCALS
	vm->callback.system->localsCount = 0;
#endif
}

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

	matchControlTag(vm, colonTag);

#if FICL_WANT_LOCALS
	if (vm->callback.system->localsCount > 0) {
		ficlDictionary *locals;
		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);
}

/*
 * 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);
}

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

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

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

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

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

/*
 * 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);
	(void) ficlLtoa((c).i, vm->pad, vm->base);
	(void) strcat(vm->pad, " ");
	ficlVmTextOut(vm, vm->pad);
}

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

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

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

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

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

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

/*
 * 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;
				/* FALLTHROUGH */
			case 'u':
			case 'U':
				unsignedInteger = 1; /* true */
				/* FALLTHROUGH */
			case 'd':
			case 'D': {
				int integer;
				integer = ficlStackPopInteger(vm->dataStack);
				if (unsignedInteger)
					(void) ficlUltoa(integer, scratch,
					    base);
				else
					(void) ficlLtoa(integer, scratch, base);
				base = 10;
				unsignedInteger = 0; /* false */
				source = scratch;
				actualLength = strlen(scratch);
				break;
			}
			case '%':
				source = format;
				actualLength = 1;
				/* FALLTHROUGH */
			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, FICL_BOOL(!append));
}

/*
 * 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);
}

/*
 * e m i t   &   f r i e n d s
 */
static void
ficlPrimitiveEmit(ficlVm *vm)
{
	char buffer[2];
	int i;

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

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

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

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);
}

/*
 * 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)
{
	(void) ficlVmParseStringEx(vm, ')', 0);
}

/*
 * 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);
}

/*
 * 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);
						/* (2) pop "if" patch addr */
	patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
	markBranch(dictionary, vm, origTag);	/* (4) push "else" patch addr */

			/* (1) FICL_VM_STATE_COMPILE patch placeholder */
	ficlDictionaryAppendUnsigned(dictionary, 1);
	offset = dictionary->here - patchAddr;
	(*patchAddr).i = offset;		/* (3) Patch "if" */
}

/*
 * e n d i f C o I m
 */
static void
ficlPrimitiveEndifCoIm(ficlVm *vm)
{
	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
	resolveForwardBranch(dictionary, vm, origTag);
}

/*
 * 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);
}

/*
 * 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).i = offset;
	}
}

/*
 * 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).i = offset;
	}
}

/*
 * 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).i = 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).i = 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));
}

/*
 * 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));
			(void) ficlVmExecuteXT(vm, word);
			if (ficlStackPopInteger(vm->dataStack))
				return;
		}
	}

	ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s),
	    FICL_STRING_GET_POINTER(s));
	/* 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));
}

/*
 * 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));
}

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))
		(void) ficlSystemAddParseStep(vm->callback.system, pStep);
}

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

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

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

/*
 * 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);
}

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);
}


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

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

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

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

/*
 * v a r i a b l e
 */
static void
ficlPrimitiveVariable(ficlVm *vm)
{
	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
	ficlString name = ficlVmGetWord(vm);

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

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

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

/*
 * b a s e   &   f r i e n d s
 */
static void
ficlPrimitiveBase(ficlVm *vm)
{
	ficlCell *pBase, c;

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

	pBase = (ficlCell *)(&vm->base);
	c.p = pBase;
	ficlStackPush(vm->dataStack, c);
}

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


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

/*
 * 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);
}

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

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

	dictionary = ficlVmGetDictionary(vm);
	ficlStackPushPointer(vm->dataStack, dictionary->here);
}

/*
 * 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);
}

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

/*
 * 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, ",");
	ficlCell c;

	FICL_VM_ASSERT(vm, pComma);

	ficlPrimitiveTick(vm);
	word = ficlStackGetTop(vm->dataStack).p;
	if (ficlWordIsImmediate(word)) {
		ficlDictionaryAppendCell(dictionary,
		    ficlStackPop(vm->dataStack));
	} else {
		ficlPrimitiveLiteralIm(vm);
		c.p = pComma;
		ficlDictionaryAppendCell(dictionary, c);
	}
}

/*
 * 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);
}

/*
 * 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));
}

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

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

static void
ficlPrimitiveIsObject(ficlVm *vm)
{
	ficlInteger flag;
	ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack);

	flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT))?
	    FICL_TRUE : FICL_FALSE;

	ficlStackPushInteger(vm->dataStack, flag);
}

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

	if (vm->state == FICL_VM_STATE_INTERPRET) {
		ficlCountedString *counted = (ficlCountedString *)
		    dictionary->here;

		(void) 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);
	}
}

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

	FICL_VM_ASSERT(vm, pType);

	ficlDictionaryAppendUnsigned(dictionary,
	    ficlInstructionStringLiteralParen);
	dictionary->here =
	    FICL_POINTER_TO_CELL(ficlVmGetString(vm,
	    (ficlCountedString *)dictionary->here, '\"'));
	ficlDictionaryAlign(dictionary);
	c.p = pType;
	ficlDictionaryAppendCell(dictionary, c);
}

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);
}

/*
 * 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));
}

/*
 * 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);
}

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

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

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);
}

/*
 * 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);
}

/*
 * 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);
}

/*
 * >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);
}

static void
ficlPrimitiveLastWord(ficlVm *vm)
{
	ficlDictionary *dictionary = ficlVmGetDictionary(vm);
	ficlWord *wp = dictionary->smudge;
	ficlCell c;

	FICL_VM_ASSERT(vm, wp);

	c.p = wp;
	ficlVmPush(vm, c);
}

/*
 * l b r a c k e t   e t c
 */
static void
ficlPrimitiveLeftBracketCoIm(ficlVm *vm)
{
	vm->state = FICL_VM_STATE_INTERPRET;
}

static void
ficlPrimitiveRightBracket(ficlVm *vm)
{
	vm->state = FICL_VM_STATE_COMPILE;
}

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

/*
 * 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);
}

/*
 * 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;
	(void) ficlStringReverse(counted->text);
	ficlStackDrop(vm->dataStack, 2);
	ficlStackPushPointer(vm->dataStack, counted->text);
	ficlStackPushUnsigned(vm->dataStack, counted->length);
}

/*
 * 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);
}

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

/*
 * 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++] = '-';
}

/*
 * 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);
}

/*
 * 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);
}

static void
ficlPrimitiveAbort(ficlVm *vm)
{
	ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
}

/*
 * 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.)
 *
 * NOTE: getchar() is used there as its present both in loader and
 *	userland; however, the more correct solution would be to set
 *	terminal to raw mode for userland.
 */
static void
ficlPrimitiveAccept(ficlVm *vm)
{
	ficlUnsigned size;
	char *address;
	int c;
	ficlUnsigned length = 0;

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

	size = ficlStackPopInteger(vm->dataStack);
	address = ficlStackPopPointer(vm->dataStack);

	while (size != length) {
		c = getchar();
		if (c == '\n' || c == '\r')
			break;
		address[length++] = c;
	}
	ficlStackPushInteger(vm->dataStack, length);
}

/*
 * 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);
}

/*
 * 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));
}

/*
 * 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);
}

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

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

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);
}

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);
}

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

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

/*
 * 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]));
}

static void
ficlPrimitiveCharCoIm(ficlVm *vm)
{
	ficlPrimitiveChar(vm);
	ficlPrimitiveLiteralIm(vm);
}

/*
 * 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);
}

/*
 * 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! */
}
#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);
}

/*
 * 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);
	}
}

/*
 * 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);
}

/*
 * 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;
		counted = (ficlCountedString *)dictionary->here;
		(void) 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);
	}
}

/*
 * 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)
			(void) strncpy(here, s, length);

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

	ficlVmTextOut(vm, s);
}

/*
 * 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);
	(void) 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);
}

/*
 * 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));
}

/*
 * 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));
}

/*
 * 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);
	}
}

/*
 * 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);
	ficlCell c;

	FICL_IGNORE(vm);
	c.p = dictionary->smudge;
	ficlDictionaryAppendCell(dictionary, c);
}

/*
 * 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));
}

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

/*
 * 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);
}

/*
 * 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);
}

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

	(void) ficlDictionaryAppendWord(dictionary, name,
	    (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT);
	ficlDictionaryAppendCell(dictionary, c);
}
#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)
			ficlDictionaryAppendUnsigned(dictionary, nLocal);
	}
}

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;

		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;
		}

		(void) ficlDictionaryAppendWord(locals, name, code,
		    FICL_WORD_COMPILE_ONLY_IMMEDIATE);
		ficlDictionaryAppendUnsigned(locals,
		    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;
			ficlDictionaryAppendUnsigned(dictionary,
			    vm->callback.system->localsCount);
		}

		ficlDictionaryAppendUnsigned(dictionary, instruction);
		ficlDictionaryAppendUnsigned(dictionary,
		    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;
	}
}

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));
		}

		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)
			ficlDictionaryAppendUnsigned(dictionary, 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));
		break;
	}

	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);
	}
}

/*
 * 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));
}

/*
 * 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));
}

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);
}

/*
 * 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));
}

/*
 * 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);
}

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);
}

/*
 * 2 r o t
 * DOUBLE   ( d1 d2 d3 -- d2 d3 d1 )
 */
static void
ficlPrimitive2Rot(ficlVm *vm)
{
	ficl2Integer d1, d2, d3;
	FICL_STACK_CHECK(vm->dataStack, 6, 6);

	d3 = ficlStackPop2Integer(vm->dataStack);
	d2 = ficlStackPop2Integer(vm->dataStack);
	d1 = ficlStackPop2Integer(vm->dataStack);
	ficlStackPush2Integer(vm->dataStack, d2);
	ficlStackPush2Integer(vm->dataStack, d3);
	ficlStackPush2Integer(vm->dataStack, d1);
}

/*
 * 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);
}

/*
 * 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);
}

/*
 * 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:
		/* Open mouth, insert emetic */
		ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
		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 */
					/* Restore just the setjmp vector */
		vm->exceptionHandler = vmCopy.exceptionHandler;
					/* Push 0 -- everything is ok */
		ficlStackPushInteger(vm->dataStack, 0);
	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 != NULL)
		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);
}
#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)	\
	(void) 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"
	 */
	(void) ficlDictionarySetPrimitive(dictionary, "#",
	    ficlPrimitiveNumberSign, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "#>",
	    ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "#s",
	    ficlPrimitiveNumberSignS, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "\'",
	    ficlPrimitiveTick, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "(",
	    ficlPrimitiveParenthesis, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "+loop",
	    ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, ".",
	    ficlPrimitiveDot, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, ".\"",
	    ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, ":",
	    ficlPrimitiveColon, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, ";",
	    ficlPrimitiveSemicolonCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "<#",
	    ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, ">body",
	    ficlPrimitiveToBody, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, ">in",
	    ficlPrimitiveToIn, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, ">number",
	    ficlPrimitiveToNumber, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "abort",
	    ficlPrimitiveAbort, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "accept",
	    ficlPrimitiveAccept, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "align",
	    ficlPrimitiveAlign, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "aligned",
	    ficlPrimitiveAligned, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "allot",
	    ficlPrimitiveAllot, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "base",
	    ficlPrimitiveBase, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "begin",
	    ficlPrimitiveBeginCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "case",
	    ficlPrimitiveCaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "char",
	    ficlPrimitiveChar, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "char+",
	    ficlPrimitiveCharPlus, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "chars",
	    ficlPrimitiveChars, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "constant",
	    ficlPrimitiveConstant, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "count",
	    ficlPrimitiveCount, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "cr",
	    ficlPrimitiveCR, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "create",
	    ficlPrimitiveCreate, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "decimal",
	    ficlPrimitiveDecimal, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "depth",
	    ficlPrimitiveDepth, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "do",
	    ficlPrimitiveDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "does>",
	    ficlPrimitiveDoesCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "else",
	    ficlPrimitiveElseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "emit",
	    ficlPrimitiveEmit, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "endcase",
	    ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "endof",
	    ficlPrimitiveEndofCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "environment?",
	    ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "evaluate",
	    ficlPrimitiveEvaluate, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "execute",
	    ficlPrimitiveExecute, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "exit",
	    ficlPrimitiveExitCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "fallthrough",
	    ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "find",
	    ficlPrimitiveCFind, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "fm/mod",
	    ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "here",
	    ficlPrimitiveHere, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "hold",
	    ficlPrimitiveHold, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "if",
	    ficlPrimitiveIfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "immediate",
	    ficlPrimitiveImmediate, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "literal",
	    ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "loop",
	    ficlPrimitiveLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "m*",
	    ficlPrimitiveMStar, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "mod",
	    ficlPrimitiveMod, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "of",
	    ficlPrimitiveOfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "postpone",
	    ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "quit",
	    ficlPrimitiveQuit, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "recurse",
	    ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "repeat",
	    ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "s\"",
	    ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "sign",
	    ficlPrimitiveSign, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "sm/rem",
	    ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "source",
	    ficlPrimitiveSource, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "state",
	    ficlPrimitiveState, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "then",
	    ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "type",
	    ficlPrimitiveType, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "u.",
	    ficlPrimitiveUDot, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "um*",
	    ficlPrimitiveUMStar, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "um/mod",
	    ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "until",
	    ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "variable",
	    ficlPrimitiveVariable, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "while",
	    ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "word",
	    ficlPrimitiveWord, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "[",
	    ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "[\']",
	    ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "[char]",
	    ficlPrimitiveCharCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "]",
	    ficlPrimitiveRightBracket, FICL_WORD_DEFAULT);
	/*
	 * The Core Extensions word set...
	 * see softcore.fr for other definitions
	 */
	/* "#tib" */
	(void) ficlDictionarySetPrimitive(dictionary, ".(",
	    ficlPrimitiveDotParen, FICL_WORD_IMMEDIATE);
	/* ".r" is in softcore */
	(void) ficlDictionarySetPrimitive(dictionary, ":noname",
	    ficlPrimitiveColonNoName, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "?do",
	    ficlPrimitiveQDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "again",
	    ficlPrimitiveAgainCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "c\"",
	    ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "hex",
	    ficlPrimitiveHex, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "pad",
	    ficlPrimitivePad, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "parse",
	    ficlPrimitiveParse, FICL_WORD_DEFAULT);

	/*
	 * query restore-input save-input tib u.r u> unused
	 * [FICL_VM_STATE_COMPILE]
	 */
	(void) ficlDictionarySetPrimitive(dictionary, "refill",
	    ficlPrimitiveRefill, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "source-id",
	    ficlPrimitiveSourceID, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "to",
	    ficlPrimitiveToValue, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "value",
	    ficlPrimitiveConstant, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "\\",
	    ficlPrimitiveBackslash, FICL_WORD_IMMEDIATE);

	/*
	 * Environment query values for the Core word set
	 */
	(void) ficlDictionarySetConstant(environment, "/counted-string",
	    FICL_COUNTED_STRING_MAX);
	(void) ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE);
	(void) ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE);
	(void) ficlDictionarySetConstant(environment, "address-unit-bits", 8);
	(void) ficlDictionarySetConstant(environment, "core", FICL_TRUE);
	(void) ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE);
	(void) ficlDictionarySetConstant(environment, "floored", FICL_FALSE);
	(void) ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX);
	(void) ficlDictionarySetConstant(environment, "max-n", LONG_MAX);
	(void) ficlDictionarySetConstant(environment, "max-u", ULONG_MAX);

	{
		ficl2Integer id;
		ficlInteger low, high;

		low = ULONG_MAX;
		high = LONG_MAX;
		FICL_2INTEGER_SET(high, low, id);
		(void) ficlDictionarySet2Constant(environment, "max-d", id);
		high = ULONG_MAX;
		FICL_2INTEGER_SET(high, low, id);
		(void) ficlDictionarySet2Constant(environment, "max-ud", id);
	}

	(void) ficlDictionarySetConstant(environment, "return-stack-cells",
	    FICL_DEFAULT_STACK_SIZE);
	(void) ficlDictionarySetConstant(environment, "stack-cells",
	    FICL_DEFAULT_STACK_SIZE);

	/*
	 * The optional Double-Number word set (partial)
	 */
	(void) ficlDictionarySetPrimitive(dictionary, "2constant",
	    ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "2literal",
	    ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "2variable",
	    ficlPrimitive2Variable, FICL_WORD_IMMEDIATE);
	/*
	 * D+ D- D. D.R D0< D0= D2* D2/ in softcore
	 * D< D= D>S DABS DMAX DMIN DNEGATE in softcore
	 * m-star-slash is TODO
	 * M+ in softcore
	 */

	/*
	 * DOUBLE EXT
	 */
	(void) ficlDictionarySetPrimitive(dictionary, "2rot",
	    ficlPrimitive2Rot, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "2value",
	    ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
	/* du< in softcore */
	/*
	 * The optional Exception and Exception Extensions word set
	 */
	(void) ficlDictionarySetPrimitive(dictionary, "catch",
	    ficlPrimitiveCatch, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "throw",
	    ficlPrimitiveThrow, FICL_WORD_DEFAULT);

	(void) ficlDictionarySetConstant(environment, "exception", FICL_TRUE);
	(void) 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
	(void) ficlDictionarySetPrimitive(dictionary, "doLocal",
	    ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
	(void) ficlDictionarySetPrimitive(dictionary, "(local)",
	    ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY);
	(void) ficlDictionarySetPrimitive(dictionary, "(2local)",
	    ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY);

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

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

	(void) ficlDictionarySetPrimitive(dictionary, "allocate",
	    ficlPrimitiveAllocate, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "free",
	    ficlPrimitiveFree, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "resize",
	    ficlPrimitiveResize, FICL_WORD_DEFAULT);

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

	/*
	 * internal support words
	 */
	interpret = ficlDictionarySetPrimitive(dictionary, "interpret",
	    ficlPrimitiveInterpret, FICL_WORD_DEFAULT);
	(void) ficlDictionarySetPrimitive(dictionary, "lookup",
	    ficlPrimitiveLookup, FICL_WORD_DEFAULT);
	(void) 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)	\
	(void) 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);
}