/* * 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 #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 ( "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 : ""); (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 }