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