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;
}
/* 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;
}
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;
}
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;
}
/* key - get a character from stdin
*
* key ( -- char )
*/
static void key(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
stackPushINT(pVM->pStack, getchar());
return;
}
/* seconds - gives number of seconds since beginning of time
*
* beginning of time is defined as:
*
* BTX - number of seconds since midnight
* FreeBSD - number of seconds since Jan 1 1970
*
* seconds ( -- u )
*/
static void pseconds(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM,0,1);
#endif
stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL));
return;
}
/*******************************************************************
** Floating point literal execution word.
*******************************************************************/
static void fliteralParen(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
PUSHFLOAT(*(float*)(pVM->ip));
vmBranchRelative(pVM, 1);
}
/*******************************************************************
** Do float stack depth.
** fdepth ( -- n )
*******************************************************************/
static void Fdepth(FICL_VM *pVM)
{
int i;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
i = stackDepth(pVM->fStack);
PUSHINT(i);
}
static void displayCellNoPad(FICL_VM *pVM)
{
CELL c;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
c = stackPop(pVM->pStack);
ltoa((c).i, pVM->pad, pVM->base);
vmTextOut(pVM, pVM->pad, 0);
return;
}
void
ficlPnphandlers(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
stackPushPtr(pVM->pStack, pnphandlers);
return;
}
/* fload - interpret file contents
*
* fload ( fd -- )
*/
static void pfload(FICL_VM *pVM)
{
int fd;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
fd = stackPopINT(pVM->pStack); /* get fd */
if (fd != -1)
ficlExecFD(pVM, fd);
return;
}
/* fclose - close a file who's fd is on stack.
*
* fclose ( fd -- )
*/
static void pfclose(FICL_VM *pVM)
{
int fd;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
fd = stackPopINT(pVM->pStack); /* get fd */
if (fd != -1)
close(fd);
return;
}
/**************************************************************************
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;
}
/* ms - wait at least that many milliseconds (FACILITY)
*
* ms ( u -- )
*
*/
static void ms(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM,1,0);
#endif
#ifdef TESTMAIN
usleep(stackPopUNS(pVM->pStack)*1000);
#else
delay(stackPopUNS(pVM->pStack)*1000);
#endif
return;
}
/*******************************************************************
** Do float 0> comparison r > 0.0.
** f0> ( r -- T/F )
*******************************************************************/
static void FzeroGreater(FICL_VM *pVM)
{
CELL c;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 1, 0);
vmCheckStack(pVM, 0, 1);
#endif
c.i = FICL_BOOL(POPFLOAT() > 0);
PUSH(c);
}
/*******************************************************************
** Get a floating point number from a variable.
** f@ ( n -- r )
*******************************************************************/
static void Ffetch(FICL_VM *pVM)
{
CELL *pCell;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 0, 1);
vmCheckStack(pVM, 1, 0);
#endif
pCell = (CELL *)POPPTR();
PUSHFLOAT(pCell->f);
}
/*******************************************************************
** Do float 0< comparison r < 0.0.
** f0< ( r -- T/F )
*******************************************************************/
static void FzeroLess(FICL_VM *pVM)
{
CELL c;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
#endif
c.i = FICL_BOOL(POPFLOAT() < 0);
PUSH(c);
}
/*******************************************************************
** Add a floating point number to contents of a variable.
** f+! ( r n -- )
*******************************************************************/
static void FplusStore(FICL_VM *pVM)
{
CELL *pCell;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
vmCheckFStack(pVM, 1, 0);
#endif
pCell = (CELL *)POPPTR();
pCell->f += POPFLOAT();
}
/*******************************************************************
** Do float to integer conversion.
** float>int ( r -- n )
*******************************************************************/
static void Ftoi(FICL_VM *pVM)
{
FICL_INT i;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
vmCheckFStack(pVM, 1, 0);
#endif
i = (FICL_INT)POPFLOAT();
PUSHINT(i);
}
/*******************************************************************
** Do integer to float conversion.
** int>float ( n -- r )
*******************************************************************/
static void itof(FICL_VM *pVM)
{
float f;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
vmCheckFStack(pVM, 0, 1);
#endif
f = (float)POPINT();
PUSHFLOAT(f);
}
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 ToF(FICL_VM *pVM)
{
CELL c;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 0, 1);
vmCheckStack(pVM, 1, 0);
#endif
c = stackPop(pVM->pStack);
stackPush(pVM->fStack, c);
return;
}
/*******************************************************************
** Do float > comparison r1 > r2.
** f> ( r1 r2 -- T/F )
*******************************************************************/
static void FisGreater(FICL_VM *pVM)
{
float x, y;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 2, 0);
vmCheckStack(pVM, 0, 1);
#endif
y = POPFLOAT();
x = POPFLOAT();
PUSHINT(FICL_BOOL(x > y));
}
/*******************************************************************
** Do float = comparison r1 = r2.
** f= ( r1 r2 -- T/F )
*******************************************************************/
static void FisEqual(FICL_VM *pVM)
{
float x, y;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 2, 0);
vmCheckStack(pVM, 0, 1);
#endif
x = POPFLOAT();
y = POPFLOAT();
PUSHINT(FICL_BOOL(x == y));
}
/* fseek - seek to a new position in a file
*
* fseek ( fd ofs whence -- pos )
*/
static void pfseek(FICL_VM *pVM)
{
int fd, pos, whence;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 3, 1);
#endif
whence = stackPopINT(pVM->pStack);
pos = stackPopINT(pVM->pStack);
fd = stackPopINT(pVM->pStack);
stackPushINT(pVM->pStack, lseek(fd, pos, whence));
return;
}
/*******************************************************************
** Do integer / float n / r.
** i/f ( n r -- r )
*******************************************************************/
static void idivf(FICL_VM *pVM)
{
FICL_FLOAT f;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 1,1);
vmCheckStack(pVM, 1, 0);
#endif
f = (FICL_FLOAT)POPINT();
f /= GETTOPF().f;
SETTOPF(f);
}
/* fkey - get a character from a file
*
* fkey ( file -- char )
*/
static void fkey(FICL_VM *pVM)
{
int i, fd;
char ch;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 1);
#endif
fd = stackPopINT(pVM->pStack);
i = read(fd, &ch, 1);
stackPushINT(pVM->pStack, i > 0 ? ch : -1);
return;
}
/* key? - check for a character from stdin (FACILITY)
*
* key? ( -- flag )
*/
static void keyQuestion(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
#ifdef TESTMAIN
/* XXX Since we don't fiddle with termios, let it always succeed... */
stackPushINT(pVM->pStack, FICL_TRUE);
#else
/* But here do the right thing. */
stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
#endif
return;
}
/**************************************************************************
f i c l - w o r d l i s t
** SEARCH ( -- wid )
** Create a new empty word list, returning its word list identifier wid.
** The new word list may be returned from a pool of preallocated word
** lists or may be dynamically allocated in data space. A system shall
** allow the creation of at least 8 new word lists in addition to any
** provided as part of the system.
** Notes:
** 1. ficl creates a new single-list hash in the dictionary and returns
** its address.
** 2. ficl-wordlist takes an arg off the stack indicating the number of
** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
** : wordlist 1 ficl-wordlist ;
**************************************************************************/
static void ficlWordlist(FICL_VM *pVM)
{
FICL_DICT *dp = vmGetDict(pVM);
FICL_HASH *pHash;
FICL_UNS nBuckets;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 1);
#endif
nBuckets = stackPopUNS(pVM->pStack);
pHash = dictCreateWordlist(dp, nBuckets);
stackPushPtr(pVM->pStack, pHash);
return;
}
