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

commit.

9 files changed, 423 insertions, 162 deletions

diff --git a/sys/boot/ficl/dict.c b/sys/boot/ficl/dict.c
index a2f5990..5f75a25 100644
--- a/sys/boot/ficl/dict.c
+++ b/sys/boot/ficl/dict.c
@@ -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)
 {
diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c
index ad776be..60e12b3 100644
--- a/sys/boot/ficl/ficl.c
+++ b/sys/boot/ficl/ficl.c
@@ -132,6 +132,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.
 ** Preconditions: system must be initialized, and there must
@@ -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;
 }
+
+
diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h
index ac5e57e..79199d1 100644
--- a/sys/boot/ficl/ficl.h
+++ b/sys/boot/ficl/ficl.h
@@ -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
@@ -772,6 +778,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.
 */
diff --git a/sys/boot/ficl/softwords/classes.fr b/sys/boot/ficl/softwords/classes.fr
index 75dc35a..9e578fb 100644
--- a/sys/boot/ficl/softwords/classes.fr
+++ b/sys/boot/ficl/softwords/classes.fr
@@ -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 )
diff --git a/sys/boot/ficl/softwords/jhlocal.fr b/sys/boot/ficl/softwords/jhlocal.fr
index 034ada5..85d1fe3 100644
--- a/sys/boot/ficl/softwords/jhlocal.fr
+++ b/sys/boot/ficl/softwords/jhlocal.fr
@@ -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
 
diff --git a/sys/boot/ficl/softwords/oo.fr b/sys/boot/ficl/softwords/oo.fr
index cd16c77..65ddf33 100644
--- a/sys/boot/ficl/softwords/oo.fr
+++ b/sys/boot/ficl/softwords/oo.fr
@@ -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 )
diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr
index bf584d0..b32ed3e 100644
--- a/sys/boot/ficl/softwords/softcore.fr
+++ b/sys/boot/ficl/softwords/softcore.fr
@@ -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
diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c
index bb6b1f8..0676cdb 100644
--- a/sys/boot/ficl/vm.c
+++ b/sys/boot/ficl/vm.c
@@ -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 */
 
@@ -260,6 +269,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
 ** 
 **************************************************************************/
@@ -364,6 +394,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
 **************************************************************************/
diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c
index 179157c..ab6700d 100644
--- a/sys/boot/ficl/words.c
+++ b/sys/boot/ficl/words.c
@@ -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;
@@ -1159,6 +1172,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:
 **   while there are words in the VM's Text Input Buffer
@@ -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);
-
-    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++;
+    STRINGINFO si;
+	char delim      = (char)stackPopINT(pVM->pStack);
 
-    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.
-    */
-
-    /* Things having gone wrong... */
-    if(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;
+
+		/*
+		** 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);
@@ -4711,6 +4809,14 @@ void ficlCompileCore(FICL_DICT *dp)
     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
     */
     dictAppendWord(dp, "catch",     ficlCatch,      FW_DEFAULT);
@@ -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 =