/**************************************************************************
d i c t C h e c k
** Checks the dictionary for corruption and throws appropriate
** errors.
** Input: +n number of ADDRESS UNITS (not Cells) proposed to allot
** -n number of ADDRESS UNITS proposed to de-allot
** 0 just do a consistency check
**************************************************************************/
void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n)
{
if ((n >= 0) && (dictCellsAvail(pDict) * (int)sizeof(CELL) < n))
{
vmThrowErr(pVM, "Error: dictionary full");
}
if ((n <= 0) && (dictCellsUsed(pDict) * (int)sizeof(CELL) < -n))
{
vmThrowErr(pVM, "Error: dictionary underflow");
}
if (pDict->nLists > FICL_DEFAULT_VOCS)
{
dictResetSearchOrder(pDict);
vmThrowErr(pVM, "Error: search order overflow");
}
else if (pDict->nLists < 0)
{
dictResetSearchOrder(pDict);
vmThrowErr(pVM, "Error: search order underflow");
}
return;
}
void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells)
{
FICL_STACK *fStack = pVM->fStack;
int nFree = fStack->base + fStack->nCells - fStack->sp;
if (popCells > STKDEPTH(fStack))
{
vmThrowErr(pVM, "Error: float stack underflow");
}
if (nFree < pushCells - popCells)
{
vmThrowErr(pVM, "Error: float stack overflow");
}
}
void
ficlUnsetenv(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *name;
#endif
char *namep;
int names;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 2, 0);
#endif
names = stackPopINT(pVM->pStack);
namep = (char*) stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
name = (char*) ficlMalloc(names+1);
if (!name)
vmThrowErr(pVM, "Error: out of memory");
strncpy(name, namep, names);
name[names] = '\0';
unsetenv(name);
ficlFree(name);
#endif
return;
}
void
ficlGetenv(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *name;
#endif
char *namep, *value;
int names;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 2, 2);
#endif
names = stackPopINT(pVM->pStack);
namep = (char*) stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
name = (char*) ficlMalloc(names+1);
if (!name)
vmThrowErr(pVM, "Error: out of memory");
strncpy(name, namep, names);
name[names] = '\0';
value = getenv(name);
ficlFree(name);
if(value != NULL) {
stackPushPtr(pVM->pStack, value);
stackPushINT(pVM->pStack, strlen(value));
} else
#endif
stackPushINT(pVM->pStack, -1);
return;
}
/**************************************************************************
s e t - o r d e r
** SEARCH ( widn ... wid1 n -- )
** Set the search order to the word lists identified by widn ... wid1.
** Subsequently, word list wid1 will be searched first, and word list
** widn searched last. If n is zero, empty the search order. If n is minus
** one, set the search order to the implementation-defined minimum
** search order. The minimum search order shall include the words
** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
** be at least eight.
**************************************************************************/
static void setOrder(FICL_VM *pVM)
{
int i;
int nLists = stackPopINT(pVM->pStack);
FICL_DICT *dp = vmGetDict(pVM);
if (nLists > FICL_DEFAULT_VOCS)
{
vmThrowErr(pVM, "set-order error: list would be too large");
}
ficlLockDictionary(TRUE);
if (nLists >= 0)
{
dp->nLists = nLists;
for (i = nLists-1; i >= 0; --i)
{
dp->pSearch[i] = stackPopPtr(pVM->pStack);
}
}
else
{
dictResetSearchOrder(dp);
}
ficlLockDictionary(FALSE);
return;
}
/*******************************************************************
v m C h e c k S t a c k
** Check the parameter stack for underflow or overflow.
** nCells controls the type of check: if nCells is zero,
** the function checks the stack state for underflow and overflow.
** If nCells > 0, checks to see that the stack has room to push
** that many cells. If less than zero, checks to see that the
** stack has room to pop that many cells. If any test fails,
** the function throws (via vmThrow) a VM_ERREXIT exception.
*******************************************************************/
void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells)
{
FICL_STACK *pStack = pVM->pStack;
int nFree = pStack->base + pStack->nCells - pStack->sp;
if (popCells > STKDEPTH(pStack))
{
vmThrowErr(pVM, "Error: stack underflow");
}
if (nFree < pushCells - popCells)
{
vmThrowErr(pVM, "Error: stack overflow");
}
return;
}
/**************************************************************************
d e f i n i t i o n s
** SEARCH ( -- )
** Make the compilation word list the same as the first word list in the
** search order. Specifies that the names of subsequent definitions will
** be placed in the compilation word list. Subsequent changes in the search
** order will not affect the compilation word list.
**************************************************************************/
static void definitions(FICL_VM *pVM)
{
FICL_DICT *pDict = vmGetDict(pVM);
assert(pDict);
if (pDict->nLists < 1)
{
vmThrowErr(pVM, "DEFINITIONS error - empty search order");
}
pDict->pCompile = pDict->pSearch[pDict->nLists-1];
return;
}
/**************************************************************************
> S E A R C H
** ficl ( wid -- )
** Push wid onto the search order. Error if the search order is full.
**************************************************************************/
static void searchPush(FICL_VM *pVM)
{
FICL_DICT *dp = vmGetDict(pVM);
ficlLockDictionary(TRUE);
if (dp->nLists > FICL_DEFAULT_VOCS)
{
vmThrowErr(pVM, ">search error: search order overflow");
}
dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
ficlLockDictionary(FALSE);
return;
}
void
ficlFindfile(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *name;
#endif
char *type, *namep, *typep;
struct preloaded_file* fp;
int names, types;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 4, 1);
#endif
types = stackPopINT(pVM->pStack);
typep = (char*) stackPopPtr(pVM->pStack);
names = stackPopINT(pVM->pStack);
namep = (char*) stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
name = (char*) ficlMalloc(names+1);
if (!name)
vmThrowErr(pVM, "Error: out of memory");
strncpy(name, namep, names);
name[names] = '\0';
type = (char*) ficlMalloc(types+1);
if (!type)
vmThrowErr(pVM, "Error: out of memory");
strncpy(type, typep, types);
type[types] = '\0';
fp = file_findfile(name, type);
#else
fp = NULL;
#endif
stackPushPtr(pVM->pStack, fp);
return;
}
void
ficlSetenvq(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *name, *value;
#endif
char *namep, *valuep;
int names, values, overwrite;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 5, 0);
#endif
overwrite = stackPopINT(pVM->pStack);
names = stackPopINT(pVM->pStack);
namep = (char*) stackPopPtr(pVM->pStack);
values = stackPopINT(pVM->pStack);
valuep = (char*) stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
name = (char*) ficlMalloc(names+1);
if (!name)
vmThrowErr(pVM, "Error: out of memory");
strncpy(name, namep, names);
name[names] = '\0';
value = (char*) ficlMalloc(values+1);
if (!value)
vmThrowErr(pVM, "Error: out of memory");
strncpy(value, valuep, values);
value[values] = '\0';
setenv(name, value, overwrite);
ficlFree(name);
ficlFree(value);
#endif
return;
}
static void tempBase(FICL_VM *pVM, int base)
{
int oldbase = pVM->base;
STRINGINFO si = vmGetWord0(pVM);
pVM->base = base;
if (!ficlParseNumber(pVM, si))
{
int i = SI_COUNT(si);
vmThrowErr(pVM, "%.*s not recognized", i, SI_PTR(si));
}
pVM->base = oldbase;
return;
}
/**************************************************************************
S E A R C H >
** ficl ( -- wid )
** Pop wid off the search order. Error if the search order is empty
**************************************************************************/
static void searchPop(FICL_VM *pVM)
{
FICL_DICT *dp = vmGetDict(pVM);
int nLists;
ficlLockDictionary(TRUE);
nLists = dp->nLists;
if (nLists == 0)
{
vmThrowErr(pVM, "search> error: empty search order");
}
stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
ficlLockDictionary(FALSE);
return;
}
void
ficlUuidFromString(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *uuid;
uint32_t status;
#endif
char *uuidp;
int uuids;
uuid_t *u;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 2, 0);
#endif
uuids = stackPopINT(pVM->pStack);
uuidp = (char *) stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
uuid = (char *)ficlMalloc(uuids + 1);
if (!uuid)
vmThrowErr(pVM, "Error: out of memory");
strncpy(uuid, uuidp, uuids);
uuid[uuids] = '\0';
u = (uuid_t *)ficlMalloc(sizeof (*u));
uuid_from_string(uuid, u, &status);
ficlFree(uuid);
if (status != uuid_s_ok) {
ficlFree(u);
u = NULL;
}
#else
u = NULL;
#endif
stackPushPtr(pVM->pStack, u);
return;
}
static void ficlLoad(FICL_VM *pVM)
{
char cp[nLINEBUF];
char filename[nLINEBUF];
FICL_STRING *pFilename = (FICL_STRING *)filename;
int nLine = 0;
FILE *fp;
int result;
CELL id;
struct stat buf;
vmGetString(pVM, pFilename, '\n');
if (pFilename->count <= 0)
{
vmTextOut(pVM, "Warning (load): nothing happened", 1);
return;
}
/*
** get the file's size and make sure it exists
*/
result = stat( pFilename->text, &buf );
if (result != 0)
{
vmTextOut(pVM, "Unable to stat file: ", 0);
vmTextOut(pVM, pFilename->text, 1);
vmThrow(pVM, VM_QUIT);
}
fp = fopen(pFilename->text, "r");
if (!fp)
{
vmTextOut(pVM, "Unable to open file ", 0);
vmTextOut(pVM, pFilename->text, 1);
vmThrow(pVM, VM_QUIT);
}
id = pVM->sourceID;
pVM->sourceID.p = (void *)fp;
/* feed each line to ficlExec */
while (fgets(cp, nLINEBUF, fp))
{
int len = strlen(cp) - 1;
nLine++;
if (len <= 0)
continue;
result = ficlExecC(pVM, cp, len);
if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
{
pVM->sourceID = id;
fclose(fp);
vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
break;
}
}
/*
** Pass an empty line with SOURCE-ID == -1 to flush
** any pending REFILLs (as required by FILE wordset)
*/
pVM->sourceID.i = -1;
ficlExec(pVM, "");
pVM->sourceID = id;
fclose(fp);
/* handle "bye" in loaded files. --lch */
if (result == VM_USEREXIT)
vmThrow(pVM, VM_USEREXIT);
return;
}