Ejemplo n.º 1
0
/**************************************************************************
                        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;
}
Ejemplo n.º 2
0
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);
}
Ejemplo n.º 3
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);
}
Ejemplo n.º 4
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;
}
Ejemplo n.º 5
0
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);
}
Ejemplo n.º 6
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;
}
Ejemplo n.º 7
0
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;
}
Ejemplo n.º 8
0
/**************************************************************************
                        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;
}
Ejemplo n.º 9
0
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;
}
Ejemplo n.º 10
0
/**************************************************************************
                        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;
}
Ejemplo n.º 11
0
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;
}
Ejemplo n.º 12
0
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);
}
Ejemplo n.º 13
0
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);
}
Ejemplo n.º 14
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);
    }
}
Ejemplo n.º 15
0
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);
}
Ejemplo n.º 16
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;
}
Ejemplo n.º 17
0
/*
** 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;
}
Ejemplo n.º 18
0
/**************************************************************************
                        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;
}
Ejemplo n.º 19
0
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));
}
Ejemplo n.º 20
0
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;
}
Ejemplo n.º 21
0
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));
}
Ejemplo n.º 22
0
/**************************************************************************
                        > 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;
}
Ejemplo n.º 23
0
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 */
}
Ejemplo n.º 24
0
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;
}
Ejemplo n.º 25
0
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;
}
Ejemplo n.º 26
0
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);
}
Ejemplo n.º 27
0
/*          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;
}
Ejemplo n.º 28
0
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;
}
Ejemplo n.º 29
0
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;
}
Ejemplo n.º 30
0
void stackUnlink(FICL_STACK *pStack)
{
    pStack->sp = pStack->pFrame;
    pStack->pFrame = stackPopPtr(pStack);
    return;
}