1 /******************************************************************* 2 ** v m . c 3 ** Forth Inspired Command Language - virtual machine methods 4 ** Author: John Sadler (john_sadler@alum.mit.edu) 5 ** Created: 19 July 1997 6 ** $Id: vm.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $ 7 *******************************************************************/ 8 /* 9 ** This file implements the virtual machine of FICL. Each virtual 10 ** machine retains the state of an interpreter. A virtual machine 11 ** owns a pair of stacks for parameters and return addresses, as 12 ** well as a pile of state variables and the two dedicated registers 13 ** of the interp. 14 */ 15 /* 16 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 17 ** All rights reserved. 18 ** 19 ** Get the latest Ficl release at http://ficl.sourceforge.net 20 ** 21 ** I am interested in hearing from anyone who uses ficl. If you have 22 ** a problem, a success story, a defect, an enhancement request, or 23 ** if you would like to contribute to the ficl release, please 24 ** contact me by email at the address above. 25 ** 26 ** L I C E N S E and D I S C L A I M E R 27 ** 28 ** Redistribution and use in source and binary forms, with or without 29 ** modification, are permitted provided that the following conditions 30 ** are met: 31 ** 1. Redistributions of source code must retain the above copyright 32 ** notice, this list of conditions and the following disclaimer. 33 ** 2. Redistributions in binary form must reproduce the above copyright 34 ** notice, this list of conditions and the following disclaimer in the 35 ** documentation and/or other materials provided with the distribution. 36 ** 37 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 38 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 39 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 40 ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 41 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 42 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 43 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 44 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 45 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 46 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 47 ** SUCH DAMAGE. 48 */ 49 50 51 #ifdef TESTMAIN 52 #include <stdlib.h> 53 #include <stdio.h> 54 #include <ctype.h> 55 #else 56 #include <stand.h> 57 #endif 58 #include <stdarg.h> 59 #include <string.h> 60 #include "ficl.h" 61 62 static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; 63 64 65 /************************************************************************** 66 v m B r a n c h R e l a t i v e 67 ** 68 **************************************************************************/ 69 void vmBranchRelative(FICL_VM *pVM, int offset) 70 { 71 pVM->ip += offset; 72 return; 73 } 74 75 76 /************************************************************************** 77 v m C r e a t e 78 ** Creates a virtual machine either from scratch (if pVM is NULL on entry) 79 ** or by resizing and reinitializing an existing VM to the specified stack 80 ** sizes. 81 **************************************************************************/ 82 FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) 83 { 84 if (pVM == NULL) 85 { 86 pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM)); 87 assert (pVM); 88 memset(pVM, 0, sizeof (FICL_VM)); 89 } 90 91 if (pVM->pStack) 92 stackDelete(pVM->pStack); 93 pVM->pStack = stackCreate(nPStack); 94 95 if (pVM->rStack) 96 stackDelete(pVM->rStack); 97 pVM->rStack = stackCreate(nRStack); 98 99 #if FICL_WANT_FLOAT 100 if (pVM->fStack) 101 stackDelete(pVM->fStack); 102 pVM->fStack = stackCreate(nPStack); 103 #endif 104 105 pVM->textOut = ficlTextOut; 106 107 vmReset(pVM); 108 return pVM; 109 } 110 111 112 /************************************************************************** 113 v m D e l e t e 114 ** Free all memory allocated to the specified VM and its subordinate 115 ** structures. 116 **************************************************************************/ 117 void vmDelete (FICL_VM *pVM) 118 { 119 if (pVM) 120 { 121 ficlFree(pVM->pStack); 122 ficlFree(pVM->rStack); 123 #if FICL_WANT_FLOAT 124 ficlFree(pVM->fStack); 125 #endif 126 ficlFree(pVM); 127 } 128 129 return; 130 } 131 132 133 /************************************************************************** 134 v m E x e c u t e 135 ** Sets up the specified word to be run by the inner interpreter. 136 ** Executes the word's code part immediately, but in the case of 137 ** colon definition, the definition itself needs the inner interp 138 ** to complete. This does not happen until control reaches ficlExec 139 **************************************************************************/ 140 void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) 141 { 142 pVM->runningWord = pWord; 143 pWord->code(pVM); 144 return; 145 } 146 147 148 /************************************************************************** 149 v m I n n e r L o o p 150 ** the mysterious inner interpreter... 151 ** This loop is the address interpreter that makes colon definitions 152 ** work. Upon entry, it assumes that the IP points to an entry in 153 ** a definition (the body of a colon word). It runs one word at a time 154 ** until something does vmThrow. The catcher for this is expected to exist 155 ** in the calling code. 156 ** vmThrow gets you out of this loop with a longjmp() 157 ** Visual C++ 5 chokes on this loop in Release mode. Aargh. 158 **************************************************************************/ 159 #if INLINE_INNER_LOOP == 0 160 void vmInnerLoop(FICL_VM *pVM) 161 { 162 M_INNER_LOOP(pVM); 163 } 164 #endif 165 #if 0 166 /* 167 ** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations, 168 ** as well as create does> : ; and various literals 169 */ 170 typedef enum 171 { 172 PATCH = 0, 173 L0, 174 L1, 175 L2, 176 LMINUS1, 177 LMINUS2, 178 DROP, 179 SWAP, 180 DUP, 181 PICK, 182 ROLL, 183 FETCH, 184 STORE, 185 BRANCH, 186 CBRANCH, 187 LEAVE, 188 TO_R, 189 R_FROM, 190 EXIT; 191 } OPCODE; 192 193 typedef CELL *IPTYPE; 194 195 void vmInnerLoop(FICL_VM *pVM) 196 { 197 IPTYPE ip = pVM->ip; 198 FICL_STACK *pStack = pVM->pStack; 199 200 for (;;) 201 { 202 OPCODE o = (*ip++).i; 203 CELL c; 204 switch (o) 205 { 206 case L0: 207 stackPushINT(pStack, 0); 208 break; 209 case L1: 210 stackPushINT(pStack, 1); 211 break; 212 case L2: 213 stackPushINT(pStack, 2); 214 break; 215 case LMINUS1: 216 stackPushINT(pStack, -1); 217 break; 218 case LMINUS2: 219 stackPushINT(pStack, -2); 220 break; 221 case DROP: 222 stackDrop(pStack, 1); 223 break; 224 case SWAP: 225 stackRoll(pStack, 1); 226 break; 227 case DUP: 228 stackPick(pStack, 0); 229 break; 230 case PICK: 231 c = *ip++; 232 stackPick(pStack, c.i); 233 break; 234 case ROLL: 235 c = *ip++; 236 stackRoll(pStack, c.i); 237 break; 238 case EXIT: 239 return; 240 } 241 } 242 243 return; 244 } 245 #endif 246 247 248 249 /************************************************************************** 250 v m G e t D i c t 251 ** Returns the address dictionary for this VM's system 252 **************************************************************************/ 253 FICL_DICT *vmGetDict(FICL_VM *pVM) 254 { 255 assert(pVM); 256 return pVM->pSys->dp; 257 } 258 259 260 /************************************************************************** 261 v m G e t S t r i n g 262 ** Parses a string out of the VM input buffer and copies up to the first 263 ** FICL_STRING_MAX characters to the supplied destination buffer, a 264 ** FICL_STRING. The destination string is NULL terminated. 265 ** 266 ** Returns the address of the first unused character in the dest buffer. 267 **************************************************************************/ 268 char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter) 269 { 270 STRINGINFO si = vmParseStringEx(pVM, delimiter, 0); 271 272 if (SI_COUNT(si) > FICL_STRING_MAX) 273 { 274 SI_SETLEN(si, FICL_STRING_MAX); 275 } 276 277 strncpy(spDest->text, SI_PTR(si), SI_COUNT(si)); 278 spDest->text[SI_COUNT(si)] = '\0'; 279 spDest->count = (FICL_COUNT)SI_COUNT(si); 280 281 return spDest->text + SI_COUNT(si) + 1; 282 } 283 284 285 /************************************************************************** 286 v m G e t W o r d 287 ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with 288 ** non-zero length. 289 **************************************************************************/ 290 STRINGINFO vmGetWord(FICL_VM *pVM) 291 { 292 STRINGINFO si = vmGetWord0(pVM); 293 294 if (SI_COUNT(si) == 0) 295 { 296 vmThrow(pVM, VM_RESTART); 297 } 298 299 return si; 300 } 301 302 303 /************************************************************************** 304 v m G e t W o r d 0 305 ** Skip leading whitespace and parse a space delimited word from the tib. 306 ** Returns the start address and length of the word. Updates the tib 307 ** to reflect characters consumed, including the trailing delimiter. 308 ** If there's nothing of interest in the tib, returns zero. This function 309 ** does not use vmParseString because it uses isspace() rather than a 310 ** single delimiter character. 311 **************************************************************************/ 312 STRINGINFO vmGetWord0(FICL_VM *pVM) 313 { 314 char *pSrc = vmGetInBuf(pVM); 315 char *pEnd = vmGetInBufEnd(pVM); 316 STRINGINFO si; 317 FICL_UNS count = 0; 318 char ch = 0; 319 320 pSrc = skipSpace(pSrc, pEnd); 321 SI_SETPTR(si, pSrc); 322 323 /* 324 for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc) 325 { 326 count++; 327 } 328 */ 329 330 /* Changed to make Purify happier. --lch */ 331 for (;;) 332 { 333 if (pEnd == pSrc) 334 break; 335 ch = *pSrc; 336 if (isspace(ch)) 337 break; 338 count++; 339 pSrc++; 340 } 341 342 SI_SETLEN(si, count); 343 344 if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */ 345 pSrc++; 346 347 vmUpdateTib(pVM, pSrc); 348 349 return si; 350 } 351 352 353 /************************************************************************** 354 v m G e t W o r d T o P a d 355 ** Does vmGetWord and copies the result to the pad as a NULL terminated 356 ** string. Returns the length of the string. If the string is too long 357 ** to fit in the pad, it is truncated. 358 **************************************************************************/ 359 int vmGetWordToPad(FICL_VM *pVM) 360 { 361 STRINGINFO si; 362 char *cp = (char *)pVM->pad; 363 si = vmGetWord(pVM); 364 365 if (SI_COUNT(si) > nPAD) 366 SI_SETLEN(si, nPAD); 367 368 strncpy(cp, SI_PTR(si), SI_COUNT(si)); 369 cp[SI_COUNT(si)] = '\0'; 370 return (int)(SI_COUNT(si)); 371 } 372 373 374 /************************************************************************** 375 v m P a r s e S t r i n g 376 ** Parses a string out of the input buffer using the delimiter 377 ** specified. Skips leading delimiters, marks the start of the string, 378 ** and counts characters to the next delimiter it encounters. It then 379 ** updates the vm input buffer to consume all these chars, including the 380 ** trailing delimiter. 381 ** Returns the address and length of the parsed string, not including the 382 ** trailing delimiter. 383 **************************************************************************/ 384 STRINGINFO vmParseString(FICL_VM *pVM, char delim) 385 { 386 return vmParseStringEx(pVM, delim, 1); 387 } 388 389 STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) 390 { 391 STRINGINFO si; 392 char *pSrc = vmGetInBuf(pVM); 393 char *pEnd = vmGetInBufEnd(pVM); 394 char ch; 395 396 if (fSkipLeading) 397 { /* skip lead delimiters */ 398 while ((pSrc != pEnd) && (*pSrc == delim)) 399 pSrc++; 400 } 401 402 SI_SETPTR(si, pSrc); /* mark start of text */ 403 404 for (ch = *pSrc; (pSrc != pEnd) 405 && (ch != delim) 406 && (ch != '\r') 407 && (ch != '\n'); ch = *++pSrc) 408 { 409 ; /* find next delimiter or end of line */ 410 } 411 412 /* set length of result */ 413 SI_SETLEN(si, pSrc - SI_PTR(si)); 414 415 if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ 416 pSrc++; 417 418 vmUpdateTib(pVM, pSrc); 419 return si; 420 } 421 422 423 /************************************************************************** 424 v m P o p 425 ** 426 **************************************************************************/ 427 CELL vmPop(FICL_VM *pVM) 428 { 429 return stackPop(pVM->pStack); 430 } 431 432 433 /************************************************************************** 434 v m P u s h 435 ** 436 **************************************************************************/ 437 void vmPush(FICL_VM *pVM, CELL c) 438 { 439 stackPush(pVM->pStack, c); 440 return; 441 } 442 443 444 /************************************************************************** 445 v m P o p I P 446 ** 447 **************************************************************************/ 448 void vmPopIP(FICL_VM *pVM) 449 { 450 pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack)); 451 return; 452 } 453 454 455 /************************************************************************** 456 v m P u s h I P 457 ** 458 **************************************************************************/ 459 void vmPushIP(FICL_VM *pVM, IPTYPE newIP) 460 { 461 stackPushPtr(pVM->rStack, (void *)pVM->ip); 462 pVM->ip = newIP; 463 return; 464 } 465 466 467 /************************************************************************** 468 v m P u s h T i b 469 ** Binds the specified input string to the VM and clears >IN (the index) 470 **************************************************************************/ 471 void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib) 472 { 473 if (pSaveTib) 474 { 475 *pSaveTib = pVM->tib; 476 } 477 478 pVM->tib.cp = text; 479 pVM->tib.end = text + nChars; 480 pVM->tib.index = 0; 481 } 482 483 484 void vmPopTib(FICL_VM *pVM, TIB *pTib) 485 { 486 if (pTib) 487 { 488 pVM->tib = *pTib; 489 } 490 return; 491 } 492 493 494 /************************************************************************** 495 v m Q u i t 496 ** 497 **************************************************************************/ 498 void vmQuit(FICL_VM *pVM) 499 { 500 stackReset(pVM->rStack); 501 pVM->fRestart = 0; 502 pVM->ip = NULL; 503 pVM->runningWord = NULL; 504 pVM->state = INTERPRET; 505 pVM->tib.cp = NULL; 506 pVM->tib.end = NULL; 507 pVM->tib.index = 0; 508 pVM->pad[0] = '\0'; 509 pVM->sourceID.i = 0; 510 return; 511 } 512 513 514 /************************************************************************** 515 v m R e s e t 516 ** 517 **************************************************************************/ 518 void vmReset(FICL_VM *pVM) 519 { 520 vmQuit(pVM); 521 stackReset(pVM->pStack); 522 #if FICL_WANT_FLOAT 523 stackReset(pVM->fStack); 524 #endif 525 pVM->base = 10; 526 return; 527 } 528 529 530 /************************************************************************** 531 v m S e t T e x t O u t 532 ** Binds the specified output callback to the vm. If you pass NULL, 533 ** binds the default output function (ficlTextOut) 534 **************************************************************************/ 535 void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut) 536 { 537 if (textOut) 538 pVM->textOut = textOut; 539 else 540 pVM->textOut = ficlTextOut; 541 542 return; 543 } 544 545 546 /************************************************************************** 547 v m T e x t O u t 548 ** Feeds text to the vm's output callback 549 **************************************************************************/ 550 void vmTextOut(FICL_VM *pVM, char *text, int fNewline) 551 { 552 assert(pVM); 553 assert(pVM->textOut); 554 (pVM->textOut)(pVM, text, fNewline); 555 556 return; 557 } 558 559 560 /************************************************************************** 561 v m T h r o w 562 ** 563 **************************************************************************/ 564 void vmThrow(FICL_VM *pVM, int except) 565 { 566 if (pVM->pState) 567 longjmp(*(pVM->pState), except); 568 } 569 570 571 void vmThrowErr(FICL_VM *pVM, char *fmt, ...) 572 { 573 va_list va; 574 va_start(va, fmt); 575 vsprintf(pVM->pad, fmt, va); 576 vmTextOut(pVM, pVM->pad, 1); 577 va_end(va); 578 longjmp(*(pVM->pState), VM_ERREXIT); 579 } 580 581 582 /************************************************************************** 583 w o r d I s I m m e d i a t e 584 ** 585 **************************************************************************/ 586 int wordIsImmediate(FICL_WORD *pFW) 587 { 588 return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE)); 589 } 590 591 592 /************************************************************************** 593 w o r d I s C o m p i l e O n l y 594 ** 595 **************************************************************************/ 596 int wordIsCompileOnly(FICL_WORD *pFW) 597 { 598 return ((pFW != NULL) && (pFW->flags & FW_COMPILE)); 599 } 600 601 602 /************************************************************************** 603 s t r r e v 604 ** 605 **************************************************************************/ 606 char *strrev( char *string ) 607 { /* reverse a string in-place */ 608 int i = strlen(string); 609 char *p1 = string; /* first char of string */ 610 char *p2 = string + i - 1; /* last non-NULL char of string */ 611 char c; 612 613 if (i > 1) 614 { 615 while (p1 < p2) 616 { 617 c = *p2; 618 *p2 = *p1; 619 *p1 = c; 620 p1++; p2--; 621 } 622 } 623 624 return string; 625 } 626 627 628 /************************************************************************** 629 d i g i t _ t o _ c h a r 630 ** 631 **************************************************************************/ 632 char digit_to_char(int value) 633 { 634 return digits[value]; 635 } 636 637 638 /************************************************************************** 639 i s P o w e r O f T w o 640 ** Tests whether supplied argument is an integer power of 2 (2**n) 641 ** where 32 > n > 1, and returns n if so. Otherwise returns zero. 642 **************************************************************************/ 643 int isPowerOfTwo(FICL_UNS u) 644 { 645 int i = 1; 646 FICL_UNS t = 2; 647 648 for (; ((t <= u) && (t != 0)); i++, t <<= 1) 649 { 650 if (u == t) 651 return i; 652 } 653 654 return 0; 655 } 656 657 658 /************************************************************************** 659 l t o a 660 ** 661 **************************************************************************/ 662 char *ltoa( FICL_INT value, char *string, int radix ) 663 { /* convert long to string, any base */ 664 char *cp = string; 665 int sign = ((radix == 10) && (value < 0)); 666 int pwr; 667 668 assert(radix > 1); 669 assert(radix < 37); 670 assert(string); 671 672 pwr = isPowerOfTwo((FICL_UNS)radix); 673 674 if (sign) 675 value = -value; 676 677 if (value == 0) 678 *cp++ = '0'; 679 else if (pwr != 0) 680 { 681 FICL_UNS v = (FICL_UNS) value; 682 FICL_UNS mask = (FICL_UNS) ~(-1 << pwr); 683 while (v) 684 { 685 *cp++ = digits[v & mask]; 686 v >>= pwr; 687 } 688 } 689 else 690 { 691 UNSQR result; 692 DPUNS v; 693 v.hi = 0; 694 v.lo = (FICL_UNS)value; 695 while (v.lo) 696 { 697 result = ficlLongDiv(v, (FICL_UNS)radix); 698 *cp++ = digits[result.rem]; 699 v.lo = result.quot; 700 } 701 } 702 703 if (sign) 704 *cp++ = '-'; 705 706 *cp++ = '\0'; 707 708 return strrev(string); 709 } 710 711 712 /************************************************************************** 713 u l t o a 714 ** 715 **************************************************************************/ 716 char *ultoa(FICL_UNS value, char *string, int radix ) 717 { /* convert long to string, any base */ 718 char *cp = string; 719 DPUNS ud; 720 UNSQR result; 721 722 assert(radix > 1); 723 assert(radix < 37); 724 assert(string); 725 726 if (value == 0) 727 *cp++ = '0'; 728 else 729 { 730 ud.hi = 0; 731 ud.lo = value; 732 result.quot = value; 733 734 while (ud.lo) 735 { 736 result = ficlLongDiv(ud, (FICL_UNS)radix); 737 ud.lo = result.quot; 738 *cp++ = digits[result.rem]; 739 } 740 } 741 742 *cp++ = '\0'; 743 744 return strrev(string); 745 } 746 747 748 /************************************************************************** 749 c a s e F o l d 750 ** Case folds a NULL terminated string in place. All characters 751 ** get converted to lower case. 752 **************************************************************************/ 753 char *caseFold(char *cp) 754 { 755 char *oldCp = cp; 756 757 while (*cp) 758 { 759 if (isupper(*cp)) 760 *cp = (char)tolower(*cp); 761 cp++; 762 } 763 764 return oldCp; 765 } 766 767 768 /************************************************************************** 769 s t r i n c m p 770 ** (jws) simplified the code a bit in hopes of appeasing Purify 771 **************************************************************************/ 772 int strincmp(char *cp1, char *cp2, FICL_UNS count) 773 { 774 int i = 0; 775 776 for (; 0 < count; ++cp1, ++cp2, --count) 777 { 778 i = tolower(*cp1) - tolower(*cp2); 779 if (i != 0) 780 return i; 781 else if (*cp1 == '\0') 782 return 0; 783 } 784 return 0; 785 } 786 787 /************************************************************************** 788 s k i p S p a c e 789 ** Given a string pointer, returns a pointer to the first non-space 790 ** char of the string, or to the NULL terminator if no such char found. 791 ** If the pointer reaches "end" first, stop there. Pass NULL to 792 ** suppress this behavior. 793 **************************************************************************/ 794 char *skipSpace(char *cp, char *end) 795 { 796 assert(cp); 797 798 while ((cp != end) && isspace(*cp)) 799 cp++; 800 801 return cp; 802 } 803 804 805