/**************************************************************************
s e a r c h - w o r d l i s t
** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
** Find the definition identified by the string c-addr u in the word list
** identified by wid. If the definition is not found, return zero. If the
** definition is found, return its execution token xt and one (1) if the
** definition is immediate, minus-one (-1) otherwise.
**************************************************************************/
static void searchWordlist(FICL_VM *pVM)
{
STRINGINFO si;
UNS16 hashCode;
FICL_WORD *pFW;
FICL_HASH *pHash = stackPopPtr(pVM->pStack);
si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
si.cp = stackPopPtr(pVM->pStack);
hashCode = hashHashCode(si);
ficlLockDictionary(TRUE);
pFW = hashLookup(pHash, si, hashCode);
ficlLockDictionary(FALSE);
if (pFW)
{
stackPushPtr(pVM->pStack, pFW);
stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
}
else
{
stackPushUNS(pVM->pStack, 0);
}
return;
}
static void ficlWriteFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
int length = stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
clearerr(ff->f);
fwrite(address, 1, length, ff->f);
pushIor(pVM, ferror(ff->f) == 0);
}
static void ficlWriteLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
size_t length = (size_t)stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
clearerr(ff->f);
if (fwrite(address, 1, length, ff->f) == length)
fwrite("\n", 1, 1, ff->f);
pushIor(pVM, ferror(ff->f) == 0);
}
/**************************************************************************
setParentWid
** FICL
** setparentwid ( parent-wid wid -- )
** Set WID's link field to the parent-wid. search-wordlist will
** iterate through all the links when finding words in the child wid.
**************************************************************************/
static void setParentWid(FICL_VM *pVM)
{
FICL_HASH *parent, *child;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 2, 0);
#endif
child = (FICL_HASH *)stackPopPtr(pVM->pStack);
parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
child->link = parent;
return;
}
static void ficlReadFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
int length = stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
int result;
clearerr(ff->f);
result = fread(address, 1, length, ff->f);
stackPushINT(pVM->pStack, result);
pushIor(pVM, ferror(ff->f) == 0);
}
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;
}
void
ficlUuidToString(FICL_VM *pVM)
{
#ifndef TESTMAIN
char *uuid;
uint32_t status;
#endif
uuid_t *u;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
u = (uuid_t *)stackPopPtr(pVM->pStack);
#ifndef TESTMAIN
uuid_to_string(u, &uuid, &status);
if (status != uuid_s_ok) {
stackPushPtr(pVM->pStack, uuid);
stackPushINT(pVM->pStack, strlen(uuid));
} else
#endif
stackPushINT(pVM->pStack, -1);
return;
}
/**************************************************************************
f i c l D e b u g X T
** debug ( xt -- )
** Given an xt of a colon definition or a word defined by DOES>, set the
** VM up to debug the word: push IP, set the xt as the next thing to execute,
** set a breakpoint at its first instruction, and run to the breakpoint.
** Note: the semantics of this word are equivalent to "step in"
**************************************************************************/
void ficlDebugXT(FICL_VM *pVM)
{
FICL_WORD *xt = stackPopPtr(pVM->pStack);
WORDKIND wk = ficlWordClassify(xt);
stackPushPtr(pVM->pStack, xt);
seeXT(pVM);
switch (wk)
{
case COLON:
case DOES:
/*
** Run the colon code and set a breakpoint at the next instruction
*/
vmExecute(pVM, xt);
vmSetBreak(pVM, &(pVM->pSys->bpStep));
break;
default:
vmExecute(pVM, xt);
break;
}
return;
}
void
ficlCcall(FICL_VM *pVM)
{
int (*func)(int, ...);
int result, p[10];
int nparam, i;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 2, 0);
#endif
func = stackPopPtr(pVM->pStack);
nparam = stackPopINT(pVM->pStack);
#if FICL_ROBUST > 1
vmCheckStack(pVM, nparam, 1);
#endif
for (i = 0; i < nparam; i++)
p[i] = stackPopINT(pVM->pStack);
result = func(p[0], p[1], p[2], p[3], p[4], p[5], p[6], p[7], p[8],
p[9]);
stackPushINT(pVM->pStack, result);
return;
}
static void ficlFileSize(FICL_VM *pVM) /* ( fileid -- ud ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
long ud = fileSize(ff->f);
stackPushINT(pVM->pStack, ud);
pushIor(pVM, ud != -1);
}
static void ficlRepositionFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
size_t ud = (size_t)stackPopINT(pVM->pStack);
pushIor(pVM, fseek(ff->f, ud, SEEK_SET) == 0);
}
static void ficlFileStatus(FICL_VM *pVM) /* ( c-addr u -- x ior ) */
{
struct stat statbuf;
int length = stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
char *filename = (char *)alloca(length + 1);
memcpy(filename, address, length);
filename[length] = 0;
if (stat(filename, &statbuf) == 0)
{
/*
** the "x" left on the stack is implementation-defined.
** I push the file's access mode (readable, writeable, is directory, etc)
** as defined by ANSI C.
*/
stackPushINT(pVM->pStack, statbuf.st_mode);
stackPushINT(pVM->pStack, 0);
}
else
{
stackPushINT(pVM->pStack, -1);
stackPushINT(pVM->pStack, ENOENT);
}
}
static void ficlResizeFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
size_t ud = (size_t)stackPopINT(pVM->pStack);
pushIor(pVM, ftruncate(fileno(ff->f), ud) == 0);
}
/* fopen - open a file and return new fd on stack.
*
* fopen ( ptr count mode -- fd )
*/
static void pfopen(FICL_VM *pVM)
{
int mode, fd, count;
char *ptr, *name;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 3, 1);
#endif
mode = stackPopINT(pVM->pStack); /* get mode */
count = stackPopINT(pVM->pStack); /* get count */
ptr = stackPopPtr(pVM->pStack); /* get ptr */
if ((count < 0) || (ptr == NULL)) {
stackPushINT(pVM->pStack, -1);
return;
}
/* ensure that the string is null terminated */
name = (char *)malloc(count+1);
bcopy(ptr,name,count);
name[count] = 0;
/* open the file */
fd = open(name, mode);
free(name);
stackPushINT(pVM->pStack, fd);
return;
}
/*
** Here's the outer part of the decompiler. It's
** just a big nested conditional that checks the
** CFA of the word to decompile for each kind of
** known word-builder code, and tries to do
** something appropriate. If the CFA is not recognized,
** just indicate that it is a primitive.
*/
static void seeXT(FICL_VM *pVM)
{
FICL_WORD *pFW;
WORDKIND kind;
pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
kind = ficlWordClassify(pFW);
switch (kind)
{
case COLON:
sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
vmTextOut(pVM, pVM->pad, 1);
seeColon(pVM, pFW->param);
break;
case DOES:
vmTextOut(pVM, "does>", 1);
seeColon(pVM, (CELL *)pFW->param->p);
break;
case CREATE:
vmTextOut(pVM, "create", 1);
break;
case VARIABLE:
sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
break;
#if FICL_WANT_USER
case USER:
sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
break;
#endif
case CONSTANT:
sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
default:
sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
vmTextOut(pVM, pVM->pad, 1);
break;
}
if (pFW->flags & FW_IMMEDIATE)
{
vmTextOut(pVM, "immediate", 1);
}
if (pFW->flags & FW_COMPILE)
{
vmTextOut(pVM, "compile-only", 1);
}
return;
}
/**************************************************************************
s e t - c u r r e n t
** SEARCH ( wid -- )
** Set the compilation word list to the word list identified by wid.
**************************************************************************/
static void setCurrent(FICL_VM *pVM)
{
FICL_HASH *pHash = stackPopPtr(pVM->pStack);
FICL_DICT *pDict = vmGetDict(pVM);
ficlLockDictionary(TRUE);
pDict->pCompile = pHash;
ficlLockDictionary(FALSE);
return;
}
static void ficlDeleteFile(FICL_VM *pVM) /* ( c-addr u -- ior ) */
{
int length = stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
char *filename = (char *)alloca(length + 1);
memcpy(filename, address, length);
filename[length] = 0;
pushIor(pVM, !unlink(filename));
}
static void execxt(FICL_VM *pVM)
{
FICL_WORD *pFW;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
pFW = stackPopPtr(pVM->pStack);
ficlExecXT(pVM, pFW);
return;
}
static void ficlRenameFile(FICL_VM *pVM) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
{
int length;
void *address;
char *from;
char *to;
length = stackPopINT(pVM->pStack);
address = (void *)stackPopPtr(pVM->pStack);
to = (char *)alloca(length + 1);
memcpy(to, address, length);
to[length] = 0;
length = stackPopINT(pVM->pStack);
address = (void *)stackPopPtr(pVM->pStack);
from = (char *)alloca(length + 1);
memcpy(from, address, length);
from[length] = 0;
pushIor(pVM, !rename(from, to));
}
/**************************************************************************
> 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;
}
static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
{
ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
int length = stackPopINT(pVM->pStack);
char *address = (char *)stackPopPtr(pVM->pStack);
int error;
int flag;
if (feof(ff->f))
{
stackPushINT(pVM->pStack, -1);
stackPushINT(pVM->pStack, 0);
stackPushINT(pVM->pStack, 0);
return;
}
clearerr(ff->f);
*address = 0;
fgets(address, length, ff->f);
error = ferror(ff->f);
if (error != 0)
{
stackPushINT(pVM->pStack, -1);
stackPushINT(pVM->pStack, 0);
stackPushINT(pVM->pStack, error);
return;
}
length = strlen(address);
flag = (length > 0);
if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
length--;
stackPushINT(pVM->pStack, length);
stackPushINT(pVM->pStack, flag);
stackPushINT(pVM->pStack, 0); /* ior */
}
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 ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
{
int fam = stackPopINT(pVM->pStack);
int length = stackPopINT(pVM->pStack);
void *address = (void *)stackPopPtr(pVM->pStack);
char mode[4];
FILE *f;
char *filename = (char *)alloca(length + 1);
memcpy(filename, address, length);
filename[length] = 0;
*mode = 0;
switch (FICL_FAM_OPEN_MODE(fam))
{
case 0:
stackPushPtr(pVM->pStack, NULL);
stackPushINT(pVM->pStack, EINVAL);
return;
case FICL_FAM_READ:
strcat(mode, "r");
break;
case FICL_FAM_WRITE:
strcat(mode, writeMode);
break;
case FICL_FAM_READ | FICL_FAM_WRITE:
strcat(mode, writeMode);
strcat(mode, "+");
break;
}
strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");
f = fopen(filename, mode);
if (f == NULL)
stackPushPtr(pVM->pStack, NULL);
else
{
ficlFILE *ff = (ficlFILE *)malloc(sizeof(ficlFILE));
strcpy(ff->filename, filename);
ff->f = f;
stackPushPtr(pVM->pStack, ff);
fseek(f, 0, SEEK_SET);
}
pushIor(pVM, f != NULL);
}
/* fwrite - write file contents
*
* fwrite ( fd buf nbytes -- nwritten )
*/
static void pfwrite(FICL_VM *pVM)
{
int fd, len;
char *buf;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 3, 1);
#endif
len = stackPopINT(pVM->pStack); /* get number of bytes to read */
buf = stackPopPtr(pVM->pStack); /* get buffer */
fd = stackPopINT(pVM->pStack); /* get fd */
if (len > 0 && buf && fd != -1)
stackPushINT(pVM->pStack, write(fd, buf, len));
else
stackPushINT(pVM->pStack, -1);
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;
}
void
ficlCopyout(FICL_VM *pVM)
{
void* dest;
vm_offset_t src;
size_t len;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 3, 0);
#endif
len = stackPopINT(pVM->pStack);
dest = stackPopPtr(pVM->pStack);
src = stackPopINT(pVM->pStack);
#ifndef TESTMAIN
archsw.arch_copyout(src, dest, len);
#endif
return;
}
void stackUnlink(FICL_STACK *pStack)
{
pStack->sp = pStack->pFrame;
pStack->pFrame = stackPopPtr(pStack);
return;
}