diff options
author | dcs <dcs@FreeBSD.org> | 2002-04-09 17:45:28 +0000 |
---|---|---|
committer | dcs <dcs@FreeBSD.org> | 2002-04-09 17:45:28 +0000 |
commit | eeb34873c0b41e7c8d88b1efdd247bad651b3129 (patch) | |
tree | 9dcaa6b46853d933617d5922244b7005f2893887 /sys/boot/ficl | |
parent | a9c8222534388beb14e2c054cf9b2fc1fe5e25fb (diff) | |
download | FreeBSD-src-eeb34873c0b41e7c8d88b1efdd247bad651b3129.zip FreeBSD-src-eeb34873c0b41e7c8d88b1efdd247bad651b3129.tar.gz |
Upgrade to FICL version 3.02. Anything wrong is my fault, everything right is
due Jon Mini.
PR: 36308
Submitted by: Jon Mini <mini@haikugeek.com>
MFC after: 4 weeks
Diffstat (limited to 'sys/boot/ficl')
27 files changed, 3925 insertions, 1275 deletions
diff --git a/sys/boot/ficl/Makefile b/sys/boot/ficl/Makefile index b80ff97..9825183 100644 --- a/sys/boot/ficl/Makefile +++ b/sys/boot/ficl/Makefile @@ -1,8 +1,9 @@ # $FreeBSD$ # .PATH: ${.CURDIR}/${MACHINE_ARCH} -BASE_SRCS= dict.c ficl.c math64.c search.c stack.c tools.c \ - prefix.c loader.c vm.c words.c +BASE_SRCS= dict.c ficl.c fileaccess.c float.c loader.c math64.c \ + prefix.c search.c stack.c tools.c vm.c words.c + SRCS= ${BASE_SRCS} sysdep.c softcore.c CLEANFILES= softcore.c testmain testmain.o .if ${MACHINE_ARCH} == "alpha" diff --git a/sys/boot/ficl/alpha/sysdep.h b/sys/boot/ficl/alpha/sysdep.h index 0a6ca33..a53d9c9 100644 --- a/sys/boot/ficl/alpha/sysdep.h +++ b/sys/boot/ficl/alpha/sysdep.h @@ -9,7 +9,7 @@ ** FICL_ROBUST is enabled. This may require some consideration ** in firmware systems since assert often ** assumes stderr/stdout. -** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ +** $Id: sysdep.h,v 1.11 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -17,6 +17,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -39,13 +44,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -75,7 +73,6 @@ #define FALSE 0 #endif - /* ** System dependent data type declarations... */ @@ -162,6 +159,7 @@ typedef struct #endif #if (FICL_MINIMAL) #define FICL_WANT_SOFTWORDS 0 +#define FICL_WANT_FILE 0 #define FICL_WANT_FLOAT 0 #define FICL_WANT_USER 0 #define FICL_WANT_LOCALS 0 @@ -181,6 +179,17 @@ typedef struct #define FICL_PLATFORM_EXTEND 1 #endif + +/* +** FICL_WANT_FILE +** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not +** have a file system! +** Contributed by Larry Hastings +*/ +#if !defined (FICL_WANT_FILE) +#define FICL_WANT_FILE 0 +#endif + /* ** FICL_WANT_FLOAT ** Includes a floating point stack for the VM, and words to do float operations. @@ -199,6 +208,14 @@ typedef struct #endif /* +** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if +** included as part of softcore.c) +*/ +#if !defined FICL_EXTENDED_PREFIX +#define FICL_EXTENDED_PREFIX 0 +#endif + +/* ** User variables: per-instance variables bound to the VM. ** Kinda like thread-local storage. Could be implemented in a ** VM private dictionary, but I've chosen the lower overhead @@ -341,14 +358,6 @@ typedef struct #endif /* -** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if -** included as part of softcore.c) -*/ -#if !defined FICL_EXTENDED_PREFIX -#define FICL_EXTENDED_PREFIX 0 -#endif - -/* ** FICL_ALIGN is the power of two to which the dictionary ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture @@ -409,4 +418,15 @@ int ficlLockDictionary(short fLock); DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); + +/* +** FICL_HAVE_FTRUNCATE indicates whether the current OS supports +** the ftruncate() function (available on most UNIXes). This +** function is necessary to provide the complete File-Access wordset. +*/ +#if !defined (FICL_HAVE_FTRUNCATE) +#define FICL_HAVE_FTRUNCATE 0 +#endif + + #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/dict.c b/sys/boot/ficl/dict.c index f5b9f15..b76d925 100644 --- a/sys/boot/ficl/dict.c +++ b/sys/boot/ficl/dict.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - dictionary methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: dict.c,v 1.6 2000-06-17 07:43:44-07 jsadler Exp jsadler $ +** $Id: dict.c,v 1.14 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** This file implements the dictionary -- FICL's model of @@ -22,6 +22,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -44,20 +49,12 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: dict.c,v 1.8 2001-04-26 21:41:45-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ #ifdef TESTMAIN #include <stdio.h> -#include <stdlib.h> #include <ctype.h> #else #include <stand.h> @@ -304,16 +301,19 @@ int dictCellsUsed(FICL_DICT *pDict) /************************************************************************** d i c t C h e c k ** Checks the dictionary for corruption and throws appropriate -** errors +** 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 nCells) +void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n) { - if ((nCells >= 0) && (dictCellsAvail(pDict) < nCells)) + if ((n >= 0) && (dictCellsAvail(pDict) * (int)sizeof(CELL) < n)) { vmThrowErr(pVM, "Error: dictionary full"); } - if ((nCells <= 0) && (dictCellsUsed(pDict) < -nCells)) + if ((n <= 0) && (dictCellsUsed(pDict) * (int)sizeof(CELL) < -n)) { vmThrowErr(pVM, "Error: dictionary underflow"); } @@ -396,6 +396,7 @@ FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash) memset(pDict, 0, sizeof (FICL_DICT)); pDict->dict = ficlMalloc(nAlloc); assert(pDict->dict); + pDict->size = nCells; dictEmpty(pDict, nHash); return pDict; @@ -460,6 +461,84 @@ void dictEmpty(FICL_DICT *pDict, unsigned nHash) /************************************************************************** + d i c t H a s h S u m m a r y +** Calculate a figure of merit for the dictionary hash table based +** on the average search depth for all the words in the dictionary, +** assuming uniform distribution of target keys. The figure of merit +** is the ratio of the total search depth for all keys in the table +** versus a theoretical optimum that would be achieved if the keys +** were distributed into the table as evenly as possible. +** The figure would be worse if the hash table used an open +** addressing scheme (i.e. collisions resolved by searching the +** table for an empty slot) for a given size table. +**************************************************************************/ +#if FICL_WANT_FLOAT +void dictHashSummary(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + FICL_HASH *pFHash; + FICL_WORD **pHash; + unsigned size; + FICL_WORD *pFW; + unsigned i; + int nMax = 0; + int nWords = 0; + int nFilled; + double avg = 0.0; + double best; + int nAvg, nRem, nDepth; + + dictCheck(dp, pVM, 0); + + pFHash = dp->pSearch[dp->nLists - 1]; + pHash = pFHash->table; + size = pFHash->size; + nFilled = size; + + for (i = 0; i < size; i++) + { + int n = 0; + pFW = pHash[i]; + + while (pFW) + { + ++n; + ++nWords; + pFW = pFW->link; + } + + avg += (double)(n * (n+1)) / 2.0; + + if (n > nMax) + nMax = n; + if (n == 0) + --nFilled; + } + + /* Calc actual avg search depth for this hash */ + avg = avg / nWords; + + /* Calc best possible performance with this size hash */ + nAvg = nWords / size; + nRem = nWords % size; + nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem; + best = (double)nDepth/nWords; + + sprintf(pVM->pad, + "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%", + size, + (double)nFilled * 100.0 / size, nMax, + avg, + best, + 100.0 * best / avg); + + ficlTextOut(pVM, pVM->pad, 1); + + return; +} +#endif + +/************************************************************************** d i c t I n c l u d e s ** Returns TRUE iff the given pointer is within the address range of ** the dictionary. @@ -471,7 +550,6 @@ int dictIncludes(FICL_DICT *pDict, void *p) ); } - /************************************************************************** d i c t L o o k u p ** Find the FICL_WORD that matches the given name and length. @@ -501,15 +579,16 @@ FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si) /************************************************************************** - d i c t L o o k u p L o c + f i c l L o o k u p L o c ** Same as dictLookup, but looks in system locals dictionary first... ** Assumes locals dictionary has only one wordlist... **************************************************************************/ #if FICL_WANT_LOCALS -FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si) +FICL_WORD *ficlLookupLoc(FICL_SYSTEM *pSys, STRINGINFO si) { FICL_WORD *pFW = NULL; - FICL_HASH *pHash = ficlGetLoc()->pForthWords; + FICL_DICT *pDict = pSys->dp; + FICL_HASH *pHash = ficlGetLoc(pSys)->pForthWords; int i; UNS16 hashCode = hashHashCode(si); diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c index d5ce084..d4370eb 100644 --- a/sys/boot/ficl/ficl.c +++ b/sys/boot/ficl/ficl.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - external interface ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: ficl.c,v 1.10 2001-04-26 21:41:42-07 jsadler Exp jsadler $ +** $Id: ficl.c,v 1.16 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** This is an ANS Forth interpreter written in C. @@ -26,6 +26,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -48,13 +53,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: ficl.c,v 1.10 2001-04-26 21:41:42-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -70,19 +68,19 @@ /* ** System statics -** The system builds a global dictionary during its start -** sequence. This is shared by all interpreter instances. -** Therefore only one instance can update the dictionary +** Each FICL_SYSTEM builds a global dictionary during its start +** sequence. This is shared by all virtual machines of that system. +** Therefore only one VM can update the dictionary ** at a time. The system imports a locking function that ** you can override in order to control update access to ** the dictionary. The function is stubbed out by default, ** but you can insert one: #define FICL_MULTITHREAD 1 ** and supply your own version of ficlLockDictionary. */ -static FICL_SYSTEM *pSys = NULL; - static int defaultStack = FICL_DEFAULT_STACK; -static int defaultDict = FICL_DEFAULT_DICT; + + +static void ficlSetVersionEnv(FICL_SYSTEM *pSys); /************************************************************************** @@ -96,67 +94,94 @@ static int defaultDict = FICL_DEFAULT_DICT; ** precompiled part. Try 1K cells minimum. Use "words" to find ** out how much of the dictionary is used at any time. **************************************************************************/ -void ficlInitSystem(int nDictCells) +FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi) { - pSys = ficlMalloc(sizeof (FICL_SYSTEM)); + int nDictCells; + int nEnvCells; + FICL_SYSTEM *pSys = ficlMalloc(sizeof (FICL_SYSTEM)); + assert(pSys); + assert(fsi->size == sizeof (FICL_SYSTEM_INFO)); memset(pSys, 0, sizeof (FICL_SYSTEM)); + nDictCells = fsi->nDictCells; if (nDictCells <= 0) - nDictCells = defaultDict; + nDictCells = FICL_DEFAULT_DICT; + + nEnvCells = fsi->nEnvCells; + if (nEnvCells <= 0) + nEnvCells = FICL_DEFAULT_DICT; pSys->dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE); pSys->dp->pForthWords->name = "forth-wordlist"; - pSys->envp = dictCreate((unsigned)FICL_DEFAULT_ENV); + pSys->envp = dictCreate((unsigned)nEnvCells); pSys->envp->pForthWords->name = "environment"; + pSys->textOut = fsi->textOut; + pSys->pExtend = fsi->pExtend; + #if FICL_WANT_LOCALS /* ** The locals dictionary is only searched while compiling, ** but this is where speed is most important. On the other ** hand, the dictionary gets emptied after each use of locals - ** The need to balance search speed with the cost of the empty + ** The need to balance search speed with the cost of the 'empty' ** operation led me to select a single-threaded list... */ pSys->localp = dictCreate((unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD); #endif /* - ** Establish the parse order. Note that prefixes precede numbers - - ** this allows constructs like "0b101010" which would parse as a - ** valid hex value otherwise. - */ - ficlCompilePrefix(pSys); - ficlAddPrecompiledParseStep(pSys, "number?", ficlParseNumber); - - /* ** Build the precompiled dictionary and load softwords. We need a temporary ** VM to do this - ficlNewVM links one to the head of the system VM list. ** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words. */ ficlCompileCore(pSys); + ficlCompilePrefix(pSys); #if FICL_WANT_FLOAT ficlCompileFloat(pSys); #endif - #if FICL_PLATFORM_EXTEND ficlCompilePlatform(pSys); #endif + ficlSetVersionEnv(pSys); + + /* + ** Establish the parse order. Note that prefixes precede numbers - + ** this allows constructs like "0b101010" which might parse as a + ** hex value otherwise. + */ + ficlAddPrecompiledParseStep(pSys, "?prefix", ficlParsePrefix); + ficlAddPrecompiledParseStep(pSys, "?number", ficlParseNumber); +#if FICL_WANT_FLOAT + ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber); +#endif /* - ** Now we can create a VM to compile the softwords. Note that the VM initialization - ** code needs to be able to find "interpret" in the dictionary in order to - ** succeed, so as presently constructed ficlCompileCore has to finish before - ** a VM can be created successfully. + ** Now create a temporary VM to compile the softwords. Since all VMs are + ** linked into the vmList of FICL_SYSTEM, we don't have to pass the VM + ** to ficlCompileSoftCore -- it just hijacks whatever it finds in the VM list. + ** ficl 2.05: vmCreate no longer depends on the presence of INTERPRET in the + ** dictionary, so a VM can be created before the dictionary is built. It just + ** can't do much... */ - ficlNewVM(); + ficlNewVM(pSys); ficlCompileSoftCore(pSys); ficlFreeVM(pSys->vmList); - return; + return pSys; +} + + +FICL_SYSTEM *ficlInitSystem(int nDictCells) +{ + FICL_SYSTEM_INFO fsi; + ficlInitInfo(&fsi); + fsi.nDictCells = nDictCells; + return ficlInitSystemEx(&fsi); } @@ -226,11 +251,13 @@ void ficlListParseSteps(FICL_VM *pVM) ** Create a new virtual machine and link it into the system list ** of VMs for later cleanup by ficlTermSystem. **************************************************************************/ -FICL_VM *ficlNewVM(void) +FICL_VM *ficlNewVM(FICL_SYSTEM *pSys) { FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack); pVM->link = pSys->vmList; pVM->pSys = pSys; + pVM->pExtend = pSys->pExtend; + vmSetTextOut(pVM, pSys->textOut); pSys->vmList = pVM; return pVM; @@ -246,6 +273,7 @@ FICL_VM *ficlNewVM(void) **************************************************************************/ void ficlFreeVM(FICL_VM *pVM) { + FICL_SYSTEM *pSys = pVM->pSys; FICL_VM *pList = pSys->vmList; assert(pVM != 0); @@ -284,10 +312,12 @@ void ficlFreeVM(FICL_VM *pVM) ** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR! ** **************************************************************************/ -int ficlBuild(char *name, FICL_CODE code, char flags) +int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags) { +#if FICL_MULTITHREAD int err = ficlLockDictionary(TRUE); if (err) return err; +#endif /* FICL_MULTITHREAD */ assert(dictCellsAvail(pSys->dp) > sizeof (FICL_WORD) / sizeof (CELL)); dictAppendWord(pSys->dp, name, code, flags); @@ -298,6 +328,21 @@ int ficlBuild(char *name, FICL_CODE code, char flags) /************************************************************************** + f i c l E v a l u a t e +** Wrapper for ficlExec() which sets SOURCE-ID to -1. +**************************************************************************/ +int ficlEvaluate(FICL_VM *pVM, char *pText) +{ + int returnValue; + CELL id = pVM->sourceID; + pVM->sourceID.i = -1; + returnValue = ficlExecC(pVM, pText, -1); + pVM->sourceID = id; + return returnValue; +} + + +/************************************************************************** f i c l E x e c ** Evaluates a block of input text in the context of the ** specified interpreter. Emits any requested output to the @@ -322,23 +367,16 @@ int ficlExec(FICL_VM *pVM, char *pText) int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) { - FICL_WORD **pInterp = pSys->pInterp; - FICL_DICT *dp = pSys->dp; + FICL_SYSTEM *pSys = pVM->pSys; + FICL_DICT *dp = pSys->dp; int except; jmp_buf vmState; jmp_buf *oldState; TIB saveTib; - if (!pInterp[0]) - { - pInterp[0] = ficlLookup("interpret"); - pInterp[1] = ficlLookup("(branch)"); - pInterp[2] = (FICL_WORD *)(void *)(-2); - } - - assert(pInterp[0]); assert(pVM); + assert(pSys->pInterp[0]); if (size < 0) size = strlen(pText); @@ -362,7 +400,7 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) } else { /* set VM up to interpret text */ - vmPushIP(pVM, &pInterp[0]); + vmPushIP(pVM, &(pSys->pInterp[0])); } vmInnerLoop(pVM); @@ -438,17 +476,13 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) **************************************************************************/ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) { - static FICL_WORD *pQuit = NULL; int except; jmp_buf vmState; jmp_buf *oldState; FICL_WORD *oldRunningWord; - if (!pQuit) - pQuit = ficlLookup("exit-inner"); - assert(pVM); - assert(pQuit); + assert(pVM->pSys->pExitInner); /* ** Save the runningword so that RESTART behaves correctly @@ -465,7 +499,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) if (except) vmPopIP(pVM); else - vmPushIP(pVM, &pQuit); + vmPushIP(pVM, &(pVM->pSys->pExitInner)); switch (except) { @@ -506,7 +540,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) ** found, return the address of the corresponding FICL_WORD. Otherwise ** return NULL. **************************************************************************/ -FICL_WORD *ficlLookup(char *name) +FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name) { STRINGINFO si; SI_PSZ(si, name); @@ -518,7 +552,7 @@ FICL_WORD *ficlLookup(char *name) f i c l G e t D i c t ** Returns the address of the system dictionary **************************************************************************/ -FICL_DICT *ficlGetDict(void) +FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys) { return pSys->dp; } @@ -528,7 +562,7 @@ FICL_DICT *ficlGetDict(void) f i c l G e t E n v ** Returns the address of the system environment space **************************************************************************/ -FICL_DICT *ficlGetEnv(void) +FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys) { return pSys->envp; } @@ -539,7 +573,7 @@ FICL_DICT *ficlGetEnv(void) ** Create an environment variable with a one-CELL payload. ficlSetEnvD ** makes one with a two-CELL payload. **************************************************************************/ -void ficlSetEnv(char *name, FICL_UNS value) +void ficlSetEnv(FICL_SYSTEM *pSys, char *name, FICL_UNS value) { STRINGINFO si; FICL_WORD *pFW; @@ -561,7 +595,7 @@ void ficlSetEnv(char *name, FICL_UNS value) return; } -void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) +void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo) { FICL_WORD *pFW; STRINGINFO si; @@ -591,7 +625,7 @@ void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) ** only used during compilation, and is shared by all VMs. **************************************************************************/ #if FICL_WANT_LOCALS -FICL_DICT *ficlGetLoc(void) +FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys) { return pSys->localp; } @@ -620,7 +654,7 @@ int ficlSetStackSize(int nStackCells) ** Tear the system down by deleting the dictionaries and all VMs. ** This saves you from having to keep track of all that stuff. **************************************************************************/ -void ficlTermSystem(void) +void ficlTermSystem(FICL_SYSTEM *pSys) { if (pSys->dp) dictDelete(pSys->dp); @@ -649,3 +683,14 @@ void ficlTermSystem(void) } +/************************************************************************** + f i c l S e t V e r s i o n E n v +** Create a double cell environment constant for the version ID +**************************************************************************/ +static void ficlSetVersionEnv(FICL_SYSTEM *pSys) +{ + ficlSetEnvD(pSys, "ficl-version", FICL_VER_MAJOR, FICL_VER_MINOR); + ficlSetEnv (pSys, "ficl-robust", FICL_ROBUST); + return; +} + diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h index b0ee3b2..98d56a5 100644 --- a/sys/boot/ficl/ficl.h +++ b/sys/boot/ficl/ficl.h @@ -3,7 +3,8 @@ ** Forth Inspired Command Language ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: ficl.h,v 1.11 2001-04-26 21:41:48-07 jsadler Exp jsadler $ +** Dedicated to RHS, in loving memory +** $Id: ficl.h,v 1.18 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -11,6 +12,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -33,13 +39,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: ficl.h,v 1.11 2001-04-26 21:41:48-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -125,17 +124,14 @@ ** T o D o L i s t ** ** 1. Unimplemented system dependent CORE word: key -** 2. Kludged CORE word: ACCEPT -** 3. Dictionary locking is full of holes - only one vm at a time -** can alter the dict. -** 4. Ficl uses the pad in CORE words - this violates the standard, +** 2. Ficl uses the PAD in some CORE words - this violates the standard, ** but it's cleaner for a multithreaded system. I'll have to make a ** second pad for reference by the word PAD to fix this. ** ** F o r M o r e I n f o r m a t i o n ** ** Web home of ficl -** http://www.taygeta.com/forth/compilers +** http://ficl.sourceforge.net ** Check this website for Forth literature (including the ANSI standard) ** http://www.taygeta.com/forthlit.html ** and here for software and more links @@ -154,7 +150,7 @@ ** - Make the main hash table a bigger prime (HASHSIZE) ** - FORGET about twiddling the hash function - my experience is ** that that is a waste of time. -** - eliminate the need to pass the pVM parameter on the stack +** - Eliminate the need to pass the pVM parameter on the stack ** by dedicating a register to it. Most words need access to the ** vm, but the parameter passing overhead can be reduced. One way ** requires that the host OS have a task switch callout. Create @@ -228,15 +224,22 @@ extern "C" { ** Forward declarations... read on. */ struct ficl_word; +typedef struct ficl_word FICL_WORD; struct vm; +typedef struct vm FICL_VM; struct ficl_dict; +typedef struct ficl_dict FICL_DICT; struct ficl_system; typedef struct ficl_system FICL_SYSTEM; +struct ficl_system_info; +typedef struct ficl_system_info FICL_SYSTEM_INFO; /* ** the Good Stuff starts here... */ -#define FICL_VER "2.05" +#define FICL_VER "3.02" +#define FICL_VER_MAJOR 3 +#define FICL_VER_MINOR 2 #if !defined (FICL_PROMPT) #define FICL_PROMPT "ok> " #endif @@ -254,7 +257,8 @@ typedef struct ficl_system FICL_SYSTEM; /* ** A CELL is the main storage type. It must be large enough ** to contain a pointer or a scalar. In order to accommodate -** 32 bit and 64 bit processors, use abstract types for i and u. +** 32 bit and 64 bit processors, use abstract types for int, +** unsigned, and float. */ typedef union _cell { @@ -268,7 +272,7 @@ typedef union _cell } CELL; /* -** LVALUEtoCELL does a little pointer trickery to cast any 32 bit +** LVALUEtoCELL does a little pointer trickery to cast any CELL sized ** lvalue (informal definition: an expression whose result has an ** address) to CELL. Remember that constants and casts are NOT ** themselves lvalues! @@ -363,59 +367,59 @@ typedef struct _ficlStack /* ** Stack methods... many map closely to required Forth words. */ -FICL_STACK *stackCreate(unsigned nCells); -void stackDelete(FICL_STACK *pStack); -int stackDepth (FICL_STACK *pStack); -void stackDrop (FICL_STACK *pStack, int n); -CELL stackFetch (FICL_STACK *pStack, int n); -CELL stackGetTop(FICL_STACK *pStack); -void stackLink (FICL_STACK *pStack, int nCells); -void stackPick (FICL_STACK *pStack, int n); -CELL stackPop (FICL_STACK *pStack); -void *stackPopPtr(FICL_STACK *pStack); -FICL_UNS stackPopUNS(FICL_STACK *pStack); -FICL_INT stackPopINT(FICL_STACK *pStack); -void stackPush (FICL_STACK *pStack, CELL c); +FICL_STACK *stackCreate (unsigned nCells); +void stackDelete (FICL_STACK *pStack); +int stackDepth (FICL_STACK *pStack); +void stackDrop (FICL_STACK *pStack, int n); +CELL stackFetch (FICL_STACK *pStack, int n); +CELL stackGetTop (FICL_STACK *pStack); +void stackLink (FICL_STACK *pStack, int nCells); +void stackPick (FICL_STACK *pStack, int n); +CELL stackPop (FICL_STACK *pStack); +void *stackPopPtr (FICL_STACK *pStack); +FICL_UNS stackPopUNS (FICL_STACK *pStack); +FICL_INT stackPopINT (FICL_STACK *pStack); +void stackPush (FICL_STACK *pStack, CELL c); void stackPushPtr (FICL_STACK *pStack, void *ptr); -void stackPushUNS(FICL_STACK *pStack, FICL_UNS u); -void stackPushINT(FICL_STACK *pStack, FICL_INT i); -void stackReset (FICL_STACK *pStack); -void stackRoll (FICL_STACK *pStack, int n); -void stackSetTop(FICL_STACK *pStack, CELL c); -void stackStore (FICL_STACK *pStack, int n, CELL c); -void stackUnlink(FICL_STACK *pStack); +void stackPushUNS (FICL_STACK *pStack, FICL_UNS u); +void stackPushINT (FICL_STACK *pStack, FICL_INT i); +void stackReset (FICL_STACK *pStack); +void stackRoll (FICL_STACK *pStack, int n); +void stackSetTop (FICL_STACK *pStack, CELL c); +void stackStore (FICL_STACK *pStack, int n, CELL c); +void stackUnlink (FICL_STACK *pStack); #if (FICL_WANT_FLOAT) float stackPopFloat (FICL_STACK *pStack); -void stackPushFloat(FICL_STACK *pStack, float f); +void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f); #endif /* ** Shortcuts (Guy Carver) */ -#define PUSHPTR(p) stackPushPtr(pVM->pStack,p) -#define PUSHUNS(u) stackPushUNS(pVM->pStack,u) -#define PUSHINT(i) stackPushINT(pVM->pStack,i) -#define PUSHFLOAT(f) stackPushFloat(pVM->fStack,f) -#define PUSH(c) stackPush(pVM->pStack,c) -#define POPPTR() stackPopPtr(pVM->pStack) -#define POPUNS() stackPopUNS(pVM->pStack) -#define POPINT() stackPopINT(pVM->pStack) -#define POPFLOAT() stackPopFloat(pVM->fStack) -#define POP() stackPop(pVM->pStack) -#define GETTOP() stackGetTop(pVM->pStack) -#define SETTOP(c) stackSetTop(pVM->pStack,LVALUEtoCELL(c)) -#define GETTOPF() stackGetTop(pVM->fStack) -#define SETTOPF(c) stackSetTop(pVM->fStack,LVALUEtoCELL(c)) -#define STORE(n,c) stackStore(pVM->pStack,n,LVALUEtoCELL(c)) -#define DEPTH() stackDepth(pVM->pStack) -#define DROP(n) stackDrop(pVM->pStack,n) -#define DROPF(n) stackDrop(pVM->fStack,n) -#define FETCH(n) stackFetch(pVM->pStack,n) -#define PICK(n) stackPick(pVM->pStack,n) -#define PICKF(n) stackPick(pVM->fStack,n) -#define ROLL(n) stackRoll(pVM->pStack,n) -#define ROLLF(n) stackRoll(pVM->fStack,n) +#define PUSHPTR(p) stackPushPtr(pVM->pStack,p) +#define PUSHUNS(u) stackPushUNS(pVM->pStack,u) +#define PUSHINT(i) stackPushINT(pVM->pStack,i) +#define PUSHFLOAT(f) stackPushFloat(pVM->fStack,f) +#define PUSH(c) stackPush(pVM->pStack,c) +#define POPPTR() stackPopPtr(pVM->pStack) +#define POPUNS() stackPopUNS(pVM->pStack) +#define POPINT() stackPopINT(pVM->pStack) +#define POPFLOAT() stackPopFloat(pVM->fStack) +#define POP() stackPop(pVM->pStack) +#define GETTOP() stackGetTop(pVM->pStack) +#define SETTOP(c) stackSetTop(pVM->pStack,LVALUEtoCELL(c)) +#define GETTOPF() stackGetTop(pVM->fStack) +#define SETTOPF(c) stackSetTop(pVM->fStack,LVALUEtoCELL(c)) +#define STORE(n,c) stackStore(pVM->pStack,n,LVALUEtoCELL(c)) +#define DEPTH() stackDepth(pVM->pStack) +#define DROP(n) stackDrop(pVM->pStack,n) +#define DROPF(n) stackDrop(pVM->fStack,n) +#define FETCH(n) stackFetch(pVM->pStack,n) +#define PICK(n) stackPick(pVM->pStack,n) +#define PICKF(n) stackPick(pVM->fStack,n) +#define ROLL(n) stackRoll(pVM->pStack,n) +#define ROLLF(n) stackRoll(pVM->fStack,n) /* ** The virtual machine (VM) contains the state for one interpreter. @@ -429,7 +433,7 @@ void stackPushFloat(FICL_STACK *pStack, float f); ** Throw an exception */ -typedef struct ficl_word ** IPTYPE; /* the VM's instruction pointer */ +typedef FICL_WORD ** IPTYPE; /* the VM's instruction pointer */ /* ** Each VM has a placeholder for an output function - @@ -437,7 +441,7 @@ typedef struct ficl_word ** IPTYPE; /* the VM's instruction pointer */ ** through a different device. If you specify no ** OUTFUNC, it defaults to ficlTextOut. */ -typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline); +typedef void (*OUTFUNC)(FICL_VM *pVM, char *text, int fNewline); /* ** Each VM operates in one of two non-error states: interpreting @@ -468,17 +472,16 @@ typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline); /* ** OK - now we can really define the VM... */ -typedef struct vm +struct vm { FICL_SYSTEM *pSys; /* Which system this VM belongs to */ - struct vm *link; /* Ficl keeps a VM list for simple teardown */ + FICL_VM *link; /* Ficl keeps a VM list for simple teardown */ jmp_buf *pState; /* crude exception mechanism... */ OUTFUNC textOut; /* Output callback - see sysdep.c */ - void * pExtend; /* vm extension pointer */ + void * pExtend; /* vm extension pointer for app use - initialized from FICL_SYSTEM */ short fRestart; /* Set TRUE to restart runningWord */ IPTYPE ip; /* instruction pointer */ - struct ficl_word - *runningWord;/* address of currently running word (often just *(ip-1) ) */ + FICL_WORD *runningWord;/* address of currently running word (often just *(ip-1) ) */ FICL_UNS state; /* compiling or interpreting */ FICL_UNS base; /* number conversion base */ FICL_STACK *pStack; /* param stack */ @@ -486,13 +489,13 @@ typedef struct vm #if FICL_WANT_FLOAT FICL_STACK *fStack; /* float stack (optional) */ #endif - CELL sourceID; /* -1 if string, 0 if normal input */ + CELL sourceID; /* -1 if EVALUATE, 0 if normal input */ TIB tib; /* address of incoming text string */ #if FICL_WANT_USER CELL user[FICL_USER_CELLS]; #endif char pad[nPAD]; /* the scratch area (see above) */ -} FICL_VM; +}; /* ** A FICL_CODE points to a function that gets called to help execute @@ -518,10 +521,10 @@ typedef void (*FICL_CODE)(FICL_VM *pVm); ** words in a linked list called the dictionary. ** A FICL_WORD starts each entry in the list. ** Version 1.02: space for the name characters is allotted from -** the dictionary ahead of the word struct - this saves about half -** the storage on average with very little runtime cost. +** the dictionary ahead of the word struct, rather than using +** a fixed size array for each name. */ -typedef struct ficl_word +struct ficl_word { struct ficl_word *link; /* Previous word in the dictionary */ UNS16 hash; @@ -530,7 +533,7 @@ typedef struct ficl_word char *name; /* First nFICLNAME chars of word name */ FICL_CODE code; /* Native code to execute the word */ CELL param[1]; /* First data cell of the word */ -} FICL_WORD; +}; /* ** Worst-case size of a word header: nFICLNAME chars in name @@ -546,6 +549,7 @@ int wordIsCompileOnly(FICL_WORD *pFW); #define FW_IMMEDIATE 1 /* execute me even if compiling */ #define FW_COMPILE 2 /* error if executed when not compiling */ #define FW_SMUDGE 4 /* definition in progress - hide me */ +#define FW_ISOBJECT 8 /* word is an object or object member variable */ #define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE) #define FW_DEFAULT 0 @@ -566,28 +570,27 @@ int wordIsCompileOnly(FICL_WORD *pFW); void vmBranchRelative(FICL_VM *pVM, int offset); -FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack); -void vmDelete (FICL_VM *pVM); -void vmExecute(FICL_VM *pVM, FICL_WORD *pWord); -char * vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter); -STRINGINFO vmGetWord(FICL_VM *pVM); -STRINGINFO vmGetWord0(FICL_VM *pVM); -int vmGetWordToPad(FICL_VM *pVM); -STRINGINFO vmParseString(FICL_VM *pVM, char delimiter); +FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack); +void vmDelete (FICL_VM *pVM); +void vmExecute (FICL_VM *pVM, FICL_WORD *pWord); +FICL_DICT *vmGetDict (FICL_VM *pVM); +char * vmGetString (FICL_VM *pVM, FICL_STRING *spDest, char delimiter); +STRINGINFO vmGetWord (FICL_VM *pVM); +STRINGINFO vmGetWord0 (FICL_VM *pVM); +int vmGetWordToPad (FICL_VM *pVM); +STRINGINFO vmParseString (FICL_VM *pVM, char delimiter); STRINGINFO vmParseStringEx(FICL_VM *pVM, char delimiter, char fSkipLeading); -CELL vmPop(FICL_VM *pVM); -void vmPush(FICL_VM *pVM, CELL c); -void vmPopIP (FICL_VM *pVM); -void vmPushIP (FICL_VM *pVM, IPTYPE newIP); -void vmQuit (FICL_VM *pVM); -void vmReset (FICL_VM *pVM); -void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut); -#if FICL_WANT_DEBUGGER -void vmStep(FICL_VM *pVM); -#endif -void vmTextOut(FICL_VM *pVM, char *text, int fNewline); -void vmThrow (FICL_VM *pVM, int except); -void vmThrowErr(FICL_VM *pVM, char *fmt, ...); +CELL vmPop (FICL_VM *pVM); +void vmPush (FICL_VM *pVM, CELL c); +void vmPopIP (FICL_VM *pVM); +void vmPushIP (FICL_VM *pVM, IPTYPE newIP); +void vmQuit (FICL_VM *pVM); +void vmReset (FICL_VM *pVM); +void vmSetTextOut (FICL_VM *pVM, OUTFUNC textOut); +void vmTextOut (FICL_VM *pVM, char *text, int fNewline); +void vmTextOut (FICL_VM *pVM, char *text, int fNewline); +void vmThrow (FICL_VM *pVM, int except); +void vmThrowErr (FICL_VM *pVM, char *fmt, ...); #define vmGetRunningWord(pVM) ((pVM)->runningWord) @@ -599,7 +602,7 @@ void vmThrowErr(FICL_VM *pVM, char *fmt, ...); #define M_VM_STEP(pVM) \ FICL_WORD *tempFW = *(pVM)->ip++; \ (pVM)->runningWord = tempFW; \ - tempFW->code(pVM); \ + tempFW->code(pVM); #define M_INNER_LOOP(pVM) \ for (;;) { M_VM_STEP(pVM) } @@ -632,11 +635,11 @@ void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells); ** PopTib restores the TIB state given a saved TIB from PushTib ** GetInBuf returns a pointer to the next unused char of the TIB */ -void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib); -void vmPopTib(FICL_VM *pVM, TIB *pTib); -#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index) -#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp) -#define vmGetInBufEnd(pVM) ((pVM)->tib.end) +void vmPushTib (FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib); +void vmPopTib (FICL_VM *pVM, TIB *pTib); +#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index) +#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp) +#define vmGetInBufEnd(pVM) ((pVM)->tib.end) #define vmGetTibIndex(pVM) (pVM)->tib.index #define vmSetTibIndex(pVM, i) (pVM)->tib.index = i #define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp @@ -686,13 +689,11 @@ typedef struct ficl_hash FICL_WORD *table[1]; } FICL_HASH; -void hashForget(FICL_HASH *pHash, void *where); -UNS16 hashHashCode(STRINGINFO si); +void hashForget (FICL_HASH *pHash, void *where); +UNS16 hashHashCode (STRINGINFO si); void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW); -FICL_WORD *hashLookup(struct ficl_hash *pHash, - STRINGINFO si, - UNS16 hashCode); -void hashReset(FICL_HASH *pHash); +FICL_WORD *hashLookup (FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode); +void hashReset (FICL_HASH *pHash); /* ** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's @@ -725,7 +726,7 @@ void hashReset(FICL_HASH *pHash); ** size -- number of cells in the dictionary (total) ** dict -- start of data area. Must be at the end of the struct. */ -typedef struct ficl_dict +struct ficl_dict { CELL *here; FICL_WORD *smudge; @@ -735,16 +736,16 @@ typedef struct ficl_dict int nLists; unsigned size; /* Number of cells in dict (total)*/ CELL *dict; /* Base of dictionary memory */ -} FICL_DICT; +}; void *alignPtr(void *ptr); void dictAbortDefinition(FICL_DICT *pDict); -void dictAlign(FICL_DICT *pDict); -int dictAllot(FICL_DICT *pDict, int n); -int dictAllotCells(FICL_DICT *pDict, int nCells); -void dictAppendCell(FICL_DICT *pDict, CELL c); -void dictAppendChar(FICL_DICT *pDict, char c); -FICL_WORD *dictAppendWord(FICL_DICT *pDict, +void dictAlign (FICL_DICT *pDict); +int dictAllot (FICL_DICT *pDict, int n); +int dictAllotCells (FICL_DICT *pDict, int nCells); +void dictAppendCell (FICL_DICT *pDict, CELL c); +void dictAppendChar (FICL_DICT *pDict, char c); +FICL_WORD *dictAppendWord (FICL_DICT *pDict, char *name, FICL_CODE pCode, UNS8 flags); @@ -752,25 +753,28 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict, STRINGINFO si, FICL_CODE pCode, UNS8 flags); -void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u); -int dictCellsAvail(FICL_DICT *pDict); -int dictCellsUsed (FICL_DICT *pDict); -void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells); +void dictAppendUNS (FICL_DICT *pDict, FICL_UNS u); +int dictCellsAvail (FICL_DICT *pDict); +int dictCellsUsed (FICL_DICT *pDict); +void dictCheck (FICL_DICT *pDict, FICL_VM *pVM, int n); FICL_DICT *dictCreate(unsigned nCELLS); FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash); FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets); -void dictDelete(FICL_DICT *pDict); -void dictEmpty(FICL_DICT *pDict, unsigned nHash); -int dictIncludes(FICL_DICT *pDict, void *p); -FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si); +void dictDelete (FICL_DICT *pDict); +void dictEmpty (FICL_DICT *pDict, unsigned nHash); +#if FICL_WANT_FLOAT +void dictHashSummary(FICL_VM *pVM); +#endif +int dictIncludes (FICL_DICT *pDict, void *p); +FICL_WORD *dictLookup (FICL_DICT *pDict, STRINGINFO si); #if FICL_WANT_LOCALS -FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si); +FICL_WORD *ficlLookupLoc (FICL_SYSTEM *pSys, STRINGINFO si); #endif void dictResetSearchOrder(FICL_DICT *pDict); -void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr); +void dictSetFlags (FICL_DICT *pDict, UNS8 set, UNS8 clr); void dictSetImmediate(FICL_DICT *pDict); -void dictUnsmudge(FICL_DICT *pDict); -CELL *dictWhere(FICL_DICT *pDict); +void dictUnsmudge (FICL_DICT *pDict); +CELL *dictWhere (FICL_DICT *pDict); /* @@ -807,6 +811,23 @@ void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP void ficlListParseSteps(FICL_VM *pVM); /* +** FICL_BREAKPOINT record. +** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt +** that the breakpoint overwrote. This is restored to the dictionary when the +** BP executes or gets cleared +** address - the location of the breakpoint (address of the instruction that +** has been replaced with the breakpoint trap +** origXT - The original contents of the location with the breakpoint +** Note: address is NULL when this breakpoint is empty +*/ +typedef struct FICL_BREAKPOINT +{ + void *address; + FICL_WORD *origXT; +} FICL_BREAKPOINT; + + +/* ** F I C L _ S Y S T E M ** The top level data structure of the system - ficl_system ties a list of ** virtual machines with their corresponding dictionaries. Ficl 3.0 will @@ -814,17 +835,13 @@ void ficlListParseSteps(FICL_VM *pVM); ** to separate dictionaries with some constraints. ** The present model allows multiple sessions to one dictionary provided ** you implement ficlLockDictionary() as specified in sysdep.h -** -** RESTRICTIONS: due to the use of static variables in words.c for compiling -** comtrol structures faster, if you use multiple ficl systems these variables -** will point into the most recently initialized dictionary - this is probably -** not a problem provided the precompiled dictionaries are identical for -** all systems. +** Note: the pExtend pointer is there to provide context for applications. It is copied +** to each VM's pExtend field as that VM is created. */ struct ficl_system { FICL_SYSTEM *link; - FICL_WORD *parseList[FICL_MAX_PARSE_STEPS]; + void *pExtend; /* Initializes VM's pExtend pointer (for application use) */ FICL_VM *vmList; FICL_DICT *dp; FICL_DICT *envp; @@ -832,8 +849,57 @@ struct ficl_system FICL_DICT *localp; #endif FICL_WORD *pInterp[3]; + FICL_WORD *parseList[FICL_MAX_PARSE_STEPS]; + OUTFUNC textOut; + + FICL_WORD *pBranchParen; + FICL_WORD *pDoParen; + FICL_WORD *pDoesParen; + FICL_WORD *pExitInner; + FICL_WORD *pExitParen; + FICL_WORD *pIfParen; + FICL_WORD *pInterpret; + FICL_WORD *pLitParen; + FICL_WORD *pTwoLitParen; + FICL_WORD *pLoopParen; + FICL_WORD *pPLoopParen; + FICL_WORD *pQDoParen; + FICL_WORD *pSemiParen; + FICL_WORD *pStore; + FICL_WORD *pCStringLit; + FICL_WORD *pStringLit; + +#if FICL_WANT_LOCALS + FICL_WORD *pGetLocalParen; + FICL_WORD *pGet2LocalParen; + FICL_WORD *pGetLocal0; + FICL_WORD *pGetLocal1; + FICL_WORD *pToLocalParen; + FICL_WORD *pTo2LocalParen; + FICL_WORD *pToLocal0; + FICL_WORD *pToLocal1; + FICL_WORD *pLinkParen; + FICL_WORD *pUnLinkParen; + FICL_INT nLocals; + CELL *pMarkLocals; +#endif + + FICL_BREAKPOINT bpStep; }; +struct ficl_system_info +{ + int size; /* structure size tag for versioning */ + int nDictCells; /* Size of system's Dictionary */ + OUTFUNC textOut; /* default textOut function */ + void *pExtend; /* Initializes VM's pExtend pointer - for application use */ + int nEnvCells; /* Size of Environment dictionary */ +}; + + +#define ficlInitInfo(x) { memset((x), 0, sizeof(FICL_SYSTEM_INFO)); \ + (x)->size = sizeof(FICL_SYSTEM_INFO); } + /* ** External interface to FICL... */ @@ -841,7 +907,8 @@ struct ficl_system ** f i c l I n i t S y s t e m ** Binds a global dictionary to the interpreter system and initializes ** the dict to contain the ANSI CORE wordset. -** You specify the address and size of the allocated area. +** You can specify the address and size of the allocated area. +** Using ficlInitSystemEx you can also specify the text output function. ** After that, ficl manages it. ** First step is to set up the static pointers to the area. ** Then write the "precompiled" portion of the dictionary in. @@ -849,7 +916,10 @@ struct ficl_system ** precompiled part. Try 1K cells minimum. Use "words" to find ** out how much of the dictionary is used at any time. */ -void ficlInitSystem(int nDictCells); +FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi); + +/* Deprecated call */ +FICL_SYSTEM *ficlInitSystem(int nDictCells); /* ** f i c l T e r m S y s t e m @@ -857,7 +927,17 @@ void ficlInitSystem(int nDictCells); ** were created with ficlNewVM (see below). Call this function to ** reclaim all memory used by the dictionary and VMs. */ -void ficlTermSystem(void); +void ficlTermSystem(FICL_SYSTEM *pSys); + +/* +** f i c l E v a l u a t e +** Evaluates a block of input text in the context of the +** specified interpreter. Also sets SOURCE-ID properly. +** +** PLEASE USE THIS FUNCTION when throwing a hard-coded +** string to the FICL interpreter. +*/ +int ficlEvaluate(FICL_VM *pVM, char *pText); /* ** f i c l E x e c @@ -880,6 +960,10 @@ void ficlTermSystem(void); ** commands. ** Preconditions: successful execution of ficlInitSystem, ** Successful creation and init of the VM by ficlNewVM (or equiv) +** +** If you call ficlExec() or one of its brothers, you MUST +** ensure pVM->sourceID was set to a sensible value. +** ficlExec() explicitly DOES NOT manage SOURCE-ID for you. */ int ficlExec (FICL_VM *pVM, char *pText); int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT nChars); @@ -899,7 +983,7 @@ int ficlExecFD(FICL_VM *pVM, int fd); ** address of the VM, or NULL if an error occurs. ** Precondition: successful execution of ficlInitSystem */ -FICL_VM *ficlNewVM(void); +FICL_VM *ficlNewVM(FICL_SYSTEM *pSys); /* ** Force deletion of a VM. You do not need to do this @@ -922,19 +1006,19 @@ int ficlSetStackSize(int nStackCells); ** dictionary with the given name, or NULL if no match. ** Precondition: successful execution of ficlInitSystem */ -FICL_WORD *ficlLookup(char *name); +FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name); /* ** f i c l G e t D i c t ** Utility function - returns the address of the system dictionary. ** Precondition: successful execution of ficlInitSystem */ -FICL_DICT *ficlGetDict(void); -FICL_DICT *ficlGetEnv(void); -void ficlSetEnv(char *name, FICL_UNS value); -void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo); +FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys); +FICL_DICT *ficlGetEnv (FICL_SYSTEM *pSys); +void ficlSetEnv (FICL_SYSTEM *pSys, char *name, FICL_UNS value); +void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo); #if FICL_WANT_LOCALS -FICL_DICT *ficlGetLoc(void); +FICL_DICT *ficlGetLoc (FICL_SYSTEM *pSys); #endif /* ** f i c l B u i l d @@ -952,7 +1036,7 @@ FICL_DICT *ficlGetLoc(void); ** Most words can use FW_DEFAULT. ** nAllot - number of extra cells to allocate in the parameter area (usually zero) */ -int ficlBuild(char *name, FICL_CODE code, char flags); +int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags); /* ** f i c l C o m p i l e C o r e @@ -964,12 +1048,15 @@ void ficlCompilePrefix(FICL_SYSTEM *pSys); void ficlCompileSearch(FICL_SYSTEM *pSys); void ficlCompileSoftCore(FICL_SYSTEM *pSys); void ficlCompileTools(FICL_SYSTEM *pSys); +void ficlCompileFile(FICL_SYSTEM *pSys); #if FICL_WANT_FLOAT void ficlCompileFloat(FICL_SYSTEM *pSys); +int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ); /* float.c */ #endif #if FICL_PLATFORM_EXTEND void ficlCompilePlatform(FICL_SYSTEM *pSys); #endif +int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si); /* ** from words.c... @@ -983,7 +1070,7 @@ void parseStepParen(FICL_VM *pVM); /* ** From tools.c */ -int isAFiclWord(FICL_WORD *pFW); +int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW); /* ** The following supports SEE and the debugger. @@ -1003,9 +1090,13 @@ typedef enum PRIMITIVE, QDO, STRINGLIT, + CSTRINGLIT, +#if FICL_WANT_USER USER, +#endif VARIABLE, } WORDKIND; + WORDKIND ficlWordClassify(FICL_WORD *pFW); /* @@ -1036,6 +1127,25 @@ extern void ficlPnphandlers(FICL_VM *pVM); extern void ficlCcall(FICL_VM *pVM); #endif +/* +** Used with File-Access wordset. +*/ +#define FICL_FAM_READ 1 +#define FICL_FAM_WRITE 2 +#define FICL_FAM_APPEND 4 +#define FICL_FAM_BINARY 8 + +#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND)) + + +#if (FICL_WANT_FILE) +typedef struct ficlFILE +{ + FILE *f; + char filename[256]; +} ficlFILE; +#endif + #ifdef __cplusplus } #endif diff --git a/sys/boot/ficl/fileaccess.c b/sys/boot/ficl/fileaccess.c new file mode 100644 index 0000000..686c721 --- /dev/null +++ b/sys/boot/ficl/fileaccess.c @@ -0,0 +1,425 @@ +/* $FreeBSD$ */ + +#include <errno.h> +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <ctype.h> +#include <sys/stat.h> +#include "ficl.h" + +#if FICL_WANT_FILE +/* +** +** fileaccess.c +** +** Implements all of the File Access word set that can be implemented in portable C. +** +*/ + +static void pushIor(FICL_VM *pVM, int success) +{ + int ior; + if (success) + ior = 0; + else + ior = errno; + stackPushINT(pVM->pStack, ior); +} + + + +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); +} + + + +static void ficlOpenFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */ +{ + ficlFopen(pVM, "a"); +} + + +static void ficlCreateFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */ +{ + ficlFopen(pVM, "w"); +} + + +static int closeFiclFILE(ficlFILE *ff) /* ( fileid -- ior ) */ +{ + FILE *f = ff->f; + free(ff); + return !fclose(f); +} + +static void ficlCloseFile(FICL_VM *pVM) /* ( fileid -- ior ) */ +{ + ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack); + pushIor(pVM, closeFiclFILE(ff)); +} + +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 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)); +} + +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 ficlFilePosition(FICL_VM *pVM) /* ( fileid -- ud ior ) */ +{ + ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack); + long ud = ftell(ff->f); + stackPushINT(pVM->pStack, ud); + pushIor(pVM, ud != -1); +} + + + +static long fileSize(FILE *f) +{ + struct stat statbuf; + statbuf.st_size = -1; + if (fstat(fileno(f), &statbuf) != 0) + return -1; + return statbuf.st_size; +} + + + +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); +} + + + +#define nLINEBUF 256 +static void ficlIncludeFile(FICL_VM *pVM) /* ( i*x fileid -- j*x ) */ +{ + ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack); + CELL id = pVM->sourceID; + int result = VM_OUTOFTEXT; + long currentPosition, totalSize; + long size; + pVM->sourceID.p = (void *)ff; + + currentPosition = ftell(ff->f); + totalSize = fileSize(ff->f); + size = totalSize - currentPosition; + + if ((totalSize != -1) && (currentPosition != -1) && (size > 0)) + { + char *buffer = (char *)malloc(size); + long got = fread(buffer, 1, size, ff->f); + if (got == size) + result = ficlExecC(pVM, buffer, size); + } + +#if 0 + ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack); + CELL id = pVM->sourceID; + char cp[nLINEBUF]; + int nLine = 0; + int keepGoing; + int result; + pVM->sourceID.p = (void *)ff; + + /* feed each line to ficlExec */ + keepGoing = TRUE; + while (keepGoing && fgets(cp, nLINEBUF, ff->f)) + { + int len = strlen(cp) - 1; + + nLine++; + if (len <= 0) + continue; + + if (cp[len] == '\n') + cp[len] = '\0'; + + result = ficlExec(pVM, cp); + + switch (result) + { + case VM_OUTOFTEXT: + case VM_USEREXIT: + break; + + default: + pVM->sourceID = id; + keepGoing = FALSE; + break; + } + } +#endif /* 0 */ + /* + ** 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; + closeFiclFILE(ff); +} + + + +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); +} + + + +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 */ +} + + + +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); +} + + + +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 ficlFlushFile(FICL_VM *pVM) /* ( fileid -- ior ) */ +{ + ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack); + pushIor(pVM, fflush(ff->f) == 0); +} + + + +#if FICL_HAVE_FTRUNCATE + +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); +} + +#endif /* FICL_HAVE_FTRUNCATE */ + +#endif /* FICL_WANT_FILE */ + + + +void ficlCompileFile(FICL_SYSTEM *pSys) +{ +#if FICL_WANT_FILE + FICL_DICT *dp = pSys->dp; + assert(dp); + + dictAppendWord(dp, "create-file", ficlCreateFile, FW_DEFAULT); + dictAppendWord(dp, "open-file", ficlOpenFile, FW_DEFAULT); + dictAppendWord(dp, "close-file", ficlCloseFile, FW_DEFAULT); + dictAppendWord(dp, "include-file", ficlIncludeFile, FW_DEFAULT); + dictAppendWord(dp, "read-file", ficlReadFile, FW_DEFAULT); + dictAppendWord(dp, "read-line", ficlReadLine, FW_DEFAULT); + dictAppendWord(dp, "write-file", ficlWriteFile, FW_DEFAULT); + dictAppendWord(dp, "write-line", ficlWriteLine, FW_DEFAULT); + dictAppendWord(dp, "file-position", ficlFilePosition, FW_DEFAULT); + dictAppendWord(dp, "file-size", ficlFileSize, FW_DEFAULT); + dictAppendWord(dp, "reposition-file", ficlRepositionFile, FW_DEFAULT); + dictAppendWord(dp, "file-status", ficlFileStatus, FW_DEFAULT); + dictAppendWord(dp, "flush-file", ficlFlushFile, FW_DEFAULT); + + dictAppendWord(dp, "delete-file", ficlDeleteFile, FW_DEFAULT); + dictAppendWord(dp, "rename-file", ficlRenameFile, FW_DEFAULT); + +#ifdef FICL_HAVE_FTRUNCATE + dictAppendWord(dp, "resize-file", ficlResizeFile, FW_DEFAULT); + + ficlSetEnv(pSys, "file", FICL_TRUE); + ficlSetEnv(pSys, "file-ext", FICL_TRUE); +#endif /* FICL_HAVE_FTRUNCATE */ +#else + &pSys; +#endif /* FICL_WANT_FILE */ +} diff --git a/sys/boot/ficl/float.c b/sys/boot/ficl/float.c new file mode 100644 index 0000000..3fe8581 --- /dev/null +++ b/sys/boot/ficl/float.c @@ -0,0 +1,1064 @@ +/******************************************************************* +** f l o a t . c +** Forth Inspired Command Language +** ANS Forth FLOAT word-set written in C +** Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu) +** Created: Apr 2001 +** $Id: float.c,v 1.8 2001/12/05 07:21:34 jsadler Exp $ +*******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +*/ + +/* $FreeBSD$ */ + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <ctype.h> +#include <math.h> +#include "ficl.h" + +#if FICL_WANT_FLOAT + +/******************************************************************* +** Do float addition r1 + r2. +** f+ ( r1 r2 -- r ) +*******************************************************************/ +static void Fadd(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 1); +#endif + + f = POPFLOAT(); + f += GETTOPF().f; + SETTOPF(f); +} + +/******************************************************************* +** Do float subtraction r1 - r2. +** f- ( r1 r2 -- r ) +*******************************************************************/ +static void Fsub(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 1); +#endif + + f = POPFLOAT(); + f = GETTOPF().f - f; + SETTOPF(f); +} + +/******************************************************************* +** Do float multiplication r1 * r2. +** f* ( r1 r2 -- r ) +*******************************************************************/ +static void Fmul(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 1); +#endif + + f = POPFLOAT(); + f *= GETTOPF().f; + SETTOPF(f); +} + +/******************************************************************* +** Do float negation. +** fnegate ( r -- r ) +*******************************************************************/ +static void Fnegate(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 1); +#endif + + f = -GETTOPF().f; + SETTOPF(f); +} + +/******************************************************************* +** Do float division r1 / r2. +** f/ ( r1 r2 -- r ) +*******************************************************************/ +static void Fdiv(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 1); +#endif + + f = POPFLOAT(); + f = GETTOPF().f / f; + SETTOPF(f); +} + +/******************************************************************* +** Do float + integer r + n. +** f+i ( r n -- r ) +*******************************************************************/ +static void Faddi(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); +} + +/******************************************************************* +** Do float - integer r - n. +** f-i ( r n -- r ) +*******************************************************************/ +static void Fsubi(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 0); +#endif + + f = GETTOPF().f; + f -= (FICL_FLOAT)POPINT(); + SETTOPF(f); +} + +/******************************************************************* +** Do float * integer r * n. +** f*i ( r n -- r ) +*******************************************************************/ +static void Fmuli(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); +} + +/******************************************************************* +** Do float / integer r / n. +** f/i ( r n -- r ) +*******************************************************************/ +static void Fdivi(FICL_VM *pVM) +{ + FICL_FLOAT f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 0); +#endif + + f = GETTOPF().f; + f /= (FICL_FLOAT)POPINT(); + SETTOPF(f); +} + +/******************************************************************* +** Do integer - float n - r. +** i-f ( n r -- r ) +*******************************************************************/ +static void isubf(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); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** Floating point constant execution word. +*******************************************************************/ +void FconstantParen(FICL_VM *pVM) +{ + FICL_WORD *pFW = pVM->runningWord; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 0, 1); +#endif + + PUSHFLOAT(pFW->param[0].f); +} + +/******************************************************************* +** Create a floating point constant. +** fconstant ( r -"name"- ) +*******************************************************************/ +static void Fconstant(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + STRINGINFO si = vmGetWord(pVM); + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); +#endif + + dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT); + dictAppendCell(dp, stackPop(pVM->fStack)); +} + +/******************************************************************* +** Display a float in decimal format. +** f. ( r -- ) +*******************************************************************/ +static void FDot(FICL_VM *pVM) +{ + float f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); +#endif + + f = POPFLOAT(); + sprintf(pVM->pad,"%#f ",f); + vmTextOut(pVM, pVM->pad, 0); +} + +/******************************************************************* +** Display a float in engineering format. +** fe. ( r -- ) +*******************************************************************/ +static void EDot(FICL_VM *pVM) +{ + float f; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); +#endif + + f = POPFLOAT(); + sprintf(pVM->pad,"%#e ",f); + vmTextOut(pVM, pVM->pad, 0); +} + +/************************************************************************** + d i s p l a y FS t a c k +** Display the parameter stack (code for "f.s") +** f.s ( -- ) +**************************************************************************/ +static void displayFStack(FICL_VM *pVM) +{ + int d = stackDepth(pVM->fStack); + int i; + CELL *pCell; + + vmCheckFStack(pVM, 0, 0); + + vmTextOut(pVM, "F:", 0); + + if (d == 0) + vmTextOut(pVM, "[0]", 0); + else + { + ltoa(d, &pVM->pad[1], pVM->base); + pVM->pad[0] = '['; + strcat(pVM->pad,"] "); + vmTextOut(pVM,pVM->pad,0); + + pCell = pVM->fStack->sp - d; + for (i = 0; i < d; i++) + { + sprintf(pVM->pad,"%#f ",(*pCell++).f); + vmTextOut(pVM,pVM->pad,0); + } + } +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** Do float stack drop. +** fdrop ( r -- ) +*******************************************************************/ +static void Fdrop(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); +#endif + + DROPF(1); +} + +/******************************************************************* +** Do float stack 2drop. +** f2drop ( r r -- ) +*******************************************************************/ +static void FtwoDrop(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 0); +#endif + + DROPF(2); +} + +/******************************************************************* +** Do float stack dup. +** fdup ( r -- r r ) +*******************************************************************/ +static void Fdup(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 2); +#endif + + PICKF(0); +} + +/******************************************************************* +** Do float stack 2dup. +** f2dup ( r1 r2 -- r1 r2 r1 r2 ) +*******************************************************************/ +static void FtwoDup(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 4); +#endif + + PICKF(1); + PICKF(1); +} + +/******************************************************************* +** Do float stack over. +** fover ( r1 r2 -- r1 r2 r1 ) +*******************************************************************/ +static void Fover(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 3); +#endif + + PICKF(1); +} + +/******************************************************************* +** Do float stack 2over. +** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 ) +*******************************************************************/ +static void FtwoOver(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 4, 6); +#endif + + PICKF(3); + PICKF(3); +} + +/******************************************************************* +** Do float stack pick. +** fpick ( n -- r ) +*******************************************************************/ +static void Fpick(FICL_VM *pVM) +{ + CELL c = POP(); + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, c.i+1, c.i+2); +#endif + + PICKF(c.i); +} + +/******************************************************************* +** Do float stack ?dup. +** f?dup ( r -- r ) +*******************************************************************/ +static void FquestionDup(FICL_VM *pVM) +{ + CELL c; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 2); +#endif + + c = GETTOPF(); + if (c.f != 0) + PICKF(0); +} + +/******************************************************************* +** Do float stack roll. +** froll ( n -- ) +*******************************************************************/ +static void Froll(FICL_VM *pVM) +{ + int i = POP().i; + i = (i > 0) ? i : 0; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, i+1, i+1); +#endif + + ROLLF(i); +} + +/******************************************************************* +** Do float stack -roll. +** f-roll ( n -- ) +*******************************************************************/ +static void FminusRoll(FICL_VM *pVM) +{ + int i = POP().i; + i = (i > 0) ? i : 0; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, i+1, i+1); +#endif + + ROLLF(-i); +} + +/******************************************************************* +** Do float stack rot. +** frot ( r1 r2 r3 -- r2 r3 r1 ) +*******************************************************************/ +static void Frot(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 3, 3); +#endif + + ROLLF(2); +} + +/******************************************************************* +** Do float stack -rot. +** f-rot ( r1 r2 r3 -- r3 r1 r2 ) +*******************************************************************/ +static void Fminusrot(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 3, 3); +#endif + + ROLLF(-2); +} + +/******************************************************************* +** Do float stack swap. +** fswap ( r1 r2 -- r2 r1 ) +*******************************************************************/ +static void Fswap(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 2, 2); +#endif + + ROLLF(1); +} + +/******************************************************************* +** Do float stack 2swap +** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 ) +*******************************************************************/ +static void FtwoSwap(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 4, 4); +#endif + + ROLLF(3); + ROLLF(3); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** Store a floating point number into a variable. +** f! ( r n -- ) +*******************************************************************/ +static void Fstore(FICL_VM *pVM) +{ + CELL *pCell; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); +#endif + + pCell = (CELL *)POPPTR(); + pCell->f = POPFLOAT(); +} + +/******************************************************************* +** 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(); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** Compile a floating point literal. +*******************************************************************/ +static void fliteralIm(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)"); + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); +#endif + + dictAppendCell(dp, LVALUEtoCELL(pfLitParen)); + dictAppendCell(dp, stackPop(pVM->fStack)); +} + +/******************************************************************* +** Do float 0= comparison r = 0.0. +** f0= ( r -- T/F ) +*******************************************************************/ +static void FzeroEquals(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); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** 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); +} + +/******************************************************************* +** 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)); +} + +/******************************************************************* +** Do float < comparison r1 < r2. +** f< ( r1 r2 -- T/F ) +*******************************************************************/ +static void FisLess(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 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)); +} + + +/******************************************************************* +** Move float to param stack (assumes they both fit in a single CELL) +** f>s +*******************************************************************/ +static void FFrom(FICL_VM *pVM) +{ + CELL c; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 1, 0); + vmCheckStack(pVM, 0, 1); +#endif + + c = stackPop(pVM->fStack); + stackPush(pVM->pStack, c); + 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; +} + + +/************************************************************************** + F l o a t P a r s e S t a t e +** Enum to determine the current segement of a floating point number +** being parsed. +**************************************************************************/ +#define NUMISNEG 1 +#define EXPISNEG 2 + +typedef enum _floatParseState +{ + FPS_START, + FPS_ININT, + FPS_INMANT, + FPS_STARTEXP, + FPS_INEXP +} FloatParseState; + +/************************************************************************** + f i c l P a r s e F l o a t N u m b e r +** pVM -- Virtual Machine pointer. +** si -- String to parse. +** Returns 1 if successful, 0 if not. +**************************************************************************/ +int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ) +{ + unsigned char ch, digit; + char *cp; + FICL_COUNT count; + float power; + float accum = 0.0f; + float mant = 0.1f; + FICL_INT exponent = 0; + char flag = 0; + FloatParseState estate = FPS_START; + +#if FICL_ROBUST > 1 + vmCheckFStack(pVM, 0, 1); +#endif + + /* + ** floating point numbers only allowed in base 10 + */ + if (pVM->base != 10) + return(0); + + + cp = SI_PTR(si); + count = (FICL_COUNT)SI_COUNT(si); + + /* Loop through the string's characters. */ + while ((count--) && ((ch = *cp++) != 0)) + { + switch (estate) + { + /* At start of the number so look for a sign. */ + case FPS_START: + { + estate = FPS_ININT; + if (ch == '-') + { + flag |= NUMISNEG; + break; + } + if (ch == '+') + { + break; + } + } /* Note! Drop through to FPS_ININT */ + /* + **Converting integer part of number. + ** Only allow digits, decimal and 'E'. + */ + case FPS_ININT: + { + if (ch == '.') + { + estate = FPS_INMANT; + } + else if ((ch == 'e') || (ch == 'E')) + { + estate = FPS_STARTEXP; + } + else + { + digit = (unsigned char)(ch - '0'); + if (digit > 9) + return(0); + + accum = accum * 10 + digit; + + } + break; + } + /* + ** Processing the fraction part of number. + ** Only allow digits and 'E' + */ + case FPS_INMANT: + { + if ((ch == 'e') || (ch == 'E')) + { + estate = FPS_STARTEXP; + } + else + { + digit = (unsigned char)(ch - '0'); + if (digit > 9) + return(0); + + accum += digit * mant; + mant *= 0.1f; + } + break; + } + /* Start processing the exponent part of number. */ + /* Look for sign. */ + case FPS_STARTEXP: + { + estate = FPS_INEXP; + + if (ch == '-') + { + flag |= EXPISNEG; + break; + } + else if (ch == '+') + { + break; + } + } /* Note! Drop through to FPS_INEXP */ + /* + ** Processing the exponent part of number. + ** Only allow digits. + */ + case FPS_INEXP: + { + digit = (unsigned char)(ch - '0'); + if (digit > 9) + return(0); + + exponent = exponent * 10 + digit; + + break; + } + } + } + + /* If parser never made it to the exponent this is not a float. */ + if (estate < FPS_STARTEXP) + return(0); + + /* Set the sign of the number. */ + if (flag & NUMISNEG) + accum = -accum; + + /* If exponent is not 0 then adjust number by it. */ + if (exponent != 0) + { + /* Determine if exponent is negative. */ + if (flag & EXPISNEG) + { + exponent = -exponent; + } + /* power = 10^x */ + power = (float)pow(10.0, exponent); + accum *= power; + } + + PUSHFLOAT(accum); + + return(1); +} + +#endif /* FICL_WANT_FLOAT */ + +/************************************************************************** +** Add float words to a system's dictionary. +** pSys -- Pointer to the FICL sytem to add float words to. +**************************************************************************/ +void ficlCompileFloat(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + assert(dp); + +#if FICL_WANT_FLOAT + dictAppendWord(dp, ">float", ToF, FW_DEFAULT); + /* d>f */ + dictAppendWord(dp, "f!", Fstore, FW_DEFAULT); + dictAppendWord(dp, "f*", Fmul, FW_DEFAULT); + dictAppendWord(dp, "f+", Fadd, FW_DEFAULT); + dictAppendWord(dp, "f-", Fsub, FW_DEFAULT); + dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT); + dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT); + dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT); + dictAppendWord(dp, "f<", FisLess, FW_DEFAULT); + /* + f>d + */ + dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT); + /* + falign + faligned + */ + dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT); + dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT); + dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT); + dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT); + dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE); +/* + float+ + floats + floor + fmax + fmin +*/ + dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT); + dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT); + dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT); + dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT); + dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT); + dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT); + dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT); + dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT); + dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT); + dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT); + dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT); + dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT); + dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT); + dictAppendWord(dp, "int>float", itof, FW_DEFAULT); + dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT); + dictAppendWord(dp, "f.", FDot, FW_DEFAULT); + dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT); + dictAppendWord(dp, "fe.", EDot, FW_DEFAULT); + dictAppendWord(dp, "fover", Fover, FW_DEFAULT); + dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT); + dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT); + dictAppendWord(dp, "froll", Froll, FW_DEFAULT); + dictAppendWord(dp, "frot", Frot, FW_DEFAULT); + dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT); + dictAppendWord(dp, "i-f", isubf, FW_DEFAULT); + dictAppendWord(dp, "i/f", idivf, FW_DEFAULT); + + dictAppendWord(dp, "float>", FFrom, FW_DEFAULT); + + dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT); + dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT); + dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE); + + ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */ + ficlSetEnv(pSys, "floating-ext", FICL_FALSE); + ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK); +#endif + return; +} diff --git a/sys/boot/ficl/i386/sysdep.h b/sys/boot/ficl/i386/sysdep.h index b44fbc4..b3f896e 100644 --- a/sys/boot/ficl/i386/sysdep.h +++ b/sys/boot/ficl/i386/sysdep.h @@ -9,7 +9,7 @@ ** FICL_ROBUST is enabled. This may require some consideration ** in firmware systems since assert often ** assumes stderr/stdout. -** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ +** $Id: sysdep.h,v 1.11 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -17,6 +17,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -39,13 +44,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -75,7 +73,6 @@ #define FALSE 0 #endif - /* ** System dependent data type declarations... */ @@ -162,6 +159,7 @@ typedef struct #endif #if (FICL_MINIMAL) #define FICL_WANT_SOFTWORDS 0 +#define FICL_WANT_FILE 0 #define FICL_WANT_FLOAT 0 #define FICL_WANT_USER 0 #define FICL_WANT_LOCALS 0 @@ -181,6 +179,17 @@ typedef struct #define FICL_PLATFORM_EXTEND 1 #endif + +/* +** FICL_WANT_FILE +** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not +** have a file system! +** Contributed by Larry Hastings +*/ +#if !defined (FICL_WANT_FILE) +#define FICL_WANT_FILE 0 +#endif + /* ** FICL_WANT_FLOAT ** Includes a floating point stack for the VM, and words to do float operations. @@ -199,6 +208,14 @@ typedef struct #endif /* +** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if +** included as part of softcore.c) +*/ +#if !defined FICL_EXTENDED_PREFIX +#define FICL_EXTENDED_PREFIX 0 +#endif + +/* ** User variables: per-instance variables bound to the VM. ** Kinda like thread-local storage. Could be implemented in a ** VM private dictionary, but I've chosen the lower overhead @@ -341,14 +358,6 @@ typedef struct #endif /* -** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if -** included as part of softcore.c) -*/ -#if !defined FICL_EXTENDED_PREFIX -#define FICL_EXTENDED_PREFIX 0 -#endif - -/* ** FICL_ALIGN is the power of two to which the dictionary ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture @@ -409,4 +418,15 @@ int ficlLockDictionary(short fLock); DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); + +/* +** FICL_HAVE_FTRUNCATE indicates whether the current OS supports +** the ftruncate() function (available on most UNIXes). This +** function is necessary to provide the complete File-Access wordset. +*/ +#if !defined (FICL_HAVE_FTRUNCATE) +#define FICL_HAVE_FTRUNCATE 0 +#endif + + #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/ia64/sysdep.h b/sys/boot/ficl/ia64/sysdep.h index 0a6ca33..d0e5a2f 100644 --- a/sys/boot/ficl/ia64/sysdep.h +++ b/sys/boot/ficl/ia64/sysdep.h @@ -9,7 +9,7 @@ ** FICL_ROBUST is enabled. This may require some consideration ** in firmware systems since assert often ** assumes stderr/stdout. -** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ +** $Id: sysdep.h,v 1.11 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -17,6 +17,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -40,11 +45,6 @@ ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. ** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** ** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ */ @@ -75,7 +75,6 @@ #define FALSE 0 #endif - /* ** System dependent data type declarations... */ @@ -162,6 +161,7 @@ typedef struct #endif #if (FICL_MINIMAL) #define FICL_WANT_SOFTWORDS 0 +#define FICL_WANT_FILE 0 #define FICL_WANT_FLOAT 0 #define FICL_WANT_USER 0 #define FICL_WANT_LOCALS 0 @@ -181,6 +181,17 @@ typedef struct #define FICL_PLATFORM_EXTEND 1 #endif + +/* +** FICL_WANT_FILE +** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not +** have a file system! +** Contributed by Larry Hastings +*/ +#if !defined (FICL_WANT_FILE) +#define FICL_WANT_FILE 0 +#endif + /* ** FICL_WANT_FLOAT ** Includes a floating point stack for the VM, and words to do float operations. @@ -199,6 +210,14 @@ typedef struct #endif /* +** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if +** included as part of softcore.c) +*/ +#if !defined FICL_EXTENDED_PREFIX +#define FICL_EXTENDED_PREFIX 0 +#endif + +/* ** User variables: per-instance variables bound to the VM. ** Kinda like thread-local storage. Could be implemented in a ** VM private dictionary, but I've chosen the lower overhead @@ -341,14 +360,6 @@ typedef struct #endif /* -** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if -** included as part of softcore.c) -*/ -#if !defined FICL_EXTENDED_PREFIX -#define FICL_EXTENDED_PREFIX 0 -#endif - -/* ** FICL_ALIGN is the power of two to which the dictionary ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture @@ -409,4 +420,15 @@ int ficlLockDictionary(short fLock); DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); + +/* +** FICL_HAVE_FTRUNCATE indicates whether the current OS supports +** the ftruncate() function (available on most UNIXes). This +** function is necessary to provide the complete File-Access wordset. +*/ +#if !defined (FICL_HAVE_FTRUNCATE) +#define FICL_HAVE_FTRUNCATE 0 +#endif + + #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/loader.c b/sys/boot/ficl/loader.c index 54380b2..7aa8e3ae 100644 --- a/sys/boot/ficl/loader.c +++ b/sys/boot/ficl/loader.c @@ -591,7 +591,7 @@ static void fkey(FICL_VM *pVM) static void freeHeap(FICL_VM *pVM) { - stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict())); + stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict(pVM->pSys))); } @@ -653,17 +653,17 @@ void ficlCompilePlatform(FICL_SYSTEM *pSys) #endif #if defined(__i386__) - ficlSetEnv("arch-i386", FICL_TRUE); - ficlSetEnv("arch-alpha", FICL_FALSE); - ficlSetEnv("arch-ia64", FICL_FALSE); + ficlSetEnv(pSys, "arch-i386", FICL_TRUE); + ficlSetEnv(pSys, "arch-alpha", FICL_FALSE); + ficlSetEnv(pSys, "arch-ia64", FICL_FALSE); #elif defined(__alpha__) - ficlSetEnv("arch-i386", FICL_FALSE); - ficlSetEnv("arch-alpha", FICL_TRUE); - ficlSetEnv("arch-ia64", FICL_FALSE); + ficlSetEnv(pSys, "arch-i386", FICL_FALSE); + ficlSetEnv(pSys, "arch-alpha", FICL_TRUE); + ficlSetEnv(pSys, "arch-ia64", FICL_FALSE); #elif defined(__ia64__) - ficlSetEnv("arch-i386", FICL_FALSE); - ficlSetEnv("arch-alpha", FICL_FALSE); - ficlSetEnv("arch-ia64", FICL_TRUE); + ficlSetEnv(pSys, "arch-i386", FICL_FALSE); + ficlSetEnv(pSys, "arch-alpha", FICL_FALSE); + ficlSetEnv(pSys, "arch-ia64", FICL_TRUE); #endif return; diff --git a/sys/boot/ficl/math64.c b/sys/boot/ficl/math64.c index a355883..6e50458 100644 --- a/sys/boot/ficl/math64.c +++ b/sys/boot/ficl/math64.c @@ -5,7 +5,7 @@ ** Created: 25 January 1998 ** Rev 2.03: Support for 128 bit DP math. This file really ouught to ** be renamed! -** $Id: math64.c,v 1.5 2001-04-26 21:41:36-07 jsadler Exp jsadler $ +** $Id: math64.c,v 1.9 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -13,6 +13,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -35,13 +40,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: math64.c,v 1.5 2001-04-26 21:41:36-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ diff --git a/sys/boot/ficl/math64.h b/sys/boot/ficl/math64.h index 8fd1517..a4e5636 100644 --- a/sys/boot/ficl/math64.h +++ b/sys/boot/ficl/math64.h @@ -3,12 +3,17 @@ ** Forth Inspired Command Language - 64 bit math support routines ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 25 January 1998 -** $Id: math64.h,v 1.5 2001-04-26 21:41:53-07 jsadler Exp jsadler $ +** $Id: math64.h,v 1.9 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) ** All rights reserved. ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** Get the latest Ficl release at http://ficl.sourceforge.net ** ** L I C E N S E and D I S C L A I M E R @@ -33,13 +38,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: math64.h,v 1.5 2001-04-26 21:41:53-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ diff --git a/sys/boot/ficl/prefix.c b/sys/boot/ficl/prefix.c index 0d52b7c..447f740 100644 --- a/sys/boot/ficl/prefix.c +++ b/sys/boot/ficl/prefix.c @@ -4,7 +4,7 @@ ** Parser extensions for Ficl ** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu) ** Created: April 2001 -** $Id: prefix.c,v 1.1 2001-04-26 21:41:33-07 jsadler Exp jsadler $ +** $Id: prefix.c,v 1.6 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -12,6 +12,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -34,13 +39,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: prefix.c,v 1.1 2001-04-26 21:41:33-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -76,9 +74,15 @@ int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si) { int i; FICL_HASH *pHash; - FICL_WORD *pFW = ficlLookup(list_name); + FICL_WORD *pFW = ficlLookup(pVM->pSys, list_name); + + /* + ** Make sure we found the prefix dictionary - otherwise silently fail + ** If forth-wordlist is not in the search order, we won't find the prefixes. + */ + if (!pFW) + return FICL_FALSE; - assert(pFW); pHash = (FICL_HASH *)(pFW->param[0].p); /* ** Walk the list looking for a match with the beginning of the incoming token @@ -96,7 +100,8 @@ int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si) */ if (!strincmp(SI_PTR(si), pFW->name, (FICL_UNS)n)) { - vmSetTibIndex(pVM, vmGetTibIndex(pVM) - 1 - SI_COUNT(si) + n); + /* (sadler) fixed off-by-one error when the token has no trailing space in the TIB */ + vmSetTibIndex(pVM, si.cp + n - pVM->tib.cp ); vmExecute(pVM, pFW); return FICL_TRUE; @@ -118,7 +123,7 @@ static void tempBase(FICL_VM *pVM, int base) if (!ficlParseNumber(pVM, si)) { int i = SI_COUNT(si); - vmThrowErr(pVM, "0x%.*s is not a valid hex value", i, SI_PTR(si)); + vmThrowErr(pVM, "%.*s not recognized", i, SI_PTR(si)); } pVM->base = oldbase; @@ -168,6 +173,10 @@ void ficlCompilePrefix(FICL_SYSTEM *pSys) pHash->name = list_name; dictAppendWord(dp, list_name, constantParen, FW_DEFAULT); dictAppendCell(dp, LVALUEtoCELL(pHash)); + + /* + ** Put __tempbase in the forth-wordlist + */ dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT); /* @@ -178,7 +187,7 @@ void ficlCompilePrefix(FICL_SYSTEM *pSys) dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT); dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT); #if (FICL_EXTENDED_PREFIX) - pFW = ficlLookup("\\"); + pFW = ficlLookup(pSys, "\\"); if (pFW) { dictAppendWord(dp, "//", pFW->code, FW_DEFAULT); @@ -186,6 +195,5 @@ void ficlCompilePrefix(FICL_SYSTEM *pSys) #endif dp->pCompile = pPrevCompile; - ficlAddPrecompiledParseStep(pSys, "prefix?", ficlParsePrefix); return; } diff --git a/sys/boot/ficl/search.c b/sys/boot/ficl/search.c index 36844ea..d445cb3 100644 --- a/sys/boot/ficl/search.c +++ b/sys/boot/ficl/search.c @@ -4,7 +4,7 @@ ** ANS Forth SEARCH and SEARCH-EXT word-set written in C ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 6 June 2000 -** $Id: search.c,v 1.4 2001-04-26 21:41:31-07 jsadler Exp jsadler $ +** $Id: search.c,v 1.9 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -12,6 +12,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -34,13 +39,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: search.c,v 1.4 2001-04-26 21:41:31-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -59,7 +57,7 @@ **************************************************************************/ static void definitions(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); assert(pDict); if (pDict->nLists < 1) @@ -81,7 +79,7 @@ static void definitions(FICL_VM *pVM) **************************************************************************/ static void forthWordlist(FICL_VM *pVM) { - FICL_HASH *pHash = ficlGetDict()->pForthWords; + FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; stackPushPtr(pVM->pStack, pHash); return; } @@ -95,7 +93,7 @@ static void forthWordlist(FICL_VM *pVM) static void getCurrent(FICL_VM *pVM) { ficlLockDictionary(TRUE); - stackPushPtr(pVM->pStack, ficlGetDict()->pCompile); + stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile); ficlLockDictionary(FALSE); return; } @@ -111,7 +109,7 @@ static void getCurrent(FICL_VM *pVM) **************************************************************************/ static void getOrder(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); int nLists = pDict->nLists; int i; @@ -172,7 +170,7 @@ static void searchWordlist(FICL_VM *pVM) static void setCurrent(FICL_VM *pVM) { FICL_HASH *pHash = stackPopPtr(pVM->pStack); - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); ficlLockDictionary(TRUE); pDict->pCompile = pHash; ficlLockDictionary(FALSE); @@ -195,7 +193,7 @@ static void setOrder(FICL_VM *pVM) { int i; int nLists = stackPopINT(pVM->pStack); - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); if (nLists > FICL_DEFAULT_VOCS) { @@ -239,7 +237,7 @@ static void setOrder(FICL_VM *pVM) **************************************************************************/ static void ficlWordlist(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_HASH *pHash; FICL_UNS nBuckets; @@ -260,7 +258,7 @@ static void ficlWordlist(FICL_VM *pVM) **************************************************************************/ static void searchPop(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); int nLists; ficlLockDictionary(TRUE); @@ -282,7 +280,7 @@ static void searchPop(FICL_VM *pVM) **************************************************************************/ static void searchPush(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); ficlLockDictionary(TRUE); if (dp->nLists > FICL_DEFAULT_VOCS) @@ -304,7 +302,7 @@ static void widGetName(FICL_VM *pVM) { FICL_HASH *pHash = vmPop(pVM).p; char *cp = pHash->name; - int len = 0; + FICL_INT len = 0; if (cp) len = strlen(cp); @@ -382,9 +380,9 @@ void ficlCompileSearch(FICL_SYSTEM *pSys) /* ** Set SEARCH environment query values */ - ficlSetEnv("search-order", FICL_TRUE); - ficlSetEnv("search-order-ext", FICL_TRUE); - ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); + ficlSetEnv(pSys, "search-order", FICL_TRUE); + ficlSetEnv(pSys, "search-order-ext", FICL_TRUE); + ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS); dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT); dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT); diff --git a/sys/boot/ficl/softwords/ficlclass.fr b/sys/boot/ficl/softwords/ficlclass.fr new file mode 100644 index 0000000..6d75efb --- /dev/null +++ b/sys/boot/ficl/softwords/ficlclass.fr @@ -0,0 +1,86 @@ +\ #if (FICL_WANT_OOP) +\ ** ficl/softwords/ficlclass.fr +\ Classes to model ficl data structures in objects +\ This is a demo! +\ John Sadler 14 Sep 1998 +\ +\ ** C - W O R D +\ Models a FICL_WORD +\ +\ $FreeBSD$ + +object subclass c-word + c-word ref: .link + c-2byte obj: .hashcode + c-byte obj: .flags + c-byte obj: .nName + c-bytePtr obj: .pName + c-cellPtr obj: .pCode + c-4byte obj: .param0 + + \ Push word's name... + : get-name ( inst class -- c-addr u ) + 2dup + my=[ .pName get-ptr ] -rot + my=[ .nName get ] + ; + + : next ( inst class -- link-inst class ) + my=> .link ; + + : ? + ." c-word: " + 2dup --> get-name type cr + ; + +end-class + +\ ** C - W O R D L I S T +\ Models a FICL_HASH +\ Example of use: +\ get-current c-wordlist --> ref current +\ current --> ? +\ current --> .hash --> ? +\ current --> .hash --> next --> ? + +object subclass c-wordlist + c-wordlist ref: .parent + c-ptr obj: .name + c-cell obj: .size + c-word ref: .hash ( first entry in hash table ) + + : ? + --> get-name ." ficl wordlist " type cr ; + : push drop >search ; + : pop 2drop previous ; + : set-current drop set-current ; + : get-name drop wid-get-name ; + : words { 2:this -- } + this my=[ .size get ] 0 do + i this my=[ .hash index ] ( 2list-head ) + begin + 2dup --> get-name type space + --> next over + 0= until 2drop cr + loop + ; +end-class + +\ : named-wid wordlist postpone c-wordlist metaclass => ref ; + + +\ ** C - F I C L S T A C K +object subclass c-ficlstack + c-4byte obj: .nCells + c-cellPtr obj: .link + c-cellPtr obj: .sp + c-4byte obj: .stackBase + + : init 2drop ; + : ? 2drop + ." ficl stack " cr ; + : top + --> .sp --> .addr --> prev --> get ; +end-class + +\ #endif diff --git a/sys/boot/ficl/softwords/fileaccess.fr b/sys/boot/ficl/softwords/fileaccess.fr new file mode 100644 index 0000000..10ec5bd --- /dev/null +++ b/sys/boot/ficl/softwords/fileaccess.fr @@ -0,0 +1,26 @@ +\ #if FICL_WANT_FILE +\ ** +\ ** File Access words for ficl +\ ** submitted by Larry Hastings, larry@hastings.org +\ ** +\ +\ $FreeBSD$ + +: r/o 1 ; +: r/w 3 ; +: w/o 2 ; +: bin 8 or ; + +: included + r/o bin open-file 0= if + locals| f | end-locals + f include-file + f close-file drop + else + drop + endif + ; + +: include parse-word included ; immediate + +\ #endif diff --git a/sys/boot/ficl/softwords/forml.fr b/sys/boot/ficl/softwords/forml.fr new file mode 100644 index 0000000..1144ef5 --- /dev/null +++ b/sys/boot/ficl/softwords/forml.fr @@ -0,0 +1,75 @@ +\ examples from FORML conference paper Nov 98 +\ sadler +\ +\ $FreeBSD$ + +.( loading FORML examples ) cr +object --> sub c-example + cell: .cell0 + c-4byte obj: .nCells + 4 c-4byte array: .quad + c-byte obj: .length + 79 chars: .name + + : init ( inst class -- ) + 2dup object => init + s" aardvark" 2swap --> set-name + ; + + : get-name ( inst class -- c-addr u ) + 2dup + --> .name -rot ( c-addr inst class ) + --> .length --> get + ; + + : set-name { c-addr u 2:this -- } + u this --> .length --> set + c-addr this --> .name u move + ; + + : ? ( inst class ) c-example => get-name type cr ; +end-class + + +: test ." this is a test" cr ; +' test +c-word --> ref testref + +\ add a method to c-word... +c-word --> get-wid ficl-set-current +\ list dictionary thread +: list ( inst class ) + begin + 2dup --> get-name type cr + --> next over + 0= until + 2drop +; +set-current + +object subclass c-led + c-byte obj: .state + + : on { led# 2:this -- } + this --> .state --> get + 1 led# lshift or dup !oreg + this --> .state --> set + ; + + : off { led# 2:this -- } + this --> .state --> get + 1 led# lshift invert and dup !oreg + this --> .state --> set + ; + +end-class + + +object subclass c-switch + + : ?on { bit# 2:this -- flag } + + 1 bit# lshift + ; +end-class + diff --git a/sys/boot/ficl/softwords/ifbrack.fr b/sys/boot/ficl/softwords/ifbrack.fr index 2359e94..a8c6062 100644 --- a/sys/boot/ficl/softwords/ifbrack.fr +++ b/sys/boot/ficl/softwords/ifbrack.fr @@ -1,29 +1,22 @@ \ ** ficl/softwords/ifbrack.fr \ ** ANS conditional compile directives [if] [else] [then] \ ** Requires ficl 2.0 or greater... - +\ \ $FreeBSD$ hide : ?[if] ( c-addr u -- c-addr u flag ) - 2dup 2dup - s" [if]" compare 0= >r - s" [IF]" compare 0= r> - or + 2dup s" [if]" compare-insensitive 0= ; : ?[else] ( c-addr u -- c-addr u flag ) - 2dup 2dup - s" [else]" compare 0= >r - s" [ELSE]" compare 0= r> - or + 2dup s" [else]" compare-insensitive 0= ; : ?[then] ( c-addr u -- c-addr u flag ) - 2dup 2dup - s" [then]" compare 0= >r - s" [THEN]" compare 0= r> + 2dup s" [then]" compare-insensitive 0= >r + 2dup s" [endif]" compare-insensitive 0= r> or ; @@ -52,5 +45,6 @@ set-current 0= if postpone [else] then ; immediate : [then] ( -- ) ; immediate +: [endif] ( -- ) ; immediate previous diff --git a/sys/boot/ficl/softwords/marker.fr b/sys/boot/ficl/softwords/marker.fr index c80c2cf..ee3c9bd 100644 --- a/sys/boot/ficl/softwords/marker.fr +++ b/sys/boot/ficl/softwords/marker.fr @@ -2,6 +2,8 @@ \ ** Ficl implementation of CORE EXT MARKER \ John Sadler, 4 Oct 98 \ Requires ficl 2.02 FORGET-WID !! +\ +\ $FreeBSD$ : marker ( "name" -- ) create diff --git a/sys/boot/ficl/softwords/oo.fr b/sys/boot/ficl/softwords/oo.fr index 87ab576..9e6a04e 100644 --- a/sys/boot/ficl/softwords/oo.fr +++ b/sys/boot/ficl/softwords/oo.fr @@ -30,8 +30,7 @@ also oop definitions \ A ficl object binds instance storage (payload) to a class. \ object ( -- instance class ) \ All objects push their payload address and class address when -\ executed. All objects have this footprint: -\ cell 0: first payload cell +\ executed. \ A ficl class consists of a parent class pointer, a wordlist \ ID for the methods of the class, and a size for the payload @@ -43,9 +42,40 @@ also oop definitions \ cell 2: size of instance's payload \ Methods expect an object couple ( instance class ) -\ on the stack. +\ on the stack. This is by convention - ficl has no way to +\ police your code to make sure this is always done, but it +\ happens naturally if you use the facilities presented here. +\ \ Overridden methods must maintain the same stack signature as -\ their predecessors. Ficl has no way of enforcing this, though. +\ their predecessors. Ficl has no way of enforcing this, either. +\ +\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now +\ has an extra field for the vtable method count. Hasvtable declares +\ refs to vtable classes +\ +\ Revised Nov 2001 - metaclass debug method now finds only metaclass methods +\ +\ Planned: Ficl vtable support +\ Each class has a vtable size parameter +\ END-CLASS allocates and clears the vtable - then it walks class's method +\ list and inserts all new methods into table. For each method, if the table +\ slot is already nonzero, do nothing (overridden method). Otherwise fill +\ vtable slot. Now do same check for parent class vtable, filling only +\ empty slots in the new vtable. +\ Methods are now structured as follows: +\ - header +\ - vtable index +\ - xt +\ :noname definition for code +\ +\ : is redefined to check for override, fill in vtable index, increment method +\ count if not an override, create header and fill in index. Allot code pointer +\ and run :noname +\ ; is overridden to fill in xt returned by :noname +\ --> compiles code to fetch vtable address, offset by index, and execute +\ => looks up xt in the vtable and compiles it directly + + user current-class 0 current-class ! @@ -54,30 +84,38 @@ user current-class \ ** L A T E B I N D I N G \ Compile the method name, and code to find and \ execute it at run-time... -\ parse-method compiles the method name so that it pushes -\ the string base address and count at run-time. \ hide +\ p a r s e - m e t h o d +\ compiles a method name so that it pushes +\ the string base address and count at run-time. + : parse-method \ name run: ( -- c-addr u ) parse-word - postpone sliteral + postpone sliteral ; compile-only +\ l o o k u p - m e t h o d +\ takes a counted string method name from the stack (as compiled +\ by parse-method) and attempts to look this method up in the method list of +\ the class that's on the stack. If successful, it leaves the class on the stack +\ and pushes the xt of the method. If not, it aborts with an error message. + : lookup-method { class 2:name -- class xt } - name class cell+ @ ( c-addr u wid ) - search-wordlist ( 0 | xt 1 | xt -1 ) - 0= if - name type ." not found in " + name class cell+ @ ( c-addr u wid ) + search-wordlist ( 0 | xt 1 | xt -1 ) + 0= if + name type ." not found in " class body> >name type cr abort - endif + endif class swap ; : find-method-xt \ name ( class -- class xt ) - parse-word lookup-method + parse-word lookup-method ; set-current ( stop hiding definitions ) @@ -96,23 +134,28 @@ set-current ( stop hiding definitions ) \ : --> ( instance class -- ??? ) state @ 0= if - find-method-xt execute + find-method-xt execute else - parse-method postpone exec-method + parse-method postpone exec-method endif ; immediate \ Method lookup with CATCH in case of exceptions : c-> ( instance class -- ?? exc-flag ) state @ 0= if - find-method-xt catch + find-method-xt catch else - parse-method postpone catch-method + parse-method postpone catch-method endif ; immediate \ METHOD makes global words that do method invocations by late binding \ in case you prefer this style (no --> in your code) +\ Example: everything has next and prev for array access, so... +\ method next +\ method prev +\ my-instance next ( does whatever next does to my-instance by late binding ) + : method create does> body> >name lookup-method execute ; @@ -130,20 +173,30 @@ set-current ( stop hiding definitions ) instance-vars dup >search ficl-set-current : => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method - drop find-method-xt compile, drop + drop find-method-xt compile, drop ; immediate compile-only : my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class current-class @ dup postpone => ; immediate compile-only +\ Problem: my=[ assumes that each method except the last is am obj: member +\ which contains its class as the first field of its parameter area. The code +\ detects non-obect members and assumes the class does not change in this case. +\ This handles methods like index, prev, and next correctly, but does not deal +\ correctly with CLASS. : my=[ \ same as my=> , but binds a chain of methods current-class @ begin - parse-word 2dup - s" ]" compare while ( class c-addr u ) - lookup-method nip dup ( xt xt ) - compile, >body cell+ @ ( class' ) + parse-word 2dup ( class c-addr u c-addr u ) + s" ]" compare while ( class c-addr u ) + lookup-method ( class xt ) + dup compile, ( class xt ) + dup ?object if \ If object member, get new class. Otherwise assume same class + nip >body cell+ @ ( new-class ) + else + drop ( class ) + endif repeat 2drop drop ; immediate compile-only @@ -164,7 +217,7 @@ instance-vars dup >search ficl-set-current \ : do-instance-var does> ( instance class addr[offset] -- addr[field] ) - nip @ + + nip @ + ; : addr-units: ( offset size "name" -- offset' ) @@ -172,14 +225,14 @@ instance-vars dup >search ficl-set-current do-instance-var ; -: chars: \ ( offset nCells "name" -- offset' ) Create n char member. +: chars: \ ( offset nCells "name" -- offset' ) Create n char member. chars addr-units: ; -: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. +: char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 1 chars: ; : cells: ( offset nCells "name" -- offset' ) - cells >r aligned r> addr-units: + cells >r aligned r> addr-units: ; : cell: ( offset nCells "name" -- offset' ) @@ -190,17 +243,17 @@ instance-vars dup >search ficl-set-current \ Example: object obj: m_obj \ : do-aggregate - does> ( instance class pfa -- a-instance a-class ) - 2@ ( inst class a-class a-offset ) - 2swap drop ( a-class a-offset inst ) - + swap ( a-inst a-class ) + objectify + does> ( instance class pfa -- a-instance a-class ) + 2@ ( inst class a-class a-offset ) + 2swap drop ( a-class a-offset inst ) + + swap ( a-inst a-class ) ; -: obj: ( offset class meta "name" -- offset' ) - locals| meta class offset | +: obj: { offset class meta -- offset' } \ "name" create offset , class , - class meta --> get-size offset + - do-aggregate + class meta --> get-size offset + + do-aggregate ; \ Aggregate an array of objects into a class @@ -210,10 +263,10 @@ instance-vars dup >search ficl-set-current \ named my-array. \ : array: ( offset n class meta "name" -- offset' ) - locals| meta class nobjs offset | - create offset , class , - class meta --> get-size nobjs * offset + - do-aggregate + locals| meta class nobjs offset | + create offset , class , + class meta --> get-size nobjs * offset + + do-aggregate ; \ Aggregate a pointer to an object: REF is a member variable @@ -223,13 +276,35 @@ instance-vars dup >search ficl-set-current \ in classes.fr. REF is only useful for pre-initialized structures, \ since there's no supported way to set one. : ref: ( offset class meta "name" -- offset' ) - locals| meta class offset | - create offset , class , - offset cell+ - does> ( inst class pfa -- ptr-inst ptr-class ) - 2@ ( inst class ptr-class ptr-offset ) - 2swap drop + @ swap + locals| meta class offset | + create offset , class , + offset cell+ + does> ( inst class pfa -- ptr-inst ptr-class ) + 2@ ( inst class ptr-class ptr-offset ) + 2swap drop + @ swap +; + +\ #if FICL_WANT_VCALL +\ vcall extensions contributed by Guy Carver +: vcall: ( paramcnt "name" -- ) + current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. + create , , \ ( paramcnt index -- ) + does> \ ( inst class pfa -- ptr-inst ptr-class ) + nip 2@ vcall \ ( params offset inst class offset -- ) +; + +: vcallr: 0x80000000 or vcall: ; \ Call with return address desired. + +\ #if FICL_WANT_FLOAT +: vcallf: \ ( paramcnt -<name>- f: r ) + 0x80000000 or + current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined. + create , , \ ( paramcnt index -- ) + does> \ ( inst class pfa -- ptr-inst ptr-class ) + nip 2@ vcall f> \ ( params offset inst class offset -- f: r ) ; +\ #endif /* FLOAT */ +\ #endif /* VCALL */ \ END-CLASS terminates construction of a class by storing \ the size of its instance variables in the class's size field @@ -237,7 +312,7 @@ instance-vars dup >search ficl-set-current \ : end-class ( old-wid addr[size] size -- ) swap ! set-current - search> drop \ pop struct builder wordlist + search> drop \ pop struct builder wordlist ; \ See resume-class (a metaclass method) below for usage @@ -256,7 +331,7 @@ set-current previous \ the wordlist of every class by the SUB method. \ PRECONDITION: current-class contains the class address \ why use a state variable instead of the stack? -\ >> Stack state is not well-defined during compilation (there are +\ >> Stack state is not well-defined during compilation (there are \ >> control structure match codes on the stack, of undefined size \ >> easiest way around this is use of this thread-local variable \ @@ -274,14 +349,18 @@ set-current previous \ See above... \ :noname - wordlist - create + wordlist + create immediate - 0 , \ NULL parent class - dup , \ wid - 3 cells , \ instance size - ficl-set-current - does> dup + 0 , \ NULL parent class + dup , \ wid +\ #if FICL_WANT_VCALL + 4 cells , \ instance size +\ #else + 3 cells , \ instance size +\ #endif + ficl-set-current + does> dup ; execute metaclass \ now brand OBJECT's wordlist (so that ORDER can display it by name) metaclass drop cell+ @ brand-wordlist @@ -300,19 +379,31 @@ create .super ( class metaclass -- parent-class ) create .wid ( class metaclass -- wid ) \ return wid of class 1 cells , do-instance-var +\ #if FICL_WANT_VCALL +create .vtCount \ Number of VTABLE methods, if any + 2 cells , do-instance-var + +create .size ( class metaclass -- size ) \ return class's payload size + 3 cells , do-instance-var +\ #else create .size ( class metaclass -- size ) \ return class's payload size 2 cells , do-instance-var +\ #endif : get-size metaclass => .size @ ; : get-wid metaclass => .wid @ ; : get-super metaclass => .super @ ; +\ #if FICL_WANT_VCALL +: get-vtCount metaclass => .vtCount @ ; +: get-vtAdd metaclass => .vtCount ; +\ #endif \ create an uninitialized instance of a class, leaving \ the address of the new instance and its class \ : instance ( class metaclass "name" -- instance class ) locals| meta parent | - create + create here parent --> .do-instance \ ( inst class ) parent meta metaclass => get-size allot \ allocate payload space @@ -321,10 +412,10 @@ create .size ( class metaclass -- size ) \ return class's payload size \ create an uninitialized array : array ( n class metaclass "name" -- n instance class ) locals| meta parent nobj | - create nobj + create nobj here parent --> .do-instance \ ( nobj inst class ) parent meta metaclass => get-size - nobj * allot \ allocate payload space + nobj * allot \ allocate payload space ; \ create an initialized instance @@ -335,8 +426,8 @@ create .size ( class metaclass -- size ) \ return class's payload size \ create an initialized array of instances : new-array ( n class metaclass "name" -- ) - metaclass => array - --> array-init + metaclass => array + --> array-init ; \ Create an anonymous initialized instance from the heap @@ -406,19 +497,22 @@ create .size ( class metaclass -- size ) \ return class's payload size \ Postcondition: leaves the address of the new class in current-class : sub ( class metaclass "name" -- old-wid addr[size] size ) wordlist - locals| wid meta parent | - parent meta metaclass => get-wid - wid wid-set-super \ set superclass - create immediate \ get the subclass name + locals| wid meta parent | + parent meta metaclass => get-wid + wid wid-set-super \ set superclass + create immediate \ get the subclass name wid brand-wordlist \ label the subclass wordlist - here current-class ! \ prep for do-do-instance - parent , \ save parent class - wid , \ save wid - here parent meta --> get-size dup , ( addr[size] size ) - metaclass => .do-instance - wid ficl-set-current -rot - do-do-instance - instance-vars >search \ push struct builder wordlist + here current-class ! \ prep for do-do-instance + parent , \ save parent class + wid , \ save wid +\ #if FICL_WANT_VCALL + parent meta --> get-vtCount , +\ #endif + here parent meta --> get-size dup , ( addr[size] size ) + metaclass => .do-instance + wid ficl-set-current -rot + do-do-instance + instance-vars >search \ push struct builder wordlist ; \ OFFSET-OF returns the offset of an instance variable @@ -430,34 +524,39 @@ create .size ( class metaclass -- size ) \ return class's payload size \ ID returns the string name cell-pair of its class : id ( class metaclass -- c-addr u ) - drop body> >name ; + drop body> >name ; \ list methods of the class : methods \ ( class meta -- ) - locals| meta class | - begin - class body> >name type ." methods:" cr - class meta --> get-wid >search words cr previous - class meta metaclass => get-super - dup to class - 0= until cr + locals| meta class | + begin + class body> >name type ." methods:" cr + class meta --> get-wid >search words cr previous + class meta metaclass => get-super + dup to class + 0= until cr ; \ list class's ancestors : pedigree ( class meta -- ) - locals| meta class | - begin - class body> >name type space - class meta metaclass => get-super - dup to class - 0= until cr + locals| meta class | + begin + class body> >name type space + class meta metaclass => get-super + dup to class + 0= until cr ; -\ decompile a method +\ decompile an instance method : see ( class meta -- ) metaclass => get-wid >search see previous ; -previous set-current +\ debug a method of metaclass +\ Eg: my-class --> debug my-method +: debug ( class meta -- ) + find-method-xt debug-xt ; + +previous set-current \ E N D M E T A C L A S S \ ** META is a nickname for the address of METACLASS... @@ -469,18 +568,24 @@ constant meta \ This method is late bound for safety... : subclass --> sub ; +\ #if FICL_WANT_VCALL +\ VTABLE Support extensions (Guy Carver) +\ object --> sub mine hasvtable +: hasvtable 4 + ; immediate +\ #endif + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** O B J E C T \ Root of all classes :noname - wordlist - create immediate - 0 , \ NULL parent class - dup , \ wid - 0 , \ instance size - ficl-set-current - does> meta + wordlist + create immediate + 0 , \ NULL parent class + dup , \ wid + 0 , \ instance size + ficl-set-current + does> meta ; execute object \ now brand OBJECT's wordlist (so that ORDER can display it by name) object drop cell+ @ brand-wordlist @@ -493,7 +598,7 @@ instance-vars >search \ Convert instance cell-pair to class cell-pair \ Useful for binding class methods from an instance : class ( instance class -- class metaclass ) - nip meta ; + nip meta ; \ default INIT method zero fills an instance : init ( instance class -- ) @@ -504,26 +609,26 @@ instance-vars >search \ Apply INIT to an array of NOBJ objects... \ : array-init ( nobj inst class -- ) - 0 dup locals| &init &next class inst | - \ - \ bind methods outside the loop to save time - \ - class s" init" lookup-method to &init - s" next" lookup-method to &next - drop - 0 ?do - inst class 2dup - &init execute - &next execute drop to inst - loop + 0 dup locals| &init &next class inst | + \ + \ bind methods outside the loop to save time + \ + class s" init" lookup-method to &init + s" next" lookup-method to &next + drop + 0 ?do + inst class 2dup + &init execute + &next execute drop to inst + loop ; \ free storage allocated to a heap instance by alloc or alloc-array \ NOTE: not protected against errors like FREEing something that's \ really in the dictionary. : free \ ( instance class -- ) - drop free - abort" free failed " + drop free + abort" free failed " ; \ Instance aliases for common class methods @@ -532,15 +637,15 @@ instance-vars >search meta metaclass => get-super ; : pedigree ( instance class -- ) - object => class + object => class metaclass => pedigree ; : size ( instance class -- sizeof-instance ) - object => class + object => class metaclass => get-size ; : methods ( instance class -- ) - object => class + object => class metaclass => methods ; \ Array indexing methods... @@ -549,27 +654,27 @@ instance-vars >search \ obj --> next \ : index ( n instance class -- instance[n] class ) - locals| class inst | - inst class + locals| class inst | + inst class object => class - metaclass => get-size * ( n*size ) - inst + class ; + metaclass => get-size * ( n*size ) + inst + class ; : next ( instance[n] class -- instance[n+1] class ) - locals| class inst | - inst class + locals| class inst | + inst class object => class - metaclass => get-size - inst + - class ; + metaclass => get-size + inst + + class ; : prev ( instance[n] class -- instance[n-1] class ) - locals| class inst | - inst class + locals| class inst | + inst class object => class - metaclass => get-size - inst swap - - class ; + metaclass => get-size + inst swap - + class ; : debug ( 2this -- ?? ) find-method-xt debug-xt ; @@ -577,6 +682,12 @@ instance-vars >search previous set-current \ E N D O B J E C T - +\ reset to default search order only definitions + +\ redefine oop in default search order to put OOP words in the search order and make them +\ the compiling wordlist... + +: oo only also oop definitions ; + \ #endif diff --git a/sys/boot/ficl/softwords/prefix.fr b/sys/boot/ficl/softwords/prefix.fr index d7b79a9..53a1d54 100644 --- a/sys/boot/ficl/softwords/prefix.fr +++ b/sys/boot/ficl/softwords/prefix.fr @@ -4,7 +4,7 @@ \ ** \ (jws) To make a prefix, simply create a new definition in the <prefixes> \ wordlist. start-prefixes and end-prefixes handle the bookkeeping - +\ \ $FreeBSD$ variable save-current diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr index 17844a8..a70ebaa 100644 --- a/sys/boot/ficl/softwords/softcore.fr +++ b/sys/boot/ficl/softwords/softcore.fr @@ -2,12 +2,11 @@ \ ** FICL soft extensions \ ** John Sadler (john_sadler@alum.mit.edu) \ ** September, 1998 - +\ \ $FreeBSD$ \ ** Ficl USER variables \ ** See words.c for primitive def'n of USER - \ #if FICL_WANT_USER variable nUser 0 nUser ! : user \ name ( -- ) @@ -35,7 +34,6 @@ decimal 32 constant bl state @ if postpone if postpone ." -\ postpone type postpone cr -2 postpone literal @@ -60,7 +58,11 @@ false invert constant true : <> = 0= ; : 0<> 0= 0= ; : compile, , ; +: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970 : erase ( addr u -- ) 0 fill ; +variable span +: expect ( c-addr u1 -- ) accept span ! ; +\ see marker.fr for MARKER implementation : nip ( y x -- x ) swap drop ; : tuck ( y x -- x y x) swap over ; : within ( test low high -- flag ) over - >r - r> u< ; @@ -168,7 +170,35 @@ set-current \ stop hiding words ." Compile: " get-current list-wid cr ; -: debug ' debug-xt ; +: debug ' debug-xt ; immediate +: on-step ." S: " .s cr ; + + +\ Submitted by lch. +: strdup ( c-addr length -- c-addr2 length2 ior ) + 0 locals| addr2 length c-addr | end-locals + length 1 + allocate + 0= if + to addr2 + c-addr addr2 length move + addr2 length 0 + else + 0 -1 + endif + ; + +: strcat ( 2:a 2:b -- 2:new-a ) + 0 locals| b-length b-u b-addr a-u a-addr | end-locals + b-u to b-length + b-addr a-addr a-u + b-length move + a-addr a-u b-length + + ; + +: strcpy ( 2:a 2:b -- 2:new-a ) + locals| b-u b-addr a-u a-addr | end-locals + a-addr 0 b-addr b-u strcat + ; + previous \ lose hidden words from search order diff --git a/sys/boot/ficl/stack.c b/sys/boot/ficl/stack.c index ab0ab46..f98a3b6 100644 --- a/sys/boot/ficl/stack.c +++ b/sys/boot/ficl/stack.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 16 Oct 1997 -** $Id: stack.c,v 1.5 2001-04-26 21:41:29-07 jsadler Exp jsadler $ +** $Id: stack.c,v 1.10 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -11,6 +11,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -33,13 +38,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: stack.c,v 1.5 2001-04-26 21:41:29-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -299,7 +297,7 @@ void stackPushINT(FICL_STACK *pStack, FICL_INT i) } #if (FICL_WANT_FLOAT) -void stackPushFloat(FICL_STACK *pStack, float f) +void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f) { *pStack->sp++ = LVALUEtoCELL(f); } diff --git a/sys/boot/ficl/testmain.c b/sys/boot/ficl/testmain.c index cd4da7e..7167f30 100644 --- a/sys/boot/ficl/testmain.c +++ b/sys/boot/ficl/testmain.c @@ -1,6 +1,40 @@ /* -** stub main for testing FICL under Win32 -** $Id: testmain.c,v 1.6 2000-06-17 07:43:50-07 jsadler Exp jsadler $ +** stub main for testing FICL under userland +** $Id: testmain.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $ +*/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. */ /* $FreeBSD$ */ @@ -24,7 +58,7 @@ static void ficlGetCWD(FICL_VM *pVM) { char *cp; - cp = getcwd(NULL, 80); + cp = getcwd(NULL, 80); vmTextOut(pVM, cp, 1); free(cp); return; @@ -62,7 +96,7 @@ static void ficlChDir(FICL_VM *pVM) ** Gets a newline (or NULL) delimited string from the input ** and feeds it to system() ** Example: -** system del *.* +** system rm -rf / ** \ ouch! */ static void ficlSystem(FICL_VM *pVM) @@ -150,10 +184,10 @@ static void ficlLoad(FICL_VM *pVM) 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; + pVM->sourceID = id; + fclose(fp); + vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine); + break; } } /* @@ -166,6 +200,9 @@ static void ficlLoad(FICL_VM *pVM) pVM->sourceID = id; fclose(fp); + /* handle "bye" in loaded files. --lch */ + if (result == VM_USEREXIT) + vmThrow(pVM, VM_USEREXIT); return; } @@ -175,7 +212,7 @@ static void ficlLoad(FICL_VM *pVM) */ static void spewHash(FICL_VM *pVM) { - FICL_HASH *pHash = ficlGetDict()->pForthWords; + FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; FICL_WORD *pFW; FILE *pOut; unsigned i; @@ -252,18 +289,18 @@ static void execxt(FICL_VM *pVM) } -void buildTestInterface(void) +void buildTestInterface(FICL_SYSTEM *pSys) { - ficlBuild("break", ficlBreak, FW_DEFAULT); - ficlBuild("clock", ficlClock, FW_DEFAULT); - ficlBuild("cd", ficlChDir, FW_DEFAULT); - ficlBuild("execxt", execxt, FW_DEFAULT); - ficlBuild("load", ficlLoad, FW_DEFAULT); - ficlBuild("pwd", ficlGetCWD, FW_DEFAULT); - ficlBuild("system", ficlSystem, FW_DEFAULT); - ficlBuild("spewhash", spewHash, FW_DEFAULT); - ficlBuild("clocks/sec", - clocksPerSec, FW_DEFAULT); + ficlBuild(pSys, "break", ficlBreak, FW_DEFAULT); + ficlBuild(pSys, "clock", ficlClock, FW_DEFAULT); + ficlBuild(pSys, "cd", ficlChDir, FW_DEFAULT); + ficlBuild(pSys, "execxt", execxt, FW_DEFAULT); + ficlBuild(pSys, "load", ficlLoad, FW_DEFAULT); + ficlBuild(pSys, "pwd", ficlGetCWD, FW_DEFAULT); + ficlBuild(pSys, "system", ficlSystem, FW_DEFAULT); + ficlBuild(pSys, "spewhash", spewHash, FW_DEFAULT); + ficlBuild(pSys, "clocks/sec", + clocksPerSec, FW_DEFAULT); return; } @@ -273,12 +310,13 @@ int main(int argc, char **argv) { char in[256]; FICL_VM *pVM; + FICL_SYSTEM *pSys; - ficlInitSystem(10000); - buildTestInterface(); - pVM = ficlNewVM(); + pSys = ficlInitSystem(10000); + buildTestInterface(pSys); + pVM = ficlNewVM(pSys); - ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit"); + ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit"); /* ** load file from cmd line... @@ -286,7 +324,7 @@ int main(int argc, char **argv) if (argc > 1) { sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]); - ficlExec(pVM, in); + ficlEvaluate(pVM, in); } for (;;) @@ -297,7 +335,7 @@ int main(int argc, char **argv) ret = ficlExec(pVM, in); if (ret == VM_USEREXIT) { - ficlTermSystem(); + ficlTermSystem(pSys); break; } } diff --git a/sys/boot/ficl/tools.c b/sys/boot/ficl/tools.c index 0fc1a88..dc321f8 100644 --- a/sys/boot/ficl/tools.c +++ b/sys/boot/ficl/tools.c @@ -3,27 +3,19 @@ ** Forth Inspired Command Language - programming tools ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 20 June 2000 -** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $ +** $Id: tools.c,v 1.11 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* -** NOTES: -** SEE needs information about the addresses of functions that -** are the CFAs of colon definitions, constants, variables, DOES> -** words, and so on. It gets this information from a table and supporting -** functions in words.c. -** colonParen doDoes createParen variableParen userParen constantParen -** -** Step and break debugger for Ficl -** debug ( xt -- ) Start debugging an xt -** Set a breakpoint -** Specify breakpoint default action -*/ -/* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) ** All rights reserved. ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -46,13 +38,20 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. +*/ + +/* +** NOTES: +** SEE needs information about the addresses of functions that +** are the CFAs of colon definitions, constants, variables, DOES> +** words, and so on. It gets this information from a table and supporting +** functions in words.c. +** colonParen doDoes createParen variableParen userParen constantParen ** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $ +** Step and break debugger for Ficl +** debug ( xt -- ) Start debugging an xt +** Set a breakpoint +** Specify breakpoint default action */ /* $FreeBSD$ */ @@ -74,51 +73,45 @@ ** for the STEP command. The rest are user programmable. */ #define nBREAKPOINTS 32 -#endif -/* -** BREAKPOINT record. -** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt -** that the breakpoint overwrote. This is restored to the dictionary when the -** BP executes or gets cleared -** address - the location of the breakpoint (address of the instruction that -** has been replaced with the breakpoint trap -** origXT - The original contents of the location with the breakpoint -** Note: address is NULL when this breakpoint is empty -*/ -typedef struct breakpoint -{ - void *address; - FICL_WORD *origXT; -} BREAKPOINT; +#endif -static BREAKPOINT bpStep = {NULL, NULL}; -/* -** vmSetBreak - set a breakpoint at the current value of IP by +/************************************************************************** + v m S e t B r e a k +** Set a breakpoint at the current value of IP by ** storing that address in a BREAKPOINT record -*/ -static void vmSetBreak(FICL_VM *pVM, BREAKPOINT *pBP) +**************************************************************************/ +static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP) { - FICL_WORD *pStep = ficlLookup("step-break"); + FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break"); assert(pStep); + pBP->address = pVM->ip; pBP->origXT = *pVM->ip; *pVM->ip = pStep; } -/* -** isAFiclWord +/************************************************************************** +** d e b u g P r o m p t +**************************************************************************/ +static void debugPrompt(FICL_VM *pVM) +{ + vmTextOut(pVM, "dbg> ", 0); +} + + +/************************************************************************** +** i s A F i c l W o r d ** Vet a candidate pointer carefully to make sure ** it's not some chunk o' inline data... ** It has to have a name, and it has to look ** like it's in the dictionary address range. ** NOTE: this excludes :noname words! -*/ -int isAFiclWord(FICL_WORD *pFW) +**************************************************************************/ +int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW) { - FICL_DICT *pd = ficlGetDict(); if (!dictIncludes(pd, pFW)) return 0; @@ -126,15 +119,56 @@ int isAFiclWord(FICL_WORD *pFW) if (!dictIncludes(pd, pFW->name)) return 0; - return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0')); + if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link)) + return 0; + + if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0')) + return 0; + + if (strlen(pFW->name) != pFW->nName) + return 0; + + return 1; } +#if 0 static int isPrimitive(FICL_WORD *pFW) { WORDKIND wk = ficlWordClassify(pFW); return ((wk != COLON) && (wk != DOES)); } +#endif + + +/************************************************************************** + f i n d E n c l o s i n g W o r d +** Given a pointer to something, check to make sure it's an address in the +** dictionary. If so, search backwards until we find something that looks +** like a dictionary header. If successful, return the address of the +** FICL_WORD found. Otherwise return NULL. +** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up +**************************************************************************/ +#define nSEARCH_CELLS 100 + +static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp) +{ + FICL_WORD *pFW; + FICL_DICT *pd = vmGetDict(pVM); + int i; + + if (!dictIncludes(pd, (void *)cp)) + return NULL; + + for (i = nSEARCH_CELLS; i > 0; --i, --cp) + { + pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL))); + if (isAFiclWord(pd, pFW)) + return pFW; + } + + return NULL; +} /************************************************************************** @@ -144,8 +178,6 @@ static int isPrimitive(FICL_WORD *pFW) ** The source of the representation (object-code decompilation, source ** block, etc.) and the particular form of the display is implementation ** defined. -** NOTE: these funcs come late in the file because they reference all -** of the word-builder funcs without declaring them again. Call me lazy. **************************************************************************/ /* ** seeColon (for proctologists only) @@ -154,17 +186,24 @@ static int isPrimitive(FICL_WORD *pFW) */ static void seeColon(FICL_VM *pVM, CELL *pc) { - static FICL_WORD *pSemiParen = NULL; - - if (!pSemiParen) - pSemiParen = ficlLookup("(;)"); + char *cp; + CELL *param0 = pc; + FICL_DICT *pd = vmGetDict(pVM); + FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)"); assert(pSemiParen); for (; pc->p != pSemiParen; pc++) { FICL_WORD *pFW = (FICL_WORD *)(pc->p); - if (isAFiclWord(pFW)) + cp = pVM->pad; + if ((void *)pc == (void *)pVM->ip) + *cp++ = '>'; + else + *cp++ = ' '; + cp += sprintf(cp, "%3d ", pc-param0); + + if (isAFiclWord(pd, pFW)) { WORDKIND kind = ficlWordClassify(pFW); CELL c; @@ -173,65 +212,72 @@ static void seeColon(FICL_VM *pVM, CELL *pc) { case LITERAL: c = *++pc; - if (isAFiclWord(c.p)) + if (isAFiclWord(pd, c.p)) { FICL_WORD *pLit = (FICL_WORD *)c.p; - sprintf(pVM->pad, " literal %.*s (%#lx)", + sprintf(cp, "%.*s ( %#lx literal )", pLit->nName, pLit->name, c.u); } else - sprintf(pVM->pad, " literal %ld (%#lx)", c.i, c.u); + sprintf(cp, "literal %ld (%#lx)", c.i, c.u); break; case STRINGLIT: { FICL_STRING *sp = (FICL_STRING *)(void *)++pc; pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; - sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text); + sprintf(cp, "s\" %.*s\"", sp->count, sp->text); + } + break; + case CSTRINGLIT: + { + FICL_STRING *sp = (FICL_STRING *)(void *)++pc; + pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; + sprintf(cp, "c\" %.*s\"", sp->count, sp->text); } break; case IF: c = *++pc; if (c.i > 0) - sprintf(pVM->pad, " if / while (branch rel %ld)", c.i); + sprintf(cp, "if / while (branch %d)", pc+c.i-param0); else - sprintf(pVM->pad, " until (branch rel %ld)", c.i); - break; + sprintf(cp, "until (branch %d)", pc+c.i-param0); + break; case BRANCH: c = *++pc; if (c.i > 0) - sprintf(pVM->pad, " else (branch rel %ld)", c.i); + sprintf(cp, "else (branch %d)", pc+c.i-param0); else - sprintf(pVM->pad, " repeat (branch rel %ld)", c.i); + sprintf(cp, "repeat (branch %d)", pc+c.i-param0); break; case QDO: c = *++pc; - sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); + sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0); break; case DO: c = *++pc; - sprintf(pVM->pad, " do (leave abs %#lx)", c.u); + sprintf(cp, "do (leave %d)", (CELL *)c.p-param0); break; case LOOP: c = *++pc; - sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); + sprintf(cp, "loop (branch %d)", pc+c.i-param0); break; case PLOOP: c = *++pc; - sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); + sprintf(cp, "+loop (branch %d)", pc+c.i-param0); break; default: - sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); + sprintf(cp, "%.*s", pFW->nName, pFW->name); break; } - vmTextOut(pVM, pVM->pad, 1); } else /* probably not a word - punt and print value */ { - sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u); - vmTextOut(pVM, pVM->pad, 1); + sprintf(cp, "%ld ( %#lx )", pc->i, pc->u); } + + vmTextOut(pVM, pVM->pad, 1); } vmTextOut(pVM, ";", 1); @@ -275,17 +321,20 @@ static void seeXT(FICL_VM *pVM) 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: - vmTextOut(pVM, "primitive", 1); + sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name); + vmTextOut(pVM, pVM->pad, 1); break; } @@ -323,9 +372,6 @@ void ficlDebugXT(FICL_VM *pVM) { FICL_WORD *xt = stackPopPtr(pVM->pStack); WORDKIND wk = ficlWordClassify(xt); - FICL_WORD *pStep = ficlLookup("step-break"); - - assert(pStep); stackPushPtr(pVM->pStack, xt); seeXT(pVM); @@ -338,9 +384,7 @@ void ficlDebugXT(FICL_VM *pVM) ** Run the colon code and set a breakpoint at the next instruction */ vmExecute(pVM, xt); - bpStep.address = pVM->ip; - bpStep.origXT = *pVM->ip; - *pVM->ip = pStep; + vmSetBreak(pVM, &(pVM->pSys->bpStep)); break; default: @@ -370,7 +414,7 @@ void stepIn(FICL_VM *pVM) /* ** Now set a breakpoint at the next instruction */ - vmSetBreak(pVM, &bpStep); + vmSetBreak(pVM, &(pVM->pSys->bpStep)); return; } @@ -387,7 +431,7 @@ void stepOver(FICL_VM *pVM) { FICL_WORD *pFW; WORDKIND kind; - FICL_WORD *pStep = ficlLookup("step-break"); + FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break"); assert(pStep); pFW = *pVM->ip; @@ -401,8 +445,8 @@ void stepOver(FICL_VM *pVM) ** assume that the next cell holds an instruction ** set a breakpoint there and return to the inner interp */ - bpStep.address = pVM->ip + 1; - bpStep.origXT = pVM->ip[1]; + pVM->pSys->bpStep.address = pVM->ip + 1; + pVM->pSys->bpStep.origXT = pVM->ip[1]; pVM->ip[1] = pStep; break; @@ -439,37 +483,37 @@ void stepBreak(FICL_VM *pVM) if (!pVM->fRestart) { - - assert(bpStep.address != NULL); + assert(pVM->pSys->bpStep.address); + assert(pVM->pSys->bpStep.origXT); /* ** Clear the breakpoint that caused me to run ** Restore the original instruction at the breakpoint, ** and restore the IP */ - assert(bpStep.address); - assert(bpStep.origXT); - - pVM->ip = (IPTYPE)bpStep.address; - *pVM->ip = bpStep.origXT; + pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address); + *pVM->ip = pVM->pSys->bpStep.origXT; /* ** If there's an onStep, do it */ - pOnStep = ficlLookup("on-step"); + pOnStep = ficlLookup(pVM->pSys, "on-step"); if (pOnStep) ficlExecXT(pVM, pOnStep); /* ** Print the name of the next instruction */ - pFW = bpStep.origXT; + pFW = pVM->pSys->bpStep.origXT; sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name); +#if 0 if (isPrimitive(pFW)) { - strcat(pVM->pad, " primitive"); + strcat(pVM->pad, " ( primitive )"); } +#endif vmTextOut(pVM, pVM->pad, 1); + debugPrompt(pVM); } else { @@ -486,21 +530,60 @@ void stepBreak(FICL_VM *pVM) { return; } + else if (!strincmp(si.cp, "l", si.count)) + { + FICL_WORD *xt; + xt = findEnclosingWord(pVM, (CELL *)(pVM->ip)); + if (xt) + { + stackPushPtr(pVM->pStack, xt); + seeXT(pVM); + } + else + { + vmTextOut(pVM, "sorry - can't do that", 1); + } + vmThrow(pVM, VM_RESTART); + } else if (!strincmp(si.cp, "o", si.count)) { stepOver(pVM); } else if (!strincmp(si.cp, "q", si.count)) { + ficlTextOut(pVM, FICL_PROMPT, 0); vmThrow(pVM, VM_ABORT); } + else if (!strincmp(si.cp, "x", si.count)) + { + /* + ** Take whatever's left in the TIB and feed it to a subordinate ficlExec + */ + int ret; + char *cp = pVM->tib.cp + pVM->tib.index; + int count = pVM->tib.end - cp; + FICL_WORD *oldRun = pVM->runningWord; + + ret = ficlExecC(pVM, cp, count); + + if (ret == VM_OUTOFTEXT) + { + ret = VM_RESTART; + pVM->runningWord = oldRun; + vmTextOut(pVM, "", 1); + } + + vmThrow(pVM, ret); + } else { vmTextOut(pVM, "i -- step In", 1); vmTextOut(pVM, "o -- step Over", 1); vmTextOut(pVM, "g -- Go (execute to completion)", 1); + vmTextOut(pVM, "l -- List source code", 1); vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1); - vmTextOut(pVM, "x -- eXecute a single word", 1); + vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1); + debugPrompt(pVM); vmThrow(pVM, VM_RESTART); } @@ -526,9 +609,10 @@ static void bye(FICL_VM *pVM) ** TOOLS ** Display the parameter stack (code for ".s") **************************************************************************/ -static void displayStack(FICL_VM *pVM) +static void displayPStack(FICL_VM *pVM) { - int d = stackDepth(pVM->pStack); + FICL_STACK *pStk = pVM->pStack; + int d = stackDepth(pStk); int i; CELL *pCell; @@ -538,34 +622,58 @@ static void displayStack(FICL_VM *pVM) vmTextOut(pVM, "(Stack Empty) ", 0); else { - pCell = pVM->pStack->base; + pCell = pStk->base; for (i = 0; i < d; i++) { vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0); vmTextOut(pVM, " ", 0); } } + return; } static void displayRStack(FICL_VM *pVM) { - int d = stackDepth(pVM->rStack); + FICL_STACK *pStk = pVM->rStack; + int d = stackDepth(pStk); int i; CELL *pCell; + FICL_DICT *dp = vmGetDict(pVM); + + vmCheckStack(pVM, 0, 0); - vmTextOut(pVM, "Return Stack: ", 0); if (d == 0) - vmTextOut(pVM, "Empty ", 0); + vmTextOut(pVM, "(Stack Empty) ", 0); else { - pCell = pVM->rStack->base; + pCell = pStk->base; for (i = 0; i < d; i++) { - vmTextOut(pVM, ultoa((*pCell++).i, pVM->pad, 16), 0); + CELL c = *pCell++; + /* + ** Attempt to find the word that contains the + ** stacked address (as if it is part of a colon definition). + ** If this works, print the name of the word. Otherwise print + ** the value as a number. + */ + if (dictIncludes(dp, c.p)) + { + FICL_WORD *pFW = findEnclosingWord(pVM, c.p); + if (pFW) + { + int offset = (CELL *)c.p - &pFW->param[0]; + sprintf(pVM->pad, "%s+%d ", pFW->name, offset); + vmTextOut(pVM, pVM->pad, 0); + continue; /* no need to print the numeric value */ + } + } + vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0); vmTextOut(pVM, " ", 0); } } + + return; } @@ -575,7 +683,7 @@ static void displayRStack(FICL_VM *pVM) **************************************************************************/ static void forgetWid(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); FICL_HASH *pHash; pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); @@ -600,7 +708,7 @@ static void forgetWid(FICL_VM *pVM) static void forget(FICL_VM *pVM) { void *where; - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); FICL_HASH *pHash = pDict->pCompile; ficlTick(pVM); @@ -619,7 +727,7 @@ static void forget(FICL_VM *pVM) #define nCOLWIDTH 8 static void listWords(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; FICL_WORD *wp; int nChars = 0; @@ -696,7 +804,7 @@ static void listWords(FICL_VM *pVM) **************************************************************************/ static void listEnv(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetEnv(); + FICL_DICT *dp = pVM->pSys->envp; FICL_HASH *pHash = dp->pForthWords; FICL_WORD *wp; unsigned i; @@ -732,7 +840,7 @@ static void envConstant(FICL_VM *pVM) vmGetWordToPad(pVM); value = POPUNS(); - ficlSetEnv(pVM->pad, (FICL_UNS)value); + ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value); return; } @@ -747,7 +855,7 @@ static void env2Constant(FICL_VM *pVM) vmGetWordToPad(pVM); v2 = POPUNS(); v1 = POPUNS(); - ficlSetEnvD(pVM->pad, v1, v2); + ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2); return; } @@ -765,8 +873,7 @@ void ficlCompileTools(FICL_SYSTEM *pSys) /* ** TOOLS and TOOLS EXT */ - dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); /* guy carver */ - dictAppendWord(dp, ".s", displayStack, FW_DEFAULT); + dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT); dictAppendWord(dp, "bye", bye, FW_DEFAULT); dictAppendWord(dp, "forget", forget, FW_DEFAULT); dictAppendWord(dp, "see", see, FW_DEFAULT); @@ -775,12 +882,13 @@ void ficlCompileTools(FICL_SYSTEM *pSys) /* ** Set TOOLS environment query values */ - ficlSetEnv("tools", FICL_TRUE); - ficlSetEnv("tools-ext", FICL_FALSE); + ficlSetEnv(pSys, "tools", FICL_TRUE); + ficlSetEnv(pSys, "tools-ext", FICL_FALSE); /* ** Ficl extras */ + dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */ dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); dictAppendWord(dp, "env-constant", envConstant, FW_DEFAULT); @@ -793,7 +901,6 @@ void ficlCompileTools(FICL_SYSTEM *pSys) dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT); dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT); - dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); return; } diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c index bebba71..7bcb19a 100644 --- a/sys/boot/ficl/vm.c +++ b/sys/boot/ficl/vm.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - virtual machine methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: vm.c,v 1.8 2001-04-26 21:41:23-07 jsadler Exp jsadler $ +** $Id: vm.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** This file implements the virtual machine of FICL. Each virtual @@ -18,6 +18,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -40,13 +45,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: vm.c,v 1.8 2001-04-26 21:41:23-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -165,6 +163,99 @@ void vmInnerLoop(FICL_VM *pVM) M_INNER_LOOP(pVM); } #endif +#if 0 +/* +** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations, +** as well as create does> : ; and various literals +*/ +typedef enum +{ + PATCH = 0, + L0, + L1, + L2, + LMINUS1, + LMINUS2, + DROP, + SWAP, + DUP, + PICK, + ROLL, + FETCH, + STORE, + BRANCH, + CBRANCH, + LEAVE, + TO_R, + R_FROM, + EXIT; +} OPCODE; + +typedef CELL *IPTYPE; + +void vmInnerLoop(FICL_VM *pVM) +{ + IPTYPE ip = pVM->ip; + FICL_STACK *pStack = pVM->pStack; + + for (;;) + { + OPCODE o = (*ip++).i; + CELL c; + switch (o) + { + case L0: + stackPushINT(pStack, 0); + break; + case L1: + stackPushINT(pStack, 1); + break; + case L2: + stackPushINT(pStack, 2); + break; + case LMINUS1: + stackPushINT(pStack, -1); + break; + case LMINUS2: + stackPushINT(pStack, -2); + break; + case DROP: + stackDrop(pStack, 1); + break; + case SWAP: + stackRoll(pStack, 1); + break; + case DUP: + stackPick(pStack, 0); + break; + case PICK: + c = *ip++; + stackPick(pStack, c.i); + break; + case ROLL: + c = *ip++; + stackRoll(pStack, c.i); + break; + case EXIT: + return; + } + } + + return; +} +#endif + + + +/************************************************************************** + v m G e t D i c t +** Returns the address dictionary for this VM's system +**************************************************************************/ +FICL_DICT *vmGetDict(FICL_VM *pVM) +{ + assert(pVM); + return pVM->pSys->dp; +} /************************************************************************** @@ -440,18 +531,6 @@ void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut) /************************************************************************** - v m S t e p -** Single step the vm - equivalent to "step into" - used for debugging -**************************************************************************/ -#if FICL_WANT_DEBUGGER -void vmStep(FICL_VM *pVM) -{ - M_VM_STEP(pVM); -} -#endif - - -/************************************************************************** v m T e x t O u t ** Feeds text to the vm's output callback **************************************************************************/ diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c index 7888a86..2f50100 100644 --- a/sys/boot/ficl/words.c +++ b/sys/boot/ficl/words.c @@ -4,7 +4,7 @@ ** ANS Forth CORE word-set written in C ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $ +** $Id: words.c,v 1.17 2001/12/05 07:21:34 jsadler Exp $ *******************************************************************/ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -12,6 +12,11 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please +** contact me by email at the address above. +** ** L I C E N S E and D I S C L A I M E R ** ** Redistribution and use in source and binary forms, with or without @@ -34,13 +39,6 @@ ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ** SUCH DAMAGE. -** -** I am interested in hearing from anyone who uses ficl. If you have -** a problem, a success story, a defect, an enhancement request, or -** if you would like to contribute to the ficl release, please send -** contact me by email at the address above. -** -** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -73,48 +71,9 @@ static char leaveTag[] = "leave"; static char destTag[] = "target"; static char origTag[] = "origin"; -/* -** Pointers to various words in the dictionary -** -- initialized by ficlCompileCore, below -- -** for use by compiling words. Colon definitions -** in ficl are lists of pointers to words. A bit -** simple-minded... -*/ -static FICL_WORD *pBranchParen = NULL; -static FICL_WORD *pComma = NULL; -static FICL_WORD *pDoParen = NULL; -static FICL_WORD *pDoesParen = NULL; -static FICL_WORD *pExitParen = NULL; -static FICL_WORD *pIfParen = NULL; -static FICL_WORD *pInterpret = NULL; -static FICL_WORD *pLitParen = NULL; -static FICL_WORD *pTwoLitParen = NULL; -static FICL_WORD *pLoopParen = NULL; -static FICL_WORD *pPLoopParen = NULL; -static FICL_WORD *pPlusStore = NULL; -static FICL_WORD *pQDoParen = NULL; -static FICL_WORD *pSemiParen = NULL; -static FICL_WORD *pStore = NULL; -static FICL_WORD *pStringLit = NULL; -static FICL_WORD *pType = NULL; - #if FICL_WANT_LOCALS -static FICL_WORD *pGetLocalParen= NULL; -static FICL_WORD *pGet2LocalParen= NULL; -static FICL_WORD *pGetLocal0 = NULL; -static FICL_WORD *pGetLocal1 = NULL; -static FICL_WORD *pToLocalParen = NULL; -static FICL_WORD *pTo2LocalParen = NULL; -static FICL_WORD *pToLocal0 = NULL; -static FICL_WORD *pToLocal1 = NULL; -static FICL_WORD *pLinkParen = NULL; -static FICL_WORD *pUnLinkParen = NULL; -static int nLocals = 0; -static CELL *pMarkLocals = NULL; - static void doLocalIm(FICL_VM *pVM); static void do2LocalIm(FICL_VM *pVM); - #endif @@ -162,7 +121,7 @@ static void matchControlTag(FICL_VM *pVM, char *tag) */ static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { - long offset; + FICL_INT offset; CELL *patchAddr; matchControlTag(pVM, tag); @@ -185,7 +144,7 @@ static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) */ static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { - long offset; + FICL_INT offset; CELL *patchAddr; matchControlTag(pVM, tag); @@ -235,12 +194,15 @@ static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) ** Attempts to convert the NULL terminated string in the VM's pad to ** a number using the VM's current base. If successful, pushes the number ** onto the param stack and returns TRUE. Otherwise, returns FALSE. +** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See +** the standard for DOUBLE wordset. **************************************************************************/ int ficlParseNumber(FICL_VM *pVM, STRINGINFO si) { FICL_INT accum = 0; char isNeg = FALSE; + char hasDP = FALSE; unsigned base = pVM->base; char *cp = SI_PTR(si); FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); @@ -266,7 +228,13 @@ int ficlParseNumber(FICL_VM *pVM, STRINGINFO si) } } - if (count == 0) + if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */ + { + hasDP = TRUE; + count--; + } + + if (count == 0) /* detect "+", "-", ".", "+." etc */ return FALSE; while ((count--) && ((ch = *cp++) != '\0')) @@ -285,6 +253,9 @@ int ficlParseNumber(FICL_VM *pVM, STRINGINFO si) accum = accum * base + digit; } + if (hasDP) /* simple (required) DOUBLE support */ + PUSHINT(0); + if (isNeg) accum = -accum; @@ -486,7 +457,7 @@ static void mulDivRem(FICL_VM *pVM) static void colon(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictCheckThreshold(dp); @@ -495,7 +466,7 @@ static void colon(FICL_VM *pVM) markControlTag(pVM, colonTag); dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); #if FICL_WANT_LOCALS - nLocals = 0; + pVM->pSys->nLocals = 0; #endif return; } @@ -539,23 +510,23 @@ static void semiParen(FICL_VM *pVM) static void semicolonCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pSemiParen); + assert(pVM->pSys->pSemiParen); matchControlTag(pVM, colonTag); #if FICL_WANT_LOCALS - assert(pUnLinkParen); - if (nLocals > 0) + assert(pVM->pSys->pUnLinkParen); + if (pVM->pSys->nLocals > 0) { - FICL_DICT *pLoc = ficlGetLoc(); + FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); dictEmpty(pLoc, pLoc->pForthWords->size); - dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } - nLocals = 0; + pVM->pSys->nLocals = 0; #endif - dictAppendCell(dp, LVALUEtoCELL(pSemiParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen)); pVM->state = INTERPRET; dictUnsmudge(dp); return; @@ -579,17 +550,17 @@ static void exitParen(FICL_VM *pVM) static void exitCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - assert(pExitParen); + FICL_DICT *dp = vmGetDict(pVM); + assert(pVM->pSys->pExitParen); IGNORE(pVM); #if FICL_WANT_LOCALS - if (nLocals > 0) + if (pVM->pSys->nLocals > 0) { - dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } #endif - dictAppendCell(dp, LVALUEtoCELL(pExitParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen)); return; } @@ -632,7 +603,7 @@ void twoConstParen(FICL_VM *pVM) static void constant(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); #if FICL_ROBUST > 1 @@ -646,7 +617,7 @@ static void constant(FICL_VM *pVM) static void twoConstant(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); CELL c; @@ -709,6 +680,172 @@ static void hexDot(FICL_VM *pVM) /************************************************************************** + s t r l e n +** FICL ( c-string -- length ) +** +** Returns the length of a C-style (zero-terminated) string. +** +** --lch +**/ +static void ficlStrlen(FICL_VM *ficlVM) + { + char *address = (char *)stackPopPtr(ficlVM->pStack); + stackPushINT(ficlVM->pStack, strlen(address)); + } + + +/************************************************************************** + s p r i n t f +** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag ) +** Similar to the C sprintf() function. It formats into a buffer based on +** a "format" string. Each character in the format string is copied verbatim +** to the output buffer, until SPRINTF encounters a percent sign ("%"). +** SPRINTF then skips the percent sign, and examines the next character +** (the "format character"). Here are the valid format characters: +** s - read a C-ADDR U-LENGTH string from the stack and copy it to +** the buffer +** d - read a cell from the stack, format it as a string (base-10, +** signed), and copy it to the buffer +** x - same as d, except in base-16 +** u - same as d, but unsigned +** % - output a literal percent-sign to the buffer +** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes +** written, and a flag indicating whether or not it ran out of space while +** writing to the output buffer (TRUE if it ran out of space). +** +** If SPRINTF runs out of space in the buffer to store the formatted string, +** it still continues parsing, in an effort to preserve your stack (otherwise +** it might leave uneaten arguments behind). +** +** --lch +**************************************************************************/ +static void ficlSprintf(FICL_VM *pVM) /* */ +{ + int bufferLength = stackPopINT(pVM->pStack); + char *buffer = (char *)stackPopPtr(pVM->pStack); + char *bufferStart = buffer; + + int formatLength = stackPopINT(pVM->pStack); + char *format = (char *)stackPopPtr(pVM->pStack); + char *formatStop = format + formatLength; + + int base = 10; + int unsignedInteger = FALSE; + + int append = FICL_TRUE; + + while (format < formatStop) + { + char scratch[64]; + char *source; + int actualLength; + int desiredLength; + int leadingZeroes; + + + if (*format != '%') + { + source = format; + actualLength = desiredLength = 1; + leadingZeroes = 0; + } + else + { + format++; + if (format == formatStop) + break; + + leadingZeroes = (*format == '0'); + if (leadingZeroes) + { + format++; + if (format == formatStop) + break; + } + + desiredLength = isdigit(*format); + if (desiredLength) + { + desiredLength = strtol(format, &format, 10); + if (format == formatStop) + break; + } + else if (*format == '*') + { + desiredLength = stackPopINT(pVM->pStack); + format++; + if (format == formatStop) + break; + } + + + switch (*format) + { + case 's': + case 'S': + { + actualLength = stackPopINT(pVM->pStack); + source = (char *)stackPopPtr(pVM->pStack); + break; + } + case 'x': + case 'X': + base = 16; + case 'u': + case 'U': + unsignedInteger = TRUE; + case 'd': + case 'D': + { + int integer = stackPopINT(pVM->pStack); + if (unsignedInteger) + ultoa(integer, scratch, base); + else + ltoa(integer, scratch, base); + base = 10; + unsignedInteger = FALSE; + source = scratch; + actualLength = strlen(scratch); + break; + } + case '%': + source = format; + actualLength = 1; + default: + continue; + } + } + + if (append == FICL_TRUE) + { + if (!desiredLength) + desiredLength = actualLength; + if (desiredLength > bufferLength) + { + append = FICL_FALSE; + desiredLength = bufferLength; + } + while (desiredLength > actualLength) + { + *buffer++ = (char)((leadingZeroes) ? '0' : ' '); + bufferLength--; + desiredLength--; + } + memcpy(buffer, source, actualLength); + buffer += actualLength; + bufferLength -= actualLength; + } + + format++; + } + + stackPushPtr(pVM->pStack, bufferStart); + stackPushINT(pVM->pStack, buffer - bufferStart); + stackPushINT(pVM->pStack, append); +} + + +/************************************************************************** d u p & f r i e n d s ** **************************************************************************/ @@ -1092,11 +1229,11 @@ static void cStore(FICL_VM *pVM) static void ifCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pIfParen); + assert(pVM->pSys->pIfParen); - dictAppendCell(dp, LVALUEtoCELL(pIfParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); markBranch(dp, pVM, origTag); dictAppendUNS(dp, 1); return; @@ -1148,11 +1285,11 @@ static void elseCoIm(FICL_VM *pVM) { CELL *patchAddr; FICL_INT offset; - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pBranchParen); + assert(pVM->pSys->pBranchParen); /* (1) compile branch runtime */ - dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); matchControlTag(pVM, origTag); patchAddr = (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ @@ -1186,7 +1323,7 @@ static void branchParen(FICL_VM *pVM) static void endifCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); resolveForwardBranch(dp, pVM, origTag); return; } @@ -1234,6 +1371,7 @@ static void interpret(FICL_VM *pVM) FICL_SYSTEM *pSys; assert(pVM); + pSys = pVM->pSys; si = vmGetWord0(pVM); @@ -1258,14 +1396,25 @@ static void interpret(FICL_VM *pVM) for (i=0; i < FICL_MAX_PARSE_STEPS; i++) { FICL_WORD *pFW = pSys->parseList[i]; - FICL_PARSE_STEP pStep; if (pFW == NULL) break; - pStep = (FICL_PARSE_STEP)(pFW->param->fn); - if ((*pStep)(pVM, si)) - return; + if (pFW->code == parseStepParen) + { + FICL_PARSE_STEP pStep; + pStep = (FICL_PARSE_STEP)(pFW->param->fn); + if ((*pStep)(pVM, si)) + return; + } + else + { + stackPushPtr(pVM->pStack, SI_PTR(si)); + stackPushUNS(pVM->pStack, SI_COUNT(si)); + ficlExecXT(pVM, pFW); + if (stackPopINT(pVM->pStack)) + return; + } } i = SI_COUNT(si); @@ -1297,7 +1446,7 @@ static void interpret(FICL_VM *pVM) **************************************************************************/ static int ficlParseWord(FICL_VM *pVM, STRINGINFO si) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *tempFW; #if FICL_ROBUST @@ -1306,9 +1455,9 @@ static int ficlParseWord(FICL_VM *pVM, STRINGINFO si) #endif #if FICL_WANT_LOCALS - if (nLocals > 0) + if (pVM->pSys->nLocals > 0) { - tempFW = dictLookupLoc(dp, si); + tempFW = ficlLookupLoc(pVM->pSys, si); } else #endif @@ -1348,6 +1497,20 @@ static int ficlParseWord(FICL_VM *pVM, STRINGINFO si) } +/* +** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in +** INTERPRET) +*/ +static void lookup(FICL_VM *pVM) +{ + STRINGINFO si; + SI_SETLEN(si, stackPopUNS(pVM->pStack)); + SI_SETPTR(si, stackPopPtr(pVM->pStack)); + stackPushINT(pVM->pStack, ficlParseWord(pVM, si)); + return; +} + + /************************************************************************** p a r e n P a r s e S t e p ** (parse-step) ( c-addr u -- flag ) @@ -1374,11 +1537,12 @@ void parseStepParen(FICL_VM *pVM) static void addParseStep(FICL_VM *pVM) { FICL_WORD *pStep; + FICL_DICT *pd = vmGetDict(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif pStep = (FICL_WORD *)(stackPop(pVM->pStack).p); - if ((pStep != NULL) && isAFiclWord(pStep)) + if ((pStep != NULL) && isAFiclWord(pd, pStep)) ficlAddParseStep(pVM->pSys, pStep); return; } @@ -1425,10 +1589,10 @@ static void twoLitParen(FICL_VM *pVM) static void literalIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - assert(pLitParen); + FICL_DICT *dp = vmGetDict(pVM); + assert(pVM->pSys->pLitParen); - dictAppendCell(dp, LVALUEtoCELL(pLitParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen)); dictAppendCell(dp, stackPop(pVM->pStack)); return; @@ -1437,10 +1601,10 @@ static void literalIm(FICL_VM *pVM) static void twoLiteralIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - assert(pTwoLitParen); + FICL_DICT *dp = vmGetDict(pVM); + assert(pVM->pSys->pTwoLitParen); - dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen)); dictAppendCell(dp, stackPop(pVM->pStack)); dictAppendCell(dp, stackPop(pVM->pStack)); @@ -1609,11 +1773,11 @@ static void bitwiseNot(FICL_VM *pVM) static void doCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pDoParen); + assert(pVM->pSys->pDoParen); - dictAppendCell(dp, LVALUEtoCELL(pDoParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen)); /* ** Allot space for a pointer to the end ** of the loop - "leave" uses this... @@ -1649,11 +1813,11 @@ static void doParen(FICL_VM *pVM) static void qDoCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pQDoParen); + assert(pVM->pSys->pQDoParen); - dictAppendCell(dp, LVALUEtoCELL(pQDoParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen)); /* ** Allot space for a pointer to the end ** of the loop - "leave" uses this... @@ -1719,11 +1883,11 @@ static void unloopCo(FICL_VM *pVM) static void loopCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pLoopParen); + assert(pVM->pSys->pLoopParen); - dictAppendCell(dp, LVALUEtoCELL(pLoopParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; @@ -1732,11 +1896,11 @@ static void loopCoIm(FICL_VM *pVM) static void plusLoopCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pPLoopParen); + assert(pVM->pSys->pPLoopParen); - dictAppendCell(dp, LVALUEtoCELL(pPLoopParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; @@ -1767,18 +1931,18 @@ static void loopParen(FICL_VM *pVM) static void plusLoopParen(FICL_VM *pVM) { - FICL_INT index,limit,increment; - int flag; + FICL_INT index,limit,increment; + int flag; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - index = stackGetTop(pVM->rStack).i; - limit = stackFetch(pVM->rStack, 1).i; - increment = POP().i; - - index += increment; + index = stackGetTop(pVM->rStack).i; + limit = stackFetch(pVM->rStack, 1).i; + increment = POP().i; + + index += increment; if (increment < 0) flag = (index < limit); @@ -1834,28 +1998,28 @@ static void loopKCo(FICL_VM *pVM) static void toRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - stackPush(pVM->rStack, POP()); + stackPush(pVM->rStack, POP()); } static void fromRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - PUSH(stackPop(pVM->rStack)); + PUSH(stackPop(pVM->rStack)); } static void fetchRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - PUSH(stackGetTop(pVM->rStack)); + PUSH(stackGetTop(pVM->rStack)); } static void twoToR(FICL_VM *pVM) @@ -1898,19 +2062,19 @@ static void twoRFetch(FICL_VM *pVM) static void variableParen(FICL_VM *pVM) { - FICL_WORD *fw; + FICL_WORD *fw; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - fw = pVM->runningWord; - PUSHPTR(fw->param); + fw = pVM->runningWord; + PUSHPTR(fw->param); } static void variable(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, variableParen, FW_DEFAULT); @@ -1921,7 +2085,7 @@ static void variable(FICL_VM *pVM) static void twoVariable(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, variableParen, FW_DEFAULT); @@ -1937,13 +2101,14 @@ static void twoVariable(FICL_VM *pVM) static void base(FICL_VM *pVM) { - CELL *pBase; + CELL *pBase; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - pBase = (CELL *)(&pVM->base); - PUSHPTR(pBase); + pBase = (CELL *)(&pVM->base); + stackPush(pVM->pStack, LVALUEtoCELL(pBase)); + return; } @@ -1968,85 +2133,85 @@ static void hex(FICL_VM *pVM) static void allot(FICL_VM *pVM) { - FICL_DICT *dp; - FICL_INT i; + FICL_DICT *dp; + FICL_INT i; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - dp = ficlGetDict(); - i = POPINT(); + dp = vmGetDict(pVM); + i = POPINT(); #if FICL_ROBUST - dictCheck(dp, pVM, i); + dictCheck(dp, pVM, i); #endif - dictAllot(dp, i); + dictAllot(dp, i); return; } static void here(FICL_VM *pVM) { - FICL_DICT *dp; + FICL_DICT *dp; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - dp = ficlGetDict(); - PUSHPTR(dp->here); + dp = vmGetDict(pVM); + PUSHPTR(dp->here); return; } static void comma(FICL_VM *pVM) { - FICL_DICT *dp; - CELL c; + FICL_DICT *dp; + CELL c; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - dp = ficlGetDict(); - c = POP(); - dictAppendCell(dp, c); + dp = vmGetDict(pVM); + c = POP(); + dictAppendCell(dp, c); return; } static void cComma(FICL_VM *pVM) { - FICL_DICT *dp; - char c; + FICL_DICT *dp; + char c; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - dp = ficlGetDict(); - c = (char)POPINT(); - dictAppendChar(dp, c); + dp = vmGetDict(pVM); + c = (char)POPINT(); + dictAppendChar(dp, c); return; } static void cells(FICL_VM *pVM) { - FICL_INT i; + FICL_INT i; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 1); #endif - i = POPINT(); - PUSHINT(i * (FICL_INT)sizeof (CELL)); + i = POPINT(); + PUSHINT(i * (FICL_INT)sizeof (CELL)); return; } static void cellPlus(FICL_VM *pVM) { - char *cp; + char *cp; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 1); #endif - cp = POPPTR(); - PUSHPTR(cp + sizeof (CELL)); + cp = POPPTR(); + PUSHPTR(cp + sizeof (CELL)); return; } @@ -2061,19 +2226,19 @@ static void cellPlus(FICL_VM *pVM) **************************************************************************/ void ficlTick(FICL_VM *pVM) { - FICL_WORD *pFW = NULL; - STRINGINFO si = vmGetWord(pVM); + FICL_WORD *pFW = NULL; + STRINGINFO si = vmGetWord(pVM); #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - pFW = dictLookup(ficlGetDict(), si); - if (!pFW) - { - int i = SI_COUNT(si); - vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); - } - PUSHPTR(pFW); + pFW = dictLookup(vmGetDict(pVM), si); + if (!pFW) + { + int i = SI_COUNT(si); + vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); + } + PUSHPTR(pFW); return; } @@ -2096,8 +2261,9 @@ static void bracketTickCoIm(FICL_VM *pVM) static void postponeCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; + FICL_WORD *pComma = ficlLookup(pVM->pSys, ","); assert(pComma); ficlTick(pVM); @@ -2147,7 +2313,7 @@ static void execute(FICL_VM *pVM) static void immediate(FICL_VM *pVM) { IGNORE(pVM); - dictSetImmediate(ficlGetDict()); + dictSetImmediate(vmGetDict(pVM)); return; } @@ -2155,11 +2321,64 @@ static void immediate(FICL_VM *pVM) static void compileOnly(FICL_VM *pVM) { IGNORE(pVM); - dictSetFlags(ficlGetDict(), FW_COMPILE, 0); + dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0); + return; +} + + +static void setObjectFlag(FICL_VM *pVM) +{ + IGNORE(pVM); + dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0); + return; +} + +static void isObject(FICL_VM *pVM) +{ + int flag; + FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); + + flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE; + stackPushINT(pVM->pStack, flag); + return; +} + +static void cstringLit(FICL_VM *pVM) +{ + FICL_STRING *sp = (FICL_STRING *)(pVM->ip); + + char *cp = sp->text; + cp += sp->count + 1; + cp = alignPtr(cp); + pVM->ip = (IPTYPE)(void *)cp; + + stackPushPtr(pVM->pStack, sp); return; } +static void cstringQuoteIm(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + + if (pVM->state == INTERPRET) + { + FICL_STRING *sp = (FICL_STRING *) dp->here; + vmGetString(pVM, sp, '\"'); + stackPushPtr(pVM->pStack, sp); + /* move HERE past string so it doesn't get overwritten. --lch */ + dictAllot(dp, sp->count + sizeof(FICL_COUNT)); + } + else /* COMPILE state */ + { + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit)); + dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); + dictAlign(dp); + } + + return; +} + /************************************************************************** d o t Q u o t e ** IMMEDIATE word that compiles a string literal for later display @@ -2173,27 +2392,29 @@ static void compileOnly(FICL_VM *pVM) static void stringLit(FICL_VM *pVM) { - FICL_STRING *sp; - FICL_COUNT count; - char *cp; + FICL_STRING *sp; + FICL_COUNT count; + char *cp; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 2); + vmCheckStack(pVM, 0, 2); #endif - sp = (FICL_STRING *)(pVM->ip); - count = sp->count; - cp = sp->text; - PUSHPTR(cp); - PUSHUNS(count); - cp += count + 1; - cp = alignPtr(cp); - pVM->ip = (IPTYPE)(void *)cp; + sp = (FICL_STRING *)(pVM->ip); + count = sp->count; + cp = sp->text; + PUSHPTR(cp); + PUSHUNS(count); + cp += count + 1; + cp = alignPtr(cp); + pVM->ip = (IPTYPE)(void *)cp; } static void dotQuoteCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - dictAppendCell(dp, LVALUEtoCELL(pStringLit)); + FICL_DICT *dp = vmGetDict(pVM); + FICL_WORD *pType = ficlLookup(pVM->pSys, "type"); + assert(pType); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); dictAlign(dp); dictAppendCell(dp, LVALUEtoCELL(pType)); @@ -2238,19 +2459,19 @@ static void dotParen(FICL_VM *pVM) **************************************************************************/ static void sLiteralCoIm(FICL_VM *pVM) { - FICL_DICT *dp; - char *cp, *cpDest; - FICL_UNS u; + FICL_DICT *dp; + char *cp, *cpDest; + FICL_UNS u; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 2, 0); + vmCheckStack(pVM, 2, 0); #endif - dp = ficlGetDict(); - u = POPUNS(); - cp = POPPTR(); + dp = vmGetDict(pVM); + u = POPUNS(); + cp = POPPTR(); - dictAppendCell(dp, LVALUEtoCELL(pStringLit)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); cpDest = (char *) dp->here; *cpDest++ = (char) u; @@ -2273,7 +2494,7 @@ static void sLiteralCoIm(FICL_VM *pVM) static void state(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif PUSHPTR(&pVM->state); return; @@ -2289,21 +2510,21 @@ static void state(FICL_VM *pVM) static void createParen(FICL_VM *pVM) { - CELL *pCell; + CELL *pCell; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - pCell = pVM->runningWord->param; - PUSHPTR(pCell+1); + pCell = pVM->runningWord->param; + PUSHPTR(pCell+1); return; } static void create(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictCheckThreshold(dp); @@ -2316,23 +2537,23 @@ static void create(FICL_VM *pVM) static void doDoes(FICL_VM *pVM) { - CELL *pCell; - IPTYPE tempIP; + CELL *pCell; + IPTYPE tempIP; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 0, 1); + vmCheckStack(pVM, 0, 1); #endif - pCell = pVM->runningWord->param; - tempIP = (IPTYPE)((*pCell).p); - PUSHPTR(pCell+1); - vmPushIP(pVM, tempIP); + pCell = pVM->runningWord->param; + tempIP = (IPTYPE)((*pCell).p); + PUSHPTR(pCell+1); + vmPushIP(pVM, tempIP); return; } static void doesParen(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); dp->smudge->code = doDoes; dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); vmPopIP(pVM); @@ -2342,21 +2563,21 @@ static void doesParen(FICL_VM *pVM) static void doesCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); #if FICL_WANT_LOCALS - assert(pUnLinkParen); - if (nLocals > 0) + assert(pVM->pSys->pUnLinkParen); + if (pVM->pSys->nLocals > 0) { - FICL_DICT *pLoc = ficlGetLoc(); + FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); dictEmpty(pLoc, pLoc->pForthWords->size); - dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } - nLocals = 0; + pVM->pSys->nLocals = 0; #endif IGNORE(pVM); - dictAppendCell(dp, LVALUEtoCELL(pDoesParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen)); return; } @@ -2369,14 +2590,14 @@ static void doesCoIm(FICL_VM *pVM) **************************************************************************/ static void toBody(FICL_VM *pVM) { - FICL_WORD *pFW; + FICL_WORD *pFW; /*#$-GUY CHANGE: Added robustness.-$#*/ #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 1); #endif - pFW = POPPTR(); - PUSHPTR(pFW->param + 1); + pFW = POPPTR(); + PUSHPTR(pFW->param + 1); return; } @@ -2387,13 +2608,13 @@ static void toBody(FICL_VM *pVM) */ static void fromBody(FICL_VM *pVM) { - char *ptr; + char *ptr; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 1); + vmCheckStack(pVM, 1, 1); #endif - ptr = (char *)POPPTR() - sizeof (FICL_WORD); - PUSHPTR(ptr); + ptr = (char *)POPPTR() - sizeof (FICL_WORD); + PUSHPTR(ptr); return; } @@ -2405,21 +2626,21 @@ static void fromBody(FICL_VM *pVM) */ static void toName(FICL_VM *pVM) { - FICL_WORD *pFW; + FICL_WORD *pFW; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 2); + vmCheckStack(pVM, 1, 2); #endif - pFW = POPPTR(); - PUSHPTR(pFW->name); - PUSHUNS(pFW->nName); + pFW = POPPTR(); + PUSHPTR(pFW->name); + PUSHUNS(pFW->nName); return; } static void getLastWord(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); FICL_WORD *wp = pDict->smudge; assert(wp); vmPush(pVM, LVALUEtoCELL(wp)); @@ -2470,18 +2691,18 @@ static void lessNumberSign(FICL_VM *pVM) */ static void numberSign(FICL_VM *pVM) { - FICL_STRING *sp; - DPUNS u; - UNS16 rem; + FICL_STRING *sp; + DPUNS u; + UNS16 rem; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 2, 2); + vmCheckStack(pVM, 2, 2); #endif - sp = PTRtoSTRING pVM->pad; - u = u64Pop(pVM->pStack); - rem = m64UMod(&u, (UNS16)(pVM->base)); - sp->text[sp->count++] = digit_to_char(rem); - u64Push(pVM->pStack, u); + sp = PTRtoSTRING pVM->pad; + u = u64Pop(pVM->pStack); + rem = m64UMod(&u, (UNS16)(pVM->base)); + sp->text[sp->count++] = digit_to_char(rem); + u64Push(pVM->pStack, u); return; } @@ -2493,17 +2714,17 @@ static void numberSign(FICL_VM *pVM) */ static void numberSignGreater(FICL_VM *pVM) { - FICL_STRING *sp; + FICL_STRING *sp; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 2, 2); + vmCheckStack(pVM, 2, 2); #endif - sp = PTRtoSTRING pVM->pad; - sp->text[sp->count] = 0; - strrev(sp->text); - DROP(2); - PUSHPTR(sp->text); - PUSHUNS(sp->count); + sp = PTRtoSTRING pVM->pad; + sp->text[sp->count] = 0; + strrev(sp->text); + DROP(2); + PUSHPTR(sp->text); + PUSHUNS(sp->count); return; } @@ -2516,24 +2737,24 @@ static void numberSignGreater(FICL_VM *pVM) */ static void numberSignS(FICL_VM *pVM) { - FICL_STRING *sp; - DPUNS u; - UNS16 rem; + FICL_STRING *sp; + DPUNS u; + UNS16 rem; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 2, 2); + vmCheckStack(pVM, 2, 2); #endif - sp = PTRtoSTRING pVM->pad; - u = u64Pop(pVM->pStack); + sp = PTRtoSTRING pVM->pad; + u = u64Pop(pVM->pStack); - do - { - rem = m64UMod(&u, (UNS16)(pVM->base)); - sp->text[sp->count++] = digit_to_char(rem); - } - while (u.hi || u.lo); + do + { + rem = m64UMod(&u, (UNS16)(pVM->base)); + sp->text[sp->count++] = digit_to_char(rem); + } + while (u.hi || u.lo); - u64Push(pVM->pStack, u); + u64Push(pVM->pStack, u); return; } @@ -2544,15 +2765,15 @@ static void numberSignS(FICL_VM *pVM) */ static void hold(FICL_VM *pVM) { - FICL_STRING *sp; - int i; + FICL_STRING *sp; + int i; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - sp = PTRtoSTRING pVM->pad; - i = POPINT(); - sp->text[sp->count++] = (char) i; + sp = PTRtoSTRING pVM->pad; + i = POPINT(); + sp->text[sp->count++] = (char) i; return; } @@ -2564,16 +2785,16 @@ static void hold(FICL_VM *pVM) */ static void sign(FICL_VM *pVM) { - FICL_STRING *sp; - int i; + FICL_STRING *sp; + int i; #if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 0); + vmCheckStack(pVM, 1, 0); #endif - sp = PTRtoSTRING pVM->pad; - i = POPINT(); - if (i < 0) - sp->text[sp->count++] = '-'; + sp = PTRtoSTRING pVM->pad; + i = POPINT(); + if (i < 0) + sp->text[sp->count++] = '-'; return; } @@ -2594,19 +2815,19 @@ static void sign(FICL_VM *pVM) **************************************************************************/ static void toNumber(FICL_VM *pVM) { - FICL_UNS count; - char *cp; - DPUNS accum; - FICL_UNS base = pVM->base; - FICL_UNS ch; - FICL_UNS digit; + FICL_UNS count; + char *cp; + DPUNS accum; + FICL_UNS base = pVM->base; + FICL_UNS ch; + FICL_UNS digit; #if FICL_ROBUST > 1 - vmCheckStack(pVM,4,4); + vmCheckStack(pVM,4,4); #endif - count = POPUNS(); - cp = (char *)POPPTR(); + count = POPUNS(); + cp = (char *)POPPTR(); accum = u64Pop(pVM->pStack); for (ch = *cp; count > 0; ch = *++cp, count--) @@ -2687,17 +2908,17 @@ static void ficlAbort(FICL_VM *pVM) **************************************************************************/ static void accept(FICL_VM *pVM) { - FICL_UNS count, len; - char *cp; - char *pBuf, *pEnd; + FICL_UNS count, len; + char *cp; + char *pBuf, *pEnd; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - pBuf = vmGetInBuf(pVM); + pBuf = vmGetInBuf(pVM); pEnd = vmGetInBufEnd(pVM); - len = pEnd - pBuf; + len = pEnd - pBuf; if (len == 0) vmThrow(pVM, VM_RESTART); @@ -2725,7 +2946,7 @@ static void accept(FICL_VM *pVM) **************************************************************************/ static void align(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); IGNORE(pVM); dictAlign(dp); return; @@ -2738,13 +2959,13 @@ static void align(FICL_VM *pVM) **************************************************************************/ static void aligned(FICL_VM *pVM) { - void *addr; + void *addr; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,1); + vmCheckStack(pVM,1,1); #endif - addr = POPPTR(); - PUSHPTR(alignPtr(addr)); + addr = POPPTR(); + PUSHPTR(alignPtr(addr)); return; } @@ -2760,29 +2981,29 @@ static void aligned(FICL_VM *pVM) **************************************************************************/ static void beginCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); markBranch(dp, pVM, destTag); return; } static void untilCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pIfParen); + assert(pVM->pSys->pIfParen); - dictAppendCell(dp, LVALUEtoCELL(pIfParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); resolveBackBranch(dp, pVM, destTag); return; } static void whileCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pIfParen); + assert(pVM->pSys->pIfParen); - dictAppendCell(dp, LVALUEtoCELL(pIfParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); markBranch(dp, pVM, origTag); twoSwap(pVM); dictAppendUNS(dp, 1); @@ -2791,10 +3012,10 @@ static void whileCoIm(FICL_VM *pVM) static void repeatCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pBranchParen); - dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); + assert(pVM->pSys->pBranchParen); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* expect "begin" branch marker */ resolveBackBranch(dp, pVM, destTag); @@ -2806,10 +3027,10 @@ static void repeatCoIm(FICL_VM *pVM) static void againCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); - assert(pBranchParen); - dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); + assert(pVM->pSys->pBranchParen); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* expect "begin" branch marker */ resolveBackBranch(dp, pVM, destTag); @@ -2833,13 +3054,13 @@ static void againCoIm(FICL_VM *pVM) **************************************************************************/ static void ficlChar(FICL_VM *pVM) { - STRINGINFO si; + STRINGINFO si; #if FICL_ROBUST > 1 - vmCheckStack(pVM,0,1); + vmCheckStack(pVM,0,1); #endif - si = vmGetWord(pVM); - PUSHUNS((FICL_UNS)(si.cp[0])); + si = vmGetWord(pVM); + PUSHUNS((FICL_UNS)(si.cp[0])); return; } @@ -2857,13 +3078,13 @@ static void charCoIm(FICL_VM *pVM) **************************************************************************/ static void charPlus(FICL_VM *pVM) { - char *cp; + char *cp; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,1); + vmCheckStack(pVM,1,1); #endif - cp = POPPTR(); - PUSHPTR(cp + 1); + cp = POPPTR(); + PUSHPTR(cp + 1); return; } @@ -2879,16 +3100,16 @@ static void charPlus(FICL_VM *pVM) #endif static void ficlChars(FICL_VM *pVM) { - if (sizeof (char) > 1) - { - FICL_INT i; + if (sizeof (char) > 1) + { + FICL_INT i; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,1); + vmCheckStack(pVM,1,1); #endif - i = POPINT(); - PUSHINT(i * sizeof (char)); - } - /* otherwise no-op! */ + i = POPINT(); + PUSHINT(i * sizeof (char)); + } + /* otherwise no-op! */ return; } #if defined (_M_IX86) @@ -2906,14 +3127,14 @@ static void ficlChars(FICL_VM *pVM) **************************************************************************/ static void count(FICL_VM *pVM) { - FICL_STRING *sp; + FICL_STRING *sp; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,2); + vmCheckStack(pVM,1,2); #endif - sp = POPPTR(); - PUSHPTR(sp->text); - PUSHUNS(sp->count); + sp = POPPTR(); + PUSHPTR(sp->text); + PUSHUNS(sp->count); return; } @@ -2932,32 +3153,28 @@ static void count(FICL_VM *pVM) **************************************************************************/ static void environmentQ(FICL_VM *pVM) { - FICL_DICT *envp; - FICL_COUNT len; - char *cp; - FICL_WORD *pFW; - STRINGINFO si; + FICL_DICT *envp; + FICL_WORD *pFW; + STRINGINFO si; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - envp = ficlGetEnv(); - len = (FICL_COUNT)POPUNS(); - cp = POPPTR(); + envp = pVM->pSys->envp; + si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); + si.cp = stackPopPtr(pVM->pStack); - IGNORE(len); - SI_PSZ(si, cp); - pFW = dictLookup(envp, si); + pFW = dictLookup(envp, si); - if (pFW != NULL) - { - vmExecute(pVM, pFW); - PUSHINT(FICL_TRUE); - } - else - { - PUSHINT(FICL_FALSE); - } + if (pFW != NULL) + { + vmExecute(pVM, pFW); + PUSHINT(FICL_TRUE); + } + else + { + PUSHINT(FICL_FALSE); + } return; } @@ -2973,24 +3190,24 @@ static void environmentQ(FICL_VM *pVM) **************************************************************************/ static void evaluate(FICL_VM *pVM) { - FICL_UNS count; - char *cp; - CELL id; + FICL_UNS count; + char *cp; + CELL id; int result; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,0); + vmCheckStack(pVM,2,0); #endif - count = POPUNS(); - cp = POPPTR(); + count = POPUNS(); + cp = POPPTR(); - IGNORE(count); - id = pVM->sourceID; - pVM->sourceID.i = -1; - result = ficlExecC(pVM, cp, count); - pVM->sourceID = id; - if (result != VM_OUTOFTEXT) - vmThrow(pVM, result); + IGNORE(count); + id = pVM->sourceID; + pVM->sourceID.i = -1; + result = ficlExecC(pVM, cp, count); + pVM->sourceID = id; + if (result != VM_OUTOFTEXT) + vmThrow(pVM, result); return; } @@ -3006,7 +3223,7 @@ static void evaluate(FICL_VM *pVM) **************************************************************************/ static void stringQuoteIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); if (pVM->state == INTERPRET) { @@ -3017,7 +3234,7 @@ static void stringQuoteIm(FICL_VM *pVM) } else /* COMPILE state */ { - dictAppendCell(dp, LVALUEtoCELL(pStringLit)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); dictAlign(dp); } @@ -3043,12 +3260,12 @@ static void type(FICL_VM *pVM) */ if (!pDest) vmThrowErr(pVM, "Error: out of memory"); - + strncpy(pDest, cp, count); pDest[count] = '\0'; - + vmTextOut(pVM, pDest, 0); - + ficlFree(pDest); return; } @@ -3069,27 +3286,27 @@ static void type(FICL_VM *pVM) **************************************************************************/ static void ficlWord(FICL_VM *pVM) { - FICL_STRING *sp; - char delim; - STRINGINFO si; + FICL_STRING *sp; + char delim; + STRINGINFO si; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,1); + vmCheckStack(pVM,1,1); #endif - sp = (FICL_STRING *)pVM->pad; - delim = (char)POPINT(); + sp = (FICL_STRING *)pVM->pad; + delim = (char)POPINT(); si = vmParseStringEx(pVM, delim, 1); - if (SI_COUNT(si) > nPAD-1) - SI_SETLEN(si, nPAD-1); + if (SI_COUNT(si) > nPAD-1) + SI_SETLEN(si, nPAD-1); - sp->count = (FICL_COUNT)SI_COUNT(si); - strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); - /*#$-GUY CHANGE: I added this.-$#*/ - sp->text[sp->count] = 0; - strcat(sp->text, " "); + sp->count = (FICL_COUNT)SI_COUNT(si); + strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); + /*#$-GUY CHANGE: I added this.-$#*/ + sp->text[sp->count] = 0; + strcat(sp->text, " "); - PUSHPTR(sp); + PUSHPTR(sp); return; } @@ -3103,14 +3320,14 @@ static void ficlWord(FICL_VM *pVM) **************************************************************************/ static void parseNoCopy(FICL_VM *pVM) { - STRINGINFO si; + STRINGINFO si; #if FICL_ROBUST > 1 - vmCheckStack(pVM,0,2); + vmCheckStack(pVM,0,2); #endif - si = vmGetWord0(pVM); - PUSHPTR(SI_PTR(si)); - PUSHUNS(SI_COUNT(si)); + si = vmGetWord0(pVM); + PUSHPTR(SI_PTR(si)); + PUSHUNS(SI_COUNT(si)); return; } @@ -3126,18 +3343,18 @@ static void parseNoCopy(FICL_VM *pVM) **************************************************************************/ static void parse(FICL_VM *pVM) { - STRINGINFO si; - char delim; + STRINGINFO si; + char delim; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,2); + vmCheckStack(pVM,1,2); #endif - delim = (char)POPINT(); + delim = (char)POPINT(); - si = vmParseStringEx(pVM, delim, 0); - PUSHPTR(SI_PTR(si)); - PUSHUNS(SI_COUNT(si)); + si = vmParseStringEx(pVM, delim, 0); + PUSHPTR(SI_PTR(si)); + PUSHUNS(SI_COUNT(si)); return; } @@ -3150,21 +3367,21 @@ static void parse(FICL_VM *pVM) **************************************************************************/ static void fill(FICL_VM *pVM) { - char ch; - FICL_UNS u; - char *cp; + char ch; + FICL_UNS u; + char *cp; #if FICL_ROBUST > 1 - vmCheckStack(pVM,3,0); + vmCheckStack(pVM,3,0); #endif - ch = (char)POPINT(); - u = POPUNS(); - cp = (char *)POPPTR(); + ch = (char)POPINT(); + u = POPUNS(); + cp = (char *)POPPTR(); - while (u > 0) - { - *cp++ = ch; - u--; - } + while (u > 0) + { + *cp++ = ch; + u--; + } return; } @@ -3179,29 +3396,68 @@ static void fill(FICL_VM *pVM) ** string, the values returned by FIND while compiling may differ from ** those returned while not compiling. **************************************************************************/ -static void find(FICL_VM *pVM) +static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure) { - FICL_STRING *sp; - FICL_WORD *pFW; - STRINGINFO si; + FICL_WORD *pFW; + + pFW = dictLookup(vmGetDict(pVM), si); + if (pFW) + { + PUSHPTR(pFW); + PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); + } + else + { + PUSHPTR(returnForFailure); + PUSHUNS(0); + } + return; +} + + + +/************************************************************************** + f i n d +** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) +** Find the definition named in the counted string at c-addr. If the +** definition is not found, return c-addr and zero. If the definition is +** found, return its execution token xt. If the definition is immediate, +** also return one (1), otherwise also return minus-one (-1). For a given +** string, the values returned by FIND while compiling may differ from +** those returned while not compiling. +**************************************************************************/ +static void cFind(FICL_VM *pVM) +{ + FICL_STRING *sp; + STRINGINFO si; + #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,2); + vmCheckStack(pVM,1,2); #endif + sp = POPPTR(); + SI_PFS(si, sp); + do_find(pVM, si, sp); +} - sp = POPPTR(); - SI_PFS(si, sp); - pFW = dictLookup(ficlGetDict(), si); - if (pFW) - { - PUSHPTR(pFW); - PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); - } - else - { - PUSHPTR(sp); - PUSHUNS(0); - } - return; + + +/************************************************************************** + s f i n d +** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 ) +** Like FIND, but takes "c-addr u" for the string. +**************************************************************************/ +static void sFind(FICL_VM *pVM) +{ + STRINGINFO si; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,2); +#endif + + si.count = stackPopINT(pVM->pStack); + si.cp = stackPopPtr(pVM->pStack); + + do_find(pVM, si, NULL); } @@ -3216,18 +3472,18 @@ static void find(FICL_VM *pVM) **************************************************************************/ static void fmSlashMod(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; #if FICL_ROBUST > 1 - vmCheckStack(pVM,3,2); + vmCheckStack(pVM,3,2); #endif - n1 = POPINT(); - d1 = i64Pop(pVM->pStack); - qr = m64FlooredDivI(d1, n1); - PUSHINT(qr.rem); - PUSHINT(qr.quot); + n1 = POPINT(); + d1 = i64Pop(pVM->pStack); + qr = m64FlooredDivI(d1, n1); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } @@ -3242,36 +3498,36 @@ static void fmSlashMod(FICL_VM *pVM) **************************************************************************/ static void smSlashRem(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; #if FICL_ROBUST > 1 - vmCheckStack(pVM,3,2); + vmCheckStack(pVM,3,2); #endif - n1 = POPINT(); - d1 = i64Pop(pVM->pStack); - qr = m64SymmetricDivI(d1, n1); - PUSHINT(qr.rem); - PUSHINT(qr.quot); + n1 = POPINT(); + d1 = i64Pop(pVM->pStack); + qr = m64SymmetricDivI(d1, n1); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } static void ficlMod(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - n1 = POPINT(); - d1.lo = POPINT(); - i64Extend(d1); - qr = m64SymmetricDivI(d1, n1); - PUSHINT(qr.rem); + n1 = POPINT(); + d1.lo = POPINT(); + i64Extend(d1); + qr = m64SymmetricDivI(d1, n1); + PUSHINT(qr.rem); return; } @@ -3315,31 +3571,31 @@ static void umSlashMod(FICL_VM *pVM) **************************************************************************/ static void lshift(FICL_VM *pVM) { - FICL_UNS nBits; - FICL_UNS x1; + FICL_UNS nBits; + FICL_UNS x1; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - nBits = POPUNS(); - x1 = POPUNS(); - PUSHUNS(x1 << nBits); + nBits = POPUNS(); + x1 = POPUNS(); + PUSHUNS(x1 << nBits); return; } static void rshift(FICL_VM *pVM) { - FICL_UNS nBits; - FICL_UNS x1; + FICL_UNS nBits; + FICL_UNS x1; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - nBits = POPUNS(); - x1 = POPUNS(); + nBits = POPUNS(); + x1 = POPUNS(); - PUSHUNS(x1 >> nBits); + PUSHUNS(x1 >> nBits); return; } @@ -3351,36 +3607,36 @@ static void rshift(FICL_VM *pVM) **************************************************************************/ static void mStar(FICL_VM *pVM) { - FICL_INT n2; - FICL_INT n1; - DPINT d; + FICL_INT n2; + FICL_INT n1; + DPINT d; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,2); + vmCheckStack(pVM,2,2); #endif - n2 = POPINT(); - n1 = POPINT(); + n2 = POPINT(); + n1 = POPINT(); - d = m64MulI(n1, n2); - i64Push(pVM->pStack, d); + d = m64MulI(n1, n2); + i64Push(pVM->pStack, d); return; } static void umStar(FICL_VM *pVM) { - FICL_UNS u2; - FICL_UNS u1; - DPUNS ud; + FICL_UNS u2; + FICL_UNS u1; + DPUNS ud; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,2); + vmCheckStack(pVM,2,2); #endif - u2 = POPUNS(); - u1 = POPUNS(); + u2 = POPUNS(); + u1 = POPUNS(); - ud = ficlLongMul(u1, u2); - u64Push(pVM->pStack, ud); + ud = ficlLongMul(u1, u2); + u64Push(pVM->pStack, ud); return; } @@ -3391,31 +3647,31 @@ static void umStar(FICL_VM *pVM) **************************************************************************/ static void ficlMax(FICL_VM *pVM) { - FICL_INT n2; - FICL_INT n1; + FICL_INT n2; + FICL_INT n1; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - n2 = POPINT(); - n1 = POPINT(); + n2 = POPINT(); + n1 = POPINT(); - PUSHINT((n1 > n2) ? n1 : n2); + PUSHINT((n1 > n2) ? n1 : n2); return; } static void ficlMin(FICL_VM *pVM) { - FICL_INT n2; - FICL_INT n1; + FICL_INT n2; + FICL_INT n1; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,1); + vmCheckStack(pVM,2,1); #endif - n2 = POPINT(); - n1 = POPINT(); + n2 = POPINT(); + n1 = POPINT(); - PUSHINT((n1 < n2) ? n1 : n2); + PUSHINT((n1 < n2) ? n1 : n2); return; } @@ -3432,16 +3688,16 @@ static void ficlMin(FICL_VM *pVM) **************************************************************************/ static void move(FICL_VM *pVM) { - FICL_UNS u; - char *addr2; - char *addr1; + FICL_UNS u; + char *addr2; + char *addr1; #if FICL_ROBUST > 1 - vmCheckStack(pVM,3,0); + vmCheckStack(pVM,3,0); #endif - u = POPUNS(); - addr2 = POPPTR(); - addr1 = POPPTR(); + u = POPUNS(); + addr2 = POPPTR(); + addr1 = POPPTR(); if (u == 0) return; @@ -3472,7 +3728,7 @@ static void move(FICL_VM *pVM) **************************************************************************/ static void recurseCoIm(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); IGNORE(pVM); dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); @@ -3488,16 +3744,16 @@ static void recurseCoIm(FICL_VM *pVM) **************************************************************************/ static void sToD(FICL_VM *pVM) { - FICL_INT s; + FICL_INT s; #if FICL_ROBUST > 1 - vmCheckStack(pVM,1,2); + vmCheckStack(pVM,1,2); #endif - s = POPINT(); + s = POPINT(); - /* sign extend to 64 bits.. */ - PUSHINT(s); - PUSHINT((s < 0) ? -1 : 0); + /* sign extend to 64 bits.. */ + PUSHINT(s); + PUSHINT((s < 0) ? -1 : 0); return; } @@ -3511,9 +3767,9 @@ static void sToD(FICL_VM *pVM) static void source(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM,0,2); + vmCheckStack(pVM,0,2); #endif - PUSHPTR(pVM->tib.cp); + PUSHPTR(pVM->tib.cp); PUSHINT(vmGetInBufLen(pVM)); return; } @@ -3537,9 +3793,9 @@ static void ficlVersion(FICL_VM *pVM) static void toIn(FICL_VM *pVM) { #if FICL_ROBUST > 1 - vmCheckStack(pVM,0,1); + vmCheckStack(pVM,0,1); #endif - PUSHPTR(&pVM->tib.index); + PUSHPTR(&pVM->tib.index); return; } @@ -3552,7 +3808,7 @@ static void toIn(FICL_VM *pVM) **************************************************************************/ static void colonNoName(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; STRINGINFO si; @@ -3594,7 +3850,7 @@ static void userParen(FICL_VM *pVM) static void userVariable(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); CELL c; @@ -3622,30 +3878,30 @@ static void userVariable(FICL_VM *pVM) static void toValue(FICL_VM *pVM) { STRINGINFO si = vmGetWord(pVM); - FICL_DICT *dp = ficlGetDict(); + FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; #if FICL_WANT_LOCALS - if ((nLocals > 0) && (pVM->state == COMPILE)) + if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE)) { - FICL_DICT *pLoc = ficlGetLoc(); + FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); pFW = dictLookup(pLoc, si); if (pFW && (pFW->code == doLocalIm)) { - dictAppendCell(dp, LVALUEtoCELL(pToLocalParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } else if (pFW && pFW->code == do2LocalIm) { - dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } } #endif - assert(pStore); + assert(pVM->pSys->pStore); pFW = dictLookup(dp, si); if (!pFW) @@ -3660,7 +3916,7 @@ static void toValue(FICL_VM *pVM) { PUSHPTR(&pFW->param[0]); literalIm(pVM); - dictAppendCell(dp, LVALUEtoCELL(pStore)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore)); } return; } @@ -3750,8 +4006,8 @@ static void toLocal1(FICL_VM *pVM) */ static void doLocalIm(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); - int nLocal = pVM->runningWord->param[0].i; + FICL_DICT *pDict = vmGetDict(pVM); + FICL_INT nLocal = pVM->runningWord->param[0].i; if (pVM->state == INTERPRET) { @@ -3762,15 +4018,15 @@ static void doLocalIm(FICL_VM *pVM) if (nLocal == 0) { - dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0)); } else if (nLocal == 1) { - dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1)); } else { - dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocal)); } } @@ -3803,52 +4059,51 @@ static void doLocalIm(FICL_VM *pVM) **************************************************************************/ static void localParen(FICL_VM *pVM) { - static CELL *pMark = NULL; - FICL_DICT *pDict; - STRINGINFO si; + FICL_DICT *pDict; + STRINGINFO si; #if FICL_ROBUST > 1 - vmCheckStack(pVM,2,0); + vmCheckStack(pVM,2,0); #endif - pDict = ficlGetDict(); - SI_SETLEN(si, POPUNS()); - SI_SETPTR(si, (char *)POPPTR()); + pDict = vmGetDict(pVM); + SI_SETLEN(si, POPUNS()); + SI_SETPTR(si, (char *)POPPTR()); if (SI_COUNT(si) > 0) { /* add a local to the **locals** dict and update nLocals */ - FICL_DICT *pLoc = ficlGetLoc(); - if (nLocals >= FICL_MAX_LOCALS) + FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); + if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) { vmThrowErr(pVM, "Error: out of local space"); } dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); - dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); + dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); - if (nLocals == 0) + if (pVM->pSys->nLocals == 0) { /* compile code to create a local stack frame */ - dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); /* save location in dictionary for #locals */ - pMarkLocals = pDict->here; - dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + pVM->pSys->pMarkLocals = pDict->here; + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); /* compile code to initialize first local */ - dictAppendCell(pDict, LVALUEtoCELL(pToLocal0)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0)); } - else if (nLocals == 1) + else if (pVM->pSys->nLocals == 1) { - dictAppendCell(pDict, LVALUEtoCELL(pToLocal1)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1)); } else { - dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen)); - dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); } - nLocals++; + (pVM->pSys->nLocals)++; } - else if (nLocals > 0) + else if (pVM->pSys->nLocals > 0) { /* write nLocals to (link) param area in dictionary */ - *(FICL_INT *)pMarkLocals = nLocals; + *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; } return; @@ -3866,8 +4121,8 @@ static void get2LocalParen(FICL_VM *pVM) static void do2LocalIm(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); - int nLocal = pVM->runningWord->param[0].i; + FICL_DICT *pDict = vmGetDict(pVM); + FICL_INT nLocal = pVM->runningWord->param[0].i; if (pVM->state == INTERPRET) { @@ -3876,7 +4131,7 @@ static void do2LocalIm(FICL_VM *pVM) } else { - dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocal)); } return; @@ -3894,38 +4149,38 @@ static void to2LocalParen(FICL_VM *pVM) static void twoLocalParen(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); + FICL_DICT *pDict = vmGetDict(pVM); STRINGINFO si; SI_SETLEN(si, stackPopUNS(pVM->pStack)); SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); if (SI_COUNT(si) > 0) { /* add a local to the **locals** dict and update nLocals */ - FICL_DICT *pLoc = ficlGetLoc(); - if (nLocals >= FICL_MAX_LOCALS) + FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); + if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) { vmThrowErr(pVM, "Error: out of local space"); } dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); - dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); + dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); - if (nLocals == 0) + if (pVM->pSys->nLocals == 0) { /* compile code to create a local stack frame */ - dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); /* save location in dictionary for #locals */ - pMarkLocals = pDict->here; - dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + pVM->pSys->pMarkLocals = pDict->here; + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); } - dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen)); - dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); - nLocals += 2; + pVM->pSys->nLocals += 2; } - else if (nLocals > 0) + else if (pVM->pSys->nLocals > 0) { /* write nLocals to (link) param area in dictionary */ - *(FICL_INT *)pMarkLocals = nLocals; + *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; } return; @@ -3947,7 +4202,7 @@ static void twoLocalParen(FICL_VM *pVM) ** lesser numeric value than the corresponding character in the string specified ** by c-addr2 u2 and one (1) otherwise. **************************************************************************/ -static void compareString(FICL_VM *pVM) +static void compareInternal(FICL_VM *pVM, int caseInsensitive) { char *cp1, *cp2; FICL_UNS u1, u2, uMin; @@ -3962,7 +4217,14 @@ static void compareString(FICL_VM *pVM) uMin = (u1 < u2)? u1 : u2; for ( ; (uMin > 0) && (n == 0); uMin--) { - n = (int)(*cp1++ - *cp2++); + char c1 = *cp1++; + char c2 = *cp2++; + if (caseInsensitive) + { + c1 = (char)tolower(c1); + c2 = (char)tolower(c2); + } + n = (int)(c1 - c2); } if (n == 0) @@ -3978,6 +4240,30 @@ static void compareString(FICL_VM *pVM) } +static void compareString(FICL_VM *pVM) +{ + compareInternal(pVM, FALSE); +} + + +static void compareStringInsensitive(FICL_VM *pVM) +{ + compareInternal(pVM, TRUE); +} + + +/************************************************************************** + p a d +** CORE EXT ( -- c-addr ) +** c-addr is the address of a transient region that can be used to hold +** data for intermediate processing. +**************************************************************************/ +static void pad(FICL_VM *pVM) +{ + stackPushPtr(pVM->pStack, pVM->pad); +} + + /************************************************************************** s o u r c e - i d ** CORE EXT, FILE ( -- 0 | -1 | fileid ) @@ -4043,8 +4329,6 @@ static void refill(FICL_VM *pVM) static void ficlCatch(FICL_VM *pVM) { - static FICL_WORD *pQuit = NULL; - int except; jmp_buf vmState; FICL_VM VM; @@ -4052,11 +4336,8 @@ static void ficlCatch(FICL_VM *pVM) FICL_STACK rStack; FICL_WORD *pFW; - if (!pQuit) - pQuit = ficlLookup("exit-inner"); - assert(pVM); - assert(pQuit); + assert(pVM->pSys->pExitInner); /* @@ -4103,7 +4384,7 @@ static void ficlCatch(FICL_VM *pVM) ** the XT */ case 0: - vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */ + vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */ vmExecute(pVM, pFW); vmInnerLoop(pVM); break; @@ -4267,19 +4548,22 @@ WORDKIND ficlWordClassify(FICL_WORD *pFW) static CODEtoKIND codeMap[] = { - {BRANCH, branchParen}, - {COLON, colonParen}, + {BRANCH, branchParen}, + {COLON, colonParen}, {CONSTANT, constantParen}, - {CREATE, createParen}, - {DO, doParen}, - {DOES, doDoes}, - {IF, ifParen}, - {LITERAL, literalParen}, - {LOOP, loopParen}, - {PLOOP, plusLoopParen}, - {QDO, qDoParen}, - {STRINGLIT, stringLit}, - {USER, userParen}, + {CREATE, createParen}, + {DO, doParen}, + {DOES, doDoes}, + {IF, ifParen}, + {LITERAL, literalParen}, + {LOOP, loopParen}, + {PLOOP, plusLoopParen}, + {QDO, qDoParen}, + {CSTRINGLIT, cstringLit}, + {STRINGLIT, stringLit}, +#if FICL_WANT_USER + {USER, userParen}, +#endif {VARIABLE, variableParen}, }; @@ -4308,11 +4592,12 @@ void ficlCompileCore(FICL_SYSTEM *pSys) FICL_DICT *dp = pSys->dp; assert (dp); + /* ** CORE word set ** see softcore.c for definitions of: abs bl space spaces abort" */ - pStore = + pSys->pStore = dictAppendWord(dp, "!", store, FW_DEFAULT); dictAppendWord(dp, "#", numberSign, FW_DEFAULT); dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); @@ -4325,7 +4610,6 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "+", add, FW_DEFAULT); dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); - pComma = dictAppendWord(dp, ",", comma, FW_DEFAULT); dictAppendWord(dp, "-", sub, FW_DEFAULT); dictAppendWord(dp, ".", displayCell, FW_DEFAULT); @@ -4334,7 +4618,6 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); - dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); @@ -4390,10 +4673,9 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "execute", execute, FW_DEFAULT); dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); dictAppendWord(dp, "fill", fill, FW_DEFAULT); - dictAppendWord(dp, "find", find, FW_DEFAULT); + dictAppendWord(dp, "find", cFind, FW_DEFAULT); dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); dictAppendWord(dp, "here", here, FW_DEFAULT); - dictAppendWord(dp, "hex", hex, FW_DEFAULT); dictAppendWord(dp, "hold", hold, FW_DEFAULT); dictAppendWord(dp, "i", loopICo, FW_COMPILE); dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); @@ -4429,7 +4711,6 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "state", state, FW_DEFAULT); dictAppendWord(dp, "swap", swap, FW_DEFAULT); dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); - pType = dictAppendWord(dp, "type", type, FW_DEFAULT); dictAppendWord(dp, "u.", uDot, FW_DEFAULT); dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); @@ -4447,17 +4728,25 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "]", rbracket, FW_DEFAULT); /* ** CORE EXT word set... - ** see softcore.c for other definitions + ** see softcore.fr for other definitions */ - dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); - dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); + /* "#tib" */ + dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE); + /* ".r" */ + dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); dictAppendWord(dp, "2>r", twoToR, FW_COMPILE); dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE); dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE); + dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); + dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE); + /* case of endof endcase */ + dictAppendWord(dp, "hex", hex, FW_DEFAULT); + dictAppendWord(dp, "pad", pad, FW_DEFAULT); dictAppendWord(dp, "parse", parse, FW_DEFAULT); dictAppendWord(dp, "pick", pick, FW_DEFAULT); + /* query restore-input save-input tib u.r u> unused [compile] */ dictAppendWord(dp, "roll", roll, FW_DEFAULT); dictAppendWord(dp, "refill", refill, FW_DEFAULT); dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); @@ -4469,20 +4758,20 @@ void ficlCompileCore(FICL_SYSTEM *pSys) /* ** Set CORE environment query values */ - ficlSetEnv("/counted-string", FICL_STRING_MAX); - ficlSetEnv("/hold", nPAD); - ficlSetEnv("/pad", nPAD); - ficlSetEnv("address-unit-bits", 8); - ficlSetEnv("core", FICL_TRUE); - ficlSetEnv("core-ext", FICL_FALSE); - ficlSetEnv("floored", FICL_FALSE); - ficlSetEnv("max-char", UCHAR_MAX); - ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff ); - ficlSetEnv("max-n", 0x7fffffff); - ficlSetEnv("max-u", 0xffffffff); - ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff); - ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK); - ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); + ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX); + ficlSetEnv(pSys, "/hold", nPAD); + ficlSetEnv(pSys, "/pad", nPAD); + ficlSetEnv(pSys, "address-unit-bits", 8); + ficlSetEnv(pSys, "core", FICL_TRUE); + ficlSetEnv(pSys, "core-ext", FICL_FALSE); + ficlSetEnv(pSys, "floored", FICL_FALSE); + ficlSetEnv(pSys, "max-char", UCHAR_MAX); + ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff); + ficlSetEnv(pSys, "max-n", 0x7fffffff); + ficlSetEnv(pSys, "max-u", 0xffffffff); + ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff); + ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK); + ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK); /* ** DOUBLE word set (partial) @@ -4499,42 +4788,42 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); - ficlSetEnv("exception", FICL_TRUE); - ficlSetEnv("exception-ext", FICL_TRUE); + ficlSetEnv(pSys, "exception", FICL_TRUE); + ficlSetEnv(pSys, "exception-ext", FICL_TRUE); /* ** LOCAL and LOCAL EXT ** see softcore.c for implementation of locals| */ #if FICL_WANT_LOCALS - pLinkParen = + pSys->pLinkParen = dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); - pUnLinkParen = + pSys->pUnLinkParen = dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); - pGetLocalParen = + pSys->pGetLocalParen = dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); - pToLocalParen = + pSys->pToLocalParen = dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); - pGetLocal0 = + pSys->pGetLocal0 = dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); - pToLocal0 = + pSys->pToLocal0 = dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); - pGetLocal1 = + pSys->pGetLocal1 = dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); - pToLocal1 = + pSys->pToLocal1 = dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); dictAppendWord(dp, "(local)", localParen, FW_COMPILE); - pGet2LocalParen = + pSys->pGet2LocalParen = dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); - pTo2LocalParen = + pSys->pTo2LocalParen = dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); - ficlSetEnv("locals", FICL_TRUE); - ficlSetEnv("locals-ext", FICL_TRUE); - ficlSetEnv("#locals", FICL_MAX_LOCALS); + ficlSetEnv(pSys, "locals", FICL_TRUE); + ficlSetEnv(pSys, "locals-ext", FICL_TRUE); + ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS); #endif /* @@ -4545,8 +4834,7 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "free", ansFree, FW_DEFAULT); dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); - ficlSetEnv("memory-alloc", FICL_TRUE); - ficlSetEnv("memory-alloc-ext", FICL_FALSE); + ficlSetEnv(pSys, "memory-alloc", FICL_TRUE); /* ** optional SEARCH-ORDER word set @@ -4559,8 +4847,18 @@ void ficlCompileCore(FICL_SYSTEM *pSys) ficlCompileTools(pSys); /* + ** FILE and FILE EXT + */ +#if FICL_WANT_FILE + ficlCompileFile(pSys); +#endif + + /* ** Ficl extras */ +#if FICL_WANT_FLOAT + dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); +#endif dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); dictAppendWord(dp, ">name", toName, FW_DEFAULT); @@ -4568,13 +4866,19 @@ void ficlCompileCore(FICL_SYSTEM *pSys) addParseStep, FW_DEFAULT); dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ + dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compile-only", compileOnly, FW_DEFAULT); dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT); dictAppendWord(dp, "hash", hash, FW_DEFAULT); + dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT); + dictAppendWord(dp, "?object", isObject, FW_DEFAULT); dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); + dictAppendWord(dp, "sfind", sFind, FW_DEFAULT); dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ + dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT); + dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT); dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT); dictAppendWord(dp, "q!", quadStore, FW_DEFAULT); dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); @@ -4584,42 +4888,54 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); dictAppendWord(dp, "user", userVariable, FW_DEFAULT); #endif + /* ** internal support words */ dictAppendWord(dp, "(create)", createParen, FW_COMPILE); - pExitParen = + pSys->pExitParen = dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); - pSemiParen = + pSys->pSemiParen = dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); - pLitParen = + pSys->pLitParen = dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); - pTwoLitParen = + pSys->pTwoLitParen = dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); - pStringLit = + pSys->pStringLit = dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); - pIfParen = + pSys->pCStringLit = + dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE); + pSys->pIfParen = dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); - pBranchParen = + pSys->pBranchParen = dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); - pDoParen = + pSys->pDoParen = dictAppendWord(dp, "(do)", doParen, FW_COMPILE); - pDoesParen = + pSys->pDoesParen = dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); - pQDoParen = + pSys->pQDoParen = dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); - pLoopParen = + pSys->pLoopParen = dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); - pPLoopParen = + pSys->pPLoopParen = dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); - pInterpret = + pSys->pInterpret = dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); + dictAppendWord(dp, "lookup", lookup, FW_DEFAULT); dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); dictAppendWord(dp, "(parse-step)", parseStepParen, FW_DEFAULT); + pSys->pExitInner = dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); + /* + ** Set up system's outer interpreter loop - maybe this should be in initSystem? + */ + pSys->pInterp[0] = pSys->pInterpret; + pSys->pInterp[1] = pSys->pBranchParen; + pSys->pInterp[2] = (FICL_WORD *)(void *)(-2); + assert(dictCellsAvail(dp) > 0); return; |