words.c revision 40989
1/******************************************************************* 2** w o r d s . c 3** Forth Inspired Command Language 4** ANS Forth CORE word-set written in C 5** Author: John Sadler (john_sadler@alum.mit.edu) 6** Created: 19 July 1997 7** 8*******************************************************************/ 9 10#ifdef TESTMAIN 11#include <stdlib.h> 12#include <stdio.h> 13#include <ctype.h> 14#include <fcntl.h> 15#else 16#include <stand.h> 17#endif 18#include <string.h> 19#include "ficl.h" 20#include "math64.h" 21 22static void colonParen(FICL_VM *pVM); 23static void literalIm(FICL_VM *pVM); 24static void interpWord(FICL_VM *pVM, STRINGINFO si); 25 26/* 27** Control structure building words use these 28** strings' addresses as markers on the stack to 29** check for structure completion. 30*/ 31static char doTag[] = "do"; 32static char ifTag[] = "if"; 33static char colonTag[] = "colon"; 34static char leaveTag[] = "leave"; 35static char beginTag[] = "begin"; 36static char whileTag[] = "while"; 37 38/* 39** Pointers to various words in the dictionary 40** -- initialized by ficlCompileCore, below -- 41** for use by compiling words. Colon definitions 42** in ficl are lists of pointers to words. A bit 43** simple-minded... 44*/ 45static FICL_WORD *pBranchParen = NULL; 46static FICL_WORD *pComma = NULL; 47static FICL_WORD *pDoParen = NULL; 48static FICL_WORD *pDoesParen = NULL; 49static FICL_WORD *pExitParen = NULL; 50static FICL_WORD *pIfParen = NULL; 51static FICL_WORD *pInterpret = NULL; 52static FICL_WORD *pLitParen = NULL; 53static FICL_WORD *pLoopParen = NULL; 54static FICL_WORD *pPLoopParen = NULL; 55static FICL_WORD *pQDoParen = NULL; 56static FICL_WORD *pSemiParen = NULL; 57static FICL_WORD *pStore = NULL; 58static FICL_WORD *pStringLit = NULL; 59static FICL_WORD *pType = NULL; 60 61#if FICL_WANT_LOCALS 62static FICL_WORD *pGetLocalParen= NULL; 63static FICL_WORD *pGetLocal0 = NULL; 64static FICL_WORD *pGetLocal1 = NULL; 65static FICL_WORD *pToLocalParen = NULL; 66static FICL_WORD *pToLocal0 = NULL; 67static FICL_WORD *pToLocal1 = NULL; 68static FICL_WORD *pLinkParen = NULL; 69static FICL_WORD *pUnLinkParen = NULL; 70static int nLocals = 0; 71#endif 72 73 74/* 75** C O N T R O L S T R U C T U R E B U I L D E R S 76** 77** Push current dict location for later branch resolution. 78** The location may be either a branch target or a patch address... 79*/ 80static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 81{ 82 stackPushPtr(pVM->pStack, dp->here); 83 stackPushPtr(pVM->pStack, tag); 84 return; 85} 86 87static void markControlTag(FICL_VM *pVM, char *tag) 88{ 89 stackPushPtr(pVM->pStack, tag); 90 return; 91} 92 93static void matchControlTag(FICL_VM *pVM, char *tag) 94{ 95 char *cp = (char *)stackPopPtr(pVM->pStack); 96 if ( strcmp(cp, tag) ) 97 { 98 vmTextOut(pVM, "Warning -- unmatched control word: ", 0); 99 vmTextOut(pVM, tag, 1); 100 } 101 102 return; 103} 104 105/* 106** Expect a branch target address on the param stack, 107** compile a literal offset from the current dict location 108** to the target address 109*/ 110static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 111{ 112 long offset; 113 CELL *patchAddr; 114 115 matchControlTag(pVM, tag); 116 117 patchAddr = (CELL *)stackPopPtr(pVM->pStack); 118 offset = patchAddr - dp->here; 119 dictAppendCell(dp, LVALUEtoCELL(offset)); 120 121 return; 122} 123 124 125/* 126** Expect a branch patch address on the param stack, 127** compile a literal offset from the patch location 128** to the current dict location 129*/ 130static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 131{ 132 long offset; 133 CELL *patchAddr; 134 135 matchControlTag(pVM, tag); 136 137 patchAddr = (CELL *)stackPopPtr(pVM->pStack); 138 offset = dp->here - patchAddr; 139 *patchAddr = LVALUEtoCELL(offset); 140 141 return; 142} 143 144/* 145** Match the tag to the top of the stack. If success, 146** sopy "here" address into the cell whose address is next 147** on the stack. Used by do..leave..loop. 148*/ 149static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 150{ 151 CELL *patchAddr; 152 char *cp; 153 154 cp = stackPopPtr(pVM->pStack); 155 if (strcmp(cp, tag)) 156 { 157 vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); 158 vmTextOut(pVM, tag, 1); 159 } 160 161 patchAddr = (CELL *)stackPopPtr(pVM->pStack); 162 *patchAddr = LVALUEtoCELL(dp->here); 163 164 return; 165} 166 167 168/************************************************************************** 169 i s N u m b e r 170** Attempts to convert the NULL terminated string in the VM's pad to 171** a number using the VM's current base. If successful, pushes the number 172** onto the param stack and returns TRUE. Otherwise, returns FALSE. 173**************************************************************************/ 174 175static int isNumber(FICL_VM *pVM, STRINGINFO si) 176{ 177 INT32 accum = 0; 178 char isNeg = FALSE; 179 unsigned base = pVM->base; 180 char *cp = SI_PTR(si); 181 FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); 182 unsigned ch; 183 unsigned digit; 184 185 if (*cp == '-') 186 { 187 cp++; 188 count--; 189 isNeg = TRUE; 190 } 191 else if ((cp[0] == '0') && (cp[1] == 'x')) 192 { /* detect 0xNNNN format for hex numbers */ 193 cp += 2; 194 count -= 2; 195 base = 16; 196 } 197 198 if (count == 0) 199 return FALSE; 200 201 while (count-- && ((ch = *cp++) != '\0')) 202 { 203 if (ch < '0') 204 return FALSE; 205 206 digit = ch - '0'; 207 208 if (digit > 9) 209 digit = tolower(ch) - 'a' + 10; 210 /* 211 ** Note: following test also catches chars between 9 and a 212 ** because 'digit' is unsigned! 213 */ 214 if (digit >= base) 215 return FALSE; 216 217 accum = accum * base + digit; 218 } 219 220 if (isNeg) 221 accum = -accum; 222 223 stackPushINT32(pVM->pStack, accum); 224 225 return TRUE; 226} 227 228 229/************************************************************************** 230 a d d & f r i e n d s 231** 232**************************************************************************/ 233 234static void add(FICL_VM *pVM) 235{ 236 INT32 i; 237#if FICL_ROBUST > 1 238 vmCheckStack(pVM, 2, 1); 239#endif 240 i = stackPopINT32(pVM->pStack); 241 i += stackGetTop(pVM->pStack).i; 242 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 243 return; 244} 245 246static void sub(FICL_VM *pVM) 247{ 248 INT32 i; 249#if FICL_ROBUST > 1 250 vmCheckStack(pVM, 2, 1); 251#endif 252 i = stackPopINT32(pVM->pStack); 253 i = stackGetTop(pVM->pStack).i - i; 254 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 255 return; 256} 257 258static void mul(FICL_VM *pVM) 259{ 260 INT32 i; 261#if FICL_ROBUST > 1 262 vmCheckStack(pVM, 2, 1); 263#endif 264 i = stackPopINT32(pVM->pStack); 265 i *= stackGetTop(pVM->pStack).i; 266 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 267 return; 268} 269 270static void negate(FICL_VM *pVM) 271{ 272 INT32 i; 273#if FICL_ROBUST > 1 274 vmCheckStack(pVM, 1, 1); 275#endif 276 i = -stackPopINT32(pVM->pStack); 277 stackPushINT32(pVM->pStack, i); 278 return; 279} 280 281static void ficlDiv(FICL_VM *pVM) 282{ 283 INT32 i; 284#if FICL_ROBUST > 1 285 vmCheckStack(pVM, 2, 1); 286#endif 287 i = stackPopINT32(pVM->pStack); 288 i = stackGetTop(pVM->pStack).i / i; 289 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 290 return; 291} 292 293/* 294** slash-mod CORE ( n1 n2 -- n3 n4 ) 295** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 296** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 297** differ in sign, the implementation-defined result returned will be the 298** same as that returned by either the phrase 299** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 300** NOTE: Ficl complies with the second phrase (symmetric division) 301*/ 302static void slashMod(FICL_VM *pVM) 303{ 304 INT64 n1; 305 INT32 n2; 306 INTQR qr; 307 308#if FICL_ROBUST > 1 309 vmCheckStack(pVM, 2, 2); 310#endif 311 n2 = stackPopINT32(pVM->pStack); 312 n1.lo = stackPopINT32(pVM->pStack); 313 i64Extend(n1); 314 315 qr = m64SymmetricDivI(n1, n2); 316 stackPushINT32(pVM->pStack, qr.rem); 317 stackPushINT32(pVM->pStack, qr.quot); 318 return; 319} 320 321static void onePlus(FICL_VM *pVM) 322{ 323 INT32 i; 324#if FICL_ROBUST > 1 325 vmCheckStack(pVM, 1, 1); 326#endif 327 i = stackGetTop(pVM->pStack).i; 328 i += 1; 329 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 330 return; 331} 332 333static void oneMinus(FICL_VM *pVM) 334{ 335 INT32 i; 336#if FICL_ROBUST > 1 337 vmCheckStack(pVM, 1, 1); 338#endif 339 i = stackGetTop(pVM->pStack).i; 340 i -= 1; 341 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 342 return; 343} 344 345static void twoMul(FICL_VM *pVM) 346{ 347 INT32 i; 348#if FICL_ROBUST > 1 349 vmCheckStack(pVM, 1, 1); 350#endif 351 i = stackGetTop(pVM->pStack).i; 352 i *= 2; 353 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 354 return; 355} 356 357static void twoDiv(FICL_VM *pVM) 358{ 359 INT32 i; 360#if FICL_ROBUST > 1 361 vmCheckStack(pVM, 1, 1); 362#endif 363 i = stackGetTop(pVM->pStack).i; 364 i >>= 1; 365 stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 366 return; 367} 368 369static void mulDiv(FICL_VM *pVM) 370{ 371 INT32 x, y, z; 372 INT64 prod; 373#if FICL_ROBUST > 1 374 vmCheckStack(pVM, 3, 1); 375#endif 376 z = stackPopINT32(pVM->pStack); 377 y = stackPopINT32(pVM->pStack); 378 x = stackPopINT32(pVM->pStack); 379 380 prod = m64MulI(x,y); 381 x = m64SymmetricDivI(prod, z).quot; 382 383 stackPushINT32(pVM->pStack, x); 384 return; 385} 386 387 388static void mulDivRem(FICL_VM *pVM) 389{ 390 INT32 x, y, z; 391 INT64 prod; 392 INTQR qr; 393#if FICL_ROBUST > 1 394 vmCheckStack(pVM, 3, 2); 395#endif 396 z = stackPopINT32(pVM->pStack); 397 y = stackPopINT32(pVM->pStack); 398 x = stackPopINT32(pVM->pStack); 399 400 prod = m64MulI(x,y); 401 qr = m64SymmetricDivI(prod, z); 402 403 stackPushINT32(pVM->pStack, qr.rem); 404 stackPushINT32(pVM->pStack, qr.quot); 405 return; 406} 407 408 409/************************************************************************** 410 b y e 411** TOOLS 412** Signal the system to shut down - this causes ficlExec to return 413** VM_USEREXIT. The rest is up to you. 414**************************************************************************/ 415 416static void bye(FICL_VM *pVM) 417{ 418 vmThrow(pVM, VM_USEREXIT); 419 return; 420} 421 422 423/************************************************************************** 424 c o l o n d e f i n i t i o n s 425** Code to begin compiling a colon definition 426** This function sets the state to COMPILE, then creates a 427** new word whose name is the next word in the input stream 428** and whose code is colonParen. 429**************************************************************************/ 430 431static void colon(FICL_VM *pVM) 432{ 433 FICL_DICT *dp = ficlGetDict(); 434 STRINGINFO si = vmGetWord(pVM); 435 436 pVM->state = COMPILE; 437 markControlTag(pVM, colonTag); 438 dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 439#if FICL_WANT_LOCALS 440 nLocals = 0; 441#endif 442 return; 443} 444 445 446/************************************************************************** 447 c o l o n P a r e n 448** This is the code that executes a colon definition. It assumes that the 449** virtual machine is running a "next" loop (See the vm.c 450** for its implementation of member function vmExecute()). The colon 451** code simply copies the address of the first word in the list of words 452** to interpret into IP after saving its old value. When we return to the 453** "next" loop, the virtual machine will call the code for each word in 454** turn. 455** 456**************************************************************************/ 457 458static void colonParen(FICL_VM *pVM) 459{ 460 IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param); 461 vmPushIP(pVM, tempIP); 462 463 return; 464} 465 466 467/************************************************************************** 468 s e m i c o l o n C o I m 469** 470** IMMEDIATE code for ";". This function sets the state to INTERPRET and 471** terminates a word under compilation by appending code for "(;)" to 472** the definition. TO DO: checks for leftover branch target tags on the 473** return stack and complains if any are found. 474**************************************************************************/ 475static void semiParen(FICL_VM *pVM) 476{ 477 vmPopIP(pVM); 478 return; 479} 480 481 482static void semicolonCoIm(FICL_VM *pVM) 483{ 484 FICL_DICT *dp = ficlGetDict(); 485 486 assert(pSemiParen); 487 matchControlTag(pVM, colonTag); 488 489#if FICL_WANT_LOCALS 490 assert(pUnLinkParen); 491 if (nLocals > 0) 492 { 493 FICL_DICT *pLoc = ficlGetLoc(); 494 dictEmpty(pLoc, pLoc->pForthWords->size); 495 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 496 } 497 nLocals = 0; 498#endif 499 500 dictAppendCell(dp, LVALUEtoCELL(pSemiParen)); 501 pVM->state = INTERPRET; 502 dictUnsmudge(dp); 503 return; 504} 505 506 507/************************************************************************** 508 e x i t 509** CORE 510** This function simply pops the previous instruction 511** pointer and returns to the "next" loop. Used for exiting from within 512** a definition. Note that exitParen is identical to semiParen - they 513** are in two different functions so that "see" can correctly identify 514** the end of a colon definition, even if it uses "exit". 515**************************************************************************/ 516static void exitParen(FICL_VM *pVM) 517{ 518 vmPopIP(pVM); 519 return; 520} 521 522static void exitCoIm(FICL_VM *pVM) 523{ 524 FICL_DICT *dp = ficlGetDict(); 525 assert(pExitParen); 526 IGNORE(pVM); 527 528#if FICL_WANT_LOCALS 529 if (nLocals > 0) 530 { 531 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 532 } 533#endif 534 dictAppendCell(dp, LVALUEtoCELL(pExitParen)); 535 return; 536} 537 538 539/************************************************************************** 540 c o n s t a n t P a r e n 541** This is the run-time code for "constant". It simply returns the 542** contents of its word's first data cell. 543** 544**************************************************************************/ 545 546void constantParen(FICL_VM *pVM) 547{ 548 FICL_WORD *pFW = pVM->runningWord; 549#if FICL_ROBUST > 1 550 vmCheckStack(pVM, 0, 1); 551#endif 552 stackPush(pVM->pStack, pFW->param[0]); 553 return; 554} 555 556void twoConstParen(FICL_VM *pVM) 557{ 558 FICL_WORD *pFW = pVM->runningWord; 559#if FICL_ROBUST > 1 560 vmCheckStack(pVM, 0, 2); 561#endif 562 stackPush(pVM->pStack, pFW->param[0]); /* lo */ 563 stackPush(pVM->pStack, pFW->param[1]); /* hi */ 564 return; 565} 566 567 568/************************************************************************** 569 c o n s t a n t 570** IMMEDIATE 571** Compiles a constant into the dictionary. Constants return their 572** value when invoked. Expects a value on top of the parm stack. 573**************************************************************************/ 574 575static void constant(FICL_VM *pVM) 576{ 577 FICL_DICT *dp = ficlGetDict(); 578 STRINGINFO si = vmGetWord(pVM); 579 580#if FICL_ROBUST > 1 581 vmCheckStack(pVM, 1, 0); 582#endif 583 dictAppendWord2(dp, si, constantParen, FW_DEFAULT); 584 dictAppendCell(dp, stackPop(pVM->pStack)); 585 return; 586} 587 588 589static void twoConstant(FICL_VM *pVM) 590{ 591 FICL_DICT *dp = ficlGetDict(); 592 STRINGINFO si = vmGetWord(pVM); 593 CELL c; 594 595#if FICL_ROBUST > 1 596 vmCheckStack(pVM, 2, 0); 597#endif 598 c = stackPop(pVM->pStack); 599 dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT); 600 dictAppendCell(dp, stackPop(pVM->pStack)); 601 dictAppendCell(dp, c); 602 return; 603} 604 605 606/************************************************************************** 607 d i s p l a y C e l l 608** Drop and print the contents of the cell at the top of the param 609** stack 610**************************************************************************/ 611 612static void displayCell(FICL_VM *pVM) 613{ 614 CELL c; 615#if FICL_ROBUST > 1 616 vmCheckStack(pVM, 1, 0); 617#endif 618 c = stackPop(pVM->pStack); 619 ltoa((c).i, pVM->pad, pVM->base); 620 strcat(pVM->pad, " "); 621 vmTextOut(pVM, pVM->pad, 0); 622 return; 623} 624 625static void uDot(FICL_VM *pVM) 626{ 627 UNS32 u; 628#if FICL_ROBUST > 1 629 vmCheckStack(pVM, 1, 0); 630#endif 631 u = stackPopUNS32(pVM->pStack); 632 ultoa(u, pVM->pad, pVM->base); 633 strcat(pVM->pad, " "); 634 vmTextOut(pVM, pVM->pad, 0); 635 return; 636} 637 638 639static void hexDot(FICL_VM *pVM) 640{ 641 UNS32 u; 642#if FICL_ROBUST > 1 643 vmCheckStack(pVM, 1, 0); 644#endif 645 u = stackPopUNS32(pVM->pStack); 646 ultoa(u, pVM->pad, 16); 647 strcat(pVM->pad, " "); 648 vmTextOut(pVM, pVM->pad, 0); 649 return; 650} 651 652 653/************************************************************************** 654 d i s p l a y S t a c k 655** Display the parameter stack (code for ".s") 656**************************************************************************/ 657 658static void displayStack(FICL_VM *pVM) 659{ 660 int d = stackDepth(pVM->pStack); 661 int i; 662 CELL *pCell; 663 664 vmCheckStack(pVM, 0, 0); 665 666 if (d == 0) 667 vmTextOut(pVM, "(Stack Empty)", 1); 668 else 669 { 670 pCell = pVM->pStack->sp; 671 for (i = 0; i < d; i++) 672 { 673 vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1); 674 } 675 } 676} 677 678 679/************************************************************************** 680 d u p & f r i e n d s 681** 682**************************************************************************/ 683 684static void depth(FICL_VM *pVM) 685{ 686 int i; 687#if FICL_ROBUST > 1 688 vmCheckStack(pVM, 0, 1); 689#endif 690 i = stackDepth(pVM->pStack); 691 stackPushINT32(pVM->pStack, i); 692 return; 693} 694 695 696static void drop(FICL_VM *pVM) 697{ 698#if FICL_ROBUST > 1 699 vmCheckStack(pVM, 1, 0); 700#endif 701 stackDrop(pVM->pStack, 1); 702 return; 703} 704 705 706static void twoDrop(FICL_VM *pVM) 707{ 708#if FICL_ROBUST > 1 709 vmCheckStack(pVM, 2, 0); 710#endif 711 stackDrop(pVM->pStack, 2); 712 return; 713} 714 715 716static void dup(FICL_VM *pVM) 717{ 718#if FICL_ROBUST > 1 719 vmCheckStack(pVM, 1, 2); 720#endif 721 stackPick(pVM->pStack, 0); 722 return; 723} 724 725 726static void twoDup(FICL_VM *pVM) 727{ 728#if FICL_ROBUST > 1 729 vmCheckStack(pVM, 2, 4); 730#endif 731 stackPick(pVM->pStack, 1); 732 stackPick(pVM->pStack, 1); 733 return; 734} 735 736 737static void over(FICL_VM *pVM) 738{ 739#if FICL_ROBUST > 1 740 vmCheckStack(pVM, 2, 3); 741#endif 742 stackPick(pVM->pStack, 1); 743 return; 744} 745 746static void twoOver(FICL_VM *pVM) 747{ 748#if FICL_ROBUST > 1 749 vmCheckStack(pVM, 4, 6); 750#endif 751 stackPick(pVM->pStack, 3); 752 stackPick(pVM->pStack, 3); 753 return; 754} 755 756 757static void pick(FICL_VM *pVM) 758{ 759 CELL c = stackPop(pVM->pStack); 760#if FICL_ROBUST > 1 761 vmCheckStack(pVM, c.i+1, c.i+2); 762#endif 763 stackPick(pVM->pStack, c.i); 764 return; 765} 766 767 768static void questionDup(FICL_VM *pVM) 769{ 770 CELL c; 771#if FICL_ROBUST > 1 772 vmCheckStack(pVM, 1, 2); 773#endif 774 c = stackGetTop(pVM->pStack); 775 776 if (c.i != 0) 777 stackPick(pVM->pStack, 0); 778 779 return; 780} 781 782 783static void roll(FICL_VM *pVM) 784{ 785 int i = stackPop(pVM->pStack).i; 786 i = (i > 0) ? i : 0; 787#if FICL_ROBUST > 1 788 vmCheckStack(pVM, i+1, i+1); 789#endif 790 stackRoll(pVM->pStack, i); 791 return; 792} 793 794 795static void minusRoll(FICL_VM *pVM) 796{ 797 int i = stackPop(pVM->pStack).i; 798 i = (i > 0) ? i : 0; 799#if FICL_ROBUST > 1 800 vmCheckStack(pVM, i+1, i+1); 801#endif 802 stackRoll(pVM->pStack, -i); 803 return; 804} 805 806 807static void rot(FICL_VM *pVM) 808{ 809#if FICL_ROBUST > 1 810 vmCheckStack(pVM, 3, 3); 811#endif 812 stackRoll(pVM->pStack, 2); 813 return; 814} 815 816 817static void swap(FICL_VM *pVM) 818{ 819#if FICL_ROBUST > 1 820 vmCheckStack(pVM, 2, 2); 821#endif 822 stackRoll(pVM->pStack, 1); 823 return; 824} 825 826 827static void twoSwap(FICL_VM *pVM) 828{ 829#if FICL_ROBUST > 1 830 vmCheckStack(pVM, 4, 4); 831#endif 832 stackRoll(pVM->pStack, 3); 833 stackRoll(pVM->pStack, 3); 834 return; 835} 836 837 838/************************************************************************** 839 e m i t & f r i e n d s 840** 841**************************************************************************/ 842 843static void emit(FICL_VM *pVM) 844{ 845 char *cp = pVM->pad; 846 int i; 847 848#if FICL_ROBUST > 1 849 vmCheckStack(pVM, 1, 0); 850#endif 851 i = stackPopINT32(pVM->pStack); 852 cp[0] = (char)i; 853 cp[1] = '\0'; 854 vmTextOut(pVM, cp, 0); 855 return; 856} 857 858 859static void cr(FICL_VM *pVM) 860{ 861 vmTextOut(pVM, "", 1); 862 return; 863} 864 865 866static void commentLine(FICL_VM *pVM) 867{ 868 char *cp = vmGetInBuf(pVM); 869 char ch = *cp; 870 871 while ((ch != '\0') && (ch != '\r') && (ch != '\n')) 872 { 873 ch = *++cp; 874 } 875 876 /* 877 ** Cope with DOS or UNIX-style EOLs - 878 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, 879 ** and point cp to next char. If EOL is \0, we're done. 880 */ 881 if (ch != '\0') 882 { 883 cp++; 884 885 if ( (ch != *cp) 886 && ((*cp == '\r') || (*cp == '\n')) ) 887 cp++; 888 } 889 890 vmUpdateTib(pVM, cp); 891 return; 892} 893 894 895/* 896** paren CORE 897** Compilation: Perform the execution semantics given below. 898** Execution: ( "ccc<paren>" -- ) 899** Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 900** The number of characters in ccc may be zero to the number of characters 901** in the parse area. 902** 903*/ 904static void commentHang(FICL_VM *pVM) 905{ 906 vmParseString(pVM, ')'); 907 return; 908} 909 910 911/************************************************************************** 912 F E T C H & S T O R E 913** 914**************************************************************************/ 915 916static void fetch(FICL_VM *pVM) 917{ 918 CELL *pCell; 919#if FICL_ROBUST > 1 920 vmCheckStack(pVM, 1, 1); 921#endif 922 pCell = (CELL *)stackPopPtr(pVM->pStack); 923 stackPush(pVM->pStack, *pCell); 924 return; 925} 926 927/* 928** two-fetch CORE ( a-addr -- x1 x2 ) 929** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and 930** x1 at the next consecutive cell. It is equivalent to the sequence 931** DUP CELL+ @ SWAP @ . 932*/ 933static void twoFetch(FICL_VM *pVM) 934{ 935 CELL *pCell; 936#if FICL_ROBUST > 1 937 vmCheckStack(pVM, 1, 2); 938#endif 939 pCell = (CELL *)stackPopPtr(pVM->pStack); 940 stackPush(pVM->pStack, *pCell++); 941 stackPush(pVM->pStack, *pCell); 942 swap(pVM); 943 return; 944} 945 946/* 947** store CORE ( x a-addr -- ) 948** Store x at a-addr. 949*/ 950static void store(FICL_VM *pVM) 951{ 952 CELL *pCell; 953#if FICL_ROBUST > 1 954 vmCheckStack(pVM, 2, 0); 955#endif 956 pCell = (CELL *)stackPopPtr(pVM->pStack); 957 *pCell = stackPop(pVM->pStack); 958} 959 960/* 961** two-store CORE ( x1 x2 a-addr -- ) 962** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the 963** next consecutive cell. It is equivalent to the sequence 964** SWAP OVER ! CELL+ ! . 965*/ 966static void twoStore(FICL_VM *pVM) 967{ 968 CELL *pCell; 969#if FICL_ROBUST > 1 970 vmCheckStack(pVM, 3, 0); 971#endif 972 pCell = (CELL *)stackPopPtr(pVM->pStack); 973 *pCell++ = stackPop(pVM->pStack); 974 *pCell = stackPop(pVM->pStack); 975} 976 977static void plusStore(FICL_VM *pVM) 978{ 979 CELL *pCell; 980#if FICL_ROBUST > 1 981 vmCheckStack(pVM, 2, 0); 982#endif 983 pCell = (CELL *)stackPopPtr(pVM->pStack); 984 pCell->i += stackPop(pVM->pStack).i; 985} 986 987 988static void wFetch(FICL_VM *pVM) 989{ 990 UNS16 *pw; 991#if FICL_ROBUST > 1 992 vmCheckStack(pVM, 1, 1); 993#endif 994 pw = (UNS16 *)stackPopPtr(pVM->pStack); 995 stackPushUNS32(pVM->pStack, (UNS32)*pw); 996 return; 997} 998 999static void wStore(FICL_VM *pVM) 1000{ 1001 UNS16 *pw; 1002#if FICL_ROBUST > 1 1003 vmCheckStack(pVM, 2, 0); 1004#endif 1005 pw = (UNS16 *)stackPopPtr(pVM->pStack); 1006 *pw = (UNS16)(stackPop(pVM->pStack).u); 1007} 1008 1009static void cFetch(FICL_VM *pVM) 1010{ 1011 UNS8 *pc; 1012#if FICL_ROBUST > 1 1013 vmCheckStack(pVM, 1, 1); 1014#endif 1015 pc = (UNS8 *)stackPopPtr(pVM->pStack); 1016 stackPushUNS32(pVM->pStack, (UNS32)*pc); 1017 return; 1018} 1019 1020static void cStore(FICL_VM *pVM) 1021{ 1022 UNS8 *pc; 1023#if FICL_ROBUST > 1 1024 vmCheckStack(pVM, 2, 0); 1025#endif 1026 pc = (UNS8 *)stackPopPtr(pVM->pStack); 1027 *pc = (UNS8)(stackPop(pVM->pStack).u); 1028} 1029 1030 1031/************************************************************************** 1032 i f C o I m 1033** IMMEDIATE 1034** Compiles code for a conditional branch into the dictionary 1035** and pushes the branch patch address on the stack for later 1036** patching by ELSE or THEN/ENDIF. 1037**************************************************************************/ 1038 1039static void ifCoIm(FICL_VM *pVM) 1040{ 1041 FICL_DICT *dp = ficlGetDict(); 1042 1043 assert(pIfParen); 1044 1045 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 1046 markBranch(dp, pVM, ifTag); 1047 dictAppendUNS32(dp, 1); 1048 return; 1049} 1050 1051 1052/************************************************************************** 1053 i f P a r e n 1054** Runtime code to do "if" or "until": pop a flag from the stack, 1055** fall through if true, branch if false. Probably ought to be 1056** called (not?branch) since it does "branch if false". 1057**************************************************************************/ 1058 1059static void ifParen(FICL_VM *pVM) 1060{ 1061 UNS32 flag; 1062 1063#if FICL_ROBUST > 1 1064 vmCheckStack(pVM, 1, 0); 1065#endif 1066 flag = stackPopUNS32(pVM->pStack); 1067 1068 if (flag) 1069 { /* fall through */ 1070 vmBranchRelative(pVM, 1); 1071 } 1072 else 1073 { /* take branch (to else/endif/begin) */ 1074 vmBranchRelative(pVM, (int)(*pVM->ip)); 1075 } 1076 1077 return; 1078} 1079 1080 1081/************************************************************************** 1082 e l s e C o I m 1083** 1084** IMMEDIATE -- compiles an "else"... 1085** 1) Compile a branch and a patch address; the address gets patched 1086** by "endif" to point past the "else" code. 1087** 2) Pop the the "if" patch address 1088** 3) Patch the "if" branch to point to the current compile address. 1089** 4) Push the "else" patch address. ("endif" patches this to jump past 1090** the "else" code. 1091**************************************************************************/ 1092 1093static void elseCoIm(FICL_VM *pVM) 1094{ 1095 CELL *patchAddr; 1096 int offset; 1097 FICL_DICT *dp = ficlGetDict(); 1098 1099 assert(pBranchParen); 1100 /* (1) compile branch runtime */ 1101 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 1102 matchControlTag(pVM, ifTag); 1103 patchAddr = 1104 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ 1105 markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */ 1106 dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */ 1107 offset = dp->here - patchAddr; 1108 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ 1109 1110 return; 1111} 1112 1113 1114/************************************************************************** 1115 b r a n c h P a r e n 1116** 1117** Runtime for "(branch)" -- expects a literal offset in the next 1118** compilation address, and branches to that location. 1119**************************************************************************/ 1120 1121static void branchParen(FICL_VM *pVM) 1122{ 1123 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1124 return; 1125} 1126 1127 1128/************************************************************************** 1129 e n d i f C o I m 1130** 1131**************************************************************************/ 1132 1133static void endifCoIm(FICL_VM *pVM) 1134{ 1135 FICL_DICT *dp = ficlGetDict(); 1136 resolveForwardBranch(dp, pVM, ifTag); 1137 return; 1138} 1139 1140 1141/************************************************************************** 1142 i n t e r p r e t 1143** This is the "user interface" of a Forth. It does the following: 1144** while there are words in the VM's Text Input Buffer 1145** Copy next word into the pad (vmGetWord) 1146** Attempt to find the word in the dictionary (dictLookup) 1147** If successful, execute the word. 1148** Otherwise, attempt to convert the word to a number (isNumber) 1149** If successful, push the number onto the parameter stack. 1150** Otherwise, print an error message and exit loop... 1151** End Loop 1152** 1153** From the standard, section 3.4 1154** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall 1155** repeat the following steps until either the parse area is empty or an 1156** ambiguous condition exists: 1157** a) Skip leading spaces and parse a name (see 3.4.1); 1158**************************************************************************/ 1159 1160static void interpret(FICL_VM *pVM) 1161{ 1162 STRINGINFO si = vmGetWord0(pVM); 1163 assert(pVM); 1164 1165 vmBranchRelative(pVM, -1); 1166 1167 /* 1168 // Get next word...if out of text, we're done. 1169 */ 1170 if (si.count == 0) 1171 { 1172 vmThrow(pVM, VM_OUTOFTEXT); 1173 } 1174 1175 interpWord(pVM, si); 1176 1177 1178 return; /* back to inner interpreter */ 1179} 1180 1181/************************************************************************** 1182** From the standard, section 3.4 1183** b) Search the dictionary name space (see 3.4.2). If a definition name 1184** matching the string is found: 1185** 1.if interpreting, perform the interpretation semantics of the definition 1186** (see 3.4.3.2), and continue at a); 1187** 2.if compiling, perform the compilation semantics of the definition 1188** (see 3.4.3.3), and continue at a). 1189** 1190** c) If a definition name matching the string is not found, attempt to 1191** convert the string to a number (see 3.4.1.3). If successful: 1192** 1.if interpreting, place the number on the data stack, and continue at a); 1193** 2.if compiling, compile code that when executed will place the number on 1194** the stack (see 6.1.1780 LITERAL), and continue at a); 1195** 1196** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 1197**************************************************************************/ 1198static void interpWord(FICL_VM *pVM, STRINGINFO si) 1199{ 1200 FICL_DICT *dp = ficlGetDict(); 1201 FICL_WORD *tempFW; 1202 1203#if FICL_ROBUST 1204 dictCheck(dp, pVM, 0); 1205 vmCheckStack(pVM, 0, 0); 1206#endif 1207 1208#if FICL_WANT_LOCALS 1209 if (nLocals > 0) 1210 { 1211 tempFW = dictLookupLoc(dp, si); 1212 } 1213 else 1214#endif 1215 tempFW = dictLookup(dp, si); 1216 1217 if (pVM->state == INTERPRET) 1218 { 1219 if (tempFW != NULL) 1220 { 1221 if (wordIsCompileOnly(tempFW)) 1222 { 1223 vmThrowErr(pVM, "Error: Compile only!"); 1224 } 1225 1226 vmExecute(pVM, tempFW); 1227 } 1228 1229 else if (!isNumber(pVM, si)) 1230 { 1231 int i = SI_COUNT(si); 1232 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1233 } 1234 } 1235 1236 else /* (pVM->state == COMPILE) */ 1237 { 1238 if (tempFW != NULL) 1239 { 1240 if (wordIsImmediate(tempFW)) 1241 { 1242 vmExecute(pVM, tempFW); 1243 } 1244 else 1245 { 1246 dictAppendCell(dp, LVALUEtoCELL(tempFW)); 1247 } 1248 } 1249 else if (isNumber(pVM, si)) 1250 { 1251 literalIm(pVM); 1252 } 1253 else 1254 { 1255 int i = SI_COUNT(si); 1256 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1257 } 1258 } 1259 1260 return; 1261} 1262 1263 1264/************************************************************************** 1265 l i t e r a l P a r e n 1266** 1267** This is the runtime for (literal). It assumes that it is part of a colon 1268** definition, and that the next CELL contains a value to be pushed on the 1269** parameter stack at runtime. This code is compiled by "literal". 1270** 1271**************************************************************************/ 1272 1273static void literalParen(FICL_VM *pVM) 1274{ 1275#if FICL_ROBUST > 1 1276 vmCheckStack(pVM, 0, 1); 1277#endif 1278 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip)); 1279 vmBranchRelative(pVM, 1); 1280 return; 1281} 1282 1283 1284/************************************************************************** 1285 l i t e r a l I m 1286** 1287** IMMEDIATE code for "literal". This function gets a value from the stack 1288** and compiles it into the dictionary preceded by the code for "(literal)". 1289** IMMEDIATE 1290**************************************************************************/ 1291 1292static void literalIm(FICL_VM *pVM) 1293{ 1294 FICL_DICT *dp = ficlGetDict(); 1295 assert(pLitParen); 1296 1297 dictAppendCell(dp, LVALUEtoCELL(pLitParen)); 1298 dictAppendCell(dp, stackPop(pVM->pStack)); 1299 1300 return; 1301} 1302 1303 1304/************************************************************************** 1305 l i s t W o r d s 1306** 1307**************************************************************************/ 1308#define nCOLWIDTH 8 1309static void listWords(FICL_VM *pVM) 1310{ 1311 FICL_DICT *dp = ficlGetDict(); 1312 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; 1313 FICL_WORD *wp; 1314 int nChars = 0; 1315 int len; 1316 unsigned i; 1317 int nWords = 0; 1318 char *cp; 1319 char *pPad = pVM->pad; 1320 1321 for (i = 0; i < pHash->size; i++) 1322 { 1323 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1324 { 1325 if (wp->nName == 0) /* ignore :noname defs */ 1326 continue; 1327 1328 cp = wp->name; 1329 nChars += sprintf(pPad + nChars, "%s", cp); 1330 1331 if (nChars > 70) 1332 { 1333 pPad[nChars] = '\0'; 1334 nChars = 0; 1335 vmTextOut(pVM, pPad, 1); 1336 } 1337 else 1338 { 1339 len = nCOLWIDTH - nChars % nCOLWIDTH; 1340 while (len-- > 0) 1341 pPad[nChars++] = ' '; 1342 } 1343 1344 if (nChars > 70) 1345 { 1346 pPad[nChars] = '\0'; 1347 nChars = 0; 1348 vmTextOut(pVM, pPad, 1); 1349 } 1350 } 1351 } 1352 1353 if (nChars > 0) 1354 { 1355 pPad[nChars] = '\0'; 1356 nChars = 0; 1357 vmTextOut(pVM, pPad, 1); 1358 } 1359 1360 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total", 1361 nWords, dp->here - dp->dict, dp->size); 1362 vmTextOut(pVM, pVM->pad, 1); 1363 return; 1364} 1365 1366 1367static void listEnv(FICL_VM *pVM) 1368{ 1369 FICL_DICT *dp = ficlGetEnv(); 1370 FICL_HASH *pHash = dp->pForthWords; 1371 FICL_WORD *wp; 1372 unsigned i; 1373 int nWords = 0; 1374 1375 for (i = 0; i < pHash->size; i++) 1376 { 1377 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1378 { 1379 vmTextOut(pVM, wp->name, 1); 1380 } 1381 } 1382 1383 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total", 1384 nWords, dp->here - dp->dict, dp->size); 1385 vmTextOut(pVM, pVM->pad, 1); 1386 return; 1387} 1388 1389 1390/************************************************************************** 1391 l o g i c a n d c o m p a r i s o n s 1392** 1393**************************************************************************/ 1394 1395static void zeroEquals(FICL_VM *pVM) 1396{ 1397 CELL c; 1398#if FICL_ROBUST > 1 1399 vmCheckStack(pVM, 1, 1); 1400#endif 1401 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0); 1402 stackPush(pVM->pStack, c); 1403 return; 1404} 1405 1406static void zeroLess(FICL_VM *pVM) 1407{ 1408 CELL c; 1409#if FICL_ROBUST > 1 1410 vmCheckStack(pVM, 1, 1); 1411#endif 1412 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0); 1413 stackPush(pVM->pStack, c); 1414 return; 1415} 1416 1417static void zeroGreater(FICL_VM *pVM) 1418{ 1419 CELL c; 1420#if FICL_ROBUST > 1 1421 vmCheckStack(pVM, 1, 1); 1422#endif 1423 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0); 1424 stackPush(pVM->pStack, c); 1425 return; 1426} 1427 1428static void isEqual(FICL_VM *pVM) 1429{ 1430 CELL x, y; 1431 1432#if FICL_ROBUST > 1 1433 vmCheckStack(pVM, 2, 1); 1434#endif 1435 x = stackPop(pVM->pStack); 1436 y = stackPop(pVM->pStack); 1437 stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i)); 1438 return; 1439} 1440 1441static void isLess(FICL_VM *pVM) 1442{ 1443 CELL x, y; 1444#if FICL_ROBUST > 1 1445 vmCheckStack(pVM, 2, 1); 1446#endif 1447 y = stackPop(pVM->pStack); 1448 x = stackPop(pVM->pStack); 1449 stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i)); 1450 return; 1451} 1452 1453static void uIsLess(FICL_VM *pVM) 1454{ 1455 UNS32 u1, u2; 1456#if FICL_ROBUST > 1 1457 vmCheckStack(pVM, 2, 1); 1458#endif 1459 u2 = stackPopUNS32(pVM->pStack); 1460 u1 = stackPopUNS32(pVM->pStack); 1461 stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2)); 1462 return; 1463} 1464 1465static void isGreater(FICL_VM *pVM) 1466{ 1467 CELL x, y; 1468#if FICL_ROBUST > 1 1469 vmCheckStack(pVM, 2, 1); 1470#endif 1471 y = stackPop(pVM->pStack); 1472 x = stackPop(pVM->pStack); 1473 stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i)); 1474 return; 1475} 1476 1477static void bitwiseAnd(FICL_VM *pVM) 1478{ 1479 CELL x, y; 1480#if FICL_ROBUST > 1 1481 vmCheckStack(pVM, 2, 1); 1482#endif 1483 x = stackPop(pVM->pStack); 1484 y = stackPop(pVM->pStack); 1485 stackPushINT32(pVM->pStack, x.i & y.i); 1486 return; 1487} 1488 1489static void bitwiseOr(FICL_VM *pVM) 1490{ 1491 CELL x, y; 1492#if FICL_ROBUST > 1 1493 vmCheckStack(pVM, 2, 1); 1494#endif 1495 x = stackPop(pVM->pStack); 1496 y = stackPop(pVM->pStack); 1497 stackPushINT32(pVM->pStack, x.i | y.i); 1498 return; 1499} 1500 1501static void bitwiseXor(FICL_VM *pVM) 1502{ 1503 CELL x, y; 1504#if FICL_ROBUST > 1 1505 vmCheckStack(pVM, 2, 1); 1506#endif 1507 x = stackPop(pVM->pStack); 1508 y = stackPop(pVM->pStack); 1509 stackPushINT32(pVM->pStack, x.i ^ y.i); 1510 return; 1511} 1512 1513static void bitwiseNot(FICL_VM *pVM) 1514{ 1515 CELL x; 1516#if FICL_ROBUST > 1 1517 vmCheckStack(pVM, 1, 1); 1518#endif 1519 x = stackPop(pVM->pStack); 1520 stackPushINT32(pVM->pStack, ~x.i); 1521 return; 1522} 1523 1524 1525/************************************************************************** 1526 D o / L o o p 1527** do -- IMMEDIATE COMPILE ONLY 1528** Compiles code to initialize a loop: compile (do), 1529** allot space to hold the "leave" address, push a branch 1530** target address for the loop. 1531** (do) -- runtime for "do" 1532** pops index and limit from the p stack and moves them 1533** to the r stack, then skips to the loop body. 1534** loop -- IMMEDIATE COMPILE ONLY 1535** +loop 1536** Compiles code for the test part of a loop: 1537** compile (loop), resolve forward branch from "do", and 1538** copy "here" address to the "leave" address allotted by "do" 1539** i,j,k -- COMPILE ONLY 1540** Runtime: Push loop indices on param stack (i is innermost loop...) 1541** Note: each loop has three values on the return stack: 1542** ( R: leave limit index ) 1543** "leave" is the absolute address of the next cell after the loop 1544** limit and index are the loop control variables. 1545** leave -- COMPILE ONLY 1546** Runtime: pop the loop control variables, then pop the 1547** "leave" address and jump (absolute) there. 1548**************************************************************************/ 1549 1550static void doCoIm(FICL_VM *pVM) 1551{ 1552 FICL_DICT *dp = ficlGetDict(); 1553 1554 assert(pDoParen); 1555 1556 dictAppendCell(dp, LVALUEtoCELL(pDoParen)); 1557 /* 1558 ** Allot space for a pointer to the end 1559 ** of the loop - "leave" uses this... 1560 */ 1561 markBranch(dp, pVM, leaveTag); 1562 dictAppendUNS32(dp, 0); 1563 /* 1564 ** Mark location of head of loop... 1565 */ 1566 markBranch(dp, pVM, doTag); 1567 1568 return; 1569} 1570 1571 1572static void doParen(FICL_VM *pVM) 1573{ 1574 CELL index, limit; 1575#if FICL_ROBUST > 1 1576 vmCheckStack(pVM, 2, 0); 1577#endif 1578 index = stackPop(pVM->pStack); 1579 limit = stackPop(pVM->pStack); 1580 1581 /* copy "leave" target addr to stack */ 1582 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1583 stackPush(pVM->rStack, limit); 1584 stackPush(pVM->rStack, index); 1585 1586 return; 1587} 1588 1589 1590static void qDoCoIm(FICL_VM *pVM) 1591{ 1592 FICL_DICT *dp = ficlGetDict(); 1593 1594 assert(pQDoParen); 1595 1596 dictAppendCell(dp, LVALUEtoCELL(pQDoParen)); 1597 /* 1598 ** Allot space for a pointer to the end 1599 ** of the loop - "leave" uses this... 1600 */ 1601 markBranch(dp, pVM, leaveTag); 1602 dictAppendUNS32(dp, 0); 1603 /* 1604 ** Mark location of head of loop... 1605 */ 1606 markBranch(dp, pVM, doTag); 1607 1608 return; 1609} 1610 1611 1612static void qDoParen(FICL_VM *pVM) 1613{ 1614 CELL index, limit; 1615#if FICL_ROBUST > 1 1616 vmCheckStack(pVM, 2, 0); 1617#endif 1618 index = stackPop(pVM->pStack); 1619 limit = stackPop(pVM->pStack); 1620 1621 /* copy "leave" target addr to stack */ 1622 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1623 1624 if (limit.u == index.u) 1625 { 1626 vmPopIP(pVM); 1627 } 1628 else 1629 { 1630 stackPush(pVM->rStack, limit); 1631 stackPush(pVM->rStack, index); 1632 } 1633 1634 return; 1635} 1636 1637 1638/* 1639** Runtime code to break out of a do..loop construct 1640** Drop the loop control variables; the branch address 1641** past "loop" is next on the return stack. 1642*/ 1643static void leaveCo(FICL_VM *pVM) 1644{ 1645 /* almost unloop */ 1646 stackDrop(pVM->rStack, 2); 1647 /* exit */ 1648 vmPopIP(pVM); 1649 return; 1650} 1651 1652 1653static void unloopCo(FICL_VM *pVM) 1654{ 1655 stackDrop(pVM->rStack, 3); 1656 return; 1657} 1658 1659 1660static void loopCoIm(FICL_VM *pVM) 1661{ 1662 FICL_DICT *dp = ficlGetDict(); 1663 1664 assert(pLoopParen); 1665 1666 dictAppendCell(dp, LVALUEtoCELL(pLoopParen)); 1667 resolveBackBranch(dp, pVM, doTag); 1668 resolveAbsBranch(dp, pVM, leaveTag); 1669 return; 1670} 1671 1672 1673static void plusLoopCoIm(FICL_VM *pVM) 1674{ 1675 FICL_DICT *dp = ficlGetDict(); 1676 1677 assert(pPLoopParen); 1678 1679 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen)); 1680 resolveBackBranch(dp, pVM, doTag); 1681 resolveAbsBranch(dp, pVM, leaveTag); 1682 return; 1683} 1684 1685 1686static void loopParen(FICL_VM *pVM) 1687{ 1688 INT32 index = stackGetTop(pVM->rStack).i; 1689 INT32 limit = stackFetch(pVM->rStack, 1).i; 1690 1691 index++; 1692 1693 if (index >= limit) 1694 { 1695 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1696 vmBranchRelative(pVM, 1); /* fall through the loop */ 1697 } 1698 else 1699 { /* update index, branch to loop head */ 1700 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1701 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1702 } 1703 1704 return; 1705} 1706 1707 1708static void plusLoopParen(FICL_VM *pVM) 1709{ 1710 INT32 index = stackGetTop(pVM->rStack).i; 1711 INT32 limit = stackFetch(pVM->rStack, 1).i; 1712 INT32 increment = stackPop(pVM->pStack).i; 1713 int flag; 1714 1715 index += increment; 1716 1717 if (increment < 0) 1718 flag = (index < limit); 1719 else 1720 flag = (index >= limit); 1721 1722 if (flag) 1723 { 1724 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1725 vmBranchRelative(pVM, 1); /* fall through the loop */ 1726 } 1727 else 1728 { /* update index, branch to loop head */ 1729 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1730 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1731 } 1732 1733 return; 1734} 1735 1736 1737static void loopICo(FICL_VM *pVM) 1738{ 1739 CELL index = stackGetTop(pVM->rStack); 1740 stackPush(pVM->pStack, index); 1741 1742 return; 1743} 1744 1745 1746static void loopJCo(FICL_VM *pVM) 1747{ 1748 CELL index = stackFetch(pVM->rStack, 3); 1749 stackPush(pVM->pStack, index); 1750 1751 return; 1752} 1753 1754 1755static void loopKCo(FICL_VM *pVM) 1756{ 1757 CELL index = stackFetch(pVM->rStack, 6); 1758 stackPush(pVM->pStack, index); 1759 1760 return; 1761} 1762 1763 1764/************************************************************************** 1765 r e t u r n s t a c k 1766** 1767**************************************************************************/ 1768 1769static void toRStack(FICL_VM *pVM) 1770{ 1771 stackPush(pVM->rStack, stackPop(pVM->pStack)); 1772 return; 1773} 1774 1775static void fromRStack(FICL_VM *pVM) 1776{ 1777 stackPush(pVM->pStack, stackPop(pVM->rStack)); 1778 return; 1779} 1780 1781static void fetchRStack(FICL_VM *pVM) 1782{ 1783 stackPush(pVM->pStack, stackGetTop(pVM->rStack)); 1784 return; 1785} 1786 1787 1788/************************************************************************** 1789 v a r i a b l e 1790** 1791**************************************************************************/ 1792 1793static void variableParen(FICL_VM *pVM) 1794{ 1795 FICL_WORD *fw = pVM->runningWord; 1796 stackPushPtr(pVM->pStack, fw->param); 1797 return; 1798} 1799 1800 1801static void variable(FICL_VM *pVM) 1802{ 1803 FICL_DICT *dp = ficlGetDict(); 1804 STRINGINFO si = vmGetWord(pVM); 1805 1806 dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 1807 dictAllotCells(dp, 1); 1808 return; 1809} 1810 1811 1812 1813/************************************************************************** 1814 b a s e & f r i e n d s 1815** 1816**************************************************************************/ 1817 1818static void base(FICL_VM *pVM) 1819{ 1820 CELL *pBase = (CELL *)(&pVM->base); 1821 stackPush(pVM->pStack, LVALUEtoCELL(pBase)); 1822 return; 1823} 1824 1825 1826static void decimal(FICL_VM *pVM) 1827{ 1828 pVM->base = 10; 1829 return; 1830} 1831 1832 1833static void hex(FICL_VM *pVM) 1834{ 1835 pVM->base = 16; 1836 return; 1837} 1838 1839 1840/************************************************************************** 1841 a l l o t & f r i e n d s 1842** 1843**************************************************************************/ 1844 1845static void allot(FICL_VM *pVM) 1846{ 1847 FICL_DICT *dp = ficlGetDict(); 1848 INT32 i = stackPopINT32(pVM->pStack); 1849#if FICL_ROBUST 1850 dictCheck(dp, pVM, i); 1851#endif 1852 dictAllot(dp, i); 1853 return; 1854} 1855 1856 1857static void here(FICL_VM *pVM) 1858{ 1859 FICL_DICT *dp = ficlGetDict(); 1860 stackPushPtr(pVM->pStack, dp->here); 1861 return; 1862} 1863 1864 1865static void comma(FICL_VM *pVM) 1866{ 1867 FICL_DICT *dp = ficlGetDict(); 1868 CELL c = stackPop(pVM->pStack); 1869 dictAppendCell(dp, c); 1870 return; 1871} 1872 1873 1874static void cComma(FICL_VM *pVM) 1875{ 1876 FICL_DICT *dp = ficlGetDict(); 1877 char c = (char)stackPopINT32(pVM->pStack); 1878 dictAppendChar(dp, c); 1879 return; 1880} 1881 1882 1883static void cells(FICL_VM *pVM) 1884{ 1885 INT32 i = stackPopINT32(pVM->pStack); 1886 stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL)); 1887 return; 1888} 1889 1890 1891static void cellPlus(FICL_VM *pVM) 1892{ 1893 char *cp = stackPopPtr(pVM->pStack); 1894 stackPushPtr(pVM->pStack, cp + sizeof (CELL)); 1895 return; 1896} 1897 1898 1899/************************************************************************** 1900 t i c k 1901** tick CORE ( "<spaces>name" -- xt ) 1902** Skip leading space delimiters. Parse name delimited by a space. Find 1903** name and return xt, the execution token for name. An ambiguous condition 1904** exists if name is not found. 1905**************************************************************************/ 1906static void tick(FICL_VM *pVM) 1907{ 1908 FICL_WORD *pFW = NULL; 1909 STRINGINFO si = vmGetWord(pVM); 1910 1911 pFW = dictLookup(ficlGetDict(), si); 1912 if (!pFW) 1913 { 1914 int i = SI_COUNT(si); 1915 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1916 } 1917 stackPushPtr(pVM->pStack, pFW); 1918 return; 1919} 1920 1921 1922static void bracketTickCoIm(FICL_VM *pVM) 1923{ 1924 tick(pVM); 1925 literalIm(pVM); 1926 1927 return; 1928} 1929 1930 1931/************************************************************************** 1932 p o s t p o n e 1933** Lookup the next word in the input stream and compile code to 1934** insert it into definitions created by the resulting word 1935** (defers compilation, even of immediate words) 1936**************************************************************************/ 1937 1938static void postponeCoIm(FICL_VM *pVM) 1939{ 1940 FICL_DICT *dp = ficlGetDict(); 1941 FICL_WORD *pFW; 1942 assert(pComma); 1943 1944 tick(pVM); 1945 pFW = stackGetTop(pVM->pStack).p; 1946 if (wordIsImmediate(pFW)) 1947 { 1948 dictAppendCell(dp, stackPop(pVM->pStack)); 1949 } 1950 else 1951 { 1952 literalIm(pVM); 1953 dictAppendCell(dp, LVALUEtoCELL(pComma)); 1954 } 1955 1956 return; 1957} 1958 1959 1960 1961/************************************************************************** 1962 e x e c u t e 1963** Pop an execution token (pointer to a word) off the stack and 1964** run it 1965**************************************************************************/ 1966 1967static void execute(FICL_VM *pVM) 1968{ 1969 FICL_WORD *pFW; 1970#if FICL_ROBUST > 1 1971 vmCheckStack(pVM, 1, 0); 1972#endif 1973 1974 pFW = stackPopPtr(pVM->pStack); 1975 vmExecute(pVM, pFW); 1976 1977 return; 1978} 1979 1980 1981/************************************************************************** 1982 i m m e d i a t e 1983** Make the most recently compiled word IMMEDIATE -- it executes even 1984** in compile state (most often used for control compiling words 1985** such as IF, THEN, etc) 1986**************************************************************************/ 1987 1988static void immediate(FICL_VM *pVM) 1989{ 1990 IGNORE(pVM); 1991 dictSetImmediate(ficlGetDict()); 1992 return; 1993} 1994 1995 1996static void compileOnly(FICL_VM *pVM) 1997{ 1998 IGNORE(pVM); 1999 dictSetFlags(ficlGetDict(), FW_COMPILE, 0); 2000 return; 2001} 2002 2003 2004/************************************************************************** 2005 d o t Q u o t e 2006** IMMEDIATE word that compiles a string literal for later display 2007** Compile stringLit, then copy the bytes of the string from the TIB 2008** to the dictionary. Backpatch the count byte and align the dictionary. 2009** 2010** stringlit: Fetch the count from the dictionary, then push the address 2011** and count on the stack. Finally, update ip to point to the first 2012** aligned address after the string text. 2013**************************************************************************/ 2014 2015static void stringLit(FICL_VM *pVM) 2016{ 2017 FICL_STRING *sp = (FICL_STRING *)(pVM->ip); 2018 FICL_COUNT count = sp->count; 2019 char *cp = sp->text; 2020 stackPushPtr(pVM->pStack, cp); 2021 stackPushUNS32(pVM->pStack, count); 2022 cp += count + 1; 2023 cp = alignPtr(cp); 2024 pVM->ip = (IPTYPE)(void *)cp; 2025 return; 2026} 2027 2028static void dotQuoteCoIm(FICL_VM *pVM) 2029{ 2030 FICL_DICT *dp = ficlGetDict(); 2031 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2032 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2033 dictAlign(dp); 2034 dictAppendCell(dp, LVALUEtoCELL(pType)); 2035 return; 2036} 2037 2038 2039static void dotParen(FICL_VM *pVM) 2040{ 2041 char *pSrc = vmGetInBuf(pVM); 2042 char *pDest = pVM->pad; 2043 char ch; 2044 2045 pSrc = skipSpace(pSrc); 2046 2047 for (ch = *pSrc; (ch != '\0') && (ch != ')'); ch = *++pSrc) 2048 *pDest++ = ch; 2049 2050 *pDest = '\0'; 2051 if (ch == ')') 2052 pSrc++; 2053 2054 vmTextOut(pVM, pVM->pad, 0); 2055 vmUpdateTib(pVM, pSrc); 2056 2057 return; 2058} 2059 2060 2061/************************************************************************** 2062 s l i t e r a l 2063** STRING 2064** Interpretation: Interpretation semantics for this word are undefined. 2065** Compilation: ( c-addr1 u -- ) 2066** Append the run-time semantics given below to the current definition. 2067** Run-time: ( -- c-addr2 u ) 2068** Return c-addr2 u describing a string consisting of the characters 2069** specified by c-addr1 u during compilation. A program shall not alter 2070** the returned string. 2071**************************************************************************/ 2072static void sLiteralCoIm(FICL_VM *pVM) 2073{ 2074 FICL_DICT *dp = ficlGetDict(); 2075 char *cp, *cpDest; 2076 UNS32 u; 2077 u = stackPopUNS32(pVM->pStack); 2078 cp = stackPopPtr(pVM->pStack); 2079 2080 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2081 cpDest = (char *) dp->here; 2082 *cpDest++ = (char) u; 2083 2084 for (; u > 0; --u) 2085 { 2086 *cpDest++ = *cp++; 2087 } 2088 2089 *cpDest++ = 0; 2090 dp->here = PTRtoCELL alignPtr(cpDest); 2091 return; 2092} 2093 2094 2095/************************************************************************** 2096 s t a t e 2097** Return the address of the VM's state member (must be sized the 2098** same as a CELL for this reason) 2099**************************************************************************/ 2100static void state(FICL_VM *pVM) 2101{ 2102 stackPushPtr(pVM->pStack, &pVM->state); 2103 return; 2104} 2105 2106 2107/************************************************************************** 2108 c r e a t e . . . d o e s > 2109** Make a new word in the dictionary with the run-time effect of 2110** a variable (push my address), but with extra space allotted 2111** for use by does> . 2112**************************************************************************/ 2113 2114static void createParen(FICL_VM *pVM) 2115{ 2116 CELL *pCell = pVM->runningWord->param; 2117 stackPushPtr(pVM->pStack, pCell+1); 2118 return; 2119} 2120 2121 2122static void create(FICL_VM *pVM) 2123{ 2124 FICL_DICT *dp = ficlGetDict(); 2125 STRINGINFO si = vmGetWord(pVM); 2126 2127 dictAppendWord2(dp, si, createParen, FW_DEFAULT); 2128 dictAllotCells(dp, 1); 2129 return; 2130} 2131 2132 2133static void doDoes(FICL_VM *pVM) 2134{ 2135 CELL *pCell = pVM->runningWord->param; 2136 IPTYPE tempIP = (IPTYPE)((*pCell).p); 2137 stackPushPtr(pVM->pStack, pCell+1); 2138 vmPushIP(pVM, tempIP); 2139 return; 2140} 2141 2142 2143static void doesParen(FICL_VM *pVM) 2144{ 2145 FICL_DICT *dp = ficlGetDict(); 2146 dp->smudge->code = doDoes; 2147 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); 2148 vmPopIP(pVM); 2149 return; 2150} 2151 2152 2153static void doesCoIm(FICL_VM *pVM) 2154{ 2155 FICL_DICT *dp = ficlGetDict(); 2156#if FICL_WANT_LOCALS 2157 assert(pUnLinkParen); 2158 if (nLocals > 0) 2159 { 2160 FICL_DICT *pLoc = ficlGetLoc(); 2161 dictEmpty(pLoc, pLoc->pForthWords->size); 2162 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 2163 } 2164 2165 nLocals = 0; 2166#endif 2167 IGNORE(pVM); 2168 2169 dictAppendCell(dp, LVALUEtoCELL(pDoesParen)); 2170 return; 2171} 2172 2173 2174/************************************************************************** 2175 t o b o d y 2176** to-body CORE ( xt -- a-addr ) 2177** a-addr is the data-field address corresponding to xt. An ambiguous 2178** condition exists if xt is not for a word defined via CREATE. 2179**************************************************************************/ 2180static void toBody(FICL_VM *pVM) 2181{ 2182 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2183 stackPushPtr(pVM->pStack, pFW->param + 1); 2184 return; 2185} 2186 2187 2188/* 2189** from-body ficl ( a-addr -- xt ) 2190** Reverse effect of >body 2191*/ 2192static void fromBody(FICL_VM *pVM) 2193{ 2194 char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD); 2195 stackPushPtr(pVM->pStack, ptr); 2196 return; 2197} 2198 2199 2200/* 2201** >name ficl ( xt -- c-addr u ) 2202** Push the address and length of a word's name given its address 2203** xt. 2204*/ 2205static void toName(FICL_VM *pVM) 2206{ 2207 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2208 stackPushPtr(pVM->pStack, pFW->name); 2209 stackPushUNS32(pVM->pStack, pFW->nName); 2210 return; 2211} 2212 2213 2214/************************************************************************** 2215 l b r a c k e t e t c 2216** 2217**************************************************************************/ 2218 2219static void lbracketCoIm(FICL_VM *pVM) 2220{ 2221 pVM->state = INTERPRET; 2222 return; 2223} 2224 2225 2226static void rbracket(FICL_VM *pVM) 2227{ 2228 pVM->state = COMPILE; 2229 return; 2230} 2231 2232 2233/************************************************************************** 2234 p i c t u r e d n u m e r i c w o r d s 2235** 2236** less-number-sign CORE ( -- ) 2237** Initialize the pictured numeric output conversion process. 2238** (clear the pad) 2239**************************************************************************/ 2240static void lessNumberSign(FICL_VM *pVM) 2241{ 2242 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2243 sp->count = 0; 2244 return; 2245} 2246 2247/* 2248** number-sign CORE ( ud1 -- ud2 ) 2249** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 2250** n. (n is the least-significant digit of ud1.) Convert n to external form 2251** and add the resulting character to the beginning of the pictured numeric 2252** output string. An ambiguous condition exists if # executes outside of a 2253** <# #> delimited number conversion. 2254*/ 2255static void numberSign(FICL_VM *pVM) 2256{ 2257 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2258 UNS64 u; 2259 UNS16 rem; 2260 2261 u = u64Pop(pVM->pStack); 2262 rem = m64UMod(&u, (UNS16)(pVM->base)); 2263 sp->text[sp->count++] = digit_to_char(rem); 2264 u64Push(pVM->pStack, u); 2265 return; 2266} 2267 2268/* 2269** number-sign-greater CORE ( xd -- c-addr u ) 2270** Drop xd. Make the pictured numeric output string available as a character 2271** string. c-addr and u specify the resulting character string. A program 2272** may replace characters within the string. 2273*/ 2274static void numberSignGreater(FICL_VM *pVM) 2275{ 2276 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2277 sp->text[sp->count] = '\0'; 2278 strrev(sp->text); 2279 stackDrop(pVM->pStack, 2); 2280 stackPushPtr(pVM->pStack, sp->text); 2281 stackPushUNS32(pVM->pStack, sp->count); 2282 return; 2283} 2284 2285/* 2286** number-sign-s CORE ( ud1 -- ud2 ) 2287** Convert one digit of ud1 according to the rule for #. Continue conversion 2288** until the quotient is zero. ud2 is zero. An ambiguous condition exists if 2289** #S executes outside of a <# #> delimited number conversion. 2290** TO DO: presently does not use ud1 hi cell - use it! 2291*/ 2292static void numberSignS(FICL_VM *pVM) 2293{ 2294 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2295 UNS64 u; 2296 UNS16 rem; 2297 2298 u = u64Pop(pVM->pStack); 2299 2300 do 2301 { 2302 rem = m64UMod(&u, (UNS16)(pVM->base)); 2303 sp->text[sp->count++] = digit_to_char(rem); 2304 } 2305 while (u.hi || u.lo); 2306 2307 u64Push(pVM->pStack, u); 2308 return; 2309} 2310 2311/* 2312** HOLD CORE ( char -- ) 2313** Add char to the beginning of the pictured numeric output string. An ambiguous 2314** condition exists if HOLD executes outside of a <# #> delimited number conversion. 2315*/ 2316static void hold(FICL_VM *pVM) 2317{ 2318 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2319 int i = stackPopINT32(pVM->pStack); 2320 sp->text[sp->count++] = (char) i; 2321 return; 2322} 2323 2324/* 2325** SIGN CORE ( n -- ) 2326** If n is negative, add a minus sign to the beginning of the pictured 2327** numeric output string. An ambiguous condition exists if SIGN 2328** executes outside of a <# #> delimited number conversion. 2329*/ 2330static void sign(FICL_VM *pVM) 2331{ 2332 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2333 int i = stackPopINT32(pVM->pStack); 2334 if (i < 0) 2335 sp->text[sp->count++] = '-'; 2336 return; 2337} 2338 2339 2340/************************************************************************** 2341 t o N u m b e r 2342** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 2343** ud2 is the unsigned result of converting the characters within the 2344** string specified by c-addr1 u1 into digits, using the number in BASE, 2345** and adding each into ud1 after multiplying ud1 by the number in BASE. 2346** Conversion continues left-to-right until a character that is not 2347** convertible, including any + or -, is encountered or the string is 2348** entirely converted. c-addr2 is the location of the first unconverted 2349** character or the first character past the end of the string if the string 2350** was entirely converted. u2 is the number of unconverted characters in the 2351** string. An ambiguous condition exists if ud2 overflows during the 2352** conversion. 2353** TO DO: presently does not use ud1 hi cell - use it! 2354**************************************************************************/ 2355static void toNumber(FICL_VM *pVM) 2356{ 2357 UNS32 count = stackPopUNS32(pVM->pStack); 2358 char *cp = (char *)stackPopPtr(pVM->pStack); 2359 UNS64 accum; 2360 UNS32 base = pVM->base; 2361 UNS32 ch; 2362 UNS32 digit; 2363 2364 accum = u64Pop(pVM->pStack); 2365 2366 for (ch = *cp; count > 0; ch = *++cp, count--) 2367 { 2368 if (ch < '0') 2369 break; 2370 2371 digit = ch - '0'; 2372 2373 if (digit > 9) 2374 digit = tolower(ch) - 'a' + 10; 2375 /* 2376 ** Note: following test also catches chars between 9 and a 2377 ** because 'digit' is unsigned! 2378 */ 2379 if (digit >= base) 2380 break; 2381 2382 accum = m64Mac(accum, base, digit); 2383 } 2384 2385 u64Push(pVM->pStack, accum); 2386 stackPushPtr (pVM->pStack, cp); 2387 stackPushUNS32(pVM->pStack, count); 2388 2389 return; 2390} 2391 2392 2393 2394/************************************************************************** 2395 q u i t & a b o r t 2396** quit CORE ( -- ) ( R: i*x -- ) 2397** Empty the return stack, store zero in SOURCE-ID if it is present, make 2398** the user input device the input source, and enter interpretation state. 2399** Do not display a message. Repeat the following: 2400** 2401** Accept a line from the input source into the input buffer, set >IN to 2402** zero, and interpret. 2403** Display the implementation-defined system prompt if in 2404** interpretation state, all processing has been completed, and no 2405** ambiguous condition exists. 2406**************************************************************************/ 2407 2408static void quit(FICL_VM *pVM) 2409{ 2410 vmThrow(pVM, VM_QUIT); 2411 return; 2412} 2413 2414 2415static void ficlAbort(FICL_VM *pVM) 2416{ 2417 vmThrow(pVM, VM_ERREXIT); 2418 return; 2419} 2420 2421 2422/************************************************************************** 2423 a c c e p t 2424** accept CORE ( c-addr +n1 -- +n2 ) 2425** Receive a string of at most +n1 characters. An ambiguous condition 2426** exists if +n1 is zero or greater than 32,767. Display graphic characters 2427** as they are received. A program that depends on the presence or absence 2428** of non-graphic characters in the string has an environmental dependency. 2429** The editing functions, if any, that the system performs in order to 2430** construct the string are implementation-defined. 2431** 2432** (Although the standard text doesn't say so, I assume that the intent 2433** of 'accept' is to store the string at the address specified on 2434** the stack.) 2435** Implementation: if there's more text in the TIB, use it. Otherwise 2436** throw out for more text. Copy characters up to the max count into the 2437** address given, and return the number of actual characters copied. 2438**************************************************************************/ 2439static void accept(FICL_VM *pVM) 2440{ 2441 UNS32 count, len; 2442 char *cp; 2443 char *pBuf = vmGetInBuf(pVM); 2444 2445 len = strlen(pBuf); 2446 if (len == 0) 2447 vmThrow(pVM, VM_RESTART); 2448 /* OK - now we have something in the text buffer - use it */ 2449 count = stackPopUNS32(pVM->pStack); 2450 cp = stackPopPtr(pVM->pStack); 2451 2452 strncpy(cp, vmGetInBuf(pVM), count); 2453 len = (count < len) ? count : len; 2454 pBuf += len; 2455 vmUpdateTib(pVM, pBuf); 2456 stackPushUNS32(pVM->pStack, len); 2457 2458 return; 2459} 2460 2461 2462/************************************************************************** 2463 a l i g n 2464** 6.1.0705 ALIGN CORE ( -- ) 2465** If the data-space pointer is not aligned, reserve enough space to 2466** align it. 2467**************************************************************************/ 2468static void align(FICL_VM *pVM) 2469{ 2470 FICL_DICT *dp = ficlGetDict(); 2471 IGNORE(pVM); 2472 dictAlign(dp); 2473 return; 2474} 2475 2476 2477/************************************************************************** 2478 a l i g n e d 2479** 2480**************************************************************************/ 2481static void aligned(FICL_VM *pVM) 2482{ 2483 void *addr = stackPopPtr(pVM->pStack); 2484 stackPushPtr(pVM->pStack, alignPtr(addr)); 2485 return; 2486} 2487 2488 2489/************************************************************************** 2490 b e g i n & f r i e n d s 2491** Indefinite loop control structures 2492** A.6.1.0760 BEGIN 2493** Typical use: 2494** : X ... BEGIN ... test UNTIL ; 2495** or 2496** : X ... BEGIN ... test WHILE ... REPEAT ; 2497**************************************************************************/ 2498static void beginCoIm(FICL_VM *pVM) 2499{ 2500 FICL_DICT *dp = ficlGetDict(); 2501 markBranch(dp, pVM, beginTag); 2502 return; 2503} 2504 2505static void untilCoIm(FICL_VM *pVM) 2506{ 2507 FICL_DICT *dp = ficlGetDict(); 2508 2509 assert(pIfParen); 2510 2511 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2512 resolveBackBranch(dp, pVM, beginTag); 2513 return; 2514} 2515 2516static void whileCoIm(FICL_VM *pVM) 2517{ 2518 FICL_DICT *dp = ficlGetDict(); 2519 2520 assert(pIfParen); 2521 2522 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2523 markBranch(dp, pVM, whileTag); 2524 twoSwap(pVM); 2525 dictAppendUNS32(dp, 1); 2526 return; 2527} 2528 2529static void repeatCoIm(FICL_VM *pVM) 2530{ 2531 FICL_DICT *dp = ficlGetDict(); 2532 2533 assert(pBranchParen); 2534 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 2535 2536 /* expect "begin" branch marker */ 2537 resolveBackBranch(dp, pVM, beginTag); 2538 /* expect "while" branch marker */ 2539 resolveForwardBranch(dp, pVM, whileTag); 2540 return; 2541} 2542 2543 2544/************************************************************************** 2545 c h a r & f r i e n d s 2546** 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 2547** Skip leading space delimiters. Parse name delimited by a space. 2548** Put the value of its first character onto the stack. 2549** 2550** bracket-char CORE 2551** Interpretation: Interpretation semantics for this word are undefined. 2552** Compilation: ( "<spaces>name" -- ) 2553** Skip leading space delimiters. Parse name delimited by a space. 2554** Append the run-time semantics given below to the current definition. 2555** Run-time: ( -- char ) 2556** Place char, the value of the first character of name, on the stack. 2557**************************************************************************/ 2558static void ficlChar(FICL_VM *pVM) 2559{ 2560 STRINGINFO si = vmGetWord(pVM); 2561 stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0])); 2562 2563 return; 2564} 2565 2566static void charCoIm(FICL_VM *pVM) 2567{ 2568 ficlChar(pVM); 2569 literalIm(pVM); 2570 return; 2571} 2572 2573/************************************************************************** 2574 c h a r P l u s 2575** char-plus CORE ( c-addr1 -- c-addr2 ) 2576** Add the size in address units of a character to c-addr1, giving c-addr2. 2577**************************************************************************/ 2578static void charPlus(FICL_VM *pVM) 2579{ 2580 char *cp = stackPopPtr(pVM->pStack); 2581 stackPushPtr(pVM->pStack, cp + 1); 2582 return; 2583} 2584 2585/************************************************************************** 2586 c h a r s 2587** chars CORE ( n1 -- n2 ) 2588** n2 is the size in address units of n1 characters. 2589** For most processors, this function can be a no-op. To guarantee 2590** portability, we'll multiply by sizeof (char). 2591**************************************************************************/ 2592#if defined (_M_IX86) 2593#pragma warning(disable: 4127) 2594#endif 2595static void ficlChars(FICL_VM *pVM) 2596{ 2597 if (sizeof (char) > 1) 2598 { 2599 INT32 i = stackPopINT32(pVM->pStack); 2600 stackPushINT32(pVM->pStack, i * sizeof (char)); 2601 } 2602 /* otherwise no-op! */ 2603 return; 2604} 2605#if defined (_M_IX86) 2606#pragma warning(default: 4127) 2607#endif 2608 2609 2610/************************************************************************** 2611 c o u n t 2612** COUNT CORE ( c-addr1 -- c-addr2 u ) 2613** Return the character string specification for the counted string stored 2614** at c-addr1. c-addr2 is the address of the first character after c-addr1. 2615** u is the contents of the character at c-addr1, which is the length in 2616** characters of the string at c-addr2. 2617**************************************************************************/ 2618static void count(FICL_VM *pVM) 2619{ 2620 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2621 stackPushPtr(pVM->pStack, sp->text); 2622 stackPushUNS32(pVM->pStack, sp->count); 2623 return; 2624} 2625 2626/************************************************************************** 2627 e n v i r o n m e n t ? 2628** environment-query CORE ( c-addr u -- false | i*x true ) 2629** c-addr is the address of a character string and u is the string's 2630** character count. u may have a value in the range from zero to an 2631** implementation-defined maximum which shall not be less than 31. The 2632** character string should contain a keyword from 3.2.6 Environmental 2633** queries or the optional word sets to be checked for correspondence 2634** with an attribute of the present environment. If the system treats the 2635** attribute as unknown, the returned flag is false; otherwise, the flag 2636** is true and the i*x returned is of the type specified in the table for 2637** the attribute queried. 2638**************************************************************************/ 2639static void environmentQ(FICL_VM *pVM) 2640{ 2641 FICL_DICT *envp = ficlGetEnv(); 2642 FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack); 2643 char *cp = stackPopPtr(pVM->pStack); 2644 FICL_WORD *pFW; 2645 STRINGINFO si; 2646 2647 SI_PSZ(si, cp); 2648 pFW = dictLookup(envp, si); 2649 2650 if (pFW != NULL) 2651 { 2652 vmExecute(pVM, pFW); 2653 stackPushINT32(pVM->pStack, FICL_TRUE); 2654 } 2655 else 2656 { 2657 stackPushINT32(pVM->pStack, FICL_FALSE); 2658 } 2659 2660 return; 2661} 2662 2663/************************************************************************** 2664 e v a l u a t e 2665** EVALUATE CORE ( i*x c-addr u -- j*x ) 2666** Save the current input source specification. Store minus-one (-1) in 2667** SOURCE-ID if it is present. Make the string described by c-addr and u 2668** both the input source and input buffer, set >IN to zero, and interpret. 2669** When the parse area is empty, restore the prior input source 2670** specification. Other stack effects are due to the words EVALUATEd. 2671** 2672** DEFICIENCY: this version does not handle errors or restarts. 2673**************************************************************************/ 2674static void evaluate(FICL_VM *pVM) 2675{ 2676 UNS32 count = stackPopUNS32(pVM->pStack); 2677 char *cp = stackPopPtr(pVM->pStack); 2678 CELL id; 2679 2680 IGNORE(count); 2681 id = pVM->sourceID; 2682 pVM->sourceID.i = -1; 2683 vmPushIP(pVM, &pInterpret); 2684 ficlExec(pVM, cp); 2685 vmPopIP(pVM); 2686 pVM->sourceID = id; 2687 return; 2688} 2689 2690 2691/************************************************************************** 2692 s t r i n g q u o t e 2693** Intrpreting: get string delimited by a quote from the input stream, 2694** copy to a scratch area, and put its count and address on the stack. 2695** Compiling: compile code to push the address and count of a string 2696** literal, compile the string from the input stream, and align the dict 2697** pointer. 2698**************************************************************************/ 2699static void stringQuoteIm(FICL_VM *pVM) 2700{ 2701 FICL_DICT *dp = ficlGetDict(); 2702 2703 if (pVM->state == INTERPRET) 2704 { 2705 FICL_STRING *sp = (FICL_STRING *) dp->here; 2706 vmGetString(pVM, sp, '\"'); 2707 stackPushPtr(pVM->pStack, sp->text); 2708 stackPushUNS32(pVM->pStack, sp->count); 2709 } 2710 else /* COMPILE state */ 2711 { 2712 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2713 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2714 dictAlign(dp); 2715 } 2716 2717 return; 2718} 2719 2720/************************************************************************** 2721 t y p e 2722** Pop count and char address from stack and print the designated string. 2723**************************************************************************/ 2724static void type(FICL_VM *pVM) 2725{ 2726 UNS32 count = stackPopUNS32(pVM->pStack); 2727 char *cp = stackPopPtr(pVM->pStack); 2728 2729 /* 2730 ** Since we don't have an output primitive for a counted string 2731 ** (oops), make sure the string is null terminated. If not, copy 2732 ** and terminate it. 2733 */ 2734 if (cp[count] != '\0') 2735 { 2736 char *pDest = (char *)ficlGetDict()->here; 2737 if (cp != pDest) 2738 strncpy(pDest, cp, count); 2739 2740 pDest[count] = '\0'; 2741 cp = pDest; 2742 } 2743 2744 vmTextOut(pVM, cp, 0); 2745 return; 2746} 2747 2748/************************************************************************** 2749 w o r d 2750** word CORE ( char "<chars>ccc<char>" -- c-addr ) 2751** Skip leading delimiters. Parse characters ccc delimited by char. An 2752** ambiguous condition exists if the length of the parsed string is greater 2753** than the implementation-defined length of a counted string. 2754** 2755** c-addr is the address of a transient region containing the parsed word 2756** as a counted string. If the parse area was empty or contained no 2757** characters other than the delimiter, the resulting string has a zero 2758** length. A space, not included in the length, follows the string. A 2759** program may replace characters within the string. 2760** NOTE! Ficl also NULL-terminates the dest string. 2761**************************************************************************/ 2762static void ficlWord(FICL_VM *pVM) 2763{ 2764 FICL_STRING *sp = (FICL_STRING *)pVM->pad; 2765 char delim = (char)stackPopINT32(pVM->pStack); 2766 STRINGINFO si; 2767 2768 si = vmParseString(pVM, delim); 2769 2770 if (SI_COUNT(si) > nPAD-1) 2771 SI_SETLEN(si, nPAD-1); 2772 2773 sp->count = (FICL_COUNT)SI_COUNT(si); 2774 strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); 2775 strcat(sp->text, " "); 2776 2777 stackPushPtr(pVM->pStack, sp); 2778 return; 2779} 2780 2781 2782/************************************************************************** 2783 p a r s e - w o r d 2784** ficl PARSE-WORD ( <spaces>name -- c-addr u ) 2785** Skip leading spaces and parse name delimited by a space. c-addr is the 2786** address within the input buffer and u is the length of the selected 2787** string. If the parse area is empty, the resulting string has a zero length. 2788**************************************************************************/ 2789static void parseNoCopy(FICL_VM *pVM) 2790{ 2791 STRINGINFO si = vmGetWord0(pVM); 2792 stackPushPtr(pVM->pStack, SI_PTR(si)); 2793 stackPushUNS32(pVM->pStack, SI_COUNT(si)); 2794 return; 2795} 2796 2797 2798/************************************************************************** 2799 p a r s e 2800** CORE EXT ( char "ccc<char>" -- c-addr u ) 2801** Parse ccc delimited by the delimiter char. 2802** c-addr is the address (within the input buffer) and u is the length of 2803** the parsed string. If the parse area was empty, the resulting string has 2804** a zero length. 2805** NOTE! PARSE differs from WORD: it does not skip leading delimiters. 2806**************************************************************************/ 2807static void parse(FICL_VM *pVM) 2808{ 2809 char *pSrc = vmGetInBuf(pVM); 2810 char *cp; 2811 UNS32 count; 2812 char delim = (char)stackPopINT32(pVM->pStack); 2813 2814 cp = pSrc; /* mark start of text */ 2815 2816 while ((*pSrc != delim) && (*pSrc != '\0')) 2817 pSrc++; /* find next delimiter or end */ 2818 2819 count = pSrc - cp; /* set length of result */ 2820 2821 if (*pSrc == delim) /* gobble trailing delimiter */ 2822 pSrc++; 2823 2824 vmUpdateTib(pVM, pSrc); 2825 stackPushPtr(pVM->pStack, cp); 2826 stackPushUNS32(pVM->pStack, count); 2827 return; 2828} 2829 2830 2831/************************************************************************** 2832 f i l l 2833** CORE ( c-addr u char -- ) 2834** If u is greater than zero, store char in each of u consecutive 2835** characters of memory beginning at c-addr. 2836**************************************************************************/ 2837static void fill(FICL_VM *pVM) 2838{ 2839 char ch = (char)stackPopINT32(pVM->pStack); 2840 UNS32 u = stackPopUNS32(pVM->pStack); 2841 char *cp = (char *)stackPopPtr(pVM->pStack); 2842 2843 while (u > 0) 2844 { 2845 *cp++ = ch; 2846 u--; 2847 } 2848 2849 return; 2850} 2851 2852 2853/************************************************************************** 2854 f i n d 2855** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2856** Find the definition named in the counted string at c-addr. If the 2857** definition is not found, return c-addr and zero. If the definition is 2858** found, return its execution token xt. If the definition is immediate, 2859** also return one (1), otherwise also return minus-one (-1). For a given 2860** string, the values returned by FIND while compiling may differ from 2861** those returned while not compiling. 2862**************************************************************************/ 2863static void find(FICL_VM *pVM) 2864{ 2865 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2866 FICL_WORD *pFW; 2867 STRINGINFO si; 2868 2869 SI_PFS(si, sp); 2870 pFW = dictLookup(ficlGetDict(), si); 2871 if (pFW) 2872 { 2873 stackPushPtr(pVM->pStack, pFW); 2874 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 2875 } 2876 else 2877 { 2878 stackPushPtr(pVM->pStack, sp); 2879 stackPushUNS32(pVM->pStack, 0); 2880 } 2881 return; 2882} 2883 2884 2885/************************************************************************** 2886 f m S l a s h M o d 2887** f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 2888** Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 2889** Input and output stack arguments are signed. An ambiguous condition 2890** exists if n1 is zero or if the quotient lies outside the range of a 2891** single-cell signed integer. 2892**************************************************************************/ 2893static void fmSlashMod(FICL_VM *pVM) 2894{ 2895 INT64 d1; 2896 INT32 n1; 2897 INTQR qr; 2898 2899 n1 = stackPopINT32(pVM->pStack); 2900 d1 = i64Pop(pVM->pStack); 2901 qr = m64FlooredDivI(d1, n1); 2902 stackPushINT32(pVM->pStack, qr.rem); 2903 stackPushINT32(pVM->pStack, qr.quot); 2904 return; 2905} 2906 2907 2908/************************************************************************** 2909 s m S l a s h R e m 2910** s-m-slash-rem CORE ( d1 n1 -- n2 n3 ) 2911** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 2912** Input and output stack arguments are signed. An ambiguous condition 2913** exists if n1 is zero or if the quotient lies outside the range of a 2914** single-cell signed integer. 2915**************************************************************************/ 2916static void smSlashRem(FICL_VM *pVM) 2917{ 2918 INT64 d1; 2919 INT32 n1; 2920 INTQR qr; 2921 2922 n1 = stackPopINT32(pVM->pStack); 2923 d1 = i64Pop(pVM->pStack); 2924 qr = m64SymmetricDivI(d1, n1); 2925 stackPushINT32(pVM->pStack, qr.rem); 2926 stackPushINT32(pVM->pStack, qr.quot); 2927 return; 2928} 2929 2930 2931static void ficlMod(FICL_VM *pVM) 2932{ 2933 INT64 d1; 2934 INT32 n1; 2935 INTQR qr; 2936 2937 n1 = stackPopINT32(pVM->pStack); 2938 d1.lo = stackPopINT32(pVM->pStack); 2939 i64Extend(d1); 2940 qr = m64SymmetricDivI(d1, n1); 2941 stackPushINT32(pVM->pStack, qr.rem); 2942 return; 2943} 2944 2945 2946/************************************************************************** 2947 u m S l a s h M o d 2948** u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 2949** Divide ud by u1, giving the quotient u3 and the remainder u2. 2950** All values and arithmetic are unsigned. An ambiguous condition 2951** exists if u1 is zero or if the quotient lies outside the range of a 2952** single-cell unsigned integer. 2953*************************************************************************/ 2954static void umSlashMod(FICL_VM *pVM) 2955{ 2956 UNS64 ud; 2957 UNS32 u1; 2958 UNSQR qr; 2959 2960 u1 = stackPopUNS32(pVM->pStack); 2961 ud = u64Pop(pVM->pStack); 2962 qr = ficlLongDiv(ud, u1); 2963 stackPushUNS32(pVM->pStack, qr.rem); 2964 stackPushUNS32(pVM->pStack, qr.quot); 2965 return; 2966} 2967 2968 2969/************************************************************************** 2970 l s h i f t 2971** l-shift CORE ( x1 u -- x2 ) 2972** Perform a logical left shift of u bit-places on x1, giving x2. 2973** Put zeroes into the least significant bits vacated by the shift. 2974** An ambiguous condition exists if u is greater than or equal to the 2975** number of bits in a cell. 2976** 2977** r-shift CORE ( x1 u -- x2 ) 2978** Perform a logical right shift of u bit-places on x1, giving x2. 2979** Put zeroes into the most significant bits vacated by the shift. An 2980** ambiguous condition exists if u is greater than or equal to the 2981** number of bits in a cell. 2982**************************************************************************/ 2983static void lshift(FICL_VM *pVM) 2984{ 2985 UNS32 nBits = stackPopUNS32(pVM->pStack); 2986 UNS32 x1 = stackPopUNS32(pVM->pStack); 2987 2988 stackPushUNS32(pVM->pStack, x1 << nBits); 2989 return; 2990} 2991 2992 2993static void rshift(FICL_VM *pVM) 2994{ 2995 UNS32 nBits = stackPopUNS32(pVM->pStack); 2996 UNS32 x1 = stackPopUNS32(pVM->pStack); 2997 2998 stackPushUNS32(pVM->pStack, x1 >> nBits); 2999 return; 3000} 3001 3002 3003/************************************************************************** 3004 m S t a r 3005** m-star CORE ( n1 n2 -- d ) 3006** d is the signed product of n1 times n2. 3007**************************************************************************/ 3008static void mStar(FICL_VM *pVM) 3009{ 3010 INT32 n2 = stackPopINT32(pVM->pStack); 3011 INT32 n1 = stackPopINT32(pVM->pStack); 3012 INT64 d; 3013 3014 d = m64MulI(n1, n2); 3015 i64Push(pVM->pStack, d); 3016 return; 3017} 3018 3019 3020static void umStar(FICL_VM *pVM) 3021{ 3022 UNS32 u2 = stackPopUNS32(pVM->pStack); 3023 UNS32 u1 = stackPopUNS32(pVM->pStack); 3024 UNS64 ud; 3025 3026 ud = ficlLongMul(u1, u2); 3027 u64Push(pVM->pStack, ud); 3028 return; 3029} 3030 3031 3032/************************************************************************** 3033 m a x & m i n 3034** 3035**************************************************************************/ 3036static void ficlMax(FICL_VM *pVM) 3037{ 3038 INT32 n2 = stackPopINT32(pVM->pStack); 3039 INT32 n1 = stackPopINT32(pVM->pStack); 3040 3041 stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2); 3042 return; 3043} 3044 3045static void ficlMin(FICL_VM *pVM) 3046{ 3047 INT32 n2 = stackPopINT32(pVM->pStack); 3048 INT32 n1 = stackPopINT32(pVM->pStack); 3049 3050 stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2); 3051 return; 3052} 3053 3054 3055/************************************************************************** 3056 m o v e 3057** CORE ( addr1 addr2 u -- ) 3058** If u is greater than zero, copy the contents of u consecutive address 3059** units at addr1 to the u consecutive address units at addr2. After MOVE 3060** completes, the u consecutive address units at addr2 contain exactly 3061** what the u consecutive address units at addr1 contained before the move. 3062** NOTE! This implementation assumes that a char is the same size as 3063** an address unit. 3064**************************************************************************/ 3065static void move(FICL_VM *pVM) 3066{ 3067 UNS32 u = stackPopUNS32(pVM->pStack); 3068 char *addr2 = stackPopPtr(pVM->pStack); 3069 char *addr1 = stackPopPtr(pVM->pStack); 3070 3071 if (u == 0) 3072 return; 3073 /* 3074 ** Do the copy carefully, so as to be 3075 ** correct even if the two ranges overlap 3076 */ 3077 if (addr1 >= addr2) 3078 { 3079 for (; u > 0; u--) 3080 *addr2++ = *addr1++; 3081 } 3082 else 3083 { 3084 addr2 += u-1; 3085 addr1 += u-1; 3086 for (; u > 0; u--) 3087 *addr2-- = *addr1--; 3088 } 3089 3090 return; 3091} 3092 3093 3094/************************************************************************** 3095 r e c u r s e 3096** 3097**************************************************************************/ 3098static void recurseCoIm(FICL_VM *pVM) 3099{ 3100 FICL_DICT *pDict = ficlGetDict(); 3101 3102 IGNORE(pVM); 3103 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); 3104 return; 3105} 3106 3107 3108/************************************************************************** 3109 s t o d 3110** s-to-d CORE ( n -- d ) 3111** Convert the number n to the double-cell number d with the same 3112** numerical value. 3113**************************************************************************/ 3114static void sToD(FICL_VM *pVM) 3115{ 3116 INT32 s = stackPopINT32(pVM->pStack); 3117 3118 /* sign extend to 64 bits.. */ 3119 stackPushINT32(pVM->pStack, s); 3120 stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0); 3121 return; 3122} 3123 3124 3125/************************************************************************** 3126 s o u r c e 3127** CORE ( -- c-addr u ) 3128** c-addr is the address of, and u is the number of characters in, the 3129** input buffer. 3130**************************************************************************/ 3131static void source(FICL_VM *pVM) 3132{ 3133 stackPushPtr(pVM->pStack, pVM->tib.cp); 3134 stackPushINT32(pVM->pStack, strlen(pVM->tib.cp)); 3135 return; 3136} 3137 3138 3139/************************************************************************** 3140 v e r s i o n 3141** non-standard... 3142**************************************************************************/ 3143static void ficlVersion(FICL_VM *pVM) 3144{ 3145 vmTextOut(pVM, "ficl Version " FICL_VER, 1); 3146 return; 3147} 3148 3149 3150/************************************************************************** 3151 t o I n 3152** to-in CORE 3153**************************************************************************/ 3154static void toIn(FICL_VM *pVM) 3155{ 3156 stackPushPtr(pVM->pStack, &pVM->tib.index); 3157 return; 3158} 3159 3160 3161/************************************************************************** 3162 d e f i n i t i o n s 3163** SEARCH ( -- ) 3164** Make the compilation word list the same as the first word list in the 3165** search order. Specifies that the names of subsequent definitions will 3166** be placed in the compilation word list. Subsequent changes in the search 3167** order will not affect the compilation word list. 3168**************************************************************************/ 3169static void definitions(FICL_VM *pVM) 3170{ 3171 FICL_DICT *pDict = ficlGetDict(); 3172 3173 assert(pDict); 3174 if (pDict->nLists < 1) 3175 { 3176 vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 3177 } 3178 3179 pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 3180 return; 3181} 3182 3183 3184/************************************************************************** 3185 f o r t h - w o r d l i s t 3186** SEARCH ( -- wid ) 3187** Return wid, the identifier of the word list that includes all standard 3188** words provided by the implementation. This word list is initially the 3189** compilation word list and is part of the initial search order. 3190**************************************************************************/ 3191static void forthWordlist(FICL_VM *pVM) 3192{ 3193 FICL_HASH *pHash = ficlGetDict()->pForthWords; 3194 stackPushPtr(pVM->pStack, pHash); 3195 return; 3196} 3197 3198 3199/************************************************************************** 3200 g e t - c u r r e n t 3201** SEARCH ( -- wid ) 3202** Return wid, the identifier of the compilation word list. 3203**************************************************************************/ 3204static void getCurrent(FICL_VM *pVM) 3205{ 3206 ficlLockDictionary(TRUE); 3207 stackPushPtr(pVM->pStack, ficlGetDict()->pCompile); 3208 ficlLockDictionary(FALSE); 3209 return; 3210} 3211 3212 3213/************************************************************************** 3214 g e t - o r d e r 3215** SEARCH ( -- widn ... wid1 n ) 3216** Returns the number of word lists n in the search order and the word list 3217** identifiers widn ... wid1 identifying these word lists. wid1 identifies 3218** the word list that is searched first, and widn the word list that is 3219** searched last. The search order is unaffected. 3220**************************************************************************/ 3221static void getOrder(FICL_VM *pVM) 3222{ 3223 FICL_DICT *pDict = ficlGetDict(); 3224 int nLists = pDict->nLists; 3225 int i; 3226 3227 ficlLockDictionary(TRUE); 3228 for (i = 0; i < nLists; i++) 3229 { 3230 stackPushPtr(pVM->pStack, pDict->pSearch[i]); 3231 } 3232 3233 stackPushUNS32(pVM->pStack, nLists); 3234 ficlLockDictionary(FALSE); 3235 return; 3236} 3237 3238 3239/************************************************************************** 3240 s e a r c h - w o r d l i s t 3241** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 3242** Find the definition identified by the string c-addr u in the word list 3243** identified by wid. If the definition is not found, return zero. If the 3244** definition is found, return its execution token xt and one (1) if the 3245** definition is immediate, minus-one (-1) otherwise. 3246**************************************************************************/ 3247static void searchWordlist(FICL_VM *pVM) 3248{ 3249 STRINGINFO si; 3250 UNS16 hashCode; 3251 FICL_WORD *pFW; 3252 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3253 3254 si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack); 3255 si.cp = stackPopPtr(pVM->pStack); 3256 hashCode = hashHashCode(si); 3257 3258 ficlLockDictionary(TRUE); 3259 pFW = hashLookup(pHash, si, hashCode); 3260 ficlLockDictionary(FALSE); 3261 3262 if (pFW) 3263 { 3264 stackPushPtr(pVM->pStack, pFW); 3265 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 3266 } 3267 else 3268 { 3269 stackPushUNS32(pVM->pStack, 0); 3270 } 3271 3272 return; 3273} 3274 3275 3276/************************************************************************** 3277 s e t - c u r r e n t 3278** SEARCH ( wid -- ) 3279** Set the compilation word list to the word list identified by wid. 3280**************************************************************************/ 3281static void setCurrent(FICL_VM *pVM) 3282{ 3283 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3284 FICL_DICT *pDict = ficlGetDict(); 3285 ficlLockDictionary(TRUE); 3286 pDict->pCompile = pHash; 3287 ficlLockDictionary(FALSE); 3288 return; 3289} 3290 3291 3292/************************************************************************** 3293 s e t - o r d e r 3294** SEARCH ( widn ... wid1 n -- ) 3295** Set the search order to the word lists identified by widn ... wid1. 3296** Subsequently, word list wid1 will be searched first, and word list 3297** widn searched last. If n is zero, empty the search order. If n is minus 3298** one, set the search order to the implementation-defined minimum 3299** search order. The minimum search order shall include the words 3300** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 3301** be at least eight. 3302**************************************************************************/ 3303static void setOrder(FICL_VM *pVM) 3304{ 3305 int i; 3306 int nLists = stackPopINT32(pVM->pStack); 3307 FICL_DICT *dp = ficlGetDict(); 3308 3309 if (nLists > FICL_DEFAULT_VOCS) 3310 { 3311 vmThrowErr(pVM, "set-order error: list would be too large"); 3312 } 3313 3314 ficlLockDictionary(TRUE); 3315 3316 if (nLists >= 0) 3317 { 3318 dp->nLists = nLists; 3319 for (i = nLists-1; i >= 0; --i) 3320 { 3321 dp->pSearch[i] = stackPopPtr(pVM->pStack); 3322 } 3323 } 3324 else 3325 { 3326 dictResetSearchOrder(dp); 3327 } 3328 3329 ficlLockDictionary(FALSE); 3330 return; 3331} 3332 3333 3334/************************************************************************** 3335 w o r d l i s t 3336** SEARCH ( -- wid ) 3337** Create a new empty word list, returning its word list identifier wid. 3338** The new word list may be returned from a pool of preallocated word 3339** lists or may be dynamically allocated in data space. A system shall 3340** allow the creation of at least 8 new word lists in addition to any 3341** provided as part of the system. 3342** Notes: 3343** 1. ficl creates a new single-list hash in the dictionary and returns 3344** its address. 3345** 2. ficl-wordlist takes an arg off the stack indicating the number of 3346** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 3347** : wordlist 1 ficl-wordlist ; 3348**************************************************************************/ 3349static void wordlist(FICL_VM *pVM) 3350{ 3351 FICL_DICT *dp = ficlGetDict(); 3352 FICL_HASH *pHash; 3353 UNS32 nBuckets; 3354 3355#if FICL_ROBUST > 1 3356 vmCheckStack(pVM, 1, 1); 3357#endif 3358 nBuckets = stackPopUNS32(pVM->pStack); 3359 3360 dictAlign(dp); 3361 pHash = (FICL_HASH *)dp->here; 3362 dictAllot(dp, sizeof (FICL_HASH) 3363 + (nBuckets-1) * sizeof (FICL_WORD *)); 3364 3365 pHash->size = nBuckets; 3366 hashReset(pHash); 3367 3368 stackPushPtr(pVM->pStack, pHash); 3369 return; 3370} 3371 3372 3373/************************************************************************** 3374 S E A R C H > 3375** ficl ( -- wid ) 3376** Pop wid off the search order. Error if the search order is empty 3377**************************************************************************/ 3378static void searchPop(FICL_VM *pVM) 3379{ 3380 FICL_DICT *dp = ficlGetDict(); 3381 int nLists; 3382 3383 ficlLockDictionary(TRUE); 3384 nLists = dp->nLists; 3385 if (nLists == 0) 3386 { 3387 vmThrowErr(pVM, "search> error: empty search order"); 3388 } 3389 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 3390 ficlLockDictionary(FALSE); 3391 return; 3392} 3393 3394 3395/************************************************************************** 3396 > S E A R C H 3397** ficl ( wid -- ) 3398** Push wid onto the search order. Error if the search order is full. 3399**************************************************************************/ 3400static void searchPush(FICL_VM *pVM) 3401{ 3402 FICL_DICT *dp = ficlGetDict(); 3403 3404 ficlLockDictionary(TRUE); 3405 if (dp->nLists > FICL_DEFAULT_VOCS) 3406 { 3407 vmThrowErr(pVM, ">search error: search order overflow"); 3408 } 3409 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 3410 ficlLockDictionary(FALSE); 3411 return; 3412} 3413 3414 3415/************************************************************************** 3416 c o l o n N o N a m e 3417** CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 3418** Create an unnamed colon definition and push its address. 3419** Change state to compile. 3420**************************************************************************/ 3421static void colonNoName(FICL_VM *pVM) 3422{ 3423 FICL_DICT *dp = ficlGetDict(); 3424 FICL_WORD *pFW; 3425 STRINGINFO si; 3426 3427 SI_SETLEN(si, 0); 3428 SI_SETPTR(si, NULL); 3429 3430 pVM->state = COMPILE; 3431 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 3432 stackPushPtr(pVM->pStack, pFW); 3433 markControlTag(pVM, colonTag); 3434 return; 3435} 3436 3437 3438/************************************************************************** 3439 u s e r V a r i a b l e 3440** user ( u -- ) "<spaces>name" 3441** Get a name from the input stream and create a user variable 3442** with the name and the index supplied. The run-time effect 3443** of a user variable is to push the address of the indexed cell 3444** in the running vm's user array. 3445** 3446** User variables are vm local cells. Each vm has an array of 3447** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 3448** Ficl's user facility is implemented with two primitives, 3449** "user" and "(user)", a variable ("nUser") (in softcore.c) that 3450** holds the index of the next free user cell, and a redefinition 3451** (also in softcore) of "user" that defines a user word and increments 3452** nUser. 3453**************************************************************************/ 3454#if FICL_WANT_USER 3455static void userParen(FICL_VM *pVM) 3456{ 3457 INT32 i = pVM->runningWord->param[0].i; 3458 stackPushPtr(pVM->pStack, &pVM->user[i]); 3459 return; 3460} 3461 3462 3463static void userVariable(FICL_VM *pVM) 3464{ 3465 FICL_DICT *dp = ficlGetDict(); 3466 STRINGINFO si = vmGetWord(pVM); 3467 CELL c; 3468 3469 c = stackPop(pVM->pStack); 3470 if (c.i >= FICL_USER_CELLS) 3471 { 3472 vmThrowErr(pVM, "Error - out of user space"); 3473 } 3474 3475 dictAppendWord2(dp, si, userParen, FW_DEFAULT); 3476 dictAppendCell(dp, c); 3477 return; 3478} 3479#endif 3480 3481 3482/************************************************************************** 3483 t o V a l u e 3484** CORE EXT 3485** Interpretation: ( x "<spaces>name" -- ) 3486** Skip leading spaces and parse name delimited by a space. Store x in 3487** name. An ambiguous condition exists if name was not defined by VALUE. 3488** NOTE: In ficl, VALUE is an alias of CONSTANT 3489**************************************************************************/ 3490static void toValue(FICL_VM *pVM) 3491{ 3492 STRINGINFO si = vmGetWord(pVM); 3493 FICL_DICT *dp = ficlGetDict(); 3494 FICL_WORD *pFW; 3495 3496#if FICL_WANT_LOCALS 3497 FICL_DICT *pLoc = ficlGetLoc(); 3498 if ((nLocals > 0) && (pVM->state == COMPILE)) 3499 { 3500 pFW = dictLookup(pLoc, si); 3501 if (pFW) 3502 { 3503 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen)); 3504 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 3505 return; 3506 } 3507 } 3508#endif 3509 3510 assert(pStore); 3511 3512 pFW = dictLookup(dp, si); 3513 if (!pFW) 3514 { 3515 int i = SI_COUNT(si); 3516 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 3517 } 3518 3519 if (pVM->state == INTERPRET) 3520 pFW->param[0] = stackPop(pVM->pStack); 3521 else /* compile code to store to word's param */ 3522 { 3523 stackPushPtr(pVM->pStack, &pFW->param[0]); 3524 literalIm(pVM); 3525 dictAppendCell(dp, LVALUEtoCELL(pStore)); 3526 } 3527 return; 3528} 3529 3530 3531#if FICL_WANT_LOCALS 3532/************************************************************************** 3533 l i n k P a r e n 3534** ( -- ) 3535** Link a frame on the return stack, reserving nCells of space for 3536** locals - the value of nCells is the next cell in the instruction 3537** stream. 3538**************************************************************************/ 3539static void linkParen(FICL_VM *pVM) 3540{ 3541 INT32 nLink = *(INT32 *)(pVM->ip); 3542 vmBranchRelative(pVM, 1); 3543 stackLink(pVM->rStack, nLink); 3544 return; 3545} 3546 3547 3548static void unlinkParen(FICL_VM *pVM) 3549{ 3550 stackUnlink(pVM->rStack); 3551 return; 3552} 3553 3554 3555/************************************************************************** 3556 d o L o c a l I m 3557** Immediate - cfa of a local while compiling - when executed, compiles 3558** code to fetch the value of a local given the local's index in the 3559** word's pfa 3560**************************************************************************/ 3561static void getLocalParen(FICL_VM *pVM) 3562{ 3563 INT32 nLocal = *(INT32 *)(pVM->ip++); 3564 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3565 return; 3566} 3567 3568 3569static void toLocalParen(FICL_VM *pVM) 3570{ 3571 INT32 nLocal = *(INT32 *)(pVM->ip++); 3572 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 3573 return; 3574} 3575 3576 3577static void getLocal0(FICL_VM *pVM) 3578{ 3579 stackPush(pVM->pStack, pVM->rStack->pFrame[0]); 3580 return; 3581} 3582 3583 3584static void toLocal0(FICL_VM *pVM) 3585{ 3586 pVM->rStack->pFrame[0] = stackPop(pVM->pStack); 3587 return; 3588} 3589 3590 3591static void getLocal1(FICL_VM *pVM) 3592{ 3593 stackPush(pVM->pStack, pVM->rStack->pFrame[1]); 3594 return; 3595} 3596 3597 3598static void toLocal1(FICL_VM *pVM) 3599{ 3600 pVM->rStack->pFrame[1] = stackPop(pVM->pStack); 3601 return; 3602} 3603 3604 3605/* 3606** Each local is recorded in a private locals dictionary as a 3607** word that does doLocalIm at runtime. DoLocalIm compiles code 3608** into the client definition to fetch the value of the 3609** corresponding local variable from the return stack. 3610** The private dictionary gets initialized at the end of each block 3611** that uses locals (in ; and does> for example). 3612*/ 3613static void doLocalIm(FICL_VM *pVM) 3614{ 3615 FICL_DICT *pDict = ficlGetDict(); 3616 int nLocal = pVM->runningWord->param[0].i; 3617 3618 if (pVM->state == INTERPRET) 3619 { 3620 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3621 } 3622 else 3623 { 3624 3625 if (nLocal == 0) 3626 { 3627 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0)); 3628 } 3629 else if (nLocal == 1) 3630 { 3631 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1)); 3632 } 3633 else 3634 { 3635 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen)); 3636 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 3637 } 3638 } 3639 return; 3640} 3641 3642 3643/************************************************************************** 3644 l o c a l P a r e n 3645** paren-local-paren LOCAL 3646** Interpretation: Interpretation semantics for this word are undefined. 3647** Execution: ( c-addr u -- ) 3648** When executed during compilation, (LOCAL) passes a message to the 3649** system that has one of two meanings. If u is non-zero, 3650** the message identifies a new local whose definition name is given by 3651** the string of characters identified by c-addr u. If u is zero, 3652** the message is last local and c-addr has no significance. 3653** 3654** The result of executing (LOCAL) during compilation of a definition is 3655** to create a set of named local identifiers, each of which is 3656** a definition name, that only have execution semantics within the scope 3657** of that definition's source. 3658** 3659** local Execution: ( -- x ) 3660** 3661** Push the local's value, x, onto the stack. The local's value is 3662** initialized as described in 13.3.3 Processing locals and may be 3663** changed by preceding the local's name with TO. An ambiguous condition 3664** exists when local is executed while in interpretation state. 3665**************************************************************************/ 3666static void localParen(FICL_VM *pVM) 3667{ 3668 static CELL *pMark = NULL; 3669 FICL_DICT *pDict = ficlGetDict(); 3670 STRINGINFO si; 3671 SI_SETLEN(si, stackPopUNS32(pVM->pStack)); 3672 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 3673 3674 if (SI_COUNT(si) > 0) 3675 { /* add a local to the dict and update nLocals */ 3676 FICL_DICT *pLoc = ficlGetLoc(); 3677 if (nLocals >= FICL_MAX_LOCALS) 3678 { 3679 vmThrowErr(pVM, "Error: out of local space"); 3680 } 3681 3682 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); 3683 dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); 3684 3685 if (nLocals == 0) 3686 { /* compile code to create a local stack frame */ 3687 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); 3688 /* save location in dictionary for #locals */ 3689 pMark = pDict->here; 3690 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3691 /* compile code to initialize first local */ 3692 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0)); 3693 } 3694 else if (nLocals == 1) 3695 { 3696 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1)); 3697 } 3698 else 3699 { 3700 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen)); 3701 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3702 } 3703 3704 nLocals++; 3705 } 3706 else if (nLocals > 0) 3707 { /* write nLocals to (link) param area in dictionary */ 3708 *(INT32 *)pMark = nLocals; 3709 } 3710 3711 return; 3712} 3713 3714 3715#endif 3716/************************************************************************** 3717 setParentWid 3718** FICL 3719** setparentwid ( parent-wid wid -- ) 3720** Set WID's link field to the parent-wid. search-wordlist will 3721** iterate through all the links when finding words in the child wid. 3722**************************************************************************/ 3723static void setParentWid(FICL_VM *pVM) 3724{ 3725 FICL_HASH *parent, *child; 3726#if FICL_ROBUST > 1 3727 vmCheckStack(pVM, 2, 0); 3728#endif 3729 child = (FICL_HASH *)stackPopPtr(pVM->pStack); 3730 parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 3731 3732 child->link = parent; 3733 return; 3734} 3735 3736 3737/************************************************************************** 3738 s e e 3739** TOOLS ( "<spaces>name" -- ) 3740** Display a human-readable representation of the named word's definition. 3741** The source of the representation (object-code decompilation, source 3742** block, etc.) and the particular form of the display is implementation 3743** defined. 3744** NOTE: these funcs come late in the file because they reference all 3745** of the word-builder funcs without declaring them again. Call me lazy. 3746**************************************************************************/ 3747/* 3748** isAFiclWord 3749** Vet a candidate pointer carefully to make sure 3750** it's not some chunk o' inline data... 3751** It has to have a name, and it has to look 3752** like it's in the dictionary address range. 3753** NOTE: this excludes :noname words! 3754*/ 3755static int isAFiclWord(FICL_WORD *pFW) 3756{ 3757 void *pv = (void *)pFW; 3758 FICL_DICT *pd = ficlGetDict(); 3759 3760 if (!dictIncludes(pd, pFW)) 3761 return 0; 3762 3763 if (!dictIncludes(pd, pFW->name)) 3764 return 0; 3765 3766 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0')); 3767} 3768 3769/* 3770** seeColon (for proctologists only) 3771** Walks a colon definition, decompiling 3772** on the fly. Knows about primitive control structures. 3773*/ 3774static void seeColon(FICL_VM *pVM, CELL *pc) 3775{ 3776 for (; pc->p != pSemiParen; pc++) 3777 { 3778 FICL_WORD *pFW = (FICL_WORD *)(pc->p); 3779 3780 if (isAFiclWord(pFW)) 3781 { 3782 if (pFW->code == literalParen) 3783 { 3784 CELL v = *++pc; 3785 if (isAFiclWord(v.p)) 3786 { 3787 FICL_WORD *pLit = (FICL_WORD *)v.p; 3788 sprintf(pVM->pad, " literal %.*s (%#lx)", 3789 pLit->nName, pLit->name, v.u); 3790 } 3791 else 3792 sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u); 3793 } 3794 else if (pFW->code == stringLit) 3795 { 3796 FICL_STRING *sp = (FICL_STRING *)(void *)++pc; 3797 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; 3798 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text); 3799 } 3800 else if (pFW->code == ifParen) 3801 { 3802 CELL c = *++pc; 3803 if (c.i > 0) 3804 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i); 3805 else 3806 sprintf(pVM->pad, " until (branch rel %ld)", c.i); 3807 } 3808 else if (pFW->code == branchParen) 3809 { 3810 CELL c = *++pc; 3811 if (c.i > 0) 3812 sprintf(pVM->pad, " else (branch rel %ld)", c.i); 3813 else 3814 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i); 3815 } 3816 else if (pFW->code == qDoParen) 3817 { 3818 CELL c = *++pc; 3819 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); 3820 } 3821 else if (pFW->code == doParen) 3822 { 3823 CELL c = *++pc; 3824 sprintf(pVM->pad, " do (leave abs %#lx)", c.u); 3825 } 3826 else if (pFW->code == loopParen) 3827 { 3828 CELL c = *++pc; 3829 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); 3830 } 3831 else if (pFW->code == plusLoopParen) 3832 { 3833 CELL c = *++pc; 3834 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); 3835 } 3836 else /* default: print word's name */ 3837 { 3838 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); 3839 } 3840 3841 vmTextOut(pVM, pVM->pad, 1); 3842 } 3843 else /* probably not a word - punt and print value */ 3844 { 3845 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u); 3846 vmTextOut(pVM, pVM->pad, 1); 3847 } 3848 } 3849 3850 vmTextOut(pVM, ";", 1); 3851} 3852 3853/* 3854** Here's the outer part of the decompiler. It's 3855** just a big nested conditional that checks the 3856** CFA of the word to decompile for each kind of 3857** known word-builder code, and tries to do 3858** something appropriate. If the CFA is not recognized, 3859** just indicate that it is a primitive. 3860*/ 3861static void see(FICL_VM *pVM) 3862{ 3863 FICL_DICT *pd = ficlGetDict(); 3864 FICL_WORD *pFW; 3865 3866 tick(pVM); 3867 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 3868 3869 if (pFW->code == colonParen) 3870 { 3871 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); 3872 vmTextOut(pVM, pVM->pad, 1); 3873 seeColon(pVM, pFW->param); 3874 } 3875 else if (pFW->code == doDoes) 3876 { 3877 vmTextOut(pVM, "does>", 1); 3878 seeColon(pVM, (CELL *)pFW->param->p); 3879 } 3880 else if (pFW->code == createParen) 3881 { 3882 vmTextOut(pVM, "create", 1); 3883 } 3884 else if (pFW->code == variableParen) 3885 { 3886 sprintf(pVM->pad, "variable = %ld (%#lx)", 3887 pFW->param->i, pFW->param->u); 3888 vmTextOut(pVM, pVM->pad, 1); 3889 } 3890 else if (pFW->code == userParen) 3891 { 3892 sprintf(pVM->pad, "user variable %ld (%#lx)", 3893 pFW->param->i, pFW->param->u); 3894 vmTextOut(pVM, pVM->pad, 1); 3895 } 3896 else if (pFW->code == constantParen) 3897 { 3898 sprintf(pVM->pad, "constant = %ld (%#lx)", 3899 pFW->param->i, pFW->param->u); 3900 vmTextOut(pVM, pVM->pad, 1); 3901 } 3902 else 3903 { 3904 vmTextOut(pVM, "primitive", 1); 3905 } 3906 3907 if (pFW->flags & FW_IMMEDIATE) 3908 { 3909 vmTextOut(pVM, "immediate", 1); 3910 } 3911 3912 return; 3913} 3914 3915 3916/************************************************************************** 3917 c o m p a r e 3918** STRING ( c-addr1 u1 c-addr2 u2 -- n ) 3919** Compare the string specified by c-addr1 u1 to the string specified by 3920** c-addr2 u2. The strings are compared, beginning at the given addresses, 3921** character by character, up to the length of the shorter string or until a 3922** difference is found. If the two strings are identical, n is zero. If the two 3923** strings are identical up to the length of the shorter string, n is minus-one 3924** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not 3925** identical up to the length of the shorter string, n is minus-one (-1) if the 3926** first non-matching character in the string specified by c-addr1 u1 has a 3927** lesser numeric value than the corresponding character in the string specified 3928** by c-addr2 u2 and one (1) otherwise. 3929**************************************************************************/ 3930static void compareString(FICL_VM *pVM) 3931{ 3932 char *cp1, *cp2; 3933 UNS32 u1, u2, uMin; 3934 int n = 0; 3935 3936 vmCheckStack(pVM, 4, 1); 3937 u2 = stackPopUNS32(pVM->pStack); 3938 cp2 = (char *)stackPopPtr(pVM->pStack); 3939 u1 = stackPopUNS32(pVM->pStack); 3940 cp1 = (char *)stackPopPtr(pVM->pStack); 3941 3942 uMin = (u1 < u2)? u1 : u2; 3943 for ( ; (uMin > 0) && (n == 0); uMin--) 3944 { 3945 n = (int)(*cp1++ - *cp2++); 3946 } 3947 3948 if (n == 0) 3949 n = (int)(u1 - u2); 3950 3951 if (n < 0) 3952 n = -1; 3953 else if (n > 0) 3954 n = 1; 3955 3956 stackPushINT32(pVM->pStack, n); 3957 return; 3958} 3959 3960 3961/************************************************************************** 3962 r e f i l l 3963** CORE EXT ( -- flag ) 3964** Attempt to fill the input buffer from the input source, returning a true 3965** flag if successful. 3966** When the input source is the user input device, attempt to receive input 3967** into the terminal input buffer. If successful, make the result the input 3968** buffer, set >IN to zero, and return true. Receipt of a line containing no 3969** characters is considered successful. If there is no input available from 3970** the current input source, return false. 3971** When the input source is a string from EVALUATE, return false and 3972** perform no other action. 3973**************************************************************************/ 3974static void refill(FICL_VM *pVM) 3975{ 3976 INT32 ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; 3977 stackPushINT32(pVM->pStack, ret); 3978 if (ret) 3979 vmThrow(pVM, VM_OUTOFTEXT); 3980 return; 3981} 3982 3983 3984/************************************************************************** 3985 f o r g e t 3986** TOOLS EXT ( "<spaces>name" -- ) 3987** Skip leading space delimiters. Parse name delimited by a space. 3988** Find name, then delete name from the dictionary along with all 3989** words added to the dictionary after name. An ambiguous 3990** condition exists if name cannot be found. 3991** 3992** If the Search-Order word set is present, FORGET searches the 3993** compilation word list. An ambiguous condition exists if the 3994** compilation word list is deleted. 3995**************************************************************************/ 3996static void forgetWid(FICL_VM *pVM) 3997{ 3998 FICL_DICT *pDict = ficlGetDict(); 3999 FICL_HASH *pHash; 4000 4001 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); 4002 hashForget(pHash, pDict->here); 4003 4004 return; 4005} 4006 4007 4008static void forget(FICL_VM *pVM) 4009{ 4010 void *where; 4011 FICL_DICT *pDict = ficlGetDict(); 4012 FICL_HASH *pHash = pDict->pCompile; 4013 4014 tick(pVM); 4015 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; 4016 hashForget(pHash, where); 4017 pDict->here = PTRtoCELL where; 4018 4019 return; 4020} 4021 4022/************************* freebsd added I/O words **************************/ 4023 4024/* fopen - open a file and return new fd on stack. 4025 * 4026 * fopen ( count ptr -- fd ) 4027 */ 4028static void pfopen(FICL_VM *pVM) 4029{ 4030 int fd; 4031 char *p; 4032 4033 (void)stackPopINT32(pVM->pStack); /* don't need count value */ 4034 p = stackPopPtr(pVM->pStack); 4035 fd = open(p, O_RDONLY); 4036 stackPushINT32(pVM->pStack, fd); 4037 return; 4038} 4039 4040/* fclose - close a file who's fd is on stack. 4041 * 4042 * fclose ( fd -- ) 4043 */ 4044static void pfclose(FICL_VM *pVM) 4045{ 4046 int fd; 4047 4048 fd = stackPopINT32(pVM->pStack); /* get fd */ 4049 if (fd != -1) 4050 close(fd); 4051 return; 4052} 4053 4054/* fload - interpret file contents 4055 * 4056 * fload ( fd -- ) 4057 */ 4058static void pfload(FICL_VM *pVM) 4059{ 4060 int fd; 4061 4062 fd = stackPopINT32(pVM->pStack); /* get fd */ 4063 if (fd != -1) 4064 ficlExecFD(pVM, fd); 4065 return; 4066} 4067 4068/* fexists - check to see if file exists, returning TRUE or FALSE 4069 * 4070 * fexists ( count ptr -- bool ) 4071 */ 4072static void pfexists(FICL_VM *pVM) 4073{ 4074 char *p; 4075 int fd; 4076 4077 (void)stackPopINT32(pVM->pStack); /* don't need count value */ 4078 p = stackPopPtr(pVM->pStack); 4079 fd = open(p, O_RDONLY); 4080 if (fd > 0) { 4081 stackPushINT32(pVM->pStack, TRUE); 4082 close(fd); 4083 } 4084 else 4085 stackPushINT32(pVM->pStack, FALSE); 4086 return; 4087} 4088 4089/* key - get a character from stdin 4090 * 4091 * key ( -- char ) 4092 */ 4093static void key(FICL_VM *pVM) 4094{ 4095 stackPushINT32(pVM->pStack, getchar()); 4096 return; 4097} 4098 4099#if 0 4100/************************************************************************** 4101 4102** 4103**************************************************************************/ 4104static void funcname(FICL_VM *pVM) 4105{ 4106 IGNORE(pVM); 4107 return; 4108} 4109 4110 4111#endif 4112/************************************************************************** 4113 f i c l C o m p i l e C o r e 4114** Builds the primitive wordset and the environment-query namespace. 4115**************************************************************************/ 4116 4117void ficlCompileCore(FICL_DICT *dp) 4118{ 4119 assert (dp); 4120 4121 /* 4122 ** CORE word set 4123 ** see softcore.c for definitions of: abs bl space spaces abort" 4124 */ 4125 pStore = 4126 dictAppendWord(dp, "!", store, FW_DEFAULT); 4127 dictAppendWord(dp, "#", numberSign, FW_DEFAULT); 4128 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); 4129 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); 4130 dictAppendWord(dp, "\'", tick, FW_DEFAULT); 4131 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); 4132 dictAppendWord(dp, "*", mul, FW_DEFAULT); 4133 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); 4134 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); 4135 dictAppendWord(dp, "+", add, FW_DEFAULT); 4136 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); 4137 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); 4138 pComma = 4139 dictAppendWord(dp, ",", comma, FW_DEFAULT); 4140 dictAppendWord(dp, "-", sub, FW_DEFAULT); 4141 dictAppendWord(dp, ".", displayCell, FW_DEFAULT); 4142 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); 4143 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); 4144 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); 4145 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); 4146 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); 4147 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); 4148 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); 4149 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); 4150 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); 4151 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); 4152 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); 4153 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); 4154 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); 4155 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); 4156 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); 4157 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); 4158 dictAppendWord(dp, ":", colon, FW_DEFAULT); 4159 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); 4160 dictAppendWord(dp, "<", isLess, FW_DEFAULT); 4161 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); 4162 dictAppendWord(dp, "=", isEqual, FW_DEFAULT); 4163 dictAppendWord(dp, ">", isGreater, FW_DEFAULT); 4164 dictAppendWord(dp, ">body", toBody, FW_DEFAULT); 4165 dictAppendWord(dp, ">in", toIn, FW_DEFAULT); 4166 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); 4167 dictAppendWord(dp, ">r", toRStack, FW_DEFAULT); 4168 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); 4169 dictAppendWord(dp, "@", fetch, FW_DEFAULT); 4170 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); 4171 dictAppendWord(dp, "accept", accept, FW_DEFAULT); 4172 dictAppendWord(dp, "align", align, FW_DEFAULT); 4173 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); 4174 dictAppendWord(dp, "allot", allot, FW_DEFAULT); 4175 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); 4176 dictAppendWord(dp, "base", base, FW_DEFAULT); 4177 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); 4178 dictAppendWord(dp, "c!", cStore, FW_DEFAULT); 4179 dictAppendWord(dp, "c,", cComma, FW_DEFAULT); 4180 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); 4181 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); 4182 dictAppendWord(dp, "cells", cells, FW_DEFAULT); 4183 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); 4184 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); 4185 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); 4186 dictAppendWord(dp, "constant", constant, FW_DEFAULT); 4187 dictAppendWord(dp, "count", count, FW_DEFAULT); 4188 dictAppendWord(dp, "cr", cr, FW_DEFAULT); 4189 dictAppendWord(dp, "create", create, FW_DEFAULT); 4190 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); 4191 dictAppendWord(dp, "depth", depth, FW_DEFAULT); 4192 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); 4193 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); 4194 dictAppendWord(dp, "drop", drop, FW_DEFAULT); 4195 dictAppendWord(dp, "dup", dup, FW_DEFAULT); 4196 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); 4197 dictAppendWord(dp, "emit", emit, FW_DEFAULT); 4198 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); 4199 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); 4200 dictAppendWord(dp, "execute", execute, FW_DEFAULT); 4201 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); 4202 dictAppendWord(dp, "fill", fill, FW_DEFAULT); 4203 dictAppendWord(dp, "find", find, FW_DEFAULT); 4204 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); 4205 dictAppendWord(dp, "here", here, FW_DEFAULT); 4206 dictAppendWord(dp, "hex", hex, FW_DEFAULT); 4207 dictAppendWord(dp, "hold", hold, FW_DEFAULT); 4208 dictAppendWord(dp, "i", loopICo, FW_COMPILE); 4209 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); 4210 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); 4211 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); 4212 dictAppendWord(dp, "j", loopJCo, FW_COMPILE); 4213 dictAppendWord(dp, "k", loopKCo, FW_COMPILE); 4214 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); 4215 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); 4216 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); 4217 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); 4218 dictAppendWord(dp, "m*", mStar, FW_DEFAULT); 4219 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); 4220 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); 4221 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); 4222 dictAppendWord(dp, "move", move, FW_DEFAULT); 4223 dictAppendWord(dp, "negate", negate, FW_DEFAULT); 4224 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); 4225 dictAppendWord(dp, "over", over, FW_DEFAULT); 4226 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); 4227 dictAppendWord(dp, "quit", quit, FW_DEFAULT); 4228 dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT); 4229 dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT); 4230 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); 4231 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); 4232 dictAppendWord(dp, "rot", rot, FW_DEFAULT); 4233 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); 4234 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); 4235 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); 4236 dictAppendWord(dp, "sign", sign, FW_DEFAULT); 4237 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); 4238 dictAppendWord(dp, "source", source, FW_DEFAULT); 4239 dictAppendWord(dp, "state", state, FW_DEFAULT); 4240 dictAppendWord(dp, "swap", swap, FW_DEFAULT); 4241 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); 4242 pType = 4243 dictAppendWord(dp, "type", type, FW_DEFAULT); 4244 dictAppendWord(dp, "u.", uDot, FW_DEFAULT); 4245 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); 4246 dictAppendWord(dp, "um*", umStar, FW_DEFAULT); 4247 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); 4248 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); 4249 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); 4250 dictAppendWord(dp, "variable", variable, FW_DEFAULT); 4251 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); 4252 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); 4253 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); 4254 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); 4255 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); 4256 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); 4257 dictAppendWord(dp, "]", rbracket, FW_DEFAULT); 4258 /* 4259 ** CORE EXT word set... 4260 ** see softcore.c for other definitions 4261 */ 4262 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); 4263 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); 4264 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); 4265 dictAppendWord(dp, "parse", parse, FW_DEFAULT); 4266 dictAppendWord(dp, "pick", pick, FW_DEFAULT); 4267 dictAppendWord(dp, "roll", roll, FW_DEFAULT); 4268 dictAppendWord(dp, "refill", refill, FW_DEFAULT); 4269 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); 4270 dictAppendWord(dp, "value", constant, FW_DEFAULT); 4271 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); 4272 4273 /* FreeBSD extention words */ 4274 dictAppendWord(dp, "fexists", pfexists, FW_DEFAULT); 4275 dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT); 4276 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT); 4277 dictAppendWord(dp, "fload", pfload, FW_DEFAULT); 4278 dictAppendWord(dp, "key", key, FW_DEFAULT); 4279 4280 /* 4281 ** Set CORE environment query values 4282 */ 4283 ficlSetEnv("/counted-string", FICL_STRING_MAX); 4284 ficlSetEnv("/hold", nPAD); 4285 ficlSetEnv("/pad", nPAD); 4286 ficlSetEnv("address-unit-bits", 8); 4287 ficlSetEnv("core", FICL_TRUE); 4288 ficlSetEnv("core-ext", FICL_FALSE); 4289 ficlSetEnv("floored", FICL_FALSE); 4290 ficlSetEnv("max-char", UCHAR_MAX); 4291 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff ); 4292 ficlSetEnv("max-n", 0x7fffffff); 4293 ficlSetEnv("max-u", 0xffffffff); 4294 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff); 4295 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK); 4296 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); 4297 4298 /* 4299 ** LOCAL and LOCAL EXT 4300 ** see softcore.c for implementation of locals| 4301 */ 4302#if FICL_WANT_LOCALS 4303 pLinkParen = 4304 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); 4305 pUnLinkParen = 4306 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); 4307 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); 4308 pGetLocalParen = 4309 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); 4310 pToLocalParen = 4311 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); 4312 pGetLocal0 = 4313 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); 4314 pToLocal0 = 4315 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); 4316 pGetLocal1 = 4317 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); 4318 pToLocal1 = 4319 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); 4320 dictAppendWord(dp, "(local)", localParen, FW_COMPILE); 4321 4322 ficlSetEnv("locals", FICL_TRUE); 4323 ficlSetEnv("locals-ext", FICL_TRUE); 4324 ficlSetEnv("#locals", FICL_MAX_LOCALS); 4325#endif 4326 4327 /* 4328 ** optional SEARCH-ORDER word set 4329 */ 4330 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 4331 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 4332 dictAppendWord(dp, "definitions", 4333 definitions, FW_DEFAULT); 4334 dictAppendWord(dp, "forth-wordlist", 4335 forthWordlist, FW_DEFAULT); 4336 dictAppendWord(dp, "get-current", 4337 getCurrent, FW_DEFAULT); 4338 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 4339 dictAppendWord(dp, "search-wordlist", 4340 searchWordlist, FW_DEFAULT); 4341 dictAppendWord(dp, "set-current", 4342 setCurrent, FW_DEFAULT); 4343 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 4344 dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT); 4345 4346 /* 4347 ** Set SEARCH environment query values 4348 */ 4349 ficlSetEnv("search-order", FICL_TRUE); 4350 ficlSetEnv("search-order-ext", FICL_TRUE); 4351 ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); 4352 4353 /* 4354 ** TOOLS and TOOLS EXT 4355 */ 4356 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT); 4357 dictAppendWord(dp, "bye", bye, FW_DEFAULT); 4358 dictAppendWord(dp, "forget", forget, FW_DEFAULT); 4359 dictAppendWord(dp, "see", see, FW_DEFAULT); 4360 dictAppendWord(dp, "words", listWords, FW_DEFAULT); 4361 4362 /* 4363 ** Set TOOLS environment query values 4364 */ 4365 ficlSetEnv("tools", FICL_TRUE); 4366 ficlSetEnv("tools-ext", FICL_FALSE); 4367 4368 /* 4369 ** Ficl extras 4370 */ 4371 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); 4372 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); 4373 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); 4374 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); 4375 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */ 4376 dictAppendWord(dp, ">name", toName, FW_DEFAULT); 4377 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); 4378 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ 4379 dictAppendWord(dp, "compile-only", 4380 compileOnly, FW_DEFAULT); 4381 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); 4382 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); 4383 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); 4384 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ 4385 dictAppendWord(dp, "wid-set-super", 4386 setParentWid, FW_DEFAULT); 4387 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); 4388 dictAppendWord(dp, "w!", wStore, FW_DEFAULT); 4389 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); 4390#if FICL_WANT_USER 4391 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); 4392 dictAppendWord(dp, "user", userVariable, FW_DEFAULT); 4393#endif 4394 /* 4395 ** internal support words 4396 */ 4397 pExitParen = 4398 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); 4399 pSemiParen = 4400 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); 4401 pLitParen = 4402 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); 4403 pStringLit = 4404 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); 4405 pIfParen = 4406 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); 4407 pBranchParen = 4408 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); 4409 pDoParen = 4410 dictAppendWord(dp, "(do)", doParen, FW_COMPILE); 4411 pDoesParen = 4412 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); 4413 pQDoParen = 4414 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); 4415 pLoopParen = 4416 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); 4417 pPLoopParen = 4418 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); 4419 pInterpret = 4420 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); 4421 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); 4422 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); 4423 4424 return; 4425} 4426 4427