/*
 * t o o l s . c
 * Forth Inspired Command Language - programming tools
 * Author: John Sadler (john_sadler@alum.mit.edu)
 * Created: 20 June 2000
 * $Id: tools.c,v 1.12 2010/08/12 13:57:22 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.
 */

/*
 * NOTES:
 * SEE needs information about the addresses of functions that
 * are the CFAs of colon definitions, constants, variables, DOES>
 * words, and so on. It gets this information from a table and supporting
 * functions in words.c.
 * fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen
 *
 * Step and break debugger for Ficl
 * debug  ( xt -- )   Start debugging an xt
 * Set a breakpoint
 * Specify breakpoint default action
 */

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

extern void exit(int);

static void ficlPrimitiveStepIn(ficlVm *vm);
static void ficlPrimitiveStepOver(ficlVm *vm);
static void ficlPrimitiveStepBreak(ficlVm *vm);

void
ficlCallbackAssert(ficlCallback *callback, int expression,
    char *expressionString, char *filename, int line)
{
#if FICL_ROBUST >= 1
        if (!expression) {
                static char buffer[256];
                (void) sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n",
                    filename, line, expressionString);
                ficlCallbackTextOut(callback, buffer);
                exit(-1);
        }
#else /* FICL_ROBUST >= 1 */
        FICL_IGNORE(callback);
        FICL_IGNORE(expression);
        FICL_IGNORE(expressionString);
        FICL_IGNORE(filename);
        FICL_IGNORE(line);
#endif /* FICL_ROBUST >= 1 */
}

/*
 * v m S e t B r e a k
 * Set a breakpoint at the current value of IP by
 * storing that address in a BREAKPOINT record
 */
static void
ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP)
{
        ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
        FICL_VM_ASSERT(vm, pStep);

        pBP->address = vm->ip;
        pBP->oldXT = *vm->ip;
        *vm->ip = pStep;
}

/*
 * d e b u g P r o m p t
 */
static void
ficlDebugPrompt(bool debug)
{
        if (debug)
                (void) setenv("prompt", "dbg> ", 1);
        else
                (void) setenv("prompt", "${interpret}", 1);
}

#if 0
static int
isPrimitive(ficlWord *word)
{
        ficlWordKind wk = ficlWordClassify(word);
        return ((wk != COLON) && (wk != DOES));
}
#endif

/*
 * d i c t H a s h S u m m a r y
 * Calculate a figure of merit for the dictionary hash table based
 * on the average search depth for all the words in the dictionary,
 * assuming uniform distribution of target keys. The figure of merit
 * is the ratio of the total search depth for all keys in the table
 * versus a theoretical optimum that would be achieved if the keys
 * were distributed into the table as evenly as possible.
 * The figure would be worse if the hash table used an open
 * addressing scheme (i.e. collisions resolved by searching the
 * table for an empty slot) for a given size table.
 */
#if FICL_WANT_FLOAT
void
ficlPrimitiveHashSummary(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlHash *pFHash;
        ficlWord **hash;
        unsigned size;
        ficlWord *word;
        unsigned i;
        int nMax = 0;
        int nWords = 0;
        int nFilled;
        double avg = 0.0;
        double best;
        int nAvg, nRem, nDepth;

        FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);

        pFHash = dictionary->wordlists[dictionary->wordlistCount - 1];
        hash = pFHash->table;
        size = pFHash->size;
        nFilled = size;

        for (i = 0; i < size; i++) {
                int n = 0;
                word = hash[i];

                while (word) {
                        ++n;
                        ++nWords;
                        word = word->link;
                }

                avg += (double)(n * (n+1)) / 2.0;

                if (n > nMax)
                        nMax = n;
                if (n == 0)
                        --nFilled;
        }

        /* Calc actual avg search depth for this hash */
        avg = avg / nWords;

        /* Calc best possible performance with this size hash */
        nAvg = nWords / size;
        nRem = nWords % size;
        nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
        best = (double)nDepth/nWords;

        (void) sprintf(vm->pad, "%d bins, %2.0f%% filled, Depth: "
            "Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n",
            size, (double)nFilled * 100.0 / size, nMax,
            avg, best, 100.0 * best / avg);

        ficlVmTextOut(vm, vm->pad);
}
#endif

/*
 * Here's the outer part of the decompiler. It's
 * just a big nested conditional that checks the
 * CFA of the word to decompile for each kind of
 * known word-builder code, and tries to do
 * something appropriate. If the CFA is not recognized,
 * just indicate that it is a primitive.
 */
static void
ficlPrimitiveSeeXT(ficlVm *vm)
{
        ficlWord *word;
        ficlWordKind kind;

        word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
        kind = ficlWordClassify(word);

        switch (kind) {
        case FICL_WORDKIND_COLON:
                (void) sprintf(vm->pad, ": %.*s\n", word->length, word->name);
                ficlVmTextOut(vm, vm->pad);
                ficlDictionarySee(ficlVmGetDictionary(vm), word,
                    &(vm->callback));
        break;
        case FICL_WORDKIND_DOES:
                ficlVmTextOut(vm, "does>\n");
                ficlDictionarySee(ficlVmGetDictionary(vm),
                    (ficlWord *)word->param->p, &(vm->callback));
        break;
        case FICL_WORDKIND_CREATE:
                ficlVmTextOut(vm, "create\n");
        break;
        case FICL_WORDKIND_VARIABLE:
                (void) sprintf(vm->pad, "variable = %ld (%#lx)\n",
                    (long)word->param->i, (long unsigned)word->param->u);
                ficlVmTextOut(vm, vm->pad);
        break;
#if FICL_WANT_USER
        case FICL_WORDKIND_USER:
                (void) sprintf(vm->pad, "user variable %ld (%#lx)\n",
                    (long)word->param->i, (long unsigned)word->param->u);
                ficlVmTextOut(vm, vm->pad);
        break;
#endif
        case FICL_WORDKIND_CONSTANT:
                (void) sprintf(vm->pad, "constant = %ld (%#lx)\n",
                    (long)word->param->i, (long unsigned)word->param->u);
                ficlVmTextOut(vm, vm->pad);
        break;
        case FICL_WORDKIND_2CONSTANT:
                (void) sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n",
                    (long)word->param[1].i, (long)word->param->i,
                    (long unsigned)word->param[1].u,
                    (long unsigned)word->param->u);
                ficlVmTextOut(vm, vm->pad);
        break;

        default:
                (void) sprintf(vm->pad, "%.*s is a primitive\n", word->length,
                    word->name);
                ficlVmTextOut(vm, vm->pad);
        break;
        }

        if (word->flags & FICL_WORD_IMMEDIATE) {
                ficlVmTextOut(vm, "immediate\n");
        }

        if (word->flags & FICL_WORD_COMPILE_ONLY) {
                ficlVmTextOut(vm, "compile-only\n");
        }
}

static void
ficlPrimitiveSee(ficlVm *vm)
{
        ficlPrimitiveTick(vm);
        ficlPrimitiveSeeXT(vm);
}

/*
 * f i c l D e b u g X T
 * debug  ( xt -- )
 * Given an xt of a colon definition or a word defined by DOES>, set the
 * VM up to debug the word: push IP, set the xt as the next thing to execute,
 * set a breakpoint at its first instruction, and run to the breakpoint.
 * Note: the semantics of this word are equivalent to "step in"
 */
static void
ficlPrimitiveDebugXT(ficlVm *vm)
{
        ficlWord *xt = ficlStackPopPointer(vm->dataStack);
        ficlWordKind wk = ficlWordClassify(xt);

        ficlStackPushPointer(vm->dataStack, xt);
        ficlPrimitiveSeeXT(vm);

        switch (wk) {
        case FICL_WORDKIND_COLON:
        case FICL_WORDKIND_DOES:
                /*
                 * Run the colon code and set a breakpoint at the next
                 * instruction
                 */
                ficlVmExecuteWord(vm, xt);
                ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
        break;
        default:
                ficlVmExecuteWord(vm, xt);
        break;
        }
}

/*
 * s t e p I n
 * Ficl
 * Execute the next instruction, stepping into it if it's a colon definition
 * or a does> word. This is the easy kind of step.
 */
static void
ficlPrimitiveStepIn(ficlVm *vm)
{
        /*
         * Do one step of the inner loop
         */
        ficlVmExecuteWord(vm, *vm->ip++);

        /*
         * Now set a breakpoint at the next instruction
         */
        ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
}

/*
 * s t e p O v e r
 * Ficl
 * Execute the next instruction atomically. This requires some insight into
 * the memory layout of compiled code. Set a breakpoint at the next instruction
 * in this word, and run until we hit it
 */
static void
ficlPrimitiveStepOver(ficlVm *vm)
{
        ficlWord *word;
        ficlWordKind kind;
        ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
        FICL_VM_ASSERT(vm, pStep);

        word = *vm->ip;
        kind = ficlWordClassify(word);

        switch (kind) {
        case FICL_WORDKIND_COLON:
        case FICL_WORDKIND_DOES:
                /*
                 * assume that the next ficlCell holds an instruction
                 * set a breakpoint there and return to the inner interpreter
                 */
                vm->callback.system->breakpoint.address = vm->ip + 1;
                vm->callback.system->breakpoint.oldXT =  vm->ip[1];
                vm->ip[1] = pStep;
        break;
        default:
                ficlPrimitiveStepIn(vm);
        break;
        }
}

/*
 * s t e p - b r e a k
 * Ficl
 * Handles breakpoints for stepped execution.
 * Upon entry, breakpoint contains the address and replaced instruction
 * of the current breakpoint.
 * Clear the breakpoint
 * Get a command from the console.
 * i (step in) - execute the current instruction and set a new breakpoint
 *    at the IP
 * o (step over) - execute the current instruction to completion and set
 *    a new breakpoint at the IP
 * g (go) - execute the current instruction and exit
 * q (quit) - abort current word
 * b (toggle breakpoint)
 */

extern char *ficlDictionaryInstructionNames[];

static void
ficlPrimitiveStepBreak(ficlVm *vm)
{
        ficlString command;
        ficlWord *word;
        ficlWord *pOnStep;
        bool debug = true;

        if (!vm->restart) {
                FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address);
                FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT);

                /*
                 * Clear the breakpoint that caused me to run
                 * Restore the original instruction at the breakpoint,
                 * and restore the IP
                 */
                vm->ip = (ficlIp)(vm->callback.system->breakpoint.address);
                *vm->ip = vm->callback.system->breakpoint.oldXT;

                /*
                 * If there's an onStep, do it
                 */
                pOnStep = ficlSystemLookup(vm->callback.system, "on-step");
                if (pOnStep)
                        (void) ficlVmExecuteXT(vm, pOnStep);

                /*
                 * Print the name of the next instruction
                 */
                word = vm->callback.system->breakpoint.oldXT;

                if ((((ficlInstruction)word) > ficlInstructionInvalid) &&
                    (((ficlInstruction)word) < ficlInstructionLast))
                        (void) sprintf(vm->pad, "next: %s (instruction %ld)\n",
                            ficlDictionaryInstructionNames[(long)word],
                            (long)word);
                else {
                        (void) sprintf(vm->pad, "next: %s\n", word->name);
                        if (strcmp(word->name, "interpret") == 0)
                                debug = false;
                }

                ficlVmTextOut(vm, vm->pad);
                ficlDebugPrompt(debug);
        } else {
                vm->restart = 0;
        }

        command = ficlVmGetWord(vm);

        switch (command.text[0]) {
                case 'i':
                        ficlPrimitiveStepIn(vm);
                break;

                case 'o':
                        ficlPrimitiveStepOver(vm);
                break;

                case 'g':
                break;

                case 'l': {
                        ficlWord *xt;
                        xt = ficlDictionaryFindEnclosingWord(
                            ficlVmGetDictionary(vm), (ficlCell *)(vm->ip));
                        if (xt) {
                                ficlStackPushPointer(vm->dataStack, xt);
                                ficlPrimitiveSeeXT(vm);
                        } else {
                                ficlVmTextOut(vm, "sorry - can't do that\n");
                        }
                        ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
                break;
                }

                case 'q':
                        ficlDebugPrompt(false);
                        ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
                        break;
                case 'x': {
                        /*
                         * Take whatever's left in the TIB and feed it to a
                         * subordinate ficlVmExecuteString
                         */
                        int returnValue;
                        ficlString s;
                        ficlWord *oldRunningWord = vm->runningWord;

                        FICL_STRING_SET_POINTER(s,
                            vm->tib.text + vm->tib.index);
                        FICL_STRING_SET_LENGTH(s,
                            vm->tib.end - FICL_STRING_GET_POINTER(s));

                        returnValue = ficlVmExecuteString(vm, s);

                        if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT) {
                                returnValue = FICL_VM_STATUS_RESTART;
                                vm->runningWord = oldRunningWord;
                                ficlVmTextOut(vm, "\n");
                        }
                        if (returnValue == FICL_VM_STATUS_ERROR_EXIT)
                                ficlDebugPrompt(false);

                        ficlVmThrow(vm, returnValue);
                        break;
                }

                default:
                        ficlVmTextOut(vm,
                            "i -- step In\n"
                            "o -- step Over\n"
                            "g -- Go (execute to completion)\n"
                            "l -- List source code\n"
                            "q -- Quit (stop debugging and abort)\n"
                            "x -- eXecute the rest of the line "
                            "as Ficl words\n");
                        ficlDebugPrompt(true);
                        ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
                break;
        }

        ficlDebugPrompt(false);
}

/*
 * b y e
 * TOOLS
 * Signal the system to shut down - this causes ficlExec to return
 * VM_USEREXIT. The rest is up to you.
 */
static void
ficlPrimitiveBye(ficlVm *vm)
{
        ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
}

/*
 * d i s p l a y S t a c k
 * TOOLS
 * Display the parameter stack (code for ".s")
 */

struct stackContext
{
        ficlVm *vm;
        ficlDictionary *dictionary;
        int count;
};

static ficlInteger
ficlStackDisplayCallback(void *c, ficlCell *cell)
{
        struct stackContext *context = (struct stackContext *)c;
        char buffer[80];

#ifdef _LP64
        (void) snprintf(buffer, sizeof (buffer),
            "[0x%016lx %3d]: %20ld (0x%016lx)\n",
            (unsigned long)cell, context->count++, (long)cell->i,
            (unsigned long)cell->u);
#else
        (void) snprintf(buffer, sizeof (buffer),
            "[0x%08x %3d]: %12d (0x%08x)\n",
            (unsigned)cell, context->count++, cell->i, cell->u);
#endif

        ficlVmTextOut(context->vm, buffer);
        return (FICL_TRUE);
}

void
ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback,
    void *context)
{
        ficlVm *vm = stack->vm;
        char buffer[128];
        struct stackContext myContext;

        FICL_STACK_CHECK(stack, 0, 0);

#ifdef _LP64
        (void) sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n",
            stack->name, ficlStackDepth(stack), (unsigned long)stack->top);
#else
        (void) sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n",
            stack->name, ficlStackDepth(stack), (unsigned)stack->top);
#endif
        ficlVmTextOut(vm, buffer);

        if (callback == NULL) {
                myContext.vm = vm;
                myContext.count = 0;
                context = &myContext;
                callback = ficlStackDisplayCallback;
        }
        ficlStackWalk(stack, callback, context, FICL_FALSE);

#ifdef _LP64
        (void) sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name,
            (unsigned long)stack->base);
#else
        (void) sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name,
            (unsigned)stack->base);
#endif
        ficlVmTextOut(vm, buffer);
}

void
ficlVmDisplayDataStack(ficlVm *vm)
{
        ficlStackDisplay(vm->dataStack, NULL, NULL);
}

static ficlInteger
ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
{
        struct stackContext *context = (struct stackContext *)c;
        char buffer[32];

        (void) sprintf(buffer, "%s%ld", context->count ? " " : "",
            (long)cell->i);
        context->count++;
        ficlVmTextOut(context->vm, buffer);
        return (FICL_TRUE);
}

void
ficlVmDisplayDataStackSimple(ficlVm *vm)
{
        ficlStack *stack = vm->dataStack;
        char buffer[32];
        struct stackContext context;

        FICL_STACK_CHECK(stack, 0, 0);

        (void) sprintf(buffer, "[%d] ", ficlStackDepth(stack));
        ficlVmTextOut(vm, buffer);

        context.vm = vm;
        context.count = 0;
        ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context,
            FICL_TRUE);
}

static ficlInteger
ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
{
        struct stackContext *context = (struct stackContext *)c;
        char buffer[128];

#ifdef _LP64
        (void) sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)",
            (unsigned long)cell, context->count++, cell->i, cell->u);
#else
        (void) sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell,
            context->count++, cell->i, cell->u);
#endif

        /*
         * Attempt to find the word that contains the return
         * stack address (as if it is part of a colon definition).
         * If this works, also print the name of the word.
         */
        if (ficlDictionaryIncludes(context->dictionary, cell->p)) {
                ficlWord *word;
                word = ficlDictionaryFindEnclosingWord(context->dictionary,
                    cell->p);
                if (word) {
                        int offset = (ficlCell *)cell->p - &word->param[0];
                        (void) sprintf(buffer + strlen(buffer), ", %s + %d ",
                            word->name, offset);
                }
        }
        (void) strcat(buffer, "\n");
        ficlVmTextOut(context->vm, buffer);
        return (FICL_TRUE);
}

void
ficlVmDisplayReturnStack(ficlVm *vm)
{
        struct stackContext context;
        context.vm = vm;
        context.count = 0;
        context.dictionary = ficlVmGetDictionary(vm);
        ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback,
            &context);
}

/*
 * f o r g e t - w i d
 */
static void
ficlPrimitiveForgetWid(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlHash *hash;

        hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
        ficlHashForget(hash, dictionary->here);
}

/*
 * f o r g e t
 * TOOLS EXT  ( "<spaces>name" -- )
 * Skip leading space delimiters. Parse name delimited by a space.
 * Find name, then delete name from the dictionary along with all
 * words added to the dictionary after name. An ambiguous
 * condition exists if name cannot be found.
 *
 * If the Search-Order word set is present, FORGET searches the
 * compilation word list. An ambiguous condition exists if the
 * compilation word list is deleted.
 */
static void
ficlPrimitiveForget(ficlVm *vm)
{
        void *where;
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlHash *hash = dictionary->compilationWordlist;

        ficlPrimitiveTick(vm);
        where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
        ficlHashForget(hash, where);
        dictionary->here = FICL_POINTER_TO_CELL(where);
}

/*
 * w o r d s
 */
#define nCOLWIDTH       8

static void
ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary,
    ficlHash *hash, char *ss)
{
        ficlWord *wp;
        int nChars = 0;
        int len;
        unsigned i;
        int nWords = 0, dWords = 0;
        char *cp;
        char *pPad;
        int columns;

        cp = getenv("screen-#cols");
        /*
         * using strtol for now. TODO: refactor number conversion from
         * ficlPrimitiveToNumber() and use it instead.
         */
        if (cp == NULL)
                columns = 80;
        else
                columns = strtol(cp, NULL, 0);

        /*
         * the pad is fixed size area, it's better to allocate
         * dedicated buffer space to deal with custom terminal sizes.
         */
        pPad = malloc(columns + 1);
        if (pPad == NULL)
                ficlVmThrowError(vm, "Error: out of memory");

        pager_open();
        for (i = 0; i < hash->size; i++) {
                for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) {
                        if (wp->length == 0) /* ignore :noname defs */
                                continue;

                        if (ss != NULL && strstr(wp->name, ss) == NULL)
                                continue;
                        if (ss != NULL && dWords == 0) {
                                (void) sprintf(pPad,
                                    "        In vocabulary %s\n",
                                    hash->name ? hash->name : "<unknown>");
                                (void) pager_output(pPad);
                        }
                        dWords++;

                        /* prevent line wrap due to long words */
                        if (nChars + wp->length >= columns) {
                                pPad[nChars++] = '\n';
                                pPad[nChars] = '\0';
                                nChars = 0;
                                if (pager_output(pPad))
                                        goto pager_done;
                        }

                        cp = wp->name;
                        nChars += sprintf(pPad + nChars, "%s", cp);

                        if (nChars > columns - 10) {
                                pPad[nChars++] = '\n';
                                pPad[nChars] = '\0';
                                nChars = 0;
                                if (pager_output(pPad))
                                        goto pager_done;
                        } else {
                                len = nCOLWIDTH - nChars % nCOLWIDTH;
                                while (len-- > 0)
                                        pPad[nChars++] = ' ';
                        }

                        if (nChars > columns - 10) {
                                pPad[nChars++] = '\n';
                                pPad[nChars] = '\0';
                                nChars = 0;
                                if (pager_output(pPad))
                                        goto pager_done;
                        }
                }
        }

        if (nChars > 0) {
                pPad[nChars++] = '\n';
                pPad[nChars] = '\0';
                nChars = 0;
                ficlVmTextOut(vm, pPad);
        }

        if (ss == NULL) {
                (void) sprintf(pPad,
                    "Dictionary: %d words, %ld cells used of %u total\n",
                    nWords, (long)(dictionary->here - dictionary->base),
                    dictionary->size);
                (void) pager_output(pPad);
        }

pager_done:
        free(pPad);
        pager_close();
}

static void
ficlPrimitiveWords(ficlVm *vm)
{
        ficlDictionary *dictionary = ficlVmGetDictionary(vm);
        ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
        ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL);
}

void
ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss)
{
        ficlDictionary *dict = ficlVmGetDictionary(vm);
        int i;

        for (i = 0; i < dict->wordlistCount; i++)
                ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss);
}

/*
 * l i s t E n v
 * Print symbols defined in the environment
 */
static void
ficlPrimitiveListEnv(ficlVm *vm)
{
        ficlDictionary *dictionary = vm->callback.system->environment;
        ficlHash *hash = dictionary->forthWordlist;
        ficlWord *word;
        unsigned i;
        int counter = 0;

        pager_open();
        for (i = 0; i < hash->size; i++) {
                for (word = hash->table[i]; word != NULL;
                    word = word->link, counter++) {
                        (void) sprintf(vm->pad, "%s\n", word->name);
                        if (pager_output(vm->pad))
                                goto pager_done;
                }
        }

        (void) sprintf(vm->pad,
            "Environment: %d words, %ld cells used of %u total\n",
            counter, (long)(dictionary->here - dictionary->base),
            dictionary->size);
        (void) pager_output(vm->pad);

pager_done:
        pager_close();
}

/*
 * This word lists the parse steps in order
 */
void
ficlPrimitiveParseStepList(ficlVm *vm)
{
        int i;
        ficlSystem *system = vm->callback.system;
        FICL_VM_ASSERT(vm, system);

        ficlVmTextOut(vm, "Parse steps:\n");
        ficlVmTextOut(vm, "lookup\n");

        for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) {
                if (system->parseList[i] != NULL) {
                        ficlVmTextOut(vm, system->parseList[i]->name);
                        ficlVmTextOut(vm, "\n");
                } else
                        break;
        }
}

/*
 * e n v C o n s t a n t
 * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl
 * code to set environment constants...
 */
static void
ficlPrimitiveEnvConstant(ficlVm *vm)
{
        unsigned value;
        FICL_STACK_CHECK(vm->dataStack, 1, 0);

        (void) ficlVmGetWordToPad(vm);
        value = ficlStackPopUnsigned(vm->dataStack);
        (void) ficlDictionarySetConstant(
            ficlSystemGetEnvironment(vm->callback.system),
            vm->pad, (ficlUnsigned)value);
}

static void
ficlPrimitiveEnv2Constant(ficlVm *vm)
{
        ficl2Integer value;

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

        (void) ficlVmGetWordToPad(vm);
        value = ficlStackPop2Integer(vm->dataStack);
        (void) ficlDictionarySet2Constant(
            ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
}


/*
 * f i c l C o m p i l e T o o l s
 * Builds wordset for debugger and TOOLS optional word set
 */
void
ficlSystemCompileTools(ficlSystem *system)
{
        ficlDictionary *dictionary = ficlSystemGetDictionary(system);
        ficlDictionary *environment = ficlSystemGetEnvironment(system);

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


        /*
         * TOOLS and TOOLS EXT
         */
        (void) ficlDictionarySetPrimitive(dictionary, ".s",
            ficlVmDisplayDataStack, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, ".s-simple",
            ficlVmDisplayDataStackSimple,  FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye,
            FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "forget",
            ficlPrimitiveForget, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee,
            FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "words",
            ficlPrimitiveWords, FICL_WORD_DEFAULT);

        /*
         * Set TOOLS environment query values
         */
        (void) ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
        (void) ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);

        /*
         * Ficl extras
         */
        (void) ficlDictionarySetPrimitive(dictionary, "r.s",
            ficlVmDisplayReturnStack, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, ".env",
            ficlPrimitiveListEnv, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "env-constant",
            ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "env-2constant",
            ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "debug-xt",
            ficlPrimitiveDebugXT, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "parse-order",
            ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "step-break",
            ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "forget-wid",
            ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "see-xt",
            ficlPrimitiveSeeXT, FICL_WORD_DEFAULT);

#if FICL_WANT_FLOAT
        (void) ficlDictionarySetPrimitive(dictionary, ".hash",
            ficlPrimitiveHashSummary, FICL_WORD_DEFAULT);
#endif
}