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