ref: 67757267d0b9c6b15a0f9a87abab74ab152d9b09
dir: 9ficl/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.16 2010/12/02 22:14:12 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 <stdlib.h>
#include <stdint.h>
#include <stdio.h> /* sprintf */
#include <string.h>
#include <ctype.h>
#include "ficl.h"
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)
{
ficlVmTextOut(vm, "dbg> ");
}
#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);
return;
}
#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", word->param->i, word->param->u);
ficlVmTextOut(vm, vm->pad);
break;
#if FICL_WANT_USER
case FICL_WORDKIND_USER:
sprintf(vm->pad, "user variable %ld (%#lx)\n", word->param->i, word->param->u);
ficlVmTextOut(vm, vm->pad);
break;
#endif
case FICL_WORDKIND_CONSTANT:
sprintf(vm->pad, "constant = %ld (%#lx)\n", word->param->i, word->param->u);
ficlVmTextOut(vm, vm->pad);
break;
case FICL_WORDKIND_2CONSTANT:
sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n", word->param[1].i, word->param->i, word->param[1].u, 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");
}
return;
}
static void ficlPrimitiveSee(ficlVm *vm)
{
ficlPrimitiveTick(vm);
ficlPrimitiveSeeXT(vm);
return;
}
/**************************************************************************
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 = (ficlWord*)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;
}
return;
}
/**************************************************************************
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));
return;
}
/**************************************************************************
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;
}
return;
}
/**************************************************************************
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;
ficlWordKind kind;
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;
kind = ficlWordClassify(word);
switch (kind)
{
case FICL_WORDKIND_INSTRUCTION:
case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
sprintf(vm->pad, "next: %s (instruction %ld)\n", ficlDictionaryInstructionNames[(long)word], (long)word);
break;
default:
sprintf(vm->pad, "next: %s\n", word->name);
break;
}
ficlVmTextOut(vm, vm->pad);
ficlDebugPrompt(vm);
}
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':
{
ficlVmTextOut(vm, FICL_PROMPT);
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");
}
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);
ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
break;
}
}
return;
}
/**************************************************************************
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);
return;
}
/**************************************************************************
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[64];
sprintf(buffer, "[0x%08jx %3d]: %12jd (0x%08jx)\n", (uintmax_t)cell, context->count++, (intmax_t)cell->i, (uintmax_t)cell->i);
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);
sprintf(buffer, "[%s stack has %d entries, top at 0x%08jx]\n", stack->name, ficlStackDepth(stack), (uintmax_t)stack->top);
ficlVmTextOut(vm, buffer);
if (callback == NULL)
{
myContext.vm = vm;
myContext.count = 0;
context = &myContext;
callback = ficlStackDisplayCallback;
}
ficlStackWalk(stack, callback, context, FICL_FALSE);
sprintf(buffer, "[%s stack base at 0x%08jx]\n", stack->name, (uintmax_t)stack->base);
ficlVmTextOut(vm, buffer);
return;
}
void ficlVmDisplayDataStack(ficlVm *vm)
{
ficlStackDisplay(vm->dataStack, NULL, NULL);
return;
}
static ficlInteger ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
{
struct stackContext *context = (struct stackContext *)c;
char buffer[32];
sprintf(buffer, "%s%jd", context->count ? " " : "", (intmax_t)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);
return;
}
static ficlInteger ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
{
struct stackContext *context = (struct stackContext *)c;
char buffer[128];
sprintf(buffer, "[0x%08jx %3d] %12jd (0x%08jx)", (uintmax_t)cell, context->count++, (intmax_t)cell->i, (uintmax_t)cell->i);
/*
** 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 = ficlDictionaryFindEnclosingWord(context->dictionary, (ficlCell*)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);
return;
}
/**************************************************************************
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);
return;
}
/**************************************************************************
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);
return;
}
/**************************************************************************
w o r d s
**
**************************************************************************/
#define nCOLWIDTH 8
static void ficlPrimitiveWords(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
ficlWord *wp;
int nChars = 0;
int len;
unsigned i;
int nWords = 0;
char *cp;
char *pPad = vm->pad;
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;
cp = wp->name;
nChars += sprintf(pPad + nChars, "%s", cp);
if (nChars > 70)
{
pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
ficlVmTextOut(vm, pPad);
}
else
{
len = nCOLWIDTH - nChars % nCOLWIDTH;
while (len-- > 0)
pPad[nChars++] = ' ';
}
if (nChars > 70)
{
pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
ficlVmTextOut(vm, pPad);
}
}
}
if (nChars > 0)
{
pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
ficlVmTextOut(vm, pPad);
}
sprintf(vm->pad, "Dictionary: %d words, %ld cells used of %u total\n",
nWords, (long) (dictionary->here - dictionary->base), dictionary->size);
ficlVmTextOut(vm, vm->pad);
return;
}
/**************************************************************************
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;
for (i = 0; i < hash->size; i++)
{
for (word = hash->table[i]; word != NULL; word = word->link, counter++)
{
ficlVmTextOut(vm, word->name);
ficlVmTextOut(vm, "\n");
}
}
sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n",
counter, (long) (dictionary->here - dictionary->base), dictionary->size);
ficlVmTextOut(vm, vm->pad);
return;
}
/*
** 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;
}
return;
}
/**************************************************************************
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);
return;
}
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);
return;
}
/**************************************************************************
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
return;
}