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