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