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
This commit is contained in:
parent
4211c74cab
commit
be88b71603
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/head/; revision=94290
@ -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"
|
||||
|
@ -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.
|
||||
@ -198,6 +207,14 @@ typedef struct
|
||||
#define FICL_WANT_DEBUGGER 1
|
||||
#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
|
||||
@ -340,14 +357,6 @@ typedef struct
|
||||
#define FICL_MAX_PARSE_STEPS 8
|
||||
#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
|
||||
@ -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__*/
|
||||
|
@ -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;
|
||||
@ -459,6 +460,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
|
||||
@ -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);
|
||||
|
||||
|
@ -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);
|
||||
|
||||
/*
|
||||
** 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.
|
||||
** Establish the parse order. Note that prefixes precede numbers -
|
||||
** this allows constructs like "0b101010" which might parse as a
|
||||
** hex value otherwise.
|
||||
*/
|
||||
ficlNewVM();
|
||||
ficlAddPrecompiledParseStep(pSys, "?prefix", ficlParsePrefix);
|
||||
ficlAddPrecompiledParseStep(pSys, "?number", ficlParseNumber);
|
||||
#if FICL_WANT_FLOAT
|
||||
ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber);
|
||||
#endif
|
||||
|
||||
/*
|
||||
** 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(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);
|
||||
@ -297,6 +327,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
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
@ -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);
|
||||
|
||||
|
||||
/*
|
||||
@ -806,6 +810,23 @@ int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW); /* ficl.c */
|
||||
void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep);
|
||||
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
|
||||
@ -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
|
||||
|
425
sys/boot/ficl/fileaccess.c
Normal file
425
sys/boot/ficl/fileaccess.c
Normal file
@ -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 */
|
||||
}
|
1064
sys/boot/ficl/float.c
Normal file
1064
sys/boot/ficl/float.c
Normal file
File diff suppressed because it is too large
Load Diff
@ -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.
|
||||
@ -198,6 +207,14 @@ typedef struct
|
||||
#define FICL_WANT_DEBUGGER 1
|
||||
#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
|
||||
@ -340,14 +357,6 @@ typedef struct
|
||||
#define FICL_MAX_PARSE_STEPS 8
|
||||
#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
|
||||
@ -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__*/
|
||||
|
@ -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.
|
||||
@ -198,6 +209,14 @@ typedef struct
|
||||
#define FICL_WANT_DEBUGGER 1
|
||||
#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
|
||||
@ -340,14 +359,6 @@ typedef struct
|
||||
#define FICL_MAX_PARSE_STEPS 8
|
||||
#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
|
||||
@ -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__*/
|
||||
|
@ -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;
|
||||
|
@ -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$ */
|
||||
|
@ -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$ */
|
||||
|
@ -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;
|
||||
}
|
||||
|
@ -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);
|
||||
|
86
sys/boot/ficl/softwords/ficlclass.fr
Normal file
86
sys/boot/ficl/softwords/ficlclass.fr
Normal file
@ -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
|
26
sys/boot/ficl/softwords/fileaccess.fr
Normal file
26
sys/boot/ficl/softwords/fileaccess.fr
Normal file
@ -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
|
75
sys/boot/ficl/softwords/forml.fr
Normal file
75
sys/boot/ficl/softwords/forml.fr
Normal file
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,21 +276,43 @@ 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
|
||||
\ ( -- old-wid addr[size] 0 )
|
||||
\
|
||||
: 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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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);
|
||||
}
|
||||
|
@ -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;
|
||||
}
|
||||
}
|
||||
|
@ -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;
|
||||
|
||||
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;
|
||||
}
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
@ -439,18 +530,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
|
||||
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user