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