common/ficl/tools.c

/*
 * 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 "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];
		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(ficlVm *vm, int debug)
{
	if (debug)
		setenv("prompt", "dbg> ", 1);
	else
		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;

	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:
		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:
		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:
		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:
		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:
		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:
		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;
	int debug = 1;

	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)
			ficlVmExecuteXT(vm, pOnStep);

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

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

		ficlVmTextOut(vm, vm->pad);
		ficlDebugPrompt(vm, 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(vm, 0);
			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(vm, 0);

			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(vm, 1);
			ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
		break;
	}

	ficlDebugPrompt(vm, 0);
}

/*
 * 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
	snprintf(buffer, sizeof (buffer), "[0x%016lx %3d]: %20ld (0x%016lx)\n",
	    (unsigned long)cell, context->count++, (long)cell->i,
	    (unsigned long)cell->u);
#else
	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
	sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n",
	    stack->name, ficlStackDepth(stack), (unsigned long)stack->top);
#else
	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
	sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name,
	    (unsigned long)stack->base);
#else
	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];

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

	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
	sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)", (unsigned long)cell,
	    context->count++, cell->i, cell->u);
#else
	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];
			sprintf(buffer + strlen(buffer), ", %s + %d ",
			    word->name, offset);
		}
	}
	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) {
				sprintf(pPad, "        In vocabulary %s\n",
				    hash->name ? hash->name : "<unknown>");
				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) {
		sprintf(pPad,
		    "Dictionary: %d words, %ld cells used of %u total\n",
		    nWords, (long)(dictionary->here - dictionary->base),
		    dictionary->size);
		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++) {
			sprintf(vm->pad, "%s\n", word->name);
			if (pager_output(vm->pad))
				goto pager_done;
		}
	}

	sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n",
	    counter, (long)(dictionary->here - dictionary->base),
	    dictionary->size);
	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);

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

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

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

	ficlVmGetWordToPad(vm);
	value = ficlStackPop2Integer(vm->dataStack);
	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
	 */
	ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack,
	    FICL_WORD_DEFAULT);
	ficlDictionarySetPrimitive(dictionary, ".s-simple",
	    ficlVmDisplayDataStackSimple,  FICL_WORD_DEFAULT);
	ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye,
	    FICL_WORD_DEFAULT);
	ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget,
	    FICL_WORD_DEFAULT);
	ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee,
	    FICL_WORD_DEFAULT);
	ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords,
	    FICL_WORD_DEFAULT);

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

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

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