usr/src/common/ficl/tools.c

   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 }