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