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 58static void colonParen(FICL_VM *pVM); 59static void literalIm(FICL_VM *pVM); 60static 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*/ 67static char doTag[] = "do"; 68static char colonTag[] = "colon"; 69static char leaveTag[] = "leave"; 70 71static char destTag[] = "target"; 72static char origTag[] = "origin"; 73 74static char caseTag[] = "case"; 75static char ofTag[] = "of"; 76static char fallthroughTag[] = "fallthrough"; 77 78#if FICL_WANT_LOCALS 79static void doLocalIm(FICL_VM *pVM); 80static 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*/ 90static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 91{ 92 PUSHPTR(dp->here); 93 PUSHPTR(tag); 94 return; 95} 96 97static void markControlTag(FICL_VM *pVM, char *tag) 98{ 99 PUSHPTR(tag); 100 return; 101} 102 103static 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*/ 126static 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*/ 149static 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*/ 171static 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 205int 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 279static 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 291static 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 303static 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 315static 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 326static 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*/ 347static 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 366static 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 378static 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 390static 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 402static 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 414static 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 433static 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 462static 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 491static 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**************************************************************************/ 508static void semiParen(FICL_VM *pVM) 509{ 510 vmPopIP(pVM); 511 return; 512} 513 514 515static 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**************************************************************************/ 549static void exitParen(FICL_VM *pVM) 550{ 551 vmPopIP(pVM); 552 return; 553} 554 555static 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 579void 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 589void 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 608static 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 622static 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 645static 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 658static 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 672static 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**/ 694static 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**************************************************************************/ 726static 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 857static 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 869static 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 879static 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 889static 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 899static 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 910static 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 919static 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 930static 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 941static 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 956static 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 968static 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 980static 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 990static 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 1000static 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 1016static void emit(FICL_VM *pVM) 1017{ 1018 char *cp = pVM->pad; 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 1032static void cr(FICL_VM *pVM) 1033{ 1034 vmTextOut(pVM, "", 1); 1035 return; 1036} 1037 1038 1039static 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*/ 1078static 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 1090static 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*/ 1107static 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*/ 1124static 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*/ 1140static 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 1151static 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 1162static 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 1173static 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 1183static 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 1194static 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 1204static 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 1215static 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 1233static 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 1246static 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 1276static 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 1302static 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 1328static 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 1349static 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 1366static 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 1415static 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 1445static 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 1485static 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 1529static 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 1570static 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 1599static 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**************************************************************************/ 1679static 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*/ 1736static 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 1754void 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 1769static 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 1792static 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 1802static 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 1822static 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 1834static 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 1851static 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 1862static 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 1873static 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 1884static 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 1897static 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 1909static 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 1921static 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 1933static void bitwiseAnd(FICL_VM *pVM) 1934{ 1935 CELL x, y; 1936#if FICL_ROBUST > 1 1937 vmCheckStack(pVM, 2, 1); 1938#endif 1939 x = stackPop(pVM->pStack); 1940 y = stackPop(pVM->pStack); 1941 PUSHINT(x.i & y.i); 1942 return; 1943} 1944 1945static void bitwiseOr(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 1957static void bitwiseXor(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 1969static void bitwiseNot(FICL_VM *pVM) 1970{ 1971 CELL x; 1972#if FICL_ROBUST > 1 1973 vmCheckStack(pVM, 1, 1); 1974#endif 1975 x = stackPop(pVM->pStack); 1976 PUSHINT(~x.i); 1977 return; 1978} 1979 1980 1981/************************************************************************** 1982 D o / L o o p 1983** do -- IMMEDIATE COMPILE ONLY 1984** Compiles code to initialize a loop: compile (do), 1985** allot space to hold the "leave" address, push a branch 1986** target address for the loop. 1987** (do) -- runtime for "do" 1988** pops index and limit from the p stack and moves them 1989** to the r stack, then skips to the loop body. 1990** loop -- IMMEDIATE COMPILE ONLY 1991** +loop 1992** Compiles code for the test part of a loop: 1993** compile (loop), resolve forward branch from "do", and 1994** copy "here" address to the "leave" address allotted by "do" 1995** i,j,k -- COMPILE ONLY 1996** Runtime: Push loop indices on param stack (i is innermost loop...) 1997** Note: each loop has three values on the return stack: 1998** ( R: leave limit index ) 1999** "leave" is the absolute address of the next cell after the loop 2000** limit and index are the loop control variables. 2001** leave -- COMPILE ONLY 2002** Runtime: pop the loop control variables, then pop the 2003** "leave" address and jump (absolute) there. 2004**************************************************************************/ 2005 2006static void doCoIm(FICL_VM *pVM) 2007{ 2008 FICL_DICT *dp = vmGetDict(pVM); 2009 2010 assert(pVM->pSys->pDoParen); 2011 2012 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen)); 2013 /* 2014 ** Allot space for a pointer to the end 2015 ** of the loop - "leave" uses this... 2016 */ 2017 markBranch(dp, pVM, leaveTag); 2018 dictAppendUNS(dp, 0); 2019 /* 2020 ** Mark location of head of loop... 2021 */ 2022 markBranch(dp, pVM, doTag); 2023 2024 return; 2025} 2026 2027 2028static void doParen(FICL_VM *pVM) 2029{ 2030 CELL index, limit; 2031#if FICL_ROBUST > 1 2032 vmCheckStack(pVM, 2, 0); 2033#endif 2034 index = stackPop(pVM->pStack); 2035 limit = stackPop(pVM->pStack); 2036 2037 /* copy "leave" target addr to stack */ 2038 stackPushPtr(pVM->rStack, *(pVM->ip++)); 2039 stackPush(pVM->rStack, limit); 2040 stackPush(pVM->rStack, index); 2041 2042 return; 2043} 2044 2045 2046static void qDoCoIm(FICL_VM *pVM) 2047{ 2048 FICL_DICT *dp = vmGetDict(pVM); 2049 2050 assert(pVM->pSys->pQDoParen); 2051 2052 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen)); 2053 /* 2054 ** Allot space for a pointer to the end 2055 ** of the loop - "leave" uses this... 2056 */ 2057 markBranch(dp, pVM, leaveTag); 2058 dictAppendUNS(dp, 0); 2059 /* 2060 ** Mark location of head of loop... 2061 */ 2062 markBranch(dp, pVM, doTag); 2063 2064 return; 2065} 2066 2067 2068static void qDoParen(FICL_VM *pVM) 2069{ 2070 CELL index, limit; 2071#if FICL_ROBUST > 1 2072 vmCheckStack(pVM, 2, 0); 2073#endif 2074 index = stackPop(pVM->pStack); 2075 limit = stackPop(pVM->pStack); 2076 2077 /* copy "leave" target addr to stack */ 2078 stackPushPtr(pVM->rStack, *(pVM->ip++)); 2079 2080 if (limit.u == index.u) 2081 { 2082 vmPopIP(pVM); 2083 } 2084 else 2085 { 2086 stackPush(pVM->rStack, limit); 2087 stackPush(pVM->rStack, index); 2088 } 2089 2090 return; 2091} 2092 2093 2094/* 2095** Runtime code to break out of a do..loop construct 2096** Drop the loop control variables; the branch address 2097** past "loop" is next on the return stack. 2098*/ 2099static void leaveCo(FICL_VM *pVM) 2100{ 2101 /* almost unloop */ 2102 stackDrop(pVM->rStack, 2); 2103 /* exit */ 2104 vmPopIP(pVM); 2105 return; 2106} 2107 2108 2109static void unloopCo(FICL_VM *pVM) 2110{ 2111 stackDrop(pVM->rStack, 3); 2112 return; 2113} 2114 2115 2116static void loopCoIm(FICL_VM *pVM) 2117{ 2118 FICL_DICT *dp = vmGetDict(pVM); 2119 2120 assert(pVM->pSys->pLoopParen); 2121 2122 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen)); 2123 resolveBackBranch(dp, pVM, doTag); 2124 resolveAbsBranch(dp, pVM, leaveTag); 2125 return; 2126} 2127 2128 2129static void plusLoopCoIm(FICL_VM *pVM) 2130{ 2131 FICL_DICT *dp = vmGetDict(pVM); 2132 2133 assert(pVM->pSys->pPLoopParen); 2134 2135 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen)); 2136 resolveBackBranch(dp, pVM, doTag); 2137 resolveAbsBranch(dp, pVM, leaveTag); 2138 return; 2139} 2140 2141 2142static void loopParen(FICL_VM *pVM) 2143{ 2144 FICL_INT index = stackGetTop(pVM->rStack).i; 2145 FICL_INT limit = stackFetch(pVM->rStack, 1).i; 2146 2147 index++; 2148 2149 if (index >= limit) 2150 { 2151 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 2152 vmBranchRelative(pVM, 1); /* fall through the loop */ 2153 } 2154 else 2155 { /* update index, branch to loop head */ 2156 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 2157 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 2158 } 2159 2160 return; 2161} 2162 2163 2164static void plusLoopParen(FICL_VM *pVM) 2165{ 2166 FICL_INT index,limit,increment; 2167 int flag; 2168 2169#if FICL_ROBUST > 1 2170 vmCheckStack(pVM, 1, 0); 2171#endif 2172 2173 index = stackGetTop(pVM->rStack).i; 2174 limit = stackFetch(pVM->rStack, 1).i; 2175 increment = POP().i; 2176 2177 index += increment; 2178 2179 if (increment < 0) 2180 flag = (index < limit); 2181 else 2182 flag = (index >= limit); 2183 2184 if (flag) 2185 { 2186 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 2187 vmBranchRelative(pVM, 1); /* fall through the loop */ 2188 } 2189 else 2190 { /* update index, branch to loop head */ 2191 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 2192 vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); 2193 } 2194 2195 return; 2196} 2197 2198 2199static void loopICo(FICL_VM *pVM) 2200{ 2201 CELL index = stackGetTop(pVM->rStack); 2202 stackPush(pVM->pStack, index); 2203 2204 return; 2205} 2206 2207 2208static void loopJCo(FICL_VM *pVM) 2209{ 2210 CELL index = stackFetch(pVM->rStack, 3); 2211 stackPush(pVM->pStack, index); 2212 2213 return; 2214} 2215 2216 2217static void loopKCo(FICL_VM *pVM) 2218{ 2219 CELL index = stackFetch(pVM->rStack, 6); 2220 stackPush(pVM->pStack, index); 2221 2222 return; 2223} 2224 2225 2226/************************************************************************** 2227 r e t u r n s t a c k 2228** 2229**************************************************************************/ 2230static void toRStack(FICL_VM *pVM) 2231{ 2232#if FICL_ROBUST > 1 2233 vmCheckStack(pVM, 1, 0); 2234#endif 2235 2236 stackPush(pVM->rStack, POP()); 2237} 2238 2239static void fromRStack(FICL_VM *pVM) 2240{ 2241#if FICL_ROBUST > 1 2242 vmCheckStack(pVM, 0, 1); 2243#endif 2244 2245 PUSH(stackPop(pVM->rStack)); 2246} 2247 2248static void fetchRStack(FICL_VM *pVM) 2249{ 2250#if FICL_ROBUST > 1 2251 vmCheckStack(pVM, 0, 1); 2252#endif 2253 2254 PUSH(stackGetTop(pVM->rStack)); 2255} 2256 2257static void twoToR(FICL_VM *pVM) 2258{ 2259#if FICL_ROBUST > 1 2260 vmCheckStack(pVM, 2, 0); 2261#endif 2262 stackRoll(pVM->pStack, 1); 2263 stackPush(pVM->rStack, stackPop(pVM->pStack)); 2264 stackPush(pVM->rStack, stackPop(pVM->pStack)); 2265 return; 2266} 2267 2268static void twoRFrom(FICL_VM *pVM) 2269{ 2270#if FICL_ROBUST > 1 2271 vmCheckStack(pVM, 0, 2); 2272#endif 2273 stackPush(pVM->pStack, stackPop(pVM->rStack)); 2274 stackPush(pVM->pStack, stackPop(pVM->rStack)); 2275 stackRoll(pVM->pStack, 1); 2276 return; 2277} 2278 2279static void twoRFetch(FICL_VM *pVM) 2280{ 2281#if FICL_ROBUST > 1 2282 vmCheckStack(pVM, 0, 2); 2283#endif 2284 stackPush(pVM->pStack, stackFetch(pVM->rStack, 1)); 2285 stackPush(pVM->pStack, stackFetch(pVM->rStack, 0)); 2286 return; 2287} 2288 2289 2290/************************************************************************** 2291 v a r i a b l e 2292** 2293**************************************************************************/ 2294 2295static void variableParen(FICL_VM *pVM) 2296{ 2297 FICL_WORD *fw; 2298#if FICL_ROBUST > 1 2299 vmCheckStack(pVM, 0, 1); 2300#endif 2301 2302 fw = pVM->runningWord; 2303 PUSHPTR(fw->param); 2304} 2305 2306 2307static void variable(FICL_VM *pVM) 2308{ 2309 FICL_DICT *dp = vmGetDict(pVM); 2310 STRINGINFO si = vmGetWord(pVM); 2311 2312 dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 2313 dictAllotCells(dp, 1); 2314 return; 2315} 2316 2317 2318static void twoVariable(FICL_VM *pVM) 2319{ 2320 FICL_DICT *dp = vmGetDict(pVM); 2321 STRINGINFO si = vmGetWord(pVM); 2322 2323 dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 2324 dictAllotCells(dp, 2); 2325 return; 2326} 2327 2328 2329/************************************************************************** 2330 b a s e & f r i e n d s 2331** 2332**************************************************************************/ 2333 2334static void base(FICL_VM *pVM) 2335{ 2336 CELL *pBase; 2337#if FICL_ROBUST > 1 2338 vmCheckStack(pVM, 0, 1); 2339#endif 2340 2341 pBase = (CELL *)(&pVM->base); 2342 stackPush(pVM->pStack, LVALUEtoCELL(pBase)); 2343 return; 2344} 2345 2346 2347static void decimal(FICL_VM *pVM) 2348{ 2349 pVM->base = 10; 2350 return; 2351} 2352 2353 2354static void hex(FICL_VM *pVM) 2355{ 2356 pVM->base = 16; 2357 return; 2358} 2359 2360 2361/************************************************************************** 2362 a l l o t & f r i e n d s 2363** 2364**************************************************************************/ 2365 2366static void allot(FICL_VM *pVM) 2367{ 2368 FICL_DICT *dp; 2369 FICL_INT i; 2370#if FICL_ROBUST > 1 2371 vmCheckStack(pVM, 1, 0); 2372#endif 2373 2374 dp = vmGetDict(pVM); 2375 i = POPINT(); 2376 2377#if FICL_ROBUST 2378 dictCheck(dp, pVM, i); 2379#endif 2380 2381 dictAllot(dp, i); 2382 return; 2383} 2384 2385 2386static void here(FICL_VM *pVM) 2387{ 2388 FICL_DICT *dp; 2389#if FICL_ROBUST > 1 2390 vmCheckStack(pVM, 0, 1); 2391#endif 2392 2393 dp = vmGetDict(pVM); 2394 PUSHPTR(dp->here); 2395 return; 2396} 2397 2398static void comma(FICL_VM *pVM) 2399{ 2400 FICL_DICT *dp; 2401 CELL c; 2402#if FICL_ROBUST > 1 2403 vmCheckStack(pVM, 1, 0); 2404#endif 2405 2406 dp = vmGetDict(pVM); 2407 c = POP(); 2408 dictAppendCell(dp, c); 2409 return; 2410} 2411 2412static void cComma(FICL_VM *pVM) 2413{ 2414 FICL_DICT *dp; 2415 char c; 2416#if FICL_ROBUST > 1 2417 vmCheckStack(pVM, 1, 0); 2418#endif 2419 2420 dp = vmGetDict(pVM); 2421 c = (char)POPINT(); 2422 dictAppendChar(dp, c); 2423 return; 2424} 2425 2426static void cells(FICL_VM *pVM) 2427{ 2428 FICL_INT i; 2429#if FICL_ROBUST > 1 2430 vmCheckStack(pVM, 1, 1); 2431#endif 2432 2433 i = POPINT(); 2434 PUSHINT(i * (FICL_INT)sizeof (CELL)); 2435 return; 2436} 2437 2438static void cellPlus(FICL_VM *pVM) 2439{ 2440 char *cp; 2441#if FICL_ROBUST > 1 2442 vmCheckStack(pVM, 1, 1); 2443#endif 2444 2445 cp = POPPTR(); 2446 PUSHPTR(cp + sizeof (CELL)); 2447 return; 2448} 2449 2450 2451 2452/************************************************************************** 2453 t i c k 2454** tick CORE ( "<spaces>name" -- xt ) 2455** Skip leading space delimiters. Parse name delimited by a space. Find 2456** name and return xt, the execution token for name. An ambiguous condition 2457** exists if name is not found. 2458**************************************************************************/ 2459void ficlTick(FICL_VM *pVM) 2460{ 2461 FICL_WORD *pFW = NULL; 2462 STRINGINFO si = vmGetWord(pVM); 2463#if FICL_ROBUST > 1 2464 vmCheckStack(pVM, 0, 1); 2465#endif 2466 2467 pFW = dictLookup(vmGetDict(pVM), si); 2468 if (!pFW) 2469 { 2470 int i = SI_COUNT(si); 2471 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 2472 } 2473 PUSHPTR(pFW); 2474 return; 2475} 2476 2477 2478static void bracketTickCoIm(FICL_VM *pVM) 2479{ 2480 ficlTick(pVM); 2481 literalIm(pVM); 2482 2483 return; 2484} 2485 2486 2487/************************************************************************** 2488 p o s t p o n e 2489** Lookup the next word in the input stream and compile code to 2490** insert it into definitions created by the resulting word 2491** (defers compilation, even of immediate words) 2492**************************************************************************/ 2493 2494static void postponeCoIm(FICL_VM *pVM) 2495{ 2496 FICL_DICT *dp = vmGetDict(pVM); 2497 FICL_WORD *pFW; 2498 FICL_WORD *pComma = ficlLookup(pVM->pSys, ","); 2499 assert(pComma); 2500 2501 ficlTick(pVM); 2502 pFW = stackGetTop(pVM->pStack).p; 2503 if (wordIsImmediate(pFW)) 2504 { 2505 dictAppendCell(dp, stackPop(pVM->pStack)); 2506 } 2507 else 2508 { 2509 literalIm(pVM); 2510 dictAppendCell(dp, LVALUEtoCELL(pComma)); 2511 } 2512 2513 return; 2514} 2515 2516 2517 2518/************************************************************************** 2519 e x e c u t e 2520** Pop an execution token (pointer to a word) off the stack and 2521** run it 2522**************************************************************************/ 2523 2524static void execute(FICL_VM *pVM) 2525{ 2526 FICL_WORD *pFW; 2527#if FICL_ROBUST > 1 2528 vmCheckStack(pVM, 1, 0); 2529#endif 2530 2531 pFW = stackPopPtr(pVM->pStack); 2532 vmExecute(pVM, pFW); 2533 2534 return; 2535} 2536 2537 2538/************************************************************************** 2539 i m m e d i a t e 2540** Make the most recently compiled word IMMEDIATE -- it executes even 2541** in compile state (most often used for control compiling words 2542** such as IF, THEN, etc) 2543**************************************************************************/ 2544 2545static void immediate(FICL_VM *pVM) 2546{ 2547 IGNORE(pVM); 2548 dictSetImmediate(vmGetDict(pVM)); 2549 return; 2550} 2551 2552 2553static void compileOnly(FICL_VM *pVM) 2554{ 2555 IGNORE(pVM); 2556 dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0); 2557 return; 2558} 2559 2560 2561static void setObjectFlag(FICL_VM *pVM) 2562{ 2563 IGNORE(pVM); 2564 dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0); 2565 return; 2566} 2567 2568static void isObject(FICL_VM *pVM) 2569{ 2570 FICL_INT flag; 2571 FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 2572 2573 flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE; 2574 stackPushINT(pVM->pStack, flag); 2575 return; 2576} 2577 2578static void cstringLit(FICL_VM *pVM) 2579{ 2580 FICL_STRING *sp = (FICL_STRING *)(pVM->ip); 2581 2582 char *cp = sp->text; 2583 cp += sp->count + 1; 2584 cp = alignPtr(cp); 2585 pVM->ip = (IPTYPE)(void *)cp; 2586 2587 stackPushPtr(pVM->pStack, sp); 2588 return; 2589} 2590 2591 2592static void cstringQuoteIm(FICL_VM *pVM) 2593{ 2594 FICL_DICT *dp = vmGetDict(pVM); 2595 2596 if (pVM->state == INTERPRET) 2597 { 2598 FICL_STRING *sp = (FICL_STRING *) dp->here; 2599 vmGetString(pVM, sp, '\"'); 2600 stackPushPtr(pVM->pStack, sp); 2601 /* move HERE past string so it doesn't get overwritten. --lch */ 2602 dictAllot(dp, sp->count + sizeof(FICL_COUNT)); 2603 } 2604 else /* COMPILE state */ 2605 { 2606 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit)); 2607 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2608 dictAlign(dp); 2609 } 2610 2611 return; 2612} 2613 2614/************************************************************************** 2615 d o t Q u o t e 2616** IMMEDIATE word that compiles a string literal for later display 2617** Compile stringLit, then copy the bytes of the string from the TIB 2618** to the dictionary. Backpatch the count byte and align the dictionary. 2619** 2620** stringlit: Fetch the count from the dictionary, then push the address 2621** and count on the stack. Finally, update ip to point to the first 2622** aligned address after the string text. 2623**************************************************************************/ 2624 2625static void stringLit(FICL_VM *pVM) 2626{ 2627 FICL_STRING *sp; 2628 FICL_COUNT count; 2629 char *cp; 2630#if FICL_ROBUST > 1 2631 vmCheckStack(pVM, 0, 2); 2632#endif 2633 2634 sp = (FICL_STRING *)(pVM->ip); 2635 count = sp->count; 2636 cp = sp->text; 2637 PUSHPTR(cp); 2638 PUSHUNS(count); 2639 cp += count + 1; 2640 cp = alignPtr(cp); 2641 pVM->ip = (IPTYPE)(void *)cp; 2642} 2643 2644static void dotQuoteCoIm(FICL_VM *pVM) 2645{ 2646 FICL_DICT *dp = vmGetDict(pVM); 2647 FICL_WORD *pType = ficlLookup(pVM->pSys, "type"); 2648 assert(pType); 2649 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 2650 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2651 dictAlign(dp); 2652 dictAppendCell(dp, LVALUEtoCELL(pType)); 2653 return; 2654} 2655 2656 2657static void dotParen(FICL_VM *pVM) 2658{ 2659 char *pSrc = vmGetInBuf(pVM); 2660 char *pEnd = vmGetInBufEnd(pVM); 2661 char *pDest = pVM->pad; 2662 char ch; 2663 2664 /* 2665 ** Note: the standard does not want leading spaces skipped (apparently) 2666 */ 2667 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) 2668 *pDest++ = ch; 2669 2670 *pDest = '\0'; 2671 if ((pEnd != pSrc) && (ch == ')')) 2672 pSrc++; 2673 2674 vmTextOut(pVM, pVM->pad, 0); 2675 vmUpdateTib(pVM, pSrc); 2676 2677 return; 2678} 2679 2680 2681/************************************************************************** 2682 s l i t e r a l 2683** STRING 2684** Interpretation: Interpretation semantics for this word are undefined. 2685** Compilation: ( c-addr1 u -- ) 2686** Append the run-time semantics given below to the current definition. 2687** Run-time: ( -- c-addr2 u ) 2688** Return c-addr2 u describing a string consisting of the characters 2689** specified by c-addr1 u during compilation. A program shall not alter 2690** the returned string. 2691**************************************************************************/ 2692static void sLiteralCoIm(FICL_VM *pVM) 2693{ 2694 FICL_DICT *dp; 2695 char *cp, *cpDest; 2696 FICL_UNS u; 2697 2698#if FICL_ROBUST > 1 2699 vmCheckStack(pVM, 2, 0); 2700#endif 2701 2702 dp = vmGetDict(pVM); 2703 u = POPUNS(); 2704 cp = POPPTR(); 2705 2706 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 2707 cpDest = (char *) dp->here; 2708 *cpDest++ = (char) u; 2709 2710 for (; u > 0; --u) 2711 { 2712 *cpDest++ = *cp++; 2713 } 2714 2715 *cpDest++ = 0; 2716 dp->here = PTRtoCELL alignPtr(cpDest); 2717 return; 2718} 2719 2720 2721/************************************************************************** 2722 s t a t e 2723** Return the address of the VM's state member (must be sized the 2724** same as a CELL for this reason) 2725**************************************************************************/ 2726static void state(FICL_VM *pVM) 2727{ 2728#if FICL_ROBUST > 1 2729 vmCheckStack(pVM, 0, 1); 2730#endif 2731 PUSHPTR(&pVM->state); 2732 return; 2733} 2734 2735 2736/************************************************************************** 2737 c r e a t e . . . d o e s > 2738** Make a new word in the dictionary with the run-time effect of 2739** a variable (push my address), but with extra space allotted 2740** for use by does> . 2741**************************************************************************/ 2742 2743static void createParen(FICL_VM *pVM) 2744{ 2745 CELL *pCell; 2746 2747#if FICL_ROBUST > 1 2748 vmCheckStack(pVM, 0, 1); 2749#endif 2750 2751 pCell = pVM->runningWord->param; 2752 PUSHPTR(pCell+1); 2753 return; 2754} 2755 2756 2757static void create(FICL_VM *pVM) 2758{ 2759 FICL_DICT *dp = vmGetDict(pVM); 2760 STRINGINFO si = vmGetWord(pVM); 2761 2762 dictCheckThreshold(dp); 2763 2764 dictAppendWord2(dp, si, createParen, FW_DEFAULT); 2765 dictAllotCells(dp, 1); 2766 return; 2767} 2768 2769 2770static void doDoes(FICL_VM *pVM) 2771{ 2772 CELL *pCell; 2773 IPTYPE tempIP; 2774#if FICL_ROBUST > 1 2775 vmCheckStack(pVM, 0, 1); 2776#endif 2777 2778 pCell = pVM->runningWord->param; 2779 tempIP = (IPTYPE)((*pCell).p); 2780 PUSHPTR(pCell+1); 2781 vmPushIP(pVM, tempIP); 2782 return; 2783} 2784 2785 2786static void doesParen(FICL_VM *pVM) 2787{ 2788 FICL_DICT *dp = vmGetDict(pVM); 2789 dp->smudge->code = doDoes; 2790 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); 2791 vmPopIP(pVM); 2792 return; 2793} 2794 2795 2796static void doesCoIm(FICL_VM *pVM) 2797{ 2798 FICL_DICT *dp = vmGetDict(pVM); 2799#if FICL_WANT_LOCALS 2800 assert(pVM->pSys->pUnLinkParen); 2801 if (pVM->pSys->nLocals > 0) 2802 { 2803 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 2804 dictEmpty(pLoc, pLoc->pForthWords->size); 2805 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); 2806 } 2807 2808 pVM->pSys->nLocals = 0; 2809#endif 2810 IGNORE(pVM); 2811 2812 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen)); 2813 return; 2814} 2815 2816 2817/************************************************************************** 2818 t o b o d y 2819** to-body CORE ( xt -- a-addr ) 2820** a-addr is the data-field address corresponding to xt. An ambiguous 2821** condition exists if xt is not for a word defined via CREATE. 2822**************************************************************************/ 2823static void toBody(FICL_VM *pVM) 2824{ 2825 FICL_WORD *pFW; 2826/*#$-GUY CHANGE: Added robustness.-$#*/ 2827#if FICL_ROBUST > 1 2828 vmCheckStack(pVM, 1, 1); 2829#endif 2830 2831 pFW = POPPTR(); 2832 PUSHPTR(pFW->param + 1); 2833 return; 2834} 2835 2836 2837/* 2838** from-body ficl ( a-addr -- xt ) 2839** Reverse effect of >body 2840*/ 2841static void fromBody(FICL_VM *pVM) 2842{ 2843 char *ptr; 2844#if FICL_ROBUST > 1 2845 vmCheckStack(pVM, 1, 1); 2846#endif 2847 2848 ptr = (char *)POPPTR() - sizeof (FICL_WORD); 2849 PUSHPTR(ptr); 2850 return; 2851} 2852 2853 2854/* 2855** >name ficl ( xt -- c-addr u ) 2856** Push the address and length of a word's name given its address 2857** xt. 2858*/ 2859static void toName(FICL_VM *pVM) 2860{ 2861 FICL_WORD *pFW; 2862#if FICL_ROBUST > 1 2863 vmCheckStack(pVM, 1, 2); 2864#endif 2865 2866 pFW = POPPTR(); 2867 PUSHPTR(pFW->name); 2868 PUSHUNS(pFW->nName); 2869 return; 2870} 2871 2872 2873static void getLastWord(FICL_VM *pVM) 2874{ 2875 FICL_DICT *pDict = vmGetDict(pVM); 2876 FICL_WORD *wp = pDict->smudge; 2877 assert(wp); 2878 vmPush(pVM, LVALUEtoCELL(wp)); 2879 return; 2880} 2881 2882 2883/************************************************************************** 2884 l b r a c k e t e t c 2885** 2886**************************************************************************/ 2887 2888static void lbracketCoIm(FICL_VM *pVM) 2889{ 2890 pVM->state = INTERPRET; 2891 return; 2892} 2893 2894 2895static void rbracket(FICL_VM *pVM) 2896{ 2897 pVM->state = COMPILE; 2898 return; 2899} 2900 2901 2902/************************************************************************** 2903 p i c t u r e d n u m e r i c w o r d s 2904** 2905** less-number-sign CORE ( -- ) 2906** Initialize the pictured numeric output conversion process. 2907** (clear the pad) 2908**************************************************************************/ 2909static void lessNumberSign(FICL_VM *pVM) 2910{ 2911 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2912 sp->count = 0; 2913 return; 2914} 2915 2916/* 2917** number-sign CORE ( ud1 -- ud2 ) 2918** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 2919** n. (n is the least-significant digit of ud1.) Convert n to external form 2920** and add the resulting character to the beginning of the pictured numeric 2921** output string. An ambiguous condition exists if # executes outside of a 2922** <# #> delimited number conversion. 2923*/ 2924static void numberSign(FICL_VM *pVM) 2925{ 2926 FICL_STRING *sp; 2927 DPUNS u; 2928 UNS16 rem; 2929#if FICL_ROBUST > 1 2930 vmCheckStack(pVM, 2, 2); 2931#endif 2932 2933 sp = PTRtoSTRING pVM->pad; 2934 u = u64Pop(pVM->pStack); 2935 rem = m64UMod(&u, (UNS16)(pVM->base)); 2936 sp->text[sp->count++] = digit_to_char(rem); 2937 u64Push(pVM->pStack, u); 2938 return; 2939} 2940 2941/* 2942** number-sign-greater CORE ( xd -- c-addr u ) 2943** Drop xd. Make the pictured numeric output string available as a character 2944** string. c-addr and u specify the resulting character string. A program 2945** may replace characters within the string. 2946*/ 2947static void numberSignGreater(FICL_VM *pVM) 2948{ 2949 FICL_STRING *sp; 2950#if FICL_ROBUST > 1 2951 vmCheckStack(pVM, 2, 2); 2952#endif 2953 2954 sp = PTRtoSTRING pVM->pad; 2955 sp->text[sp->count] = 0; 2956 strrev(sp->text); 2957 DROP(2); 2958 PUSHPTR(sp->text); 2959 PUSHUNS(sp->count); 2960 return; 2961} 2962 2963/* 2964** number-sign-s CORE ( ud1 -- ud2 ) 2965** Convert one digit of ud1 according to the rule for #. Continue conversion 2966** until the quotient is zero. ud2 is zero. An ambiguous condition exists if 2967** #S executes outside of a <# #> delimited number conversion. 2968** TO DO: presently does not use ud1 hi cell - use it! 2969*/ 2970static void numberSignS(FICL_VM *pVM) 2971{ 2972 FICL_STRING *sp; 2973 DPUNS u; 2974 UNS16 rem; 2975#if FICL_ROBUST > 1 2976 vmCheckStack(pVM, 2, 2); 2977#endif 2978 2979 sp = PTRtoSTRING pVM->pad; 2980 u = u64Pop(pVM->pStack); 2981 2982 do 2983 { 2984 rem = m64UMod(&u, (UNS16)(pVM->base)); 2985 sp->text[sp->count++] = digit_to_char(rem); 2986 } 2987 while (u.hi || u.lo); 2988 2989 u64Push(pVM->pStack, u); 2990 return; 2991} 2992 2993/* 2994** HOLD CORE ( char -- ) 2995** Add char to the beginning of the pictured numeric output string. An ambiguous 2996** condition exists if HOLD executes outside of a <# #> delimited number conversion. 2997*/ 2998static void hold(FICL_VM *pVM) 2999{ 3000 FICL_STRING *sp; 3001 int i; 3002#if FICL_ROBUST > 1 3003 vmCheckStack(pVM, 1, 0); 3004#endif 3005 3006 sp = PTRtoSTRING pVM->pad; 3007 i = POPINT(); 3008 sp->text[sp->count++] = (char) i; 3009 return; 3010} 3011 3012/* 3013** SIGN CORE ( n -- ) 3014** If n is negative, add a minus sign to the beginning of the pictured 3015** numeric output string. An ambiguous condition exists if SIGN 3016** executes outside of a <# #> delimited number conversion. 3017*/ 3018static void sign(FICL_VM *pVM) 3019{ 3020 FICL_STRING *sp; 3021 int i; 3022#if FICL_ROBUST > 1 3023 vmCheckStack(pVM, 1, 0); 3024#endif 3025 3026 sp = PTRtoSTRING pVM->pad; 3027 i = POPINT(); 3028 if (i < 0) 3029 sp->text[sp->count++] = '-'; 3030 return; 3031} 3032 3033 3034/************************************************************************** 3035 t o N u m b e r 3036** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 3037** ud2 is the unsigned result of converting the characters within the 3038** string specified by c-addr1 u1 into digits, using the number in BASE, 3039** and adding each into ud1 after multiplying ud1 by the number in BASE. 3040** Conversion continues left-to-right until a character that is not 3041** convertible, including any + or -, is encountered or the string is 3042** entirely converted. c-addr2 is the location of the first unconverted 3043** character or the first character past the end of the string if the string 3044** was entirely converted. u2 is the number of unconverted characters in the 3045** string. An ambiguous condition exists if ud2 overflows during the 3046** conversion. 3047**************************************************************************/ 3048static void toNumber(FICL_VM *pVM) 3049{ 3050 FICL_UNS count; 3051 char *cp; 3052 DPUNS accum; 3053 FICL_UNS base = pVM->base; 3054 FICL_UNS ch; 3055 FICL_UNS digit; 3056 3057#if FICL_ROBUST > 1 3058 vmCheckStack(pVM,4,4); 3059#endif 3060 3061 count = POPUNS(); 3062 cp = (char *)POPPTR(); 3063 accum = u64Pop(pVM->pStack); 3064 3065 for (ch = *cp; count > 0; ch = *++cp, count--) 3066 { 3067 if (ch < '0') 3068 break; 3069 3070 digit = ch - '0'; 3071 3072 if (digit > 9) 3073 digit = tolower(ch) - 'a' + 10; 3074 /* 3075 ** Note: following test also catches chars between 9 and a 3076 ** because 'digit' is unsigned! 3077 */ 3078 if (digit >= base) 3079 break; 3080 3081 accum = m64Mac(accum, base, digit); 3082 } 3083 3084 u64Push(pVM->pStack, accum); 3085 PUSHPTR(cp); 3086 PUSHUNS(count); 3087 3088 return; 3089} 3090 3091 3092 3093/************************************************************************** 3094 q u i t & a b o r t 3095** quit CORE ( -- ) ( R: i*x -- ) 3096** Empty the return stack, store zero in SOURCE-ID if it is present, make 3097** the user input device the input source, and enter interpretation state. 3098** Do not display a message. Repeat the following: 3099** 3100** Accept a line from the input source into the input buffer, set >IN to 3101** zero, and interpret. 3102** Display the implementation-defined system prompt if in 3103** interpretation state, all processing has been completed, and no 3104** ambiguous condition exists. 3105**************************************************************************/ 3106 3107static void quit(FICL_VM *pVM) 3108{ 3109 vmThrow(pVM, VM_QUIT); 3110 return; 3111} 3112 3113 3114static void ficlAbort(FICL_VM *pVM) 3115{ 3116 vmThrow(pVM, VM_ABORT); 3117 return; 3118} 3119 3120 3121/************************************************************************** 3122 a c c e p t 3123** accept CORE ( c-addr +n1 -- +n2 ) 3124** Receive a string of at most +n1 characters. An ambiguous condition 3125** exists if +n1 is zero or greater than 32,767. Display graphic characters 3126** as they are received. A program that depends on the presence or absence 3127** of non-graphic characters in the string has an environmental dependency. 3128** The editing functions, if any, that the system performs in order to 3129** construct the string are implementation-defined. 3130** 3131** (Although the standard text doesn't say so, I assume that the intent 3132** of 'accept' is to store the string at the address specified on 3133** the stack.) 3134** Implementation: if there's more text in the TIB, use it. Otherwise 3135** throw out for more text. Copy characters up to the max count into the 3136** address given, and return the number of actual characters copied. 3137** 3138** Note (sobral) this may not be the behavior you'd expect if you're 3139** trying to get user input at load time! 3140**************************************************************************/ 3141static void accept(FICL_VM *pVM) 3142{ 3143 FICL_UNS count, len; 3144 char *cp; 3145 char *pBuf, *pEnd; 3146 3147#if FICL_ROBUST > 1 3148 vmCheckStack(pVM,2,1); 3149#endif 3150 3151 pBuf = vmGetInBuf(pVM); 3152 pEnd = vmGetInBufEnd(pVM); 3153 len = pEnd - pBuf; 3154 if (len == 0) 3155 vmThrow(pVM, VM_RESTART); 3156 3157 /* 3158 ** Now we have something in the text buffer - use it 3159 */ 3160 count = stackPopINT(pVM->pStack); 3161 cp = stackPopPtr(pVM->pStack); 3162 3163 len = (count < len) ? count : len; 3164 strncpy(cp, vmGetInBuf(pVM), len); 3165 pBuf += len; 3166 vmUpdateTib(pVM, pBuf); 3167 PUSHINT(len); 3168 3169 return; 3170} 3171 3172 3173/************************************************************************** 3174 a l i g n 3175** 6.1.0705 ALIGN CORE ( -- ) 3176** If the data-space pointer is not aligned, reserve enough space to 3177** align it. 3178**************************************************************************/ 3179static void align(FICL_VM *pVM) 3180{ 3181 FICL_DICT *dp = vmGetDict(pVM); 3182 IGNORE(pVM); 3183 dictAlign(dp); 3184 return; 3185} 3186 3187 3188/************************************************************************** 3189 a l i g n e d 3190** 3191**************************************************************************/ 3192static void aligned(FICL_VM *pVM) 3193{ 3194 void *addr; 3195#if FICL_ROBUST > 1 3196 vmCheckStack(pVM,1,1); 3197#endif 3198 3199 addr = POPPTR(); 3200 PUSHPTR(alignPtr(addr)); 3201 return; 3202} 3203 3204 3205/************************************************************************** 3206 b e g i n & f r i e n d s 3207** Indefinite loop control structures 3208** A.6.1.0760 BEGIN 3209** Typical use: 3210** : X ... BEGIN ... test UNTIL ; 3211** or 3212** : X ... BEGIN ... test WHILE ... REPEAT ; 3213**************************************************************************/ 3214static void beginCoIm(FICL_VM *pVM) 3215{ 3216 FICL_DICT *dp = vmGetDict(pVM); 3217 markBranch(dp, pVM, destTag); 3218 return; 3219} 3220 3221static void untilCoIm(FICL_VM *pVM) 3222{ 3223 FICL_DICT *dp = vmGetDict(pVM); 3224 3225 assert(pVM->pSys->pBranch0); 3226 3227 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); 3228 resolveBackBranch(dp, pVM, destTag); 3229 return; 3230} 3231 3232static void whileCoIm(FICL_VM *pVM) 3233{ 3234 FICL_DICT *dp = vmGetDict(pVM); 3235 3236 assert(pVM->pSys->pBranch0); 3237 3238 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); 3239 markBranch(dp, pVM, origTag); 3240 twoSwap(pVM); 3241 dictAppendUNS(dp, 1); 3242 return; 3243} 3244 3245static void repeatCoIm(FICL_VM *pVM) 3246{ 3247 FICL_DICT *dp = vmGetDict(pVM); 3248 3249 assert(pVM->pSys->pBranchParen); 3250 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 3251 3252 /* expect "begin" branch marker */ 3253 resolveBackBranch(dp, pVM, destTag); 3254 /* expect "while" branch marker */ 3255 resolveForwardBranch(dp, pVM, origTag); 3256 return; 3257} 3258 3259 3260static void againCoIm(FICL_VM *pVM) 3261{ 3262 FICL_DICT *dp = vmGetDict(pVM); 3263 3264 assert(pVM->pSys->pBranchParen); 3265 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); 3266 3267 /* expect "begin" branch marker */ 3268 resolveBackBranch(dp, pVM, destTag); 3269 return; 3270} 3271 3272 3273/************************************************************************** 3274 c h a r & f r i e n d s 3275** 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 3276** Skip leading space delimiters. Parse name delimited by a space. 3277** Put the value of its first character onto the stack. 3278** 3279** bracket-char CORE 3280** Interpretation: Interpretation semantics for this word are undefined. 3281** Compilation: ( "<spaces>name" -- ) 3282** Skip leading space delimiters. Parse name delimited by a space. 3283** Append the run-time semantics given below to the current definition. 3284** Run-time: ( -- char ) 3285** Place char, the value of the first character of name, on the stack. 3286**************************************************************************/ 3287static void ficlChar(FICL_VM *pVM) 3288{ 3289 STRINGINFO si; 3290#if FICL_ROBUST > 1 3291 vmCheckStack(pVM,0,1); 3292#endif 3293 3294 si = vmGetWord(pVM); 3295 PUSHUNS((FICL_UNS)(si.cp[0])); 3296 return; 3297} 3298 3299static void charCoIm(FICL_VM *pVM) 3300{ 3301 ficlChar(pVM); 3302 literalIm(pVM); 3303 return; 3304} 3305 3306/************************************************************************** 3307 c h a r P l u s 3308** char-plus CORE ( c-addr1 -- c-addr2 ) 3309** Add the size in address units of a character to c-addr1, giving c-addr2. 3310**************************************************************************/ 3311static void charPlus(FICL_VM *pVM) 3312{ 3313 char *cp; 3314#if FICL_ROBUST > 1 3315 vmCheckStack(pVM,1,1); 3316#endif 3317 3318 cp = POPPTR(); 3319 PUSHPTR(cp + 1); 3320 return; 3321} 3322 3323/************************************************************************** 3324 c h a r s 3325** chars CORE ( n1 -- n2 ) 3326** n2 is the size in address units of n1 characters. 3327** For most processors, this function can be a no-op. To guarantee 3328** portability, we'll multiply by sizeof (char). 3329**************************************************************************/ 3330#if defined (_M_IX86) 3331#pragma warning(disable: 4127) 3332#endif 3333static void ficlChars(FICL_VM *pVM) 3334{ 3335 if (sizeof (char) > 1) 3336 { 3337 FICL_INT i; 3338#if FICL_ROBUST > 1 3339 vmCheckStack(pVM,1,1); 3340#endif 3341 i = POPINT(); 3342 PUSHINT(i * sizeof (char)); 3343 } 3344 /* otherwise no-op! */ 3345 return; 3346} 3347#if defined (_M_IX86) 3348#pragma warning(default: 4127) 3349#endif 3350 3351 3352/************************************************************************** 3353 c o u n t 3354** COUNT CORE ( c-addr1 -- c-addr2 u ) 3355** Return the character string specification for the counted string stored 3356** at c-addr1. c-addr2 is the address of the first character after c-addr1. 3357** u is the contents of the character at c-addr1, which is the length in 3358** characters of the string at c-addr2. 3359**************************************************************************/ 3360static void count(FICL_VM *pVM) 3361{ 3362 FICL_STRING *sp; 3363#if FICL_ROBUST > 1 3364 vmCheckStack(pVM,1,2); 3365#endif 3366 3367 sp = POPPTR(); 3368 PUSHPTR(sp->text); 3369 PUSHUNS(sp->count); 3370 return; 3371} 3372 3373/************************************************************************** 3374 e n v i r o n m e n t ? 3375** environment-query CORE ( c-addr u -- false | i*x true ) 3376** c-addr is the address of a character string and u is the string's 3377** character count. u may have a value in the range from zero to an 3378** implementation-defined maximum which shall not be less than 31. The 3379** character string should contain a keyword from 3.2.6 Environmental 3380** queries or the optional word sets to be checked for correspondence 3381** with an attribute of the present environment. If the system treats the 3382** attribute as unknown, the returned flag is false; otherwise, the flag 3383** is true and the i*x returned is of the type specified in the table for 3384** the attribute queried. 3385**************************************************************************/ 3386static void environmentQ(FICL_VM *pVM) 3387{ 3388 FICL_DICT *envp; 3389 FICL_WORD *pFW; 3390 STRINGINFO si; 3391#if FICL_ROBUST > 1 3392 vmCheckStack(pVM,2,1); 3393#endif 3394 3395 envp = pVM->pSys->envp; 3396 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 3397 si.cp = stackPopPtr(pVM->pStack); 3398 3399 pFW = dictLookup(envp, si); 3400 3401 if (pFW != NULL) 3402 { 3403 vmExecute(pVM, pFW); 3404 PUSHINT(FICL_TRUE); 3405 } 3406 else 3407 { 3408 PUSHINT(FICL_FALSE); 3409 } 3410 return; 3411} 3412 3413/************************************************************************** 3414 e v a l u a t e 3415** EVALUATE CORE ( i*x c-addr u -- j*x ) 3416** Save the current input source specification. Store minus-one (-1) in 3417** SOURCE-ID if it is present. Make the string described by c-addr and u 3418** both the input source and input buffer, set >IN to zero, and interpret. 3419** When the parse area is empty, restore the prior input source 3420** specification. Other stack effects are due to the words EVALUATEd. 3421** 3422**************************************************************************/ 3423static void evaluate(FICL_VM *pVM) 3424{ 3425 FICL_UNS count; 3426 char *cp; 3427 CELL id; 3428 int result; 3429#if FICL_ROBUST > 1 3430 vmCheckStack(pVM,2,0); 3431#endif 3432 3433 count = POPUNS(); 3434 cp = POPPTR(); 3435 3436 IGNORE(count); 3437 id = pVM->sourceID; 3438 pVM->sourceID.i = -1; 3439 result = ficlExecC(pVM, cp, count); 3440 pVM->sourceID = id; 3441 if (result != VM_OUTOFTEXT) 3442 vmThrow(pVM, result); 3443 3444 return; 3445} 3446 3447 3448/************************************************************************** 3449 s t r i n g q u o t e 3450** Interpreting: get string delimited by a quote from the input stream, 3451** copy to a scratch area, and put its count and address on the stack. 3452** Compiling: compile code to push the address and count of a string 3453** literal, compile the string from the input stream, and align the dict 3454** pointer. 3455**************************************************************************/ 3456static void stringQuoteIm(FICL_VM *pVM) 3457{ 3458 FICL_DICT *dp = vmGetDict(pVM); 3459 3460 if (pVM->state == INTERPRET) 3461 { 3462 FICL_STRING *sp = (FICL_STRING *) dp->here; 3463 vmGetString(pVM, sp, '\"'); 3464 PUSHPTR(sp->text); 3465 PUSHUNS(sp->count); 3466 } 3467 else /* COMPILE state */ 3468 { 3469 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); 3470 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 3471 dictAlign(dp); 3472 } 3473 3474 return; 3475} 3476 3477 3478/************************************************************************** 3479 t y p e 3480** Pop count and char address from stack and print the designated string. 3481**************************************************************************/ 3482static void type(FICL_VM *pVM) 3483{ 3484 FICL_UNS count = stackPopUNS(pVM->pStack); 3485 char *cp = stackPopPtr(pVM->pStack); 3486 char *pDest = (char *)ficlMalloc(count + 1); 3487 3488 /* 3489 ** Since we don't have an output primitive for a counted string 3490 ** (oops), make sure the string is null terminated. If not, copy 3491 ** and terminate it. 3492 */ 3493 if (!pDest) 3494 vmThrowErr(pVM, "Error: out of memory"); 3495 3496 strncpy(pDest, cp, count); 3497 pDest[count] = '\0'; 3498 3499 vmTextOut(pVM, pDest, 0); 3500 3501 ficlFree(pDest); 3502 return; 3503} 3504 3505/************************************************************************** 3506 w o r d 3507** word CORE ( char "<chars>ccc<char>" -- c-addr ) 3508** Skip leading delimiters. Parse characters ccc delimited by char. An 3509** ambiguous condition exists if the length of the parsed string is greater 3510** than the implementation-defined length of a counted string. 3511** 3512** c-addr is the address of a transient region containing the parsed word 3513** as a counted string. If the parse area was empty or contained no 3514** characters other than the delimiter, the resulting string has a zero 3515** length. A space, not included in the length, follows the string. A 3516** program may replace characters within the string. 3517** NOTE! Ficl also NULL-terminates the dest string. 3518**************************************************************************/ 3519static void ficlWord(FICL_VM *pVM) 3520{ 3521 FICL_STRING *sp; 3522 char delim; 3523 STRINGINFO si; 3524#if FICL_ROBUST > 1 3525 vmCheckStack(pVM,1,1); 3526#endif 3527 3528 sp = (FICL_STRING *)pVM->pad; 3529 delim = (char)POPINT(); 3530 si = vmParseStringEx(pVM, delim, 1); 3531 3532 if (SI_COUNT(si) > nPAD-1) 3533 SI_SETLEN(si, nPAD-1); 3534 3535 sp->count = (FICL_COUNT)SI_COUNT(si); 3536 strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); 3537 /*#$-GUY CHANGE: I added this.-$#*/ 3538 sp->text[sp->count] = 0; 3539 strcat(sp->text, " "); 3540 3541 PUSHPTR(sp); 3542 return; 3543} 3544 3545 3546/************************************************************************** 3547 p a r s e - w o r d 3548** ficl PARSE-WORD ( <spaces>name -- c-addr u ) 3549** Skip leading spaces and parse name delimited by a space. c-addr is the 3550** address within the input buffer and u is the length of the selected 3551** string. If the parse area is empty, the resulting string has a zero length. 3552**************************************************************************/ 3553static void parseNoCopy(FICL_VM *pVM) 3554{ 3555 STRINGINFO si; 3556#if FICL_ROBUST > 1 3557 vmCheckStack(pVM,0,2); 3558#endif 3559 3560 si = vmGetWord0(pVM); 3561 PUSHPTR(SI_PTR(si)); 3562 PUSHUNS(SI_COUNT(si)); 3563 return; 3564} 3565 3566 3567/************************************************************************** 3568 p a r s e 3569** CORE EXT ( char "ccc<char>" -- c-addr u ) 3570** Parse ccc delimited by the delimiter char. 3571** c-addr is the address (within the input buffer) and u is the length of 3572** the parsed string. If the parse area was empty, the resulting string has 3573** a zero length. 3574** NOTE! PARSE differs from WORD: it does not skip leading delimiters. 3575**************************************************************************/ 3576static void parse(FICL_VM *pVM) 3577{ 3578 STRINGINFO si; 3579 char delim; 3580 3581#if FICL_ROBUST > 1 3582 vmCheckStack(pVM,1,2); 3583#endif 3584 3585 delim = (char)POPINT(); 3586 3587 si = vmParseStringEx(pVM, delim, 0); 3588 PUSHPTR(SI_PTR(si)); 3589 PUSHUNS(SI_COUNT(si)); 3590 return; 3591} 3592 3593 3594/************************************************************************** 3595 f i l l 3596** CORE ( c-addr u char -- ) 3597** If u is greater than zero, store char in each of u consecutive 3598** characters of memory beginning at c-addr. 3599**************************************************************************/ 3600static void fill(FICL_VM *pVM) 3601{ 3602 char ch; 3603 FICL_UNS u; 3604 char *cp; 3605#if FICL_ROBUST > 1 3606 vmCheckStack(pVM,3,0); 3607#endif 3608 ch = (char)POPINT(); 3609 u = POPUNS(); 3610 cp = (char *)POPPTR(); 3611 3612 while (u > 0) 3613 { 3614 *cp++ = ch; 3615 u--; 3616 } 3617 return; 3618} 3619 3620 3621/************************************************************************** 3622 f i n d 3623** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 3624** Find the definition named in the counted string at c-addr. If the 3625** definition is not found, return c-addr and zero. If the definition is 3626** found, return its execution token xt. If the definition is immediate, 3627** also return one (1), otherwise also return minus-one (-1). For a given 3628** string, the values returned by FIND while compiling may differ from 3629** those returned while not compiling. 3630**************************************************************************/ 3631static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure) 3632{ 3633 FICL_WORD *pFW; 3634 3635 pFW = dictLookup(vmGetDict(pVM), si); 3636 if (pFW) 3637 { 3638 PUSHPTR(pFW); 3639 PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); 3640 } 3641 else 3642 { 3643 PUSHPTR(returnForFailure); 3644 PUSHUNS(0); 3645 } 3646 return; 3647} 3648 3649 3650 3651/************************************************************************** 3652 f i n d 3653** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 3654** Find the definition named in the counted string at c-addr. If the 3655** definition is not found, return c-addr and zero. If the definition is 3656** found, return its execution token xt. If the definition is immediate, 3657** also return one (1), otherwise also return minus-one (-1). For a given 3658** string, the values returned by FIND while compiling may differ from 3659** those returned while not compiling. 3660**************************************************************************/ 3661static void cFind(FICL_VM *pVM) 3662{ 3663 FICL_STRING *sp; 3664 STRINGINFO si; 3665 3666#if FICL_ROBUST > 1 3667 vmCheckStack(pVM,1,2); 3668#endif 3669 sp = POPPTR(); 3670 SI_PFS(si, sp); 3671 do_find(pVM, si, sp); 3672} 3673 3674 3675 3676/************************************************************************** 3677 s f i n d 3678** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 ) 3679** Like FIND, but takes "c-addr u" for the string. 3680**************************************************************************/ 3681static void sFind(FICL_VM *pVM) 3682{ 3683 STRINGINFO si; 3684 3685#if FICL_ROBUST > 1 3686 vmCheckStack(pVM,2,2); 3687#endif 3688 3689 si.count = stackPopINT(pVM->pStack); 3690 si.cp = stackPopPtr(pVM->pStack); 3691 3692 do_find(pVM, si, NULL); 3693} 3694 3695 3696 3697/************************************************************************** 3698 f m S l a s h M o d 3699** f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 3700** Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 3701** Input and output stack arguments are signed. An ambiguous condition 3702** exists if n1 is zero or if the quotient lies outside the range of a 3703** single-cell signed integer. 3704**************************************************************************/ 3705static void fmSlashMod(FICL_VM *pVM) 3706{ 3707 DPINT d1; 3708 FICL_INT n1; 3709 INTQR qr; 3710#if FICL_ROBUST > 1 3711 vmCheckStack(pVM,3,2); 3712#endif 3713 3714 n1 = POPINT(); 3715 d1 = i64Pop(pVM->pStack); 3716 qr = m64FlooredDivI(d1, n1); 3717 PUSHINT(qr.rem); 3718 PUSHINT(qr.quot); 3719 return; 3720} 3721 3722 3723/************************************************************************** 3724 s m S l a s h R e m 3725** s-m-slash-rem CORE ( d1 n1 -- n2 n3 ) 3726** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 3727** Input and output stack arguments are signed. An ambiguous condition 3728** exists if n1 is zero or if the quotient lies outside the range of a 3729** single-cell signed integer. 3730**************************************************************************/ 3731static void smSlashRem(FICL_VM *pVM) 3732{ 3733 DPINT d1; 3734 FICL_INT n1; 3735 INTQR qr; 3736#if FICL_ROBUST > 1 3737 vmCheckStack(pVM,3,2); 3738#endif 3739 3740 n1 = POPINT(); 3741 d1 = i64Pop(pVM->pStack); 3742 qr = m64SymmetricDivI(d1, n1); 3743 PUSHINT(qr.rem); 3744 PUSHINT(qr.quot); 3745 return; 3746} 3747 3748 3749static void ficlMod(FICL_VM *pVM) 3750{ 3751 DPINT d1; 3752 FICL_INT n1; 3753 INTQR qr; 3754#if FICL_ROBUST > 1 3755 vmCheckStack(pVM,2,1); 3756#endif 3757 3758 n1 = POPINT(); 3759 d1.lo = POPINT(); 3760 i64Extend(d1); 3761 qr = m64SymmetricDivI(d1, n1); 3762 PUSHINT(qr.rem); 3763 return; 3764} 3765 3766 3767/************************************************************************** 3768 u m S l a s h M o d 3769** u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 3770** Divide ud by u1, giving the quotient u3 and the remainder u2. 3771** All values and arithmetic are unsigned. An ambiguous condition 3772** exists if u1 is zero or if the quotient lies outside the range of a 3773** single-cell unsigned integer. 3774*************************************************************************/ 3775static void umSlashMod(FICL_VM *pVM) 3776{ 3777 DPUNS ud; 3778 FICL_UNS u1; 3779 UNSQR qr; 3780 3781 u1 = stackPopUNS(pVM->pStack); 3782 ud = u64Pop(pVM->pStack); 3783 qr = ficlLongDiv(ud, u1); 3784 PUSHUNS(qr.rem); 3785 PUSHUNS(qr.quot); 3786 return; 3787} 3788 3789 3790/************************************************************************** 3791 l s h i f t 3792** l-shift CORE ( x1 u -- x2 ) 3793** Perform a logical left shift of u bit-places on x1, giving x2. 3794** Put zeroes into the least significant bits vacated by the shift. 3795** An ambiguous condition exists if u is greater than or equal to the 3796** number of bits in a cell. 3797** 3798** r-shift CORE ( x1 u -- x2 ) 3799** Perform a logical right shift of u bit-places on x1, giving x2. 3800** Put zeroes into the most significant bits vacated by the shift. An 3801** ambiguous condition exists if u is greater than or equal to the 3802** number of bits in a cell. 3803**************************************************************************/ 3804static void lshift(FICL_VM *pVM) 3805{ 3806 FICL_UNS nBits; 3807 FICL_UNS x1; 3808#if FICL_ROBUST > 1 3809 vmCheckStack(pVM,2,1); 3810#endif 3811 3812 nBits = POPUNS(); 3813 x1 = POPUNS(); 3814 PUSHUNS(x1 << nBits); 3815 return; 3816} 3817 3818 3819static void rshift(FICL_VM *pVM) 3820{ 3821 FICL_UNS nBits; 3822 FICL_UNS x1; 3823#if FICL_ROBUST > 1 3824 vmCheckStack(pVM,2,1); 3825#endif 3826 3827 nBits = POPUNS(); 3828 x1 = POPUNS(); 3829 3830 PUSHUNS(x1 >> nBits); 3831 return; 3832} 3833 3834 3835/************************************************************************** 3836 m S t a r 3837** m-star CORE ( n1 n2 -- d ) 3838** d is the signed product of n1 times n2. 3839**************************************************************************/ 3840static void mStar(FICL_VM *pVM) 3841{ 3842 FICL_INT n2; 3843 FICL_INT n1; 3844 DPINT d; 3845#if FICL_ROBUST > 1 3846 vmCheckStack(pVM,2,2); 3847#endif 3848 3849 n2 = POPINT(); 3850 n1 = POPINT(); 3851 3852 d = m64MulI(n1, n2); 3853 i64Push(pVM->pStack, d); 3854 return; 3855} 3856 3857 3858static void umStar(FICL_VM *pVM) 3859{ 3860 FICL_UNS u2; 3861 FICL_UNS u1; 3862 DPUNS ud; 3863#if FICL_ROBUST > 1 3864 vmCheckStack(pVM,2,2); 3865#endif 3866 3867 u2 = POPUNS(); 3868 u1 = POPUNS(); 3869 3870 ud = ficlLongMul(u1, u2); 3871 u64Push(pVM->pStack, ud); 3872 return; 3873} 3874 3875 3876/************************************************************************** 3877 m a x & m i n 3878** 3879**************************************************************************/ 3880static void ficlMax(FICL_VM *pVM) 3881{ 3882 FICL_INT n2; 3883 FICL_INT n1; 3884#if FICL_ROBUST > 1 3885 vmCheckStack(pVM,2,1); 3886#endif 3887 3888 n2 = POPINT(); 3889 n1 = POPINT(); 3890 3891 PUSHINT((n1 > n2) ? n1 : n2); 3892 return; 3893} 3894 3895static void ficlMin(FICL_VM *pVM) 3896{ 3897 FICL_INT n2; 3898 FICL_INT n1; 3899#if FICL_ROBUST > 1 3900 vmCheckStack(pVM,2,1); 3901#endif 3902 3903 n2 = POPINT(); 3904 n1 = POPINT(); 3905 3906 PUSHINT((n1 < n2) ? n1 : n2); 3907 return; 3908} 3909 3910 3911/************************************************************************** 3912 m o v e 3913** CORE ( addr1 addr2 u -- ) 3914** If u is greater than zero, copy the contents of u consecutive address 3915** units at addr1 to the u consecutive address units at addr2. After MOVE 3916** completes, the u consecutive address units at addr2 contain exactly 3917** what the u consecutive address units at addr1 contained before the move. 3918** NOTE! This implementation assumes that a char is the same size as 3919** an address unit. 3920**************************************************************************/ 3921static void move(FICL_VM *pVM) 3922{ 3923 FICL_UNS u; 3924 char *addr2; 3925 char *addr1; 3926#if FICL_ROBUST > 1 3927 vmCheckStack(pVM,3,0); 3928#endif 3929 3930 u = POPUNS(); 3931 addr2 = POPPTR(); 3932 addr1 = POPPTR(); 3933 3934 if (u == 0) 3935 return; 3936 /* 3937 ** Do the copy carefully, so as to be 3938 ** correct even if the two ranges overlap 3939 */ 3940 if (addr1 >= addr2) 3941 { 3942 for (; u > 0; u--) 3943 *addr2++ = *addr1++; 3944 } 3945 else 3946 { 3947 addr2 += u-1; 3948 addr1 += u-1; 3949 for (; u > 0; u--) 3950 *addr2-- = *addr1--; 3951 } 3952 3953 return; 3954} 3955 3956 3957/************************************************************************** 3958 r e c u r s e 3959** 3960**************************************************************************/ 3961static void recurseCoIm(FICL_VM *pVM) 3962{ 3963 FICL_DICT *pDict = vmGetDict(pVM); 3964 3965 IGNORE(pVM); 3966 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); 3967 return; 3968} 3969 3970 3971/************************************************************************** 3972 s t o d 3973** s-to-d CORE ( n -- d ) 3974** Convert the number n to the double-cell number d with the same 3975** numerical value. 3976**************************************************************************/ 3977static void sToD(FICL_VM *pVM) 3978{ 3979 FICL_INT s; 3980#if FICL_ROBUST > 1 3981 vmCheckStack(pVM,1,2); 3982#endif 3983 3984 s = POPINT(); 3985 3986 /* sign extend to 64 bits.. */ 3987 PUSHINT(s); 3988 PUSHINT((s < 0) ? -1 : 0); 3989 return; 3990} 3991 3992 3993/************************************************************************** 3994 s o u r c e 3995** CORE ( -- c-addr u ) 3996** c-addr is the address of, and u is the number of characters in, the 3997** input buffer. 3998**************************************************************************/ 3999static void source(FICL_VM *pVM) 4000{ 4001#if FICL_ROBUST > 1 4002 vmCheckStack(pVM,0,2); 4003#endif 4004 PUSHPTR(pVM->tib.cp); 4005 PUSHINT(vmGetInBufLen(pVM)); 4006 return; 4007} 4008 4009 4010/************************************************************************** 4011 v e r s i o n 4012** non-standard... 4013**************************************************************************/ 4014static void ficlVersion(FICL_VM *pVM) 4015{ 4016 vmTextOut(pVM, "ficl Version " FICL_VER, 1); 4017 return; 4018} 4019 4020 4021/************************************************************************** 4022 t o I n 4023** to-in CORE 4024**************************************************************************/ 4025static void toIn(FICL_VM *pVM) 4026{ 4027#if FICL_ROBUST > 1 4028 vmCheckStack(pVM,0,1); 4029#endif 4030 PUSHPTR(&pVM->tib.index); 4031 return; 4032} 4033 4034 4035/************************************************************************** 4036 c o l o n N o N a m e 4037** CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 4038** Create an unnamed colon definition and push its address. 4039** Change state to compile. 4040**************************************************************************/ 4041static void colonNoName(FICL_VM *pVM) 4042{ 4043 FICL_DICT *dp = vmGetDict(pVM); 4044 FICL_WORD *pFW; 4045 STRINGINFO si; 4046 4047 SI_SETLEN(si, 0); 4048 SI_SETPTR(si, NULL); 4049 4050 pVM->state = COMPILE; 4051 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 4052 PUSHPTR(pFW); 4053 markControlTag(pVM, colonTag); 4054 return; 4055} 4056 4057 4058/************************************************************************** 4059 u s e r V a r i a b l e 4060** user ( u -- ) "<spaces>name" 4061** Get a name from the input stream and create a user variable 4062** with the name and the index supplied. The run-time effect 4063** of a user variable is to push the address of the indexed cell 4064** in the running vm's user array. 4065** 4066** User variables are vm local cells. Each vm has an array of 4067** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 4068** Ficl's user facility is implemented with two primitives, 4069** "user" and "(user)", a variable ("nUser") (in softcore.c) that 4070** holds the index of the next free user cell, and a redefinition 4071** (also in softcore) of "user" that defines a user word and increments 4072** nUser. 4073**************************************************************************/ 4074#if FICL_WANT_USER 4075static void userParen(FICL_VM *pVM) 4076{ 4077 FICL_INT i = pVM->runningWord->param[0].i; 4078 PUSHPTR(&pVM->user[i]); 4079 return; 4080} 4081 4082 4083static void userVariable(FICL_VM *pVM) 4084{ 4085 FICL_DICT *dp = vmGetDict(pVM); 4086 STRINGINFO si = vmGetWord(pVM); 4087 CELL c; 4088 4089 c = stackPop(pVM->pStack); 4090 if (c.i >= FICL_USER_CELLS) 4091 { 4092 vmThrowErr(pVM, "Error - out of user space"); 4093 } 4094 4095 dictAppendWord2(dp, si, userParen, FW_DEFAULT); 4096 dictAppendCell(dp, c); 4097 return; 4098} 4099#endif 4100 4101 4102/************************************************************************** 4103 t o V a l u e 4104** CORE EXT 4105** Interpretation: ( x "<spaces>name" -- ) 4106** Skip leading spaces and parse name delimited by a space. Store x in 4107** name. An ambiguous condition exists if name was not defined by VALUE. 4108** NOTE: In ficl, VALUE is an alias of CONSTANT 4109**************************************************************************/ 4110static void toValue(FICL_VM *pVM) 4111{ 4112 STRINGINFO si = vmGetWord(pVM); 4113 FICL_DICT *dp = vmGetDict(pVM); 4114 FICL_WORD *pFW; 4115 4116#if FICL_WANT_LOCALS 4117 if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE)) 4118 { 4119 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 4120 pFW = dictLookup(pLoc, si); 4121 if (pFW && (pFW->code == doLocalIm)) 4122 { 4123 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen)); 4124 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 4125 return; 4126 } 4127 else if (pFW && pFW->code == do2LocalIm) 4128 { 4129 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); 4130 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 4131 return; 4132 } 4133 } 4134#endif 4135 4136 assert(pVM->pSys->pStore); 4137 4138 pFW = dictLookup(dp, si); 4139 if (!pFW) 4140 { 4141 int i = SI_COUNT(si); 4142 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 4143 } 4144 4145 if (pVM->state == INTERPRET) 4146 pFW->param[0] = stackPop(pVM->pStack); 4147 else /* compile code to store to word's param */ 4148 { 4149 PUSHPTR(&pFW->param[0]); 4150 literalIm(pVM); 4151 dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore)); 4152 } 4153 return; 4154} 4155 4156 4157#if FICL_WANT_LOCALS 4158/************************************************************************** 4159 l i n k P a r e n 4160** ( -- ) 4161** Link a frame on the return stack, reserving nCells of space for 4162** locals - the value of nCells is the next cell in the instruction 4163** stream. 4164**************************************************************************/ 4165static void linkParen(FICL_VM *pVM) 4166{ 4167 FICL_INT nLink = *(FICL_INT *)(pVM->ip); 4168 vmBranchRelative(pVM, 1); 4169 stackLink(pVM->rStack, nLink); 4170 return; 4171} 4172 4173 4174static void unlinkParen(FICL_VM *pVM) 4175{ 4176 stackUnlink(pVM->rStack); 4177 return; 4178} 4179 4180 4181/************************************************************************** 4182 d o L o c a l I m 4183** Immediate - cfa of a local while compiling - when executed, compiles 4184** code to fetch the value of a local given the local's index in the 4185** word's pfa 4186**************************************************************************/ 4187static void getLocalParen(FICL_VM *pVM) 4188{ 4189 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 4190 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 4191 return; 4192} 4193 4194 4195static void toLocalParen(FICL_VM *pVM) 4196{ 4197 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 4198 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 4199 return; 4200} 4201 4202 4203static void getLocal0(FICL_VM *pVM) 4204{ 4205 stackPush(pVM->pStack, pVM->rStack->pFrame[0]); 4206 return; 4207} 4208 4209 4210static void toLocal0(FICL_VM *pVM) 4211{ 4212 pVM->rStack->pFrame[0] = stackPop(pVM->pStack); 4213 return; 4214} 4215 4216 4217static void getLocal1(FICL_VM *pVM) 4218{ 4219 stackPush(pVM->pStack, pVM->rStack->pFrame[1]); 4220 return; 4221} 4222 4223 4224static void toLocal1(FICL_VM *pVM) 4225{ 4226 pVM->rStack->pFrame[1] = stackPop(pVM->pStack); 4227 return; 4228} 4229 4230 4231/* 4232** Each local is recorded in a private locals dictionary as a 4233** word that does doLocalIm at runtime. DoLocalIm compiles code 4234** into the client definition to fetch the value of the 4235** corresponding local variable from the return stack. 4236** The private dictionary gets initialized at the end of each block 4237** that uses locals (in ; and does> for example). 4238*/ 4239static void doLocalIm(FICL_VM *pVM) 4240{ 4241 FICL_DICT *pDict = vmGetDict(pVM); 4242 FICL_INT nLocal = pVM->runningWord->param[0].i; 4243 4244 if (pVM->state == INTERPRET) 4245 { 4246 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 4247 } 4248 else 4249 { 4250 4251 if (nLocal == 0) 4252 { 4253 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0)); 4254 } 4255 else if (nLocal == 1) 4256 { 4257 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1)); 4258 } 4259 else 4260 { 4261 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen)); 4262 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 4263 } 4264 } 4265 return; 4266} 4267 4268 4269/************************************************************************** 4270 l o c a l P a r e n 4271** paren-local-paren LOCAL 4272** Interpretation: Interpretation semantics for this word are undefined. 4273** Execution: ( c-addr u -- ) 4274** When executed during compilation, (LOCAL) passes a message to the 4275** system that has one of two meanings. If u is non-zero, 4276** the message identifies a new local whose definition name is given by 4277** the string of characters identified by c-addr u. If u is zero, 4278** the message is last local and c-addr has no significance. 4279** 4280** The result of executing (LOCAL) during compilation of a definition is 4281** to create a set of named local identifiers, each of which is 4282** a definition name, that only have execution semantics within the scope 4283** of that definition's source. 4284** 4285** local Execution: ( -- x ) 4286** 4287** Push the local's value, x, onto the stack. The local's value is 4288** initialized as described in 13.3.3 Processing locals and may be 4289** changed by preceding the local's name with TO. An ambiguous condition 4290** exists when local is executed while in interpretation state. 4291**************************************************************************/ 4292static void localParen(FICL_VM *pVM) 4293{ 4294 FICL_DICT *pDict; 4295 STRINGINFO si; 4296#if FICL_ROBUST > 1 4297 vmCheckStack(pVM,2,0); 4298#endif 4299 4300 pDict = vmGetDict(pVM); 4301 SI_SETLEN(si, POPUNS()); 4302 SI_SETPTR(si, (char *)POPPTR()); 4303 4304 if (SI_COUNT(si) > 0) 4305 { /* add a local to the **locals** dict and update nLocals */ 4306 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 4307 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) 4308 { 4309 vmThrowErr(pVM, "Error: out of local space"); 4310 } 4311 4312 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); 4313 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); 4314 4315 if (pVM->pSys->nLocals == 0) 4316 { /* compile code to create a local stack frame */ 4317 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); 4318 /* save location in dictionary for #locals */ 4319 pVM->pSys->pMarkLocals = pDict->here; 4320 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 4321 /* compile code to initialize first local */ 4322 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0)); 4323 } 4324 else if (pVM->pSys->nLocals == 1) 4325 { 4326 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1)); 4327 } 4328 else 4329 { 4330 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen)); 4331 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 4332 } 4333 4334 (pVM->pSys->nLocals)++; 4335 } 4336 else if (pVM->pSys->nLocals > 0) 4337 { /* write nLocals to (link) param area in dictionary */ 4338 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; 4339 } 4340 4341 return; 4342} 4343 4344 4345static void get2LocalParen(FICL_VM *pVM) 4346{ 4347 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 4348 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 4349 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 4350 return; 4351} 4352 4353 4354static void do2LocalIm(FICL_VM *pVM) 4355{ 4356 FICL_DICT *pDict = vmGetDict(pVM); 4357 FICL_INT nLocal = pVM->runningWord->param[0].i; 4358 4359 if (pVM->state == INTERPRET) 4360 { 4361 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 4362 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 4363 } 4364 else 4365 { 4366 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen)); 4367 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 4368 } 4369 return; 4370} 4371 4372 4373static void to2LocalParen(FICL_VM *pVM) 4374{ 4375 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 4376 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack); 4377 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 4378 return; 4379} 4380 4381 4382static void twoLocalParen(FICL_VM *pVM) 4383{ 4384 FICL_DICT *pDict = vmGetDict(pVM); 4385 STRINGINFO si; 4386 SI_SETLEN(si, stackPopUNS(pVM->pStack)); 4387 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 4388 4389 if (SI_COUNT(si) > 0) 4390 { /* add a local to the **locals** dict and update nLocals */ 4391 FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); 4392 if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) 4393 { 4394 vmThrowErr(pVM, "Error: out of local space"); 4395 } 4396 4397 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); 4398 dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); 4399 4400 if (pVM->pSys->nLocals == 0) 4401 { /* compile code to create a local stack frame */ 4402 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); 4403 /* save location in dictionary for #locals */ 4404 pVM->pSys->pMarkLocals = pDict->here; 4405 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 4406 } 4407 4408 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); 4409 dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); 4410 4411 pVM->pSys->nLocals += 2; 4412 } 4413 else if (pVM->pSys->nLocals > 0) 4414 { /* write nLocals to (link) param area in dictionary */ 4415 *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; 4416 } 4417 4418 return; 4419} 4420 4421 4422#endif 4423/************************************************************************** 4424 c o m p a r e 4425** STRING ( c-addr1 u1 c-addr2 u2 -- n ) 4426** Compare the string specified by c-addr1 u1 to the string specified by 4427** c-addr2 u2. The strings are compared, beginning at the given addresses, 4428** character by character, up to the length of the shorter string or until a 4429** difference is found. If the two strings are identical, n is zero. If the two 4430** strings are identical up to the length of the shorter string, n is minus-one 4431** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not 4432** identical up to the length of the shorter string, n is minus-one (-1) if the 4433** first non-matching character in the string specified by c-addr1 u1 has a 4434** lesser numeric value than the corresponding character in the string specified 4435** by c-addr2 u2 and one (1) otherwise. 4436**************************************************************************/ 4437static void compareInternal(FICL_VM *pVM, int caseInsensitive) 4438{ 4439 char *cp1, *cp2; 4440 FICL_UNS u1, u2, uMin; 4441 int n = 0; 4442 4443 vmCheckStack(pVM, 4, 1); 4444 u2 = stackPopUNS(pVM->pStack); 4445 cp2 = (char *)stackPopPtr(pVM->pStack); 4446 u1 = stackPopUNS(pVM->pStack); 4447 cp1 = (char *)stackPopPtr(pVM->pStack); 4448 4449 uMin = (u1 < u2)? u1 : u2; 4450 for ( ; (uMin > 0) && (n == 0); uMin--) 4451 { 4452 char c1 = *cp1++; 4453 char c2 = *cp2++; 4454 if (caseInsensitive) 4455 { 4456 c1 = (char)tolower(c1); 4457 c2 = (char)tolower(c2); 4458 } 4459 n = (int)(c1 - c2); 4460 } 4461 4462 if (n == 0) 4463 n = (int)(u1 - u2); 4464 4465 if (n < 0) 4466 n = -1; 4467 else if (n > 0) 4468 n = 1; 4469 4470 PUSHINT(n); 4471 return; 4472} 4473 4474 4475static void compareString(FICL_VM *pVM) 4476{ 4477 compareInternal(pVM, FALSE); 4478} 4479 4480 4481static void compareStringInsensitive(FICL_VM *pVM) 4482{ 4483 compareInternal(pVM, TRUE); 4484} 4485 4486 4487/************************************************************************** 4488 p a d 4489** CORE EXT ( -- c-addr ) 4490** c-addr is the address of a transient region that can be used to hold 4491** data for intermediate processing. 4492**************************************************************************/ 4493static void pad(FICL_VM *pVM) 4494{ 4495 stackPushPtr(pVM->pStack, pVM->pad); 4496} 4497 4498 4499/************************************************************************** 4500 s o u r c e - i d 4501** CORE EXT, FILE ( -- 0 | -1 | fileid ) 4502** Identifies the input source as follows: 4503** 4504** SOURCE-ID Input source 4505** --------- ------------ 4506** fileid Text file fileid 4507** -1 String (via EVALUATE) 4508** 0 User input device 4509**************************************************************************/ 4510static void sourceid(FICL_VM *pVM) 4511{ 4512 PUSHINT(pVM->sourceID.i); 4513 return; 4514} 4515 4516 4517/************************************************************************** 4518 r e f i l l 4519** CORE EXT ( -- flag ) 4520** Attempt to fill the input buffer from the input source, returning a true 4521** flag if successful. 4522** When the input source is the user input device, attempt to receive input 4523** into the terminal input buffer. If successful, make the result the input 4524** buffer, set >IN to zero, and return true. Receipt of a line containing no 4525** characters is considered successful. If there is no input available from 4526** the current input source, return false. 4527** When the input source is a string from EVALUATE, return false and 4528** perform no other action. 4529**************************************************************************/ 4530static void refill(FICL_VM *pVM) 4531{ 4532 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; 4533 if (ret && (pVM->fRestart == 0)) 4534 vmThrow(pVM, VM_RESTART); 4535 4536 PUSHINT(ret); 4537 return; 4538} 4539 4540 4541/************************************************************************** 4542 freebsd exception handling words 4543** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE 4544** the word in ToS. If an exception happens, restore the state to what 4545** it was before, and pushes the exception value on the stack. If not, 4546** push zero. 4547** 4548** Notice that Catch implements an inner interpreter. This is ugly, 4549** but given how ficl works, it cannot be helped. The problem is that 4550** colon definitions will be executed *after* the function returns, 4551** while "code" definitions will be executed immediately. I considered 4552** other solutions to this problem, but all of them shared the same 4553** basic problem (with added disadvantages): if ficl ever changes it's 4554** inner thread modus operandi, one would have to fix this word. 4555** 4556** More comments can be found throughout catch's code. 4557** 4558** Daniel C. Sobral Jan 09/1999 4559** sadler may 2000 -- revised to follow ficl.c:ficlExecXT. 4560**************************************************************************/ 4561 4562static void ficlCatch(FICL_VM *pVM) 4563{ 4564 int except; 4565 jmp_buf vmState; 4566 FICL_VM VM; 4567 FICL_STACK pStack; 4568 FICL_STACK rStack; 4569 FICL_WORD *pFW; 4570 4571 assert(pVM); 4572 assert(pVM->pSys->pExitInner); 4573 4574 4575 /* 4576 ** Get xt. 4577 ** We need this *before* we save the stack pointer, or 4578 ** we'll have to pop one element out of the stack after 4579 ** an exception. I prefer to get done with it up front. :-) 4580 */ 4581#if FICL_ROBUST > 1 4582 vmCheckStack(pVM, 1, 0); 4583#endif 4584 pFW = stackPopPtr(pVM->pStack); 4585 4586 /* 4587 ** Save vm's state -- a catch will not back out environmental 4588 ** changes. 4589 ** 4590 ** We are *not* saving dictionary state, since it is 4591 ** global instead of per vm, and we are not saving 4592 ** stack contents, since we are not required to (and, 4593 ** thus, it would be useless). We save pVM, and pVM 4594 ** "stacks" (a structure containing general information 4595 ** about it, including the current stack pointer). 4596 */ 4597 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); 4598 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); 4599 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); 4600 4601 /* 4602 ** Give pVM a jmp_buf 4603 */ 4604 pVM->pState = &vmState; 4605 4606 /* 4607 ** Safety net 4608 */ 4609 except = setjmp(vmState); 4610 4611 switch (except) 4612 { 4613 /* 4614 ** Setup condition - push poison pill so that the VM throws 4615 ** VM_INNEREXIT if the XT terminates normally, then execute 4616 ** the XT 4617 */ 4618 case 0: 4619 vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */ 4620 vmExecute(pVM, pFW); 4621 vmInnerLoop(pVM); 4622 break; 4623 4624 /* 4625 ** Normal exit from XT - lose the poison pill, 4626 ** restore old setjmp vector and push a zero. 4627 */ 4628 case VM_INNEREXIT: 4629 vmPopIP(pVM); /* Gack - hurl poison pill */ 4630 pVM->pState = VM.pState; /* Restore just the setjmp vector */ 4631 PUSHINT(0); /* Push 0 -- everything is ok */ 4632 break; 4633 4634 /* 4635 ** Some other exception got thrown - restore pre-existing VM state 4636 ** and push the exception code 4637 */ 4638 default: 4639 /* Restore vm's state */ 4640 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); 4641 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); 4642 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); 4643 4644 PUSHINT(except);/* Push error */ 4645 break; 4646 } 4647} 4648 4649/************************************************************************** 4650** t h r o w 4651** EXCEPTION 4652** Throw -- From ANS Forth standard. 4653** 4654** Throw takes the ToS and, if that's different from zero, 4655** returns to the last executed catch context. Further throws will 4656** unstack previously executed "catches", in LIFO mode. 4657** 4658** Daniel C. Sobral Jan 09/1999 4659**************************************************************************/ 4660static void ficlThrow(FICL_VM *pVM) 4661{ 4662 int except; 4663 4664 except = stackPopINT(pVM->pStack); 4665 4666 if (except) 4667 vmThrow(pVM, except); 4668} 4669 4670 4671/************************************************************************** 4672** a l l o c a t e 4673** MEMORY 4674**************************************************************************/ 4675static void ansAllocate(FICL_VM *pVM) 4676{ 4677 size_t size; 4678 void *p; 4679 4680 size = stackPopINT(pVM->pStack); 4681 p = ficlMalloc(size); 4682 PUSHPTR(p); 4683 if (p) 4684 PUSHINT(0); 4685 else 4686 PUSHINT(1); 4687} 4688 4689 4690/************************************************************************** 4691** f r e e 4692** MEMORY 4693**************************************************************************/ 4694static void ansFree(FICL_VM *pVM) 4695{ 4696 void *p; 4697 4698 p = stackPopPtr(pVM->pStack); 4699 ficlFree(p); 4700 PUSHINT(0); 4701} 4702 4703 4704/************************************************************************** 4705** r e s i z e 4706** MEMORY 4707**************************************************************************/ 4708static void ansResize(FICL_VM *pVM) 4709{ 4710 size_t size; 4711 void *new, *old; 4712 4713 size = stackPopINT(pVM->pStack); 4714 old = stackPopPtr(pVM->pStack); 4715 new = ficlRealloc(old, size); 4716 if (new) 4717 { 4718 PUSHPTR(new); 4719 PUSHINT(0); 4720 } 4721 else 4722 { 4723 PUSHPTR(old); 4724 PUSHINT(1); 4725 } 4726} 4727 4728 4729/************************************************************************** 4730** e x i t - i n n e r 4731** Signals execXT that an inner loop has completed 4732**************************************************************************/ 4733static void ficlExitInner(FICL_VM *pVM) 4734{ 4735 vmThrow(pVM, VM_INNEREXIT); 4736} 4737 4738 4739/************************************************************************** 4740 d n e g a t e 4741** DOUBLE ( d1 -- d2 ) 4742** d2 is the negation of d1. 4743**************************************************************************/ 4744static void dnegate(FICL_VM *pVM) 4745{ 4746 DPINT i = i64Pop(pVM->pStack); 4747 i = m64Negate(i); 4748 i64Push(pVM->pStack, i); 4749 4750 return; 4751} 4752 4753 4754#if 0 4755/************************************************************************** 4756 4757** 4758**************************************************************************/ 4759static void funcname(FICL_VM *pVM) 4760{ 4761 IGNORE(pVM); 4762 return; 4763} 4764 4765 4766#endif 4767/************************************************************************** 4768 f i c l W o r d C l a s s i f y 4769** This public function helps to classify word types for SEE 4770** and the deugger in tools.c. Given a pointer to a word, it returns 4771** a member of WOR 4772**************************************************************************/ 4773WORDKIND ficlWordClassify(FICL_WORD *pFW) 4774{ 4775 typedef struct 4776 { 4777 WORDKIND kind; 4778 FICL_CODE code; 4779 } CODEtoKIND; 4780 4781 static CODEtoKIND codeMap[] = 4782 { 4783 {BRANCH, branchParen}, 4784 {COLON, colonParen}, 4785 {CONSTANT, constantParen}, 4786 {CREATE, createParen}, 4787 {DO, doParen}, 4788 {DOES, doDoes}, 4789 {IF, branch0}, 4790 {LITERAL, literalParen}, 4791 {LOOP, loopParen}, 4792 {OF, ofParen}, 4793 {PLOOP, plusLoopParen}, 4794 {QDO, qDoParen}, 4795 {CSTRINGLIT, cstringLit}, 4796 {STRINGLIT, stringLit}, 4797#if FICL_WANT_USER 4798 {USER, userParen}, 4799#endif 4800 {VARIABLE, variableParen}, 4801 }; 4802 4803#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND)) 4804 4805 FICL_CODE code = pFW->code; 4806 int i; 4807 4808 for (i=0; i < nMAP; i++) 4809 { 4810 if (codeMap[i].code == code) 4811 return codeMap[i].kind; 4812 } 4813 4814 return PRIMITIVE; 4815} 4816 4817 4818#ifdef TESTMAIN 4819/************************************************************************** 4820** r a n d o m 4821** FICL-specific 4822**************************************************************************/ 4823static void ficlRandom(FICL_VM *pVM) 4824{ 4825 PUSHINT(rand()); 4826} 4827 4828 4829/************************************************************************** 4830** s e e d - r a n d o m 4831** FICL-specific 4832**************************************************************************/ 4833static void ficlSeedRandom(FICL_VM *pVM) 4834{ 4835 srand(POPINT()); 4836} 4837#endif 4838 4839 4840/************************************************************************** 4841 f i c l C o m p i l e C o r e 4842** Builds the primitive wordset and the environment-query namespace. 4843**************************************************************************/ 4844 4845void ficlCompileCore(FICL_SYSTEM *pSys) 4846{ 4847 FICL_DICT *dp = pSys->dp; 4848 assert (dp); 4849 4850 4851 /* 4852 ** CORE word set 4853 ** see softcore.c for definitions of: abs bl space spaces abort" 4854 */ 4855 pSys->pStore = 4856 dictAppendWord(dp, "!", store, FW_DEFAULT); 4857 dictAppendWord(dp, "#", numberSign, FW_DEFAULT); 4858 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); 4859 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); 4860 dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT); 4861 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); 4862 dictAppendWord(dp, "*", mul, FW_DEFAULT); 4863 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); 4864 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); 4865 dictAppendWord(dp, "+", add, FW_DEFAULT); 4866 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); 4867 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); 4868 dictAppendWord(dp, ",", comma, FW_DEFAULT); 4869 dictAppendWord(dp, "-", sub, FW_DEFAULT); 4870 dictAppendWord(dp, ".", displayCell, FW_DEFAULT); 4871 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); 4872 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); 4873 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); 4874 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); 4875 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); 4876 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); 4877 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); 4878 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); 4879 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); 4880 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); 4881 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); 4882 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); 4883 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); 4884 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); 4885 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); 4886 dictAppendWord(dp, ":", colon, FW_DEFAULT); 4887 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); 4888 dictAppendWord(dp, "<", isLess, FW_DEFAULT); 4889 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); 4890 dictAppendWord(dp, "=", isEqual, FW_DEFAULT); 4891 dictAppendWord(dp, ">", isGreater, FW_DEFAULT); 4892 dictAppendWord(dp, ">body", toBody, FW_DEFAULT); 4893 dictAppendWord(dp, ">in", toIn, FW_DEFAULT); 4894 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); 4895 dictAppendWord(dp, ">r", toRStack, FW_COMPILE); 4896 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); 4897 dictAppendWord(dp, "@", fetch, FW_DEFAULT); 4898 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); 4899 dictAppendWord(dp, "accept", accept, FW_DEFAULT); 4900 dictAppendWord(dp, "align", align, FW_DEFAULT); 4901 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); 4902 dictAppendWord(dp, "allot", allot, FW_DEFAULT); 4903 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); 4904 dictAppendWord(dp, "base", base, FW_DEFAULT); 4905 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); 4906 dictAppendWord(dp, "c!", cStore, FW_DEFAULT); 4907 dictAppendWord(dp, "c,", cComma, FW_DEFAULT); 4908 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); 4909 dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED); 4910 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); 4911 dictAppendWord(dp, "cells", cells, FW_DEFAULT); 4912 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); 4913 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); 4914 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); 4915 dictAppendWord(dp, "constant", constant, FW_DEFAULT); 4916 dictAppendWord(dp, "count", count, FW_DEFAULT); 4917 dictAppendWord(dp, "cr", cr, FW_DEFAULT); 4918 dictAppendWord(dp, "create", create, FW_DEFAULT); 4919 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); 4920 dictAppendWord(dp, "depth", depth, FW_DEFAULT); 4921 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); 4922 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); 4923 pSys->pDrop = 4924 dictAppendWord(dp, "drop", drop, FW_DEFAULT); 4925 dictAppendWord(dp, "dup", dup, FW_DEFAULT); 4926 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); 4927 dictAppendWord(dp, "emit", emit, FW_DEFAULT); 4928 dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED); 4929 dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED); 4930 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); 4931 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); 4932 dictAppendWord(dp, "execute", execute, FW_DEFAULT); 4933 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); 4934 dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED); 4935 dictAppendWord(dp, "fill", fill, FW_DEFAULT); 4936 dictAppendWord(dp, "find", cFind, FW_DEFAULT); 4937 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); 4938 dictAppendWord(dp, "here", here, FW_DEFAULT); 4939 dictAppendWord(dp, "hold", hold, FW_DEFAULT); 4940 dictAppendWord(dp, "i", loopICo, FW_COMPILE); 4941 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); 4942 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); 4943 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); 4944 dictAppendWord(dp, "j", loopJCo, FW_COMPILE); 4945 dictAppendWord(dp, "k", loopKCo, FW_COMPILE); 4946 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); 4947 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); 4948 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); 4949 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); 4950 dictAppendWord(dp, "m*", mStar, FW_DEFAULT); 4951 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); 4952 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); 4953 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); 4954 dictAppendWord(dp, "move", move, FW_DEFAULT); 4955 dictAppendWord(dp, "negate", negate, FW_DEFAULT); 4956 dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED); 4957 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); 4958 dictAppendWord(dp, "over", over, FW_DEFAULT); 4959 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); 4960 dictAppendWord(dp, "quit", quit, FW_DEFAULT); 4961 dictAppendWord(dp, "r>", fromRStack, FW_COMPILE); 4962 dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE); 4963 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); 4964 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); 4965 dictAppendWord(dp, "rot", rot, FW_DEFAULT); 4966 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); 4967 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); 4968 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); 4969 dictAppendWord(dp, "sign", sign, FW_DEFAULT); 4970 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); 4971 dictAppendWord(dp, "source", source, FW_DEFAULT); 4972 dictAppendWord(dp, "state", state, FW_DEFAULT); 4973 dictAppendWord(dp, "swap", swap, FW_DEFAULT); 4974 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); 4975 dictAppendWord(dp, "type", type, FW_DEFAULT); 4976 dictAppendWord(dp, "u.", uDot, FW_DEFAULT); 4977 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); 4978 dictAppendWord(dp, "um*", umStar, FW_DEFAULT); 4979 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); 4980 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); 4981 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); 4982 dictAppendWord(dp, "variable", variable, FW_DEFAULT); 4983 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); 4984 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); 4985 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); 4986 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); 4987 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); 4988 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); 4989 dictAppendWord(dp, "]", rbracket, FW_DEFAULT); 4990 /* 4991 ** CORE EXT word set... 4992 ** see softcore.fr for other definitions 4993 */ 4994 /* "#tib" */ 4995 dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE); 4996 /* ".r" */ 4997 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); 4998 dictAppendWord(dp, "2>r", twoToR, FW_COMPILE); 4999 dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE); 5000 dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE); 5001 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); 5002 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); 5003 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); 5004 dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE); 5005 dictAppendWord(dp, "hex", hex, FW_DEFAULT); 5006 dictAppendWord(dp, "pad", pad, FW_DEFAULT); 5007 dictAppendWord(dp, "parse", parse, FW_DEFAULT); 5008 dictAppendWord(dp, "pick", pick, FW_DEFAULT); 5009 /* query restore-input save-input tib u.r u> unused [compile] */ 5010 dictAppendWord(dp, "roll", roll, FW_DEFAULT); 5011 dictAppendWord(dp, "refill", refill, FW_DEFAULT); 5012 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); 5013 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); 5014 dictAppendWord(dp, "value", constant, FW_DEFAULT); 5015 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); 5016 5017 5018 /* 5019 ** Set CORE environment query values 5020 */ 5021 ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX); 5022 ficlSetEnv(pSys, "/hold", nPAD); 5023 ficlSetEnv(pSys, "/pad", nPAD); 5024 ficlSetEnv(pSys, "address-unit-bits", 8); 5025 ficlSetEnv(pSys, "core", FICL_TRUE); 5026 ficlSetEnv(pSys, "core-ext", FICL_FALSE); 5027 ficlSetEnv(pSys, "floored", FICL_FALSE); 5028 ficlSetEnv(pSys, "max-char", UCHAR_MAX); 5029 ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff); 5030 ficlSetEnv(pSys, "max-n", 0x7fffffff); 5031 ficlSetEnv(pSys, "max-u", 0xffffffff); 5032 ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff); 5033 ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK); 5034 ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK); 5035 5036 /* 5037 ** DOUBLE word set (partial) 5038 */ 5039 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); 5040 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); 5041 dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE); 5042 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); 5043 5044 5045 /* 5046 ** EXCEPTION word set 5047 */ 5048 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); 5049 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); 5050 5051 ficlSetEnv(pSys, "exception", FICL_TRUE); 5052 ficlSetEnv(pSys, "exception-ext", FICL_TRUE); 5053 5054 /* 5055 ** LOCAL and LOCAL EXT 5056 ** see softcore.c for implementation of locals| 5057 */ 5058#if FICL_WANT_LOCALS 5059 pSys->pLinkParen = 5060 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); 5061 pSys->pUnLinkParen = 5062 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); 5063 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); 5064 pSys->pGetLocalParen = 5065 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); 5066 pSys->pToLocalParen = 5067 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); 5068 pSys->pGetLocal0 = 5069 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); 5070 pSys->pToLocal0 = 5071 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); 5072 pSys->pGetLocal1 = 5073 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); 5074 pSys->pToLocal1 = 5075 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); 5076 dictAppendWord(dp, "(local)", localParen, FW_COMPILE); 5077 5078 pSys->pGet2LocalParen = 5079 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); 5080 pSys->pTo2LocalParen = 5081 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); 5082 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); 5083 5084 ficlSetEnv(pSys, "locals", FICL_TRUE); 5085 ficlSetEnv(pSys, "locals-ext", FICL_TRUE); 5086 ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS); 5087#endif 5088 5089 /* 5090 ** Optional MEMORY-ALLOC word set 5091 */ 5092 5093 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT); 5094 dictAppendWord(dp, "free", ansFree, FW_DEFAULT); 5095 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); 5096 5097 ficlSetEnv(pSys, "memory-alloc", FICL_TRUE); 5098 5099 /* 5100 ** optional SEARCH-ORDER word set 5101 */ 5102 ficlCompileSearch(pSys); 5103 5104 /* 5105 ** TOOLS and TOOLS EXT 5106 */ 5107 ficlCompileTools(pSys); 5108 5109 /* 5110 ** FILE and FILE EXT 5111 */ 5112#if FICL_WANT_FILE 5113 ficlCompileFile(pSys); 5114#endif 5115 5116 /* 5117 ** Ficl extras 5118 */ 5119#if FICL_WANT_FLOAT 5120 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); 5121#endif 5122 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); 5123 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); 5124 dictAppendWord(dp, ">name", toName, FW_DEFAULT); 5125 dictAppendWord(dp, "add-parse-step", 5126 addParseStep, FW_DEFAULT); 5127 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); 5128 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ 5129 dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */ 5130 dictAppendWord(dp, "compile-only", 5131 compileOnly, FW_DEFAULT); 5132 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); 5133 dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT); 5134 dictAppendWord(dp, "hash", hash, FW_DEFAULT); 5135 dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT); 5136 dictAppendWord(dp, "?object", isObject, FW_DEFAULT); 5137 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); 5138 dictAppendWord(dp, "sfind", sFind, FW_DEFAULT); 5139 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ 5140 dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT); 5141 dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT); 5142 dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT); 5143 dictAppendWord(dp, "q!", quadStore, FW_DEFAULT); 5144 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); 5145 dictAppendWord(dp, "w!", wStore, FW_DEFAULT); 5146 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); 5147#if FICL_WANT_USER 5148 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); 5149 dictAppendWord(dp, "user", userVariable, FW_DEFAULT); 5150#endif 5151#ifdef TESTMAIN 5152 dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT); 5153 dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT); 5154#endif 5155 5156 /* 5157 ** internal support words 5158 */ 5159 dictAppendWord(dp, "(create)", createParen, FW_COMPILE); 5160 pSys->pExitParen = 5161 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); 5162 pSys->pSemiParen = 5163 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); 5164 pSys->pLitParen = 5165 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); 5166 pSys->pTwoLitParen = 5167 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); 5168 pSys->pStringLit = 5169 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); 5170 pSys->pCStringLit = 5171 dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE); 5172 pSys->pBranch0 = 5173 dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE); 5174 pSys->pBranchParen = 5175 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); 5176 pSys->pDoParen = 5177 dictAppendWord(dp, "(do)", doParen, FW_COMPILE); 5178 pSys->pDoesParen = 5179 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); 5180 pSys->pQDoParen = 5181 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); 5182 pSys->pLoopParen = 5183 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); 5184 pSys->pPLoopParen = 5185 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); 5186 pSys->pInterpret = 5187 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); 5188 dictAppendWord(dp, "lookup", lookup, FW_DEFAULT); 5189 pSys->pOfParen = 5190 dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT); 5191 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); 5192 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); 5193 dictAppendWord(dp, "(parse-step)", 5194 parseStepParen, FW_DEFAULT); 5195 pSys->pExitInner = 5196 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); 5197 5198 /* 5199 ** Set up system's outer interpreter loop - maybe this should be in initSystem? 5200 */ 5201 pSys->pInterp[0] = pSys->pInterpret; 5202 pSys->pInterp[1] = pSys->pBranchParen; 5203 pSys->pInterp[2] = (FICL_WORD *)(void *)(-2); 5204 5205 assert(dictCellsAvail(dp) > 0); 5206 5207 return; 5208} 5209 5210