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

Bring in FICL 2.04. No bump of loader version is required by this

Browse Source 
commit.
This commit is contained in:
Daniel C. Sobral 2000-05-26 21:35:08 +00:00
parent 35f9e4a1db
commit 7795d19132
Notes: svn2git 2020-12-20 02:59:44 +00:00 
svn path=/head/; revision=60959
9 changed files with 422 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -381,8 +381,7 @@ void dictDelete(FICL_DICT *pDict)
/**************************************************************************
d i c t E m p t y
** Empty the dictionary, reset its hash table, and reset its search order.
** Clears and (re-)creates the main hash table (pForthWords) with the
** size specified by nHash.
** Clears and (re-)creates the hash table with the size specified by nHash.
**************************************************************************/
void dictEmpty(FICL_DICT *pDict, unsigned nHash)
{

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

@ -131,6 +131,38 @@ FICL_VM *ficlNewVM(void)
}
/**************************************************************************
f i c l F r e e V M
** Removes the VM in question from the system VM list and deletes the
** memory allocated to it. This is an optional call, since ficlTermSystem
** will do this cleanup for you. This function is handy if you're going to
** do a lot of dynamic creation of VMs.
**************************************************************************/
void ficlFreeVM(FICL_VM *pVM)
{
FICL_VM *pList = vmList;
assert(pVM != 0);
if (vmList == pVM)
{
vmList = vmList->link;
}
else for (pList; pList != 0; pList = pList->link)
{
if (pList->link == pVM)
{
pList->link = pVM->link;
break;
}
}
if (pList)
vmDelete(pVM);
return;
}
/**************************************************************************
f i c l B u i l d
** Builds a word into the dictionary.
@ -151,6 +183,7 @@ int ficlBuild(char *name, FICL_CODE code, char flags)
int err = ficlLockDictionary(TRUE);
if (err) return err;
assert(dictCellsAvail(dp) > sizeof (FICL_WORD) / sizeof (CELL));
dictAppendWord(dp, name, code, flags);
ficlLockDictionary(FALSE);
@ -187,9 +220,8 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
int except;
jmp_buf vmState;
jmp_buf *oldState;
TIB saveTib;
FICL_VM VM;
FICL_STACK rStack;
if (!pInterp)
pInterp = ficlLookup("interpret");
@ -203,11 +235,9 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
vmPushTib(pVM, pText, size, &saveTib);
/*
** Save and restore pVM and pVM->rStack to enable nested calls to ficlExec
** Save and restore VM's jmp_buf to enable nested calls to ficlExec
*/
memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
oldState = pVM->pState;
pVM->pState = &vmState; /* This has to come before the setjmp! */
except = setjmp(vmState);
@ -267,14 +297,11 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
#endif
}
dictResetSearchOrder(dp);
memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
stackReset(pVM->pStack);
pVM->base = 10;
vmReset(pVM);
break;
}
pVM->pState = VM.pState;
pVM->pState = oldState;
vmPopTib(pVM, &saveTib);
return (except);
}
@ -393,7 +420,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
vmThrow(pVM, except);
}
break;
}
}
pVM->pState = oldState;
return (except);
@ -543,3 +570,5 @@ void ficlTermSystem(void)
return;
}

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

@ -517,11 +517,17 @@ 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, ...);
@ -533,13 +539,13 @@ void vmThrowErr(FICL_VM *pVM, char *fmt, ...);
** The inner interpreter - coded as a macro (see note for
** INLINE_INNER_LOOP in sysdep.h for complaints about VC++ 5
*/
#define M_INNER_LOOP(pVM) \
for (;;) \
{ \
#define M_VM_STEP(pVM) \
FICL_WORD *tempFW = *(pVM)->ip++; \
(pVM)->runningWord = tempFW; \
tempFW->code(pVM); \
}
#define M_INNER_LOOP(pVM) \
for (;;) { M_VM_STEP(pVM) }
#if INLINE_INNER_LOOP != 0
@ -771,6 +777,16 @@ int ficlExecFD(FICL_VM *pVM, int fd);
*/
FICL_VM *ficlNewVM(void);
/*
** Force deletion of a VM. You do not need to do this
** unless you're creating and discarding a lot of VMs.
** For systems that use a constant pool of VMs for the life
** of the system, ficltermSystem takes care of VM cleanup
** automatically.
*/
void ficlFreeVM(FICL_VM *pVM);
/*
** Set the stack sizes (return and parameter) to be used for all
** subsequently created VMs. Returns actual stack size to be used.

12
sys/boot/ficl/softwords/classes.fr
View File

@ -2,6 +2,8 @@
\ ** F I C L 2 . 0 C L A S S E S
\ john sadler 1 sep 98
\ Needs oop.fr
\
\ $FreeBSD$
.( loading ficl utility classes ) cr
also oop definitions
@ -68,6 +70,16 @@ object subclass c-ptr
c-4byte => set
;
\ force the pointer to be null
: clr-ptr
0 -rot c-ptr => .addr c-4byte => set
;
\ return flag indicating null-ness
: ?null ( inst class -- flag )
c-ptr => get-ptr 0=
;
\ increment the pointer in place
: inc-ptr ( inst class -- )
2dup 2dup ( i c i c i c )

35
sys/boot/ficl/softwords/jhlocal.fr
View File

@ -9,6 +9,11 @@
\ locstate: 0 = looking for | or -- or }}
\ 1 = found |
\ 2 = found --
\ 3 = found }
\ 4 = end of line
\
\ $FreeBSD$
hide
0 constant zero
@ -19,16 +24,18 @@ hide
: ?| ( c-addr u -- c-addr u flag )
2dup s" |" compare 0= ;
\ examine name and push true if it's a 2local
\ (starts with '2'), false otherwise.
: ?2loc ( c-addr u -- c-addr n flag )
over c@ [char] 2 = if true else false endif ;
: ?delim ( c-addr u -- state | c-addr u 0 )
?| if
2drop 1
else
?-- if
2drop 2
else
?} if 2drop 3 else 0 endif
endif
endif
?| if 2drop 1 exit endif
?-- if 2drop 2 exit endif
?} if 2drop 3 exit endif
dup 0=
if 2drop 4 exit endif
0
;
set-current
@ -45,7 +52,9 @@ set-current
repeat
\ now unstack the locals
0 do (local) loop \ ( )
0 do
?2loc if (2local) else (local) endif
loop \ ( )
\ zero locals until -- or }
locstate 1 = if
@ -53,7 +62,11 @@ set-current
parse-word
?delim dup to locstate
0= while
postpone zero (local)
?2loc if
postpone zero postpone zero (2local)
else
postpone zero (local)
endif
repeat
endif

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

@ -1,6 +1,9 @@
\ ** ficl/softwords/oo.fr
\ ** F I C L O - O E X T E N S I O N S
\ ** john sadler aug 1998
\
\ $FreeBSD$
.( loading ficl O-O extensions ) cr
7 ficl-vocabulary oop
@ -216,6 +219,10 @@ set-current previous
\ instance of the class. This word gets compiled into
\ 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
\ >> control structure match codes on the stack, of undefined size
\ >> easiest way around this is use of this thread-local variable
\
: do-do-instance ( -- )
s" : .do-instance does> [ current-class @ ] literal ;"
@ -232,7 +239,8 @@ set-current previous
\
:noname
wordlist
create immediate
create
immediate
0 , \ NULL parent class
dup , \ wid
3 cells , \ instance size
@ -295,6 +303,24 @@ previous
--> array-init
;
\ Create an anonymous initialized instance from the heap
: alloc \ ( class metaclass -- instance class )
locals| meta class |
class meta metaclass => get-size allocate ( -- addr fail-flag )
abort" allocate failed " ( -- addr )
class 2dup --> init
;
\ Create an anonymous array of initialized instances from the heap
: alloc-array \ ( n class metaclass -- instance class )
locals| meta class nobj |
class meta metaclass => get-size
nobj * allocate ( -- addr fail-flag )
abort" allocate failed " ( -- addr )
nobj over class --> array-init
class
;
\ create a proxy object with initialized payload address given
: ref ( instance-addr class metaclass "name" -- )
drop create , ,
@ -412,6 +438,14 @@ do-do-instance
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 "
;
\ Instance aliases for common class methods
\ Upcast to parent class
: super ( instance class -- instance parent-class )

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

@ -69,6 +69,8 @@ decimal 32 constant bl
: local ( name -- ) bl word count (local) ; immediate
: 2local ( name -- ) bl word count (2local) ; immediate
: end-locals ( -- ) 0 0 (local) ; immediate
\ #endif

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

@ -118,6 +118,7 @@ void vmInnerLoop(FICL_VM *pVM)
}
#endif
/**************************************************************************
v m G e t S t r i n g
** Parses a string out of the VM input buffer and copies up to the first
@ -128,7 +129,7 @@ void vmInnerLoop(FICL_VM *pVM)
**************************************************************************/
char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
{
STRINGINFO si = vmParseString(pVM, delimiter);
STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
if (SI_COUNT(si) > FICL_STRING_MAX)
{
@ -229,14 +230,22 @@ int vmGetWordToPad(FICL_VM *pVM)
** trailing delimiter.
**************************************************************************/
STRINGINFO vmParseString(FICL_VM *pVM, char delim)
{
return vmParseStringEx(pVM, delim, 1);
}
STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
{
STRINGINFO si;
char *pSrc = vmGetInBuf(pVM);
char *pEnd = vmGetInBufEnd(pVM);
char ch;
while ((pSrc != pEnd) && (*pSrc == delim)) /* skip lead delimiters */
pSrc++;
if (fSkipLeading)
{ /* skip lead delimiters */
while ((pSrc != pEnd) && (*pSrc == delim))
pSrc++;
}
SI_SETPTR(si, pSrc); /* mark start of text */
@ -259,6 +268,27 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
}
/**************************************************************************
v m P o p
**
**************************************************************************/
CELL vmPop(FICL_VM *pVM)
{
return stackPop(pVM->pStack);
}
/**************************************************************************
v m P u s h
**
**************************************************************************/
void vmPush(FICL_VM *pVM, CELL c)
{
stackPush(pVM->pStack, c);
return;
}
/**************************************************************************
v m P o p I P
**
@ -363,6 +393,18 @@ 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

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

@ -52,6 +52,7 @@ static FICL_WORD *pExitParen = NULL;
static FICL_WORD *pIfParen = NULL;
static FICL_WORD *pInterpret = NULL;
static FICL_WORD *pLitParen = NULL;
static FICL_WORD *pTwoLitParen = NULL;
static FICL_WORD *pLoopParen = NULL;
static FICL_WORD *pPLoopParen = NULL;
static FICL_WORD *pQDoParen = NULL;
@ -62,16 +63,24 @@ static FICL_WORD *pType = NULL;
#if FICL_WANT_LOCALS
static FICL_WORD *pGetLocalParen= NULL;
static FICL_WORD *pGet2LocalParen= NULL;
static FICL_WORD *pGetLocal0 = NULL;
static FICL_WORD *pGetLocal1 = NULL;
static FICL_WORD *pToLocalParen = NULL;
static FICL_WORD *pTo2LocalParen = NULL;
static FICL_WORD *pToLocal0 = NULL;
static FICL_WORD *pToLocal1 = NULL;
static FICL_WORD *pLinkParen = NULL;
static FICL_WORD *pUnLinkParen = NULL;
static int nLocals = 0;
static CELL *pMarkLocals = NULL;
static void doLocalIm(FICL_VM *pVM);
static void do2LocalIm(FICL_VM *pVM);
#endif
/*
** C O N T R O L S T R U C T U R E B U I L D E R S
**
@ -223,6 +232,18 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si)
}
static void ficlIsNum(FICL_VM *pVM)
{
STRINGINFO si;
FICL_INT ret;
SI_SETLEN(si, stackPopINT(pVM->pStack));
SI_SETPTR(si, stackPopPtr(pVM->pStack));
ret = isNumber(pVM, si) ? FICL_TRUE : FICL_FALSE;
stackPushINT(pVM->pStack, ret);
return;
}
/**************************************************************************
a d d & f r i e n d s
**
@ -915,7 +936,7 @@ static void commentLine(FICL_VM *pVM)
*/
static void commentHang(FICL_VM *pVM)
{
vmParseString(pVM, ')');
vmParseStringEx(pVM, ')', 0);
return;
}
@ -1068,11 +1089,7 @@ static void ifCoIm(FICL_VM *pVM)
** called (not?branch) since it does "branch if false".
**************************************************************************/
#ifdef FICL_TRACE
void ifParen(FICL_VM *pVM)
#else
static void ifParen(FICL_VM *pVM)
#endif
{
FICL_UNS flag;
@ -1134,11 +1151,7 @@ static void elseCoIm(FICL_VM *pVM)
** compilation address, and branches to that location.
**************************************************************************/
#ifdef FICL_TRACE
void branchParen(FICL_VM *pVM)
#else
static void branchParen(FICL_VM *pVM)
#endif
{
vmBranchRelative(pVM, *(int *)(pVM->ip));
return;
@ -1158,6 +1171,22 @@ static void endifCoIm(FICL_VM *pVM)
}
/**************************************************************************
h a s h
** hash ( c-addr u -- code)
** calculates hashcode of specified string and leaves it on the stack
**************************************************************************/
static void hash(FICL_VM *pVM)
{
STRINGINFO si;
SI_SETLEN(si, stackPopUNS(pVM->pStack));
SI_SETPTR(si, stackPopPtr(pVM->pStack));
stackPushUNS(pVM->pStack, hashHashCode(si));
return;
}
/**************************************************************************
i n t e r p r e t
** This is the "user interface" of a Forth. It does the following:
@ -1188,10 +1217,13 @@ static void interpret(FICL_VM *pVM)
** Get next word...if out of text, we're done.
*/
if (si.count == 0)
{
vmThrow(pVM, VM_OUTOFTEXT);
}
interpWord(pVM, si);
return; /* back to inner interpreter */
}
@ -1239,6 +1271,7 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si)
{
vmThrowErr(pVM, "Error: Compile only!");
}
vmExecute(pVM, tempFW);
}
@ -1285,11 +1318,8 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si)
** parameter stack at runtime. This code is compiled by "literal".
**
**************************************************************************/
#ifdef FICL_TRACE
void literalParen(FICL_VM *pVM)
#else
static void literalParen(FICL_VM *pVM)
#endif
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
@ -1299,6 +1329,17 @@ static void literalParen(FICL_VM *pVM)
return;
}
static void twoLitParen(FICL_VM *pVM)
{
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 2);
#endif
stackPushINT(pVM->pStack, *((FICL_INT *)(pVM->ip)+1));
stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip));
vmBranchRelative(pVM, 2);
return;
}
/**************************************************************************
l i t e r a l I m
@ -1320,6 +1361,18 @@ static void literalIm(FICL_VM *pVM)
}
static void twoLiteralIm(FICL_VM *pVM)
{
FICL_DICT *dp = ficlGetDict();
assert(pTwoLitParen);
dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen));
dictAppendCell(dp, stackPop(pVM->pStack));
dictAppendCell(dp, stackPop(pVM->pStack));
return;
}
/**************************************************************************
l i s t W o r d s
**
@ -1602,11 +1655,8 @@ static void doCoIm(FICL_VM *pVM)
return;
}
#ifdef FICL_TRACE
void doParen(FICL_VM *pVM)
#else
static void doParen(FICL_VM *pVM)
#endif
{
CELL index, limit;
#if FICL_ROBUST > 1
@ -1645,11 +1695,8 @@ static void qDoCoIm(FICL_VM *pVM)
return;
}
#ifdef FICL_TRACE
void qDoParen(FICL_VM *pVM)
#else
static void qDoParen(FICL_VM *pVM)
#endif
{
CELL index, limit;
#if FICL_ROBUST > 1
@ -1722,11 +1769,8 @@ static void plusLoopCoIm(FICL_VM *pVM)
return;
}
#ifdef FICL_TRACE
void loopParen(FICL_VM *pVM)
#else
static void loopParen(FICL_VM *pVM)
#endif
{
FICL_INT index = stackGetTop(pVM->rStack).i;
FICL_INT limit = stackFetch(pVM->rStack, 1).i;
@ -1747,11 +1791,8 @@ static void loopParen(FICL_VM *pVM)
return;
}
#ifdef FICL_TRACE
void plusLoopParen(FICL_VM *pVM)
#else
static void plusLoopParen(FICL_VM *pVM)
#endif
{
FICL_INT index = stackGetTop(pVM->rStack).i;
FICL_INT limit = stackFetch(pVM->rStack, 1).i;
@ -2057,11 +2098,8 @@ static void compileOnly(FICL_VM *pVM)
** and count on the stack. Finally, update ip to point to the first
** aligned address after the string text.
**************************************************************************/
#ifdef FICL_TRACE
void stringLit(FICL_VM *pVM)
#else
static void stringLit(FICL_VM *pVM)
#endif
{
FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
FICL_COUNT count = sp->count;
@ -2092,8 +2130,6 @@ static void dotParen(FICL_VM *pVM)
char *pDest = pVM->pad;
char ch;
pSrc = skipSpace(pSrc, pEnd);
for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
*pDest++ = ch;
@ -2597,6 +2633,19 @@ static void repeatCoIm(FICL_VM *pVM)
}
static void againCoIm(FICL_VM *pVM)
{
FICL_DICT *dp = ficlGetDict();
assert(pBranchParen);
dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
/* expect "begin" branch marker */
resolveBackBranch(dp, pVM, destTag);
return;
}
/**************************************************************************
c h a r & f r i e n d s
** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
@ -2723,7 +2772,7 @@ static void environmentQ(FICL_VM *pVM)
** EVALUATE CORE ( i*x c-addr u -- j*x )
** Save the current input source specification. Store minus-one (-1) in
** SOURCE-ID if it is present. Make the string described by c-addr and u
** both the input source andinput buffer, set >IN to zero, and interpret.
** both the input source and input buffer, set >IN to zero, and interpret.
** When the parse area is empty, restore the prior input source
** specification. Other stack effects are due to the words EVALUATEd.
**
@ -2775,6 +2824,7 @@ static void stringQuoteIm(FICL_VM *pVM)
return;
}
/**************************************************************************
t y p e
** Pop count and char address from stack and print the designated string.
@ -2822,7 +2872,7 @@ static void ficlWord(FICL_VM *pVM)
char delim = (char)stackPopINT(pVM->pStack);
STRINGINFO si;
si = vmParseString(pVM, delim);
si = vmParseStringEx(pVM, delim, 1);
if (SI_COUNT(si) > nPAD-1)
SI_SETLEN(si, nPAD-1);
@ -2863,27 +2913,12 @@ static void parseNoCopy(FICL_VM *pVM)
**************************************************************************/
static void parse(FICL_VM *pVM)
{
char *pSrc = vmGetInBuf(pVM);
char *pEnd = vmGetInBufEnd(pVM);
char *cp;
FICL_UNS count;
char delim = (char)stackPopINT(pVM->pStack);
STRINGINFO si;
char delim = (char)stackPopINT(pVM->pStack);
cp = pSrc; /* mark start of text */
while ((pSrc != pEnd) && (*pSrc != delim))
{
pSrc++; /* find next delimiter or end */
}
count = pSrc - cp; /* set length of result */
if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
stackPushPtr(pVM->pStack, cp);
stackPushUNS(pVM->pStack, count);
si = vmParseStringEx(pVM, delim, 0);
stackPushPtr(pVM->pStack, SI_PTR(si));
stackPushUNS(pVM->pStack, SI_COUNT(si));
return;
}
@ -2942,6 +2977,7 @@ static void find(FICL_VM *pVM)
}
/**************************************************************************
f m S l a s h M o d
** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
@ -3189,8 +3225,7 @@ static void sToD(FICL_VM *pVM)
** input buffer.
**************************************************************************/
static void source(FICL_VM *pVM)
{ int i;
{
stackPushPtr(pVM->pStack, pVM->tib.cp);
stackPushINT(pVM->pStack, vmGetInBufLen(pVM));
return;
@ -3555,16 +3590,22 @@ static void toValue(FICL_VM *pVM)
FICL_WORD *pFW;
#if FICL_WANT_LOCALS
FICL_DICT *pLoc = ficlGetLoc();
if ((nLocals > 0) && (pVM->state == COMPILE))
{
FICL_DICT *pLoc = ficlGetLoc();
pFW = dictLookup(pLoc, si);
if (pFW)
if (pFW && (pFW->code == doLocalIm))
{
dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
}
else if (pFW && pFW->code == do2LocalIm)
{
dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen));
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
}
}
#endif
@ -3726,14 +3767,13 @@ static void doLocalIm(FICL_VM *pVM)
**************************************************************************/
static void localParen(FICL_VM *pVM)
{
static CELL *pMark = NULL;
FICL_DICT *pDict = ficlGetDict();
STRINGINFO si;
SI_SETLEN(si, stackPopUNS(pVM->pStack));
SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
if (SI_COUNT(si) > 0)
{ /* add a local to the dict and update nLocals */
{ /* add a local to the **locals** dict and update nLocals */
FICL_DICT *pLoc = ficlGetLoc();
if (nLocals >= FICL_MAX_LOCALS)
{
@ -3747,7 +3787,7 @@ static void localParen(FICL_VM *pVM)
{ /* compile code to create a local stack frame */
dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
/* save location in dictionary for #locals */
pMark = pDict->here;
pMarkLocals = pDict->here;
dictAppendCell(pDict, LVALUEtoCELL(nLocals));
/* compile code to initialize first local */
dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
@ -3766,7 +3806,84 @@ static void localParen(FICL_VM *pVM)
}
else if (nLocals > 0)
{ /* write nLocals to (link) param area in dictionary */
*(FICL_INT *)pMark = nLocals;
*(FICL_INT *)pMarkLocals = nLocals;
}
return;
}
static void get2LocalParen(FICL_VM *pVM)
{
FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
return;
}
static void do2LocalIm(FICL_VM *pVM)
{
FICL_DICT *pDict = ficlGetDict();
int nLocal = pVM->runningWord->param[0].i;
if (pVM->state == INTERPRET)
{
stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
}
else
{
dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen));
dictAppendCell(pDict, LVALUEtoCELL(nLocal));
}
return;
}
static void to2LocalParen(FICL_VM *pVM)
{
FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
return;
}
static void twoLocalParen(FICL_VM *pVM)
{
FICL_DICT *pDict = ficlGetDict();
STRINGINFO si;
SI_SETLEN(si, stackPopUNS(pVM->pStack));
SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
if (SI_COUNT(si) > 0)
{ /* add a local to the **locals** dict and update nLocals */
FICL_DICT *pLoc = ficlGetLoc();
if (nLocals >= FICL_MAX_LOCALS)
{
vmThrowErr(pVM, "Error: out of local space");
}
dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
if (nLocals == 0)
{ /* compile code to create a local stack frame */
dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
/* save location in dictionary for #locals */
pMarkLocals = pDict->here;
dictAppendCell(pDict, LVALUEtoCELL(nLocals));
}
dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
dictAppendCell(pDict, LVALUEtoCELL(nLocals));
nLocals += 2;
}
else if (nLocals > 0)
{ /* write nLocals to (link) param area in dictionary */
*(FICL_INT *)pMarkLocals = nLocals;
}
return;
@ -3813,11 +3930,7 @@ static void setParentWid(FICL_VM *pVM)
** like it's in the dictionary address range.
** NOTE: this excludes :noname words!
*/
#ifdef FICL_TRACE
int isAFiclWord(FICL_WORD *pFW)
#else
static int isAFiclWord(FICL_WORD *pFW)
#endif
{
FICL_DICT *pd = ficlGetDict();
@ -4262,20 +4375,27 @@ static void fkey(FICL_VM *pVM)
**
** More comments can be found throughout catch's code.
**
** BUGS: do not handle locals unnesting correctly... I think...
**
** Daniel C. Sobral Jan 09/1999
** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
**************************************************************************/
static void ficlCatch(FICL_VM *pVM)
{
int except;
static FICL_WORD *pQuit = NULL;
int except;
jmp_buf vmState;
FICL_VM VM;
FICL_STACK pStack;
FICL_STACK rStack;
FICL_WORD *pFW;
IPTYPE exitIP;
if (!pQuit)
pQuit = ficlLookup("exit-inner");
assert(pVM);
assert(pQuit);
/*
** Get xt.
@ -4313,63 +4433,42 @@ static void ficlCatch(FICL_VM *pVM)
*/
except = setjmp(vmState);
/*
** And now, choose what to do depending on except.
*/
switch (except)
{
/*
** Setup condition - push poison pill so that the VM throws
** VM_INNEREXIT if the XT terminates normally, then execute
** the XT
*/
case 0:
vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */
vmExecute(pVM, pFW);
vmInnerLoop(pVM);
break;
/* Things having gone wrong... */
if(except)
{
/*
** Normal exit from XT - lose the poison pill,
** restore old setjmp vector and push a zero.
*/
case VM_INNEREXIT:
vmPopIP(pVM); /* Gack - hurl poison pill */
pVM->pState = VM.pState; /* Restore just the setjmp vector */
stackPushINT(pVM->pStack, 0); /* Push 0 -- everything is ok */
break;
/*
** Some other exception got thrown - restore pre-existing VM state
** and push the exception code
*/
default:
/* Restore vm's state */
memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
/* Push error */
stackPushINT(pVM->pStack, except);
}
else /* Things being ok... */
{
/*
* We need to know when to exit the inner loop
* Colonp, the "code" for colon words, just pushes
* the word's IP onto the RP, and expect the inner
* interpreter to do the rest. Well, I'd rather have
* it done *before* I return from this function,
* losing the automatic variables I'm using to save
* state. Sure, I could save this on dynamic memory
* and save state on RP, or I could even implement
* the poor man's version of this word in Forth with
* sp@, sp!, rp@ and rp!, but we have a lot of state
* neatly tucked away in pVM, so why not save it?
*/
exitIP = pVM->ip;
/* Execute the xt -- inline code for vmExecute */
pVM->runningWord = pFW;
pFW->code(pVM);
/*
** Run the inner loop until we get back to exitIP
*/
for (; pVM->ip != exitIP;)
{
pFW = *pVM->ip++;
/* Inline code for vmExecute */
pVM->runningWord = pFW;
pFW->code(pVM);
}
/* Restore just the setjmp vector */
pVM->pState = VM.pState;
/* Push 0 -- everything is ok */
stackPushINT(pVM->pStack, 0);
}
stackPushINT(pVM->pStack, except);/* Push error */
break;
}
}
/*
@ -4393,8 +4492,6 @@ static void ficlThrow(FICL_VM *pVM)
}
/*************** freebsd added memory-alloc handling words ******************/
static void ansAllocate(FICL_VM *pVM)
{
size_t size;
@ -4652,6 +4749,7 @@ void ficlCompileCore(FICL_DICT *dp)
dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);
dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
dictAppendWord(dp, "parse", parse, FW_DEFAULT);
dictAppendWord(dp, "pick", pick, FW_DEFAULT);
dictAppendWord(dp, "roll", roll, FW_DEFAULT);
@ -4710,6 +4808,14 @@ void ficlCompileCore(FICL_DICT *dp)
ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);
ficlSetEnv("stack-cells", FICL_DEFAULT_STACK);
/*
** DOUBLE word set (partial)
*/
dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
/*
** EXCEPTION word set
*/
@ -4743,6 +4849,12 @@ void ficlCompileCore(FICL_DICT *dp)
dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
pGet2LocalParen =
dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
pTo2LocalParen =
dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
ficlSetEnv("locals", FICL_TRUE);
ficlSetEnv("locals-ext", FICL_TRUE);
ficlSetEnv("#locals", FICL_MAX_LOCALS);
@ -4806,15 +4918,15 @@ void ficlCompileCore(FICL_DICT *dp)
dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */
dictAppendWord(dp, ">name", toName, FW_DEFAULT);
dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
dictAppendWord(dp, "compile-only",
compileOnly, FW_DEFAULT);
dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); /* DOUBLE */
dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
dictAppendWord(dp, "hash", hash, FW_DEFAULT);
dictAppendWord(dp, "number?", ficlIsNum, FW_DEFAULT);
dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
dictAppendWord(dp, "wid-set-super",
@ -4835,6 +4947,8 @@ void ficlCompileCore(FICL_DICT *dp)
dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
pLitParen =
dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
pTwoLitParen =
dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
pStringLit =
dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
pIfParen =