1afc2ba1dSToomas Soome /* 2afc2ba1dSToomas Soome * t o o l s . c 3afc2ba1dSToomas Soome * Forth Inspired Command Language - programming tools 4afc2ba1dSToomas Soome * Author: John Sadler (john_sadler@alum.mit.edu) 5afc2ba1dSToomas Soome * Created: 20 June 2000 6afc2ba1dSToomas Soome * $Id: tools.c,v 1.12 2010/08/12 13:57:22 asau Exp $ 7afc2ba1dSToomas Soome */ 8afc2ba1dSToomas Soome /* 9afc2ba1dSToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 10afc2ba1dSToomas Soome * All rights reserved. 11afc2ba1dSToomas Soome * 12afc2ba1dSToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net 13afc2ba1dSToomas Soome * 14afc2ba1dSToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have 15afc2ba1dSToomas Soome * a problem, a success story, a defect, an enhancement request, or 16afc2ba1dSToomas Soome * if you would like to contribute to the Ficl release, please 17afc2ba1dSToomas Soome * contact me by email at the address above. 18afc2ba1dSToomas Soome * 19afc2ba1dSToomas Soome * L I C E N S E and D I S C L A I M E R 20afc2ba1dSToomas Soome * 21afc2ba1dSToomas Soome * Redistribution and use in source and binary forms, with or without 22afc2ba1dSToomas Soome * modification, are permitted provided that the following conditions 23afc2ba1dSToomas Soome * are met: 24afc2ba1dSToomas Soome * 1. Redistributions of source code must retain the above copyright 25afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer. 26afc2ba1dSToomas Soome * 2. Redistributions in binary form must reproduce the above copyright 27afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer in the 28afc2ba1dSToomas Soome * documentation and/or other materials provided with the distribution. 29afc2ba1dSToomas Soome * 30afc2ba1dSToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 31afc2ba1dSToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 32afc2ba1dSToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 33afc2ba1dSToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 34afc2ba1dSToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 35afc2ba1dSToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 36afc2ba1dSToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 37afc2ba1dSToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 38afc2ba1dSToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 39afc2ba1dSToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 40afc2ba1dSToomas Soome * SUCH DAMAGE. 41afc2ba1dSToomas Soome */ 42afc2ba1dSToomas Soome 43afc2ba1dSToomas Soome /* 44afc2ba1dSToomas Soome * NOTES: 45afc2ba1dSToomas Soome * SEE needs information about the addresses of functions that 46afc2ba1dSToomas Soome * are the CFAs of colon definitions, constants, variables, DOES> 47afc2ba1dSToomas Soome * words, and so on. It gets this information from a table and supporting 48afc2ba1dSToomas Soome * functions in words.c. 49afc2ba1dSToomas Soome * fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen 50afc2ba1dSToomas Soome * 51afc2ba1dSToomas Soome * Step and break debugger for Ficl 52afc2ba1dSToomas Soome * debug ( xt -- ) Start debugging an xt 53afc2ba1dSToomas Soome * Set a breakpoint 54afc2ba1dSToomas Soome * Specify breakpoint default action 55afc2ba1dSToomas Soome */ 56afc2ba1dSToomas Soome 57*1fb83a8fSToomas Soome #include <stdbool.h> 58afc2ba1dSToomas Soome #include "ficl.h" 59afc2ba1dSToomas Soome 60afc2ba1dSToomas Soome extern void exit(int); 61afc2ba1dSToomas Soome 62afc2ba1dSToomas Soome static void ficlPrimitiveStepIn(ficlVm *vm); 63afc2ba1dSToomas Soome static void ficlPrimitiveStepOver(ficlVm *vm); 64afc2ba1dSToomas Soome static void ficlPrimitiveStepBreak(ficlVm *vm); 65afc2ba1dSToomas Soome 66afc2ba1dSToomas Soome void 67afc2ba1dSToomas Soome ficlCallbackAssert(ficlCallback *callback, int expression, 68afc2ba1dSToomas Soome char *expressionString, char *filename, int line) 69afc2ba1dSToomas Soome { 70afc2ba1dSToomas Soome #if FICL_ROBUST >= 1 71afc2ba1dSToomas Soome if (!expression) { 72afc2ba1dSToomas Soome static char buffer[256]; 73afc2ba1dSToomas Soome sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n", 74afc2ba1dSToomas Soome filename, line, expressionString); 75afc2ba1dSToomas Soome ficlCallbackTextOut(callback, buffer); 76afc2ba1dSToomas Soome exit(-1); 77afc2ba1dSToomas Soome } 78afc2ba1dSToomas Soome #else /* FICL_ROBUST >= 1 */ 79afc2ba1dSToomas Soome FICL_IGNORE(callback); 80afc2ba1dSToomas Soome FICL_IGNORE(expression); 81afc2ba1dSToomas Soome FICL_IGNORE(expressionString); 82afc2ba1dSToomas Soome FICL_IGNORE(filename); 83afc2ba1dSToomas Soome FICL_IGNORE(line); 84afc2ba1dSToomas Soome #endif /* FICL_ROBUST >= 1 */ 85afc2ba1dSToomas Soome } 86afc2ba1dSToomas Soome 87afc2ba1dSToomas Soome /* 88afc2ba1dSToomas Soome * v m S e t B r e a k 89afc2ba1dSToomas Soome * Set a breakpoint at the current value of IP by 90afc2ba1dSToomas Soome * storing that address in a BREAKPOINT record 91afc2ba1dSToomas Soome */ 92afc2ba1dSToomas Soome static void 93afc2ba1dSToomas Soome ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP) 94afc2ba1dSToomas Soome { 95afc2ba1dSToomas Soome ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break"); 96afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, pStep); 97afc2ba1dSToomas Soome 98afc2ba1dSToomas Soome pBP->address = vm->ip; 99afc2ba1dSToomas Soome pBP->oldXT = *vm->ip; 100afc2ba1dSToomas Soome *vm->ip = pStep; 101afc2ba1dSToomas Soome } 102afc2ba1dSToomas Soome 103afc2ba1dSToomas Soome /* 104afc2ba1dSToomas Soome * d e b u g P r o m p t 105afc2ba1dSToomas Soome */ 106afc2ba1dSToomas Soome static void 107*1fb83a8fSToomas Soome ficlDebugPrompt(bool debug) 108afc2ba1dSToomas Soome { 109afc2ba1dSToomas Soome if (debug) 110afc2ba1dSToomas Soome setenv("prompt", "dbg> ", 1); 111afc2ba1dSToomas Soome else 112afc2ba1dSToomas Soome setenv("prompt", "${interpret}", 1); 113afc2ba1dSToomas Soome } 114afc2ba1dSToomas Soome 115afc2ba1dSToomas Soome #if 0 116afc2ba1dSToomas Soome static int 117afc2ba1dSToomas Soome isPrimitive(ficlWord *word) 118afc2ba1dSToomas Soome { 119afc2ba1dSToomas Soome ficlWordKind wk = ficlWordClassify(word); 120afc2ba1dSToomas Soome return ((wk != COLON) && (wk != DOES)); 121afc2ba1dSToomas Soome } 122afc2ba1dSToomas Soome #endif 123afc2ba1dSToomas Soome 124afc2ba1dSToomas Soome /* 125afc2ba1dSToomas Soome * d i c t H a s h S u m m a r y 126afc2ba1dSToomas Soome * Calculate a figure of merit for the dictionary hash table based 127afc2ba1dSToomas Soome * on the average search depth for all the words in the dictionary, 128afc2ba1dSToomas Soome * assuming uniform distribution of target keys. The figure of merit 129afc2ba1dSToomas Soome * is the ratio of the total search depth for all keys in the table 130afc2ba1dSToomas Soome * versus a theoretical optimum that would be achieved if the keys 131afc2ba1dSToomas Soome * were distributed into the table as evenly as possible. 132afc2ba1dSToomas Soome * The figure would be worse if the hash table used an open 133afc2ba1dSToomas Soome * addressing scheme (i.e. collisions resolved by searching the 134afc2ba1dSToomas Soome * table for an empty slot) for a given size table. 135afc2ba1dSToomas Soome */ 136afc2ba1dSToomas Soome #if FICL_WANT_FLOAT 137afc2ba1dSToomas Soome void 138afc2ba1dSToomas Soome ficlPrimitiveHashSummary(ficlVm *vm) 139afc2ba1dSToomas Soome { 140afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 141afc2ba1dSToomas Soome ficlHash *pFHash; 142afc2ba1dSToomas Soome ficlWord **hash; 143afc2ba1dSToomas Soome unsigned size; 144afc2ba1dSToomas Soome ficlWord *word; 145afc2ba1dSToomas Soome unsigned i; 146afc2ba1dSToomas Soome int nMax = 0; 147afc2ba1dSToomas Soome int nWords = 0; 148afc2ba1dSToomas Soome int nFilled; 149afc2ba1dSToomas Soome double avg = 0.0; 150afc2ba1dSToomas Soome double best; 151afc2ba1dSToomas Soome int nAvg, nRem, nDepth; 152afc2ba1dSToomas Soome 153afc2ba1dSToomas Soome FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0); 154afc2ba1dSToomas Soome 155afc2ba1dSToomas Soome pFHash = dictionary->wordlists[dictionary->wordlistCount - 1]; 156afc2ba1dSToomas Soome hash = pFHash->table; 157afc2ba1dSToomas Soome size = pFHash->size; 158afc2ba1dSToomas Soome nFilled = size; 159afc2ba1dSToomas Soome 160afc2ba1dSToomas Soome for (i = 0; i < size; i++) { 161afc2ba1dSToomas Soome int n = 0; 162afc2ba1dSToomas Soome word = hash[i]; 163afc2ba1dSToomas Soome 164afc2ba1dSToomas Soome while (word) { 165afc2ba1dSToomas Soome ++n; 166afc2ba1dSToomas Soome ++nWords; 167afc2ba1dSToomas Soome word = word->link; 168afc2ba1dSToomas Soome } 169afc2ba1dSToomas Soome 170afc2ba1dSToomas Soome avg += (double)(n * (n+1)) / 2.0; 171afc2ba1dSToomas Soome 172afc2ba1dSToomas Soome if (n > nMax) 173afc2ba1dSToomas Soome nMax = n; 174afc2ba1dSToomas Soome if (n == 0) 175afc2ba1dSToomas Soome --nFilled; 176afc2ba1dSToomas Soome } 177afc2ba1dSToomas Soome 178afc2ba1dSToomas Soome /* Calc actual avg search depth for this hash */ 179afc2ba1dSToomas Soome avg = avg / nWords; 180afc2ba1dSToomas Soome 181afc2ba1dSToomas Soome /* Calc best possible performance with this size hash */ 182afc2ba1dSToomas Soome nAvg = nWords / size; 183afc2ba1dSToomas Soome nRem = nWords % size; 184afc2ba1dSToomas Soome nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem; 185afc2ba1dSToomas Soome best = (double)nDepth/nWords; 186afc2ba1dSToomas Soome 187afc2ba1dSToomas Soome sprintf(vm->pad, "%d bins, %2.0f%% filled, Depth: " 188afc2ba1dSToomas Soome "Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n", 189afc2ba1dSToomas Soome size, (double)nFilled * 100.0 / size, nMax, 190afc2ba1dSToomas Soome avg, best, 100.0 * best / avg); 191afc2ba1dSToomas Soome 192afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 193afc2ba1dSToomas Soome } 194afc2ba1dSToomas Soome #endif 195afc2ba1dSToomas Soome 196afc2ba1dSToomas Soome /* 197afc2ba1dSToomas Soome * Here's the outer part of the decompiler. It's 198afc2ba1dSToomas Soome * just a big nested conditional that checks the 199afc2ba1dSToomas Soome * CFA of the word to decompile for each kind of 200afc2ba1dSToomas Soome * known word-builder code, and tries to do 201afc2ba1dSToomas Soome * something appropriate. If the CFA is not recognized, 202afc2ba1dSToomas Soome * just indicate that it is a primitive. 203afc2ba1dSToomas Soome */ 204afc2ba1dSToomas Soome static void 205afc2ba1dSToomas Soome ficlPrimitiveSeeXT(ficlVm *vm) 206afc2ba1dSToomas Soome { 207afc2ba1dSToomas Soome ficlWord *word; 208afc2ba1dSToomas Soome ficlWordKind kind; 209afc2ba1dSToomas Soome 210afc2ba1dSToomas Soome word = (ficlWord *)ficlStackPopPointer(vm->dataStack); 211afc2ba1dSToomas Soome kind = ficlWordClassify(word); 212afc2ba1dSToomas Soome 213afc2ba1dSToomas Soome switch (kind) { 214afc2ba1dSToomas Soome case FICL_WORDKIND_COLON: 215afc2ba1dSToomas Soome sprintf(vm->pad, ": %.*s\n", word->length, word->name); 216afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 217afc2ba1dSToomas Soome ficlDictionarySee(ficlVmGetDictionary(vm), word, 218afc2ba1dSToomas Soome &(vm->callback)); 219afc2ba1dSToomas Soome break; 220afc2ba1dSToomas Soome case FICL_WORDKIND_DOES: 221afc2ba1dSToomas Soome ficlVmTextOut(vm, "does>\n"); 222afc2ba1dSToomas Soome ficlDictionarySee(ficlVmGetDictionary(vm), 223afc2ba1dSToomas Soome (ficlWord *)word->param->p, &(vm->callback)); 224afc2ba1dSToomas Soome break; 225afc2ba1dSToomas Soome case FICL_WORDKIND_CREATE: 226afc2ba1dSToomas Soome ficlVmTextOut(vm, "create\n"); 227afc2ba1dSToomas Soome break; 228afc2ba1dSToomas Soome case FICL_WORDKIND_VARIABLE: 229afc2ba1dSToomas Soome sprintf(vm->pad, "variable = %ld (%#lx)\n", 230afc2ba1dSToomas Soome (long)word->param->i, (long unsigned)word->param->u); 231afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 232afc2ba1dSToomas Soome break; 233afc2ba1dSToomas Soome #if FICL_WANT_USER 234afc2ba1dSToomas Soome case FICL_WORDKIND_USER: 235afc2ba1dSToomas Soome sprintf(vm->pad, "user variable %ld (%#lx)\n", 236afc2ba1dSToomas Soome (long)word->param->i, (long unsigned)word->param->u); 237afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 238afc2ba1dSToomas Soome break; 239afc2ba1dSToomas Soome #endif 240afc2ba1dSToomas Soome case FICL_WORDKIND_CONSTANT: 241afc2ba1dSToomas Soome sprintf(vm->pad, "constant = %ld (%#lx)\n", 242afc2ba1dSToomas Soome (long)word->param->i, (long unsigned)word->param->u); 243afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 244afc2ba1dSToomas Soome break; 245afc2ba1dSToomas Soome case FICL_WORDKIND_2CONSTANT: 246afc2ba1dSToomas Soome sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n", 247afc2ba1dSToomas Soome (long)word->param[1].i, (long)word->param->i, 248afc2ba1dSToomas Soome (long unsigned)word->param[1].u, 249afc2ba1dSToomas Soome (long unsigned)word->param->u); 250afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 251afc2ba1dSToomas Soome break; 252afc2ba1dSToomas Soome 253afc2ba1dSToomas Soome default: 254afc2ba1dSToomas Soome sprintf(vm->pad, "%.*s is a primitive\n", word->length, 255afc2ba1dSToomas Soome word->name); 256afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 257afc2ba1dSToomas Soome break; 258afc2ba1dSToomas Soome } 259afc2ba1dSToomas Soome 260afc2ba1dSToomas Soome if (word->flags & FICL_WORD_IMMEDIATE) { 261afc2ba1dSToomas Soome ficlVmTextOut(vm, "immediate\n"); 262afc2ba1dSToomas Soome } 263afc2ba1dSToomas Soome 264afc2ba1dSToomas Soome if (word->flags & FICL_WORD_COMPILE_ONLY) { 265afc2ba1dSToomas Soome ficlVmTextOut(vm, "compile-only\n"); 266afc2ba1dSToomas Soome } 267afc2ba1dSToomas Soome } 268afc2ba1dSToomas Soome 269afc2ba1dSToomas Soome static void 270afc2ba1dSToomas Soome ficlPrimitiveSee(ficlVm *vm) 271afc2ba1dSToomas Soome { 272afc2ba1dSToomas Soome ficlPrimitiveTick(vm); 273afc2ba1dSToomas Soome ficlPrimitiveSeeXT(vm); 274afc2ba1dSToomas Soome } 275afc2ba1dSToomas Soome 276afc2ba1dSToomas Soome /* 277afc2ba1dSToomas Soome * f i c l D e b u g X T 278afc2ba1dSToomas Soome * debug ( xt -- ) 279afc2ba1dSToomas Soome * Given an xt of a colon definition or a word defined by DOES>, set the 280afc2ba1dSToomas Soome * VM up to debug the word: push IP, set the xt as the next thing to execute, 281afc2ba1dSToomas Soome * set a breakpoint at its first instruction, and run to the breakpoint. 282afc2ba1dSToomas Soome * Note: the semantics of this word are equivalent to "step in" 283afc2ba1dSToomas Soome */ 284afc2ba1dSToomas Soome static void 285afc2ba1dSToomas Soome ficlPrimitiveDebugXT(ficlVm *vm) 286afc2ba1dSToomas Soome { 287afc2ba1dSToomas Soome ficlWord *xt = ficlStackPopPointer(vm->dataStack); 288afc2ba1dSToomas Soome ficlWordKind wk = ficlWordClassify(xt); 289afc2ba1dSToomas Soome 290afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, xt); 291afc2ba1dSToomas Soome ficlPrimitiveSeeXT(vm); 292afc2ba1dSToomas Soome 293afc2ba1dSToomas Soome switch (wk) { 294afc2ba1dSToomas Soome case FICL_WORDKIND_COLON: 295afc2ba1dSToomas Soome case FICL_WORDKIND_DOES: 296afc2ba1dSToomas Soome /* 297afc2ba1dSToomas Soome * Run the colon code and set a breakpoint at the next 298afc2ba1dSToomas Soome * instruction 299afc2ba1dSToomas Soome */ 300afc2ba1dSToomas Soome ficlVmExecuteWord(vm, xt); 301afc2ba1dSToomas Soome ficlVmSetBreak(vm, &(vm->callback.system->breakpoint)); 302afc2ba1dSToomas Soome break; 303afc2ba1dSToomas Soome default: 304afc2ba1dSToomas Soome ficlVmExecuteWord(vm, xt); 305afc2ba1dSToomas Soome break; 306afc2ba1dSToomas Soome } 307afc2ba1dSToomas Soome } 308afc2ba1dSToomas Soome 309afc2ba1dSToomas Soome /* 310afc2ba1dSToomas Soome * s t e p I n 311afc2ba1dSToomas Soome * Ficl 312afc2ba1dSToomas Soome * Execute the next instruction, stepping into it if it's a colon definition 313afc2ba1dSToomas Soome * or a does> word. This is the easy kind of step. 314afc2ba1dSToomas Soome */ 315afc2ba1dSToomas Soome static void 316afc2ba1dSToomas Soome ficlPrimitiveStepIn(ficlVm *vm) 317afc2ba1dSToomas Soome { 318afc2ba1dSToomas Soome /* 319afc2ba1dSToomas Soome * Do one step of the inner loop 320afc2ba1dSToomas Soome */ 321afc2ba1dSToomas Soome ficlVmExecuteWord(vm, *vm->ip++); 322afc2ba1dSToomas Soome 323afc2ba1dSToomas Soome /* 324afc2ba1dSToomas Soome * Now set a breakpoint at the next instruction 325afc2ba1dSToomas Soome */ 326afc2ba1dSToomas Soome ficlVmSetBreak(vm, &(vm->callback.system->breakpoint)); 327afc2ba1dSToomas Soome } 328afc2ba1dSToomas Soome 329afc2ba1dSToomas Soome /* 330afc2ba1dSToomas Soome * s t e p O v e r 331afc2ba1dSToomas Soome * Ficl 332afc2ba1dSToomas Soome * Execute the next instruction atomically. This requires some insight into 333afc2ba1dSToomas Soome * the memory layout of compiled code. Set a breakpoint at the next instruction 334afc2ba1dSToomas Soome * in this word, and run until we hit it 335afc2ba1dSToomas Soome */ 336afc2ba1dSToomas Soome static void 337afc2ba1dSToomas Soome ficlPrimitiveStepOver(ficlVm *vm) 338afc2ba1dSToomas Soome { 339afc2ba1dSToomas Soome ficlWord *word; 340afc2ba1dSToomas Soome ficlWordKind kind; 341afc2ba1dSToomas Soome ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break"); 342afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, pStep); 343afc2ba1dSToomas Soome 344afc2ba1dSToomas Soome word = *vm->ip; 345afc2ba1dSToomas Soome kind = ficlWordClassify(word); 346afc2ba1dSToomas Soome 347afc2ba1dSToomas Soome switch (kind) { 348afc2ba1dSToomas Soome case FICL_WORDKIND_COLON: 349afc2ba1dSToomas Soome case FICL_WORDKIND_DOES: 350afc2ba1dSToomas Soome /* 351afc2ba1dSToomas Soome * assume that the next ficlCell holds an instruction 352afc2ba1dSToomas Soome * set a breakpoint there and return to the inner interpreter 353afc2ba1dSToomas Soome */ 354afc2ba1dSToomas Soome vm->callback.system->breakpoint.address = vm->ip + 1; 355afc2ba1dSToomas Soome vm->callback.system->breakpoint.oldXT = vm->ip[1]; 356afc2ba1dSToomas Soome vm->ip[1] = pStep; 357afc2ba1dSToomas Soome break; 358afc2ba1dSToomas Soome default: 359afc2ba1dSToomas Soome ficlPrimitiveStepIn(vm); 360afc2ba1dSToomas Soome break; 361afc2ba1dSToomas Soome } 362afc2ba1dSToomas Soome } 363afc2ba1dSToomas Soome 364afc2ba1dSToomas Soome /* 365afc2ba1dSToomas Soome * s t e p - b r e a k 366afc2ba1dSToomas Soome * Ficl 367afc2ba1dSToomas Soome * Handles breakpoints for stepped execution. 368afc2ba1dSToomas Soome * Upon entry, breakpoint contains the address and replaced instruction 369afc2ba1dSToomas Soome * of the current breakpoint. 370afc2ba1dSToomas Soome * Clear the breakpoint 371afc2ba1dSToomas Soome * Get a command from the console. 372afc2ba1dSToomas Soome * i (step in) - execute the current instruction and set a new breakpoint 373afc2ba1dSToomas Soome * at the IP 374afc2ba1dSToomas Soome * o (step over) - execute the current instruction to completion and set 375afc2ba1dSToomas Soome * a new breakpoint at the IP 376afc2ba1dSToomas Soome * g (go) - execute the current instruction and exit 377afc2ba1dSToomas Soome * q (quit) - abort current word 378afc2ba1dSToomas Soome * b (toggle breakpoint) 379afc2ba1dSToomas Soome */ 380afc2ba1dSToomas Soome 381afc2ba1dSToomas Soome extern char *ficlDictionaryInstructionNames[]; 382afc2ba1dSToomas Soome 383afc2ba1dSToomas Soome static void 384afc2ba1dSToomas Soome ficlPrimitiveStepBreak(ficlVm *vm) 385afc2ba1dSToomas Soome { 386afc2ba1dSToomas Soome ficlString command; 387afc2ba1dSToomas Soome ficlWord *word; 388afc2ba1dSToomas Soome ficlWord *pOnStep; 389*1fb83a8fSToomas Soome bool debug = true; 390afc2ba1dSToomas Soome 391afc2ba1dSToomas Soome if (!vm->restart) { 392afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address); 393afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT); 394afc2ba1dSToomas Soome 395afc2ba1dSToomas Soome /* 396afc2ba1dSToomas Soome * Clear the breakpoint that caused me to run 397afc2ba1dSToomas Soome * Restore the original instruction at the breakpoint, 398afc2ba1dSToomas Soome * and restore the IP 399afc2ba1dSToomas Soome */ 400afc2ba1dSToomas Soome vm->ip = (ficlIp)(vm->callback.system->breakpoint.address); 401afc2ba1dSToomas Soome *vm->ip = vm->callback.system->breakpoint.oldXT; 402afc2ba1dSToomas Soome 403afc2ba1dSToomas Soome /* 404afc2ba1dSToomas Soome * If there's an onStep, do it 405afc2ba1dSToomas Soome */ 406afc2ba1dSToomas Soome pOnStep = ficlSystemLookup(vm->callback.system, "on-step"); 407afc2ba1dSToomas Soome if (pOnStep) 408afc2ba1dSToomas Soome ficlVmExecuteXT(vm, pOnStep); 409afc2ba1dSToomas Soome 410afc2ba1dSToomas Soome /* 411afc2ba1dSToomas Soome * Print the name of the next instruction 412afc2ba1dSToomas Soome */ 413afc2ba1dSToomas Soome word = vm->callback.system->breakpoint.oldXT; 414afc2ba1dSToomas Soome 415afc2ba1dSToomas Soome if ((((ficlInstruction)word) > ficlInstructionInvalid) && 416afc2ba1dSToomas Soome (((ficlInstruction)word) < ficlInstructionLast)) 417afc2ba1dSToomas Soome sprintf(vm->pad, "next: %s (instruction %ld)\n", 418afc2ba1dSToomas Soome ficlDictionaryInstructionNames[(long)word], 419afc2ba1dSToomas Soome (long)word); 420afc2ba1dSToomas Soome else { 421afc2ba1dSToomas Soome sprintf(vm->pad, "next: %s\n", word->name); 422afc2ba1dSToomas Soome if (strcmp(word->name, "interpret") == 0) 423*1fb83a8fSToomas Soome debug = false; 424afc2ba1dSToomas Soome } 425afc2ba1dSToomas Soome 426afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 427*1fb83a8fSToomas Soome ficlDebugPrompt(debug); 428afc2ba1dSToomas Soome } else { 429afc2ba1dSToomas Soome vm->restart = 0; 430afc2ba1dSToomas Soome } 431afc2ba1dSToomas Soome 432afc2ba1dSToomas Soome command = ficlVmGetWord(vm); 433afc2ba1dSToomas Soome 434afc2ba1dSToomas Soome switch (command.text[0]) { 435afc2ba1dSToomas Soome case 'i': 436afc2ba1dSToomas Soome ficlPrimitiveStepIn(vm); 437afc2ba1dSToomas Soome break; 438afc2ba1dSToomas Soome 439afc2ba1dSToomas Soome case 'o': 440afc2ba1dSToomas Soome ficlPrimitiveStepOver(vm); 441afc2ba1dSToomas Soome break; 442afc2ba1dSToomas Soome 443afc2ba1dSToomas Soome case 'g': 444afc2ba1dSToomas Soome break; 445afc2ba1dSToomas Soome 446afc2ba1dSToomas Soome case 'l': { 447afc2ba1dSToomas Soome ficlWord *xt; 448afc2ba1dSToomas Soome xt = ficlDictionaryFindEnclosingWord( 449afc2ba1dSToomas Soome ficlVmGetDictionary(vm), (ficlCell *)(vm->ip)); 450afc2ba1dSToomas Soome if (xt) { 451afc2ba1dSToomas Soome ficlStackPushPointer(vm->dataStack, xt); 452afc2ba1dSToomas Soome ficlPrimitiveSeeXT(vm); 453afc2ba1dSToomas Soome } else { 454afc2ba1dSToomas Soome ficlVmTextOut(vm, "sorry - can't do that\n"); 455afc2ba1dSToomas Soome } 456afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_RESTART); 457afc2ba1dSToomas Soome break; 458afc2ba1dSToomas Soome } 459afc2ba1dSToomas Soome 460afc2ba1dSToomas Soome case 'q': 461*1fb83a8fSToomas Soome ficlDebugPrompt(false); 462afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_ABORT); 463afc2ba1dSToomas Soome break; 464afc2ba1dSToomas Soome case 'x': { 465afc2ba1dSToomas Soome /* 466afc2ba1dSToomas Soome * Take whatever's left in the TIB and feed it to a 467afc2ba1dSToomas Soome * subordinate ficlVmExecuteString 468afc2ba1dSToomas Soome */ 469afc2ba1dSToomas Soome int returnValue; 470afc2ba1dSToomas Soome ficlString s; 471afc2ba1dSToomas Soome ficlWord *oldRunningWord = vm->runningWord; 472afc2ba1dSToomas Soome 473afc2ba1dSToomas Soome FICL_STRING_SET_POINTER(s, 474afc2ba1dSToomas Soome vm->tib.text + vm->tib.index); 475afc2ba1dSToomas Soome FICL_STRING_SET_LENGTH(s, 476afc2ba1dSToomas Soome vm->tib.end - FICL_STRING_GET_POINTER(s)); 477afc2ba1dSToomas Soome 478afc2ba1dSToomas Soome returnValue = ficlVmExecuteString(vm, s); 479afc2ba1dSToomas Soome 480afc2ba1dSToomas Soome if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT) { 481afc2ba1dSToomas Soome returnValue = FICL_VM_STATUS_RESTART; 482afc2ba1dSToomas Soome vm->runningWord = oldRunningWord; 483afc2ba1dSToomas Soome ficlVmTextOut(vm, "\n"); 484afc2ba1dSToomas Soome } 485afc2ba1dSToomas Soome if (returnValue == FICL_VM_STATUS_ERROR_EXIT) 486*1fb83a8fSToomas Soome ficlDebugPrompt(false); 487afc2ba1dSToomas Soome 488afc2ba1dSToomas Soome ficlVmThrow(vm, returnValue); 489afc2ba1dSToomas Soome break; 490afc2ba1dSToomas Soome } 491afc2ba1dSToomas Soome 492afc2ba1dSToomas Soome default: 493afc2ba1dSToomas Soome ficlVmTextOut(vm, 494afc2ba1dSToomas Soome "i -- step In\n" 495afc2ba1dSToomas Soome "o -- step Over\n" 496afc2ba1dSToomas Soome "g -- Go (execute to completion)\n" 497afc2ba1dSToomas Soome "l -- List source code\n" 498afc2ba1dSToomas Soome "q -- Quit (stop debugging and abort)\n" 499afc2ba1dSToomas Soome "x -- eXecute the rest of the line " 500afc2ba1dSToomas Soome "as Ficl words\n"); 501*1fb83a8fSToomas Soome ficlDebugPrompt(true); 502afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_RESTART); 503afc2ba1dSToomas Soome break; 504afc2ba1dSToomas Soome } 505afc2ba1dSToomas Soome 506*1fb83a8fSToomas Soome ficlDebugPrompt(false); 507afc2ba1dSToomas Soome } 508afc2ba1dSToomas Soome 509afc2ba1dSToomas Soome /* 510afc2ba1dSToomas Soome * b y e 511afc2ba1dSToomas Soome * TOOLS 512afc2ba1dSToomas Soome * Signal the system to shut down - this causes ficlExec to return 513afc2ba1dSToomas Soome * VM_USEREXIT. The rest is up to you. 514afc2ba1dSToomas Soome */ 515afc2ba1dSToomas Soome static void 516afc2ba1dSToomas Soome ficlPrimitiveBye(ficlVm *vm) 517afc2ba1dSToomas Soome { 518afc2ba1dSToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT); 519afc2ba1dSToomas Soome } 520afc2ba1dSToomas Soome 521afc2ba1dSToomas Soome /* 522afc2ba1dSToomas Soome * d i s p l a y S t a c k 523afc2ba1dSToomas Soome * TOOLS 524afc2ba1dSToomas Soome * Display the parameter stack (code for ".s") 525afc2ba1dSToomas Soome */ 526afc2ba1dSToomas Soome 527afc2ba1dSToomas Soome struct stackContext 528afc2ba1dSToomas Soome { 529afc2ba1dSToomas Soome ficlVm *vm; 530afc2ba1dSToomas Soome ficlDictionary *dictionary; 531afc2ba1dSToomas Soome int count; 532afc2ba1dSToomas Soome }; 533afc2ba1dSToomas Soome 534afc2ba1dSToomas Soome static ficlInteger 535afc2ba1dSToomas Soome ficlStackDisplayCallback(void *c, ficlCell *cell) 536afc2ba1dSToomas Soome { 537afc2ba1dSToomas Soome struct stackContext *context = (struct stackContext *)c; 538afc2ba1dSToomas Soome char buffer[80]; 539afc2ba1dSToomas Soome 540afc2ba1dSToomas Soome #ifdef _LP64 541afc2ba1dSToomas Soome snprintf(buffer, sizeof (buffer), "[0x%016lx %3d]: %20ld (0x%016lx)\n", 542afc2ba1dSToomas Soome (unsigned long)cell, context->count++, (long)cell->i, 543afc2ba1dSToomas Soome (unsigned long)cell->u); 544afc2ba1dSToomas Soome #else 545afc2ba1dSToomas Soome snprintf(buffer, sizeof (buffer), "[0x%08x %3d]: %12d (0x%08x)\n", 546afc2ba1dSToomas Soome (unsigned)cell, context->count++, cell->i, cell->u); 547afc2ba1dSToomas Soome #endif 548afc2ba1dSToomas Soome 549afc2ba1dSToomas Soome ficlVmTextOut(context->vm, buffer); 550afc2ba1dSToomas Soome return (FICL_TRUE); 551afc2ba1dSToomas Soome } 552afc2ba1dSToomas Soome 553afc2ba1dSToomas Soome void 554afc2ba1dSToomas Soome ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, 555afc2ba1dSToomas Soome void *context) 556afc2ba1dSToomas Soome { 557afc2ba1dSToomas Soome ficlVm *vm = stack->vm; 558afc2ba1dSToomas Soome char buffer[128]; 559afc2ba1dSToomas Soome struct stackContext myContext; 560afc2ba1dSToomas Soome 561afc2ba1dSToomas Soome FICL_STACK_CHECK(stack, 0, 0); 562afc2ba1dSToomas Soome 563afc2ba1dSToomas Soome #ifdef _LP64 564afc2ba1dSToomas Soome sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n", 565afc2ba1dSToomas Soome stack->name, ficlStackDepth(stack), (unsigned long)stack->top); 566afc2ba1dSToomas Soome #else 567afc2ba1dSToomas Soome sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n", 568afc2ba1dSToomas Soome stack->name, ficlStackDepth(stack), (unsigned)stack->top); 569afc2ba1dSToomas Soome #endif 570afc2ba1dSToomas Soome ficlVmTextOut(vm, buffer); 571afc2ba1dSToomas Soome 572afc2ba1dSToomas Soome if (callback == NULL) { 573afc2ba1dSToomas Soome myContext.vm = vm; 574afc2ba1dSToomas Soome myContext.count = 0; 575afc2ba1dSToomas Soome context = &myContext; 576afc2ba1dSToomas Soome callback = ficlStackDisplayCallback; 577afc2ba1dSToomas Soome } 578afc2ba1dSToomas Soome ficlStackWalk(stack, callback, context, FICL_FALSE); 579afc2ba1dSToomas Soome 580afc2ba1dSToomas Soome #ifdef _LP64 581afc2ba1dSToomas Soome sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name, 582afc2ba1dSToomas Soome (unsigned long)stack->base); 583afc2ba1dSToomas Soome #else 584afc2ba1dSToomas Soome sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name, 585afc2ba1dSToomas Soome (unsigned)stack->base); 586afc2ba1dSToomas Soome #endif 587afc2ba1dSToomas Soome ficlVmTextOut(vm, buffer); 588afc2ba1dSToomas Soome } 589afc2ba1dSToomas Soome 590afc2ba1dSToomas Soome void 591afc2ba1dSToomas Soome ficlVmDisplayDataStack(ficlVm *vm) 592afc2ba1dSToomas Soome { 593afc2ba1dSToomas Soome ficlStackDisplay(vm->dataStack, NULL, NULL); 594afc2ba1dSToomas Soome } 595afc2ba1dSToomas Soome 596afc2ba1dSToomas Soome static ficlInteger 597afc2ba1dSToomas Soome ficlStackDisplaySimpleCallback(void *c, ficlCell *cell) 598afc2ba1dSToomas Soome { 599afc2ba1dSToomas Soome struct stackContext *context = (struct stackContext *)c; 600afc2ba1dSToomas Soome char buffer[32]; 601afc2ba1dSToomas Soome 602afc2ba1dSToomas Soome sprintf(buffer, "%s%ld", context->count ? " " : "", (long)cell->i); 603afc2ba1dSToomas Soome context->count++; 604afc2ba1dSToomas Soome ficlVmTextOut(context->vm, buffer); 605afc2ba1dSToomas Soome return (FICL_TRUE); 606afc2ba1dSToomas Soome } 607afc2ba1dSToomas Soome 608afc2ba1dSToomas Soome void 609afc2ba1dSToomas Soome ficlVmDisplayDataStackSimple(ficlVm *vm) 610afc2ba1dSToomas Soome { 611afc2ba1dSToomas Soome ficlStack *stack = vm->dataStack; 612afc2ba1dSToomas Soome char buffer[32]; 613afc2ba1dSToomas Soome struct stackContext context; 614afc2ba1dSToomas Soome 615afc2ba1dSToomas Soome FICL_STACK_CHECK(stack, 0, 0); 616afc2ba1dSToomas Soome 617afc2ba1dSToomas Soome sprintf(buffer, "[%d] ", ficlStackDepth(stack)); 618afc2ba1dSToomas Soome ficlVmTextOut(vm, buffer); 619afc2ba1dSToomas Soome 620afc2ba1dSToomas Soome context.vm = vm; 621afc2ba1dSToomas Soome context.count = 0; 622afc2ba1dSToomas Soome ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context, 623afc2ba1dSToomas Soome FICL_TRUE); 624afc2ba1dSToomas Soome } 625afc2ba1dSToomas Soome 626afc2ba1dSToomas Soome static ficlInteger 627afc2ba1dSToomas Soome ficlReturnStackDisplayCallback(void *c, ficlCell *cell) 628afc2ba1dSToomas Soome { 629afc2ba1dSToomas Soome struct stackContext *context = (struct stackContext *)c; 630afc2ba1dSToomas Soome char buffer[128]; 631afc2ba1dSToomas Soome 632afc2ba1dSToomas Soome #ifdef _LP64 633afc2ba1dSToomas Soome sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)", (unsigned long)cell, 634afc2ba1dSToomas Soome context->count++, cell->i, cell->u); 635afc2ba1dSToomas Soome #else 636afc2ba1dSToomas Soome sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell, 637afc2ba1dSToomas Soome context->count++, cell->i, cell->u); 638afc2ba1dSToomas Soome #endif 639afc2ba1dSToomas Soome 640afc2ba1dSToomas Soome /* 641afc2ba1dSToomas Soome * Attempt to find the word that contains the return 642afc2ba1dSToomas Soome * stack address (as if it is part of a colon definition). 643afc2ba1dSToomas Soome * If this works, also print the name of the word. 644afc2ba1dSToomas Soome */ 645afc2ba1dSToomas Soome if (ficlDictionaryIncludes(context->dictionary, cell->p)) { 646afc2ba1dSToomas Soome ficlWord *word; 647afc2ba1dSToomas Soome word = ficlDictionaryFindEnclosingWord(context->dictionary, 648afc2ba1dSToomas Soome cell->p); 649afc2ba1dSToomas Soome if (word) { 650afc2ba1dSToomas Soome int offset = (ficlCell *)cell->p - &word->param[0]; 651afc2ba1dSToomas Soome sprintf(buffer + strlen(buffer), ", %s + %d ", 652afc2ba1dSToomas Soome word->name, offset); 653afc2ba1dSToomas Soome } 654afc2ba1dSToomas Soome } 655afc2ba1dSToomas Soome strcat(buffer, "\n"); 656afc2ba1dSToomas Soome ficlVmTextOut(context->vm, buffer); 657afc2ba1dSToomas Soome return (FICL_TRUE); 658afc2ba1dSToomas Soome } 659afc2ba1dSToomas Soome 660afc2ba1dSToomas Soome void 661afc2ba1dSToomas Soome ficlVmDisplayReturnStack(ficlVm *vm) 662afc2ba1dSToomas Soome { 663afc2ba1dSToomas Soome struct stackContext context; 664afc2ba1dSToomas Soome context.vm = vm; 665afc2ba1dSToomas Soome context.count = 0; 666afc2ba1dSToomas Soome context.dictionary = ficlVmGetDictionary(vm); 667afc2ba1dSToomas Soome ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback, 668afc2ba1dSToomas Soome &context); 669afc2ba1dSToomas Soome } 670afc2ba1dSToomas Soome 671afc2ba1dSToomas Soome /* 672afc2ba1dSToomas Soome * f o r g e t - w i d 673afc2ba1dSToomas Soome */ 674afc2ba1dSToomas Soome static void 675afc2ba1dSToomas Soome ficlPrimitiveForgetWid(ficlVm *vm) 676afc2ba1dSToomas Soome { 677afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 678afc2ba1dSToomas Soome ficlHash *hash; 679afc2ba1dSToomas Soome 680afc2ba1dSToomas Soome hash = (ficlHash *)ficlStackPopPointer(vm->dataStack); 681afc2ba1dSToomas Soome ficlHashForget(hash, dictionary->here); 682afc2ba1dSToomas Soome } 683afc2ba1dSToomas Soome 684afc2ba1dSToomas Soome /* 685afc2ba1dSToomas Soome * f o r g e t 686afc2ba1dSToomas Soome * TOOLS EXT ( "<spaces>name" -- ) 687afc2ba1dSToomas Soome * Skip leading space delimiters. Parse name delimited by a space. 688afc2ba1dSToomas Soome * Find name, then delete name from the dictionary along with all 689afc2ba1dSToomas Soome * words added to the dictionary after name. An ambiguous 690afc2ba1dSToomas Soome * condition exists if name cannot be found. 691afc2ba1dSToomas Soome * 692afc2ba1dSToomas Soome * If the Search-Order word set is present, FORGET searches the 693afc2ba1dSToomas Soome * compilation word list. An ambiguous condition exists if the 694afc2ba1dSToomas Soome * compilation word list is deleted. 695afc2ba1dSToomas Soome */ 696afc2ba1dSToomas Soome static void 697afc2ba1dSToomas Soome ficlPrimitiveForget(ficlVm *vm) 698afc2ba1dSToomas Soome { 699afc2ba1dSToomas Soome void *where; 700afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 701afc2ba1dSToomas Soome ficlHash *hash = dictionary->compilationWordlist; 702afc2ba1dSToomas Soome 703afc2ba1dSToomas Soome ficlPrimitiveTick(vm); 704afc2ba1dSToomas Soome where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name; 705afc2ba1dSToomas Soome ficlHashForget(hash, where); 706afc2ba1dSToomas Soome dictionary->here = FICL_POINTER_TO_CELL(where); 707afc2ba1dSToomas Soome } 708afc2ba1dSToomas Soome 709afc2ba1dSToomas Soome /* 710afc2ba1dSToomas Soome * w o r d s 711afc2ba1dSToomas Soome */ 712afc2ba1dSToomas Soome #define nCOLWIDTH 8 713afc2ba1dSToomas Soome 714afc2ba1dSToomas Soome static void 7158751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary, 7168751d36cSAndy Fiddaman ficlHash *hash, char *ss) 717afc2ba1dSToomas Soome { 718afc2ba1dSToomas Soome ficlWord *wp; 719afc2ba1dSToomas Soome int nChars = 0; 720afc2ba1dSToomas Soome int len; 721afc2ba1dSToomas Soome unsigned i; 7228751d36cSAndy Fiddaman int nWords = 0, dWords = 0; 723afc2ba1dSToomas Soome char *cp; 724afc2ba1dSToomas Soome char *pPad; 725afc2ba1dSToomas Soome int columns; 726afc2ba1dSToomas Soome 7279890ff83SToomas Soome cp = getenv("screen-#cols"); 728afc2ba1dSToomas Soome /* 729afc2ba1dSToomas Soome * using strtol for now. TODO: refactor number conversion from 730afc2ba1dSToomas Soome * ficlPrimitiveToNumber() and use it instead. 731afc2ba1dSToomas Soome */ 732afc2ba1dSToomas Soome if (cp == NULL) 733afc2ba1dSToomas Soome columns = 80; 734afc2ba1dSToomas Soome else 735afc2ba1dSToomas Soome columns = strtol(cp, NULL, 0); 736afc2ba1dSToomas Soome 737afc2ba1dSToomas Soome /* 738afc2ba1dSToomas Soome * the pad is fixed size area, it's better to allocate 739afc2ba1dSToomas Soome * dedicated buffer space to deal with custom terminal sizes. 740afc2ba1dSToomas Soome */ 741afc2ba1dSToomas Soome pPad = malloc(columns + 1); 742afc2ba1dSToomas Soome if (pPad == NULL) 743afc2ba1dSToomas Soome ficlVmThrowError(vm, "Error: out of memory"); 744afc2ba1dSToomas Soome 745afc2ba1dSToomas Soome pager_open(); 746afc2ba1dSToomas Soome for (i = 0; i < hash->size; i++) { 747afc2ba1dSToomas Soome for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) { 748afc2ba1dSToomas Soome if (wp->length == 0) /* ignore :noname defs */ 749afc2ba1dSToomas Soome continue; 750afc2ba1dSToomas Soome 7518751d36cSAndy Fiddaman if (ss != NULL && strstr(wp->name, ss) == NULL) 7528751d36cSAndy Fiddaman continue; 7538751d36cSAndy Fiddaman if (ss != NULL && dWords == 0) { 7548751d36cSAndy Fiddaman sprintf(pPad, " In vocabulary %s\n", 7558751d36cSAndy Fiddaman hash->name ? hash->name : "<unknown>"); 7568751d36cSAndy Fiddaman pager_output(pPad); 7578751d36cSAndy Fiddaman } 7588751d36cSAndy Fiddaman dWords++; 7598751d36cSAndy Fiddaman 760afc2ba1dSToomas Soome /* prevent line wrap due to long words */ 761afc2ba1dSToomas Soome if (nChars + wp->length >= columns) { 762afc2ba1dSToomas Soome pPad[nChars++] = '\n'; 763afc2ba1dSToomas Soome pPad[nChars] = '\0'; 764afc2ba1dSToomas Soome nChars = 0; 765afc2ba1dSToomas Soome if (pager_output(pPad)) 766afc2ba1dSToomas Soome goto pager_done; 767afc2ba1dSToomas Soome } 768afc2ba1dSToomas Soome 769afc2ba1dSToomas Soome cp = wp->name; 770afc2ba1dSToomas Soome nChars += sprintf(pPad + nChars, "%s", cp); 771afc2ba1dSToomas Soome 772afc2ba1dSToomas Soome if (nChars > columns - 10) { 773afc2ba1dSToomas Soome pPad[nChars++] = '\n'; 774afc2ba1dSToomas Soome pPad[nChars] = '\0'; 775afc2ba1dSToomas Soome nChars = 0; 776afc2ba1dSToomas Soome if (pager_output(pPad)) 777afc2ba1dSToomas Soome goto pager_done; 778afc2ba1dSToomas Soome } else { 779afc2ba1dSToomas Soome len = nCOLWIDTH - nChars % nCOLWIDTH; 780afc2ba1dSToomas Soome while (len-- > 0) 781afc2ba1dSToomas Soome pPad[nChars++] = ' '; 782afc2ba1dSToomas Soome } 783afc2ba1dSToomas Soome 784afc2ba1dSToomas Soome if (nChars > columns - 10) { 785afc2ba1dSToomas Soome pPad[nChars++] = '\n'; 786afc2ba1dSToomas Soome pPad[nChars] = '\0'; 787afc2ba1dSToomas Soome nChars = 0; 788afc2ba1dSToomas Soome if (pager_output(pPad)) 789afc2ba1dSToomas Soome goto pager_done; 790afc2ba1dSToomas Soome } 791afc2ba1dSToomas Soome } 792afc2ba1dSToomas Soome } 793afc2ba1dSToomas Soome 794afc2ba1dSToomas Soome if (nChars > 0) { 795afc2ba1dSToomas Soome pPad[nChars++] = '\n'; 796afc2ba1dSToomas Soome pPad[nChars] = '\0'; 797afc2ba1dSToomas Soome nChars = 0; 798afc2ba1dSToomas Soome ficlVmTextOut(vm, pPad); 799afc2ba1dSToomas Soome } 800afc2ba1dSToomas Soome 8018751d36cSAndy Fiddaman if (ss == NULL) { 8028751d36cSAndy Fiddaman sprintf(pPad, 8038751d36cSAndy Fiddaman "Dictionary: %d words, %ld cells used of %u total\n", 804afc2ba1dSToomas Soome nWords, (long)(dictionary->here - dictionary->base), 805afc2ba1dSToomas Soome dictionary->size); 806afc2ba1dSToomas Soome pager_output(pPad); 8078751d36cSAndy Fiddaman } 808afc2ba1dSToomas Soome 809afc2ba1dSToomas Soome pager_done: 810afc2ba1dSToomas Soome free(pPad); 811afc2ba1dSToomas Soome pager_close(); 812afc2ba1dSToomas Soome } 813afc2ba1dSToomas Soome 8148751d36cSAndy Fiddaman static void 8158751d36cSAndy Fiddaman ficlPrimitiveWords(ficlVm *vm) 8168751d36cSAndy Fiddaman { 8178751d36cSAndy Fiddaman ficlDictionary *dictionary = ficlVmGetDictionary(vm); 8188751d36cSAndy Fiddaman ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1]; 8198751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL); 8208751d36cSAndy Fiddaman } 8218751d36cSAndy Fiddaman 8228751d36cSAndy Fiddaman void 8238751d36cSAndy Fiddaman ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss) 8248751d36cSAndy Fiddaman { 8258751d36cSAndy Fiddaman ficlDictionary *dict = ficlVmGetDictionary(vm); 8268751d36cSAndy Fiddaman int i; 8278751d36cSAndy Fiddaman 8288751d36cSAndy Fiddaman for (i = 0; i < dict->wordlistCount; i++) 8298751d36cSAndy Fiddaman ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss); 8308751d36cSAndy Fiddaman } 8318751d36cSAndy Fiddaman 832afc2ba1dSToomas Soome /* 833afc2ba1dSToomas Soome * l i s t E n v 834afc2ba1dSToomas Soome * Print symbols defined in the environment 835afc2ba1dSToomas Soome */ 836afc2ba1dSToomas Soome static void 837afc2ba1dSToomas Soome ficlPrimitiveListEnv(ficlVm *vm) 838afc2ba1dSToomas Soome { 839afc2ba1dSToomas Soome ficlDictionary *dictionary = vm->callback.system->environment; 840afc2ba1dSToomas Soome ficlHash *hash = dictionary->forthWordlist; 841afc2ba1dSToomas Soome ficlWord *word; 842afc2ba1dSToomas Soome unsigned i; 843afc2ba1dSToomas Soome int counter = 0; 844afc2ba1dSToomas Soome 845afc2ba1dSToomas Soome pager_open(); 846afc2ba1dSToomas Soome for (i = 0; i < hash->size; i++) { 847afc2ba1dSToomas Soome for (word = hash->table[i]; word != NULL; 848afc2ba1dSToomas Soome word = word->link, counter++) { 849afc2ba1dSToomas Soome sprintf(vm->pad, "%s\n", word->name); 850afc2ba1dSToomas Soome if (pager_output(vm->pad)) 851afc2ba1dSToomas Soome goto pager_done; 852afc2ba1dSToomas Soome } 853afc2ba1dSToomas Soome } 854afc2ba1dSToomas Soome 855afc2ba1dSToomas Soome sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n", 856afc2ba1dSToomas Soome counter, (long)(dictionary->here - dictionary->base), 857afc2ba1dSToomas Soome dictionary->size); 858afc2ba1dSToomas Soome pager_output(vm->pad); 859afc2ba1dSToomas Soome 860afc2ba1dSToomas Soome pager_done: 861afc2ba1dSToomas Soome pager_close(); 862afc2ba1dSToomas Soome } 863afc2ba1dSToomas Soome 864afc2ba1dSToomas Soome /* 865afc2ba1dSToomas Soome * This word lists the parse steps in order 866afc2ba1dSToomas Soome */ 867afc2ba1dSToomas Soome void 868afc2ba1dSToomas Soome ficlPrimitiveParseStepList(ficlVm *vm) 869afc2ba1dSToomas Soome { 870afc2ba1dSToomas Soome int i; 871afc2ba1dSToomas Soome ficlSystem *system = vm->callback.system; 872afc2ba1dSToomas Soome FICL_VM_ASSERT(vm, system); 873afc2ba1dSToomas Soome 874afc2ba1dSToomas Soome ficlVmTextOut(vm, "Parse steps:\n"); 875afc2ba1dSToomas Soome ficlVmTextOut(vm, "lookup\n"); 876afc2ba1dSToomas Soome 877afc2ba1dSToomas Soome for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) { 878afc2ba1dSToomas Soome if (system->parseList[i] != NULL) { 879afc2ba1dSToomas Soome ficlVmTextOut(vm, system->parseList[i]->name); 880afc2ba1dSToomas Soome ficlVmTextOut(vm, "\n"); 881afc2ba1dSToomas Soome } else 882afc2ba1dSToomas Soome break; 883afc2ba1dSToomas Soome } 884afc2ba1dSToomas Soome } 885afc2ba1dSToomas Soome 886afc2ba1dSToomas Soome /* 887afc2ba1dSToomas Soome * e n v C o n s t a n t 888afc2ba1dSToomas Soome * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl 889afc2ba1dSToomas Soome * code to set environment constants... 890afc2ba1dSToomas Soome */ 891afc2ba1dSToomas Soome static void 892afc2ba1dSToomas Soome ficlPrimitiveEnvConstant(ficlVm *vm) 893afc2ba1dSToomas Soome { 894afc2ba1dSToomas Soome unsigned value; 895afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 896afc2ba1dSToomas Soome 897afc2ba1dSToomas Soome ficlVmGetWordToPad(vm); 898afc2ba1dSToomas Soome value = ficlStackPopUnsigned(vm->dataStack); 899afc2ba1dSToomas Soome ficlDictionarySetConstant(ficlSystemGetEnvironment(vm->callback.system), 900afc2ba1dSToomas Soome vm->pad, (ficlUnsigned)value); 901afc2ba1dSToomas Soome } 902afc2ba1dSToomas Soome 903afc2ba1dSToomas Soome static void 904afc2ba1dSToomas Soome ficlPrimitiveEnv2Constant(ficlVm *vm) 905afc2ba1dSToomas Soome { 906afc2ba1dSToomas Soome ficl2Integer value; 907afc2ba1dSToomas Soome 908afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 909afc2ba1dSToomas Soome 910afc2ba1dSToomas Soome ficlVmGetWordToPad(vm); 911afc2ba1dSToomas Soome value = ficlStackPop2Integer(vm->dataStack); 912afc2ba1dSToomas Soome ficlDictionarySet2Constant( 913afc2ba1dSToomas Soome ficlSystemGetEnvironment(vm->callback.system), vm->pad, value); 914afc2ba1dSToomas Soome } 915afc2ba1dSToomas Soome 916afc2ba1dSToomas Soome 917afc2ba1dSToomas Soome /* 918afc2ba1dSToomas Soome * f i c l C o m p i l e T o o l s 919afc2ba1dSToomas Soome * Builds wordset for debugger and TOOLS optional word set 920afc2ba1dSToomas Soome */ 921afc2ba1dSToomas Soome void 922afc2ba1dSToomas Soome ficlSystemCompileTools(ficlSystem *system) 923afc2ba1dSToomas Soome { 924afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system); 925afc2ba1dSToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system); 926afc2ba1dSToomas Soome 927afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, dictionary); 928afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, environment); 929afc2ba1dSToomas Soome 930afc2ba1dSToomas Soome 931afc2ba1dSToomas Soome /* 932afc2ba1dSToomas Soome * TOOLS and TOOLS EXT 933afc2ba1dSToomas Soome */ 934afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack, 935afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 936afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, ".s-simple", 937afc2ba1dSToomas Soome ficlVmDisplayDataStackSimple, FICL_WORD_DEFAULT); 938afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye, 939afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 940afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget, 941afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 942afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee, 943afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 944afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords, 945afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 946afc2ba1dSToomas Soome 947afc2ba1dSToomas Soome /* 948afc2ba1dSToomas Soome * Set TOOLS environment query values 949afc2ba1dSToomas Soome */ 950afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "tools", FICL_TRUE); 951afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE); 952afc2ba1dSToomas Soome 953afc2ba1dSToomas Soome /* 954afc2ba1dSToomas Soome * Ficl extras 955afc2ba1dSToomas Soome */ 956afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "r.s", ficlVmDisplayReturnStack, 957afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 958afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, ".env", ficlPrimitiveListEnv, 959afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 960afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "env-constant", 961afc2ba1dSToomas Soome ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT); 962afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "env-2constant", 963afc2ba1dSToomas Soome ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT); 964afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "debug-xt", ficlPrimitiveDebugXT, 965afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 966afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "parse-order", 967afc2ba1dSToomas Soome ficlPrimitiveParseStepList, FICL_WORD_DEFAULT); 968afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "step-break", 969afc2ba1dSToomas Soome ficlPrimitiveStepBreak, FICL_WORD_DEFAULT); 970afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "forget-wid", 971afc2ba1dSToomas Soome ficlPrimitiveForgetWid, FICL_WORD_DEFAULT); 972afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "see-xt", ficlPrimitiveSeeXT, 973afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 974afc2ba1dSToomas Soome 975afc2ba1dSToomas Soome #if FICL_WANT_FLOAT 976afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, ".hash", 977afc2ba1dSToomas Soome ficlPrimitiveHashSummary, FICL_WORD_DEFAULT); 978afc2ba1dSToomas Soome #endif 979afc2ba1dSToomas Soome } 980