/*******************************************************************
** v m . c
** Forth Inspired Command Language - virtual machine methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** $Id: vm.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
*******************************************************************/
/*
** This file implements the virtual machine of FICL. Each virtual
** machine retains the state of an interpreter. A virtual machine
** owns a pair of stacks for parameters and return addresses, as
** well as a pile of state variables and the two dedicated registers
** of the interp.
*/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
** All rights reserved.
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
** I am interested in hearing from anyone who uses ficl. If you have
** a problem, a success story, a defect, an enhancement request, or
** if you would like to contribute to the ficl release, please
** contact me by email at the address above.
**
** L I C E N S E and D I S C L A I M E R
**
** Redistribution and use in source and binary forms, with or without
** modification, are permitted provided that the following conditions
** are met:
** 1. Redistributions of source code must retain the above copyright
** notice, this list of conditions and the following disclaimer.
** 2. Redistributions in binary form must reproduce the above copyright
** notice, this list of conditions and the following disclaimer in the
** documentation and/or other materials provided with the distribution.
**
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
** SUCH DAMAGE.
*/
/* $FreeBSD$ */
#ifdef TESTMAIN
#include <stdlib.h>
#include <stdio.h>
#include <ctype.h>
#else
#include <stand.h>
#endif
#include <stdarg.h>
#include <string.h>
#include "ficl.h"
static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
/**************************************************************************
v m B r a n c h R e l a t i v e
**
**************************************************************************/
void vmBranchRelative(FICL_VM *pVM, int offset)
{
pVM->ip += offset;
return;
}
/**************************************************************************
v m C r e a t e
** Creates a virtual machine either from scratch (if pVM is NULL on entry)
** or by resizing and reinitializing an existing VM to the specified stack
** sizes.
**************************************************************************/
FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
{
if (pVM == NULL)
{
pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
assert (pVM);
memset(pVM, 0, sizeof (FICL_VM));
}
if (pVM->pStack)
stackDelete(pVM->pStack);
pVM->pStack = stackCreate(nPStack);
if (pVM->rStack)
stackDelete(pVM->rStack);
pVM->rStack = stackCreate(nRStack);
#if FICL_WANT_FLOAT
if (pVM->fStack)
stackDelete(pVM->fStack);
pVM->fStack = stackCreate(nPStack);
#endif
pVM->textOut = ficlTextOut;
vmReset(pVM);
return pVM;
}
/**************************************************************************
v m D e l e t e
** Free all memory allocated to the specified VM and its subordinate
** structures.
**************************************************************************/
void vmDelete (FICL_VM *pVM)
{
if (pVM)
{
ficlFree(pVM->pStack);
ficlFree(pVM->rStack);
#if FICL_WANT_FLOAT
ficlFree(pVM->fStack);
#endif
ficlFree(pVM);
}
return;
}
/**************************************************************************
v m E x e c u t e
** Sets up the specified word to be run by the inner interpreter.
** Executes the word's code part immediately, but in the case of
** colon definition, the definition itself needs the inner interp
** to complete. This does not happen until control reaches ficlExec
**************************************************************************/
void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
{
pVM->runningWord = pWord;
pWord->code(pVM);
return;
}
/**************************************************************************
v m I n n e r L o o p
** the mysterious inner interpreter...
** This loop is the address interpreter that makes colon definitions
** work. Upon entry, it assumes that the IP points to an entry in
** a definition (the body of a colon word). It runs one word at a time
** until something does vmThrow. The catcher for this is expected to exist
** in the calling code.
** vmThrow gets you out of this loop with a longjmp()
** Visual C++ 5 chokes on this loop in Release mode. Aargh.
**************************************************************************/
#if INLINE_INNER_LOOP == 0
void vmInnerLoop(FICL_VM *pVM)
{
M_INNER_LOOP(pVM);
}
#endif
#if 0
/*
** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations,
** as well as create does> : ; and various literals
*/
typedef enum
{
PATCH = 0,
L0,
L1,
L2,
LMINUS1,
LMINUS2,
DROP,
SWAP,
DUP,
PICK,
ROLL,
FETCH,
STORE,
BRANCH,
CBRANCH,
LEAVE,
TO_R,
R_FROM,
EXIT;
} OPCODE;
typedef CELL *IPTYPE;
void vmInnerLoop(FICL_VM *pVM)
{
IPTYPE ip = pVM->ip;
FICL_STACK *pStack = pVM->pStack;
for (;;)
{
OPCODE o = (*ip++).i;
CELL c;
switch (o)
{
case L0:
stackPushINT(pStack, 0);
break;
case L1:
stackPushINT(pStack, 1);
break;
case L2:
stackPushINT(pStack, 2);
break;
case LMINUS1:
stackPushINT(pStack, -1);
break;
case LMINUS2:
stackPushINT(pStack, -2);
break;
case DROP:
stackDrop(pStack, 1);
break;
case SWAP:
stackRoll(pStack, 1);
break;
case DUP:
stackPick(pStack, 0);
break;
case PICK:
c = *ip++;
stackPick(pStack, c.i);
break;
case ROLL:
c = *ip++;
stackRoll(pStack, c.i);
break;
case EXIT:
return;
}
}
return;
}
#endif
/**************************************************************************
v m G e t D i c t
** Returns the address dictionary for this VM's system
**************************************************************************/
FICL_DICT *vmGetDict(FICL_VM *pVM)
{
assert(pVM);
return pVM->pSys->dp;
}
/**************************************************************************
v m G e t S t r i n g
** Parses a string out of the VM input buffer and copies up to the first
** FICL_STRING_MAX characters to the supplied destination buffer, a
** FICL_STRING. The destination string is NULL terminated.
**
** Returns the address of the first unused character in the dest buffer.
**************************************************************************/
char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
{
STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
if (SI_COUNT(si) > FICL_STRING_MAX)
{
SI_SETLEN(si, FICL_STRING_MAX);
}
strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
spDest->text[SI_COUNT(si)] = '\0';
spDest->count = (FICL_COUNT)SI_COUNT(si);
return spDest->text + SI_COUNT(si) + 1;
}
/**************************************************************************
v m G e t W o r d
** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
** non-zero length.
**************************************************************************/
STRINGINFO vmGetWord(FICL_VM *pVM)
{
STRINGINFO si = vmGetWord0(pVM);
if (SI_COUNT(si) == 0)
{
vmThrow(pVM, VM_RESTART);
}
return si;
}
/**************************************************************************
v m G e t W o r d 0
** Skip leading whitespace and parse a space delimited word from the tib.
** Returns the start address and length of the word. Updates the tib
** to reflect characters consumed, including the trailing delimiter.
** If there's nothing of interest in the tib, returns zero. This function
** does not use vmParseString because it uses isspace() rather than a
** single delimiter character.
**************************************************************************/
STRINGINFO vmGetWord0(FICL_VM *pVM)
{
char *pSrc = vmGetInBuf(pVM);
char *pEnd = vmGetInBufEnd(pVM);
STRINGINFO si;
FICL_UNS count = 0;
char ch = 0;
pSrc = skipSpace(pSrc, pEnd);
SI_SETPTR(si, pSrc);
/*
for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
{
count++;
}
*/
/* Changed to make Purify happier. --lch */
for (;;)
{
if (pEnd == pSrc)
break;
ch = *pSrc;
if (isspace(ch))
break;
count++;
pSrc++;
}
SI_SETLEN(si, count);
if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
return si;
}
/**************************************************************************
v m G e t W o r d T o P a d
** Does vmGetWord and copies the result to the pad as a NULL terminated
** string. Returns the length of the string. If the string is too long
** to fit in the pad, it is truncated.
**************************************************************************/
int vmGetWordToPad(FICL_VM *pVM)
{
STRINGINFO si;
char *cp = (char *)pVM->pad;
si = vmGetWord(pVM);
if (SI_COUNT(si) > nPAD)
SI_SETLEN(si, nPAD);
strncpy(cp, SI_PTR(si), SI_COUNT(si));
cp[SI_COUNT(si)] = '\0';
return (int)(SI_COUNT(si));
}
/**************************************************************************
v m P a r s e S t r i n g
** Parses a string out of the input buffer using the delimiter
** specified. Skips leading delimiters, marks the start of the string,
** and counts characters to the next delimiter it encounters. It then
** updates the vm input buffer to consume all these chars, including the
** trailing delimiter.
** Returns the address and length of the parsed string, not including the
** trailing delimiter.
**************************************************************************/
STRINGINFO vmParseString(FICL_VM *pVM, char delim)
{
return vmParseStringEx(pVM, delim, 1);
}
STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
{
STRINGINFO si;
char *pSrc = vmGetInBuf(pVM);
char *pEnd = vmGetInBufEnd(pVM);
char ch;
if (fSkipLeading)
{ /* skip lead delimiters */
while ((pSrc != pEnd) && (*pSrc == delim))
pSrc++;
}
SI_SETPTR(si, pSrc); /* mark start of text */
for (ch = *pSrc; (pSrc != pEnd)
&& (ch != delim)
&& (ch != '\r')
&& (ch != '\n'); ch = *++pSrc)
{
; /* find next delimiter or end of line */
}
/* set length of result */
SI_SETLEN(si, pSrc - SI_PTR(si));
if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
return si;
}
/**************************************************************************
v m P o p
**
**************************************************************************/
CELL vmPop(FICL_VM *pVM)
{
return stackPop(pVM->pStack);
}
/**************************************************************************
v m P u s h
**
**************************************************************************/
void vmPush(FICL_VM *pVM, CELL c)
{
stackPush(pVM->pStack, c);
return;
}
/**************************************************************************
v m P o p I P
**
**************************************************************************/
void vmPopIP(FICL_VM *pVM)
{
pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
return;
}
/**************************************************************************
v m P u s h I P
**
**************************************************************************/
void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
{
stackPushPtr(pVM->rStack, (void *)pVM->ip);
pVM->ip = newIP;
return;
}
/**************************************************************************
v m P u s h T i b
** Binds the specified input string to the VM and clears >IN (the index)
**************************************************************************/
void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib)
{
if (pSaveTib)
{
*pSaveTib = pVM->tib;
}
pVM->tib.cp = text;
pVM->tib.end = text + nChars;
pVM->tib.index = 0;
}
void vmPopTib(FICL_VM *pVM, TIB *pTib)
{
if (pTib)
{
pVM->tib = *pTib;
}
return;
}
/**************************************************************************
v m Q u i t
**
**************************************************************************/
void vmQuit(FICL_VM *pVM)
{
stackReset(pVM->rStack);
pVM->fRestart = 0;
pVM->ip = NULL;
pVM->runningWord = NULL;
pVM->state = INTERPRET;
pVM->tib.cp = NULL;
pVM->tib.end = NULL;
pVM->tib.index = 0;
pVM->pad[0] = '\0';
pVM->sourceID.i = 0;
return;
}
/**************************************************************************
v m R e s e t
**
**************************************************************************/
void vmReset(FICL_VM *pVM)
{
vmQuit(pVM);
stackReset(pVM->pStack);
#if FICL_WANT_FLOAT
stackReset(pVM->fStack);
#endif
pVM->base = 10;
return;
}
/**************************************************************************
v m S e t T e x t O u t
** Binds the specified output callback to the vm. If you pass NULL,
** binds the default output function (ficlTextOut)
**************************************************************************/
void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut)
{
if (textOut)
pVM->textOut = textOut;
else
pVM->textOut = ficlTextOut;
return;
}
/**************************************************************************
v m T e x t O u t
** Feeds text to the vm's output callback
**************************************************************************/
void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
{
assert(pVM);
assert(pVM->textOut);
(pVM->textOut)(pVM, text, fNewline);
return;
}
/**************************************************************************
v m T h r o w
**
**************************************************************************/
void vmThrow(FICL_VM *pVM, int except)
{
if (pVM->pState)
longjmp(*(pVM->pState), except);
}
void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
{
va_list va;
va_start(va, fmt);
vsprintf(pVM->pad, fmt, va);
vmTextOut(pVM, pVM->pad, 1);
va_end(va);
longjmp(*(pVM->pState), VM_ERREXIT);
}
/**************************************************************************
w o r d I s I m m e d i a t e
**
**************************************************************************/
int wordIsImmediate(FICL_WORD *pFW)
{
return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
}
/**************************************************************************
w o r d I s C o m p i l e O n l y
**
**************************************************************************/
int wordIsCompileOnly(FICL_WORD *pFW)
{
return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
}
/**************************************************************************
s t r r e v
**
**************************************************************************/
char *strrev( char *string )
{ /* reverse a string in-place */
int i = strlen(string);
char *p1 = string; /* first char of string */
char *p2 = string + i - 1; /* last non-NULL char of string */
char c;
if (i > 1)
{
while (p1 < p2)
{
c = *p2;
*p2 = *p1;
*p1 = c;
p1++; p2--;
}
}
return string;
}
/**************************************************************************
d i g i t _ t o _ c h a r
**
**************************************************************************/
char digit_to_char(int value)
{
return digits[value];
}
/**************************************************************************
i s P o w e r O f T w o
** Tests whether supplied argument is an integer power of 2 (2**n)
** where 32 > n > 1, and returns n if so. Otherwise returns zero.
**************************************************************************/
int isPowerOfTwo(FICL_UNS u)
{
int i = 1;
FICL_UNS t = 2;
for (; ((t <= u) && (t != 0)); i++, t <<= 1)
{
if (u == t)
return i;
}
return 0;
}
/**************************************************************************
l t o a
**
**************************************************************************/
char *ltoa( FICL_INT value, char *string, int radix )
{ /* convert long to string, any base */
char *cp = string;
int sign = ((radix == 10) && (value < 0));
int pwr;
assert(radix > 1);
assert(radix < 37);
assert(string);
pwr = isPowerOfTwo((FICL_UNS)radix);
if (sign)
value = -value;
if (value == 0)
*cp++ = '0';
else if (pwr != 0)
{
FICL_UNS v = (FICL_UNS) value;
FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
while (v)
{
*cp++ = digits[v & mask];
v >>= pwr;
}
}
else
{
UNSQR result;
DPUNS v;
v.hi = 0;
v.lo = (FICL_UNS)value;
while (v.lo)
{
result = ficlLongDiv(v, (FICL_UNS)radix);
*cp++ = digits[result.rem];
v.lo = result.quot;
}
}
if (sign)
*cp++ = '-';
*cp++ = '\0';
return strrev(string);
}
/**************************************************************************
u l t o a
**
**************************************************************************/
char *ultoa(FICL_UNS value, char *string, int radix )
{ /* convert long to string, any base */
char *cp = string;
DPUNS ud;
UNSQR result;
assert(radix > 1);
assert(radix < 37);
assert(string);
if (value == 0)
*cp++ = '0';
else
{
ud.hi = 0;
ud.lo = value;
result.quot = value;
while (ud.lo)
{
result = ficlLongDiv(ud, (FICL_UNS)radix);
ud.lo = result.quot;
*cp++ = digits[result.rem];
}
}
*cp++ = '\0';
return strrev(string);
}
/**************************************************************************
c a s e F o l d
** Case folds a NULL terminated string in place. All characters
** get converted to lower case.
**************************************************************************/
char *caseFold(char *cp)
{
char *oldCp = cp;
while (*cp)
{
if (isupper(*cp))
*cp = (char)tolower(*cp);
cp++;
}
return oldCp;
}
/**************************************************************************
s t r i n c m p
** (jws) simplified the code a bit in hopes of appeasing Purify
**************************************************************************/
int strincmp(char *cp1, char *cp2, FICL_UNS count)
{
int i = 0;
for (; 0 < count; ++cp1, ++cp2, --count)
{
i = tolower(*cp1) - tolower(*cp2);
if (i != 0)
return i;
else if (*cp1 == '\0')
return 0;
}
return 0;
}
/**************************************************************************
s k i p S p a c e
** Given a string pointer, returns a pointer to the first non-space
** char of the string, or to the NULL terminator if no such char found.
** If the pointer reaches "end" first, stop there. Pass NULL to
** suppress this behavior.
**************************************************************************/
char *skipSpace(char *cp, char *end)
{
assert(cp);
while ((cp != end) && isspace(*cp))
cp++;
return cp;
}