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