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

#include "ficl.h"
#include <limits.h>

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

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

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

/*
 * C O N T R O L   S T R U C T U R E   B U I L D E R S
 *
 * Push current dictionary location for later branch resolution.
 * The location may be either a branch target or a patch address...
 */
static void
markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
{
        ficlStackPushPointer(vm->dataStack, dictionary->here);
        ficlStackPushPointer(vm->dataStack, tag);
}

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

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

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

        tag = (char *)ficlStackPopPointer(vm->dataStack);

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

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

        matchControlTag(vm, tag);

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

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

        ficlDictionaryAppendCell(dictionary, c);
}

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

        matchControlTag(vm, tag);

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

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

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

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

        tag = ficlStackPopPointer(vm->dataStack);

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

        patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
        (*patchAddr).p = dictionary->here;
}

/*
 * c o l o n   d e f i n i t i o n s
 * Code to begin compiling a colon definition
 * This function sets the state to FICL_VM_STATE_COMPILE, then creates a
 * new word whose name is the next word in the input stream
 * and whose code is colonParen.
 */
static void
ficlPrimitiveColon(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlString name = ficlVmGetWord(vm);

        vm->state = FICL_VM_STATE_COMPILE;
        markControlTag(vm, colonTag);
        (void) ficlDictionaryAppendWord(dictionary, name,
            (ficlPrimitive)ficlInstructionColonParen,
            FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);

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

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

        matchControlTag(vm, colonTag);

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

        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen);
        vm->state = FICL_VM_STATE_INTERPRET;
        ficlDictionaryUnsmudge(dictionary);
}

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

#if FICL_WANT_LOCALS
        if (vm->callback.system->localsCount > 0) {
                ficlDictionaryAppendUnsigned(dictionary,
                    ficlInstructionUnlinkParen);
        }
#endif
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen);
}

/*
 * c o n s t a n t
 * IMMEDIATE
 * Compiles a constant into the dictionary. Constants return their
 * value when invoked. Expects a value on top of the parm stack.
 */
static void
ficlPrimitiveConstant(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlString name = ficlVmGetWord(vm);

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

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

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

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

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

/*
 * d i s p l a y C e l l
 * Drop and print the contents of the ficlCell at the top of the param
 * stack
 */
static void
ficlPrimitiveDot(ficlVm *vm)
{
        ficlCell c;

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

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

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

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

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

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

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

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

/*
 * s t r l e n
 * Ficl   ( c-string -- length )
 *
 * Returns the length of a C-style (zero-terminated) string.
 *
 * --lch
 */
static void
ficlPrimitiveStrlen(ficlVm *vm)
{
        char *address = (char *)ficlStackPopPointer(vm->dataStack);
        ficlStackPushInteger(vm->dataStack, strlen(address));
}

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

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

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

        int append = 1; /* true */

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

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

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

                        desiredLength = isdigit((unsigned char)*format);
                        if (desiredLength) {
                                desiredLength = strtoul(format, &format, 10);
                                if (format == formatStop)
                                        break;
                        } else if (*format == '*') {
                                desiredLength =
                                    ficlStackPopInteger(vm->dataStack);

                                format++;
                                if (format == formatStop)
                                        break;
                        }

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

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

                format++;
        }

        ficlStackPushPointer(vm->dataStack, bufferStart);
        ficlStackPushInteger(vm->dataStack, buffer - bufferStart);
        ficlStackPushInteger(vm->dataStack, FICL_BOOL(!append));
}

/*
 * d u p   &   f r i e n d s
 */
static void
ficlPrimitiveDepth(ficlVm *vm)
{
        int i;

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

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

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

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

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

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

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

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

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

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

        ficlVmUpdateTib(vm, trace);
}

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

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

/*
 * i f C o I m
 * IMMEDIATE
 * Compiles code for a conditional branch into the dictionary
 * and pushes the branch patch address on the stack for later
 * patching by ELSE or THEN/ENDIF.
 */
static void
ficlPrimitiveIfCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);

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

/*
 * e l s e C o I m
 *
 * IMMEDIATE -- compiles an "else"...
 * 1) FICL_VM_STATE_COMPILE a branch and a patch address;
 *    the address gets patched
 *    by "endif" to point past the "else" code.
 * 2) Pop the the "if" patch address
 * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE
 *    address.
 * 4) Push the "else" patch address. ("endif" patches this to jump past
 *    the "else" code.
 */
static void
ficlPrimitiveElseCoIm(ficlVm *vm)
{
        ficlCell *patchAddr;
        ficlInteger offset;
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);

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

        matchControlTag(vm, origTag);
                                                /* (2) pop "if" patch addr */
        patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
        markBranch(dictionary, vm, origTag);    /* (4) push "else" patch addr */

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

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

/*
 * c a s e C o I m
 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
 *
 *
 * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks
 * like this:
 *                      i*addr i caseTag
 * and an OF-SYS (see DPANS94 6.2.1950) looks like this:
 *                      i*addr i caseTag addr ofTag
 * The integer under caseTag is the count of fixup addresses that branch
 * to ENDCASE.
 */
static void
ficlPrimitiveCaseCoIm(ficlVm *vm)
{
        FICL_STACK_CHECK(vm->dataStack, 0, 2);

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

/*
 * e n d c a s eC o I m
 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
 */
static void
ficlPrimitiveEndcaseCoIm(ficlVm *vm)
{
        ficlUnsigned fixupCount;
        ficlDictionary *dictionary;
        ficlCell *patchAddr;
        ficlInteger offset;

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

        matchControlTag(vm, caseTag);

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

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

        dictionary = ficlVmGetDictionary(vm);

        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop);

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

/*
 * o f C o I m
 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
 */
static void
ficlPrimitiveOfCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlCell *fallthroughFixup = NULL;

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

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

        matchControlTag(vm, caseTag);

        markControlTag(vm, caseTag);

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

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

/*
 * e n d o f C o I m
 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
 */
static void
ficlPrimitiveEndofCoIm(ficlVm *vm)
{
        ficlCell *patchAddr;
        ficlUnsigned fixupCount;
        ficlInteger offset;
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);

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

        /* ensure we're in an OF, */
        matchControlTag(vm, ofTag);

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

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

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

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

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

/*
 * f a l l t h r o u g h C o I m
 * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
 */
static void
ficlPrimitiveFallthroughCoIm(ficlVm *vm)
{
        ficlCell *patchAddr;
        ficlInteger offset;
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);

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

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

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

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

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

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

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

/*
 * h a s h
 * hash ( c-addr u -- code)
 * calculates hashcode of specified string and leaves it on the stack
 */
static void
ficlPrimitiveHash(ficlVm *vm)
{
        ficlString s;

        FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack));
        FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
        ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s));
}

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

        FICL_VM_ASSERT(vm, vm);

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

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

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

                if (word == NULL)
                        break;

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

        ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s),
            FICL_STRING_GET_POINTER(s));
        /* back to inner interpreter */
}

/*
 * Surrogate precompiled parse step for ficlParseWord
 * (this step is hard coded in FICL_VM_STATE_INTERPRET)
 */
static void
ficlPrimitiveLookup(ficlVm *vm)
{
        ficlString name;
        FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
        FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack));
        ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name));
}

/*
 * p a r e n P a r s e S t e p
 * (parse-step)  ( c-addr u -- flag )
 * runtime for a precompiled parse step - pop a counted string off the
 * stack, run the parse step against it, and push the result flag (FICL_TRUE
 * if success, FICL_FALSE otherwise).
 */
void
ficlPrimitiveParseStepParen(ficlVm *vm)
{
        ficlString s;
        ficlWord *word = vm->runningWord;
        ficlParseStep pStep = (ficlParseStep)(word->param->fn);

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

        ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s));
}

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

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

        pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p);
        if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep))
                (void) ficlSystemAddParseStep(vm->callback.system, pStep);
}

/*
 * l i t e r a l I m
 *
 * IMMEDIATE code for "literal". This function gets a value from the stack
 * and compiles it into the dictionary preceded by the code for "(literal)".
 * IMMEDIATE
 */
void
ficlPrimitiveLiteralIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlInteger value;

        value = ficlStackPopInteger(vm->dataStack);

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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


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

/*
 * a l l o t   &   f r i e n d s
 */
static void
ficlPrimitiveAllot(ficlVm *vm)
{
        ficlDictionary *dictionary;
        ficlInteger i;

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

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

        FICL_VM_DICTIONARY_CHECK(vm, dictionary, i);

        ficlVmDictionaryAllot(vm, dictionary, i);
}

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

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

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

/*
 * t i c k
 * tick         CORE ( "<spaces>name" -- xt )
 * Skip leading space delimiters. Parse name delimited by a space. Find
 * name and return xt, the execution token for name. An ambiguous condition
 * exists if name is not found.
 */
void
ficlPrimitiveTick(ficlVm *vm)
{
        ficlWord *word = NULL;
        ficlString name = ficlVmGetWord(vm);

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

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

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

/*
 * p o s t p o n e
 * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to
 * insert it into definitions created by the resulting word
 * (defers compilation, even of immediate words)
 */
static void
ficlPrimitivePostponeCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary  = ficlVmGetDictionary(vm);
        ficlWord *word;
        ficlWord *pComma = ficlSystemLookup(vm->callback.system, ",");
        ficlCell c;

        FICL_VM_ASSERT(vm, pComma);

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

/*
 * e x e c u t e
 * Pop an execution token (pointer to a word) off the stack and
 * run it
 */
static void
ficlPrimitiveExecute(ficlVm *vm)
{
        ficlWord *word;

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

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

/*
 * i m m e d i a t e
 * Make the most recently compiled word IMMEDIATE -- it executes even
 * in FICL_VM_STATE_COMPILE state (most often used for control compiling words
 * such as IF, THEN, etc)
 */
static void
ficlPrimitiveImmediate(ficlVm *vm)
{
        FICL_IGNORE(vm);
        ficlDictionarySetImmediate(ficlVmGetDictionary(vm));
}

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

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

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

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

        ficlStackPushInteger(vm->dataStack, flag);
}

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

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

                (void) ficlVmGetString(vm, counted, '\"');
                ficlStackPushPointer(vm->dataStack, counted);

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

/*
 * d o t Q u o t e
 * IMMEDIATE word that compiles a string literal for later display
 * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the
 * string from the
 * TIB to the dictionary. Backpatch the count byte and align the dictionary.
 */
static void
ficlPrimitiveDotQuoteCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlWord *pType = ficlSystemLookup(vm->callback.system, "type");
        ficlCell c;

        FICL_VM_ASSERT(vm, pType);

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

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

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

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

        ficlVmTextOut(vm, vm->pad);
        ficlVmUpdateTib(vm, from);
}

/*
 * s l i t e r a l
 * STRING
 * Interpretation: Interpretation semantics for this word are undefined.
 * Compilation: ( c-addr1 u -- )
 * Append the run-time semantics given below to the current definition.
 * Run-time:       ( -- c-addr2 u )
 * Return c-addr2 u describing a string consisting of the characters
 * specified by c-addr1 u during compilation. A program shall not alter
 * the returned string.
 */
static void ficlPrimitiveSLiteralCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary;
        char *from;
        char *to;
        ficlUnsigned length;

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

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

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

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

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

/*
 * s t a t e
 * Return the address of the VM's state member (must be sized the
 * same as a ficlCell for this reason)
 */
static void ficlPrimitiveState(ficlVm *vm)
{
        FICL_STACK_CHECK(vm->dataStack, 0, 1);
        ficlStackPushPointer(vm->dataStack, &vm->state);
}

/*
 * c r e a t e . . . d o e s >
 * Make a new word in the dictionary with the run-time effect of
 * a variable (push my address), but with extra space allotted
 * for use by does> .
 */
static void
ficlPrimitiveCreate(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlString name = ficlVmGetWord(vm);

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

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

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

        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen);
}

/*
 * t o   b o d y
 * to-body      CORE ( xt -- a-addr )
 * a-addr is the data-field address corresponding to xt. An ambiguous
 * condition exists if xt is not for a word defined via CREATE.
 */
static void
ficlPrimitiveToBody(ficlVm *vm)
{
        ficlWord *word;
        FICL_STACK_CHECK(vm->dataStack, 1, 1);

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

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

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

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

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

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

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

        FICL_VM_ASSERT(vm, wp);

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

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

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

/*
 * p i c t u r e d   n u m e r i c   w o r d s
 *
 * less-number-sign CORE ( -- )
 * Initialize the pictured numeric output conversion process.
 * (clear the pad)
 */
static void
ficlPrimitiveLessNumberSign(ficlVm *vm)
{
        ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
        counted->length = 0;
}

/*
 * number-sign          CORE ( ud1 -- ud2 )
 * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
 * n. (n is the least-significant digit of ud1.) Convert n to external form
 * and add the resulting character to the beginning of the pictured numeric
 * output  string. An ambiguous condition exists if # executes outside of a
 * <# #> delimited number conversion.
 */
static void
ficlPrimitiveNumberSign(ficlVm *vm)
{
        ficlCountedString *counted;
        ficl2Unsigned u;
        ficl2UnsignedQR uqr;

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

        counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
        u = ficlStackPop2Unsigned(vm->dataStack);
        uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
        counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
        ficlStackPush2Unsigned(vm->dataStack, uqr.quotient);
}

/*
 * number-sign-greater CORE ( xd -- c-addr u )
 * Drop xd. Make the pictured numeric output string available as a character
 * string. c-addr and u specify the resulting character string. A program
 * may replace characters within the string.
 */
static void
ficlPrimitiveNumberSignGreater(ficlVm *vm)
{
        ficlCountedString *counted;

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

        counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
        counted->text[counted->length] = 0;
        (void) ficlStringReverse(counted->text);
        ficlStackDrop(vm->dataStack, 2);
        ficlStackPushPointer(vm->dataStack, counted->text);
        ficlStackPushUnsigned(vm->dataStack, counted->length);
}

/*
 * number-sign-s        CORE ( ud1 -- ud2 )
 * Convert one digit of ud1 according to the rule for #. Continue conversion
 * until the quotient is zero. ud2 is zero. An ambiguous condition exists if
 * #S executes outside of a <# #> delimited number conversion.
 * TO DO: presently does not use ud1 hi ficlCell - use it!
 */
static void
ficlPrimitiveNumberSignS(ficlVm *vm)
{
        ficlCountedString *counted;
        ficl2Unsigned u;
        ficl2UnsignedQR uqr;

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

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

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

        ficlStackPush2Unsigned(vm->dataStack, u);
}

/*
 * HOLD         CORE ( char -- )
 * Add char to the beginning of the pictured numeric output string.
 * An ambiguous condition exists if HOLD executes outside of a <# #>
 * delimited number conversion.
 */
static void
ficlPrimitiveHold(ficlVm *vm)
{
        ficlCountedString *counted;
        int i;

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

        counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
        i = ficlStackPopInteger(vm->dataStack);
        counted->text[counted->length++] = (char)i;
}

/*
 * SIGN         CORE ( n -- )
 * If n is negative, add a minus sign to the beginning of the pictured
 * numeric output string. An ambiguous condition exists if SIGN
 * executes outside of a <# #> delimited number conversion.
 */
static void
ficlPrimitiveSign(ficlVm *vm)
{
        ficlCountedString *counted;
        int i;

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

        counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
        i = ficlStackPopInteger(vm->dataStack);
        if (i < 0)
                counted->text[counted->length++] = '-';
}

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

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

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

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

                digit = c - '0';

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

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

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

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

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

/*
 * a c c e p t
 * accept       CORE ( c-addr +n1 -- +n2 )
 * Receive a string of at most +n1 characters. An ambiguous condition
 * exists if +n1 is zero or greater than 32,767. Display graphic characters
 * as they are received. A program that depends on the presence or absence
 * of non-graphic characters in the string has an environmental dependency.
 * The editing functions, if any, that the system performs in order to
 * construct the string are implementation-defined.
 *
 * (Although the standard text doesn't say so, I assume that the intent
 * of 'accept' is to store the string at the address specified on
 * the stack.)
 *
 * NOTE: getchar() is used there as its present both in loader and
 *      userland; however, the more correct solution would be to set
 *      terminal to raw mode for userland.
 */
static void
ficlPrimitiveAccept(ficlVm *vm)
{
        ficlUnsigned size;
        char *address;
        int c;
        ficlUnsigned length = 0;

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

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

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

/*
 * a l i g n
 * 6.1.0705 ALIGN       CORE ( -- )
 * If the data-space pointer is not aligned, reserve enough space to
 * align it.
 */
static void
ficlPrimitiveAlign(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        FICL_IGNORE(vm);
        ficlDictionaryAlign(dictionary);
}

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

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

        addr = ficlStackPopPointer(vm->dataStack);
        ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr));
}

/*
 * b e g i n   &   f r i e n d s
 * Indefinite loop control structures
 * A.6.1.0760 BEGIN
 * Typical use:
 *      : X ... BEGIN ... test UNTIL ;
 * or
 *      : X ... BEGIN ... test WHILE ... REPEAT ;
 */
static void
ficlPrimitiveBeginCoIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        markBranch(dictionary, vm, destTag);
}

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

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

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

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

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

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

        ficlDictionaryAppendUnsigned(dictionary, 1);
}

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

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

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

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

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

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

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

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

/*
 * c h a r P l u s
 * char-plus    CORE ( c-addr1 -- c-addr2 )
 * Add the size in address units of a character to c-addr1, giving c-addr2.
 */
static void
ficlPrimitiveCharPlus(ficlVm *vm)
{
        char *p;

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

        p = ficlStackPopPointer(vm->dataStack);
        ficlStackPushPointer(vm->dataStack, p + 1);
}

/*
 * c h a r s
 * chars        CORE ( n1 -- n2 )
 * n2 is the size in address units of n1 characters.
 * For most processors, this function can be a no-op. To guarantee
 * portability, we'll multiply by sizeof (char).
 */
#if defined(_M_IX86)
#pragma warning(disable: 4127)
#endif
static void
ficlPrimitiveChars(ficlVm *vm)
{
        if (sizeof (char) > 1) {
                ficlInteger i;

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

                i = ficlStackPopInteger(vm->dataStack);
                ficlStackPushInteger(vm->dataStack, i * sizeof (char));
        }
        /* otherwise no-op! */
}
#if defined(_M_IX86)
#pragma warning(default: 4127)
#endif

/*
 * c o u n t
 * COUNT        CORE ( c-addr1 -- c-addr2 u )
 * Return the character string specification for the counted string stored
 * at c-addr1. c-addr2 is the address of the first character after c-addr1.
 * u is the contents of the character at c-addr1, which is the length in
 * characters of the string at c-addr2.
 */
static void
ficlPrimitiveCount(ficlVm *vm)
{
        ficlCountedString *counted;

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

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

/*
 * e n v i r o n m e n t ?
 * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE )
 * c-addr is the address of a character string and u is the string's
 * character count. u may have a value in the range from zero to an
 * implementation-defined maximum which shall not be less than 31. The
 * character string should contain a keyword from 3.2.6 Environmental
 * queries or the optional word sets to be checked for correspondence
 * with an attribute of the present environment. If the system treats the
 * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag
 * is FICL_TRUE and the i*x returned is of the type specified in the table for
 * the attribute queried.
 */
static void
ficlPrimitiveEnvironmentQ(ficlVm *vm)
{
        ficlDictionary *environment;
        ficlWord *word;
        ficlString name;

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

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

        word = ficlDictionaryLookup(environment, name);

        if (word != NULL) {
                ficlVmExecuteWord(vm, word);
                ficlStackPushInteger(vm->dataStack, FICL_TRUE);
        } else {
                ficlStackPushInteger(vm->dataStack, FICL_FALSE);
        }
}

/*
 * e v a l u a t e
 * EVALUATE CORE ( i*x c-addr u -- j*x )
 * Save the current input source specification. Store minus-one (-1) in
 * SOURCE-ID if it is present. Make the string described by c-addr and u
 * both the input source and input buffer, set >IN to zero, and
 * FICL_VM_STATE_INTERPRET.
 * When the parse area is empty, restore the prior input source
 * specification. Other stack effects are due to the words EVALUATEd.
 */
static void
ficlPrimitiveEvaluate(ficlVm *vm)
{
        ficlCell id;
        int result;
        ficlString string;

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

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

        id = vm->sourceId;
        vm->sourceId.i = -1;
        result = ficlVmExecuteString(vm, string);
        vm->sourceId = id;
        if (result != FICL_VM_STATUS_OUT_OF_TEXT)
                ficlVmThrow(vm, result);
}

/*
 * s t r i n g   q u o t e
 * Interpreting: get string delimited by a quote from the input stream,
 * copy to a scratch area, and put its count and address on the stack.
 * Compiling: FICL_VM_STATE_COMPILE code to push the address and count
 * of a string literal, FICL_VM_STATE_COMPILE the string from the input
 * stream, and align the dictionary pointer.
 */
static void
ficlPrimitiveStringQuoteIm(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);

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

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

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

        length = ficlStackPopUnsigned(vm->dataStack);
        s = ficlStackPopPointer(vm->dataStack);

        if ((s == NULL) || (length == 0))
                return;

        /*
         * Since we don't have an output primitive for a counted string
         * (oops), make sure the string is null terminated. If not, copy
         * and terminate it.
         */
        if (s[length] != 0) {
                char *here = (char *)ficlVmGetDictionary(vm)->here;
                if (s != here)
                        (void) strncpy(here, s, length);

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

        ficlVmTextOut(vm, s);
}

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

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

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

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

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

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

        ficlStackPushPointer(vm->dataStack, counted);
}

/*
 * p a r s e - w o r d
 * Ficl   PARSE-WORD  ( <spaces>name -- c-addr u )
 * Skip leading spaces and parse name delimited by a space. c-addr is the
 * address within the input buffer and u is the length of the selected
 * string. If the parse area is empty, the resulting string has a zero length.
 */
static void ficlPrimitiveParseNoCopy(ficlVm *vm)
{
        ficlString s;

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

        s = ficlVmGetWord0(vm);
        ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
        ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
}

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

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

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

        s = ficlVmParseStringEx(vm, delim, 0);
        ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
        ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
}

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

        word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
        if (word) {
                ficlStackPushPointer(vm->dataStack, word);
                ficlStackPushInteger(vm->dataStack,
                    (ficlWordIsImmediate(word) ? 1 : -1));
        } else {
                ficlStackPushPointer(vm->dataStack, returnForFailure);
                ficlStackPushUnsigned(vm->dataStack, 0);
        }
}

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

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

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

/*
 * s f i n d
 * Ficl   ( c-addr u -- 0 0  |  xt 1  |  xt -1 )
 * Like FIND, but takes "c-addr u" for the string.
 */
static void
ficlPrimitiveSFind(ficlVm *vm)
{
        ficlString name;

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

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

        do_find(vm, name, NULL);
}

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

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

/*
 * s o u r c e
 * CORE ( -- c-addr u )
 * c-addr is the address of, and u is the number of characters in, the
 * input buffer.
 */
static void
ficlPrimitiveSource(ficlVm *vm)
{
        FICL_STACK_CHECK(vm->dataStack, 0, 2);

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

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

/*
 * t o I n
 * to-in CORE
 */
static void
ficlPrimitiveToIn(ficlVm *vm)
{
        FICL_STACK_CHECK(vm->dataStack, 0, 1);

        ficlStackPushPointer(vm->dataStack, &vm->tib.index);
}

/*
 * c o l o n N o N a m e
 * CORE EXT ( C:  -- colon-sys )  ( S:  -- xt )
 * Create an unnamed colon definition and push its address.
 * Change state to FICL_VM_STATE_COMPILE.
 */
static void
ficlPrimitiveColonNoName(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlWord *word;
        ficlString name;

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

        vm->state = FICL_VM_STATE_COMPILE;
        word = ficlDictionaryAppendWord(dictionary, name,
            (ficlPrimitive)ficlInstructionColonParen,
            FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);

        ficlStackPushPointer(vm->dataStack, word);
        markControlTag(vm, colonTag);
}

/*
 * u s e r   V a r i a b l e
 * user  ( u -- )  "<spaces>name"
 * Get a name from the input stream and create a user variable
 * with the name and the index supplied. The run-time effect
 * of a user variable is to push the address of the indexed ficlCell
 * in the running vm's user array.
 *
 * User variables are vm local cells. Each vm has an array of
 * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
 * Ficl's user facility is implemented with two primitives,
 * "user" and "(user)", a variable ("nUser") (in softcore.c) that
 * holds the index of the next free user ficlCell, and a redefinition
 * (also in softcore) of "user" that defines a user word and increments
 * nUser.
 */
#if FICL_WANT_USER
static void
ficlPrimitiveUser(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlString name = ficlVmGetWord(vm);
        ficlCell c;

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

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

#if FICL_WANT_LOCALS
/*
 * Each local is recorded in a private locals dictionary as a
 * word that does doLocalIm at runtime. DoLocalIm compiles code
 * into the client definition to fetch the value of the
 * corresponding local variable from the return stack.
 * The private dictionary gets initialized at the end of each block
 * that uses locals (in ; and does> for example).
 */
void
ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlInteger nLocal = vm->runningWord->param[0].i;

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

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

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

                ficlDictionaryAppendUnsigned(dictionary, instruction);
                if (appendLocalOffset)
                        ficlDictionaryAppendUnsigned(dictionary, nLocal);
        }
}

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

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

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

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

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

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

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

        if (FICL_STRING_GET_LENGTH(name) > 0) {
                /*
                 * add a local to the **locals** dictionary and
                 * update localsCount
                 */
                ficlPrimitive code;
                ficlInstruction instruction;
                ficlDictionary *locals;

                locals = ficlSystemGetLocals(vm->callback.system);
                if (vm->callback.system->localsCount >= FICL_MAX_LOCALS) {
                        ficlVmThrowError(vm, "Error: out of local space");
                }

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

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

                if (vm->callback.system->localsCount == 0) {
                        /*
                         * FICL_VM_STATE_COMPILE code to create a local
                         * stack frame
                         */
                        ficlDictionaryAppendUnsigned(dictionary,
                            ficlInstructionLinkParen);

                        /* save location in dictionary for #locals */
                        vm->callback.system->localsFixup = dictionary->here;
                        ficlDictionaryAppendUnsigned(dictionary,
                            vm->callback.system->localsCount);
                }

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

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

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

static void
ficlPrimitive2LocalParen(ficlVm *vm)
{
        ficlLocalParen(vm, 1, 0);
}
#endif /* FICL_WANT_LOCALS */

/*
 * t o V a l u e
 * CORE EXT
 * Interpretation: ( x "<spaces>name" -- )
 * Skip leading spaces and parse name delimited by a space. Store x in
 * name. An ambiguous condition exists if name was not defined by VALUE.
 * NOTE: In Ficl, VALUE is an alias of CONSTANT
 */
static void
ficlPrimitiveToValue(ficlVm *vm)
{
        ficlString name = ficlVmGetWord(vm);
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlWord *word;
        ficlInstruction instruction = 0;
        ficlStack *stack;
        ficlInteger isDouble;
#if FICL_WANT_LOCALS
        ficlInteger nLocal;
        ficlInteger appendLocalOffset;
        ficlInteger isFloat;
#endif /* FICL_WANT_LOCALS */

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

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

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

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

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

                ficlDictionaryAppendUnsigned(dictionary, instruction);
                if (appendLocalOffset)
                        ficlDictionaryAppendUnsigned(dictionary, nLocal);
                return;
        }
#endif

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

        switch ((ficlInstruction)word->code) {
        case ficlInstructionConstantParen:
                instruction = ficlInstructionStore;
                stack = vm->dataStack;
                isDouble = FICL_FALSE;
                break;
        case ficlInstruction2ConstantParen:
                instruction = ficlInstruction2Store;
                stack = vm->dataStack;
                isDouble = FICL_TRUE;
                break;
#if FICL_WANT_FLOAT
        case ficlInstructionFConstantParen:
                instruction = ficlInstructionFStore;
                stack = vm->floatStack;
                isDouble = FICL_FALSE;
                break;
        case ficlInstructionF2ConstantParen:
                instruction = ficlInstructionF2Store;
                stack = vm->floatStack;
                isDouble = FICL_TRUE;
                break;
#endif /* FICL_WANT_FLOAT */
        default:
                ficlVmThrowError(vm,
                    "to %.*s : value/constant is of unknown type",
                    FICL_STRING_GET_LENGTH(name),
                    FICL_STRING_GET_POINTER(name));
                break;
        }

        if (vm->state == FICL_VM_STATE_INTERPRET) {
                word->param[0] = ficlStackPop(stack);
                if (isDouble)
                        word->param[1] = ficlStackPop(stack);
        } else {
                /* FICL_VM_STATE_COMPILE code to store to word's param */
                ficlStackPushPointer(vm->dataStack, &word->param[0]);
                ficlPrimitiveLiteralIm(vm);
                ficlDictionaryAppendUnsigned(dictionary, instruction);
        }
}

/*
 * f m S l a s h M o d
 * f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
 * Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
 * Input and output stack arguments are signed. An ambiguous condition
 * exists if n1 is zero or if the quotient lies outside the range of a
 * single-ficlCell signed integer.
 */
static void
ficlPrimitiveFMSlashMod(ficlVm *vm)
{
        ficl2Integer d1;
        ficlInteger n1;
        ficl2IntegerQR qr;

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

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

/*
 * s m S l a s h R e m
 * s-m-slash-remainder CORE ( d1 n1 -- n2 n3 )
 * Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
 * Input and output stack arguments are signed. An ambiguous condition
 * exists if n1 is zero or if the quotient lies outside the range of a
 * single-ficlCell signed integer.
 */
static void
ficlPrimitiveSMSlashRem(ficlVm *vm)
{
        ficl2Integer d1;
        ficlInteger n1;
        ficl2IntegerQR qr;

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

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

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

        n1 = ficlStackPopInteger(vm->dataStack);
        i = ficlStackPopInteger(vm->dataStack);
        FICL_INTEGER_TO_2INTEGER(i, d1);
        qr = ficl2IntegerDivideSymmetric(d1, n1);
        ficlStackPushInteger(vm->dataStack, qr.remainder);
}

/*
 * u m S l a s h M o d
 * u-m-slash-mod CORE ( ud u1 -- u2 u3 )
 * Divide ud by u1, giving the quotient u3 and the remainder u2.
 * All values and arithmetic are unsigned. An ambiguous condition
 * exists if u1 is zero or if the quotient lies outside the range of a
 * single-ficlCell unsigned integer.
 */
static void
ficlPrimitiveUMSlashMod(ficlVm *vm)
{
        ficl2Unsigned ud;
        ficlUnsigned u1;
        ficl2UnsignedQR uqr;

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

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

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

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

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

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

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

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

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

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

/*
 * s o u r c e - i d
 * CORE EXT, FILE   ( -- 0 | -1 | fileid )
 *    Identifies the input source as follows:
 *
 * SOURCE-ID       Input source
 * ---------       ------------
 * fileid          Text file fileid
 * -1              String (via EVALUATE)
 * 0               User input device
 */
static void
ficlPrimitiveSourceID(ficlVm *vm)
{
        ficlStackPushInteger(vm->dataStack, vm->sourceId.i);
}

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

        ficlStackPushInteger(vm->dataStack, ret);
}

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

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

        /*
         * Get xt.
         * We need this *before* we save the stack pointer, or
         * we'll have to pop one element out of the stack after
         * an exception. I prefer to get done with it up front. :-)
         */

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

        word = ficlStackPopPointer(vm->dataStack);

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

        /*
         * Give vm a jmp_buf
         */
        vm->exceptionHandler = &vmState;

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

        switch (except) {
        /*
         * Setup condition - push poison pill so that the VM throws
         * VM_INNEREXIT if the XT terminates normally, then execute
         * the XT
         */
        case 0:
                /* Open mouth, insert emetic */
                ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
                ficlVmExecuteWord(vm, word);
                ficlVmInnerLoop(vm, 0);
        break;

        /*
         * Normal exit from XT - lose the poison pill,
         * restore old setjmp vector and push a zero.
         */
        case FICL_VM_STATUS_INNER_EXIT:
                ficlVmPopIP(vm);        /* Gack - hurl poison pill */
                                        /* Restore just the setjmp vector */
                vm->exceptionHandler = vmCopy.exceptionHandler;
                                        /* Push 0 -- everything is ok */
                ficlStackPushInteger(vm->dataStack, 0);
        break;

        /*
         * Some other exception got thrown - restore pre-existing VM state
         * and push the exception code
         */
        default:
                /* Restore vm's state */
                memcpy((void*)vm, (void*)&vmCopy, sizeof (ficlVm));
                memcpy((void*)vm->dataStack, (void*)&dataStackCopy,
                    sizeof (ficlStack));
                memcpy((void*)vm->returnStack, (void*)&returnStackCopy,
                    sizeof (ficlStack));

                ficlStackPushInteger(vm->dataStack, except); /* Push error */
        break;
        }
}

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

        except = ficlStackPopInteger(vm->dataStack);

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

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

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

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

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

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

        size = ficlStackPopInteger(vm->dataStack);
        old = ficlStackPopPointer(vm->dataStack);
        new = ficlRealloc(old, size);

        if (new) {
                ficlStackPushPointer(vm->dataStack, new);
                ficlStackPushInteger(vm->dataStack, 0);
        } else {
                ficlStackPushPointer(vm->dataStack, old);
                ficlStackPushInteger(vm->dataStack, 1);
        }
}

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

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

/*
 * f i c l C o m p i l e C o r e
 * Builds the primitive wordset and the environment-query namespace.
 */
void
ficlSystemCompileCore(ficlSystem *system)
{
        ficlWord *interpret;
        ficlDictionary *dictionary = ficlSystemGetDictionary(system);
        ficlDictionary *environment = ficlSystemGetEnvironment(system);

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

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

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

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

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

        {
                ficl2Integer id;
                ficlInteger low, high;

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

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

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

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

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

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

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

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

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

        (void) ficlDictionarySetConstant(environment, "memory-alloc",
            FICL_TRUE);

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

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

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

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

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

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

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

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