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