stand/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.11 2001/12/05 07:21:34 jsadler 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 ** colonParen doDoes createParen variableParen userParen constantParen
  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
  58 #ifdef TESTMAIN
  59 #include <stdlib.h>
  60 #include <stdio.h>          /* sprintf */
  61 #include <ctype.h>
  62 #else
  63 #include <stand.h>
  64 #endif
  65 #include <string.h>
  66 #include "ficl.h"
  67
  68
  69 #if 0
  70 /*
  71 ** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
  72 ** for the STEP command. The rest are user programmable.
  73 */
  74 #define nBREAKPOINTS 32
  75
  76 #endif
  77
  78
  79 /**************************************************************************
  80                         v m S e t B r e a k
  81 ** Set a breakpoint at the current value of IP by
  82 ** storing that address in a BREAKPOINT record
  83 **************************************************************************/
  84 static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
  85 {
  86     FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
  87     assert(pStep);
  88
  89     pBP->address = pVM->ip;
  90     pBP->origXT = *pVM->ip;
  91     *pVM->ip = pStep;
  92 }
  93
  94
  95 /**************************************************************************
  96 **                      d e b u g P r o m p t
  97 **************************************************************************/
  98 static void debugPrompt(FICL_VM *pVM)
  99 {
 100         vmTextOut(pVM, "dbg> ", 0);
 101 }
 102
 103
 104 /**************************************************************************
 105 **                      i s A F i c l W o r d
 106 ** Vet a candidate pointer carefully to make sure
 107 ** it's not some chunk o' inline data...
 108 ** It has to have a name, and it has to look
 109 ** like it's in the dictionary address range.
 110 ** NOTE: this excludes :noname words!
 111 **************************************************************************/
 112 int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
 113 {
 114
 115     if (!dictIncludes(pd, pFW))
 116        return 0;
 117
 118     if (!dictIncludes(pd, pFW->name))
 119         return 0;
 120
 121         if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
 122                 return 0;
 123
 124     if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
 125                 return 0;
 126
 127         if (strlen(pFW->name) != pFW->nName)
 128                 return 0;
 129
 130         return 1;
 131 }
 132
 133
 134 #if 0
 135 static int isPrimitive(FICL_WORD *pFW)
 136 {
 137     WORDKIND wk = ficlWordClassify(pFW);
 138     return ((wk != COLON) && (wk != DOES));
 139 }
 140 #endif
 141
 142
 143 /**************************************************************************
 144                         f i n d E n c l o s i n g W o r d
 145 ** Given a pointer to something, check to make sure it's an address in the
 146 ** dictionary. If so, search backwards until we find something that looks
 147 ** like a dictionary header. If successful, return the address of the
 148 ** FICL_WORD found. Otherwise return NULL.
 149 ** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
 150 **************************************************************************/
 151 #define nSEARCH_CELLS 100
 152
 153 static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
 154 {
 155     FICL_WORD *pFW;
 156     FICL_DICT *pd = vmGetDict(pVM);
 157     int i;
 158
 159     if (!dictIncludes(pd, (void *)cp))
 160         return NULL;
 161
 162     for (i = nSEARCH_CELLS; i > 0; --i, --cp)
 163     {
 164         pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL)));
 165         if (isAFiclWord(pd, pFW))
 166             return pFW;
 167     }
 168
 169     return NULL;
 170 }
 171
 172
 173 /**************************************************************************
 174                         s e e
 175 ** TOOLS ( "<spaces>name" -- )
 176 ** Display a human-readable representation of the named word's definition.
 177 ** The source of the representation (object-code decompilation, source
 178 ** block, etc.) and the particular form of the display is implementation
 179 ** defined.
 180 **************************************************************************/
 181 /*
 182 ** seeColon (for proctologists only)
 183 ** Walks a colon definition, decompiling
 184 ** on the fly. Knows about primitive control structures.
 185 */
 186 static void seeColon(FICL_VM *pVM, CELL *pc)
 187 {
 188         char *cp;
 189     CELL *param0 = pc;
 190     FICL_DICT *pd = vmGetDict(pVM);
 191         FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)");
 192     assert(pSemiParen);
 193
 194     for (; pc->p != pSemiParen; pc++)
 195     {
 196         FICL_WORD *pFW = (FICL_WORD *)(pc->p);
 197
 198         cp = pVM->pad;
 199                 if ((void *)pc == (void *)pVM->ip)
 200                         *cp++ = '>';
 201                 else
 202                         *cp++ = ' ';
 203         cp += sprintf(cp, "%3d   ", (int)(pc-param0));
 204
 205         if (isAFiclWord(pd, pFW))
 206         {
 207             WORDKIND kind = ficlWordClassify(pFW);
 208             CELL c;
 209
 210             switch (kind)
 211             {
 212             case LITERAL:
 213                 c = *++pc;
 214                 if (isAFiclWord(pd, c.p))
 215                 {
 216                     FICL_WORD *pLit = (FICL_WORD *)c.p;
 217                     sprintf(cp, "%.*s ( %#lx literal )",
 218                         pLit->nName, pLit->name, (unsigned long)c.u);
 219                 }
 220                 else
 221                     sprintf(cp, "literal %ld (%#lx)",
 222                         (long)c.i, (unsigned long)c.u);
 223                 break;
 224             case STRINGLIT:
 225                 {
 226                     FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
 227                     pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
 228                     sprintf(cp, "s\" %.*s\"", sp->count, sp->text);
 229                 }
 230                 break;
 231             case CSTRINGLIT:
 232                 {
 233                     FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
 234                     pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
 235                     sprintf(cp, "c\" %.*s\"", sp->count, sp->text);
 236                 }
 237                 break;
 238             case IF:
 239                 c = *++pc;
 240                 if (c.i > 0)
 241                     sprintf(cp, "if / while (branch %d)", (int)(pc+c.i-param0));
 242                 else
 243                     sprintf(cp, "until (branch %d)",      (int)(pc+c.i-param0));
 244                 break;
 245             case BRANCH:
 246                 c = *++pc;
 247                 if (c.i == 0)
 248                     sprintf(cp, "repeat (branch %d)",     (int)(pc+c.i-param0));
 249                 else if (c.i == 1)
 250                     sprintf(cp, "else (branch %d)",       (int)(pc+c.i-param0));
 251                 else
 252                     sprintf(cp, "endof (branch %d)",      (int)(pc+c.i-param0));
 253                 break;
 254
 255             case OF:
 256                 c = *++pc;
 257                 sprintf(cp, "of (branch %d)",       (int)(pc+c.i-param0));
 258                 break;
 259
 260             case QDO:
 261                 c = *++pc;
 262                 sprintf(cp, "?do (leave %d)",  (int)((CELL *)c.p-param0));
 263                 break;
 264             case DO:
 265                 c = *++pc;
 266                 sprintf(cp, "do (leave %d)", (int)((CELL *)c.p-param0));
 267                 break;
 268             case LOOP:
 269                 c = *++pc;
 270                 sprintf(cp, "loop (branch %d)", (int)(pc+c.i-param0));
 271                 break;
 272             case PLOOP:
 273                 c = *++pc;
 274                 sprintf(cp, "+loop (branch %d)", (int)(pc+c.i-param0));
 275                 break;
 276             default:
 277                 sprintf(cp, "%.*s", pFW->nName, pFW->name);
 278                 break;
 279             }
 280
 281         }
 282         else /* probably not a word - punt and print value */
 283         {
 284             sprintf(cp, "%ld ( %#lx )", (long)pc->i, (unsigned long)pc->u);
 285         }
 286
 287                 vmTextOut(pVM, pVM->pad, 1);
 288     }
 289
 290     vmTextOut(pVM, ";", 1);
 291 }
 292
 293 /*
 294 ** Here's the outer part of the decompiler. It's
 295 ** just a big nested conditional that checks the
 296 ** CFA of the word to decompile for each kind of
 297 ** known word-builder code, and tries to do
 298 ** something appropriate. If the CFA is not recognized,
 299 ** just indicate that it is a primitive.
 300 */
 301 static void seeXT(FICL_VM *pVM)
 302 {
 303     FICL_WORD *pFW;
 304     WORDKIND kind;
 305
 306     pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
 307     kind = ficlWordClassify(pFW);
 308
 309     switch (kind)
 310     {
 311     case COLON:
 312         sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
 313         vmTextOut(pVM, pVM->pad, 1);
 314         seeColon(pVM, pFW->param);
 315         break;
 316
 317     case DOES:
 318         vmTextOut(pVM, "does>", 1);
 319         seeColon(pVM, (CELL *)pFW->param->p);
 320         break;
 321
 322     case CREATE:
 323         vmTextOut(pVM, "create", 1);
 324         break;
 325
 326     case VARIABLE:
 327         sprintf(pVM->pad, "variable = %ld (%#lx)",
 328             (long)pFW->param->i, (unsigned long)pFW->param->u);
 329         vmTextOut(pVM, pVM->pad, 1);
 330         break;
 331
 332 #if FICL_WANT_USER
 333     case USER:
 334         sprintf(pVM->pad, "user variable %ld (%#lx)",
 335             (long)pFW->param->i, (unsigned long)pFW->param->u);
 336         vmTextOut(pVM, pVM->pad, 1);
 337         break;
 338 #endif
 339
 340     case CONSTANT:
 341         sprintf(pVM->pad, "constant = %ld (%#lx)",
 342             (long)pFW->param->i, (unsigned long)pFW->param->u);
 343         vmTextOut(pVM, pVM->pad, 1);
 344
 345     default:
 346         sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
 347         vmTextOut(pVM, pVM->pad, 1);
 348         break;
 349     }
 350
 351     if (pFW->flags & FW_IMMEDIATE)
 352     {
 353         vmTextOut(pVM, "immediate", 1);
 354     }
 355
 356     if (pFW->flags & FW_COMPILE)
 357     {
 358         vmTextOut(pVM, "compile-only", 1);
 359     }
 360
 361     return;
 362 }
 363
 364
 365 static void see(FICL_VM *pVM)
 366 {
 367     ficlTick(pVM);
 368     seeXT(pVM);
 369     return;
 370 }
 371
 372
 373 /**************************************************************************
 374                         f i c l D e b u g X T
 375 ** debug  ( xt -- )
 376 ** Given an xt of a colon definition or a word defined by DOES>, set the
 377 ** VM up to debug the word: push IP, set the xt as the next thing to execute,
 378 ** set a breakpoint at its first instruction, and run to the breakpoint.
 379 ** Note: the semantics of this word are equivalent to "step in"
 380 **************************************************************************/
 381 void ficlDebugXT(FICL_VM *pVM)
 382 {
 383     FICL_WORD *xt    = stackPopPtr(pVM->pStack);
 384     WORDKIND   wk    = ficlWordClassify(xt);
 385
 386     stackPushPtr(pVM->pStack, xt);
 387     seeXT(pVM);
 388
 389     switch (wk)
 390     {
 391     case COLON:
 392     case DOES:
 393         /*
 394         ** Run the colon code and set a breakpoint at the next instruction
 395         */
 396         vmExecute(pVM, xt);
 397         vmSetBreak(pVM, &(pVM->pSys->bpStep));
 398         break;
 399
 400     default:
 401         vmExecute(pVM, xt);
 402         break;
 403     }
 404
 405     return;
 406 }
 407
 408
 409 /**************************************************************************
 410                         s t e p I n
 411 ** FICL
 412 ** Execute the next instruction, stepping into it if it's a colon definition
 413 ** or a does> word. This is the easy kind of step.
 414 **************************************************************************/
 415 void stepIn(FICL_VM *pVM)
 416 {
 417     /*
 418     ** Do one step of the inner loop
 419     */
 420     {
 421         M_VM_STEP(pVM)
 422     }
 423
 424     /*
 425     ** Now set a breakpoint at the next instruction
 426     */
 427     vmSetBreak(pVM, &(pVM->pSys->bpStep));
 428
 429     return;
 430 }
 431
 432
 433 /**************************************************************************
 434                         s t e p O v e r
 435 ** FICL
 436 ** Execute the next instruction atomically. This requires some insight into
 437 ** the memory layout of compiled code. Set a breakpoint at the next instruction
 438 ** in this word, and run until we hit it
 439 **************************************************************************/
 440 void stepOver(FICL_VM *pVM)
 441 {
 442     FICL_WORD *pFW;
 443     WORDKIND kind;
 444     FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
 445     assert(pStep);
 446
 447     pFW = *pVM->ip;
 448     kind = ficlWordClassify(pFW);
 449
 450     switch (kind)
 451     {
 452     case COLON:
 453     case DOES:
 454         /*
 455         ** assume that the next cell holds an instruction
 456         ** set a breakpoint there and return to the inner interp
 457         */
 458         pVM->pSys->bpStep.address = pVM->ip + 1;
 459         pVM->pSys->bpStep.origXT =  pVM->ip[1];
 460         pVM->ip[1] = pStep;
 461         break;
 462
 463     default:
 464         stepIn(pVM);
 465         break;
 466     }
 467
 468     return;
 469 }
 470
 471
 472 /**************************************************************************
 473                         s t e p - b r e a k
 474 ** FICL
 475 ** Handles breakpoints for stepped execution.
 476 ** Upon entry, bpStep contains the address and replaced instruction
 477 ** of the current breakpoint.
 478 ** Clear the breakpoint
 479 ** Get a command from the console.
 480 ** i (step in) - execute the current instruction and set a new breakpoint
 481 **    at the IP
 482 ** o (step over) - execute the current instruction to completion and set
 483 **    a new breakpoint at the IP
 484 ** g (go) - execute the current instruction and exit
 485 ** q (quit) - abort current word
 486 ** b (toggle breakpoint)
 487 **************************************************************************/
 488 void stepBreak(FICL_VM *pVM)
 489 {
 490     STRINGINFO si;
 491     FICL_WORD *pFW;
 492     FICL_WORD *pOnStep;
 493
 494     if (!pVM->fRestart)
 495     {
 496         assert(pVM->pSys->bpStep.address);
 497         assert(pVM->pSys->bpStep.origXT);
 498         /*
 499         ** Clear the breakpoint that caused me to run
 500         ** Restore the original instruction at the breakpoint,
 501         ** and restore the IP
 502         */
 503         pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
 504         *pVM->ip = pVM->pSys->bpStep.origXT;
 505
 506         /*
 507         ** If there's an onStep, do it
 508         */
 509         pOnStep = ficlLookup(pVM->pSys, "on-step");
 510         if (pOnStep)
 511             ficlExecXT(pVM, pOnStep);
 512
 513         /*
 514         ** Print the name of the next instruction
 515         */
 516         pFW = pVM->pSys->bpStep.origXT;
 517         sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
 518 #if 0
 519         if (isPrimitive(pFW))
 520         {
 521             strcat(pVM->pad, " ( primitive )");
 522         }
 523 #endif
 524
 525         vmTextOut(pVM, pVM->pad, 1);
 526         debugPrompt(pVM);
 527     }
 528     else
 529     {
 530         pVM->fRestart = 0;
 531     }
 532
 533     si = vmGetWord(pVM);
 534
 535     if      (!strincmp(si.cp, "i", si.count))
 536     {
 537         stepIn(pVM);
 538     }
 539     else if (!strincmp(si.cp, "g", si.count))
 540     {
 541         return;
 542     }
 543     else if (!strincmp(si.cp, "l", si.count))
 544     {
 545         FICL_WORD *xt;
 546         xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
 547         if (xt)
 548         {
 549             stackPushPtr(pVM->pStack, xt);
 550             seeXT(pVM);
 551         }
 552         else
 553         {
 554             vmTextOut(pVM, "sorry - can't do that", 1);
 555         }
 556         vmThrow(pVM, VM_RESTART);
 557     }
 558     else if (!strincmp(si.cp, "o", si.count))
 559     {
 560         stepOver(pVM);
 561     }
 562     else if (!strincmp(si.cp, "q", si.count))
 563     {
 564         ficlTextOut(pVM, FICL_PROMPT, 0);
 565         vmThrow(pVM, VM_ABORT);
 566     }
 567     else if (!strincmp(si.cp, "x", si.count))
 568     {
 569         /*
 570         ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
 571         */
 572         int ret;
 573         char *cp = pVM->tib.cp + pVM->tib.index;
 574         int count = pVM->tib.end - cp;
 575         FICL_WORD *oldRun = pVM->runningWord;
 576
 577         ret = ficlExecC(pVM, cp, count);
 578
 579         if (ret == VM_OUTOFTEXT)
 580         {
 581             ret = VM_RESTART;
 582             pVM->runningWord = oldRun;
 583             vmTextOut(pVM, "", 1);
 584         }
 585
 586         vmThrow(pVM, ret);
 587     }
 588     else
 589     {
 590         vmTextOut(pVM, "i -- step In", 1);
 591         vmTextOut(pVM, "o -- step Over", 1);
 592         vmTextOut(pVM, "g -- Go (execute to completion)", 1);
 593         vmTextOut(pVM, "l -- List source code", 1);
 594         vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
 595         vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
 596         debugPrompt(pVM);
 597         vmThrow(pVM, VM_RESTART);
 598     }
 599
 600     return;
 601 }
 602
 603
 604 /**************************************************************************
 605                         b y e
 606 ** TOOLS
 607 ** Signal the system to shut down - this causes ficlExec to return
 608 ** VM_USEREXIT. The rest is up to you.
 609 **************************************************************************/
 610 static void bye(FICL_VM *pVM)
 611 {
 612     vmThrow(pVM, VM_USEREXIT);
 613     return;
 614 }
 615
 616
 617 /**************************************************************************
 618                         d i s p l a y S t a c k
 619 ** TOOLS
 620 ** Display the parameter stack (code for ".s")
 621 **************************************************************************/
 622 static void displayPStack(FICL_VM *pVM)
 623 {
 624     FICL_STACK *pStk = pVM->pStack;
 625     int d = stackDepth(pStk);
 626     int i;
 627     CELL *pCell;
 628
 629     vmCheckStack(pVM, 0, 0);
 630
 631     if (d == 0)
 632         vmTextOut(pVM, "(Stack Empty) ", 0);
 633     else
 634     {
 635         pCell = pStk->base;
 636         for (i = 0; i < d; i++)
 637         {
 638             vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
 639             vmTextOut(pVM, " ", 0);
 640         }
 641     }
 642     return;
 643 }
 644
 645
 646 static void displayRStack(FICL_VM *pVM)
 647 {
 648     FICL_STACK *pStk = pVM->rStack;
 649     int d = stackDepth(pStk);
 650     int i;
 651     CELL *pCell;
 652     FICL_DICT *dp = vmGetDict(pVM);
 653
 654     vmCheckStack(pVM, 0, 0);
 655
 656     if (d == 0)
 657         vmTextOut(pVM, "(Stack Empty) ", 0);
 658     else
 659     {
 660         pCell = pStk->base;
 661         for (i = 0; i < d; i++)
 662         {
 663             CELL c = *pCell++;
 664             /*
 665             ** Attempt to find the word that contains the
 666             ** stacked address (as if it is part of a colon definition).
 667             ** If this works, print the name of the word. Otherwise print
 668             ** the value as a number.
 669             */
 670             if (dictIncludes(dp, c.p))
 671             {
 672                 FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
 673                 if (pFW)
 674                 {
 675                     int offset = (CELL *)c.p - &pFW->param[0];
 676                     sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
 677                     vmTextOut(pVM, pVM->pad, 0);
 678                     continue;  /* no need to print the numeric value */
 679                 }
 680             }
 681             vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
 682             vmTextOut(pVM, " ", 0);
 683         }
 684     }
 685
 686     return;
 687 }
 688
 689
 690 /**************************************************************************
 691                         f o r g e t - w i d
 692 **
 693 **************************************************************************/
 694 static void forgetWid(FICL_VM *pVM)
 695 {
 696     FICL_DICT *pDict = vmGetDict(pVM);
 697     FICL_HASH *pHash;
 698
 699     pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
 700     hashForget(pHash, pDict->here);
 701
 702     return;
 703 }
 704
 705
 706 /**************************************************************************
 707                         f o r g e t
 708 ** TOOLS EXT  ( "<spaces>name" -- )
 709 ** Skip leading space delimiters. Parse name delimited by a space.
 710 ** Find name, then delete name from the dictionary along with all
 711 ** words added to the dictionary after name. An ambiguous
 712 ** condition exists if name cannot be found.
 713 **
 714 ** If the Search-Order word set is present, FORGET searches the
 715 ** compilation word list. An ambiguous condition exists if the
 716 ** compilation word list is deleted.
 717 **************************************************************************/
 718 static void forget(FICL_VM *pVM)
 719 {
 720     void *where;
 721     FICL_DICT *pDict = vmGetDict(pVM);
 722     FICL_HASH *pHash = pDict->pCompile;
 723
 724     ficlTick(pVM);
 725     where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
 726     hashForget(pHash, where);
 727     pDict->here = PTRtoCELL where;
 728
 729     return;
 730 }
 731
 732
 733 /**************************************************************************
 734                         l i s t W o r d s
 735 **
 736 **************************************************************************/
 737 #define nCOLWIDTH 8
 738 static void listWords(FICL_VM *pVM)
 739 {
 740     FICL_DICT *dp = vmGetDict(pVM);
 741     FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
 742     FICL_WORD *wp;
 743     int nChars = 0;
 744     int len;
 745     int y = 0;
 746     unsigned i;
 747     int nWords = 0;
 748     char *cp;
 749     char *pPad = pVM->pad;
 750
 751     for (i = 0; i < pHash->size; i++)
 752     {
 753         for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
 754         {
 755             if (wp->nName == 0) /* ignore :noname defs */
 756                 continue;
 757
 758             cp = wp->name;
 759             nChars += sprintf(pPad + nChars, "%s", cp);
 760
 761             if (nChars > 70)
 762             {
 763                 pPad[nChars] = '\0';
 764                 nChars = 0;
 765                 y++;
 766                 if(y>23) {
 767                         y=0;
 768                         vmTextOut(pVM, "--- Press Enter to continue ---",0);
 769                         getchar();
 770                         vmTextOut(pVM,"\r",0);
 771                 }
 772                 vmTextOut(pVM, pPad, 1);
 773             }
 774             else
 775             {
 776                 len = nCOLWIDTH - nChars % nCOLWIDTH;
 777                 while (len-- > 0)
 778                     pPad[nChars++] = ' ';
 779             }
 780
 781             if (nChars > 70)
 782             {
 783                 pPad[nChars] = '\0';
 784                 nChars = 0;
 785                 y++;
 786                 if(y>23) {
 787                         y=0;
 788                         vmTextOut(pVM, "--- Press Enter to continue ---",0);
 789                         getchar();
 790                         vmTextOut(pVM,"\r",0);
 791                 }
 792                 vmTextOut(pVM, pPad, 1);
 793             }
 794         }
 795     }
 796
 797     if (nChars > 0)
 798     {
 799         pPad[nChars] = '\0';
 800         nChars = 0;
 801         vmTextOut(pVM, pPad, 1);
 802     }
 803
 804     sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
 805         nWords, (long) (dp->here - dp->dict), dp->size);
 806     vmTextOut(pVM, pVM->pad, 1);
 807     return;
 808 }
 809
 810
 811 /**************************************************************************
 812                         l i s t E n v
 813 ** Print symbols defined in the environment
 814 **************************************************************************/
 815 static void listEnv(FICL_VM *pVM)
 816 {
 817     FICL_DICT *dp = pVM->pSys->envp;
 818     FICL_HASH *pHash = dp->pForthWords;
 819     FICL_WORD *wp;
 820     unsigned i;
 821     int nWords = 0;
 822
 823     for (i = 0; i < pHash->size; i++)
 824     {
 825         for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
 826         {
 827             vmTextOut(pVM, wp->name, 1);
 828         }
 829     }
 830
 831     sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
 832         nWords, (long) (dp->here - dp->dict), dp->size);
 833     vmTextOut(pVM, pVM->pad, 1);
 834     return;
 835 }
 836
 837
 838 /**************************************************************************
 839                         e n v C o n s t a n t
 840 ** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
 841 ** environment constants...
 842 **************************************************************************/
 843 static void envConstant(FICL_VM *pVM)
 844 {
 845     unsigned value;
 846
 847 #if FICL_ROBUST > 1
 848     vmCheckStack(pVM, 1, 0);
 849 #endif
 850
 851     vmGetWordToPad(pVM);
 852     value = POPUNS();
 853     ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
 854     return;
 855 }
 856
 857 static void env2Constant(FICL_VM *pVM)
 858 {
 859     unsigned v1, v2;
 860
 861 #if FICL_ROBUST > 1
 862     vmCheckStack(pVM, 2, 0);
 863 #endif
 864
 865     vmGetWordToPad(pVM);
 866     v2 = POPUNS();
 867     v1 = POPUNS();
 868     ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
 869     return;
 870 }
 871
 872
 873 /**************************************************************************
 874                         f i c l C o m p i l e T o o l s
 875 ** Builds wordset for debugger and TOOLS optional word set
 876 **************************************************************************/
 877
 878 void ficlCompileTools(FICL_SYSTEM *pSys)
 879 {
 880     FICL_DICT *dp = pSys->dp;
 881     assert (dp);
 882
 883     /*
 884     ** TOOLS and TOOLS EXT
 885     */
 886     dictAppendWord(dp, ".s",        displayPStack,  FW_DEFAULT);
 887     dictAppendWord(dp, "bye",       bye,            FW_DEFAULT);
 888     dictAppendWord(dp, "forget",    forget,         FW_DEFAULT);
 889     dictAppendWord(dp, "see",       see,            FW_DEFAULT);
 890     dictAppendWord(dp, "words",     listWords,      FW_DEFAULT);
 891
 892     /*
 893     ** Set TOOLS environment query values
 894     */
 895     ficlSetEnv(pSys, "tools",            FICL_TRUE);
 896     ficlSetEnv(pSys, "tools-ext",        FICL_FALSE);
 897
 898     /*
 899     ** Ficl extras
 900     */
 901     dictAppendWord(dp, "r.s",       displayRStack,  FW_DEFAULT); /* guy carver */
 902     dictAppendWord(dp, ".env",      listEnv,        FW_DEFAULT);
 903     dictAppendWord(dp, "env-constant",
 904                                     envConstant,    FW_DEFAULT);
 905     dictAppendWord(dp, "env-2constant",
 906                                     env2Constant,   FW_DEFAULT);
 907     dictAppendWord(dp, "debug-xt",  ficlDebugXT,    FW_DEFAULT);
 908     dictAppendWord(dp, "parse-order",
 909                                     ficlListParseSteps,
 910                                                     FW_DEFAULT);
 911     dictAppendWord(dp, "step-break",stepBreak,      FW_DEFAULT);
 912     dictAppendWord(dp, "forget-wid",forgetWid,      FW_DEFAULT);
 913     dictAppendWord(dp, "see-xt",    seeXT,          FW_DEFAULT);
 914
 915     return;
 916 }
 917