1 /*******************************************************************
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 *******************************************************************/
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
16 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
17 ** All rights reserved.
19 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
26 ** L I C E N S E and D I S C L A I M E R
28 ** Redistribution and use in source and binary forms, with or without
29 ** modification, are permitted provided that the following conditions
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.
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
63 static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
66 /**************************************************************************
67 v m B r a n c h R e l a t i v e
69 **************************************************************************/
70 void vmBranchRelative(FICL_VM *pVM, int offset)
77 /**************************************************************************
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
82 **************************************************************************/
83 FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
87 pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
89 memset(pVM, 0, sizeof (FICL_VM));
93 stackDelete(pVM->pStack);
94 pVM->pStack = stackCreate(nPStack);
97 stackDelete(pVM->rStack);
98 pVM->rStack = stackCreate(nRStack);
102 stackDelete(pVM->fStack);
103 pVM->fStack = stackCreate(nPStack);
106 pVM->textOut = ficlTextOut;
113 /**************************************************************************
115 ** Free all memory allocated to the specified VM and its subordinate
117 **************************************************************************/
118 void vmDelete (FICL_VM *pVM)
122 ficlFree(pVM->pStack);
123 ficlFree(pVM->rStack);
125 ficlFree(pVM->fStack);
134 /**************************************************************************
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)
143 pVM->runningWord = pWord;
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)
168 ** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations,
169 ** as well as create does> : ; and various literals
194 typedef CELL *IPTYPE;
196 void vmInnerLoop(FICL_VM *pVM)
199 FICL_STACK *pStack = pVM->pStack;
203 OPCODE o = (*ip++).i;
208 stackPushINT(pStack, 0);
211 stackPushINT(pStack, 1);
214 stackPushINT(pStack, 2);
217 stackPushINT(pStack, -1);
220 stackPushINT(pStack, -2);
223 stackDrop(pStack, 1);
226 stackRoll(pStack, 1);
229 stackPick(pStack, 0);
233 stackPick(pStack, c.i);
237 stackRoll(pStack, c.i);
250 /**************************************************************************
252 ** Returns the address dictionary for this VM's system
253 **************************************************************************/
254 FICL_DICT *vmGetDict(FICL_VM *pVM)
257 return pVM->pSys->dp;
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.
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)
271 STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
273 if (SI_COUNT(si) > FICL_STRING_MAX)
275 SI_SETLEN(si, FICL_STRING_MAX);
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);
282 return spDest->text + SI_COUNT(si) + 1;
286 /**************************************************************************
288 ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
290 **************************************************************************/
291 STRINGINFO vmGetWord(FICL_VM *pVM)
293 STRINGINFO si = vmGetWord0(pVM);
295 if (SI_COUNT(si) == 0)
297 vmThrow(pVM, VM_RESTART);
304 /**************************************************************************
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)
315 char *pSrc = vmGetInBuf(pVM);
316 char *pEnd = vmGetInBufEnd(pVM);
321 pSrc = skipSpace(pSrc, pEnd);
325 for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
331 /* Changed to make Purify happier. --lch */
343 SI_SETLEN(si, count);
345 if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */
348 vmUpdateTib(pVM, pSrc);
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)
363 char *cp = (char *)pVM->pad;
366 if (SI_COUNT(si) > nPAD)
369 strncpy(cp, SI_PTR(si), SI_COUNT(si));
370 cp[SI_COUNT(si)] = '\0';
371 return (int)(SI_COUNT(si));
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)
387 return vmParseStringEx(pVM, delim, 1);
390 STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
393 char *pSrc = vmGetInBuf(pVM);
394 char *pEnd = vmGetInBufEnd(pVM);
398 { /* skip lead delimiters */
399 while ((pSrc != pEnd) && (*pSrc == delim))
403 SI_SETPTR(si, pSrc); /* mark start of text */
405 for (ch = *pSrc; (pSrc != pEnd)
408 && (ch != '\n'); ch = *++pSrc)
410 ; /* find next delimiter or end of line */
413 /* set length of result */
414 SI_SETLEN(si, pSrc - SI_PTR(si));
416 if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
419 vmUpdateTib(pVM, pSrc);
424 /**************************************************************************
427 **************************************************************************/
428 CELL vmPop(FICL_VM *pVM)
430 return stackPop(pVM->pStack);
434 /**************************************************************************
437 **************************************************************************/
438 void vmPush(FICL_VM *pVM, CELL c)
440 stackPush(pVM->pStack, c);
445 /**************************************************************************
448 **************************************************************************/
449 void vmPopIP(FICL_VM *pVM)
451 pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
456 /**************************************************************************
459 **************************************************************************/
460 void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
462 stackPushPtr(pVM->rStack, (void *)pVM->ip);
468 /**************************************************************************
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)
476 *pSaveTib = pVM->tib;
480 pVM->tib.end = text + nChars;
485 void vmPopTib(FICL_VM *pVM, TIB *pTib)
495 /**************************************************************************
498 **************************************************************************/
499 void vmQuit(FICL_VM *pVM)
501 stackReset(pVM->rStack);
504 pVM->runningWord = NULL;
505 pVM->state = INTERPRET;
515 /**************************************************************************
518 **************************************************************************/
519 void vmReset(FICL_VM *pVM)
522 stackReset(pVM->pStack);
524 stackReset(pVM->fStack);
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)
539 pVM->textOut = textOut;
541 pVM->textOut = ficlTextOut;
547 /**************************************************************************
549 ** Feeds text to the vm's output callback
550 **************************************************************************/
551 void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
554 assert(pVM->textOut);
555 (pVM->textOut)(pVM, text, fNewline);
561 /**************************************************************************
564 **************************************************************************/
565 void vmThrow(FICL_VM *pVM, int except)
568 longjmp(*(pVM->pState), except);
572 void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
576 vsprintf(pVM->pad, fmt, va);
577 vmTextOut(pVM, pVM->pad, 1);
579 longjmp(*(pVM->pState), VM_ERREXIT);
583 /**************************************************************************
584 w o r d I s I m m e d i a t e
586 **************************************************************************/
587 int wordIsImmediate(FICL_WORD *pFW)
589 return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
593 /**************************************************************************
594 w o r d I s C o m p i l e O n l y
596 **************************************************************************/
597 int wordIsCompileOnly(FICL_WORD *pFW)
599 return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
603 /**************************************************************************
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 */
629 /**************************************************************************
630 d i g i t _ t o _ c h a r
632 **************************************************************************/
633 char digit_to_char(int value)
635 return digits[value];
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)
649 for (; ((t <= u) && (t != 0)); i++, t <<= 1)
659 /**************************************************************************
662 **************************************************************************/
663 char *ltoa( FICL_INT value, char *string, int radix )
664 { /* convert long to string, any base */
666 int sign = ((radix == 10) && (value < 0));
673 pwr = isPowerOfTwo((FICL_UNS)radix);
682 FICL_UNS v = (FICL_UNS) value;
683 FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
686 *cp++ = digits[v & mask];
695 v.lo = (FICL_UNS)value;
698 result = ficlLongDiv(v, (FICL_UNS)radix);
699 *cp++ = digits[result.rem];
709 return strrev(string);
713 /**************************************************************************
716 **************************************************************************/
717 char *ultoa(FICL_UNS value, char *string, int radix )
718 { /* convert long to string, any base */
737 result = ficlLongDiv(ud, (FICL_UNS)radix);
739 *cp++ = digits[result.rem];
745 return strrev(string);
749 /**************************************************************************
751 ** Case folds a NULL terminated string in place. All characters
752 ** get converted to lower case.
753 **************************************************************************/
754 char *caseFold(char *cp)
761 *cp = (char)tolower(*cp);
769 /**************************************************************************
771 ** (jws) simplified the code a bit in hopes of appeasing Purify
772 **************************************************************************/
773 int strincmp(char *cp1, char *cp2, FICL_UNS count)
777 for (; 0 < count; ++cp1, ++cp2, --count)
779 i = tolower(*cp1) - tolower(*cp2);
782 else if (*cp1 == '\0')
788 /**************************************************************************
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)
799 while ((cp != end) && isspace(*cp))