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