xref: /titanic_51/usr/src/common/ficl/vm.c (revision 205758d42fe795e367ed7eb43c4451d62bc714c3)

/*
 * v m . c
 * Forth Inspired Command Language - virtual machine methods
 * Author: John Sadler (john_sadler@alum.mit.edu)
 * Created: 19 July 1997
 * $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $
 */
/*
 * This file implements the virtual machine of Ficl. Each virtual
 * machine retains the state of an interpreter. A virtual machine
 * owns a pair of stacks for parameters and return addresses, as
 * well as a pile of state variables and the two dedicated registers
 * of the interpreter.
 */
/*
 * 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"

#if FICL_ROBUST >= 2
#define	FICL_VM_CHECK(vm)	\
	FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord)
#else
#define	FICL_VM_CHECK(vm)
#endif

/*
 * v m B r a n c h R e l a t i v e
 */
void
ficlVmBranchRelative(ficlVm *vm, int offset)
{
	vm->ip += offset;
}

/*
 * v m C r e a t e
 * Creates a virtual machine either from scratch (if vm is NULL on entry)
 * or by resizing and reinitializing an existing VM to the specified stack
 * sizes.
 */
ficlVm *
ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack)
{
	if (vm == NULL) {
		vm = (ficlVm *)ficlMalloc(sizeof (ficlVm));
		FICL_ASSERT(NULL, vm);
		memset(vm, 0, sizeof (ficlVm));
	}

	if (vm->dataStack)
		ficlStackDestroy(vm->dataStack);
	vm->dataStack = ficlStackCreate(vm, "data", nPStack);

	if (vm->returnStack)
		ficlStackDestroy(vm->returnStack);
	vm->returnStack = ficlStackCreate(vm, "return", nRStack);

#if FICL_WANT_FLOAT
	if (vm->floatStack)
		ficlStackDestroy(vm->floatStack);
	vm->floatStack = ficlStackCreate(vm, "float", nPStack);
#endif

	ficlVmReset(vm);
	return (vm);
}

/*
 * v m D e l e t e
 * Free all memory allocated to the specified VM and its subordinate
 * structures.
 */
void
ficlVmDestroy(ficlVm *vm)
{
	if (vm) {
		ficlFree(vm->dataStack);
		ficlFree(vm->returnStack);
#if FICL_WANT_FLOAT
		ficlFree(vm->floatStack);
#endif
		ficlFree(vm);
	}
}

/*
 * v m E x e c u t e
 * Sets up the specified word to be run by the inner interpreter.
 * Executes the word's code part immediately, but in the case of
 * colon definition, the definition itself needs the inner interpreter
 * to complete. This does not happen until control reaches ficlExec
 */
void
ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
{
	ficlVmInnerLoop(vm, pWord);
}

static void
ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip)
{
	ficlIp destination;
	switch ((ficlInstruction)(*ip)) {
	case ficlInstructionBranchParenWithCheck:
		*ip = (ficlWord *)ficlInstructionBranchParen;
		goto RUNTIME_FIXUP;

	case ficlInstructionBranch0ParenWithCheck:
		*ip = (ficlWord *)ficlInstructionBranch0Paren;
RUNTIME_FIXUP:
		ip++;
		destination = ip + *(ficlInteger *)ip;
		switch ((ficlInstruction)*destination) {
		case ficlInstructionBranchParenWithCheck:
			/* preoptimize where we're jumping to */
			ficlVmOptimizeJumpToJump(vm, destination);
			/* FALLTHROUGH */
		case ficlInstructionBranchParen:
			destination++;
			destination += *(ficlInteger *)destination;
			*ip = (ficlWord *)(destination - ip);
		break;
		}
	}
}

/*
 * v m I n n e r L o o p
 * the mysterious inner interpreter...
 * This loop is the address interpreter that makes colon definitions
 * work. Upon entry, it assumes that the IP points to an entry in
 * a definition (the body of a colon word). It runs one word at a time
 * until something does vmThrow. The catcher for this is expected to exist
 * in the calling code.
 * vmThrow gets you out of this loop with a longjmp()
 */

#if FICL_ROBUST <= 1
	/* turn off stack checking for primitives */
#define	_CHECK_STACK(stack, top, pop, push)
#else

#define	_CHECK_STACK(stack, top, pop, push)	\
	ficlStackCheckNospill(stack, top, pop, push)

static FICL_PLATFORM_INLINE void
ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells,
    int pushCells)
{
	/*
	 * Why save and restore stack->top?
	 * So the simple act of stack checking doesn't force a "register" spill,
	 * which might mask bugs (places where we needed to spill but didn't).
	 * --lch
	 */
	ficlCell *oldTop = stack->top;
	stack->top = top;
	ficlStackCheck(stack, popCells, pushCells);
	stack->top = oldTop;
}

#endif /* FICL_ROBUST <= 1 */

#define	CHECK_STACK(pop, push)		\
	_CHECK_STACK(vm->dataStack, dataTop, pop, push)
#define	CHECK_FLOAT_STACK(pop, push)	\
	_CHECK_STACK(vm->floatStack, floatTop, pop, push)
#define	CHECK_RETURN_STACK(pop, push)	\
	_CHECK_STACK(vm->returnStack, returnTop, pop, push)

#if FICL_WANT_FLOAT
#define	FLOAT_LOCAL_VARIABLE_SPILL	\
	vm->floatStack->top = floatTop;
#define	FLOAT_LOCAL_VARIABLE_REFILL	\
	floatTop = vm->floatStack->top;
#else
#define	FLOAT_LOCAL_VARIABLE_SPILL
#define	FLOAT_LOCAL_VARIABLE_REFILL
#endif  /* FICL_WANT_FLOAT */

#if FICL_WANT_LOCALS
#define	LOCALS_LOCAL_VARIABLE_SPILL	\
	vm->returnStack->frame = frame;
#define	LOCALS_LOCAL_VARIABLE_REFILL \
	frame = vm->returnStack->frame;
#else
#define	LOCALS_LOCAL_VARIABLE_SPILL
#define	LOCALS_LOCAL_VARIABLE_REFILL
#endif  /* FICL_WANT_FLOAT */

#define	LOCAL_VARIABLE_SPILL	\
		vm->ip = (ficlIp)ip;	\
		vm->dataStack->top = dataTop;	\
		vm->returnStack->top = returnTop;	\
		FLOAT_LOCAL_VARIABLE_SPILL \
		LOCALS_LOCAL_VARIABLE_SPILL

#define	LOCAL_VARIABLE_REFILL	\
		ip = (ficlInstruction *)vm->ip; \
		dataTop = vm->dataStack->top;	\
		returnTop = vm->returnStack->top;	\
		FLOAT_LOCAL_VARIABLE_REFILL	\
		LOCALS_LOCAL_VARIABLE_REFILL

void
ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
{
	register ficlInstruction *ip;
	register ficlCell *dataTop;
	register ficlCell *returnTop;
#if FICL_WANT_FLOAT
	register ficlCell *floatTop;
	ficlFloat f;
#endif  /* FICL_WANT_FLOAT */
#if FICL_WANT_LOCALS
	register ficlCell *frame;
#endif  /* FICL_WANT_LOCALS */
	jmp_buf *oldExceptionHandler;
	jmp_buf exceptionHandler;
	int except;
	int once;
	int count;
	ficlInstruction instruction;
	ficlInteger i;
	ficlUnsigned u;
	ficlCell c;
	ficlCountedString *s;
	ficlCell *cell;
	char *cp;

	once = (fw != NULL);
	if (once)
		count = 1;

	oldExceptionHandler = vm->exceptionHandler;
	/* This has to come before the setjmp! */
	vm->exceptionHandler = &exceptionHandler;
	except = setjmp(exceptionHandler);

	LOCAL_VARIABLE_REFILL;

	if (except) {
		LOCAL_VARIABLE_SPILL;
		vm->exceptionHandler = oldExceptionHandler;
		ficlVmThrow(vm, except);
	}

	for (;;) {
		if (once) {
			if (!count--)
				break;
			instruction = (ficlInstruction)((void *)fw);
		} else {
			instruction = *ip++;
			fw = (ficlWord *)instruction;
		}

AGAIN:
		switch (instruction) {
		case ficlInstructionInvalid:
			ficlVmThrowError(vm,
			    "Error: NULL instruction executed!");
		return;

		case ficlInstruction1:
		case ficlInstruction2:
		case ficlInstruction3:
		case ficlInstruction4:
		case ficlInstruction5:
		case ficlInstruction6:
		case ficlInstruction7:
		case ficlInstruction8:
		case ficlInstruction9:
		case ficlInstruction10:
		case ficlInstruction11:
		case ficlInstruction12:
		case ficlInstruction13:
		case ficlInstruction14:
		case ficlInstruction15:
		case ficlInstruction16:
			CHECK_STACK(0, 1);
			(++dataTop)->i = instruction;
		continue;

		case ficlInstruction0:
		case ficlInstructionNeg1:
		case ficlInstructionNeg2:
		case ficlInstructionNeg3:
		case ficlInstructionNeg4:
		case ficlInstructionNeg5:
		case ficlInstructionNeg6:
		case ficlInstructionNeg7:
		case ficlInstructionNeg8:
		case ficlInstructionNeg9:
		case ficlInstructionNeg10:
		case ficlInstructionNeg11:
		case ficlInstructionNeg12:
		case ficlInstructionNeg13:
		case ficlInstructionNeg14:
		case ficlInstructionNeg15:
		case ficlInstructionNeg16:
			CHECK_STACK(0, 1);
			(++dataTop)->i = ficlInstruction0 - instruction;
		continue;

		/*
		 * stringlit: Fetch the count from the dictionary, then push
		 * the address and count on the stack. Finally, update ip to
		 * point to the first aligned address after the string text.
		 */
		case ficlInstructionStringLiteralParen: {
			ficlUnsigned8 length;
			CHECK_STACK(0, 2);

			s = (ficlCountedString *)(ip);
			length = s->length;
			cp = s->text;
			(++dataTop)->p = cp;
			(++dataTop)->i = length;

			cp += length + 1;
			cp = ficlAlignPointer(cp);
			ip = (void *)cp;
		continue;
		}

		case ficlInstructionCStringLiteralParen:
			CHECK_STACK(0, 1);

			s = (ficlCountedString *)(ip);
			cp = s->text + s->length + 1;
			cp = ficlAlignPointer(cp);
			ip = (void *)cp;
			(++dataTop)->p = s;
		continue;

#if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
#if FICL_WANT_FLOAT
FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
			*++floatTop = cell[1];
			/* intentional fall-through */
FLOAT_PUSH_CELL_POINTER_MINIPROC:
			*++floatTop = cell[0];
		continue;

FLOAT_POP_CELL_POINTER_MINIPROC:
			cell[0] = *floatTop--;
		continue;

FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
			cell[0] = *floatTop--;
			cell[1] = *floatTop--;
		continue;

#define	FLOAT_PUSH_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
#define	FLOAT_PUSH_CELL_POINTER(cp)		\
	cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
#define	FLOAT_POP_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
#define	FLOAT_POP_CELL_POINTER(cp)		\
	cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
#endif /* FICL_WANT_FLOAT */

		/*
		 * Think of these as little mini-procedures.
		 * --lch
		 */
PUSH_CELL_POINTER_DOUBLE_MINIPROC:
			*++dataTop = cell[1];
			/* intentional fall-through */
PUSH_CELL_POINTER_MINIPROC:
			*++dataTop = cell[0];
		continue;

POP_CELL_POINTER_MINIPROC:
			cell[0] = *dataTop--;
		continue;
POP_CELL_POINTER_DOUBLE_MINIPROC:
			cell[0] = *dataTop--;
			cell[1] = *dataTop--;
		continue;

#define	PUSH_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
#define	PUSH_CELL_POINTER(cp)		\
	cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
#define	POP_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
#define	POP_CELL_POINTER(cp)		\
	cell = (cp); goto POP_CELL_POINTER_MINIPROC

BRANCH_MINIPROC:
			ip += *(ficlInteger *)ip;
		continue;

#define	BRANCH()	goto BRANCH_MINIPROC

EXIT_FUNCTION_MINIPROC:
			ip = (ficlInstruction *)((returnTop--)->p);
				continue;

#define	EXIT_FUNCTION	goto EXIT_FUNCTION_MINIPROC

#else /* FICL_WANT_SIZE */

#if FICL_WANT_FLOAT
#define	FLOAT_PUSH_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
#define	FLOAT_PUSH_CELL_POINTER(cp)		\
	cell = (cp); *++floatTop = *cell; continue
#define	FLOAT_POP_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
#define	FLOAT_POP_CELL_POINTER(cp)		\
	cell = (cp); *cell = *floatTop--; continue
#endif /* FICL_WANT_FLOAT */

#define	PUSH_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
#define	PUSH_CELL_POINTER(cp)		\
	cell = (cp); *++dataTop = *cell; continue
#define	POP_CELL_POINTER_DOUBLE(cp)	\
	cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
#define	POP_CELL_POINTER(cp)		\
	cell = (cp); *cell = *dataTop--; continue

#define	BRANCH()	ip += *(ficlInteger *)ip; continue
#define	EXIT_FUNCTION()	ip = (ficlInstruction *)((returnTop--)->p); continue

#endif /* FICL_WANT_SIZE */


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

		case ficlInstructionLiteralParen:
			CHECK_STACK(0, 1);
			(++dataTop)->i = *ip++;
		continue;

		case ficlInstruction2LiteralParen:
			CHECK_STACK(0, 2);
			(++dataTop)->i = ip[1];
			(++dataTop)->i = ip[0];
			ip += 2;
		continue;

#if FICL_WANT_LOCALS
		/*
		 * Link a frame on the return stack, reserving nCells of space
		 * for locals - the value of nCells is the next ficlCell in
		 * the instruction stream.
		 * 1) Push frame onto returnTop
		 * 2) frame = returnTop
		 * 3) returnTop += nCells
		 */
		case ficlInstructionLinkParen: {
			ficlInteger nCells = *ip++;
			(++returnTop)->p = frame;
			frame = returnTop + 1;
			returnTop += nCells;
		continue;
		}

		/*
		 * Unink a stack frame previously created by stackLink
		 * 1) dataTop = frame
		 * 2) frame = pop()
		 */
		case ficlInstructionUnlinkParen:
			returnTop = frame - 1;
			frame = (returnTop--)->p;
		continue;

		/*
		 * Immediate - cfa of a local while compiling - when executed,
		 * compiles code to fetch the value of a local given the
		 * local's index in the word's pfa
		 */
#if FICL_WANT_FLOAT
		case ficlInstructionGetF2LocalParen:
			FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);

		case ficlInstructionGetFLocalParen:
			FLOAT_PUSH_CELL_POINTER(frame + *ip++);

		case ficlInstructionToF2LocalParen:
			FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);

		case ficlInstructionToFLocalParen:
			FLOAT_POP_CELL_POINTER(frame + *ip++);
#endif /* FICL_WANT_FLOAT */

		case ficlInstructionGet2LocalParen:
			PUSH_CELL_POINTER_DOUBLE(frame + *ip++);

		case ficlInstructionGetLocalParen:
			PUSH_CELL_POINTER(frame + *ip++);

		/*
		 * Immediate - cfa of a local while compiling - when executed,
		 * compiles code to store the value of a local given the
		 * local's index in the word's pfa
		 */

		case ficlInstructionTo2LocalParen:
			POP_CELL_POINTER_DOUBLE(frame + *ip++);

		case ficlInstructionToLocalParen:
			POP_CELL_POINTER(frame + *ip++);

		/*
		 * Silly little minor optimizations.
		 * --lch
		 */
		case ficlInstructionGetLocal0:
			PUSH_CELL_POINTER(frame);

		case ficlInstructionGetLocal1:
			PUSH_CELL_POINTER(frame + 1);

		case ficlInstructionGet2Local0:
			PUSH_CELL_POINTER_DOUBLE(frame);

		case ficlInstructionToLocal0:
			POP_CELL_POINTER(frame);

		case ficlInstructionToLocal1:
			POP_CELL_POINTER(frame + 1);

		case ficlInstructionTo2Local0:
			POP_CELL_POINTER_DOUBLE(frame);

#endif /* FICL_WANT_LOCALS */

		case ficlInstructionPlus:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i += i;
		continue;

		case ficlInstructionMinus:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i -= i;
		continue;

		case ficlInstruction1Plus:
			CHECK_STACK(1, 1);
			dataTop->i++;
		continue;

		case ficlInstruction1Minus:
			CHECK_STACK(1, 1);
			dataTop->i--;
		continue;

		case ficlInstruction2Plus:
			CHECK_STACK(1, 1);
			dataTop->i += 2;
		continue;

		case ficlInstruction2Minus:
			CHECK_STACK(1, 1);
			dataTop->i -= 2;
		continue;

		case ficlInstructionDup: {
			ficlInteger i = dataTop->i;
			CHECK_STACK(0, 1);
			(++dataTop)->i = i;
			continue;
		}

		case ficlInstructionQuestionDup:
			CHECK_STACK(1, 2);

			if (dataTop->i != 0) {
				dataTop[1] = dataTop[0];
				dataTop++;
			}

		continue;

		case ficlInstructionSwap: {
			ficlCell swap;
			CHECK_STACK(2, 2);
			swap = dataTop[0];
			dataTop[0] = dataTop[-1];
			dataTop[-1] = swap;
		}
		continue;

		case ficlInstructionDrop:
			CHECK_STACK(1, 0);
			dataTop--;
		continue;

		case ficlInstruction2Drop:
			CHECK_STACK(2, 0);
			dataTop -= 2;
		continue;

		case ficlInstruction2Dup:
			CHECK_STACK(2, 4);
			dataTop[1] = dataTop[-1];
			dataTop[2] = *dataTop;
			dataTop += 2;
		continue;

		case ficlInstructionOver:
			CHECK_STACK(2, 3);
			dataTop[1] = dataTop[-1];
			dataTop++;
		continue;

		case ficlInstruction2Over:
			CHECK_STACK(4, 6);
			dataTop[1] = dataTop[-3];
			dataTop[2] = dataTop[-2];
			dataTop += 2;
		continue;

		case ficlInstructionPick:
			CHECK_STACK(1, 0);
			i = dataTop->i;
			if (i < 0)
				continue;
			CHECK_STACK(i + 2, i + 3);
			*dataTop = dataTop[-i - 1];
		continue;

		/*
		 * Do stack rot.
		 * rot ( 1 2 3  -- 2 3 1 )
		 */
		case ficlInstructionRot:
			i = 2;
		goto ROLL;

		/*
		 * Do stack roll.
		 * roll ( n -- )
		 */
		case ficlInstructionRoll:
			CHECK_STACK(1, 0);
			i = (dataTop--)->i;

			if (i < 1)
				continue;

ROLL:
			CHECK_STACK(i+1, i+2);
			c = dataTop[-i];
			memmove(dataTop - i, dataTop - (i - 1),
			    i * sizeof (ficlCell));
			*dataTop = c;
		continue;

		/*
		 * Do stack -rot.
		 * -rot ( 1 2 3  -- 3 1 2 )
		 */
		case ficlInstructionMinusRot:
			i = 2;
		goto MINUSROLL;

		/*
		 * Do stack -roll.
		 * -roll ( n -- )
		 */
		case ficlInstructionMinusRoll:
			CHECK_STACK(1, 0);
			i = (dataTop--)->i;

			if (i < 1)
				continue;

MINUSROLL:
			CHECK_STACK(i+1, i+2);
			c = *dataTop;
			memmove(dataTop - (i - 1), dataTop - i,
			    i * sizeof (ficlCell));
			dataTop[-i] = c;

		continue;

		/*
		 * Do stack 2swap
		 * 2swap ( 1 2 3 4  -- 3 4 1 2 )
		 */
		case ficlInstruction2Swap: {
			ficlCell c2;
			CHECK_STACK(4, 4);

			c = *dataTop;
			c2 = dataTop[-1];

			*dataTop = dataTop[-2];
			dataTop[-1] = dataTop[-3];

			dataTop[-2] = c;
			dataTop[-3] = c2;
		continue;
		}

		case ficlInstructionPlusStore: {
			ficlCell *cell;
			CHECK_STACK(2, 0);
			cell = (ficlCell *)(dataTop--)->p;
			cell->i += (dataTop--)->i;
		continue;
		}

		case ficlInstructionQuadFetch: {
			ficlUnsigned32 *integer32;
			CHECK_STACK(1, 1);
			integer32 = (ficlUnsigned32 *)dataTop->i;
			dataTop->u = (ficlUnsigned)*integer32;
		continue;
		}

		case ficlInstructionQuadStore: {
			ficlUnsigned32 *integer32;
			CHECK_STACK(2, 0);
			integer32 = (ficlUnsigned32 *)(dataTop--)->p;
			*integer32 = (ficlUnsigned32)((dataTop--)->u);
		continue;
		}

		case ficlInstructionWFetch: {
			ficlUnsigned16 *integer16;
			CHECK_STACK(1, 1);
			integer16 = (ficlUnsigned16 *)dataTop->p;
			dataTop->u = ((ficlUnsigned)*integer16);
		continue;
		}

		case ficlInstructionWStore: {
			ficlUnsigned16 *integer16;
			CHECK_STACK(2, 0);
			integer16 = (ficlUnsigned16 *)(dataTop--)->p;
			*integer16 = (ficlUnsigned16)((dataTop--)->u);
		continue;
		}

		case ficlInstructionCFetch: {
			ficlUnsigned8 *integer8;
			CHECK_STACK(1, 1);
			integer8 = (ficlUnsigned8 *)dataTop->p;
			dataTop->u = ((ficlUnsigned)*integer8);
		continue;
		}

		case ficlInstructionCStore: {
			ficlUnsigned8 *integer8;
			CHECK_STACK(2, 0);
			integer8 = (ficlUnsigned8 *)(dataTop--)->p;
			*integer8 = (ficlUnsigned8)((dataTop--)->u);
		continue;
		}


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

		case ficlInstruction0Equals:
			CHECK_STACK(1, 1);
			dataTop->i = FICL_BOOL(dataTop->i == 0);
		continue;

		case ficlInstruction0Less:
			CHECK_STACK(1, 1);
			dataTop->i = FICL_BOOL(dataTop->i < 0);
		continue;

		case ficlInstruction0Greater:
			CHECK_STACK(1, 1);
			dataTop->i = FICL_BOOL(dataTop->i > 0);
		continue;

		case ficlInstructionEquals:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i = FICL_BOOL(dataTop->i == i);
		continue;

		case ficlInstructionLess:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i = FICL_BOOL(dataTop->i < i);
		continue;

		case ficlInstructionULess:
			CHECK_STACK(2, 1);
			u = (dataTop--)->u;
			dataTop->i = FICL_BOOL(dataTop->u < u);
		continue;

		case ficlInstructionAnd:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i = dataTop->i & i;
		continue;

		case ficlInstructionOr:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i = dataTop->i | i;
		continue;

		case ficlInstructionXor:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i = dataTop->i ^ i;
		continue;

		case ficlInstructionInvert:
			CHECK_STACK(1, 1);
			dataTop->i = ~dataTop->i;
		continue;

		/*
		 * r e t u r n   s t a c k
		 */
		case ficlInstructionToRStack:
			CHECK_STACK(1, 0);
			CHECK_RETURN_STACK(0, 1);
			*++returnTop = *dataTop--;
		continue;

		case ficlInstructionFromRStack:
			CHECK_STACK(0, 1);
			CHECK_RETURN_STACK(1, 0);
			*++dataTop = *returnTop--;
		continue;

		case ficlInstructionFetchRStack:
			CHECK_STACK(0, 1);
			CHECK_RETURN_STACK(1, 1);
			*++dataTop = *returnTop;
		continue;

		case ficlInstruction2ToR:
			CHECK_STACK(2, 0);
			CHECK_RETURN_STACK(0, 2);
			*++returnTop = dataTop[-1];
			*++returnTop = dataTop[0];
			dataTop -= 2;
		continue;

		case ficlInstruction2RFrom:
			CHECK_STACK(0, 2);
			CHECK_RETURN_STACK(2, 0);
			*++dataTop = returnTop[-1];
			*++dataTop = returnTop[0];
			returnTop -= 2;
		continue;

		case ficlInstruction2RFetch:
			CHECK_STACK(0, 2);
			CHECK_RETURN_STACK(2, 2);
			*++dataTop = returnTop[-1];
			*++dataTop = returnTop[0];
		continue;

		/*
		 * f i l l
		 * CORE ( c-addr u char -- )
		 * If u is greater than zero, store char in each of u
		 * consecutive characters of memory beginning at c-addr.
		 */
		case ficlInstructionFill: {
			char c;
			char *memory;
			CHECK_STACK(3, 0);
			c = (char)(dataTop--)->i;
			u = (dataTop--)->u;
			memory = (char *)(dataTop--)->p;

			/*
			 * memset() is faster than the previous hand-rolled
			 * solution.  --lch
			 */
			memset(memory, c, u);
		continue;
		}

		/*
		 * l s h i f t
		 * l-shift CORE ( x1 u -- x2 )
		 * Perform a logical left shift of u bit-places on x1,
		 * giving x2. Put zeroes into the least significant bits
		 * vacated by the shift. An ambiguous condition exists if
		 * u is greater than or equal to the number of bits in a
		 * ficlCell.
		 *
		 * r-shift CORE ( x1 u -- x2 )
		 * Perform a logical right shift of u bit-places on x1,
		 * giving x2. Put zeroes into the most significant bits
		 * vacated by the shift. An ambiguous condition exists
		 * if u is greater than or equal to the number of bits
		 * in a ficlCell.
		 */
		case ficlInstructionLShift: {
			ficlUnsigned nBits;
			ficlUnsigned x1;
			CHECK_STACK(2, 1);

			nBits = (dataTop--)->u;
			x1 = dataTop->u;
			dataTop->u = x1 << nBits;
		continue;
		}

		case ficlInstructionRShift: {
			ficlUnsigned nBits;
			ficlUnsigned x1;
			CHECK_STACK(2, 1);

			nBits = (dataTop--)->u;
			x1 = dataTop->u;
			dataTop->u = x1 >> nBits;
			continue;
		}

		/*
		 * m a x   &   m i n
		 */
		case ficlInstructionMax: {
			ficlInteger n2;
			ficlInteger n1;
			CHECK_STACK(2, 1);

			n2 = (dataTop--)->i;
			n1 = dataTop->i;

			dataTop->i = ((n1 > n2) ? n1 : n2);
		continue;
		}

		case ficlInstructionMin: {
			ficlInteger n2;
			ficlInteger n1;
			CHECK_STACK(2, 1);

			n2 = (dataTop--)->i;
				n1 = dataTop->i;

			dataTop->i = ((n1 < n2) ? n1 : n2);
			continue;
		}

		/*
		 * m o v e
		 * CORE ( addr1 addr2 u -- )
		 * If u is greater than zero, copy the contents of u
		 * consecutive address units at addr1 to the u consecutive
		 * address units at addr2. After MOVE completes, the u
		 * consecutive address units at addr2 contain exactly
		 * what the u consecutive address units at addr1 contained
		 * before the move.
		 * NOTE! This implementation assumes that a char is the same
		 * size as an address unit.
		 */
		case ficlInstructionMove: {
			ficlUnsigned u;
			char *addr2;
			char *addr1;
			CHECK_STACK(3, 0);

			u = (dataTop--)->u;
			addr2 = (dataTop--)->p;
			addr1 = (dataTop--)->p;

			if (u == 0)
				continue;
			/*
			 * Do the copy carefully, so as to be
			 * correct even if the two ranges overlap
			 */
			/* Which ANSI C's memmove() does for you! Yay!  --lch */
			memmove(addr2, addr1, u);
		continue;
		}

		/*
		 * s t o d
		 * s-to-d CORE ( n -- d )
		 * Convert the number n to the double-ficlCell number d with
		 * the same numerical value.
		 */
		case ficlInstructionSToD: {
			ficlInteger s;
			CHECK_STACK(1, 2);

			s = dataTop->i;

			/* sign extend to 64 bits.. */
			(++dataTop)->i = (s < 0) ? -1 : 0;
		continue;
		}

		/*
		 * c o m p a r e
		 * STRING ( c-addr1 u1 c-addr2 u2 -- n )
		 * Compare the string specified by c-addr1 u1 to the string
		 * specified by c-addr2 u2. The strings are compared, beginning
		 * at the given addresses, character by character, up to the
		 * length of the shorter string or until a difference is found.
		 * If the two strings are identical, n is zero. If the two
		 * strings are identical up to the length of the shorter string,
		 * n is minus-one (-1) if u1 is less than u2 and one (1)
		 * otherwise. If the two strings are not identical up to the
		 * length of the shorter string, n is minus-one (-1) if the
		 * first non-matching character in the string specified by
		 * c-addr1 u1 has a lesser numeric value than the corresponding
		 * character in the string specified by c-addr2 u2 and
		 * one (1) otherwise.
		 */
		case ficlInstructionCompare:
			i = FICL_FALSE;
		goto COMPARE;


		case ficlInstructionCompareInsensitive:
			i = FICL_TRUE;
		goto COMPARE;

COMPARE:
		{
			char *cp1, *cp2;
			ficlUnsigned u1, u2, uMin;
			int n = 0;

			CHECK_STACK(4, 1);
			u2  = (dataTop--)->u;
			cp2 = (char *)(dataTop--)->p;
			u1  = (dataTop--)->u;
			cp1 = (char *)(dataTop--)->p;

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

				if (i) {
					c1 = tolower(c1);
					c2 = tolower(c2);
				}
				n = (c1 - c2);
			}

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

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

			(++dataTop)->i = n;
		continue;
		}

		/*
		 * r a n d o m
		 * Ficl-specific
		 */
		case ficlInstructionRandom:
			(++dataTop)->i = random();
		continue;

		/*
		 * s e e d - r a n d o m
		 * Ficl-specific
		 */
		case ficlInstructionSeedRandom:
			srandom((dataTop--)->i);
		continue;

		case ficlInstructionGreaterThan: {
			ficlInteger x, y;
			CHECK_STACK(2, 1);
			y = (dataTop--)->i;
			x = dataTop->i;
			dataTop->i = FICL_BOOL(x > y);
		continue;

		case ficlInstructionUGreaterThan:
			CHECK_STACK(2, 1);
			u = (dataTop--)->u;
			dataTop->i = FICL_BOOL(dataTop->u > u);
		continue;

		}

		/*
		 * 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".
		 */
		case ficlInstructionExitParen:
		case ficlInstructionSemiParen:
			EXIT_FUNCTION();

		/*
		 * The first time we run "(branch)", perform a "peephole
		 * optimization" to see if we're jumping to another
		 * unconditional jump.  If so, just jump directly there.
		 */
		case ficlInstructionBranchParenWithCheck:
			LOCAL_VARIABLE_SPILL;
			ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
			LOCAL_VARIABLE_REFILL;
		goto BRANCH_PAREN;

		/*
		 * Same deal with branch0.
		 */
		case ficlInstructionBranch0ParenWithCheck:
			LOCAL_VARIABLE_SPILL;
			ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
			LOCAL_VARIABLE_REFILL;
			/* intentional fall-through */

		/*
		 * Runtime code for "(branch0)"; pop a flag from the stack,
		 * branch if 0. fall through otherwise.
		 * The heart of "if" and "until".
		 */
		case ficlInstructionBranch0Paren:
			CHECK_STACK(1, 0);

			if ((dataTop--)->i) {
				/*
				 * don't branch, but skip over branch
				 * relative address
				 */
				ip += 1;
				continue;
			}
			/* otherwise, take branch (to else/endif/begin) */
			/* intentional fall-through! */

		/*
		 * Runtime for "(branch)" -- expects a literal offset in the
		 * next compilation address, and branches to that location.
		 */
		case ficlInstructionBranchParen:
BRANCH_PAREN:
			BRANCH();

		case ficlInstructionOfParen: {
			ficlUnsigned a, b;

			CHECK_STACK(2, 1);

			a = (dataTop--)->u;
			b = dataTop->u;

			if (a == b) {
				/* fall through */
				ip++;
				/* remove CASE argument */
				dataTop--;
			} else {
				/* take branch to next of or endcase */
				BRANCH();
			}

		continue;
		}

		case ficlInstructionDoParen: {
			ficlCell index, limit;

			CHECK_STACK(2, 0);

			index = *dataTop--;
			limit = *dataTop--;

			/* copy "leave" target addr to stack */
			(++returnTop)->i = *(ip++);
			*++returnTop = limit;
			*++returnTop = index;

		continue;
		}

		case ficlInstructionQDoParen: {
			ficlCell index, limit, leave;

			CHECK_STACK(2, 0);

			index = *dataTop--;
			limit = *dataTop--;

			leave.i = *ip;

			if (limit.u == index.u) {
				ip = leave.p;
			} else {
				ip++;
				*++returnTop = leave;
				*++returnTop = limit;
				*++returnTop = index;
			}

		continue;
		}

		case ficlInstructionLoopParen:
		case ficlInstructionPlusLoopParen: {
			ficlInteger index;
			ficlInteger limit;
			int direction = 0;

			index = returnTop->i;
			limit = returnTop[-1].i;

			if (instruction == ficlInstructionLoopParen)
				index++;
			else {
				ficlInteger increment;
				CHECK_STACK(1, 0);
				increment = (dataTop--)->i;
				index += increment;
				direction = (increment < 0);
			}

			if (direction ^ (index >= limit)) {
				/* nuke the loop indices & "leave" addr */
				returnTop -= 3;
				ip++;  /* fall through the loop */
			} else {	/* update index, branch to loop head */
				returnTop->i = index;
				BRANCH();
			}

		continue;
		}


		/*
		 * Runtime code to break out of a do..loop construct
		 * Drop the loop control variables; the branch address
		 * past "loop" is next on the return stack.
		 */
		case ficlInstructionLeave:
			/* almost unloop */
			returnTop -= 2;
			/* exit */
			EXIT_FUNCTION();

		case ficlInstructionUnloop:
			returnTop -= 3;
		continue;

		case ficlInstructionI:
			*++dataTop = *returnTop;
		continue;

		case ficlInstructionJ:
			*++dataTop = returnTop[-3];
		continue;

		case ficlInstructionK:
			*++dataTop = returnTop[-6];
		continue;

		case ficlInstructionDoesParen: {
			ficlDictionary *dictionary = ficlVmGetDictionary(vm);
			dictionary->smudge->code =
			    (ficlPrimitive)ficlInstructionDoDoes;
			dictionary->smudge->param[0].p = ip;
			ip = (ficlInstruction *)((returnTop--)->p);
		continue;
		}

		case ficlInstructionDoDoes: {
			ficlCell *cell;
			ficlIp tempIP;

			CHECK_STACK(0, 1);

			cell = fw->param;
			tempIP = (ficlIp)((*cell).p);
			(++dataTop)->p = (cell + 1);
			(++returnTop)->p = (void *)ip;
			ip = (ficlInstruction *)tempIP;
		continue;
		}

#if FICL_WANT_FLOAT
		case ficlInstructionF2Fetch:
			CHECK_FLOAT_STACK(0, 2);
			CHECK_STACK(1, 0);
			FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);

		case ficlInstructionFFetch:
			CHECK_FLOAT_STACK(0, 1);
			CHECK_STACK(1, 0);
			FLOAT_PUSH_CELL_POINTER((dataTop--)->p);

		case ficlInstructionF2Store:
			CHECK_FLOAT_STACK(2, 0);
			CHECK_STACK(1, 0);
			FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p);

		case ficlInstructionFStore:
			CHECK_FLOAT_STACK(1, 0);
			CHECK_STACK(1, 0);
			FLOAT_POP_CELL_POINTER((dataTop--)->p);
#endif /* FICL_WANT_FLOAT */

		/*
		 * two-fetch CORE ( a-addr -- x1 x2 )
		 *
		 * Fetch the ficlCell pair x1 x2 stored at a-addr.
		 * x2 is stored at a-addr and x1 at the next consecutive
		 * ficlCell. It is equivalent to the sequence
		 * DUP ficlCell+ @ SWAP @ .
		 */
		case ficlInstruction2Fetch:
			CHECK_STACK(1, 2);
			PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);

		/*
		 * fetch CORE ( a-addr -- x )
		 *
		 * x is the value stored at a-addr.
		 */
		case ficlInstructionFetch:
			CHECK_STACK(1, 1);
			PUSH_CELL_POINTER((dataTop--)->p);

		/*
		 * two-store    CORE ( x1 x2 a-addr -- )
		 * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr
		 * and x1 at the next consecutive ficlCell. It is equivalent
		 * to the sequence SWAP OVER ! ficlCell+ !
		 */
		case ficlInstruction2Store:
			CHECK_STACK(3, 0);
			POP_CELL_POINTER_DOUBLE((dataTop--)->p);

		/*
		 * store	CORE ( x a-addr -- )
		 * Store x at a-addr.
		 */
		case ficlInstructionStore:
			CHECK_STACK(2, 0);
			POP_CELL_POINTER((dataTop--)->p);

		case ficlInstructionComma: {
			ficlDictionary *dictionary;
			CHECK_STACK(1, 0);

			dictionary = ficlVmGetDictionary(vm);
			ficlDictionaryAppendCell(dictionary, *dataTop--);
		continue;
		}

		case ficlInstructionCComma: {
			ficlDictionary *dictionary;
			char c;
			CHECK_STACK(1, 0);

			dictionary = ficlVmGetDictionary(vm);
			c = (char)(dataTop--)->i;
			ficlDictionaryAppendCharacter(dictionary, c);
		continue;
		}

		case ficlInstructionCells:
			CHECK_STACK(1, 1);
			dataTop->i *= sizeof (ficlCell);
		continue;

		case ficlInstructionCellPlus:
			CHECK_STACK(1, 1);
			dataTop->i += sizeof (ficlCell);
		continue;

		case ficlInstructionStar:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i *= i;
		continue;

		case ficlInstructionNegate:
			CHECK_STACK(1, 1);
			dataTop->i = - dataTop->i;
		continue;

		case ficlInstructionSlash:
			CHECK_STACK(2, 1);
			i = (dataTop--)->i;
			dataTop->i /= i;
		continue;

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

			CHECK_STACK(2, 2);
			n2    = dataTop[0].i;
			FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1);

			qr = ficl2IntegerDivideSymmetric(n1, n2);
			dataTop[-1].i = qr.remainder;
			dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
		continue;
		}

		case ficlInstruction2Star:
			CHECK_STACK(1, 1);
			dataTop->i <<= 1;
		continue;

		case ficlInstruction2Slash:
			CHECK_STACK(1, 1);
			dataTop->i >>= 1;
		continue;

		case ficlInstructionStarSlash: {
			ficlInteger x, y, z;
			ficl2Integer prod;
			CHECK_STACK(3, 1);

			z = (dataTop--)->i;
			y = (dataTop--)->i;
			x = dataTop->i;

			prod = ficl2IntegerMultiply(x, y);
			dataTop->i = FICL_2UNSIGNED_GET_LOW(
			    ficl2IntegerDivideSymmetric(prod, z).quotient);
		continue;
		}

		case ficlInstructionStarSlashMod: {
			ficlInteger x, y, z;
			ficl2Integer prod;
			ficl2IntegerQR qr;

			CHECK_STACK(3, 2);

			z = (dataTop--)->i;
			y = dataTop[0].i;
			x = dataTop[-1].i;

			prod = ficl2IntegerMultiply(x, y);
			qr   = ficl2IntegerDivideSymmetric(prod, z);

			dataTop[-1].i = qr.remainder;
			dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
			continue;
		}

#if FICL_WANT_FLOAT
		case ficlInstructionF0:
			CHECK_FLOAT_STACK(0, 1);
			(++floatTop)->f = 0.0f;
		continue;

		case ficlInstructionF1:
			CHECK_FLOAT_STACK(0, 1);
			(++floatTop)->f = 1.0f;
		continue;

		case ficlInstructionFNeg1:
			CHECK_FLOAT_STACK(0, 1);
			(++floatTop)->f = -1.0f;
		continue;

		/*
		 * Floating point literal execution word.
		 */
		case ficlInstructionFLiteralParen:
			CHECK_FLOAT_STACK(0, 1);

			/*
			 * Yes, I'm using ->i here,
			 * but it's really a float.  --lch
			 */
			(++floatTop)->i = *ip++;
				continue;

		/*
		 * Do float addition r1 + r2.
		 * f+ ( r1 r2 -- r )
		 */
		case ficlInstructionFPlus:
			CHECK_FLOAT_STACK(2, 1);

			f = (floatTop--)->f;
			floatTop->f += f;
		continue;

		/*
		 * Do float subtraction r1 - r2.
		 * f- ( r1 r2 -- r )
		 */
		case ficlInstructionFMinus:
			CHECK_FLOAT_STACK(2, 1);

			f = (floatTop--)->f;
			floatTop->f -= f;
		continue;

		/*
		 * Do float multiplication r1 * r2.
		 * f* ( r1 r2 -- r )
		 */
		case ficlInstructionFStar:
			CHECK_FLOAT_STACK(2, 1);

			f = (floatTop--)->f;
			floatTop->f *= f;
		continue;

		/*
		 * Do float negation.
		 * fnegate ( r -- r )
		 */
		case ficlInstructionFNegate:
			CHECK_FLOAT_STACK(1, 1);

			floatTop->f = -(floatTop->f);
		continue;

		/*
		 * Do float division r1 / r2.
		 * f/ ( r1 r2 -- r )
		 */
		case ficlInstructionFSlash:
			CHECK_FLOAT_STACK(2, 1);

			f = (floatTop--)->f;
			floatTop->f /= f;
		continue;

		/*
		 * Do float + integer r + n.
		 * f+i ( r n -- r )
		 */
		case ficlInstructionFPlusI:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f += f;
		continue;

		/*
		 * Do float - integer r - n.
		 * f-i ( r n -- r )
		 */
		case ficlInstructionFMinusI:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f -= f;
		continue;

		/*
		 * Do float * integer r * n.
		 * f*i ( r n -- r )
		 */
		case ficlInstructionFStarI:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f *= f;
		continue;

		/*
		 * Do float / integer r / n.
		 * f/i ( r n -- r )
		 */
		case ficlInstructionFSlashI:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f /= f;
			continue;

		/*
		 * Do integer - float n - r.
		 * i-f ( n r -- r )
		 */
		case ficlInstructionIMinusF:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f = f - floatTop->f;
		continue;

		/*
		 * Do integer / float n / r.
		 * i/f ( n r -- r )
		 */
		case ficlInstructionISlashF:
			CHECK_FLOAT_STACK(1, 1);
			CHECK_STACK(1, 0);

			f = (ficlFloat)(dataTop--)->f;
			floatTop->f = f / floatTop->f;
		continue;

		/*
		 * Do integer to float conversion.
		 * int>float ( n -- r )
		 */
		case ficlInstructionIntToFloat:
			CHECK_STACK(1, 0);
			CHECK_FLOAT_STACK(0, 1);

			(++floatTop)->f = ((dataTop--)->f);
		continue;

		/*
		 * Do float to integer conversion.
		 * float>int ( r -- n )
		 */
		case ficlInstructionFloatToInt:
			CHECK_STACK(0, 1);
			CHECK_FLOAT_STACK(1, 0);

			(++dataTop)->i = ((floatTop--)->i);
		continue;

		/*
		 * Add a floating point number to contents of a variable.
		 * f+! ( r n -- )
		 */
		case ficlInstructionFPlusStore: {
			ficlCell *cell;

			CHECK_STACK(1, 0);
			CHECK_FLOAT_STACK(1, 0);

			cell = (ficlCell *)(dataTop--)->p;
			cell->f += (floatTop--)->f;
		continue;
		}

		/*
		 * Do float stack drop.
		 * fdrop ( r -- )
		 */
		case ficlInstructionFDrop:
			CHECK_FLOAT_STACK(1, 0);
			floatTop--;
		continue;

		/*
		 * Do float stack ?dup.
		 * f?dup ( r -- r )
		 */
		case ficlInstructionFQuestionDup:
			CHECK_FLOAT_STACK(1, 2);

			if (floatTop->f != 0)
				goto FDUP;

		continue;

		/*
		 * Do float stack dup.
		 * fdup ( r -- r r )
		 */
		case ficlInstructionFDup:
			CHECK_FLOAT_STACK(1, 2);

FDUP:
			floatTop[1] = floatTop[0];
			floatTop++;
			continue;

		/*
		 * Do float stack swap.
		 * fswap ( r1 r2 -- r2 r1 )
		 */
		case ficlInstructionFSwap:
			CHECK_FLOAT_STACK(2, 2);

			c = floatTop[0];
			floatTop[0] = floatTop[-1];
			floatTop[-1] = c;
		continue;

		/*
		 * Do float stack 2drop.
		 * f2drop ( r r -- )
		 */
		case ficlInstructionF2Drop:
			CHECK_FLOAT_STACK(2, 0);

			floatTop -= 2;
		continue;

		/*
		 * Do float stack 2dup.
		 * f2dup ( r1 r2 -- r1 r2 r1 r2 )
		 */
		case ficlInstructionF2Dup:
			CHECK_FLOAT_STACK(2, 4);

			floatTop[1] = floatTop[-1];
			floatTop[2] = *floatTop;
			floatTop += 2;
		continue;

		/*
		 * Do float stack over.
		 * fover ( r1 r2 -- r1 r2 r1 )
		 */
		case ficlInstructionFOver:
			CHECK_FLOAT_STACK(2, 3);

			floatTop[1] = floatTop[-1];
			floatTop++;
		continue;

		/*
		 * Do float stack 2over.
		 * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
		 */
		case ficlInstructionF2Over:
			CHECK_FLOAT_STACK(4, 6);

			floatTop[1] = floatTop[-2];
			floatTop[2] = floatTop[-1];
			floatTop += 2;
		continue;

		/*
		 * Do float stack pick.
		 * fpick ( n -- r )
		 */
		case ficlInstructionFPick:
			CHECK_STACK(1, 0);
			c = *dataTop--;
			CHECK_FLOAT_STACK(c.i+2, c.i+3);

			floatTop[1] = floatTop[- c.i - 1];
		continue;

		/*
		 * Do float stack rot.
		 * frot ( r1 r2 r3  -- r2 r3 r1 )
		 */
		case ficlInstructionFRot:
			i = 2;
		goto FROLL;

		/*
		 * Do float stack roll.
		 * froll ( n -- )
		 */
		case ficlInstructionFRoll:
			CHECK_STACK(1, 0);
			i = (dataTop--)->i;

			if (i < 1)
				continue;

FROLL:
			CHECK_FLOAT_STACK(i+1, i+2);
			c = floatTop[-i];
			memmove(floatTop - i, floatTop - (i - 1),
			    i * sizeof (ficlCell));
			*floatTop = c;

		continue;

		/*
		 * Do float stack -rot.
		 * f-rot ( r1 r2 r3  -- r3 r1 r2 )
		 */
		case ficlInstructionFMinusRot:
			i = 2;
			goto FMINUSROLL;


		/*
		 * Do float stack -roll.
		 * f-roll ( n -- )
		 */
		case ficlInstructionFMinusRoll:
			CHECK_STACK(1, 0);
			i = (dataTop--)->i;

			if (i < 1)
				continue;

FMINUSROLL:
			CHECK_FLOAT_STACK(i+1, i+2);
			c = *floatTop;
			memmove(floatTop - (i - 1), floatTop - i,
			    i * sizeof (ficlCell));
			floatTop[-i] = c;

		continue;

		/*
		 * Do float stack 2swap
		 * f2swap ( r1 r2 r3 r4  -- r3 r4 r1 r2 )
		 */
		case ficlInstructionF2Swap: {
			ficlCell c2;
			CHECK_FLOAT_STACK(4, 4);

			c = *floatTop;
			c2 = floatTop[-1];

			*floatTop = floatTop[-2];
			floatTop[-1] = floatTop[-3];

			floatTop[-2] = c;
			floatTop[-3] = c2;
		continue;
		}

		/*
		 * Do float 0= comparison r = 0.0.
		 * f0= ( r -- T/F )
		 */
		case ficlInstructionF0Equals:
			CHECK_FLOAT_STACK(1, 0);
			CHECK_STACK(0, 1);

			(++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f);
		continue;

		/*
		 * Do float 0< comparison r < 0.0.
		 * f0< ( r -- T/F )
		 */
		case ficlInstructionF0Less:
			CHECK_FLOAT_STACK(1, 0);
			CHECK_STACK(0, 1);

			(++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f);
		continue;

		/*
		 * Do float 0> comparison r > 0.0.
		 * f0> ( r -- T/F )
		 */
		case ficlInstructionF0Greater:
			CHECK_FLOAT_STACK(1, 0);
			CHECK_STACK(0, 1);

			(++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f);
		continue;

		/*
		 * Do float = comparison r1 = r2.
		 * f= ( r1 r2 -- T/F )
		 */
		case ficlInstructionFEquals:
			CHECK_FLOAT_STACK(2, 0);
			CHECK_STACK(0, 1);

			f = (floatTop--)->f;
			(++dataTop)->i = FICL_BOOL((floatTop--)->f == f);
		continue;

		/*
		 * Do float < comparison r1 < r2.
		 * f< ( r1 r2 -- T/F )
		 */
		case ficlInstructionFLess:
			CHECK_FLOAT_STACK(2, 0);
			CHECK_STACK(0, 1);

			f = (floatTop--)->f;
			(++dataTop)->i = FICL_BOOL((floatTop--)->f < f);
		continue;

		/*
		 * Do float > comparison r1 > r2.
		 * f> ( r1 r2 -- T/F )
		 */
		case ficlInstructionFGreater:
			CHECK_FLOAT_STACK(2, 0);
			CHECK_STACK(0, 1);

			f = (floatTop--)->f;
			(++dataTop)->i = FICL_BOOL((floatTop--)->f > f);
		continue;


		/*
		 * Move float to param stack (assumes they both fit in a
		 * single ficlCell) f>s
		 */
		case ficlInstructionFFrom:
			CHECK_FLOAT_STACK(1, 0);
			CHECK_STACK(0, 1);

			*++dataTop = *floatTop--;
		continue;

		case ficlInstructionToF:
			CHECK_FLOAT_STACK(0, 1);
			CHECK_STACK(1, 0);

			*++floatTop = *dataTop--;
		continue;

#endif /* FICL_WANT_FLOAT */

		/*
		 * c o l o n P a r e n
		 * This is the code that executes a colon definition. It
		 * assumes that the virtual machine is running a "next" loop
		 * (See the vm.c for its implementation of member function
		 * vmExecute()). The colon code simply copies the address of
		 * the first word in the list of words to interpret into IP
		 * after saving its old value. When we return to the "next"
		 * loop, the virtual machine will call the code for each
		 * word in turn.
		 */
		case ficlInstructionColonParen:
			(++returnTop)->p = (void *)ip;
			ip = (ficlInstruction *)(fw->param);
		continue;

		case ficlInstructionCreateParen:
			CHECK_STACK(0, 1);
			(++dataTop)->p = (fw->param + 1);
		continue;

		case ficlInstructionVariableParen:
			CHECK_STACK(0, 1);
			(++dataTop)->p = fw->param;
		continue;

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

#if FICL_WANT_FLOAT
		case ficlInstructionF2ConstantParen:
			CHECK_FLOAT_STACK(0, 2);
			FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param);

		case ficlInstructionFConstantParen:
			CHECK_FLOAT_STACK(0, 1);
			FLOAT_PUSH_CELL_POINTER(fw->param);
#endif /* FICL_WANT_FLOAT */

		case ficlInstruction2ConstantParen:
			CHECK_STACK(0, 2);
			PUSH_CELL_POINTER_DOUBLE(fw->param);

		case ficlInstructionConstantParen:
			CHECK_STACK(0, 1);
			PUSH_CELL_POINTER(fw->param);

#if FICL_WANT_USER
		case ficlInstructionUserParen: {
			ficlInteger i = fw->param[0].i;
			(++dataTop)->p = &vm->user[i];
		continue;
		}
#endif

		default:
		/*
		 * Clever hack, or evil coding?  You be the judge.
		 *
		 * If the word we've been asked to execute is in fact
		 * an *instruction*, we grab the instruction, stow it
		 * in "i" (our local cache of *ip), and *jump* to the
		 * top of the switch statement.  --lch
		 */
			if (((ficlInstruction)fw->code >
			    ficlInstructionInvalid) &&
			    ((ficlInstruction)fw->code < ficlInstructionLast)) {
				instruction = (ficlInstruction)fw->code;
				goto AGAIN;
			}

			LOCAL_VARIABLE_SPILL;
			(vm)->runningWord = fw;
			fw->code(vm);
			LOCAL_VARIABLE_REFILL;
		continue;
		}
	}

	LOCAL_VARIABLE_SPILL;
	vm->exceptionHandler = oldExceptionHandler;
}

/*
 * v m G e t D i c t
 * Returns the address dictionary for this VM's system
 */
ficlDictionary *
ficlVmGetDictionary(ficlVm *vm)
{
	FICL_VM_ASSERT(vm, vm);
	return (vm->callback.system->dictionary);
}

/*
 * v m G e t S t r i n g
 * Parses a string out of the VM input buffer and copies up to the first
 * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a
 * ficlCountedString. The destination string is NULL terminated.
 *
 * Returns the address of the first unused character in the dest buffer.
 */
char *
ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter)
{
	ficlString s = ficlVmParseStringEx(vm, delimiter, 0);

	if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) {
		FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX);
	}

	strncpy(counted->text, FICL_STRING_GET_POINTER(s),
	    FICL_STRING_GET_LENGTH(s));
	counted->text[FICL_STRING_GET_LENGTH(s)] = '\0';
	counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);

	return (counted->text + FICL_STRING_GET_LENGTH(s) + 1);
}

/*
 * v m G e t W o r d
 * vmGetWord calls vmGetWord0 repeatedly until it gets a string with
 * non-zero length.
 */
ficlString
ficlVmGetWord(ficlVm *vm)
{
	ficlString s = ficlVmGetWord0(vm);

	if (FICL_STRING_GET_LENGTH(s) == 0) {
		ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
	}

	return (s);
}

/*
 * v m G e t W o r d 0
 * Skip leading whitespace and parse a space delimited word from the tib.
 * Returns the start address and length of the word. Updates the tib
 * to reflect characters consumed, including the trailing delimiter.
 * If there's nothing of interest in the tib, returns zero. This function
 * does not use vmParseString because it uses isspace() rather than a
 * single  delimiter character.
 */
ficlString
ficlVmGetWord0(ficlVm *vm)
{
	char *trace = ficlVmGetInBuf(vm);
	char *stop = ficlVmGetInBufEnd(vm);
	ficlString s;
	ficlUnsigned length = 0;
	char c = 0;

	trace = ficlStringSkipSpace(trace, stop);
	FICL_STRING_SET_POINTER(s, trace);

	/* Please leave this loop this way; it makes Purify happier.  --lch */
	for (;;) {
		if (trace == stop)
			break;
		c = *trace;
		if (isspace((unsigned char)c))
			break;
		length++;
		trace++;
	}

	FICL_STRING_SET_LENGTH(s, length);

	/* skip one trailing delimiter */
	if ((trace != stop) && isspace((unsigned char)c))
		trace++;

	ficlVmUpdateTib(vm, trace);

	return (s);
}

/*
 * v m G e t W o r d T o P a d
 * Does vmGetWord and copies the result to the pad as a NULL terminated
 * string. Returns the length of the string. If the string is too long
 * to fit in the pad, it is truncated.
 */
int
ficlVmGetWordToPad(ficlVm *vm)
{
	ficlString s;
	char *pad = (char *)vm->pad;
	s = ficlVmGetWord(vm);

	if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE)
		FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE);

	strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
	pad[FICL_STRING_GET_LENGTH(s)] = '\0';
	return ((int)(FICL_STRING_GET_LENGTH(s)));
}

/*
 * v m P a r s e S t r i n g
 * Parses a string out of the input buffer using the delimiter
 * specified. Skips leading delimiters, marks the start of the string,
 * and counts characters to the next delimiter it encounters. It then
 * updates the vm input buffer to consume all these chars, including the
 * trailing delimiter.
 * Returns the address and length of the parsed string, not including the
 * trailing delimiter.
 */
ficlString
ficlVmParseString(ficlVm *vm, char delimiter)
{
	return (ficlVmParseStringEx(vm, delimiter, 1));
}

ficlString
ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
{
	ficlString s;
	char *trace = ficlVmGetInBuf(vm);
	char *stop = ficlVmGetInBufEnd(vm);
	char c;

	if (skipLeadingDelimiters) {
		while ((trace != stop) && (*trace == delimiter))
			trace++;
	}

	FICL_STRING_SET_POINTER(s, trace);    /* mark start of text */

	/* find next delimiter or end of line */
	for (c = *trace;
	    (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n');
	    c = *++trace) {
		;
	}

	/* set length of result */
	FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));

	/* gobble trailing delimiter */
	if ((trace != stop) && (*trace == delimiter))
		trace++;

	ficlVmUpdateTib(vm, trace);
	return (s);
}


/*
 * v m P o p
 */
ficlCell
ficlVmPop(ficlVm *vm)
{
	return (ficlStackPop(vm->dataStack));
}

/*
 * v m P u s h
 */
void
ficlVmPush(ficlVm *vm, ficlCell c)
{
	ficlStackPush(vm->dataStack, c);
}

/*
 * v m P o p I P
 */
void
ficlVmPopIP(ficlVm *vm)
{
	vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
}

/*
 * v m P u s h I P
 */
void
ficlVmPushIP(ficlVm *vm, ficlIp newIP)
{
	ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
	vm->ip = newIP;
}

/*
 * v m P u s h T i b
 * Binds the specified input string to the VM and clears >IN (the index)
 */
void
ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
{
	if (pSaveTib) {
		*pSaveTib = vm->tib;
	}
	vm->tib.text = text;
	vm->tib.end = text + nChars;
	vm->tib.index = 0;
}

void
ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
{
	if (pTib) {
		vm->tib = *pTib;
	}
}

/*
 * v m Q u i t
 */
void
ficlVmQuit(ficlVm *vm)
{
	ficlStackReset(vm->returnStack);
	vm->restart = 0;
	vm->ip = NULL;
	vm->runningWord = NULL;
	vm->state = FICL_VM_STATE_INTERPRET;
	vm->tib.text = NULL;
	vm->tib.end = NULL;
	vm->tib.index = 0;
	vm->pad[0] = '\0';
	vm->sourceId.i = 0;
}

/*
 * v m R e s e t
 */
void
ficlVmReset(ficlVm *vm)
{
	ficlVmQuit(vm);
	ficlStackReset(vm->dataStack);
#if FICL_WANT_FLOAT
	ficlStackReset(vm->floatStack);
#endif
	vm->base = 10;
}

/*
 * v m S e t T e x t O u t
 * Binds the specified output callback to the vm. If you pass NULL,
 * binds the default output function (ficlTextOut)
 */
void
ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
{
	vm->callback.textOut = textOut;
}

void
ficlVmTextOut(ficlVm *vm, char *text)
{
	ficlCallbackTextOut((ficlCallback *)vm, text);
}


void
ficlVmErrorOut(ficlVm *vm, char *text)
{
	ficlCallbackErrorOut((ficlCallback *)vm, text);
}


/*
 * v m T h r o w
 */
void
ficlVmThrow(ficlVm *vm, int except)
{
	if (vm->exceptionHandler)
		longjmp(*(vm->exceptionHandler), except);
}

void
ficlVmThrowError(ficlVm *vm, char *fmt, ...)
{
	va_list list;

	va_start(list, fmt);
	vsprintf(vm->pad, fmt, list);
	va_end(list);
	strcat(vm->pad, "\n");

	ficlVmErrorOut(vm, vm->pad);
	longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
}

void
ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
{
	vsprintf(vm->pad, fmt, list);
	/*
	 * well, we can try anyway, we're certainly not
	 * returning to our caller!
	 */
	va_end(list);
	strcat(vm->pad, "\n");

	ficlVmErrorOut(vm, vm->pad);
	longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
}

/*
 * f i c l E v a l u a t e
 * Wrapper for ficlExec() which sets SOURCE-ID to -1.
 */
int
ficlVmEvaluate(ficlVm *vm, char *s)
{
	int returnValue;
	ficlCell id = vm->sourceId;
	ficlString string;
	vm->sourceId.i = -1;
	FICL_STRING_SET_FROM_CSTRING(string, s);
	returnValue = ficlVmExecuteString(vm, string);
	vm->sourceId = id;
	return (returnValue);
}

/*
 * f i c l E x e c
 * Evaluates a block of input text in the context of the
 * specified interpreter. Emits any requested output to the
 * interpreter's output function.
 *
 * Contains the "inner interpreter" code in a tight loop
 *
 * Returns one of the VM_XXXX codes defined in ficl.h:
 * VM_OUTOFTEXT is the normal exit condition
 * VM_ERREXIT means that the interpreter encountered a syntax error
 *      and the vm has been reset to recover (some or all
 *      of the text block got ignored
 * VM_USEREXIT means that the user executed the "bye" command
 *      to shut down the interpreter. This would be a good
 *      time to delete the vm, etc -- or you can ignore this
 *      signal.
 */
int
ficlVmExecuteString(ficlVm *vm, ficlString s)
{
	ficlSystem *system = vm->callback.system;
	ficlDictionary *dictionary = system->dictionary;

	int except;
	jmp_buf vmState;
	jmp_buf *oldState;
	ficlTIB saveficlTIB;

	FICL_VM_ASSERT(vm, vm);
	FICL_VM_ASSERT(vm, system->interpreterLoop[0]);

	ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s),
	    FICL_STRING_GET_LENGTH(s), &saveficlTIB);

	/*
	 * Save and restore VM's jmp_buf to enable nested calls to ficlExec
	 */
	oldState = vm->exceptionHandler;

	/* This has to come before the setjmp! */
	vm->exceptionHandler = &vmState;
	except = setjmp(vmState);

	switch (except) {
	case 0:
		if (vm->restart) {
			vm->runningWord->code(vm);
			vm->restart = 0;
		} else {	/* set VM up to interpret text */
			ficlVmPushIP(vm, &(system->interpreterLoop[0]));
		}

		ficlVmInnerLoop(vm, 0);
	break;

	case FICL_VM_STATUS_RESTART:
		vm->restart = 1;
		except = FICL_VM_STATUS_OUT_OF_TEXT;
	break;

	case FICL_VM_STATUS_OUT_OF_TEXT:
		ficlVmPopIP(vm);
#if 0	/* we dont output prompt in loader */
		if ((vm->state != FICL_VM_STATE_COMPILE) &&
		    (vm->sourceId.i == 0))
			ficlVmTextOut(vm, FICL_PROMPT);
#endif
	break;

	case FICL_VM_STATUS_USER_EXIT:
	case FICL_VM_STATUS_INNER_EXIT:
	case FICL_VM_STATUS_BREAK:
	break;

	case FICL_VM_STATUS_QUIT:
		if (vm->state == FICL_VM_STATE_COMPILE) {
			ficlDictionaryAbortDefinition(dictionary);
#if FICL_WANT_LOCALS
			ficlDictionaryEmpty(system->locals,
			    system->locals->forthWordlist->size);
#endif
		}
		ficlVmQuit(vm);
	break;

	case FICL_VM_STATUS_ERROR_EXIT:
	case FICL_VM_STATUS_ABORT:
	case FICL_VM_STATUS_ABORTQ:
	default:		/* user defined exit code?? */
		if (vm->state == FICL_VM_STATE_COMPILE) {
			ficlDictionaryAbortDefinition(dictionary);
#if FICL_WANT_LOCALS
			ficlDictionaryEmpty(system->locals,
			    system->locals->forthWordlist->size);
#endif
		}
		ficlDictionaryResetSearchOrder(dictionary);
		ficlVmReset(vm);
	break;
	}

	vm->exceptionHandler = oldState;
	ficlVmPopTib(vm, &saveficlTIB);
	return (except);
}

/*
 * f i c l E x e c X T
 * Given a pointer to a ficlWord, push an inner interpreter and
 * execute the word to completion. This is in contrast with vmExecute,
 * which does not guarantee that the word will have completed when
 * the function returns (ie in the case of colon definitions, which
 * need an inner interpreter to finish)
 *
 * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
 * exit condition is VM_INNEREXIT, Ficl's private signal to exit the
 * inner loop under normal circumstances. If another code is thrown to
 * exit the loop, this function will re-throw it if it's nested under
 * itself or ficlExec.
 *
 * NOTE: this function is intended so that C code can execute ficlWords
 * given their address in the dictionary (xt).
 */
int
ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
{
	int except;
	jmp_buf vmState;
	jmp_buf *oldState;
	ficlWord *oldRunningWord;

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

	/*
	 * Save the runningword so that RESTART behaves correctly
	 * over nested calls.
	 */
	oldRunningWord = vm->runningWord;
	/*
	 * Save and restore VM's jmp_buf to enable nested calls
	 */
	oldState = vm->exceptionHandler;
	/* This has to come before the setjmp! */
	vm->exceptionHandler = &vmState;
	except = setjmp(vmState);

	if (except)
		ficlVmPopIP(vm);
	else
		ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));

	switch (except) {
	case 0:
		ficlVmExecuteWord(vm, pWord);
		ficlVmInnerLoop(vm, 0);
	break;

	case FICL_VM_STATUS_INNER_EXIT:
	case FICL_VM_STATUS_BREAK:
	break;

	case FICL_VM_STATUS_RESTART:
	case FICL_VM_STATUS_OUT_OF_TEXT:
	case FICL_VM_STATUS_USER_EXIT:
	case FICL_VM_STATUS_QUIT:
	case FICL_VM_STATUS_ERROR_EXIT:
	case FICL_VM_STATUS_ABORT:
	case FICL_VM_STATUS_ABORTQ:
	default:		/* user defined exit code?? */
		if (oldState) {
			vm->exceptionHandler = oldState;
			ficlVmThrow(vm, except);
		}
	break;
	}

	vm->exceptionHandler = oldState;
	vm->runningWord = oldRunningWord;
	return (except);
}

/*
 * f i c l P a r s e N u m b e r
 * Attempts to convert the NULL terminated string in the VM's pad to
 * a number using the VM's current base. If successful, pushes the number
 * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE.
 * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
 * the standard for DOUBLE wordset.
 */
int
ficlVmParseNumber(ficlVm *vm, ficlString s)
{
	ficlInteger accumulator = 0;
	char isNegative = 0;
	char isDouble = 0;
	unsigned base = vm->base;
	char *trace = FICL_STRING_GET_POINTER(s);
	ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
	unsigned c;
	unsigned digit;

	if (length > 1) {
		switch (*trace) {
		case '-':
			trace++;
			length--;
			isNegative = 1;
		break;
		case '+':
			trace++;
			length--;
			isNegative = 0;
		break;
		default:
		break;
		}
	}

	/* detect & remove trailing decimal */
	if ((length > 0) && (trace[length - 1] == '.')) {
		isDouble = 1;
		length--;
	}

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

	while ((length--) && ((c = *trace++) != '\0')) {
		if (!isalnum(c))
			return (0);	/* false */

		digit = c - '0';

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

		if (digit >= base)
			return (0);	/* false */

		accumulator = accumulator * base + digit;
	}

	if (isNegative)
		accumulator = -accumulator;

	ficlStackPushInteger(vm->dataStack, accumulator);
	if (vm->state == FICL_VM_STATE_COMPILE)
		ficlPrimitiveLiteralIm(vm);

	if (isDouble) {			/* simple (required) DOUBLE support */
		if (isNegative)
			ficlStackPushInteger(vm->dataStack, -1);
		else
			ficlStackPushInteger(vm->dataStack, 0);
		if (vm->state == FICL_VM_STATE_COMPILE)
			ficlPrimitiveLiteralIm(vm);
	}

	return (1); /* true */
}

/*
 * d i c t C h e c k
 * Checks the dictionary for corruption and throws appropriate
 * errors.
 * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
 *        -n number of ADDRESS UNITS proposed to de-allot
 *         0 just do a consistency check
 */
void
ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
{
#if FICL_ROBUST >= 1
	if ((cells >= 0) &&
	    (ficlDictionaryCellsAvailable(dictionary) *
	    (int)sizeof (ficlCell) < cells)) {
		ficlVmThrowError(vm, "Error: dictionary full");
	}

	if ((cells <= 0) &&
	    (ficlDictionaryCellsUsed(dictionary) *
	    (int)sizeof (ficlCell) < -cells)) {
		ficlVmThrowError(vm, "Error: dictionary underflow");
	}
#else /* FICL_ROBUST >= 1 */
	FICL_IGNORE(vm);
	FICL_IGNORE(dictionary);
	FICL_IGNORE(cells);
#endif /* FICL_ROBUST >= 1 */
}

void
ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
{
#if FICL_ROBUST >= 1
	ficlVmDictionarySimpleCheck(vm, dictionary, cells);

	if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
		ficlDictionaryResetSearchOrder(dictionary);
		ficlVmThrowError(vm, "Error: search order overflow");
	} else if (dictionary->wordlistCount < 0) {
		ficlDictionaryResetSearchOrder(dictionary);
		ficlVmThrowError(vm, "Error: search order underflow");
	}
#else /* FICL_ROBUST >= 1 */
	FICL_IGNORE(vm);
	FICL_IGNORE(dictionary);
	FICL_IGNORE(cells);
#endif /* FICL_ROBUST >= 1 */
}

void
ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
{
	FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
	FICL_IGNORE(vm);
	ficlDictionaryAllot(dictionary, n);
}

void
ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
{
	FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
	FICL_IGNORE(vm);
	ficlDictionaryAllotCells(dictionary, cells);
}

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

	FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
	FICL_STACK_CHECK(vm->dataStack, 0, 0);

#if FICL_WANT_LOCALS
	if (vm->callback.system->localsCount > 0) {
		tempFW = ficlSystemLookupLocal(vm->callback.system, name);
	} else
#endif
		tempFW = ficlDictionaryLookup(dictionary, name);

	if (vm->state == FICL_VM_STATE_INTERPRET) {
		if (tempFW != NULL) {
			if (ficlWordIsCompileOnly(tempFW)) {
				ficlVmThrowError(vm,
				    "Error: FICL_VM_STATE_COMPILE only!");
			}

			ficlVmExecuteWord(vm, tempFW);
			return (1); /* true */
		}
	} else {	/* (vm->state == FICL_VM_STATE_COMPILE) */
		if (tempFW != NULL) {
			if (ficlWordIsImmediate(tempFW)) {
				ficlVmExecuteWord(vm, tempFW);
			} else {
				ficlCell c;
				c.p = tempFW;
				if (tempFW->flags & FICL_WORD_INSTRUCTION)
					ficlDictionaryAppendUnsigned(dictionary,
					    (ficlInteger)tempFW->code);
				else
					ficlDictionaryAppendCell(dictionary, c);
			}
			return (1); /* true */
		}
	}

	return (0); /* false */
}