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