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