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 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 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 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 107 ficlDebugPrompt(bool debug) 108 { 109 if (debug) 110 setenv("prompt", "dbg> ", 1); 111 else 112 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 sprintf(vm->pad, "next: %s (instruction %ld)\n", 418 ficlDictionaryInstructionNames[(long)word], 419 (long)word); 420 else { 421 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 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 535 ficlStackDisplayCallback(void *c, ficlCell *cell) 536 { 537 struct stackContext *context = (struct stackContext *)c; 538 char buffer[80]; 539 540 #ifdef _LP64 541 snprintf(buffer, sizeof (buffer), "[0x%016lx %3d]: %20ld (0x%016lx)\n", 542 (unsigned long)cell, context->count++, (long)cell->i, 543 (unsigned long)cell->u); 544 #else 545 snprintf(buffer, sizeof (buffer), "[0x%08x %3d]: %12d (0x%08x)\n", 546 (unsigned)cell, context->count++, cell->i, cell->u); 547 #endif 548 549 ficlVmTextOut(context->vm, buffer); 550 return (FICL_TRUE); 551 } 552 553 void 554 ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, 555 void *context) 556 { 557 ficlVm *vm = stack->vm; 558 char buffer[128]; 559 struct stackContext myContext; 560 561 FICL_STACK_CHECK(stack, 0, 0); 562 563 #ifdef _LP64 564 sprintf(buffer, "[%s stack has %d entries, top at 0x%016lx]\n", 565 stack->name, ficlStackDepth(stack), (unsigned long)stack->top); 566 #else 567 sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n", 568 stack->name, ficlStackDepth(stack), (unsigned)stack->top); 569 #endif 570 ficlVmTextOut(vm, buffer); 571 572 if (callback == NULL) { 573 myContext.vm = vm; 574 myContext.count = 0; 575 context = &myContext; 576 callback = ficlStackDisplayCallback; 577 } 578 ficlStackWalk(stack, callback, context, FICL_FALSE); 579 580 #ifdef _LP64 581 sprintf(buffer, "[%s stack base at 0x%016lx]\n", stack->name, 582 (unsigned long)stack->base); 583 #else 584 sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name, 585 (unsigned)stack->base); 586 #endif 587 ficlVmTextOut(vm, buffer); 588 } 589 590 void 591 ficlVmDisplayDataStack(ficlVm *vm) 592 { 593 ficlStackDisplay(vm->dataStack, NULL, NULL); 594 } 595 596 static ficlInteger 597 ficlStackDisplaySimpleCallback(void *c, ficlCell *cell) 598 { 599 struct stackContext *context = (struct stackContext *)c; 600 char buffer[32]; 601 602 sprintf(buffer, "%s%ld", context->count ? " " : "", (long)cell->i); 603 context->count++; 604 ficlVmTextOut(context->vm, buffer); 605 return (FICL_TRUE); 606 } 607 608 void 609 ficlVmDisplayDataStackSimple(ficlVm *vm) 610 { 611 ficlStack *stack = vm->dataStack; 612 char buffer[32]; 613 struct stackContext context; 614 615 FICL_STACK_CHECK(stack, 0, 0); 616 617 sprintf(buffer, "[%d] ", ficlStackDepth(stack)); 618 ficlVmTextOut(vm, buffer); 619 620 context.vm = vm; 621 context.count = 0; 622 ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context, 623 FICL_TRUE); 624 } 625 626 static ficlInteger 627 ficlReturnStackDisplayCallback(void *c, ficlCell *cell) 628 { 629 struct stackContext *context = (struct stackContext *)c; 630 char buffer[128]; 631 632 #ifdef _LP64 633 sprintf(buffer, "[0x%016lx %3d] %20ld (0x%016lx)", (unsigned long)cell, 634 context->count++, cell->i, cell->u); 635 #else 636 sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", (unsigned)cell, 637 context->count++, cell->i, cell->u); 638 #endif 639 640 /* 641 * Attempt to find the word that contains the return 642 * stack address (as if it is part of a colon definition). 643 * If this works, also print the name of the word. 644 */ 645 if (ficlDictionaryIncludes(context->dictionary, cell->p)) { 646 ficlWord *word; 647 word = ficlDictionaryFindEnclosingWord(context->dictionary, 648 cell->p); 649 if (word) { 650 int offset = (ficlCell *)cell->p - &word->param[0]; 651 sprintf(buffer + strlen(buffer), ", %s + %d ", 652 word->name, offset); 653 } 654 } 655 strcat(buffer, "\n"); 656 ficlVmTextOut(context->vm, buffer); 657 return (FICL_TRUE); 658 } 659 660 void 661 ficlVmDisplayReturnStack(ficlVm *vm) 662 { 663 struct stackContext context; 664 context.vm = vm; 665 context.count = 0; 666 context.dictionary = ficlVmGetDictionary(vm); 667 ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback, 668 &context); 669 } 670 671 /* 672 * f o r g e t - w i d 673 */ 674 static void 675 ficlPrimitiveForgetWid(ficlVm *vm) 676 { 677 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 678 ficlHash *hash; 679 680 hash = (ficlHash *)ficlStackPopPointer(vm->dataStack); 681 ficlHashForget(hash, dictionary->here); 682 } 683 684 /* 685 * f o r g e t 686 * TOOLS EXT ( "<spaces>name" -- ) 687 * Skip leading space delimiters. Parse name delimited by a space. 688 * Find name, then delete name from the dictionary along with all 689 * words added to the dictionary after name. An ambiguous 690 * condition exists if name cannot be found. 691 * 692 * If the Search-Order word set is present, FORGET searches the 693 * compilation word list. An ambiguous condition exists if the 694 * compilation word list is deleted. 695 */ 696 static void 697 ficlPrimitiveForget(ficlVm *vm) 698 { 699 void *where; 700 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 701 ficlHash *hash = dictionary->compilationWordlist; 702 703 ficlPrimitiveTick(vm); 704 where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name; 705 ficlHashForget(hash, where); 706 dictionary->here = FICL_POINTER_TO_CELL(where); 707 } 708 709 /* 710 * w o r d s 711 */ 712 #define nCOLWIDTH 8 713 714 static void 715 ficlPrimitiveWordsBackend(ficlVm *vm, ficlDictionary *dictionary, 716 ficlHash *hash, char *ss) 717 { 718 ficlWord *wp; 719 int nChars = 0; 720 int len; 721 unsigned i; 722 int nWords = 0, dWords = 0; 723 char *cp; 724 char *pPad; 725 int columns; 726 727 cp = getenv("screen-#cols"); 728 /* 729 * using strtol for now. TODO: refactor number conversion from 730 * ficlPrimitiveToNumber() and use it instead. 731 */ 732 if (cp == NULL) 733 columns = 80; 734 else 735 columns = strtol(cp, NULL, 0); 736 737 /* 738 * the pad is fixed size area, it's better to allocate 739 * dedicated buffer space to deal with custom terminal sizes. 740 */ 741 pPad = malloc(columns + 1); 742 if (pPad == NULL) 743 ficlVmThrowError(vm, "Error: out of memory"); 744 745 pager_open(); 746 for (i = 0; i < hash->size; i++) { 747 for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++) { 748 if (wp->length == 0) /* ignore :noname defs */ 749 continue; 750 751 if (ss != NULL && strstr(wp->name, ss) == NULL) 752 continue; 753 if (ss != NULL && dWords == 0) { 754 sprintf(pPad, " In vocabulary %s\n", 755 hash->name ? hash->name : "<unknown>"); 756 pager_output(pPad); 757 } 758 dWords++; 759 760 /* prevent line wrap due to long words */ 761 if (nChars + wp->length >= columns) { 762 pPad[nChars++] = '\n'; 763 pPad[nChars] = '\0'; 764 nChars = 0; 765 if (pager_output(pPad)) 766 goto pager_done; 767 } 768 769 cp = wp->name; 770 nChars += sprintf(pPad + nChars, "%s", cp); 771 772 if (nChars > columns - 10) { 773 pPad[nChars++] = '\n'; 774 pPad[nChars] = '\0'; 775 nChars = 0; 776 if (pager_output(pPad)) 777 goto pager_done; 778 } else { 779 len = nCOLWIDTH - nChars % nCOLWIDTH; 780 while (len-- > 0) 781 pPad[nChars++] = ' '; 782 } 783 784 if (nChars > columns - 10) { 785 pPad[nChars++] = '\n'; 786 pPad[nChars] = '\0'; 787 nChars = 0; 788 if (pager_output(pPad)) 789 goto pager_done; 790 } 791 } 792 } 793 794 if (nChars > 0) { 795 pPad[nChars++] = '\n'; 796 pPad[nChars] = '\0'; 797 nChars = 0; 798 ficlVmTextOut(vm, pPad); 799 } 800 801 if (ss == NULL) { 802 sprintf(pPad, 803 "Dictionary: %d words, %ld cells used of %u total\n", 804 nWords, (long)(dictionary->here - dictionary->base), 805 dictionary->size); 806 pager_output(pPad); 807 } 808 809 pager_done: 810 free(pPad); 811 pager_close(); 812 } 813 814 static void 815 ficlPrimitiveWords(ficlVm *vm) 816 { 817 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 818 ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1]; 819 ficlPrimitiveWordsBackend(vm, dictionary, hash, NULL); 820 } 821 822 void 823 ficlPrimitiveSiftingImpl(ficlVm *vm, char *ss) 824 { 825 ficlDictionary *dict = ficlVmGetDictionary(vm); 826 int i; 827 828 for (i = 0; i < dict->wordlistCount; i++) 829 ficlPrimitiveWordsBackend(vm, dict, dict->wordlists[i], ss); 830 } 831 832 /* 833 * l i s t E n v 834 * Print symbols defined in the environment 835 */ 836 static void 837 ficlPrimitiveListEnv(ficlVm *vm) 838 { 839 ficlDictionary *dictionary = vm->callback.system->environment; 840 ficlHash *hash = dictionary->forthWordlist; 841 ficlWord *word; 842 unsigned i; 843 int counter = 0; 844 845 pager_open(); 846 for (i = 0; i < hash->size; i++) { 847 for (word = hash->table[i]; word != NULL; 848 word = word->link, counter++) { 849 sprintf(vm->pad, "%s\n", word->name); 850 if (pager_output(vm->pad)) 851 goto pager_done; 852 } 853 } 854 855 sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n", 856 counter, (long)(dictionary->here - dictionary->base), 857 dictionary->size); 858 pager_output(vm->pad); 859 860 pager_done: 861 pager_close(); 862 } 863 864 /* 865 * This word lists the parse steps in order 866 */ 867 void 868 ficlPrimitiveParseStepList(ficlVm *vm) 869 { 870 int i; 871 ficlSystem *system = vm->callback.system; 872 FICL_VM_ASSERT(vm, system); 873 874 ficlVmTextOut(vm, "Parse steps:\n"); 875 ficlVmTextOut(vm, "lookup\n"); 876 877 for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) { 878 if (system->parseList[i] != NULL) { 879 ficlVmTextOut(vm, system->parseList[i]->name); 880 ficlVmTextOut(vm, "\n"); 881 } else 882 break; 883 } 884 } 885 886 /* 887 * e n v C o n s t a n t 888 * Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl 889 * code to set environment constants... 890 */ 891 static void 892 ficlPrimitiveEnvConstant(ficlVm *vm) 893 { 894 unsigned value; 895 FICL_STACK_CHECK(vm->dataStack, 1, 0); 896 897 ficlVmGetWordToPad(vm); 898 value = ficlStackPopUnsigned(vm->dataStack); 899 ficlDictionarySetConstant(ficlSystemGetEnvironment(vm->callback.system), 900 vm->pad, (ficlUnsigned)value); 901 } 902 903 static void 904 ficlPrimitiveEnv2Constant(ficlVm *vm) 905 { 906 ficl2Integer value; 907 908 FICL_STACK_CHECK(vm->dataStack, 2, 0); 909 910 ficlVmGetWordToPad(vm); 911 value = ficlStackPop2Integer(vm->dataStack); 912 ficlDictionarySet2Constant( 913 ficlSystemGetEnvironment(vm->callback.system), vm->pad, value); 914 } 915 916 917 /* 918 * f i c l C o m p i l e T o o l s 919 * Builds wordset for debugger and TOOLS optional word set 920 */ 921 void 922 ficlSystemCompileTools(ficlSystem *system) 923 { 924 ficlDictionary *dictionary = ficlSystemGetDictionary(system); 925 ficlDictionary *environment = ficlSystemGetEnvironment(system); 926 927 FICL_SYSTEM_ASSERT(system, dictionary); 928 FICL_SYSTEM_ASSERT(system, environment); 929 930 931 /* 932 * TOOLS and TOOLS EXT 933 */ 934 ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack, 935 FICL_WORD_DEFAULT); 936 ficlDictionarySetPrimitive(dictionary, ".s-simple", 937 ficlVmDisplayDataStackSimple, FICL_WORD_DEFAULT); 938 ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye, 939 FICL_WORD_DEFAULT); 940 ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget, 941 FICL_WORD_DEFAULT); 942 ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee, 943 FICL_WORD_DEFAULT); 944 ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords, 945 FICL_WORD_DEFAULT); 946 947 /* 948 * Set TOOLS environment query values 949 */ 950 ficlDictionarySetConstant(environment, "tools", FICL_TRUE); 951 ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE); 952 953 /* 954 * Ficl extras 955 */ 956 ficlDictionarySetPrimitive(dictionary, "r.s", ficlVmDisplayReturnStack, 957 FICL_WORD_DEFAULT); 958 ficlDictionarySetPrimitive(dictionary, ".env", ficlPrimitiveListEnv, 959 FICL_WORD_DEFAULT); 960 ficlDictionarySetPrimitive(dictionary, "env-constant", 961 ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT); 962 ficlDictionarySetPrimitive(dictionary, "env-2constant", 963 ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT); 964 ficlDictionarySetPrimitive(dictionary, "debug-xt", ficlPrimitiveDebugXT, 965 FICL_WORD_DEFAULT); 966 ficlDictionarySetPrimitive(dictionary, "parse-order", 967 ficlPrimitiveParseStepList, FICL_WORD_DEFAULT); 968 ficlDictionarySetPrimitive(dictionary, "step-break", 969 ficlPrimitiveStepBreak, FICL_WORD_DEFAULT); 970 ficlDictionarySetPrimitive(dictionary, "forget-wid", 971 ficlPrimitiveForgetWid, FICL_WORD_DEFAULT); 972 ficlDictionarySetPrimitive(dictionary, "see-xt", ficlPrimitiveSeeXT, 973 FICL_WORD_DEFAULT); 974 975 #if FICL_WANT_FLOAT 976 ficlDictionarySetPrimitive(dictionary, ".hash", 977 ficlPrimitiveHashSummary, FICL_WORD_DEFAULT); 978 #endif 979 } 980