6a80a16d7d
Make TIB handling use buffer size to conform with ANS Forth. Add ANS MEMORY-ALLOC word set. See the PRs for extensive details. PR: kern/9412 kern/9442 kern/9514 Submitted by: PRs from Daniel Sobral <dcs@newsguy.com>
571 lines
15 KiB
C
571 lines
15 KiB
C
/*******************************************************************
|
|
** v m . c
|
|
** Forth Inspired Command Language - virtual machine methods
|
|
** Author: John Sadler (john_sadler@alum.mit.edu)
|
|
** Created: 19 July 1997
|
|
**
|
|
*******************************************************************/
|
|
/*
|
|
** 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.
|
|
*/
|
|
|
|
#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
|
|
**
|
|
**************************************************************************/
|
|
FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
|
|
{
|
|
if (pVM == NULL)
|
|
{
|
|
pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
|
|
pVM->pStack = NULL;
|
|
pVM->rStack = NULL;
|
|
pVM->link = NULL;
|
|
}
|
|
assert (pVM);
|
|
|
|
if (pVM->pStack)
|
|
stackDelete(pVM->pStack);
|
|
pVM->pStack = stackCreate(nPStack);
|
|
|
|
if (pVM->rStack)
|
|
stackDelete(pVM->rStack);
|
|
pVM->rStack = stackCreate(nRStack);
|
|
|
|
pVM->textOut = ficlTextOut;
|
|
|
|
vmReset(pVM);
|
|
return pVM;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
v m D e l e t e
|
|
**
|
|
**************************************************************************/
|
|
void vmDelete (FICL_VM *pVM)
|
|
{
|
|
if (pVM)
|
|
{
|
|
ficlFree(pVM->pStack);
|
|
ficlFree(pVM->rStack);
|
|
ficlFree(pVM);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
v m E x e c u t e
|
|
**
|
|
**************************************************************************/
|
|
void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
|
|
{
|
|
pVM->runningWord = pWord;
|
|
pWord->code(pVM);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
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 = vmParseString(pVM, delimiter);
|
|
|
|
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);
|
|
STRINGINFO si;
|
|
UNS32 count = 0;
|
|
char ch;
|
|
|
|
pSrc = skipSpace(pSrc,pVM->tib.end);
|
|
SI_SETPTR(si, pSrc);
|
|
|
|
for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc)
|
|
{
|
|
count++;
|
|
}
|
|
|
|
SI_SETLEN(si, count);
|
|
|
|
if ((pVM->tib.end != 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 vmGetWord0 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 = vmGetWord0(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)
|
|
{
|
|
STRINGINFO si;
|
|
char *pSrc = vmGetInBuf(pVM);
|
|
char ch;
|
|
|
|
while ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* skip lead delimiters */
|
|
pSrc++;
|
|
|
|
SI_SETPTR(si, pSrc); /* mark start of text */
|
|
|
|
for (ch = *pSrc; (pVM->tib.end != pSrc)
|
|
&& (ch != delim)
|
|
&& (ch != '\0')
|
|
&& (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 ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
|
|
pSrc++;
|
|
|
|
vmUpdateTib(pVM, pSrc);
|
|
return si;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
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, INT32 size, TIB *pSaveTib)
|
|
{
|
|
if (pSaveTib)
|
|
{
|
|
*pSaveTib = pVM->tib;
|
|
}
|
|
|
|
pVM->tib.cp = text;
|
|
pVM->tib.end = text + size;
|
|
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)
|
|
{
|
|
static FICL_WORD *pInterp = NULL;
|
|
if (!pInterp)
|
|
pInterp = ficlLookup("interpret");
|
|
assert(pInterp);
|
|
|
|
stackReset(pVM->rStack);
|
|
pVM->fRestart = 0;
|
|
pVM->ip = &pInterp;
|
|
pVM->runningWord = pInterp;
|
|
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);
|
|
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)
|
|
{
|
|
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];
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
l t o a
|
|
**
|
|
**************************************************************************/
|
|
char *ltoa( INT32 value, char *string, int radix )
|
|
{ /* convert long to string, any base */
|
|
char *cp = string;
|
|
int sign = ((radix == 10) && (value < 0));
|
|
UNSQR result;
|
|
UNS64 v;
|
|
|
|
assert(radix > 1);
|
|
assert(radix < 37);
|
|
assert(string);
|
|
|
|
if (sign)
|
|
value = -value;
|
|
|
|
if (value == 0)
|
|
*cp++ = '0';
|
|
else
|
|
{
|
|
v.hi = 0;
|
|
v.lo = (UNS32)value;
|
|
while (v.lo)
|
|
{
|
|
result = ficlLongDiv(v, (UNS32)radix);
|
|
*cp++ = digits[result.rem];
|
|
v.lo = result.quot;
|
|
}
|
|
}
|
|
|
|
if (sign)
|
|
*cp++ = '-';
|
|
|
|
*cp++ = '\0';
|
|
|
|
return strrev(string);
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
u l t o a
|
|
**
|
|
**************************************************************************/
|
|
char *ultoa(UNS32 value, char *string, int radix )
|
|
{ /* convert long to string, any base */
|
|
char *cp = string;
|
|
UNS64 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, (UNS32)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
|
|
**
|
|
**************************************************************************/
|
|
int strincmp(char *cp1, char *cp2, FICL_COUNT count)
|
|
{
|
|
int i = 0;
|
|
char c1, c2;
|
|
|
|
for (c1 = *cp1, c2 = *cp2;
|
|
((i == 0) && count && c1 && c2);
|
|
c1 = *++cp1, c2 = *++cp2, count--)
|
|
{
|
|
i = tolower(c1) - tolower(c2);
|
|
}
|
|
|
|
return i;
|
|
}
|
|
|
|
|
|
|
|
/**************************************************************************
|
|
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. If you don't want
|
|
** that, pass NULL.
|
|
**************************************************************************/
|
|
char *skipSpace(char *cp, char *end)
|
|
{
|
|
assert(cp);
|
|
|
|
while ((cp != end) && isspace(*cp))
|
|
cp++;
|
|
|
|
return cp;
|
|
}
|
|
|
|
|