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