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