common/ficl/vm.c

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

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

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