Add EXCEPTION word set.

Make TIB handling use buffer size to conform with ANS Forth.

Add ANS MEMORY-ALLOC word set.

See the PRs for extensive details.

PR:		kern/9412 kern/9442 kern/9514
Submitted by:	PRs from Daniel Sobral <dcs@newsguy.com>

13 files changed, 339 insertions, 58 deletions

diff --git a/sys/boot/ficl/alpha/sysdep.c b/sys/boot/ficl/alpha/sysdep.c
index 84a704d..8d4ed74 100644
--- a/sys/boot/ficl/alpha/sysdep.c
+++ b/sys/boot/ficl/alpha/sysdep.c
@@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
     return malloc(size);
 }
 
+void *ficlRealloc (void *p, size_t size)
+{
+    return realloc(p, size);
+}
+
 void  ficlFree   (void *p)
 {
     free(p);
 }
 
+#ifndef TESTMAIN
 #ifdef __i386__
 /* 
  * outb ( port# c -- )
@@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
 	stackPushINT32(pVM->pStack,c);
 }
 #endif
+#endif
 
 /*
 ** Stub function for dictionary access control - does nothing
diff --git a/sys/boot/ficl/alpha/sysdep.h b/sys/boot/ficl/alpha/sysdep.h
index 4095701..170a690 100644
--- a/sys/boot/ficl/alpha/sysdep.h
+++ b/sys/boot/ficl/alpha/sysdep.h
@@ -215,6 +215,7 @@ typedef struct
 struct vm;
 void  ficlTextOut(struct vm *pVM, char *msg, int fNewline);
 void *ficlMalloc (size_t size);
+void *ficlRealloc (void *p, size_t size);
 void  ficlFree   (void *p);
 
 /*
diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c
index 3b5885f..f8b13ac 100644
--- a/sys/boot/ficl/ficl.c
+++ b/sys/boot/ficl/ficl.c
@@ -170,7 +170,7 @@ int ficlBuild(char *name, FICL_CODE code, char flags)
 **      time to delete the vm, etc -- or you can ignore this
 **      signal.
 **************************************************************************/
-int ficlExec(FICL_VM *pVM, char *pText)
+int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
 {
     int        except;
     FICL_WORD *tempFW;
@@ -180,7 +180,7 @@ int ficlExec(FICL_VM *pVM, char *pText)
 
     assert(pVM);
 
-    vmPushTib(pVM, pText, &saveTib);
+    vmPushTib(pVM, pText, size, &saveTib);
 
     /*
     ** Save and restore VM's jmp_buf to enable nested calls to ficlExec 
@@ -237,6 +237,8 @@ int ficlExec(FICL_VM *pVM, char *pText)
         break;
 
     case VM_ERREXIT:
+    case VM_ABORT:
+    case VM_ABORTQ:
     default:    /* user defined exit code?? */
         if (pVM->state == COMPILE)
         {
@@ -285,8 +287,7 @@ int ficlExecFD(FICL_VM *pVM, int fd)
 		break;
 	    continue;
 	}
-	cp[i] = '\0';
-        if ((rval = ficlExec(pVM, cp)) >= VM_ERREXIT)
+        if ((rval = ficlExec(pVM, cp, i)) >= VM_ERREXIT)
         {
             pVM->sourceID = id;
             vmThrowErr(pVM, "ficlExecFD: Error at line %d", nLine);
@@ -298,7 +299,7 @@ int ficlExecFD(FICL_VM *pVM, int fd)
     ** any pending REFILLs (as required by FILE wordset)
     */
     pVM->sourceID.i = -1;
-    ficlExec(pVM, "");
+    ficlExec(pVM, "", 0);
 
     pVM->sourceID = id;
     return rval;
diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h
index 3fcb32e..7a54df9 100644
--- a/sys/boot/ficl/ficl.h
+++ b/sys/boot/ficl/ficl.h
@@ -114,6 +114,19 @@
 ** 4. Ficl uses the pad in 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.
+** 5. The whole inner interpreter is screwed up. It ought to be detached
+**    from ficlExec. Also, it should fall in line with exception
+**    handling by saving state. (sobral)
+** 6. EXCEPTION should be cleaned. Right now, it doubles ficlExec's
+**    inner interpreter. (sobral)
+** 7. colonParen must get the inner interpreter working on it's "case"
+**    *before* returning, so that it becomes possible to execute them
+**    inside other definitions without recreating the inner interpreter
+**    or other such hacks. (sobral)
+** 8. We now have EXCEPTION word set. Let's:
+**    8.1. Use the appropriate exceptions throughout the code.
+**    8.2. Print the error messages at ficlExec, so someone can catch
+**         them first. (sobral)
 **
 ** F o r   M o r e   I n f o r m a t i o n
 **
@@ -153,6 +166,15 @@
 
 /*
 ** Revision History:
+**
+** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an
+** "end" field, and all words respect this. ficlExec is passed a "size"
+** of TIB, as well as vmPushTib. This size is used to calculate the "end"
+** of the string, ie, base+size. If the size is not known, pass -1.
+**
+** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing
+** words has been modified to conform to EXCEPTION EXT word set. 
+**
 ** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT,
 **  SEARCH / SEARCH EXT, TOOLS / TOOLS EXT. 
 **  Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD,
@@ -292,10 +314,19 @@ typedef struct
 ** the block of text it's working on and an index to the next
 ** unconsumed character in the string. Traditionally, this is
 ** done by a Text Input Buffer, so I've called this struct TIB.
+**
+** Since this structure also holds the size of the input buffer,
+** and since evaluate requires that, let's put the size here.
+** The size is stored as an end-pointer because that is what the
+** null-terminated string aware functions find most easy to deal
+** with.
+** Notice, though, that nobody really uses this except evaluate,
+** so it might just be moved to FICL_VM instead. (sobral)
 */
 typedef struct
 {
     INT32 index;
+    char *end;
     char *cp;
 } TIB;
 
@@ -470,11 +501,13 @@ int wordIsCompileOnly(FICL_WORD *pFW);
 /*
 ** Exit codes for vmThrow
 */
-#define VM_OUTOFTEXT    1   /* hungry - normal exit */
-#define VM_RESTART      2   /* word needs more text to suxcceed - re-run it */
-#define VM_USEREXIT     3   /* user wants to quit */
-#define VM_ERREXIT      4   /* interp found an error */
-#define VM_QUIT         5   /* like errexit, but leave pStack & base alone */
+#define VM_OUTOFTEXT -256   /* hungry - normal exit */
+#define VM_RESTART   -257   /* word needs more text to suxcceed - re-run it */
+#define VM_USEREXIT  -258   /* user wants to quit */
+#define VM_ERREXIT   -259   /* interp found an error */
+#define VM_ABORT       -1   /* like errexit -- abort */
+#define VM_ABORTQ      -2   /* like errexit -- abort" */
+#define VM_QUIT       -56   /* like errexit, but leave pStack & base alone */
 
 
 void        vmBranchRelative(FICL_VM *pVM, int offset);
@@ -513,7 +546,7 @@ void        vmCheckStack(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, TIB *pSaveTib);
+void        vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib);
 void        vmPopTib(FICL_VM *pVM, TIB *pTib);
 #define     vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
 #define     vmSetTibIndex(pVM, i) (pVM)->tib.index = i
@@ -535,7 +568,7 @@ char       *ltoa( INT32 value, char *string, int radix );
 char       *ultoa(UNS32 value, char *string, int radix );
 char        digit_to_char(int value);
 char       *strrev( char *string );
-char       *skipSpace(char *cp);
+char       *skipSpace(char *cp,char *end);
 char       *caseFold(char *cp);
 int         strincmp(char *cp1, char *cp2, FICL_COUNT count);
 
@@ -677,7 +710,8 @@ void       ficlTermSystem(void);
 ** f i c l E x e c
 ** Evaluates a block of input text in the context of the
 ** specified interpreter. Emits any requested output to the
-** interpreter's output function
+** interpreter's output function. If the size of the input
+** is not known, pass -1.
 ** Execution returns when the text block has been executed,
 ** or an error occurs.
 ** Returns one of the VM_XXXX codes defined in ficl.h:
@@ -689,10 +723,12 @@ void       ficlTermSystem(void);
 **      to shut down the interpreter. This would be a good
 **      time to delete the vm, etc -- or you can ignore this
 **      signal.
+** VM_ABORT and VM_ABORTQ are generated by 'abort' and 'abort"'
+**      commands.
 ** Preconditions: successful execution of ficlInitSystem,
 **      Successful creation and init of the VM by ficlNewVM (or equiv)
 */
-int        ficlExec(FICL_VM *pVM, char *pText);
+int        ficlExec(FICL_VM *pVM, char *pText, INT32 size);
 
 /*
 ** ficlExecFD(FICL_VM *pVM, int fd);
diff --git a/sys/boot/ficl/i386/sysdep.c b/sys/boot/ficl/i386/sysdep.c
index 84a704d..8d4ed74 100644
--- a/sys/boot/ficl/i386/sysdep.c
+++ b/sys/boot/ficl/i386/sysdep.c
@@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
     return malloc(size);
 }
 
+void *ficlRealloc (void *p, size_t size)
+{
+    return realloc(p, size);
+}
+
 void  ficlFree   (void *p)
 {
     free(p);
 }
 
+#ifndef TESTMAIN
 #ifdef __i386__
 /* 
  * outb ( port# c -- )
@@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
 	stackPushINT32(pVM->pStack,c);
 }
 #endif
+#endif
 
 /*
 ** Stub function for dictionary access control - does nothing
diff --git a/sys/boot/ficl/i386/sysdep.h b/sys/boot/ficl/i386/sysdep.h
index 4095701..170a690 100644
--- a/sys/boot/ficl/i386/sysdep.h
+++ b/sys/boot/ficl/i386/sysdep.h
@@ -215,6 +215,7 @@ typedef struct
 struct vm;
 void  ficlTextOut(struct vm *pVM, char *msg, int fNewline);
 void *ficlMalloc (size_t size);
+void *ficlRealloc (void *p, size_t size);
 void  ficlFree   (void *p);
 
 /*
diff --git a/sys/boot/ficl/softwords/softcore.awk b/sys/boot/ficl/softwords/softcore.awk
index b182b99..8928db6 100644
--- a/sys/boot/ficl/softwords/softcore.awk
+++ b/sys/boot/ficl/softwords/softcore.awk
@@ -91,6 +91,6 @@ END \
   printf "    \"quit \";\n";
   printf "\n\nvoid ficlCompileSoftCore(FICL_VM *pVM)\n";
   printf "{\n";
-  printf "    assert(ficlExec(pVM, softWords) != VM_ERREXIT);\n";
+  printf "    assert(ficlExec(pVM, softWords, -1) != VM_ERREXIT);\n";
   printf "}\n";
 }
diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr
index bcc2696..2b11142 100644
--- a/sys/boot/ficl/softwords/softcore.fr
+++ b/sys/boot/ficl/softwords/softcore.fr
@@ -33,7 +33,9 @@ decimal 32 constant bl
     postpone if 
     postpone ." 
     postpone cr 
-    postpone abort 
+    -2
+    postpone literal
+    postpone throw 
     postpone endif 
 ; immediate 
 
diff --git a/sys/boot/ficl/sysdep.c b/sys/boot/ficl/sysdep.c
index 84a704d..8d4ed74 100644
--- a/sys/boot/ficl/sysdep.c
+++ b/sys/boot/ficl/sysdep.c
@@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
     return malloc(size);
 }
 
+void *ficlRealloc (void *p, size_t size)
+{
+    return realloc(p, size);
+}
+
 void  ficlFree   (void *p)
 {
     free(p);
 }
 
+#ifndef TESTMAIN
 #ifdef __i386__
 /* 
  * outb ( port# c -- )
@@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
 	stackPushINT32(pVM->pStack,c);
 }
 #endif
+#endif
 
 /*
 ** Stub function for dictionary access control - does nothing
diff --git a/sys/boot/ficl/sysdep.h b/sys/boot/ficl/sysdep.h
index 4095701..170a690 100644
--- a/sys/boot/ficl/sysdep.h
+++ b/sys/boot/ficl/sysdep.h
@@ -215,6 +215,7 @@ typedef struct
 struct vm;
 void  ficlTextOut(struct vm *pVM, char *msg, int fNewline);
 void *ficlMalloc (size_t size);
+void *ficlRealloc (void *p, size_t size);
 void  ficlFree   (void *p);
 
 /*
diff --git a/sys/boot/ficl/testmain.c b/sys/boot/ficl/testmain.c
index f7cdc44..bfb7364 100644
--- a/sys/boot/ficl/testmain.c
+++ b/sys/boot/ficl/testmain.c
@@ -144,11 +144,8 @@ static void ficlLoad(FICL_VM *pVM)
         if (len <= 0)
             continue;
 
-        if (cp[len] == '\n')
-            cp[len] = '\0';
-
-        result = ficlExec(pVM, cp);
-        if (result >= VM_ERREXIT)
+        result = ficlExec(pVM, cp, len);
+        if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
         {
             pVM->sourceID = id;
             fclose(fp);
@@ -161,7 +158,7 @@ static void ficlLoad(FICL_VM *pVM)
     ** any pending REFILLs (as required by FILE wordset)
     */
     pVM->sourceID.i = -1;
-    ficlExec(pVM, "");
+    ficlExec(pVM, "", 0);
 
     pVM->sourceID = id;
     fclose(fp);
@@ -246,7 +243,7 @@ int main(int argc, char **argv)
     buildTestInterface();
     pVM = ficlNewVM();
 
-    ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
+    ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit", -1);
 
     /*
     ** load file from cmd line...
@@ -254,7 +251,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);
+        ficlExec(pVM, in, -1);
     }
 
     for (;;)
@@ -262,7 +259,7 @@ int main(int argc, char **argv)
         int ret;
         if (fgets(in, sizeof(in) - 1, stdin) == NULL)
 	    break;
-        ret = ficlExec(pVM, in);
+        ret = ficlExec(pVM, in, -1);
         if (ret == VM_USEREXIT)
         {
             ficlTermSystem();
diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c
index 6852c62..ebdf944 100644
--- a/sys/boot/ficl/vm.c
+++ b/sys/boot/ficl/vm.c
@@ -156,17 +156,17 @@ STRINGINFO vmGetWord0(FICL_VM *pVM)
     UNS32 count = 0;
     char ch;
 
-    pSrc = skipSpace(pSrc);
+    pSrc = skipSpace(pSrc,pVM->tib.end);
     SI_SETPTR(si, pSrc);
 
-    for (ch = *pSrc; ch != '\0' && !isspace(ch); ch = *++pSrc)
+    for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc)
     {
         count++;
     }
 
     SI_SETLEN(si, count);
 
-    if (isspace(ch))    /* skip one trailing delimiter */
+    if ((pVM->tib.end != pSrc) && isspace(ch))    /* skip one trailing delimiter */
         pSrc++;
 
     vmUpdateTib(pVM, pSrc);
@@ -210,14 +210,15 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
 {
     STRINGINFO si;
     char *pSrc      = vmGetInBuf(pVM);
-    char ch;
+    char ch; 
 
-    while (*pSrc == delim)  /* skip lead delimiters */
+    while ((pVM->tib.end != pSrc) && (*pSrc == delim))  /* skip lead delimiters */
         pSrc++;
 
     SI_SETPTR(si, pSrc);    /* mark start of text */
 
-    for (ch = *pSrc; (ch != delim)
+    for (ch = *pSrc; (pVM->tib.end != pSrc)
+		  && (ch != delim)
                   && (ch != '\0') 
                   && (ch != '\r') 
                   && (ch != '\n'); ch = *++pSrc)
@@ -228,7 +229,7 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
                             /* set length of result */
     SI_SETLEN(si, pSrc - SI_PTR(si));
 
-    if (*pSrc == delim)     /* gobble trailing delimiter */
+    if ((pVM->tib.end != pSrc) && (*pSrc == delim))     /* gobble trailing delimiter */
         pSrc++;
 
     vmUpdateTib(pVM, pSrc);
@@ -263,7 +264,7 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
                         v m P u s h T i b
 ** Binds the specified input string to the VM and clears >IN (the index)
 **************************************************************************/
-void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib)
+void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib)
 {
     if (pSaveTib)
     {
@@ -271,6 +272,7 @@ void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib)
     }
 
     pVM->tib.cp = text;
+    pVM->tib.end = text + size;
     pVM->tib.index = 0;
 }
 
@@ -302,6 +304,7 @@ void vmQuit(FICL_VM *pVM)
     pVM->runningWord = pInterp;
     pVM->state       = INTERPRET;
     pVM->tib.cp      = NULL;
+    pVM->tib.end     = NULL;
     pVM->tib.index   = 0;
     pVM->pad[0]      = '\0';
     pVM->sourceID.i  = 0;
@@ -551,12 +554,14 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count)
                         s k i p S p a c e
 ** Given a string pointer, returns a pointer to the first non-space
 ** char of the string, or to the NULL terminator if no such char found.
+** If the pointer reaches "end" first, stop there. If you don't want
+** that, pass NULL.
 **************************************************************************/
-char *skipSpace(char *cp)
+char *skipSpace(char *cp, char *end)
 {
     assert(cp);
 
-    while (isspace(*cp))
+    while ((cp != end) && isspace(*cp))
         cp++;
 
     return cp;
diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c
index c76c169..d7a420b 100644
--- a/sys/boot/ficl/words.c
+++ b/sys/boot/ficl/words.c
@@ -880,7 +880,7 @@ static void commentLine(FICL_VM *pVM)
     char *cp = vmGetInBuf(pVM);
     char ch = *cp;
 
-    while ((ch != '\0') && (ch != '\r') && (ch != '\n'))
+    while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n'))
     {
         ch = *++cp;
     }
@@ -890,11 +890,11 @@ static void commentLine(FICL_VM *pVM)
     ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
     ** and point cp to next char. If EOL is \0, we're done.
     */
-    if (ch != '\0')
+    if ((pVM->tib.end != cp) && (ch != '\0'))
     {
         cp++;
 
-        if ( (ch != *cp) 
+        if ( (pVM->tib.end != cp) && (ch != *cp) 
              && ((*cp == '\r') || (*cp == '\n')) )
             cp++;
     }
@@ -1180,13 +1180,10 @@ 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 */
 }
 
@@ -1234,7 +1231,6 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si)
             {
                 vmThrowErr(pVM, "Error: Compile only!");
             }
-
             vmExecute(pVM, tempFW);
         }
 
@@ -2069,13 +2065,13 @@ static void dotParen(FICL_VM *pVM)
     char *pDest = pVM->pad;
     char ch;
 
-    pSrc = skipSpace(pSrc);
+    pSrc = skipSpace(pSrc,pVM->tib.end);
 
-    for (ch = *pSrc; (ch != '\0') && (ch != ')'); ch = *++pSrc)
+    for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc)
         *pDest++ = ch;
 
     *pDest = '\0';
-    if (ch == ')')
+    if ((pVM->tib.end != pSrc) && (ch == ')'))
         pSrc++;
 
     vmTextOut(pVM, pVM->pad, 0);
@@ -2441,7 +2437,7 @@ static void quit(FICL_VM *pVM)
 
 static void ficlAbort(FICL_VM *pVM)
 {
-    vmThrow(pVM, VM_ERREXIT);
+    vmThrow(pVM, VM_ABORT);
     return;
 }
 
@@ -2462,6 +2458,10 @@ static void ficlAbort(FICL_VM *pVM)
 ** Implementation: if there's more text in the TIB, use it. Otherwise
 ** throw out for more text. Copy characters up to the max count into the
 ** address given, and return the number of actual characters copied.
+**
+** This may not strictly violate the standard, but I'm sure any programs
+** asking for user input at load time will *not* be expecting this
+** behavior. (sobral)
 **************************************************************************/
 static void accept(FICL_VM *pVM)
 {
@@ -2469,7 +2469,7 @@ static void accept(FICL_VM *pVM)
     char *cp;
     char *pBuf = vmGetInBuf(pVM);
 
-    len = strlen(pBuf);
+    for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++);
     if (len == 0)
         vmThrow(pVM, VM_RESTART);
     /* OK - now we have something in the text buffer - use it */
@@ -2692,25 +2692,28 @@ 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 and input buffer, set >IN to zero, and interpret.
+** both the input source andinput 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. 
 **
-** DEFICIENCY: this version does not handle errors or restarts.
+** DEFICIENCY: this version does not handle restarts. Also, exceptions
+** are just passed ahead. Is this the Right Thing? I don't know...
 **************************************************************************/
 static void evaluate(FICL_VM *pVM)
 {
-    UNS32 count = stackPopUNS32(pVM->pStack);
+    INT32 count = stackPopINT32(pVM->pStack);
     char *cp    = stackPopPtr(pVM->pStack);
     CELL id;
+    int result;
 
-    IGNORE(count);
     id = pVM->sourceID;
     pVM->sourceID.i = -1;
     vmPushIP(pVM, &pInterpret);
-    ficlExec(pVM, cp);
+    result = ficlExec(pVM, cp, count);
     vmPopIP(pVM);
     pVM->sourceID = id;
+    if (result != VM_OUTOFTEXT)
+	vmThrow(pVM, result);
     return;
 }
 
@@ -2843,12 +2846,12 @@ static void parse(FICL_VM *pVM)
 
     cp = pSrc;              /* mark start of text */
 
-    while ((*pSrc != delim) && (*pSrc != '\0'))
+    while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0'))
         pSrc++;             /* find next delimiter or end */
 
     count = pSrc - cp;      /* set length of result */
 
-    if (*pSrc == delim)     /* gobble trailing delimiter */
+    if ((pVM->tib.end != pSrc) && (*pSrc == delim))     /* gobble trailing delimiter */
         pSrc++;
 
     vmUpdateTib(pVM, pSrc);
@@ -3159,9 +3162,11 @@ static void sToD(FICL_VM *pVM)
 ** input buffer. 
 **************************************************************************/
 static void source(FICL_VM *pVM)
-{
+{   int i;
+
     stackPushPtr(pVM->pStack, pVM->tib.cp);
-    stackPushINT32(pVM->pStack, strlen(pVM->tib.cp));
+    for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++);
+    stackPushINT32(pVM->pStack, i);
     return;
 }
 
@@ -4049,6 +4054,194 @@ static void forget(FICL_VM *pVM)
     return;
 }
 
+/*************** freebsd added memory-alloc handling words ******************/
+
+static void allocate(FICL_VM *pVM)
+{
+    size_t size;
+    void *p;
+
+    size = stackPopINT32(pVM->pStack);
+    p = ficlMalloc(size);
+    stackPushPtr(pVM->pStack, p);
+    if (p)
+	stackPushINT32(pVM->pStack, 0);
+    else
+	stackPushINT32(pVM->pStack, 1);
+}
+
+static void free4th(FICL_VM *pVM)
+{
+    void *p;
+
+    p = stackPopPtr(pVM->pStack);
+    ficlFree(p);
+    stackPushINT32(pVM->pStack, 0);
+}
+
+static void resize(FICL_VM *pVM)
+{
+    size_t size;
+    void *new, *old;
+
+    size = stackPopINT32(pVM->pStack);
+    old = stackPopPtr(pVM->pStack);
+    new = ficlRealloc(old, size);
+    if (new) {
+	stackPushPtr(pVM->pStack, new);
+	stackPushINT32(pVM->pStack, 0);
+     } else {
+	stackPushPtr(pVM->pStack, old);
+	stackPushINT32(pVM->pStack, 1);
+    }
+}
+
+/***************** freebsd added exception handling words *******************/
+
+/*
+ * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
+ * the word in ToS. If an exception happens, restore the state to what
+ * it was before, and pushes the exception value on the stack. If not,
+ * push zero.
+ *
+ * Notice that Catch implements an inner interpreter. This is ugly,
+ * but given how ficl works, it cannot be helped. The problem is that
+ * colon definitions will be executed *after* the function returns,
+ * while "code" definitions will be executed immediately. I considered
+ * other solutions to this problem, but all of them shared the same
+ * basic problem (with added disadvantages): if ficl ever changes it's
+ * inner thread modus operandi, one would have to fix this word.
+ *
+ * More comments can be found throughout catch's code.
+ *
+ * BUGS: do not handle locals unnesting correctly... I think...
+ *
+ * Daniel C. Sobral	Jan 09/1999
+ */
+
+static void catch(FICL_VM *pVM)
+{
+	int		except;
+	jmp_buf		vmState;
+	FICL_VM		VM;
+	FICL_STACK	pStack;
+	FICL_STACK	rStack;
+	FICL_WORD	*pFW;
+	IPTYPE		exitIP;
+
+	/*
+         * Get xt.
+	 * We need this *before* we save the stack pointer, or
+         * we'll have to pop one element out of the stack after
+         * an exception. I prefer to get done with it up front. :-)
+         */
+#if FICL_ROBUST > 1
+	vmCheckStack(pVM, 1, 0);
+#endif
+	pFW = stackPopPtr(pVM->pStack);
+
+	/* 
+	 * Save vm's state -- a catch will not back out environmental
+         * changes.
+	 *
+	 * We are *not* saving dictionary state, since it is
+	 * global instead of per vm, and we are not saving
+	 * stack contents, since we are not required to (and,
+	 * thus, it would be useless). We save pVM, and pVM
+	 * "stacks" (a structure containing general information
+	 * about it, including the current stack pointer).
+         */
+	memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
+	memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
+	memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
+
+	/*
+	 * Give pVM a jmp_buf
+	 */
+	pVM->pState = &vmState;
+
+	/*
+	 * Safety net
+	 */
+	except = setjmp(vmState);
+
+	/*
+	 * And now, choose what to do depending on except.
+	 */
+
+		/* Things having gone wrong... */
+	if(except) {
+		/* 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 */
+		stackPushINT32(pVM->pStack, except);
+
+		/* Things being ok... */
+	} else {
+		/*
+		 * 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 */
+		stackPushINT32(pVM->pStack, 0);
+	}
+}
+
+/*
+ * Throw -- maybe vmThow already do what's required, but I don't really
+ * know what happens when you longjmp(buf, 0). From ANS Forth standard.
+ *
+ * Anyway, throw takes the ToS and, if that's different from zero,
+ * returns to the last executed catch context. Further throws will
+ * unstack previously executed "catches", in LIFO mode.
+ *
+ * Daniel C. Sobral	Jan 09/1999
+ */
+
+static void throw(FICL_VM *pVM)
+{
+	int except;
+	
+	except = stackPopINT32(pVM->pStack);
+
+	if (except)
+		vmThrow(pVM, except);
+}
+
 /************************* freebsd added I/O words **************************/
 
 /*          fopen - open a file and return new fd on stack.
@@ -4385,14 +4578,37 @@ void ficlCompileCore(FICL_DICT *dp)
     dictAppendWord(dp, "key?",	    keyQuestion,    FW_DEFAULT);
     dictAppendWord(dp, "ms",        ms,             FW_DEFAULT);
     dictAppendWord(dp, "seconds",   pseconds,       FW_DEFAULT);
-#ifdef __i386__
+    /*
+    ** EXCEPTION word set
+    */
+    dictAppendWord(dp, "catch",     catch,          FW_DEFAULT);
+    dictAppendWord(dp, "throw",     throw,          FW_DEFAULT);
+    
+    ficlSetEnv("exception",         FICL_TRUE);
+    ficlSetEnv("exception-ext",     FICL_TRUE);
+
+    /*
+    ** MEMORY-ALLOC word set
+    */
+    dictAppendWord(dp, "allocate",  allocate,       FW_DEFAULT);
+    dictAppendWord(dp, "free",      free4th,        FW_DEFAULT);
+    dictAppendWord(dp, "resize",    resize,         FW_DEFAULT);
+ 
+    ficlSetEnv("memory-alloc",         FICL_TRUE);
+
 #ifndef TESTMAIN
+#ifdef __i386__
     dictAppendWord(dp, "outb",      ficlOutb,       FW_DEFAULT);
     dictAppendWord(dp, "inb",       ficlInb,        FW_DEFAULT);
 #endif
+#endif
+
+#if defined(__i386__)
     ficlSetEnv("arch-i386",         FICL_TRUE);
-#else
+    ficlSetEnv("arch-alpha",        FICL_FALSE);
+#elif defined(__alpha__)
     ficlSetEnv("arch-i386",         FICL_FALSE);
+    ficlSetEnv("arch-alpha",        FICL_TRUE);
 #endif
 
     /*