d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Upgrade to FICL version 3.02. Anything wrong is my fault, everything right is

Browse Source 
due Jon Mini.

PR:		36308
Submitted by:	Jon Mini <mini@haikugeek.com>
MFC after:	4 weeks
This commit is contained in:
Daniel C. Sobral 2002-04-09 17:45:28 +00:00
parent 4211c74cab
commit be88b71603
27 changed files with 3925 additions and 1275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
sys/boot/ficl/Makefile
View File

@ -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"

54
sys/boot/ficl/alpha/sysdep.h
View File

@ -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__*/

113
sys/boot/ficl/dict.c
View File

@ -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);

165
sys/boot/ficl/ficl.c
View File

@ -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;
}

402
sys/boot/ficl/ficl.h
View File

@ -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
View 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
View File

File diff suppressed because it is too large Load Diff

54
sys/boot/ficl/i386/sysdep.h
View File

@ -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__*/

52
sys/boot/ficl/ia64/sysdep.h
View File

@ -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__*/

20
sys/boot/ficl/loader.c
View File

@ -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;

14
sys/boot/ficl/math64.c
View File

@ -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$ */

14
sys/boot/ficl/math64.h
View File

@ -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$ */

36
sys/boot/ficl/prefix.c
View File

@ -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;
}

40
sys/boot/ficl/search.c
View File

@ -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
View 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
View 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
View 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

18
sys/boot/ficl/softwords/ifbrack.fr
View File

@ -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
sys/boot/ficl/softwords/marker.fr
View File

@ -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

363
sys/boot/ficl/softwords/oo.fr
View File

@ -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

2
sys/boot/ficl/softwords/prefix.fr
View File

@ -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

38
sys/boot/ficl/softwords/softcore.fr
View File

@ -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

16
sys/boot/ficl/stack.c
View File

@ -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);
}

90
sys/boot/ficl/testmain.c
View File

@ -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;
}
}

333
sys/boot/ficl/tools.c
View File

@ -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;
}

119
sys/boot/ficl/vm.c
View File

@ -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

1574
sys/boot/ficl/words.c
View File

File diff suppressed because it is too large Load Diff