ref: 90bf6a12d969275fb47171207dcfd89c65d17895
author: jsadler <jsadler@ficl.sf.net>
date: Tue Jun 6 23:16:46 CDT 2000
*** empty log message ***
--- /dev/null
+++ b/.gitignore
@@ -1,0 +1,28 @@
+# CVS default ignores begin
+tags
+TAGS
+.make.state
+.nse_depinfo
+*~
+\#*
+.#*
+,*
+_$*
+*$
+*.old
+*.bak
+*.BAK
+*.orig
+*.rej
+.del-*
+*.a
+*.olb
+*.o
+*.obj
+*.so
+*.exe
+*.Z
+*.elc
+*.ln
+core
+# CVS default ignores end
--- /dev/null
+++ b/dict.c
@@ -1,0 +1,740 @@
+/*******************************************************************
+** d i c t . c
+** Forth Inspired Command Language - dictionary methods
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+**
+*******************************************************************/
+/*
+** This file implements the dictionary -- FICL's model of
+** memory management. All FICL words are stored in the
+** dictionary. A word is a named chunk of data with its
+** associated code. FICL treats all words the same, even
+** precompiled ones, so your words become first-class
+** extensions of the language. You can even define new
+** control structures.
+**
+** 29 jun 1998 (sadler) added variable sized hash table support
+*/
+
+#include <stdlib.h>
+#include <stdio.h> /* sprintf */
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+
+static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si);
+
+/**************************************************************************
+ d i c t A b o r t D e f i n i t i o n
+** Abort a definition in process: reclaim its memory and unlink it
+** from the dictionary list. Assumes that there is a smudged
+** definition in process...otherwise does nothing.
+** NOTE: this function is not smart enough to unlink a word that
+** has been successfully defined (ie linked into a hash). It
+** only works for defs in process. If the def has been unsmudged,
+** nothing happens.
+**************************************************************************/
+void dictAbortDefinition(FICL_DICT *pDict)
+{+ FICL_WORD *pFW;
+ ficlLockDictionary(TRUE);
+ pFW = pDict->smudge;
+
+ if (pFW->flags & FW_SMUDGE)
+ pDict->here = (CELL *)pFW->name;
+
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ a l i g n P t r
+** Aligns the given pointer to FICL_ALIGN address units.
+** Returns the aligned pointer value.
+**************************************************************************/
+void *alignPtr(void *ptr)
+{+#if FICL_ALIGN > 0
+ char *cp;
+ CELL c;
+ cp = (char *)ptr + FICL_ALIGN_ADD;
+ c.p = (void *)cp;
+ c.u = c.u & (~FICL_ALIGN_ADD);
+ ptr = (CELL *)c.p;
+#endif
+ return ptr;
+}
+
+
+/**************************************************************************
+ d i c t A l i g n
+** Align the dictionary's free space pointer
+**************************************************************************/
+void dictAlign(FICL_DICT *pDict)
+{+ pDict->here = alignPtr(pDict->here);
+}
+
+
+/**************************************************************************
+ d i c t A l l o t
+** Allocate or remove n chars of dictionary space, with
+** checks for underrun and overrun
+**************************************************************************/
+int dictAllot(FICL_DICT *pDict, int n)
+{+ char *cp = (char *)pDict->here;
+#if FICL_ROBUST
+ if (n > 0)
+ {+ if ((unsigned)n <= dictCellsAvail(pDict) * sizeof (CELL))
+ cp += n;
+ else
+ return 1; /* dict is full */
+ }
+ else
+ {+ n = -n;
+ if ((unsigned)n <= dictCellsUsed(pDict) * sizeof (CELL))
+ cp -= n;
+ else /* prevent underflow */
+ cp -= dictCellsUsed(pDict) * sizeof (CELL);
+ }
+#else
+ cp += n;
+#endif
+ pDict->here = PTRtoCELL cp;
+ return 0;
+}
+
+
+/**************************************************************************
+ d i c t A l l o t C e l l s
+** Reserve space for the requested number of cells in the
+** dictionary. If nCells < 0 , removes space from the dictionary.
+**************************************************************************/
+int dictAllotCells(FICL_DICT *pDict, int nCells)
+{+#if FICL_ROBUST
+ if (nCells > 0)
+ {+ if (nCells <= dictCellsAvail(pDict))
+ pDict->here += nCells;
+ else
+ return 1; /* dict is full */
+ }
+ else
+ {+ nCells = -nCells;
+ if (nCells <= dictCellsUsed(pDict))
+ pDict->here -= nCells;
+ else /* prevent underflow */
+ pDict->here -= dictCellsUsed(pDict);
+ }
+#else
+ pDict->here += nCells;
+#endif
+ return 0;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d C e l l
+** Append the specified cell to the dictionary
+**************************************************************************/
+void dictAppendCell(FICL_DICT *pDict, CELL c)
+{+ *pDict->here++ = c;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d C h a r
+** Append the specified char to the dictionary
+**************************************************************************/
+void dictAppendChar(FICL_DICT *pDict, char c)
+{+ char *cp = (char *)pDict->here;
+ *cp++ = c;
+ pDict->here = PTRtoCELL cp;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d W o r d
+** Create a new word in the dictionary with the specified
+** name, code, and flags. Name must be NULL-terminated.
+**************************************************************************/
+FICL_WORD *dictAppendWord(FICL_DICT *pDict,
+ char *name,
+ FICL_CODE pCode,
+ UNS8 flags)
+{+ STRINGINFO si;
+ SI_SETLEN(si, strlen(name));
+ SI_SETPTR(si, name);
+ return dictAppendWord2(pDict, si, pCode, flags);
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d W o r d 2
+** Create a new word in the dictionary with the specified
+** STRINGINFO, code, and flags. Does not require a NULL-terminated
+** name.
+**************************************************************************/
+FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
+ STRINGINFO si,
+ FICL_CODE pCode,
+ UNS8 flags)
+{+ FICL_COUNT len = (FICL_COUNT)SI_COUNT(si);
+ char *name = SI_PTR(si);
+ char *pName;
+ FICL_WORD *pFW;
+
+ ficlLockDictionary(TRUE);
+
+ /*
+ ** NOTE: dictCopyName advances "here" as a side-effect.
+ ** It must execute before pFW is initialized.
+ */
+ pName = dictCopyName(pDict, si);
+ pFW = (FICL_WORD *)pDict->here;
+ pDict->smudge = pFW;
+ pFW->hash = hashHashCode(si);
+ pFW->code = pCode;
+ pFW->flags = (UNS8)(flags | FW_SMUDGE);
+ pFW->nName = (char)len;
+ pFW->name = pName;
+ /*
+ ** Point "here" to first cell of new word's param area...
+ */
+ pDict->here = pFW->param;
+
+ if (!(flags & FW_SMUDGE))
+ dictUnsmudge(pDict);
+
+ ficlLockDictionary(FALSE);
+ return pFW;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d U N S 3 2
+** Append the specified UNS32 to the dictionary
+**************************************************************************/
+void dictAppendUNS32(FICL_DICT *pDict, UNS32 u)
+{+ *pDict->here++ = LVALUEtoCELL(u);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t C e l l s A v a i l
+** Returns the number of empty cells left in the dictionary
+**************************************************************************/
+int dictCellsAvail(FICL_DICT *pDict)
+{+ return pDict->size - dictCellsUsed(pDict);
+}
+
+
+/**************************************************************************
+ d i c t C e l l s U s e d
+** Returns the number of cells consumed in the dicionary
+**************************************************************************/
+int dictCellsUsed(FICL_DICT *pDict)
+{+ return pDict->here - pDict->dict;
+}
+
+
+/**************************************************************************
+ d i c t C h e c k
+** Checks the dictionary for corruption and throws appropriate
+** errors
+**************************************************************************/
+void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells)
+{+ if ((nCells >= 0) && (dictCellsAvail(pDict) < nCells))
+ {+ vmThrowErr(pVM, "Error: dictionary full");
+ }
+
+ if ((nCells <= 0) && (dictCellsUsed(pDict) < -nCells))
+ {+ vmThrowErr(pVM, "Error: dictionary underflow");
+ }
+
+ if (pDict->nLists > FICL_DEFAULT_VOCS)
+ {+ dictResetSearchOrder(pDict);
+ vmThrowErr(pVM, "Error: search order overflow");
+ }
+ else if (pDict->nLists < 1)
+ {+ dictResetSearchOrder(pDict);
+ vmThrowErr(pVM, "Error: search order underflow");
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ d i c t C o p y N a m e
+** Copy up to nFICLNAME characters of the name specified by si into
+** the dictionary starting at "here", then NULL-terminate the name,
+** point "here" to the next available byte, and return the address of
+** the beginning of the name. Used by dictAppendWord.
+** N O T E S :
+** 1. "here" is guaranteed to be aligned after this operation.
+** 2. If the string has zero length, align and return "here"
+**************************************************************************/
+static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si)
+{+ char *oldCP = (char *)pDict->here;
+ char *cp = oldCP;
+ char *name = SI_PTR(si);
+ int i = SI_COUNT(si);
+
+ if (i == 0)
+ {+ dictAlign(pDict);
+ return (char *)pDict->here;
+ }
+
+ if (i > nFICLNAME)
+ i = nFICLNAME;
+
+ for (; i > 0; --i)
+ {+ *cp++ = *name++;
+ }
+
+ *cp++ = '\0';
+
+ pDict->here = PTRtoCELL cp;
+ dictAlign(pDict);
+ return oldCP;
+}
+
+
+/**************************************************************************
+ d i c t C r e a t e
+** Create and initialize a dictionary with the specified number
+** of cells capacity, and no hashing (hash size == 1).
+**************************************************************************/
+FICL_DICT *dictCreate(unsigned nCells)
+{+ return dictCreateHashed(nCells, 1);
+}
+
+
+FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash)
+{+ FICL_DICT *pDict;
+ size_t nAlloc;
+
+ nAlloc = sizeof (FICL_DICT) + nCells * sizeof (CELL)
+ + sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *);
+
+ pDict = ficlMalloc(nAlloc);
+ assert(pDict);
+ pDict->size = nCells;
+ dictEmpty(pDict, nHash);
+ return pDict;
+}
+
+
+/**************************************************************************
+ d i c t D e l e t e
+** Free all memory allocated for the given dictionary
+**************************************************************************/
+void dictDelete(FICL_DICT *pDict)
+{+ assert(pDict);
+ ficlFree(pDict);
+ return;
+}
+
+
+/**************************************************************************
+ 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.
+**************************************************************************/
+void dictEmpty(FICL_DICT *pDict, unsigned nHash)
+{+ FICL_HASH *pHash;
+
+ pDict->here = pDict->dict;
+
+ dictAlign(pDict);
+ pHash = (FICL_HASH *)pDict->here;
+ dictAllot(pDict,
+ sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *));
+
+ pHash->size = nHash;
+ hashReset(pHash);
+
+ pDict->pForthWords = pHash;
+ pDict->smudge = NULL;
+ dictResetSearchOrder(pDict);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t H a s h S u m m a r y
+** Calculate a figure of merit for the dictionary hash table based
+** on the average search depth for all the words in the dictionary,
+** assuming uniform distribution of target keys. The figure of merit
+** is the ratio of the total search depth for all keys in the table
+** versus a theoretical optimum that would be achieved if the keys
+** were distributed into the table as evenly as possible.
+** The figure would be worse if the hash table used an open
+** addressing scheme (i.e. collisions resolved by searching the
+** table for an empty slot) for a given size table.
+**************************************************************************/
+void dictHashSummary(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_HASH *pFHash;
+ FICL_WORD **pHash;
+ unsigned size;
+ FICL_WORD *pFW;
+ unsigned i;
+ int nMax = 0;
+ int nWords = 0;
+ int nFilled;
+ double avg = 0.0;
+ double best;
+ int nAvg, nRem, nDepth;
+
+ dictCheck(dp, pVM, 0);
+
+ pFHash = dp->pSearch[dp->nLists - 1];
+ pHash = pFHash->table;
+ size = pFHash->size;
+ nFilled = size;
+
+ for (i = 0; i < size; i++)
+ {+ int n = 0;
+ pFW = pHash[i];
+
+ while (pFW)
+ {+ ++n;
+ ++nWords;
+ pFW = pFW->link;
+ }
+
+ avg += (double)(n * (n+1)) / 2.0;
+
+ if (n > nMax)
+ nMax = n;
+ if (n == 0)
+ --nFilled;
+ }
+
+ /* Calc actual avg search depth for this hash */
+ avg = avg / nWords;
+
+ /* Calc best possible performance with this size hash */
+ nAvg = nWords / size;
+ nRem = nWords % size;
+ nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
+ best = (double)nDepth/nWords;
+
+ sprintf(pVM->pad,
+ "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%",
+ size,
+ (double)nFilled * 100.0 / size, nMax,
+ avg,
+ best,
+ 100.0 * best / avg);
+
+ ficlTextOut(pVM, pVM->pad, 1);
+
+ return;
+}
+
+
+/**************************************************************************
+ d i c t I n c l u d e s
+** Returns TRUE iff the given pointer is within the address range of
+** the dictionary.
+**************************************************************************/
+int dictIncludes(FICL_DICT *pDict, void *p)
+{+ return ((p >= (void *) &pDict->dict)
+ && (p < (void *)(&pDict->dict + pDict->size))
+ );
+}
+
+
+/**************************************************************************
+ d i c t L o o k u p
+** Find the FICL_WORD that matches the given name and length.
+** If found, returns the word's address. Otherwise returns NULL.
+** Uses the search order list to search multiple wordlists.
+**************************************************************************/
+FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si)
+{+ FICL_WORD *pFW = NULL;
+ FICL_HASH *pHash;
+ int i;
+ UNS16 hashCode = hashHashCode(si);
+
+ assert(pDict);
+
+ ficlLockDictionary(1);
+
+ for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
+ {+ pHash = pDict->pSearch[i];
+ pFW = hashLookup(pHash, si, hashCode);
+ }
+
+ ficlLockDictionary(0);
+ return pFW;
+}
+
+
+/**************************************************************************
+ d i c t L o o k u p L o c
+** Same as dictLookup, but looks in system locals dictionary first...
+** Assumes locals dictionary has only one wordlist...
+**************************************************************************/
+#if FICL_WANT_LOCALS
+FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si)
+{+ FICL_WORD *pFW = NULL;
+ FICL_HASH *pHash = ficlGetLoc()->pForthWords;
+ int i;
+ UNS16 hashCode = hashHashCode(si);
+
+ assert(pHash);
+ assert(pDict);
+
+ ficlLockDictionary(1);
+ /*
+ ** check the locals dict first...
+ */
+ pFW = hashLookup(pHash, si, hashCode);
+
+ /*
+ ** If no joy, (!pFW) --------------------------v
+ ** iterate over the search list in the main dict
+ */
+ for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
+ {+ pHash = pDict->pSearch[i];
+ pFW = hashLookup(pHash, si, hashCode);
+ }
+
+ ficlLockDictionary(0);
+ return pFW;
+}
+#endif
+
+
+/**************************************************************************
+ d i c t R e s e t S e a r c h O r d e r
+** Initialize the dictionary search order list to sane state
+**************************************************************************/
+void dictResetSearchOrder(FICL_DICT *pDict)
+{+ assert(pDict);
+ pDict->pCompile = pDict->pForthWords;
+ pDict->nLists = 1;
+ pDict->pSearch[0] = pDict->pForthWords;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t S e t F l a g s
+** Changes the flags field of the most recently defined word:
+** Set all bits that are ones in the set parameter, clear all bits
+** that are ones in the clr parameter. Clear wins in case the same bit
+** is set in both parameters.
+**************************************************************************/
+void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr)
+{+ assert(pDict->smudge);
+ pDict->smudge->flags |= set;
+ pDict->smudge->flags &= ~clr;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t S e t I m m e d i a t e
+** Set the most recently defined word as IMMEDIATE
+**************************************************************************/
+void dictSetImmediate(FICL_DICT *pDict)
+{+ assert(pDict->smudge);
+ pDict->smudge->flags |= FW_IMMEDIATE;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t U n s m u d g e
+** Completes the definition of a word by linking it
+** into the main list
+**************************************************************************/
+void dictUnsmudge(FICL_DICT *pDict)
+{+ FICL_WORD *pFW = pDict->smudge;
+ FICL_HASH *pHash = pDict->pCompile;
+
+ assert(pHash);
+ assert(pFW);
+ hashInsertWord(pHash, pFW);
+ pFW->flags &= ~(FW_SMUDGE);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t W h e r e
+** Returns the value of the HERE pointer -- the address
+** of the next free cell in the dictionary
+**************************************************************************/
+CELL *dictWhere(FICL_DICT *pDict)
+{+ return pDict->here;
+}
+
+
+/**************************************************************************
+ h a s h H a s h C o d e
+**
+** Generate a 16 bit hashcode from a character string using a rolling
+** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds
+** the name before hashing it...
+** N O T E : If string has zero length, returns zero.
+**************************************************************************/
+UNS16 hashHashCode(STRINGINFO si)
+{ + /* hashPJW */
+ UNS8 *cp;
+ UNS16 code = (UNS16)si.count;
+ UNS16 shift = 0;
+
+ if (si.count == 0)
+ return 0;
+
+ for (cp = (UNS8 *)si.cp; *cp && si.count; cp++, si.count--)
+ {+ code = (UNS16)((code << 4) + tolower(*cp));
+ shift = (UNS16)(code & 0xf000);
+ if (shift)
+ {+ code ^= (UNS16)(shift >> 8);
+ code ^= (UNS16)shift;
+ }
+ }
+
+ return (UNS16)code;
+}
+
+
+/**************************************************************************
+ h a s h R e s e t
+** Initialize a FICL_HASH to empty state.
+**************************************************************************/
+void hashReset(FICL_HASH *pHash)
+{+ unsigned i;
+
+ assert(pHash);
+
+ for (i = 0; i < pHash->size; i++)
+ {+ pHash->table[i] = NULL;
+ }
+
+ pHash->link = NULL;
+ return;
+}
+
+
+/**************************************************************************
+ h a s h I n s e r t W o r d
+** Put a word into the hash table using the word's hashcode as
+** an index (modulo the table size).
+**************************************************************************/
+void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW)
+{+ FICL_WORD **pList;
+
+ assert(pHash);
+ assert(pFW);
+
+ if (pHash->size == 1)
+ {+ pList = pHash->table;
+ }
+ else
+ {+ pList = pHash->table + (pFW->hash % pHash->size);
+ }
+
+ pFW->link = *pList;
+ *pList = pFW;
+ return;
+}
+
+
+/**************************************************************************
+ h a s h L o o k u p
+** Find a name in the hash table given the hashcode and text of the name.
+** Returns the address of the corresponding FICL_WORD if found,
+** otherwise NULL.
+** Note: outer loop on link field supports inheritance in wordlists.
+** It's not part of ANS Forth - ficl only. hashReset creates wordlists
+** with NULL link fields.
+**************************************************************************/
+FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode)
+{+ FICL_COUNT nCmp = (FICL_COUNT)si.count;
+ FICL_WORD *pFW;
+ UNS16 hashIdx;
+
+ if (nCmp > nFICLNAME)
+ nCmp = nFICLNAME;
+
+ for (; pHash != NULL; pHash = pHash->link)
+ {+ if (pHash->size > 1)
+ hashIdx = (UNS16)(hashCode % pHash->size);
+ else /* avoid the modulo op for single threaded lists */
+ hashIdx = 0;
+
+ for (pFW = pHash->table[hashIdx]; pFW; pFW = pFW->link)
+ {+ if ( (pFW->nName == si.count)
+ && (!strincmp(si.cp, pFW->name, nCmp)) )
+ return pFW;
+#if FICL_ROBUST
+ assert(pFW != pFW->link);
+#endif
+ }
+ }
+
+ return NULL;
+}
+
--- /dev/null
+++ b/doc/ficl.html
@@ -1,0 +1,1947 @@
+<HTML>
+<HEAD>
+ <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+ <META NAME="Author" CONTENT="john sadler">
+ <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+ <TITLE>ficl 2.0 release notes</TITLE>
+</HEAD>
+<BODY>
+
+<CENTER>
+<H1>
+<B>ficl 2.0 release notes</B></H1></CENTER>
+
+<TABLE BORDER=0 CELLSPACING=3 WIDTH="600" >
+<TR>
+<TD><B>Forth Inspired Command Language </B></TD>
+
+<TD ROWSPAN="4"><IMG SRC="Logo.jpg" HEIGHT=64 WIDTH=64></TD>
+</TR>
+
+<TR>
+<TD><B>Author: John Sadler (john_sadler@alum.mit.edu)</B></TD>
+</TR>
+
+<TR>
+<TD><B>Created: 19 July 1997 </B></TD>
+</TR>
+
+<TR>
+<TD><B>Revision 2.0: 14 September 1998 </B></TD>
+</TR>
+</TABLE>
+
+<H2>
+Contents</H2>
+
+<UL>
+<LI>
+<A HREF="#whatis">What is ficl?</A></LI>
+
+<LI>
+<A HREF="#features">Ficl features</A></LI>
+
+<LI>
+<A HREF="#porting">Porting</A></LI>
+
+<LI>
+<A HREF="#manifest">Distribution source files</A></LI>
+
+<LI>
+<A HREF="#whatsnew">What's new in Ficl 2.0</A></LI>
+
+<LI>
+<A HREF="#objects">Objects in ficl</A></LI>
+
+<UL>
+<LI>
+<A HREF="#glossinstance">Instance variable glossary</A></LI>
+
+<LI>
+<A HREF="#glossclass">Class methods glossary</A></LI>
+
+<LI>
+<A HREF="#objectgloss">Object base-class methods glossary</A></LI>
+
+<LI>
+<A HREF="#stockclasses">Supplied Classes</A></LI>
+</UL>
+
+<LI>
+<A HREF="#extras">Ficl extras</A></LI>
+
+<LI>
+<A HREF="#ansinfo">ANS required information</A></LI>
+
+<LI>
+<A HREF="#links">Forth references</A></LI>
+
+<LI>
+<A HREF="#lawyerbait">Disclaimer & License</A></LI>
+</UL>
+
+<H2>
+
+<HR WIDTH="100%"><A NAME="whatis"></A>What is ficl?</H2>
+
+<TABLE CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>Ficl (Forth-inspired command language) is an ANS Forth interpreter
+written in C. Unlike traditional Forths, this interpreter is designed to
+be embedded into other systems as a command/macro/development prototype
+language.</TD>
+</TR>
+
+<TR>
+<TD>Where Forths usually view themselves as the center of the system and
+expect the rest of the system to be coded in Forth, Ficl acts as a component
+of the system. It is easy to export code written in C or ASM to Ficl in
+the style of TCL, or to invoke Ficl code from a compiled module. This allows
+you to do incremental development in a way that combines the best features
+of threaded languages (rapid development, quick code/test/debug cycle,
+reasonably fast) with the best features of C (everyone knows it, easier
+to support large blocks of code, efficient, type checking). In addition,
+Ficl provides a simple object model that can act as an object oriented
+adapter for code written in C (or asm, Forth, C++...).
+<BR> </TD>
+</TR>
+
+<TR>
+<TD><B>Ficl Design goals</B>
+<UL>
+<LI>
+Target 32 bit processors </LI>
+
+<LI>
+Scripting, prototyping, and extension language for systems written also
+in C</LI>
+
+<LI>
+Supportable - code is as transparent as I can make it</LI>
+
+<LI>
+Interface to functions written in C</LI>
+
+<LI>
+Conform to the Forth DPANS 94</LI>
+
+<LI>
+Minimize porting effort - require an ANSI C runtime environment and minimal
+glue code</LI>
+
+<LI>
+Provide object oriented extensions</LI>
+</UL>
+</TD>
+</TR>
+</TABLE>
+
+<H3>
+<A NAME="features"></A>Ficl features</H3>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>
+<UL>
+<LI>
+Code is written in ANSI C for portability.</LI>
+
+<LI>
+Standard: Implements the ANS Forth CORE word set, part of the CORE EXT
+word-set, SEARCH and SEARCH EXT, TOOLS and part of TOOLS EXT, LOCAL and
+LOCAL EXT and various extras.</LI>
+
+<LI>
+Extensible: you can export code written in Forth, C, or asm in a straightforward
+way. Ficl provides open facilities for extending the language in an application
+specific way. You can even add new control structures (not surprising if
+you're familiar with Forth)</LI>
+
+<LI>
+Ficl and C can interact in two ways: Ficl can wrap C code, and C functions
+can invoke ficl code.</LI>
+
+<LI>
+Ficl is thread safe and re-entrant: Each Ficl virtual machine has
+an otherwise complete state, and each can be bound to a separate I/O channel
+(or none at all). All Ficl VMs share one system dictionary. An optional
+function called ficlLockDictionary() can control exclusive dictionary access.
+This function is stubbed out by default (See FICL_MULTITHREAD in sysdep.h).
+As long as there is only one "session" that can compile words into the
+dictionary, you do not need exclusive dictionary access for multithreading.</LI>
+
+<LI>
+Simple incorporation into existing systems: the sample implementation requires
+three Ficl function calls (see the example program in testmain.c).</LI>
+
+<LI>
+ROMable: Ficl is designed to work in RAM-based and ROM code / RAM data
+environments. It does require somewhat more memory than a pure ROM implementation
+because it builds its system dictionary in RAM at startup time.</LI>
+
+<LI>
+Written an ANSI C to be as simple as I can make it to understand, support,
+debug, and port. Compiles without complaint at /Az /W4 (require ANSI C,
+max warnings) under Microsoft VC++ 5.</LI>
+
+<LI>
+Does full 32 bit math (but you need to implement two mixed precision math
+primitives (see sysdep.c))</LI>
+
+<LI>
+Type 1 indirect threaded interpreter</LI>
+</UL>
+</TD>
+</TR>
+</TABLE>
+
+<H3>
+
+<HR WIDTH="100%"><A NAME="porting"></A>Porting ficl</H3>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>To install ficl on your target system, you need an ANSI C compiler
+and its runtime library. Inspect the system dependent macros and functions
+in <TT>sysdep.h</TT> and <TT>sysdep.c</TT> and edit them to suit your system.
+For example, <TT>INT16</TT> is a <TT>short</TT> on some compilers and an
+<TT>int</TT> on others. Check the default <TT>CELL</TT> alignment controlled
+by <TT>FICL_ALIGN</TT>. If necessary, add new definitions of <TT>ficlMalloc,
+ficlFree, ficlLockDictionary</TT>, and <TT>ficlTextOut</TT> to work with
+your operating system. Finally, use <TT>testmain.c</TT> as a guide to installing
+the ficl system and one or more virtual machines into your code. You do
+not need to include <TT>testmain.c</TT> in your build.
+
+<P>Feel free to stub out the double precision math functions (which are
+presently implemented as inline assembly because it's so easy on many 32
+bit processors) with kludge code that only goes to 32 bit precision. In
+most applications, you won't notice the difference. If you're doing a lot
+of number crunching, consider implementing them correctly.
+<H3>
+Build controls</H3>
+The file sysdep.h contains default values for build controls. Most of these
+are written such that if you define them on the compiler command line,
+the defaults are overridden. I suggest you take the defaults on everything
+below the "build controls" section until you're confident of your port.
+Beware of declaring too small a dictionary, for example. You need about
+3200 cells for a full system, about 2000 if you strip out most of the "soft"
+words.
+<H3>
+To-Do List (target system dependent words)</H3>
+
+<UL>
+<LI>
+Unimplemented system dependent <TT>CORE</TT> word: <TT>KEY</TT> </LI>
+
+<LI>
+Kludged <TT>CORE</TT> word: <TT>ACCEPT</TT></LI>
+</UL>
+</TD>
+</TR>
+</TABLE>
+
+<H3>
+ <A NAME="manifest"></A>Ficl Source Files</H3>
+
+<TABLE BORDER=0 CELLSPACING=5 WIDTH="600" >
+<TR>
+<TD><B>ficl.h</B></TD>
+
+<TD>Declares most public functions and all data structures. Includes sysdep.h
+and math.h</TD>
+</TR>
+
+<TR>
+<TD><B>sysdep.h</B></TD>
+
+<TD>Declares system dependent functions and contains build control macros.
+Edit this file to port to another system.</TD>
+</TR>
+
+<TR>
+<TD><B>math.h</B></TD>
+
+<TD>Declares functions for 64 bit math</TD>
+</TR>
+
+<TR>
+<TD><B>words.c</B></TD>
+
+<TD>Exports ficlCompileCore(), the run-time dictionary builder, and contains
+all primitive words as static functions.</TD>
+</TR>
+
+<TR>
+<TD><B>vm.c</B></TD>
+
+<TD>Virtual Machine methods</TD>
+</TR>
+
+<TR>
+<TD><B>stack.c</B></TD>
+
+<TD>Stack methods</TD>
+</TR>
+
+<TR>
+<TD><B>ficl.c</B></TD>
+
+<TD>System initialization, termination, and ficlExec</TD>
+</TR>
+
+<TR>
+<TD><B>dict.c</B></TD>
+
+<TD>Dictionary</TD>
+</TR>
+
+<TR>
+<TD><B>math64.c</B></TD>
+
+<TD>Implementation of 64 bit math words (except the two unsigned primitives
+declared in sysdep.h and implemented in sysdep.c)</TD>
+</TR>
+
+<TR>
+<TD><B>softcore.c</B></TD>
+
+<TD>Contains all of the "soft" words - those written in Forth and compiled
+by Ficl at startup time. Sources for these words are in the softwords directory.
+The files softcore.bat and softcore.pl generate softcore.c from the .fr
+sources.</TD>
+</TR>
+
+<TR>
+<TD><B>sysdep.c</B></TD>
+
+<TD>Implementation of system dependent functions declared in sysdep.h</TD>
+</TR>
+
+<TR>
+<TD><B>softwords/</B></TD>
+
+<TD>Directory contains sources and translation scripts for the words defined
+in softcore.c. Softcore.c depends on most of the files in this directory.
+See softcore.bat for the actual list of files that contribute to softcore.c.</TD>
+</TR>
+</TABLE>
+
+<H2>
+
+<HR WIDTH="100%"><A NAME="whatsnew"></A>What's new in version 2.0</H2>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>
+<UL>
+<LI>
+New ANS Forth words: <TT>TOOLS</TT> and part of <TT>TOOLS EXT, SEARCH</TT>
+and <TT>SEARCH EXT, LOCALS</TT> and <TT>LOCALS EXT</TT> word sets, additional
+words from <TT>CORE EXT, DOUBLE</TT>, and <TT>STRING</TT>. (See the function
+ficlCompileCore in words.c for an alphabetical list by word-set).</LI>
+
+<LI>
+Simple <TT>USER</TT> variable support - a user variable is a virtual machine
+instance variable. User variables behave as <TT>VARIABLE</TT>s in all other
+respects.</LI>
+
+<LI>
+Object oriented syntax extensions (see below)</LI>
+
+<LI>
+Optional stack underflow and overflow checking in many CORE words (enabled
+when FICL_ROBUST is set to 2)</LI>
+
+<LI>
+Various bug fixes</LI>
+</UL>
+
+<H3>
+Local Variables</H3>
+Ficl now includes support for <TT>LOCALS</TT> and <TT>LOCALS EXT</TT> words
+(all three of them!). I've implemented both of the local variable syntaxes
+suggested in DPANS Appendix A.13. Examples: (By the way, Ficl implements
+<TT>-ROT</TT> as <TT>: -rot 2 -roll ;</TT> )
+<UL><B><TT>\ Using LOCALS| from LOCALS EXT</TT></B>
+<BR><B><TT>: -rot ( a b c -- c a b )</TT></B>
+<BR><B><TT> locals| c b a |</TT></B>
+<BR><B><TT> c a b </TT></B>
+<BR><B><TT>;</TT></B>
+<BR><B><TT>\ Using LOCAL END-LOCAL</TT></B>
+<BR><B><TT>: -rot ( a b c -- c a b )</TT></B>
+<BR><B><TT> local c</TT></B>
+<BR><B><TT> local b</TT></B>
+<BR><B><TT> local a</TT></B>
+<BR><B><TT> end-locals</TT></B>
+<BR><B><TT> c a b</TT></B>
+<BR><B><TT>;</TT></B> </UL>
+Local variable support is optional because it adds a small amount of overhead
+to the outer interpreter. You can disable it by setting FICL_WANT_LOCALS
+to 0 in sysdep.h. Beware: much of the OOP code described below uses local
+variables, so if you disable locals, you're going to lose other capabilities
+too. Local variables can make Forth code quite a bit easier to read, so
+I'd encourage you to experiment with them.
+<BR>The default maximum number of local variables is 16. It's controlled
+by FICL_MAX_LOCALS in sysdep.h.
+<H3>
+Search Order</H3>
+Ficl implements many of the search order words in terms of two primitives
+called <TT>>SEARCH</TT> and <TT>SEARCH></TT>. As their names suggest (assuming
+you're familiar with Forth), they push and pop the search order stack.
+See the list of <A HREF="#extras">Ficl extras</A> for details.
+<BR>The standard does not appear to specify any conditions under which
+the search order is reset to a sane state. Ficl resets the search order
+to its default state whenever <TT>ABORT</TT> happens. This includes stack
+underflows and overflows. <TT>QUIT</TT> does not affect the search order.
+The minimum search order (set by <TT>ONLY</TT>) is equivalent to
+<BR><B><TT>FORTH-WORDLIST 1 SET-ORDER</TT></B>
+<BR>There is a default maximum of 16 wordlists in the search order. This
+can be changed by redefining FICL_DEFAULT_VOCS (declared in sysdep.h).
+<H3>
+Soft Words</H3>
+Many words from all the supported wordsets are written in Forth, and stored
+as a big string that Ficl compiles when it starts. The sources for all
+of these words are in directory ficl/softwords. There is a .bat file (softcore.bat)
+and a PERL 5 script (softcore.pl) that convert Forth files into the file
+softcore.c, so softcore.c is really dependent on the Forth sources. This
+is not reflected in the Visual C++ project database. For the time being,
+it's a manual step. You can edit softcore.bat to change the list of files
+that contribute to softcore.c. </TD>
+</TR>
+</TABLE>
+
+<H2>
+
+<HR WIDTH="100%"></H2>
+
+<H2>
+<A NAME="objects"></A>Objects in ficl</H2>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>Ficl is not the first Forth to include Object Oriented extensions.
+Ficl's OO syntax owes a debt to the work of John Hayes and Dick Pountain,
+among others. OO Ficl is different from other OO Forths in a few ways,
+though (some things never change). First, unlike several implementations,
+the syntax is documented (<A HREF="#ootutorial">below</A>) beyond the source
+code. In Ficl's spirit of working with C code, the OO syntax provides means
+to adapt existing data structures. I've tried to make Ficl's OO model simple
+and safe by unifying classes and objects, providing late binding by default,
+and separating namespaces so that methods and regular Forth words are not
+easily confused.
+<H3>
+Design goals of Ficl OO syntax</H3>
+Ficl's object extensions provide the traditional OO benefits of associating
+data with the code that manipulates it, and reuse through single inheritance.
+Ficl also has some unusual capabilities that support interoperation with
+systems written in C.
+<UL>
+<LI>
+Ficl objects are normally late bound for safety (late binding guarantees
+that the appropriate method will always be invoked for a particular object).
+Early binding is also available, provided you know the object's class at
+compile-time.</LI>
+
+<LI>
+Ficl OOP supports single inheritance, aggregation, and arrays of objects.</LI>
+
+<LI>
+Classes have independent name spaces for their methods: methods are only
+visible in the context of a class or object. Methods can be overridden
+or added in subclasses; there is no fixed limit on the number of methods
+of a class or subclass.</LI>
+
+<LI>
+Ficl OOP syntax is regular and unified over classes and objects. This means
+that classes are a kind of object. Class methods include the ability to
+subclass and instantiate.</LI>
+
+<LI>
+Ficl can adapt legacy data structures with object wrappers. You can model
+a structure in a Ficl class, and create an instance that refers to an address
+in memory that holds the structure. The ref object can them manipulate
+the structure directly. This lets you wrap data structures written and
+instantiated in C.</LI>
+</UL>
+</TD>
+</TR>
+</TABLE>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>
+<H3>
+Ficl Object Model</H3>
+All classes in Ficl are derived from the common base class <TT>OBJECT</TT>.
+All classes are instances of <TT>METACLASS</TT>. This means that classes
+are objects, too. <TT>METACLASS</TT> implements the methods for messages
+sent to classes. Class methods create instances and subclasses, and give
+information about the class. Classes have exactly three elements:
+<UL>
+<LI>
+The address ( <TT>.CLASS</TT> ) of a parent class, or zero if it's a base
+class (only <TT>OBJECT</TT> and <TT>METACLASS</TT> have this property)</LI>
+
+<LI>
+The size ( <TT>.SIZE</TT> ) in address units of an instance of the class</LI>
+
+<LI>
+A wordlist ID ( <TT>.WID</TT> ) for the methods of the class</LI>
+</UL>
+In the figure below, <TT>METACLASS</TT> and <TT>OBJECT</TT> are system-supplied
+classes. The others are contrived to illustrate the relationships among
+derived classes, instances, and the two system base classes. The dashed
+line with an arrow at the end indicates that the object/class at the arrow
+end is an instance of the class at the other end. The vertical line with
+a triangle denotes inheritance.
+
+<P>Note for the curious: <TT>METACLASS</TT> behaves like a class - it responds
+to class messages and has the same properties as any other class. If you
+want to twist your brain in knots, you can think of <TT>METACLASS</TT>
+as an instance of itself.
+<BR> </TD>
+</TR>
+</TABLE>
+<IMG SRC="ficl_oop.jpg" VSPACE=10 HEIGHT=442 WIDTH=652>
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>
+<H2>
+<A NAME="ootutorial"></A>Ficl OO Syntax Tutorial</H2>
+
+<H3>
+Introduction</H3>
+Ficl objects associate a class with an instance (really the storage for
+one set of instance variables). This is done explicitly, in that any Ficl
+object is represented by the cell pair:
+<UL><B><TT>( instance-addr class-addr )</TT></B> </UL>
+on the stack. Whenever a named Ficl object executes, it leaves this "signature".
+All methods expect a class and instance on the stack when they execute,
+too. In many other OO languages, including C++, instances contain information
+about their classes (a vtable pointer, for example). By making this pairing
+explicit rather than implicit, Ficl can be OO about chunks of data that
+don't realize that they are objects, without sacrificing any robustness
+for native objects. Whenever you create an object in Ficl, you specify
+its class. After that, the object always pushes its class and the address
+of its payload when invoked by name.
+
+<P>Classes are special kinds of objects that store the methods of their
+instances, the size of an instance's payload, and a parent class pointer.
+Classes themselves are instances of a special base class called <TT>METACLASS</TT>,
+and all classes inherit from class <TT>OBJECT</TT>. This is confusing at
+first, but it means that Ficl has a very simple syntax for constructing
+and using objects. Class methods include subclassing (<TT>SUB</TT>), creating
+initialized and uninitialized instances (<TT>NEW</TT> and <TT>INSTANCE</TT>),
+and creating reference instances (<TT>REF</TT>). Classes also have methods
+for disassembling their methods (<TT>SEE</TT>), identifying themselves
+(<TT>ID</TT>), and listing their pedigree (<TT>PEDIGREE</TT>). All objects
+inherit methods for initializing instances and arrays of instances, for
+performing array operations, and for getting information about themselves.
+<H3>
+Methods and messages</H3>
+Methods are the chunks of code that objects execute in response to messages.
+A message is a request to an object for a behavior that the object supports.
+When it receives a message, the target object looks up a method that performs
+the behavior for its class, and executes it. Any specific message will
+be bound to different methods in different objects, according to class.
+This separation of messages and methods allows objects to behave polymorphically.
+(In Ficl, methods are words defined in the context of a class, and messages
+are the names of those words.) Ficl classes associate names with methods
+for their instances. Ficl provides a late-binding operator <TT>--></TT>
+that sends messages to objects at run-time, and an early-binding operator
+<TT>=></TT> that compiles a specific class's method. These operators are
+the only supported way to invoke methods. Regular Forth words are not visible
+to the method-binding operators, so there's no chance of confusing
+a message with a regular word of the same name.
+<H3>
+Tutorial (finally!)</H3>
+Since this is a tutorial, I'm assuming you're following along by typing
+the examples into ficlWin, the Win32 version of Ficl (or some other build
+that includes the OO part of softcore.c). I also assume that you're familiar
+with Forth. If not, please see one of the <A HREF="#links">references</A>,
+below. Ficl's OOP words are in vocabulary OOP, which is in the search order
+and is the compile wordlist when you start one of the executables from
+the release. To get to this state from the default search order (as set
+by <TT>ONLY</TT>), type:
+<UL><B><TT>ALSO OOP DEFINITIONS</TT></B> </UL>
+To start, we'll work with the two base classes <TT>OBJECT</TT> and <TT>METACLASS</TT>.
+Try this:
+<UL><B><TT>metaclass --> methods</TT> </B> </UL>
+The line above contains three words. The first is the name of a class,
+so it pushes its signature on the stack. Since all classes are instances
+of <TT>METACLASS</TT>, <TT>METACLASS</TT> behaves as if it is an instance
+of itself (this is the only class with this property). It pushes the same
+address twice: once for the class and once for the instance variables,
+since they are the same. The next word finds a method in the context of
+a class and executes it. In this case, the name of the method is <TT>methods</TT>.
+Its job is to list all the methods that a class knows. What you get when
+you execute this line is a list of all the class methods Ficl provides.
+<UL><B><TT>object --> sub c-foo</TT></B> </UL>
+Causes base-class <TT>OBJECT</TT> to derive from itself a new class called
+c-foo. Now we'll add some instance variables and methods to the new class...
+<UL><B><TT>cell: m_cell1</TT></B>
+<BR><B><TT>4 chars: m_chars</TT></B>
+<BR><B><TT>: init ( inst class -- )</TT></B>
+<BR><B><TT> locals| class inst |</TT></B>
+<BR><B><TT> 0 inst class --> m_cell1 !</TT></B>
+<BR><B><TT> inst class --> m_chars 4 0 fill</TT></B>
+<BR><B><TT> ." initializing an instance of c_foo at "
+inst x. cr</TT></B>
+<BR><B><TT>;</TT></B>
+<BR><B><TT>end-class</TT></B> </UL>
+The first two lines add named instance variables to the class, and creates
+a method for each. <I>Untyped</I> instance variable methods (like those
+created by <TT>cell: cells: char:</TT> and <TT>chars:</TT>) just push the
+address of the corresponding instance variable when invoked on an instance
+of the class. It's up to you to remember the size of the instance variable
+and manipulate it with the usual Forth words for fetching and storing.
+We've also defined a method called <TT>init</TT> that clears the instance
+variables. Notice that the method expects the addresses of the class and
+instance when it's called. It stashes those in local variables to avoid
+stack tricks, and puts them onto the stack whenever it calls a method.
+In this case, we're storing zero to the two member variables.
+
+<P>The <TT>init</TT> method is special for Ficl objects: whenever you create
+an initialized instance using <B><TT>new</TT></B> or <B><TT>new-array</TT></B>,
+Ficl calls the class's <TT>init</TT> method for you on that instance. The
+default <TT>init</TT> method supplied by class <TT>object</TT> clears the
+instance, so we didn't really need to override it in this case (see the
+source code in ficl/softwords/oo.fr).
+<BR>Now make an instance of the new class:
+<UL><B><TT>c-foo --> new foo-instance</TT></B> </UL>
+And try a few things...
+<UL><B><TT>foo-instance --> methods</TT></B>
+<BR><B><TT>foo-instance --> pedigree</TT></B> </UL>
+Or you could type this with the same effect:
+<UL><B><TT>foo-instance 2dup --> methods --> pedigree</TT></B> </UL>
+Notice that we've overridden the init method supplied by object, and added
+two more methods for the member variables. If you type WORDS, you'll see
+that these methods are not visible outside the context of the class that
+contains them. The method finder --> uses the class to look up methods.
+You can use this word in a definition, as we did in init, and it performs
+late binding, meaning that the mapping from message (method name) to method
+(the code) is deferred until run-time. To see this, you can decompile the
+init method like this:
+<UL><B><TT>c-foo --> see init</TT></B>
+<BR>or
+<BR><B><TT>foo-instance --> class --> see init</TT></B> </UL>
+Ficl also provides early binding, but you have to ask for it. Ficl's early
+binding operator pops a class off the stack and compiles the method you've
+named, so that that method executes regardless of the class of object it's
+used on. This can be dangerous, since it defeats the data-to-code matching
+mechanism object oriented languages were created to provide, but it does
+increase run-time speed by binding the method at compile time. In many
+cases, such as the init method, you can be reasonably certain of the class
+of thing you're working on. This is also true when invoking class methods,
+since all classes are instances of metaclass. Here's an example from oo.fr:
+<UL><B><TT>: new \ ( class metaclass "name" -- )</TT></B>
+<BR><B><TT> metaclass => instance --> init ;</TT></B>
+<BR><B><TT>metaclass --> see new</TT></B> </UL>
+Decompiling the method with <TT>SEE</TT> shows the difference between the
+two strategies. The early bound method is compiled inline, while the late-binding
+operator compiles the method name and code to find and execute it in the
+context of whatever class is supplied on the stack at run-time.
+<BR>Notice that the early-binding operator requires a class at compile
+time. For this reason, classes are <TT>IMMEDIATE</TT>, meaning that they
+push their signature at compile time or run time. I'd recommend that you
+avoid early binding until you're very comfortable with Forth, object-oriented
+programming, and Ficl's OOP syntax.
+
+<P>As advertised earlier, Ficl provides ways to objectify existing data
+structures without changing them. Instead, you can create a Ficl class
+that models the structure, and instantiate a <B>ref </B>from this class,
+supplying the address of the structure. After that, the ref instance behaves
+as a Ficl object, but its instance variables take on the values in the
+existing structure. Example (from ficlclass.fr):
+<BR>
+<UL><B><TT>object subclass c-wordlist \ OO model of FICL_HASH</TT></B>
+<BR><B><TT> cell: .parent</TT></B>
+<BR><B><TT> cell: .size</TT></B>
+<BR><B><TT> cell: .hash</TT></B>
+
+<P><B><TT> : push drop >search ;</TT></B>
+<BR><B><TT> : pop 2drop previous ;</TT></B>
+<BR><B><TT> : set-current drop set-current ;</TT></B>
+<BR><B><TT> : words --> push words previous ;</TT></B>
+<BR><B><TT>end-class</TT></B>
+
+<P><B><TT>: named-wid ( "name" -- ) </TT></B>
+<BR><B><TT> wordlist postpone c-wordlist
+metaclass => ref ;</TT></B> </UL>
+In this case, <TT>c-wordlist</TT> describes Ficl's wordlist structure;
+named-wid creates a wordlist and binds it to a ref instance of <TT>c-wordlist</TT>.
+The fancy footwork with <TT>POSTPONE</TT> and early binding is required
+because classes are immediate. An equivalent way to define named-wid with
+late binding is:
+<UL><B><TT>: named-wid ( "name" -- )</TT></B>
+<BR><B><TT> wordlist postpone c-wordlist
+--> ref ;</TT></B> </UL>
+To do the same thing at run-time (and call it my-wordlist):
+<UL><B><TT>wordlist c-wordlist --> ref my-wordlist</TT></B> </UL>
+Now you can deal with the wordlist through the ref instance:
+<UL><B><TT>my-wordlist --> push</TT></B>
+<BR><B><TT>my-wordlist --> set-current</TT></B>
+<BR><B><TT>order</TT></B> </UL>
+Ficl can also model linked lists and other structures that contain pointers
+to structures of the same or different types. The class constructor word
+<B><TT><A HREF="#exampleref:">ref:</A></TT></B> makes an aggregate reference
+to a particular class. See the <A HREF="#glossinstance">instance variable
+glossary</A> for an <A HREF="#exampleref:">example</A>.
+
+<P>Ficl can make arrays of instances, and aggregate arrays into class descripions.
+The <A HREF="#glossclass">class methods</A> <B><TT>array</TT></B> and <B><TT>new-array</TT></B>
+create uninitialized and initialized arrays, respectively, of a class.
+In order to initialize an array, the class must define a reasonable <B><TT>init</TT></B>
+method. <B><TT>New-array</TT></B> invokes it on each member of the array
+in sequence from lowest to highest. Array instances and array members use
+the object methods <B><TT>index</TT></B>, <B><TT>next</TT></B>, and <B><TT>prev</TT></B>
+to navigate. Aggregate a member array of objects using <B><TT><A HREF="#arraycolon">array:</A></TT></B>.
+The objects are not automatically initialized in this case - your class
+initializer has to call <B><TT>array-init</TT></B> explicitly if you want
+this behavior.
+
+<P>For further examples of OOP in Ficl, please see the source file ficl/softwords/ficlclass.fr.
+This file wraps several Ficl internal data structures in objects and gives
+use examples.
+<H3>
+<A NAME="glossinstance"></A>Instance Variable Glossary</H3>
+Note: these words are only visible when creating a subclass! To create
+a subclass, use the <TT>sub</TT> method on <TT>object</TT> or any class
+derived from it (<I>not</I> <TT>metaclass</TT>). Source code for Ficl OOP
+is in ficl/softwords/oo.fr.
+<DT>
+Instance variable words do two things: they create methods that do an action
+appropriate for the type of instance variable they represent, and they
+reserve space in the class template for the instance variable. We'll use
+the term <I>instance variable</I> to refer both to the method that gives
+access to a particular field of an object, and to the field itself. Rather
+than give esentially the same example over and over, here's one example
+that shows several of the instance variable construction words in use:</DT>
+
+<UL>
+<DT>
+<TT>object subclass c-example</TT></DT>
+
+<DT>
+<TT> cell:
+.cell0</TT></DT>
+
+<BR><TT> c-4byte obj: .nCells</TT>
+<BR><TT> 4 c-4byte array: .quad</TT>
+<BR><TT> char:
+.length</TT>
+<BR><TT> 79 chars:
+.name</TT>
+<BR><TT>end-class</TT></UL>
+This class only defines instance variables, and it inherits some methods
+from <TT>object</TT>. Each untyped instance variable (.cell0, .length,
+.name) pushes its address when executed. Each object instance variable
+pushes the address and class of the aggregate object. Similar to C, an
+array instance variable leaves its base address (and its class) when executed.
+<BR>
+<DT>
+<B><TT>cell: ( offset "name"
+-- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- cell-addr )</TT></B></DT>
+
+<DL>
+<DD>
+Create an untyped instance variable one cell wide. The instance variable
+leaves its payload's address when executed. </DD>
+
+<DT>
+<B><TT>cells: ( offset nCells "name"
+-- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- cell-addr )</TT></B></DT>
+
+<DD>
+Create an untyped instance variable n cells wide.</DD>
+
+<DT>
+<B><TT>char: ( offset "name"
+-- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- char-addr )</TT></B></DT>
+
+<DD>
+Create an untyped member variable one char wide</DD>
+
+<DT>
+<B><TT>chars: ( offset nChars "name"
+-- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- char-addr )</TT></B></DT>
+
+<DD>
+Create an untyped member variable n chars wide.</DD>
+
+<DT>
+<B><TT>obj: ( offset class
+meta "name" -- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- instance class )</TT></B></DT>
+
+<DT>
+Aggregate an uninitialized instance of class as a member variable of the
+class under construction.<A NAME="arraycolon"></A><B><TT>array:
+( offset n class meta "name" -- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- instance class )</TT></B></DT>
+
+<DD>
+Aggregate an uninitialized array of instances of the class specified as
+a member variable of the class under construction.</DD>
+
+<DT>
+<A NAME="exampleref:"></A><B><TT>ref:
+( offset class meta "name" -- offset' )</TT></B></DT>
+
+<DT>
+<B><TT>
+Execution: ( -- ref-instance ref-class )</TT></B></DT>
+
+<DD>
+Aggregate a reference to a class instance. There is no way to set the value
+of an aggregated ref - it's meant as a way to manipulate existing data
+structures with a Ficl OO model. For example, if your system contains a
+linked list of 4 byte quantities, you can make a class that represents
+a list element like this: </DD>
+
+<DL>
+<DD>
+<TT>object subclass c-4list</TT></DD>
+
+<DD>
+<TT>c-4list ref: .link</TT></DD>
+
+<DD>
+<TT>c-4byte obj: .payload</TT></DD>
+
+<DD>
+<TT>end-class;</TT></DD>
+
+<DD>
+<TT>address-of-existing-list c-4list --> ref mylist</TT></DD>
+</DL>
+
+<DD>
+The last line binds the existing structure to an instance of the class
+we just created. The link method pushes the link value and the class c_4list,
+so that the link looks like an object to Ficl and like a struct to C (it
+doesn;t carry any extra baggage for the object model - the Ficl methods
+alone take care of storing the class information). </DD>
+
+<DD>
+Note: Since a ref: aggregate can only support one class, it's good for
+modeling static structures, but not appropriate for polymorphism. If you
+want polymorphism, aggregate a c_ref (see classes.fr for source) into your
+class - it has methods to set and get an object.</DD>
+
+<DD>
+By the way, it is also possible to construct a pair of classes that contain
+aggregate pointers to each other. Here's a rough example:</DD>
+
+<DL>
+<DD>
+<TT>object subclass c-fee</TT></DD>
+
+<DD>
+<TT>object subclass c-fie</TT></DD>
+
+<DD>
+<TT> c-fee ref: .fee</TT></DD>
+
+<DD>
+<TT>end-class
+\ done with c-fie</TT></DD>
+
+<DD>
+<TT> c-fie ref: .fie</TT></DD>
+
+<DD>
+<TT>end-class
+\ done with c-fee</TT></DD>
+</DL>
+</DL>
+
+<H3>
+<A NAME="glossclass"></A>Class Methods Glossary</H3>
+
+<DL>
+<DT>
+<B><TT>instance ( class metaclass "name" -- instance
+class )</TT></B> </DT>
+
+<DD>
+Create an uninitialized instance of the class, giving it the name specified.
+The method leaves the instance 's signature on the stack (handy if you
+want to initialize). Example:</DD>
+
+<DD>
+<TT>c_ref --> instance uninit-ref 2drop</TT></DD>
+
+<DT>
+<B><TT>new ( class
+metaclass "name" -- )</TT></B> </DT>
+
+<DD>
+Create an initialized instance of class, giving it the name specified.
+This method calls init to perform initialization. </DD>
+
+<DT>
+<B><TT>array ( nObj class metaclass
+"name" -- nObjs instance class )</TT></B> </DT>
+
+<DD>
+Create an array of nObj instances of the specified class. Instances are
+not initialized. Example:</DD>
+
+<DD>
+<TT>10 c_4byte --> array 40-raw-bytes 2drop drop</TT></DD>
+
+<DT>
+<B><TT>new-array ( nObj class metaclass "name" -- )</TT></B> </DT>
+
+<DD>
+Creates an initialized array of nObj instances of the class. Same syntax
+as <TT>array</TT></DD>
+
+<DT>
+<B><TT>ref ( instance-addr
+class metaclass "name" -- )</TT></B> </DT>
+
+<DD>
+Make a ref instance of the class that points to the supplied instance address.
+No new instance space is allotted. Instead, the instance refers to the
+address supplied on the stack forever afterward. For wrapping existing
+structures.</DD>
+</DL>
+
+<DL>
+<DT>
+<B><TT>sub ( class
+metaclass -- old-wid addr[size] size )</TT></B></DT>
+
+<DD>
+Derive a subclass. You can add or override methods, and add instance variables.
+Alias: <TT>subclass</TT>. Examples:</DD>
+
+<DL>
+<DD>
+<TT>c_4byte --> sub c_special4byte</TT></DD>
+
+<DD>
+<TT>( your new methods and instance variables here )</TT></DD>
+
+<DD>
+<TT>end-class</TT></DD>
+
+<DD>
+or</DD>
+
+<DD>
+<TT>c_4byte subclass c_special4byte</TT></DD>
+
+<DD>
+<TT>( your new methods and instance variables here )</TT></DD>
+
+<DD>
+<TT>end-class</TT></DD>
+</DL>
+
+<DT>
+<B><TT>.size ( class metaclass
+-- instance-size )</TT></B> </DT>
+
+<DD>
+Returns address of the class's instance size field, in address units. This
+is a metaclass member variable.</DD>
+
+<DT>
+<B><TT>.super ( class metaclass --
+superclass )</TT></B> </DT>
+
+<DD>
+Returns address of the class's superclass field. This is a metaclass member
+variable.</DD>
+
+<DT>
+<B><TT>.wid ( class metaclass
+-- wid )</TT></B> </DT>
+
+<DD>
+Returns the address of the class's wordlist ID field. This is a metaclass
+member variable.</DD>
+
+<DT>
+<B><TT>get-size</TT></B></DT>
+
+<DD>
+Returns the size of an instance of the class in address units. Imeplemented
+as</DD>
+
+<DD>
+<TT>: get-size metaclass => .size @ ;</TT></DD>
+
+<DT>
+<B><TT>get-wid</TT></B></DT>
+
+<DD>
+<TT>Returns the wordlist ID of the class. Implemented as </TT></DD>
+
+<DD>
+<TT>: get-wid metaclass => .wid @ ;</TT></DD>
+
+<DT>
+<B><TT>get-super</TT></B></DT>
+
+<DD>
+<TT>Returns the class's superclass. Implemented as</TT></DD>
+
+<DD>
+<TT>: get-super metaclass => .super @ ;</TT></DD>
+
+<DT>
+<B><TT>id (
+class metaclass -- c-addr u )</TT></B> </DT>
+
+<DD>
+Returns the address and length of a string that names the class.</DD>
+
+<DT>
+<B><TT>methods ( class metaclass -- )</TT></B> </DT>
+
+<DD>
+Lists methods of the class and all its superclasses</DD>
+
+<DT>
+<B><TT>offset-of ( class metaclass "name" -- offset )</TT></B></DT>
+
+<DD>
+Pushes the offset from the instance base address of the named member variable.
+If the name is not that of an instance variable method, you get garbage.
+There is presently no way to detect this error. Example:</DD>
+
+<DL>
+<DD>
+<TT>metaclass --> offset-of .wid</TT></DD>
+</DL>
+
+<DT>
+<B><TT>pedigree ( class metaclass -- )</TT></B> </DT>
+
+<DD>
+Lists the pedigree of the class (inheritance trail)</DD>
+
+<DT>
+<B><TT>see ( class
+metaclass "name" -- )</TT></B> </DT>
+
+<DD>
+Decompiles the specified method - obect version of <TT>SEE</TT>, from the
+<TT>TOOLS</TT> wordset.</DD>
+</DL>
+
+<H3>
+<A NAME="objectgloss"></A><TT>object</TT> base-class Methods Glossary</H3>
+
+<DL>
+<DT>
+<B><TT>init ( instance
+class -- )</TT> </B></DT>
+
+<DD>
+Default initializer called automatically for all instances created with
+<TT>new</TT> or <TT>new-array</TT>. Zero-fills the instance. You do not
+normally need to invoke <TT>init</TT> explicitly.</DD>
+
+<DT>
+<B><TT>array-init ( nObj instance class -- )</TT></B> </DT>
+
+<DD>
+Applies <TT>init</TT> to an array of objects created by <TT>new-array</TT>.
+Note that <TT>array:</TT> does not cause aggregate arrays to be initialized
+automatically. You do not normally need to invoke <TT>array-init</TT> explicitly.</DD>
+
+<DT>
+<B><TT>class ( instance class
+-- class metaclass )</TT></B> </DT>
+
+<DD>
+Convert an object signature into that of its class. Useful for calling
+class methods that have no object aliases.</DD>
+
+<DT>
+<B><TT>super ( instance class
+-- instance parent-class )</TT></B> </DT>
+
+<DD>
+Upcast an object to its parent class. The parent class of <TT>object</TT>
+is zero. Useful for invoking an overridden parent class method.</DD>
+
+<DT>
+<B><TT>pedigree ( instance class -- )</TT></B> </DT>
+
+<DD>
+Display an object's pedigree - its chain of inheritance. This is an alias
+for the corresponding class method.</DD>
+
+<DT>
+<B><TT>size ( instance
+class -- sizeof(instance) )</TT></B> </DT>
+
+<DD>
+Returns the size, in address units, of one instance. Does not know about
+arrays! This is an alias for the class method <TT>.size</TT></DD>
+
+<DT>
+<B><TT>methods ( instance class -- )</TT></B> </DT>
+
+<DD>
+Class method alias. Displays the list of methods of the class and all superclasses
+of the instance.</DD>
+
+<DT>
+<B><TT>index ( n instance class
+-- instance[n] class )</TT></B> </DT>
+
+<DD>
+Convert array-of-objects base signature into signature for array element
+n. No check for bounds overflow. Index is zero-based, like C, so </DD>
+
+<DL>
+<DD>
+<TT>0 my-obj --> index</TT> </DD>
+</DL>
+
+<DD>
+is equivalent to </DD>
+
+<DL>
+<DD>
+<TT>my-obj</TT></DD>
+</DL>
+
+<DD>
+Check out the <A HREF="#minusrot">description of <TT>-ROT</TT></A> for
+help in dealing with indices on the stack.</DD>
+
+<DT>
+<B><TT>next ( instance[n]
+class -- instance[n+1] class )</TT></B> </DT>
+
+<DD>
+Convert an array-object signature into the signature of the next
+object in the array. No check for bounds overflow.</DD>
+
+<DT>
+<B><TT>prev ( instance[n]
+class -- instance[n-1] class )</TT></B> </DT>
+
+<DD>
+Convert an object signature into the signature of the previous object in
+the array. No check for bounds underflow.</DD>
+</DL>
+
+<H3>
+<A NAME="stockclasses"></A>Supplied Classes (See classes.fr)</H3>
+
+<DL>
+<DT>
+<B><TT>metaclass </TT></B></DT>
+
+<DD>
+Describes all classes of Ficl. Contains class methods. Should never be
+directly instantiated or subclassed.</DD>
+
+<DT>
+<B><TT>object</TT> </B></DT>
+
+<DD>
+Mother of all Ficl objects. Defines default initialization and array indexing
+methods.</DD>
+
+<DT>
+<B><TT>c-ref</TT> </B></DT>
+
+<DD>
+Holds the signature of another object. Aggregate on of these into a data
+structure class to get polymorphism type stuff.</DD>
+
+<DT>
+<B><TT>c-byte </TT></B></DT>
+
+<DD>
+Primitive class with a 1-byte payload. Set and get methods perform correct-length
+fetch and store.</DD>
+
+<DT>
+<B><TT>c-2byte</TT></B> </DT>
+
+<DD>
+Primitive class with a 2-byte payload. Set and get methods perform correct-length
+fetch and store.</DD>
+
+<DT>
+<B><TT>c-4byte</TT></B> </DT>
+
+<DD>
+Primitive class with a 4-byte payload. Set and get methods perform correct-length
+fetch and store.</DD>
+
+<DT>
+<B><TT>c-cellptr</TT></B></DT>
+
+<DD>
+Models a pointer-to-cell.</DD>
+
+<DT>
+<B><TT>c-string</TT></B> </DT>
+
+<DD>
+Models a counted string..</DD>
+</DL>
+ </TD>
+</TR>
+</TABLE>
+
+<H2>
+
+<HR WIDTH="100%"><A NAME="extras"></A>Ficl extras</H2>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD>
+<DL>
+<H3>
+Number syntax</H3>
+You can precede a number with "0x", as in C, and it will be interpreted
+as a hex value regardless of the value of <TT>BASE</TT>. Example:
+<DL><TT>ok> decimal 123 . cr</TT>
+<BR><TT>123 </TT>
+<BR><TT>ok> 0x123 . cr</TT>
+<BR><TT>291 </TT></DL>
+
+<H3>
+Search order words</H3>
+Note: Ficl resets the search order whenever it does <TT>ABORT</TT>. If
+you don't like this behavior, just comment out the dictResetSearchOrder()
+line in ficlExec().
+<BR>
+<DT>
+<TT>>search ( wid -- )</TT></DT>
+
+<DD>
+Push <TT>wid</TT> onto the search order. Many of the other search order
+words are written in terms of the <TT>SEARCH></TT> and <TT>>SEARCH</TT>
+primitives.</DD>
+
+<DT>
+<TT>search> ( -- wid )</TT></DT>
+
+<DD>
+Pop <TT>wid</TT> off the search order</DD>
+
+<DT>
+<TT>ficl-set-current ( wid -- old-wid )</TT></DT>
+
+<DD>
+Set wid as compile wordlist, leave previous compile wordlist on stack</DD>
+
+<DT>
+<TT>wid-set-super ( wid -- )</TT></DT>
+
+<DD>
+Ficl wordlists have a parent wordlist pointer that is not specified in
+standard Forth. Ficl initializes this pointer to NULL whenever it creates
+a wordlist, so it ordinarily has no effect. This word sets the parent pointer
+to the wordlist specified on the top of the stack. Ficl's implementation
+of <TT>SEARCH-WORDLIST</TT> will chain backward through the parent link
+of the wordlist when searching. This simplifies Ficl's object model in
+that the search order does not need to reflect an object's class hierarchy
+when searching for a method. It is possible to implement Ficl object syntax
+in strict ANS Forth, but method finders need to manipulate the search order
+explicitly.</DD>
+</DL>
+
+<H3>
+User variables</H3>
+
+<DL>
+<DT>
+<TT>user ( -- ) name</TT></DT>
+
+<DD>
+Create a user variable with the given name. User variables are virtual
+machine local. Each VM allocates a fixed amount of storage for them. You
+can change the maximum number of user variables allowed by defining FICL_USER_CELLS
+on your compiiler's command line. Default is 16 user cells.</DD>
+</DL>
+
+<H3>
+Miscellaneous</H3>
+
+<DL>
+<DT>
+<TT>-roll ( xu xu-1 ... x0 u -- x0 xu-1 ... x1 ) </TT></DT>
+
+<DD>
+Rotate u+1 items on top of the stack after removing u. Rotation is in the
+opposite sense to <TT>ROLL</TT></DD>
+</DL>
+
+<DL>
+<DT>
+<A NAME="minusrot"></A><TT>-rot ( a b c -- c a b )</TT></DT>
+
+<DD>
+Rotate the top three stack entries, moving the top of stack to third place.
+I like to think of this as <TT>1<SUP>1</SUP>/<SUB>2</SUB>swap</TT> because
+it's good for tucking a single cell value behind a cell-pair (like an object). </DD>
+</DL>
+
+<DL>
+<DT>
+<TT>.env ( -- )</TT></DT>
+
+<DD>
+List all environment variables of the system</DD>
+
+<DT>
+<TT>.hash ( -- )</TT></DT>
+
+<DD>
+List hash table performance statistics of the wordlist that's first in
+the search order</DD>
+
+<DT>
+<TT>.ver ( -- )</TT></DT>
+
+<DD>
+Display ficl version ID</DD>
+
+<DT>
+<TT>>name ( xt -- c-addr u )</TT></DT>
+
+<DD>
+Convert a word's execution token into the address and length of its name</DD>
+
+<DT>
+<TT>body> ( a-addr -- xt )</TT></DT>
+
+<DD>
+Reverses the effect of <TT>CORE</TT> word <TT>>body</TT></DD>
+
+<DT>
+<TT>compile-only</TT></DT>
+
+<DD>
+Mark the most recently defined word as being executable only while in compile
+state. Many immediate words have this property.</DD>
+
+<DT>
+<TT>empty ( -- )</TT> </DT>
+
+<DD>
+Empty the parameter stack</DD>
+
+<DT>
+<TT>endif</TT></DT>
+
+<DD>
+Synonym for <TT>THEN</TT></DD>
+
+<DT>
+<TT>parse-word ( <spaces>name -- c-addr u )</TT></DT>
+
+<DD>
+Skip leading spaces and parse name delimited by a space. c-addr is the
+address within the input buffer and u is the length of the selected string.
+If the parse area is empty, the resulting string has a zero length</DD>
+
+<DT>
+<TT>w@ ( addr -- x )</TT></DT>
+
+<DD>
+Fetch a 16 bit quantity from the specified address</DD>
+
+<DT>
+<TT>w! ( x addr -- )</TT></DT>
+
+<DD>
+Store a 16 bit quantity to the specified address (the low 16 bits of the
+given value)</DD>
+
+<DT>
+<TT>x. ( x -- )</TT></DT>
+
+<DD>
+Pop and display the value in hex format, regardless of the current value
+of <TT>BASE</TT></DD>
+</DL>
+</TD>
+</TR>
+</TABLE>
+
+<H2>
+
+<HR WIDTH="100%"><A NAME="ansinfo"></A>ANS Required Information</H2>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD><B>ANS Forth System</B>
+<BR><B>Providing names from the Core Extensions word set </B>
+<BR><B>Providing the Locals word set </B>
+<BR><B>Providing the Locals Extensions word set </B>
+<BR><B>Providing the Programming-Tools word set</B>
+<BR><B>Providing names from the Programming-Tools Extensions word set</B>
+<BR><B>Providing the Search-Order word set</B>
+<BR><B>Providing the Search-Order Extensions word set </B>
+<H3>
+Implementation-defined Options</H3>
+The implementation-defined items in the following list represent characteristics
+and choices left to the discretion of the implementor, provided that the
+requirements of the Standard are met. A system shall document the values
+for, or behaviors of, each item.
+<UL>
+<LI>
+<B>aligned address requirements (3.1.3.3 Addresses);</B> </LI>
+
+<BR><FONT COLOR="#000000">System dependent. You can change the default
+address alignment by defining FICL_ALIGN on your compiler's command line.
+The default value is set to 2 in sysdep.h. This causes dictionary entries
+and <TT>ALIGN</TT> and <TT>ALIGNED</TT> to align on 4 byte boundaries.
+To align on <B>2<SUP><FONT FACE="">n</FONT></SUP></B> byte boundaries,
+set FICL_ALIGN to <B>n</B>. </FONT>
+<LI>
+<B>behavior of 6.1.1320 EMIT for non-graphic characters</B>; </LI>
+
+<BR><FONT COLOR="#000000">Depends on target system, C runtime library,
+and your implementation of ficlTextOut().</FONT>
+<LI>
+<B>character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT</B>; </LI>
+
+<BR><FONT COLOR="#000000">None implemented in the versions supplied in
+words.c. Because ficlExec() is supplied a text buffer externally, it's
+up to your system to define how that buffer will be obtained.</FONT>
+<LI>
+<B>character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750 KEY)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Depends on target system and implementation of
+ficlTextOut()</FONT>
+<LI>
+<B>character-aligned address requirements (3.1.3.3 Addresses)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl characters are one byte each. There are
+no alignment requirements.</FONT>
+<LI>
+<B>character-set-extensions matching characteristics (3.4.2 Finding definition
+n<FONT COLOR="#000000">ames)</FONT></B><FONT COLOR="#000000">; </FONT></LI>
+
+<BR><FONT COLOR="#000000">No special processing is performed on characters
+beyond case-folding. Therefore, extended characters will not match their
+unaccented counterparts.</FONT>
+<LI>
+<B>conditions under which control characters match a space delimiter (3.4.1.1
+Delimiters)</B>;<FONT COLOR="#FF6666"> </FONT></LI>
+
+<BR><FONT COLOR="#000000">Ficl uses the Standard C function isspace() to
+distinguish space characters. The rest is up to your library vendor.</FONT>
+<LI>
+<B>format of the control-flow stack (3.2.3.2 Control-flow stack)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Uses the data stack</FONT>
+<LI>
+<B>conversion of digits larger than thirty-five (3.2.1.2 Digit conversion)</B>; </LI>
+
+<BR><FONT COLOR="#000000">The maximum supported value of <TT>BASE</TT>
+is 36. Ficl will assertion fail in function ltoa of vm.c if the base is
+found to be larger than 36 or smaller than 2. There will be no effect if
+NDEBUG is defined</FONT>, however, other than possibly unexpected behavior.
+<LI>
+<B>display after input terminates in 6.1.0695 ACCEPT and 6.2.1390 EXPECT</B>; </LI>
+
+<BR><FONT COLOR="#000000">Target system dependent</FONT>
+<LI>
+<B>exception abort sequence (as in 6.1.0680 ABORT")</B>; </LI>
+
+<BR><FONT COLOR="#000000">Does <TT>ABORT</TT></FONT>
+<LI>
+<B>input line terminator (3.2.4.1 User input device)</B>;<FONT COLOR="#FF0000"> </FONT></LI>
+
+<BR><FONT COLOR="#000000">Target system dependent (implementation of outer
+loop that calls ficlExec)</FONT>
+<LI>
+<B>maximum size of a counted string, in characters (3.1.3.4 Counted strings,
+6.1.2450 WORD)</B>; </LI>
+
+<BR><FONT COLOR="#000000">255</FONT>
+<LI>
+<B>maximum size of a parsed string (3.4.1 Parsing)</B>; </LI>
+
+<BR>Limited by available memory and the maximum unsigned value that can
+fit in a CELL (2<SUP>32</SUP>-1).
+<LI>
+<B>maximum size of a definition name, in characters (3.3.1.2 Definition
+names)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl stores the first 31 characters of a definition
+name.</FONT>
+<LI>
+<B>maximum string length for 6.1.1345 ENVIRONMENT?, in characters</B>; </LI>
+
+<BR><FONT COLOR="#000000">Same as maximum definition name length</FONT>
+<LI>
+<B>method of selecting 3.2.4.1 User input device</B>; </LI>
+
+<BR>None supported. This is up to the target system
+<LI>
+<B>method of selecting 3.2.4.2 User output device</B>; </LI>
+
+<BR>None supported. This is up to the target system
+<LI>
+<B>methods of dictionary compilation (3.3 The Forth dictionary)</B>; </LI>
+
+<LI>
+<B>number of bits in one address unit (3.1.3.3 Addresses)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Target system dependent. Ficl generally supports
+processors that can address 8 bit quantities, but there is no dependency
+that I'm aware of.</FONT>
+<LI>
+<B>number representation and arithmetic (3.2.1.1 Internal number representation)</B>; </LI>
+
+<BR>System dependent. Ficl represents a CELL internally as a union that
+can hold INT32 (a signed 32 bit scalar value), UNS32 (32 bits unsigned),
+and an untyped pointer. No specific byte ordering is assumed.
+<LI>
+<B>ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types, 3.1.4 Cell-pair
+types)</B>; </LI>
+
+<BR>Assuming a 32 bit implementation, range for signed single-cell values
+is -2<SUP>31</SUP>..2<SUP>31</SUP>-1. Range for unsigned single cell values
+is 0..2<SUP>32</SUP>-1. Range for signed double-cell values is -2<SUP>63</SUP>..2<SUP>63</SUP>-1.
+Range for unsigned single cell values is 0..2<SUP>64</SUP>-1.
+<LI>
+<B>read-only data-space regions (3.3.3 Data space)</B>;</LI>
+
+<BR>None
+<LI>
+<B>size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient regions)</B>; </LI>
+
+<BR>Default is 255. Depends on the setting of nPAD in ficl.h.
+<LI>
+<B>size of one cell in address units (3.1.3 Single-cell types)</B>; </LI>
+
+<BR><FONT COLOR="#000000">System dependent, generally four.</FONT>
+<LI>
+<B>size of one character in address units (3.1.2 Character types)</B>; </LI>
+
+<BR><FONT COLOR="#000000">System dependent, generally one.</FONT>
+<LI>
+<B>size of the keyboard terminal input buffer (3.3.3.5 Input buffers)</B>; </LI>
+
+<BR><FONT COLOR="#000000">This buffer is supplied by the host program.
+Ficl imposes no practical limit.</FONT>
+<LI>
+<B>size of the pictured numeric output string buffer (3.3.3.6 Other transient
+regions)</B>; </LI>
+
+<BR>Default is 255 characters. Depends on the setting of nPAD in ficl.h.
+<LI>
+<B>size of the scratch area whose address is returned by 6.2.2000 PAD (3.3.3.6
+Other transient regions)</B>; </LI>
+
+<BR>Not presently supported
+<LI>
+<B>system case-sensitivity characteristics (3.4.2 Finding definition names)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl is not case sensitive</FONT>
+<LI>
+<B>system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)</B>; </LI>
+
+<BR><FONT COLOR="#000000">"ok>"</FONT>
+<LI>
+<B>type of division rounding (3.2.2.1 Integer division, 6.1.0100 */, 6.1.0110
+*/MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Symmetric</FONT>
+<LI>
+<B>values of 6.1.2250 STATE when true</B>; </LI>
+
+<BR><FONT COLOR="#000000">One (no others)</FONT>
+<LI>
+<B>values returned after arithmetic overflow (3.2.2.2 Other integer operations)</B>; </LI>
+
+<BR>System dependent. Ficl makes no special checks for overflow.
+<LI>
+<B>whether the current definition can be found after 6.1.1250 DOES> (6.1.0450
+:)</B>. </LI>
+
+<BR><FONT COLOR="#000000">No. Definitions are unsmudged after ; only, and
+only then if no control structure matching problems have been detected.</FONT></UL>
+
+<H3>
+Ambiguous Conditions</H3>
+A system shall document the system action taken upon each of the general
+or specific ambiguous conditions identified in this Standard. See 3.4.4
+Possible actions on an ambiguous condition.
+
+<P>The following general ambiguous conditions could occur because of a
+combination of factors:
+<UL>
+<DL>
+<LI>
+<B>a name is neither a valid definition name nor a valid number during
+text interpretation (3.4 The Forth text interpreter)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl does <TT>ABORT</TT> and prints the name
+followed by " not found".</FONT>
+<LI>
+<B>a definition name exceeded the maximum length allowed (3.3.1.2 Definition
+names)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl stores the first 31 characters of the definition
+name, and uses all characters of the name in computing its hash code. The
+actual length of the name, up to 255 characters, is stored in the definition's
+length field.</FONT>
+<LI>
+<B>addressing a region not listed in 3.3.3 Data Space</B>; </LI>
+
+<BR><FONT COLOR="#000000">No problem: all addresses in ficl are absolute.
+You can reach any 32 bit address in Ficl's address space.</FONT>
+<LI>
+<B>argument type incompatible with specified input parameter, e.g., passing
+a flag to a word expecting an n (3.1 Data types)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl makes no check for argument type compatibility.
+Effects of a mismatch vary widely depending on the specific problem and
+operands.</FONT></DL>
+
+<LI>
+<B>attempting to obtain the execution token, (e.g., with 6.1.0070 ', 6.1.1550
+FIND, etc.) of a definition with undefined interpretation semantics</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl returns a valid token, but the result of
+executing that token while interpreting may be undesirable.</FONT>
+<LI>
+<B>dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240
+/MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD,
+8.6.1.1820 M*/)</B>;</LI>
+
+<BR><FONT COLOR="#000000">Results are target procesor dependent. Generally,
+Ficl makes no check for divide-by-zero. The target processor will probably
+throw an exception.</FONT>
+<LI>
+<B>insufficient data-stack space or return-stack space (stack overflow)</B>; </LI>
+
+<BR><FONT COLOR="#000000">With FICL_ROBUST (sysdep.h) set >= 2, most parameter
+stack operations are checked for underflow and overflow. Ficl does not
+check the return stack.</FONT>
+<LI>
+<B>insufficient space for loop-control parameters</B>; </LI>
+
+<BR><FONT COLOR="#000000">No check - Evil results.</FONT>
+<LI>
+<B>insufficient space in the dictionary</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl generates an error message if the dictionary
+is too full to create a definition header. It checks <TT>ALLOT</TT> as
+well, but it is possible to make an unchecked allocation request that overflows
+the dictionary.</FONT>
+<LI>
+<B>interpreting a word with undefined interpretation semantics</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl protects all ANS Forth words with undefined
+interpretation semantics from being executed while in interpret state.
+It is possible to defeat this protection using ' (tick) and <TT>EXECUTE</TT>,
+though.</FONT>
+<LI>
+<B>modifying the contents of the input buffer or a string literal (3.3.3.4
+Text-literal regions, 3.3.3.5 Input buffers)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Varies depending on the nature of the buffer.
+The input buffer is supplied by ficl's host function, and may reside in
+read-only memory. If so, writing the input buffer can ganerate an exception.
+String literals are stored in the dictionary, and are writable.</FONT>
+<LI>
+<B>overflow of a pictured numeric output string</B>;</LI>
+
+<BR>In the unlikely event you are able to construct a pictured numeric
+string of more than 255 characters, the system will be corrupted unpredictably.
+The buffer area that holds pictured numeric output is at the end of the
+virtual machine. Whatever is mapped after the offending VM in memory will
+be trashed, along with the heap structures that contain it.
+<LI>
+<B>parsed string overflow</B>;</LI>
+
+<BR>Ficl does not copy parsed strings unless asked to. Ordinarily, a string
+parsed from the input buffer during normal interpretation is left in-place,
+so there is no possibility of overflow. If you ask to parse a string into
+the dictionary, as in <TT>SLITERAL</TT>, you need to have enough room for
+the string, otherwise bad things may happen. This is not usually a problem.
+<LI>
+<B>producing a result out of range, e.g., multiplication (using *) results
+in a value too big to be represented by a single-cell integer (6.1.0090
+*, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570 >NUMBER, 6.1.1561 FM/MOD, 6.1.2214
+SM/REM, 6.1.2370 UM/MOD, 6.2.0970 CONVERT, 8.6.1.1820 M*/)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Value will be truncated</FONT>
+<LI>
+<B>reading from an empty data stack or return stack (stack underflow)</B>; </LI>
+
+<BR><FONT COLOR="#000000">Most stack underflows are detected and prevented
+if FICL_ROBUST (sysdep.h) is set to 2 or greater. Otherwise, the stack
+pointer and size are likely to be trashed.</FONT>
+<LI>
+<B>unexpected end of input buffer, resulting in an attempt to use a zero-length
+string as a name</B>; </LI>
+
+<BR><FONT COLOR="#000000">Ficl returns for a new input buffer until a non-empty
+one is supplied.</FONT></UL>
+The following specific ambiguous conditions are noted in the glossary entries
+of the relevant words:
+<UL>
+<LI>
+<B>>IN greater than size of input buffer (3.4.1 Parsing)</B></LI>
+
+<BR>Bad Things occur - unpredictable bacause the input buffer is supplied
+by the host program's outer loop.
+<LI>
+<B>6.1.2120 RECURSE appears after 6.1.1250 DOES></B></LI>
+
+<BR>It finds the address of the definition before <TT>DOES></TT>
+<LI>
+<B>argument input source different than current input source for 6.2.2148
+RESTORE-INPUT</B></LI>
+
+<BR>Not implemented
+<LI>
+<B>data space containing definitions is de-allocated (3.3.3.2 Contiguous
+regions)</B></LI>
+
+<BR>This is OK until the cells are overwritten with something else. The
+dictionary maintains a hash table, and the table must be updated in order
+to de-allocate words without corruption.
+<LI>
+<B>data space read/write with incorrect alignment (3.3.3.1 Address alignment)</B></LI>
+
+<BR>Target processor dependent. Consequences include: none (Intel), address
+error exception (68K).
+<LI>
+<B>data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860 C,)</B></LI>
+
+<BR>See above on data space read/write alignment
+<LI>
+<B>less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)</B></LI>
+
+<BR>Ficl detects a stack underflow and reports it, executing <TT>ABORT,</TT>
+as long as FICL_ROBUST is two or larger.
+<LI>
+<B>loop-control parameters not available ( 6.1.0140 +LOOP, 6.1.1680 I,
+6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)</B></LI>
+
+<BR>Loop initiation words are responsible for checking the stack and guaranteeing
+that the control parameters are pushed. Any underflows will be detected
+early if FICL_ROBUST is set to two or greater. Note however that Ficl only
+checks for return stack underflows at the end of each line of text.
+<LI>
+<B>most recent definition does not have a name (6.1.1710 IMMEDIATE)</B></LI>
+
+<BR>No problem.
+<LI>
+<B>name not defined by 6.2.2405 VALUE used by 6.2.2295 TO</B></LI>
+
+<BR>Ficl's version of <TT>TO</TT> works correctly with <TT>VALUE</TT>s,
+<TT>CONSTANT</TT>s and <TT>VARIABLE</TT>s.
+<LI>
+<B>name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['], 6.2.2530
+[COMPILE])</B></LI>
+
+<BR>Ficl prints an error message and does <TT>ABORT</TT>
+<LI>
+<B>parameters are not of the same type (6.1.1240 DO, 6.2.0620 ?DO, 6.2.2440
+WITHIN)</B></LI>
+
+<BR>No check. Results vary depending on the specific problem.
+<LI>
+<B>6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO</B></LI>
+
+<BR>The word is postponed correctly.
+<LI>
+<B>string longer than a counted string returned by 6.1.2450 WORD</B></LI>
+
+<BR>Ficl stores the first FICL_STRING_MAX-1 chars in the destination buffer.
+(The extra character is the trailing space required by the standard. Yuck.)
+<LI>
+<B>u greater than or equal to the number of bits in a cell (6.1.1805 LSHIFT,
+6.1.2162 RSHIFT)</B></LI>
+
+<BR>Depends on target process or and C runtime library implementations
+of the << and >> operators on unsigned values. For I386, the processor
+appears to shift modulo the number of bits in a cell.
+<LI>
+<B>word not defined via 6.1.1000 CREATE (6.1.0550 >BODY, 6.1.1250 DOES>)</B></LI>
+
+<BR><B>words improperly used outside 6.1.0490 <# and 6.1.0040 #> (6.1.0030
+#, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)</B>
+<BR>Don't. <TT>CREATE</TT> reserves a field in words it builds for <TT>DOES></TT>
+to fill in. If you use <TT>DOES></TT> on a word not made by <TT>CREATE</TT>,
+it will overwrite the first cell of its parameter area. That's probably
+not what you want. Likewise, pictured numeric words assume that there is
+a string under construction in the VM's scratch buffer. If that's not the
+case, results may be unpleasant.</UL>
+
+<H3>
+Locals Implementation-defined options</H3>
+
+<UL>
+<LI>
+<B>maximum number of locals in a definition (13.3.3 Processing locals,
+13.6.2.1795 LOCALS|)</B></LI>
+
+<BR>Default is 16. Change by redefining FICL_MAX_LOCALS, defined in sysdep.h</UL>
+
+<H3>
+Locals Ambiguous conditions</H3>
+
+<UL>
+<LI>
+<B>executing a named local while in interpretation state (13.6.1.0086 (LOCAL))</B></LI>
+
+<BR>Locals can be found in interpretation state while in the context of
+a definition under construction. Under these circumstances, locals behave
+correctly. Locals are not visible at all outside the scope of a definition.
+<LI>
+<B>name not defined by VALUE or LOCAL (13.6.1.2295 TO)</B></LI>
+
+<BR>See the CORE ambiguous conditions, above (no change)</UL>
+
+<H3>
+Programming Tools Implementation-defined options</H3>
+
+<UL>
+<LI>
+<B>source and format of display by 15.6.1.2194 SEE</B></LI>
+
+<BR>SEE de-compiles definitions from the dictionary. Because Ficl words
+are threaded by their header addresses, it is very straightforward to print
+the name and other characteristics of words in a definition. Primitives
+are so noted. Colon definitions are decompiled, but branch target labels
+are not reconstructed. Literals and string literals are so noted, and their
+contents displayed.</UL>
+
+<H3>
+Search Order Implementation-defined options</H3>
+
+<UL>
+<LI>
+<B>maximum number of word lists in the search order (16.3.3 Finding definition
+names, 16.6.1.2197 SET-ORDER)</B> </LI>
+
+<BR>Defaults to 16. Can be changed by redefining FICL_DEFAULT_VOCS, declared
+in sysdep.h
+<LI>
+<B>minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)</B> </LI>
+
+<BR>Equivalent to <TT>FORTH-WORDLIST 1 SET-ORDER</TT></UL>
+
+<H3>
+Search Order Ambiguous conditions</H3>
+
+<UL>
+<LI>
+<B>changing the compilation word list (16.3.3 Finding definition names)</B></LI>
+
+<BR>Ficl stores a link to the current definition independently of the compile
+wordlist while it is being defined, and links it into the compile wordlist
+only after the definition completes successfully. Changing the compile
+wordlist mid-definition will cause the definition to link into the <I>new</I>
+compile wordlist.
+<LI>
+<B>search order empty (16.6.2.2037 PREVIOUS)</B></LI>
+
+<BR>Ficl prints an error message if the search order underflows, and resets
+the order to its default state.
+<LI>
+<B>too many word lists in search order (16.6.2.0715 ALSO)</B></LI>
+
+<BR>Ficl prints an error message if the search order overflows, and resets
+the order to its default state.</UL>
+
+<BR> </TD>
+</TR>
+</TABLE>
+
+<H2>
+
+<HR WIDTH="100%"><A NAME="links"></A>For more information</H2>
+
+<UL>
+<LI>
+<A HREF="http://www.taygeta.com/forth/compilers">Web home of ficl</A></LI>
+
+<LI>
+<A HREF="http://www.taygeta.com/forthlit.html">Forth literature</A></LI>
+
+<UL>
+<LI>
+<A HREF="http://www.softsynth.com/pforth/pf_tut.htm">Phil Burk's Forth
+Tutorial</A></LI>
+
+<LI>
+<A HREF="http://www.taygeta.com/forth/dpans.html">Draft Proposed American
+National Standard for Forth</A></LI>
+</UL>
+
+<LI>
+<A HREF="http://www.fig.org">Forth Interest Group</A></LI>
+
+<LI>
+<A HREF="ftp://ftp.taygeta.com/pub/Forth/Compilers/native/misc/ficl200.zip">Download
+ficl 2.0</A></LI>
+</UL>
+
+<H2>
+
+<HR WIDTH="100%"></H2>
+
+<H2>
+<A NAME="lawyerbait"></A>DISCLAIMER OF WARRANTY and LICENSE</H2>
+
+<TABLE BORDER=0 CELLSPACING=3 COLS=1 WIDTH="600" >
+<TR>
+<TD><I>Ficl is freeware. Use it in any way that you like, with the understanding
+that the code is not supported.</I>
+
+<P>Any third party may reproduce, distribute, or modify the ficl software
+code or any derivative works thereof without any compensation or license,
+provided that the original author information and this disclaimer text
+are retained in the source code files. The ficl software code is provided
+on an "as is" basis without warranty of any kind, including, without limitation,
+the implied warranties of merchantability and fitness for a particular
+purpose and their equivalents under the laws of any jurisdiction.
+
+<P>I am interested in hearing from anyone who uses ficl. If you have a
+problem, a success story, a defect, an enhancement request, or if you would
+like to contribute to the ficl release (yay!), please send me email at
+the address above. </TD>
+</TR>
+</TABLE>
+
+</BODY>
+</HTML>
--- /dev/null
+++ b/ficl.c
@@ -1,0 +1,380 @@
+/*******************************************************************
+** f i c l . c
+** Forth Inspired Command Language - external interface
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+**
+*******************************************************************/
+/*
+** This is an ANS Forth interpreter written in C.
+** Ficl uses Forth syntax for its commands, but turns the Forth
+** model on its head in other respects.
+** Ficl provides facilities for interoperating
+** with programs written in C: C functions can be exported to Ficl,
+** and Ficl commands can be executed via a C calling interface. The
+** interpreter is re-entrant, so it can be used in multiple instances
+** in a multitasking system. Unlike Forth, Ficl's outer interpreter
+** expects a text block as input, and returns to the caller after each
+** text block, so the data pump is somewhere in external code. This
+** is more like TCL than Forth.
+**
+** Code is written in ANSI C for portability.
+*/
+
+#include <stdlib.h>
+#include <string.h>
+#include "ficl.h"
+
+
+/*
+** Local prototypes
+*/
+
+
+/*
+** System statics
+** The system builds a global dictionary during its start
+** sequence. This is shared by all interpreter instances.
+** Therefore only one instance can update the dictionary
+** at a time. The system imports a locking function that
+** you can override in order to control update access to
+** the dictionary. The function is stubbed out by default,
+** but you can insert one: #define FICL_MULTITHREAD 1
+** and supply your own version of ficlLockDictionary.
+*/
+static FICL_DICT *dp = NULL;
+static FICL_DICT *envp = NULL;
+#if FICL_WANT_LOCALS
+static FICL_DICT *localp = NULL;
+#endif
+static FICL_VM *vmList = NULL;
+
+static int defaultStack = FICL_DEFAULT_STACK;
+static int defaultDict = FICL_DEFAULT_DICT;
+
+
+/**************************************************************************
+ f i c l I n i t S y s t e m
+** Binds a global dictionary to the interpreter system.
+** You specify the address and size of the allocated area.
+** After that, ficl manages it.
+** First step is to set up the static pointers to the area.
+** Then write the "precompiled" portion of the dictionary in.
+** The dictionary needs to be at least large enough to hold the
+** precompiled part. Try 1K cells minimum. Use "words" to find
+** out how much of the dictionary is used at any time.
+**************************************************************************/
+void ficlInitSystem(int nDictCells)
+{+ if (dp)
+ dictDelete(dp);
+
+ if (envp)
+ dictDelete(envp);
+
+#if FICL_WANT_LOCALS
+ if (localp)
+ dictDelete(localp);
+#endif
+
+ if (nDictCells <= 0)
+ nDictCells = defaultDict;
+
+ dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
+ envp = dictCreate( (unsigned)FICL_DEFAULT_ENV);
+#if FICL_WANT_LOCALS
+ /*
+ ** The locals dictionary is only searched while compiling,
+ ** but this is where speed is most important. On the other
+ ** hand, the dictionary gets emptied after each use of locals
+ ** The need to balance search speed with the cost of the empty
+ ** operation led me to select a single-threaded list...
+ */
+ localp = dictCreate( (unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
+#endif
+
+ ficlCompileCore(dp);
+
+ return;
+}
+
+
+/**************************************************************************
+ f i c l N e w V M
+** Create a new virtual machine and link it into the system list
+** of VMs for later cleanup by ficlTermSystem. If this is the first
+** VM to be created, use it to compile the words in softcore.c
+**************************************************************************/
+FICL_VM *ficlNewVM(void)
+{+ FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
+ pVM->link = vmList;
+
+ /*
+ ** Borrow the first vm to build the soft words in softcore.c
+ */
+ if (vmList == NULL)
+ ficlCompileSoftCore(pVM);
+
+ vmList = pVM;
+ return pVM;
+}
+
+
+/**************************************************************************
+ f i c l B u i l d
+** Builds a word into the dictionary.
+** Preconditions: system must be initialized, and there must
+** be enough space for the new word's header! Operation is
+** controlled by ficlLockDictionary, so any initialization
+** required by your version of the function (if you overrode
+** it) must be complete at this point.
+** Parameters:
+** name -- duh, the name of the word
+** code -- code to execute when the word is invoked - must take a single param
+** pointer to a FICL_VM
+** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR!
+**
+**************************************************************************/
+int ficlBuild(char *name, FICL_CODE code, char flags)
+{+ int err = ficlLockDictionary(TRUE);
+ if (err) return err;
+
+ dictAppendWord(dp, name, code, flags);
+
+ ficlLockDictionary(FALSE);
+ return 0;
+}
+
+
+/**************************************************************************
+ 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.
+**
+** Contains the "inner interpreter" code in a tight loop
+**
+** Returns one of the VM_XXXX codes defined in ficl.h:
+** VM_OUTOFTEXT is the normal exit condition
+** VM_ERREXIT means that the interp encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** VM_USEREXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
+**************************************************************************/
+int ficlExec(FICL_VM *pVM, char *pText)
+{+ int except;
+ FICL_WORD *tempFW;
+ jmp_buf vmState;
+ jmp_buf *oldState;
+ TIB saveTib;
+
+ assert(pVM);
+
+ vmPushTib(pVM, pText, &saveTib);
+
+ /*
+ ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
+ */
+ oldState = pVM->pState;
+ pVM->pState = &vmState; /* This has to come before the setjmp! */
+ except = setjmp(vmState);
+
+ switch (except)
+ {+ case 0:
+ if (pVM->fRestart)
+ {+ pVM->fRestart = 0;
+ pVM->runningWord->code(pVM);
+ }
+
+ /*
+ ** the mysterious inner interpreter...
+ ** vmThrow gets you out of this loop with a longjmp()
+ */
+ for (;;)
+ {+ tempFW = *pVM->ip++;
+ /*
+ ** inline code for
+ ** vmExecute(pVM, tempFW);
+ */
+ pVM->runningWord = tempFW;
+ tempFW->code(pVM);
+ }
+
+ break;
+
+ case VM_RESTART:
+ pVM->fRestart = 1;
+ except = VM_OUTOFTEXT;
+ break;
+
+ case VM_OUTOFTEXT:
+ if ((pVM->state != COMPILE) && (pVM->sourceID == 0))
+ ficlTextOut(pVM, FICL_PROMPT, 0);
+ break;
+
+ case VM_USEREXIT:
+ break;
+
+ case VM_QUIT:
+ if (pVM->state == COMPILE)
+ dictAbortDefinition(dp);
+ vmQuit(pVM);
+ break;
+
+ case VM_ERREXIT:
+ default: /* user defined exit code?? */
+ if (pVM->state == COMPILE)
+ {+ dictAbortDefinition(dp);
+ dictResetSearchOrder(dp);
+#if FICL_WANT_LOCALS
+ dictEmpty(localp, localp->pForthWords->size);
+#endif
+ }
+ vmReset(pVM);
+ break;
+ }
+
+ pVM->pState = oldState;
+ vmPopTib(pVM, &saveTib);
+ return (except);
+}
+
+
+/**************************************************************************
+ f i c l L o o k u p
+** Look in the system dictionary for a match to the given name. If
+** found, return the address of the corresponding FICL_WORD. Otherwise
+** return NULL.
+**************************************************************************/
+FICL_WORD *ficlLookup(char *name)
+{+ STRINGINFO si;
+ SI_PSZ(si, name);
+ return dictLookup(dp, si);
+}
+
+
+/**************************************************************************
+ f i c l G e t D i c t
+** Returns the address of the system dictionary
+**************************************************************************/
+FICL_DICT *ficlGetDict(void)
+{+ return dp;
+}
+
+
+/**************************************************************************
+ f i c l G e t E n v
+** Returns the address of the system environment space
+**************************************************************************/
+FICL_DICT *ficlGetEnv(void)
+{+ return envp;
+}
+
+
+/**************************************************************************
+ f i c l S e t E n v
+** Create an environment variable with a one-CELL payload. ficlSetEnvD
+** makes one with a two-CELL payload.
+**************************************************************************/
+void ficlSetEnv(char *name, UNS32 value)
+{+ STRINGINFO si;
+ FICL_WORD *pFW;
+
+ SI_PSZ(si, name);
+ pFW = dictLookup(envp, si);
+
+ if (pFW == NULL)
+ {+ dictAppendWord(envp, name, constantParen, FW_DEFAULT);
+ dictAppendCell(envp, LVALUEtoCELL(value));
+ }
+ else
+ {+ pFW->param[0] = LVALUEtoCELL(value);
+ }
+
+ return;
+}
+
+void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo)
+{+ FICL_WORD *pFW;
+ STRINGINFO si;
+ SI_PSZ(si, name);
+ pFW = dictLookup(envp, si);
+
+ if (pFW == NULL)
+ {+ dictAppendWord(envp, name, twoConstParen, FW_DEFAULT);
+ dictAppendCell(envp, LVALUEtoCELL(lo));
+ dictAppendCell(envp, LVALUEtoCELL(hi));
+ }
+ else
+ {+ pFW->param[0] = LVALUEtoCELL(lo);
+ pFW->param[1] = LVALUEtoCELL(hi);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ f i c l G e t L o c
+** Returns the address of the system locals dictionary. This dict is
+** only used during compilation, and is shared by all VMs.
+**************************************************************************/
+#if FICL_WANT_LOCALS
+FICL_DICT *ficlGetLoc(void)
+{+ return localp;
+}
+#endif
+
+
+/**************************************************************************
+ f i c l T e r m S y s t e m
+** Tear the system down by deleting the dictionaries and all VMs.
+** This saves you from having to keep track of all that stuff.
+**************************************************************************/
+void ficlTermSystem(void)
+{+ if (dp)
+ dictDelete(dp);
+ dp = NULL;
+
+ if (envp)
+ dictDelete(envp);
+ envp = NULL;
+
+#if FICL_WANT_LOCALS
+ if (localp)
+ dictDelete(localp);
+ localp = NULL;
+#endif
+
+ while (vmList != NULL)
+ {+ FICL_VM *pVM = vmList;
+ vmList = vmList->link;
+ vmDelete(pVM);
+ }
+
+ return;
+}
+
+
--- /dev/null
+++ b/ficl.h
@@ -1,0 +1,756 @@
+/*******************************************************************
+** f i c l . h
+** Forth Inspired Command Language
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+**
+*******************************************************************/
+/*
+** N O T I C E -- DISCLAIMER OF WARRANTY
+**
+** Ficl is freeware. Use it in any way that you like, with
+** the understanding that the code is not supported.
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this disclaimer text are retained in the source code files.
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+**
+** I am interested in hearing from anyone who uses ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the ficl release (yay!), please
+** send me email at the address above.
+*/
+
+#if !defined (__FICL_H__)
+#define __FICL_H__
+/*
+** Ficl (Forth-inspired command language) is an ANS Forth
+** interpreter written in C. Unlike traditional Forths, this
+** interpreter is designed to be embedded into other systems
+** as a command/macro/development prototype language.
+**
+** Where Forths usually view themselves as the center of the system
+** and expect the rest of the system to be coded in Forth, Ficl
+** acts as a component of the system. It is easy to export
+** code written in C or ASM to Ficl in the style of TCL, or to invoke
+** Ficl code from a compiled module. This allows you to do incremental
+** development in a way that combines the best features of threaded
+** languages (rapid development, quick code/test/debug cycle,
+** reasonably fast) with the best features of C (everyone knows it,
+** easier to support large blocks of code, efficient, type checking).
+**
+** Ficl provides facilities for interoperating
+** with programs written in C: C functions can be exported to Ficl,
+** and Ficl commands can be executed via a C calling interface. The
+** interpreter is re-entrant, so it can be used in multiple instances
+** in a multitasking system. Unlike Forth, Ficl's outer interpreter
+** expects a text block as input, and returns to the caller after each
+** text block, so the "data pump" is somewhere in external code. This
+** is more like TCL than Forth, which usually expcets to be at the center
+** of the system, requesting input at its convenience. Each Ficl virtual
+** machine can be bound to a different I/O channel, and is independent
+** of all others in in the same address space except that all virtual
+** machines share a common dictionary (a sort or open symbol table that
+** defines all of the elements of the language).
+**
+** Code is written in ANSI C for portability.
+**
+** Summary of Ficl features and constraints:
+** - Standard: Implements the ANSI Forth CORE word set and part
+** of the CORE EXT word-set, SEARCH and SEARCH EXT, TOOLS and
+** TOOLS EXT, LOCAL and LOCAL ext and various extras.
+** - Extensible: you can export code written in Forth, C,
+** or asm in a straightforward way. Ficl provides open
+** facilities for extending the language in an application
+** specific way. You can even add new control structures!
+** - Ficl and C can interact in two ways: Ficl can encapsulate
+** C code, or C code can invoke Ficl code.
+** - Thread-safe, re-entrant: The shared system dictionary
+** uses a locking mechanism that you can either supply
+** or stub out to provide exclusive access. Each Ficl
+** virtual machine has an otherwise complete state, and
+** each can be bound to a separate I/O channel (or none at all).
+** - Simple encapsulation into existing systems: a basic implementation
+** requires three function calls (see the example program in testmain.c).
+** - ROMable: Ficl is designed to work in RAM-based and ROM code / RAM data
+** environments. It does require somewhat more memory than a pure
+** ROM implementation because it builds its system dictionary in
+** RAM at startup time.
+** - Written an ANSI C to be as simple as I can make it to understand,
+** support, debug, and port. Compiles without complaint at /Az /W4
+** (require ANSI C, max warnings) under Microsoft VC++ 5.
+** - Does full 32 bit math (but you need to implement
+** two mixed precision math primitives (see sysdep.c))
+** - Indirect threaded interpreter is not the fastest kind of
+** Forth there is (see pForth 68K for a really fast subroutine
+** threaded interpreter), but it's the cleanest match to a
+** pure C implementation.
+**
+** P O R T I N G F i c l
+**
+** To install Ficl on your target system, you need an ANSI C compiler
+** and its runtime library. Inspect the system dependent macros and
+** functions in sysdep.h and sysdep.c and edit them to suit your
+** system. For example, INT16 is a short on some compilers and an
+** int on others. Check the default CELL alignment controlled by
+** FICL_ALIGN. If necessary, add new definitions of ficlMalloc, ficlFree,
+** ficlLockDictionary, and ficlTextOut to work with your operating system.
+** Finally, use testmain.c as a guide to installing the Ficl system and
+** one or more virtual machines into your code. You do not need to include
+** testmain.c in your build.
+**
+** T o D o L i s t
+**
+** 1. Unimplemented system dependent CORE word: key
+** 2. Kludged CORE word: ACCEPT
+** 3. Dictionary locking is full of holes - only one vm at a time
+** can alter the dict.
+** 4. Ficl uses the pad in CORE words - this violates the standard,
+** but it's cleaner for a multithreaded system. I'll have to make a
+** second pad for reference by the word PAD to fix this.
+**
+** F o r M o r e I n f o r m a t i o n
+**
+** Web home of ficl
+** http://www.taygeta.com/forth/compilers
+** Check this website for Forth literature (including the ANSI standard)
+** http://www.taygeta.com/forthlit.html
+** and here for software and more links
+** http://www.taygeta.com/forth.html
+**
+** Obvious Performance enhancement opportunities
+** Compile speed
+** - work on interpret speed
+** - turn off locals (FICL_WANT_LOCALS)
+** Interpret speed
+** - Change inner interpreter (and everything else)
+** so that a definition is a list of pointers to functions
+** and inline data rather than pointers to words. This gets
+** rid of vm->runningWord and a level of indirection in the
+** inner loop. I'll look at it for ficl 3.0
+** - Make the main hash table a bigger prime (HASHSIZE)
+** - FORGET about twiddling the hash function - my experience is
+** that that is a waste of time.
+** - eliminate the need to pass the pVM parameter on the stack
+** by dedicating a register to it. Most words need access to the
+** vm, but the parameter passing overhead can be reduced. One way
+** requires that the host OS have a task switch callout. Create
+** a global variable for the running VM and refer to it in words
+** that need VM access. Alternative: use thread local storage.
+** For single threaded implementations, you can just use a global.
+** The first two solutions create portability problems, so I
+** haven't considered doing them. Another possibility is to
+** declare the pVm parameter to be "register", and hope the compiler
+** pays attention.
+**
+*/
+
+/*
+** Revision History:
+** 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,
+** EMPTY to clear stack.
+**
+** 29 jun 1998 (sadler) added variable sized hash table support
+** and ANS Forth optional SEARCH & SEARCH EXT word set.
+** 26 May 1998 (sadler)
+** FICL_PROMPT macro
+** 14 April 1998 (sadler) V1.04
+** Ficlwin: Windows version, Skip Carter's Linux port
+** 5 March 1998 (sadler) V1.03
+** Bug fixes -- passes John Ryan's ANS test suite "core.fr"
+**
+** 24 February 1998 (sadler) V1.02
+** -Fixed bugs in <# # #>
+** -Changed FICL_WORD so that storage for the name characters
+** can be allocated from the dictionary as needed rather than
+** reserving 32 bytes in each word whether needed or not -
+** this saved 50% of the dictionary storage requirement.
+** -Added words in testmain for Win32 functions system,chdir,cwd,
+** also added a word that loads and evaluates a file.
+**
+** December 1997 (sadler)
+** -Added VM_RESTART exception handling in ficlExec -- this lets words
+** that require additional text to succeed (like :, create, variable...)
+** recover gracefully from an empty input buffer rather than emitting
+** an error message. Definitions can span multiple input blocks with
+** no restrictions.
+** -Changed #include order so that <assert.h> is included in sysdep.h,
+** and sysdep is included in all other files. This lets you define
+** NDEBUG in sysdep.h to disable assertions if you want to.
+** -Make PC specific system dependent code conditional on _M_IX86
+** defined so that ports can coexist in sysdep.h/sysdep.c
+*/
+
+#ifdef __cplusplus
+extern "C" {+#endif
+
+#include "sysdep.h"
+#include <limits.h> /* UCHAR_MAX */
+
+/*
+** Forward declarations... read on.
+*/
+struct ficl_word;
+struct vm;
+struct ficl_dict;
+
+/*
+** the Good Stuff starts here...
+*/
+#define FICL_VER "2.00"
+#define FICL_PROMPT "ok> "
+
+/*
+** ANS Forth requires false to be zero, and true to be the ones
+** complement of false... that unifies logical and bitwise operations
+** nicely.
+*/
+#define FICL_TRUE (0xffffffffL)
+#define FICL_FALSE (0)
+#define FICL_BOOL(x) ((x) ? FICL_TRUE : FICL_FALSE)
+
+
+/*
+** A CELL is the main storage type. It must be large enough
+** to contain a pointer or a scalar. Let's be picky and make
+** a 32 bit cell explicitly...
+*/
+typedef union _cell
+{+ INT32 i;
+ UNS32 u;
+ void *p;
+} CELL;
+
+/*
+** LVALUEtoCELL does a little pointer trickery to cast any 32 bit
+** lvalue (informal definition: an expression whose result has an
+** address) to CELL. Remember that constants and casts are NOT
+** themselves lvalues!
+*/
+#define LVALUEtoCELL(v) (*(CELL *)&v)
+
+/*
+** PTRtoCELL is a cast through void * intended to satisfy the
+** most outrageously pedantic compiler... (I won't mention
+** its name)
+*/
+#define PTRtoCELL (CELL *)(void *)
+#define PTRtoSTRING (FICL_STRING *)(void *)
+
+/*
+** Strings in FICL are stored in Pascal style - with a count
+** preceding the text. We'll also NULL-terminate them so that
+** they work with the usual C lib string functions. (Belt &
+** suspenders? You decide.)
+** STRINGINFO hides the implementation with a couple of
+** macros for use in internal routines.
+*/
+
+typedef unsigned char FICL_COUNT;
+#define FICL_STRING_MAX UCHAR_MAX
+typedef struct _ficl_string
+{+ FICL_COUNT count;
+ char text[1];
+} FICL_STRING;
+
+typedef struct
+{+ UNS32 count;
+ char *cp;
+} STRINGINFO;
+
+#define SI_COUNT(si) (si.count)
+#define SI_PTR(si) (si.cp)
+#define SI_SETLEN(si, len) (si.count = (UNS32)(len))
+#define SI_SETPTR(si, ptr) (si.cp = (char *)(ptr))
+/*
+** Init a STRINGINFO from a pointer to NULL-terminated string
+*/
+#define SI_PSZ(si, psz) \
+ {si.cp = psz; si.count = (FICL_COUNT)strlen(psz);}+/*
+** Init a STRINGINFO from a pointer to FICL_STRING
+*/
+#define SI_PFS(si, pfs) \
+ {si.cp = pfs->text; si.count = pfs->count;}+
+/*
+** Ficl uses a this little structure to hold the address of
+** 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.
+*/
+typedef struct
+{+ INT32 index;
+ char *cp;
+} TIB;
+
+
+/*
+** Stacks get heavy use in Ficl and Forth...
+** Each virtual machine implements two of them:
+** one holds parameters (data), and the other holds return
+** addresses and control flow information for the virtual
+** machine. (Note: C's automatic stack is implicitly used,
+** but not modeled because it doesn't need to be...)
+** Here's an abstract type for a stack
+*/
+typedef struct _ficlStack
+{+ UNS32 nCells; /* size of the stack */
+ CELL *pFrame; /* link reg for stack frame */
+ CELL *sp; /* stack pointer */
+ CELL base[1]; /* Bottom of the stack */
+} FICL_STACK;
+
+/*
+** Stack methods... many map closely to required Forth words.
+*/
+FICL_STACK *stackCreate(unsigned nCells);
+void stackDelete(FICL_STACK *pStack);
+int stackDepth (FICL_STACK *pStack);
+void stackDrop (FICL_STACK *pStack, int n);
+CELL stackFetch (FICL_STACK *pStack, int n);
+CELL stackGetTop(FICL_STACK *pStack);
+void stackLink (FICL_STACK *pStack, int nCells);
+void stackPick (FICL_STACK *pStack, int n);
+CELL stackPop (FICL_STACK *pStack);
+void *stackPopPtr (FICL_STACK *pStack);
+UNS32 stackPopUNS32 (FICL_STACK *pStack);
+INT32 stackPopINT32 (FICL_STACK *pStack);
+void stackPush (FICL_STACK *pStack, CELL c);
+void stackPushPtr (FICL_STACK *pStack, void *ptr);
+void stackPushUNS32(FICL_STACK *pStack, UNS32 u);
+void stackPushINT32(FICL_STACK *pStack, INT32 i);
+void stackReset (FICL_STACK *pStack);
+void stackRoll (FICL_STACK *pStack, int n);
+void stackSetTop(FICL_STACK *pStack, CELL c);
+void stackStore (FICL_STACK *pStack, int n, CELL c);
+void stackUnlink(FICL_STACK *pStack);
+
+/*
+** The virtual machine (VM) contains the state for one interpreter.
+** Defined operations include:
+** Create & initialize
+** Delete
+** Execute a block of text
+** Parse a word out of the input stream
+** Call return, and branch
+** Text output
+** Throw an exception
+*/
+
+typedef struct ficl_word ** IPTYPE; /* the VM's instruction pointer */
+
+/*
+** Each VM has a placeholder for an output function -
+** this makes it possible to have each VM do I/O
+** through a different device. If you specify no
+** OUTFUNC, it defaults to ficlTextOut.
+*/
+typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline);
+
+/*
+** Each VM operates in one of two non-error states: interpreting
+** or compiling. When interpreting, words are simply executed.
+** When compiling, most words in the input stream have their
+** addresses inserted into the word under construction. Some words
+** (known as IMMEDIATE) are executed in the compile state, too.
+*/
+/* values of STATE */
+#define INTERPRET 0
+#define COMPILE 1
+
+/*
+** The pad is a small scratch area for text manipulation. ANS Forth
+** requires it to hold at least 84 characters.
+*/
+#if !defined nPAD
+#define nPAD 256
+#endif
+
+/*
+** ANS Forth requires that a word's name contain {1..31} characters.+*/
+#if !defined nFICLNAME
+#define nFICLNAME 31
+#endif
+
+/*
+** OK - now we can really define the VM...
+*/
+typedef struct vm
+{+ struct vm *link; /* Ficl keeps a VM list for simple teardown */
+ jmp_buf *pState; /* crude exception mechanism... */
+ OUTFUNC textOut; /* Output callback - see sysdep.c */
+ void * pExtend; /* vm extension pointer */
+ short fRestart; /* Set TRUE to restart runningWord */
+ IPTYPE ip; /* instruction pointer */
+ struct ficl_word
+ *runningWord;/* address of currently running word (often just *(ip-1) ) */
+ UNS32 state; /* compiling or interpreting */
+ UNS32 base; /* number conversion base */
+ FICL_STACK *pStack; /* param stack */
+ FICL_STACK *rStack; /* return stack */
+ INT32 sourceID; /* -1 if string, 0 if normal input */
+ TIB tib; /* address of incoming text string */
+#if FICL_WANT_USER
+ CELL user[FICL_USER_CELLS];
+#endif
+ char pad[nPAD]; /* the scratch area (see above) */
+} FICL_VM;
+
+/*
+** A FICL_CODE points to a function that gets called to help execute
+** a word in the dictionary. It always gets passed a pointer to the
+** running virtual machine, and from there it can get the address
+** of the parameter area of the word it's supposed to operate on.
+** For precompiled words, the code is all there is. For user defined
+** words, the code assumes that the word's parameter area is a list
+** of pointers to the code fields of other words to execute, and
+** may also contain inline data. The first parameter is always
+** a pointer to a code field.
+*/
+typedef void (*FICL_CODE)(FICL_VM *pVm);
+
+/*
+** Ficl models memory as a contiguous space divided into
+** words in a linked list called the dictionary.
+** A FICL_WORD starts each entry in the list.
+** Version 1.02: space for the name characters is allotted from
+** the dictionary ahead of the word struct - this saves about half
+** the storage on average with very little runtime cost.
+*/
+typedef struct ficl_word
+{+ struct ficl_word *link; /* Previous word in the dictionary */
+ UNS16 hash;
+ UNS8 flags; /* Immediate, Smudge, Compile-only */
+ FICL_COUNT nName; /* Number of chars in word name */
+ char *name; /* First nFICLNAME chars of word name */
+ FICL_CODE code; /* Native code to execute the word */
+ CELL param[1]; /* First data cell of the word */
+} FICL_WORD;
+
+/*
+** Worst-case size of a word header: nFICLNAME chars in name
+*/
+#define CELLS_PER_WORD \
+ ( (sizeof (FICL_WORD) + nFICLNAME + sizeof (CELL)) \
+ / (sizeof (CELL)) )
+
+int wordIsImmediate(FICL_WORD *pFW);
+int wordIsCompileOnly(FICL_WORD *pFW);
+
+/* flag values for word header */
+#define FW_IMMEDIATE 1 /* execute me even if compiling */
+#define FW_COMPILE 2 /* error if executed when not compiling */
+#define FW_SMUDGE 4 /* definition in progress - hide me */
+#define FW_CLASS 8 /* Word defines a class */
+
+#define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE)
+#define FW_DEFAULT 0
+
+
+/*
+** 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 */
+
+
+void vmBranchRelative(FICL_VM *pVM, int offset);
+FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack);
+void vmDelete (FICL_VM *pVM);
+void vmExecute(FICL_VM *pVM, FICL_WORD *pWord);
+char * vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter);
+STRINGINFO vmGetWord(FICL_VM *pVM);
+STRINGINFO vmGetWord0(FICL_VM *pVM);
+int vmGetWordToPad(FICL_VM *pVM);
+STRINGINFO vmParseString(FICL_VM *pVM, char delimiter);
+void vmPopIP (FICL_VM *pVM);
+void vmPushIP (FICL_VM *pVM, IPTYPE newIP);
+void vmQuit (FICL_VM *pVM);
+void vmReset (FICL_VM *pVM);
+void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut);
+void vmTextOut(FICL_VM *pVM, char *text, int fNewline);
+void vmThrow (FICL_VM *pVM, int except);
+void vmThrowErr(FICL_VM *pVM, char *fmt, ...);
+
+/*
+** vmCheckStack needs a vm pointer because it might have to say
+** something if it finds a problem. Parms popCells and pushCells
+** correspond to the number of parameters on the left and right of
+** a word's stack effect comment.
+*/
+void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
+
+/*
+** TIB access routines...
+** ANS forth seems to require the input buffer to be represented
+** as a pointer to the start of the buffer, and an index to the
+** next character to read.
+** PushTib points the VM to a new input string and optionally
+** returns a copy of the current state
+** 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 vmPopTib(FICL_VM *pVM, TIB *pTib);
+#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
+#define vmSetTibIndex(pVM, i) (pVM)->tib.index = i
+#define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp
+
+/*
+** Generally useful string manipulators omitted by ANSI C...
+** ltoa complements strtol
+*/
+#if defined(_WIN32) && !FICL_MAIN
+/* #SHEESH
+** Why do Microsoft Meatballs insist on contaminating
+** my namespace with their string functions???
+*/
+#pragma warning(disable: 4273)
+#endif
+
+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 *caseFold(char *cp);
+int strincmp(char *cp1, char *cp2, FICL_COUNT count);
+
+#if defined(_WIN32) && !FICL_MAIN
+#pragma warning(default: 4273)
+#endif
+
+/*
+** Ficl hash table - variable size.
+** assert(size > 0)
+** If size is 1, the table degenerates into a linked list.
+** A WORDLIST (see the search order word set in DPANS) is
+** just a pointer to a FICL_HASH in this implementation.
+*/
+#if !defined HASHSIZE /* Default size of hash table. For best */
+#define HASHSIZE 127 /* performance, use a prime number! */
+#endif
+
+typedef struct ficl_hash
+{+ struct ficl_hash *link; /* eventual inheritance support */
+ unsigned size;
+ FICL_WORD *table[1];
+} FICL_HASH;
+
+UNS16 hashHashCode(STRINGINFO si);
+void hashReset(FICL_HASH *pHash);
+void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW);
+FICL_WORD *hashLookup(struct ficl_hash *pHash,
+ STRINGINFO si,
+ UNS16 hashCode);
+
+/*
+** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's
+** memory model. Description of fields:
+**
+** here -- points to the next free byte in the dictionary. This
+** pointer is forced to be CELL-aligned before a definition is added.
+** Do not assume any specific alignment otherwise - Use dictAlign().
+**
+** smudge -- pointer to word currently being defined (or last defined word)
+** If the definition completes successfully, the word will be
+** linked into the hash table. If unsuccessful, dictUnsmudge
+** uses this pointer to restore the previous state of the dictionary.
+** Smudge prevents unintentional recursion as a side-effect: the
+** dictionary search algo examines only completed definitions, so a
+** word cannot invoke itself by name. See the ficl word "recurse".
+** NOTE: smudge always points to the last word defined. IMMEDIATE
+** makes use of this fact. Smudge is initially NULL.
+**
+** pForthWords -- pointer to the default wordlist (FICL_HASH).
+** This is the initial compilation list, and contains all
+** ficl's precompiled words.
+**
+** pCompile -- compilation wordlist - initially equal to pForthWords
+** pSearch -- array of pointers to wordlists. Managed as a stack.
+** Highest index is the first list in the search order.
+** nLists -- number of lists in pSearch. nLists-1 is the highest
+** filled slot in pSearch, and points to the first wordlist
+** in the search order
+** size -- number of cells in the dictionary (total)
+** dict -- start of data area. Must be at the end of the struct.
+*/
+typedef struct ficl_dict
+{+ CELL *here;
+ FICL_WORD *smudge;
+ FICL_HASH *pForthWords;
+ FICL_HASH *pCompile;
+ FICL_HASH *pSearch[FICL_DEFAULT_VOCS];
+ int nLists;
+ unsigned size; /* Number of cells in dict (total)*/
+ CELL dict[1]; /* Base of dictionary memory */
+} FICL_DICT;
+
+void *alignPtr(void *ptr);
+void dictAbortDefinition(FICL_DICT *pDict);
+void dictAlign(FICL_DICT *pDict);
+int dictAllot(FICL_DICT *pDict, int n);
+int dictAllotCells(FICL_DICT *pDict, int nCells);
+void dictAppendCell(FICL_DICT *pDict, CELL c);
+void dictAppendChar(FICL_DICT *pDict, char c);
+FICL_WORD *dictAppendWord(FICL_DICT *pDict,
+ char *name,
+ FICL_CODE pCode,
+ UNS8 flags);
+FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
+ STRINGINFO si,
+ FICL_CODE pCode,
+ UNS8 flags);
+void dictAppendUNS32(FICL_DICT *pDict, UNS32 u);
+int dictCellsAvail(FICL_DICT *pDict);
+int dictCellsUsed (FICL_DICT *pDict);
+void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells);
+FICL_DICT *dictCreate(unsigned nCELLS);
+FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash);
+void dictDelete(FICL_DICT *pDict);
+void dictEmpty(FICL_DICT *pDict, unsigned nHash);
+void dictHashSummary(FICL_VM *pVM);
+int dictIncludes(FICL_DICT *pDict, void *p);
+FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si);
+#if FICL_WANT_LOCALS
+FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si);
+#endif
+void dictResetSearchOrder(FICL_DICT *pDict);
+void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr);
+void dictSetImmediate(FICL_DICT *pDict);
+void dictUnsmudge(FICL_DICT *pDict);
+CELL *dictWhere(FICL_DICT *pDict);
+
+
+/*
+** External interface to FICL...
+*/
+/*
+** f i c l I n i t S y s t e m
+** Binds a global dictionary to the interpreter system and initializes
+** the dict to contain the ANSI CORE wordset.
+** You specify the address and size of the allocated area.
+** After that, ficl manages it.
+** First step is to set up the static pointers to the area.
+** Then write the "precompiled" portion of the dictionary in.
+** The dictionary needs to be at least large enough to hold the
+** precompiled part. Try 1K cells minimum. Use "words" to find
+** out how much of the dictionary is used at any time.
+*/
+void ficlInitSystem(int nDictCells);
+
+/*
+** f i c l T e r m S y s t e m
+** Deletes the system dictionary and all virtual machines that
+** were created with ficlNewVM (see below). Call this function to
+** reclaim all memory used by the dictionary and VMs.
+*/
+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
+** Execution returns when the text block has been executed,
+** or an error occurs.
+** Returns one of the VM_XXXX codes defined in ficl.h:
+** VM_OUTOFTEXT is the normal exit condition
+** VM_ERREXIT means that the interp encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** VM_USEREXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
+** Preconditions: successful execution of ficlInitSystem,
+** Successful creation and init of the VM by ficlNewVM (or equiv)
+*/
+int ficlExec(FICL_VM *pVM, char *pText);
+
+/*
+** Create a new VM from the heap, and link it into the system VM list.
+** Initializes the VM and binds default sized stacks to it. Returns the
+** address of the VM, or NULL if an error occurs.
+** Precondition: successful execution of ficlInitSystem
+*/
+FICL_VM *ficlNewVM(void);
+
+/*
+** Returns the address of the most recently defined word in the system
+** dictionary with the given name, or NULL if no match.
+** Precondition: successful execution of ficlInitSystem
+*/
+FICL_WORD *ficlLookup(char *name);
+
+/*
+** f i c l G e t D i c t
+** Utility function - returns the address of the system dictionary.
+** Precondition: successful execution of ficlInitSystem
+*/
+FICL_DICT *ficlGetDict(void);
+FICL_DICT *ficlGetEnv(void);
+void ficlSetEnv(char *name, UNS32 value);
+void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo);
+#if FICL_WANT_LOCALS
+FICL_DICT *ficlGetLoc(void);
+#endif
+/*
+** f i c l B u i l d
+** Builds a word into the system default dictionary in a thread-safe way.
+** Preconditions: system must be initialized, and there must
+** be enough space for the new word's header! Operation is
+** controlled by ficlLockDictionary, so any initialization
+** required by your version of the function (if you "overrode"
+** it) must be complete at this point.
+** Parameters:
+** name -- the name of the word to be built
+** code -- code to execute when the word is invoked - must take a single param
+** pointer to a FICL_VM
+** flags -- 0 or more of FW_IMMEDIATE, FW_COMPILE, use bitwise OR!
+** Most words can use FW_DEFAULT.
+** nAllot - number of extra cells to allocate in the parameter area (usually zero)
+*/
+int ficlBuild(char *name, FICL_CODE code, char flags);
+
+/*
+** f i c l C o m p i l e C o r e
+** Builds the ANS CORE wordset into the dictionary - called by
+** ficlInitSystem - no need to waste dict space by doing it again.
+*/
+void ficlCompileCore(FICL_DICT *dp);
+void ficlCompileSoftCore(FICL_VM *pVM);
+
+/*
+** from words.c...
+*/
+void constantParen(FICL_VM *pVM);
+void twoConstParen(FICL_VM *pVM);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __FICL_H__ */
--- /dev/null
+++ b/softwords/ficlclass.fr
@@ -1,0 +1,74 @@
+\ ** ficl/softwords/ficlclass.fr
+\ Classes to model ficl data structures in objects
+\ This is a demo!
+\ John Sadler 14 Sep 1998
+\
+\ ** C - W O R D
+\ Models a ficl word...
+
+object subclass c-word
+ c-word ref: .link
+ c-2byte obj: .hashcode
+ c-byte obj: .flags
+ c-byte obj: .nName
+ c-4byte obj: .pName
+ c-4byte obj: .pCode
+ c-4byte obj: .param0
+
+ \ Push word's name...
+ : get-name ( inst class -- c-addr u )
+ 2dup
+ --> .pName --> get -rot
+ --> .nName --> get
+ ;
+
+ : next ( inst class -- link-inst class )
+ --> .link ;
+
+ : info
+ ." ficl word: "
+ 2dup --> get-name type cr
+ ." hash = "
+ 2dup --> .hashcode --> get x. cr
+ ." flags = "
+ --> .flags --> get x. cr
+ ;
+
+end-class
+
+\ ** C - W O R D L I S T
+\ Example of use:
+\ get-current c-wordlist --> ref current
+\ current --> info
+\ current --> .hash --> info
+\ current --> .hash --> next --> info
+
+object subclass c-wordlist
+ c-wordlist ref: .parent
+ c-4byte obj: .size
+ c-word ref: .hash
+
+ : info
+ 2drop ." ficl wordlist " cr ;
+ : push drop >search ;
+ : pop 2drop previous ;
+ : set-current drop set-current ;
+ : words --> push words previous ;
+end-class
+
+: named-wid wordlist postpone c-wordlist metaclass => ref ;
+
+
+\ ** C - F I C L S T A C K
+object subclass c-ficlstack
+ c-4byte obj: .nCells
+ c-cellPtr obj: .link
+ c-cellPtr obj: .sp
+ c-4byte obj: .stackBase
+
+ : init 2drop ;
+ : info 2drop
+ ." ficl stack " cr ;
+ : top
+ --> .sp --> .addr --> prev --> get ;
+end-class
--- /dev/null
+++ b/softwords/oo.fr
@@ -1,0 +1,454 @@
+\ ** ficl/softwords/oo.fr
+\ ** F I C L O - O E X T E N S I O N S
+\ ** john sadler aug 1998
+
+.( loading ficl O-O extensions ) cr
+vocabulary oop
+also oop definitions
+
+\ Design goals:
+\ 0. Traditional OOP: late binding by default for safety.
+\ Early binding if you ask for it.
+\ 1. Single inheritance
+\ 2. Object aggregation (has-a relationship)
+\ 3. Support objects in the dictionary and as proxies for
+\ existing structures (by reference):
+\ *** A ficl object can wrap a C struct ***
+\ 4. Separate name-spaces for methods - methods are
+\ only visible in the context of a class / object
+\ 5. Methods can be overridden, and subclasses can add methods.
+\ No limit on number of methods.
+
+\ General info:
+\ Classes are objects, too: all classes are instances of METACLASS
+\ All classes are derived (by convention) from OBJECT. This
+\ base class provides a default initializer and superclass
+\ access method
+
+\ A ficl object binds instance storage (payload) to a class.
+\ object ( -- instance class )
+\ All objects push their payload address and class address when
+\ executed. All objects have this footprint:
+\ cell 0: first payload cell
+
+\ A ficl class consists of a parent class pointer, a wordlist
+\ ID for the methods of the class, and a size for the payload
+\ of objects created by the class. A class is an object.
+\ The NEW method creates and initializes an instance of a class.
+\ Classes have this footprint:
+\ cell 0: parent class address
+\ cell 1: wordlist ID
+\ cell 2: size of instance's payload
+
+\ Methods expect an object couple ( instance class )
+\ on the stack.
+\ Overridden methods must maintain the same stack signature as
+\ their predecessors. Ficl has no way of enforcing this, though.
+
+user current-class
+0 current-class !
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** L A T E B I N D I N G
+\ Compile the method name, and code to find and
+\ execute it at run-time...
+\ parse-method compiles the method name so that it pushes
+\ the string base address and count at run-time.
+\
+: parse-method \ name run: ( -- c-addr u )
+ parse-word
+ postpone sliteral
+; compile-only
+
+: lookup-method ( class c-addr u -- class xt )
+ 2dup
+ local u
+ local c-addr
+ end-locals
+ 2 pick cell+ @ ( -- class c-addr u wid )
+ search-wordlist ( -- class 0 | xt 1 | xt -1 )
+ 0= if
+ ." Method <" c-addr u type ." > not found" cr abort
+ endif
+;
+
+: exec-method ( instance class c-addr u -- <method-signature> )
+ lookup-method execute
+;
+
+: find-method-xt \ name ( class -- class xt )
+ parse-word lookup-method
+;
+
+
+\ Method lookup operator takes a class-addr and instance-addr
+\ and executes the method from the class's wordlist if
+\ interpreting. If compiling, bind late.
+\
+: --> ( instance class -- ??? )
+ state @ 0= if
+ find-method-xt execute
+ else
+ parse-method postpone exec-method
+ endif
+; immediate
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** E A R L Y B I N D I N G
+\ Early binding operator compiles code to execute a method
+\ given its class at compile time. Classes are immediate,
+\ so they leave their cell-pair on the stack when compiling.
+\ Example:
+\ : get-wid metaclass => .wid @ ;
+\ Usage
+\ my-class get-wid ( -- wid-of-my-class )
+\
+: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
+ drop find-method-xt , drop
+; immediate compile-only
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** I N S T A N C E V A R I A B L E S
+\ Instance variables (IV) are represented by words in the class's
+\ private wordlist. Each IV word contains the offset
+\ of the IV it represents, and runs code to add that offset
+\ to the base address of an instance when executed.
+\ The metaclass SUB method, defined below, leaves the address
+\ of the new class's offset field and its initial size on the
+\ stack for these words to update. When a class definition is
+\ complete, END-CLASS saves the final size in the class's size
+\ field, and restores the search order and compile wordlist to
+\ prior state. Note that these words are hidden in their own
+\ wordlist to prevent accidental use outside a SUB END-CLASS pair.
+\
+wordlist
+dup constant instance-vars
+dup >search ficl-set-current
+: do-instance-var
+ does> ( instance class addr[offset] -- addr[field] )
+ nip @ +
+;
+
+: addr-units: ( offset size "name" -- offset' )
+ create over , +
+ do-instance-var
+;
+
+: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
+ chars addr-units: ;
+
+: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
+ 1 chars: ;
+
+: cells: ( offset nCells "name" -- offset' )
+ cells >r aligned r> addr-units:
+;
+
+: cell: ( offset nCells "name" -- offset' )
+ 1 cells: ;
+
+\ Aggregate an object into the class...
+\ Needs the class of the instance to create
+\ Example: object obj: m_obj
+\
+: do-aggregate
+ does> ( instance class pfa -- a-instance a-class )
+ 2@ ( inst class a-class a-offset )
+ 2swap drop ( a-class a-offset inst )
+ + swap ( a-inst a-class )
+;
+
+: obj: ( offset class meta "name" -- offset' )
+ locals| meta class offset |
+ create offset , class ,
+ class meta --> get-size offset +
+ do-aggregate
+;
+
+\ Aggregate an array of objects into a class
+\ Usage example:
+\ 3 my-class array: my-array
+\ Makes an instance variable array of 3 instances of my-class
+\ named my-array.
+\
+: array: ( offset n class meta "name" -- offset' )
+ locals| meta class nobjs offset |
+ create offset , class ,
+ class meta --> get-size nobjs * offset +
+ do-aggregate
+;
+
+\ Aggregate a pointer to an object: REF is a member variable
+\ whose class is set at compile time. This is useful for wrapping
+\ data structures in C, where there is only a pointer and the type
+\ it refers to is known. If you want polymorphism, see c_ref
+\ in classes.fr. REF is only useful for pre-initialized structures,
+\ since there's no supported way to set one.
+: ref: ( offset class meta "name" -- offset' )
+ locals| meta class offset |
+ create offset , class ,
+ offset cell+
+ does> ( inst class pfa -- ptr-inst ptr-class )
+ 2@ ( inst class ptr-class ptr-offset )
+ 2swap drop + @ swap
+;
+
+\ END-CLASS terminates construction of a class by storing
+\ the size of its instance variables in the class's size field
+\ ( -- old-wid addr[size] 0 )
+\
+: end-class ( old-wid addr[size] size -- )
+ swap ! set-current
+ search> drop \ pop struct builder wordlist
+;
+
+set-current previous
+\ E N D I N S T A N C E V A R I A B L E S
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ D O - D O - I N S T A N C E
+\ Makes a class method that contains the code for an
+\ 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
+\
+: do-do-instance \ c:( -- ) r: ( -- )
+ s" : .do-instance does> [ current-class @ ] literal ;" evaluate
+;
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** M E T A C L A S S
+\ Every class is an instance of metaclass. This lets
+\ classes have methods that are different from those
+\ of their instances.
+\ Classes are IMMEDIATE to make early binding simpler
+\ See above...
+\
+: meta-class
+ wordlist
+ create immediate
+ 0 , \ NULL parent class
+ dup , \ wid
+ 3 cells , \ instance size
+ ficl-set-current
+ does> dup
+;
+
+meta-class metaclass
+
+metaclass drop current-class !
+do-do-instance
+
+\
+\ C L A S S M E T H O D S
+\
+instance-vars >search
+
+create .super ( class metaclass -- parent-class )
+ 0 cells , do-instance-var
+
+create .wid ( class metaclass -- wid ) \ return wid of class
+ 1 cells , do-instance-var
+
+create .size ( class metaclass -- size ) \ return class's payload size
+ 2 cells , do-instance-var
+
+previous
+
+: get-size metaclass => .size @ ;
+: get-wid metaclass => .wid @ ;
+: get-super metaclass => .super @ ;
+
+\ create an uninitialized instance of a class, leaving
+\ the address of the new instance and its class
+\
+: instance ( class metaclass "name" -- instance class )
+ locals| meta parent |
+ create
+ here parent --> .do-instance \ ( inst class )
+ parent meta --> get-size
+ allot \ allocate payload space
+;
+
+\ create an uninitialized array
+: array ( n class metaclass "name" -- n instance class )
+ locals| meta parent nobj |
+ create nobj
+ here parent --> .do-instance \ ( nobj inst class )
+ parent meta --> get-size
+ nobj * allot \ allocate payload space
+;
+
+\ create an initialized instance
+\
+: new \ ( class metaclass "name" -- )
+ metaclass => instance --> init
+;
+
+\ create an initialized array of instances
+: new-array ( n class metaclass "name" -- )
+ --> array
+ --> array-init
+;
+
+\ create a proxy object with initialized payload address given
+: ref ( instance-addr class metaclass "name" -- )
+ drop create , ,
+ does> 2@
+;
+
+\ create a subclass
+: sub ( class metaclass "name" -- old-wid addr[size] size )
+ wordlist
+ locals| wid meta parent |
+ parent meta metaclass => get-wid
+ wid wid-set-super
+ create immediate
+ here current-class ! \ prep for do-do-instance
+ parent , \ save parent class
+ wid , \ save wid
+ here parent meta --> get-size dup , ( addr[size] size )
+ metaclass => .do-instance
+ wid ficl-set-current rot rot
+ do-do-instance
+ instance-vars >search \ push struct builder wordlist
+;
+
+\ OFFSET-OF returns the offset of an instance variable
+\ from the instance base address. If the next token is not
+\ the name of in instance variable method, you get garbage
+\ results -- there is no way at present to check for this error.
+: offset-of ( class metaclass "name" -- offset )
+ drop find-method-xt nip >body @ ;
+
+\ ID returns the string name cell-pair of its class
+: id ( class metaclass -- c-addr u )
+ drop body> >name ;
+
+\ list methods of the class
+: methods \ ( class meta -- )
+ locals| meta class |
+ begin
+ class body> >name type ." methods:" cr
+ class meta --> get-wid >search words cr previous
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
+;
+
+\ list class's ancestors
+: pedigree ( class meta -- )
+ locals| meta class |
+ begin
+ class body> >name type space
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
+;
+
+\ decompile a method
+: see ( class meta -- )
+ --> get-wid >search see previous ;
+
+set-current
+\ E N D M E T A C L A S S
+
+
+\ SUBCLASS is a nickname for a class's SUB method...
+\ Subclass compilation ends when you invoke end-class
+\ This method is late bound for safety...
+: subclass --> sub ;
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** O B J E C T
+\ Root of all classes
+: root-class
+ wordlist
+ create immediate
+ 0 , \ NULL parent class
+ dup , \ wid
+ 0 , \ instance size
+ ficl-set-current
+ does> [ metaclass drop ] literal
+;
+
+root-class object
+
+object drop current-class !
+do-do-instance
+
+\ O B J E C T M E T H O D S
+\ default INIT method zero fills an instance
+: init ( instance class -- )
+ over swap ( inst inst class )
+ --> size 0 fill ;
+
+\ Apply INIT to an array of NOBJ objects...
+\
+: array-init ( nobj inst class -- )
+ 0 dup locals| &init &next class inst |
+ \
+ \ bind methods outside the loop to save time
+ \
+ class s" init" lookup-method to &init
+ s" next" lookup-method to &next
+ drop
+ 0 ?do
+ inst class 2dup
+ &init execute
+ &next execute drop to inst
+ loop
+;
+
+\ Convert object cell-pair to class cell-pair
+: class ( instance class -- class metaclass )
+ nip [ metaclass nip ] literal
+;
+
+\ Instance aliases for common class methods
+\ Upcast to parent class
+: super ( instance class -- instance parent-class )
+ dup --> class --> get-super ;
+
+: pedigree ( instance class -- )
+ --> class --> pedigree ;
+
+: size ( instance class -- sizeof-instance )
+ --> class --> get-size ;
+
+: methods ( instance class -- )
+ --> class --> methods ;
+
+\ Array indexing methods...
+\ Usage examples:
+\ 10 object-array --> index
+\ obj --> next
+\
+: index ( n instance class -- instance[n] class )
+ locals| class inst |
+ inst class --> class
+ metaclass => get-size * ( n*size )
+ inst + class ;
+
+: next ( instance[n] class -- instance[n+1] class )
+ locals| class inst |
+ inst class --> class
+ metaclass => get-size
+ inst +
+ class ;
+
+: prev ( instance[n] class -- instance[n-1] class )
+ locals| class inst |
+ inst class --> class
+ metaclass => get-size
+ inst swap -
+ class ;
+
+set-current
+\ E N D O B J E C T
+
+
--- /dev/null
+++ b/softwords/softcore.fr
@@ -1,0 +1,117 @@
+\ ** softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+\ ** CORE
+: abs ( x -- x )
+ dup 0< if negate endif ;
+decimal 32 constant bl
+
+: space ( -- ) bl emit ;
+
+: spaces ( n -- ) 0 ?do space loop ;
+
+: abort"
+ postpone if
+ postpone ."
+ postpone cr
+ postpone abort
+ postpone endif
+; immediate
+
+
+\ ** CORE EXT
+0 constant false
+-1 constant true
+: <> = invert ;
+: 0<> 0= invert ;
+: compile, , ;
+: erase ( addr u -- ) 0 fill ;
+: nip ( y x -- x ) swap drop ;
+: tuck ( y x -- x y x) swap over ;
+
+\ ** LOCAL EXT word set
+\ #if FICL_WANT_LOCALS
+: locals| ( name...name | -- )
+ begin
+ bl word count
+ dup 0= abort" where's the delimiter??"
+ over c@
+ [char] | - over 1- or
+ while
+ (local)
+ repeat 2drop 0 0 (local)
+; immediate
+
+: local ( name -- ) bl word count (local) ; immediate
+
+: end-locals ( -- ) 0 0 (local) ; immediate
+
+\ #endif
+
+\ ** TOOLS word set...
+: ? ( addr -- ) @ . ;
+: dump ( addr u -- )
+ 0 ?do
+ dup c@ . 1+
+ i 7 and 7 = if cr endif
+ loop drop
+;
+
+\ ** SEARCH EXT words and ficl helpers
+\
+\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
+\ When executed, new voc replaces top of search stack
+: do-vocabulary ( -- )
+ does> @ search> drop >search ;
+
+: vocabulary ( name -- )
+ wordlist create , do-vocabulary ;
+
+\ ALSO dups the search stack...
+: also ( -- )
+ search> dup >search >search ;
+
+\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
+: forth ( -- )
+ search> drop
+ forth-wordlist >search ;
+
+\ ONLY sets the search order to a default state
+: only ( -- )
+ -1 set-order ;
+
+\ ORDER displays the compile wid and the search order list
+: order ( -- )
+ ." Search: "
+ get-order 0 ?do x. loop cr
+ ." Compile: " get-current x. cr ;
+
+\ PREVIOUS drops the search order stack
+: previous ( -- ) search> drop ;
+
+\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
+: ficl-set-current ( wid -- old-wid )
+ get-current swap set-current ;
+
+
+\ ** Ficl USER variables
+\ ** See words.c for primitive def'n of USER
+\ #if FICL_WANT_USER
+
+variable nUser 0 nUser !
+: user \ name ( -- )
+ nUser dup @ user 1 swap +! ;
+
+\ #endif
+
+\ ** ficl extras
+\ EMPTY cleans the parameter stack
+: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
+\ CELL- undoes CELL+
+: cell- ( addr -- addr ) [ 1 cells ] literal - ;
+: -rot ( a b c -- c a b ) 2 -roll ;
+
+\ ** E N D S O F T C O R E . F R
+
--- /dev/null
+++ b/testmain.c
@@ -1,0 +1,293 @@
+/*
+** stub main for testing FICL under Win32
+**
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#ifdef WIN32
+#include <direct.h>
+#endif
+#include <sys/types.h>
+#include <sys/stat.h>
+#ifdef linux
+#include <unistd.h>
+#endif
+
+#include "ficl.h"
+
+/*
+** Ficl interface to _getcwd (Win32)
+** Prints the current working directory using the VM's
+** textOut method...
+*/
+static void ficlGetCWD(FICL_VM *pVM)
+{+ char *cp;
+
+#ifdef WIN32
+ cp = _getcwd(NULL, 80);
+#else
+ cp = getcwd(NULL, 80);
+#endif
+ vmTextOut(pVM, cp, 1);
+ free(cp);
+ return;
+}
+
+/*
+** Ficl interface to _chdir (Win32)
+** Gets a newline (or NULL) delimited string from the input
+** and feeds it to the Win32 chdir function...
+** Example:
+** cd c:\tmp
+*/
+static void ficlChDir(FICL_VM *pVM)
+{+ FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
+ vmGetString(pVM, pFS, '\n');
+ if (pFS->count > 0)
+ {+#ifdef WIN32
+ int err = _chdir(pFS->text);
+#else
+ int err = chdir(pFS->text);
+#endif
+ if (err)
+ {+ vmTextOut(pVM, "Error: path not found", 1);
+ vmThrow(pVM, VM_QUIT);
+ }
+ }
+ else
+ {+ vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
+ }
+ return;
+}
+
+/*
+** Ficl interface to system (ANSI)
+** Gets a newline (or NULL) delimited string from the input
+** and feeds it to the Win32 system function...
+** Example:
+** system del *.*
+** \ ouch!
+*/
+static void ficlSystem(FICL_VM *pVM)
+{+ FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
+
+ vmGetString(pVM, pFS, '\n');
+ if (pFS->count > 0)
+ {+ int err = system(pFS->text);
+ if (err)
+ {+ sprintf(pVM->pad, "System call returned %d", err);
+ vmTextOut(pVM, pVM->pad, 1);
+ vmThrow(pVM, VM_QUIT);
+ }
+ }
+ else
+ {+ vmTextOut(pVM, "Warning (system): nothing happened", 1);
+ }
+ return;
+}
+
+/*
+** Ficl add-in to load a text file and execute it...
+** Cheesy, but illustrative.
+** Line oriented... filename is newline (or NULL) delimited.
+** Example:
+** load test.ficl
+*/
+#define nLINEBUF 256
+static void ficlLoad(FICL_VM *pVM)
+{+ char cp[nLINEBUF];
+ char filename[nLINEBUF];
+ FICL_STRING *pFilename = (FICL_STRING *)filename;
+ int nLine = 0;
+ FILE *fp;
+ int result;
+ UNS32 id;
+#ifdef WIN32
+ struct _stat buf;
+#else
+ struct stat buf;
+#endif
+
+
+ vmGetString(pVM, pFilename, '\n');
+
+ if (pFilename->count <= 0)
+ {+ vmTextOut(pVM, "Warning (load): nothing happened", 1);
+ return;
+ }
+
+ /*
+ ** get the file's size and make sure it exists
+ */
+#ifdef WIN32
+ result = _stat( pFilename->text, &buf );
+#else
+ result = stat( pFilename->text, &buf );
+#endif
+
+ if (result != 0)
+ {+ vmTextOut(pVM, "Unable to stat file: ", 0);
+ vmTextOut(pVM, pFilename->text, 1);
+ vmThrow(pVM, VM_QUIT);
+ }
+
+ fp = fopen(pFilename->text, "r");
+ if (!fp)
+ {+ vmTextOut(pVM, "Unable to open file ", 0);
+ vmTextOut(pVM, pFilename->text, 1);
+ vmThrow(pVM, VM_QUIT);
+ }
+
+ id = pVM->sourceID;
+ pVM->sourceID = -1;
+
+ /* feed each line to ficlExec */
+ while (fgets(cp, nLINEBUF, fp))
+ {+ int len = strlen(cp) - 1;
+
+ nLine++;
+ if (len <= 0)
+ continue;
+
+ if (cp[len] == '\n')
+ cp[len] = '\0';
+
+ result = ficlExec(pVM, cp);
+ if (result >= VM_ERREXIT)
+ {+ pVM->sourceID = id;
+ fclose(fp);
+ vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
+ break;
+ }
+ }
+
+ pVM->sourceID = id;
+ fclose(fp);
+
+ return;
+}
+
+/*
+** Dump a tab delimited file that summarizes the contents of the
+** dictionary hash table by hashcode...
+*/
+static void spewHash(FICL_VM *pVM)
+{+ FICL_HASH *pHash = ficlGetDict()->pForthWords;
+ FICL_WORD *pFW;
+ FILE *pOut;
+ unsigned i;
+ unsigned nHash = pHash->size;
+
+ if (!vmGetWordToPad(pVM))
+ vmThrow(pVM, VM_OUTOFTEXT);
+
+ pOut = fopen(pVM->pad, "w");
+ if (!pOut)
+ {+ vmTextOut(pVM, "unable to open file", 1);
+ return;
+ }
+
+ for (i=0; i < nHash; i++)
+ {+ int n = 0;
+
+ pFW = pHash->table[i];
+ while (pFW)
+ {+ n++;
+ pFW = pFW->link;
+ }
+
+ fprintf(pOut, "%d\t%d", i, n);
+
+ pFW = pHash->table[i];
+ while (pFW)
+ {+ fprintf(pOut, "\t%s", pFW->name);
+ pFW = pFW->link;
+ }
+
+ fprintf(pOut, "\n");
+ }
+
+ fclose(pOut);
+ return;
+}
+
+static void ficlBreak(FICL_VM *pVM)
+{+ pVM->state = pVM->state;
+ return;
+}
+
+void buildTestInterface(void)
+{+ ficlBuild("break", ficlBreak, FW_DEFAULT);+ ficlBuild("cd", ficlChDir, FW_DEFAULT);+ ficlBuild("load", ficlLoad, FW_DEFAULT);+ ficlBuild("pwd", ficlGetCWD, FW_DEFAULT);+ ficlBuild("system", ficlSystem, FW_DEFAULT);+ ficlBuild("spewhash", spewHash, FW_DEFAULT);+
+ return;
+}
+
+
+#if !defined (_WINDOWS)
+
+int main(int argc, char **argv)
+{+ char in[256];
+ FICL_VM *pVM;
+
+ ficlInitSystem(10000);
+ pVM = ficlNewVM();
+
+ buildTestInterface();
+ ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
+
+ /*
+ ** load file from cmd line...
+ */
+ if (argc > 1)
+ {+ sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
+ ficlExec(pVM, in);
+ }
+
+ for (;;)
+ {+ int ret;
+ gets(in);
+ ret = ficlExec(pVM, in);
+ if (ret == VM_USEREXIT)
+ {+ ficlTermSystem();
+ break;
+ }
+ }
+
+ return 0;
+}
+
+#endif
+
--- /dev/null
+++ b/vm.c
@@ -1,0 +1,561 @@
+/*******************************************************************
+** v m . c
+** Forth Inspired Command Language - virtual machine methods
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+**
+*******************************************************************/
+/*
+** This file implements the virtual machine of FICL. Each virtual
+** machine retains the state of an interpreter. A virtual machine
+** owns a pair of stacks for parameters and return addresses, as
+** well as a pile of state variables and the two dedicated registers
+** of the interp.
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+
+static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+
+/**************************************************************************
+ v m B r a n c h R e l a t i v e
+**
+**************************************************************************/
+void vmBranchRelative(FICL_VM *pVM, int offset)
+{+ pVM->ip += offset;
+ return;
+}
+
+
+/**************************************************************************
+ v m C r e a t e
+**
+**************************************************************************/
+FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
+{+ if (pVM == NULL)
+ {+ pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
+ pVM->pStack = NULL;
+ pVM->rStack = NULL;
+ pVM->link = NULL;
+ }
+ assert (pVM);
+
+ if (pVM->pStack)
+ stackDelete(pVM->pStack);
+ pVM->pStack = stackCreate(nPStack);
+
+ if (pVM->rStack)
+ stackDelete(pVM->rStack);
+ pVM->rStack = stackCreate(nRStack);
+
+ pVM->textOut = ficlTextOut;
+
+ vmReset(pVM);
+ return pVM;
+}
+
+
+/**************************************************************************
+ v m D e l e t e
+**
+**************************************************************************/
+void vmDelete (FICL_VM *pVM)
+{+ if (pVM)
+ {+ ficlFree(pVM->pStack);
+ ficlFree(pVM->rStack);
+ ficlFree(pVM);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ v m E x e c u t e
+**
+**************************************************************************/
+void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
+{+ pVM->runningWord = pWord;
+ pWord->code(pVM);
+ return;
+}
+
+
+/**************************************************************************
+ 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
+** FICL_STRING_MAX characters to the supplied destination buffer, a
+** FICL_STRING. The destination string is NULL terminated.
+**
+** Returns the address of the first unused character in the dest buffer.
+**************************************************************************/
+char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
+{+ STRINGINFO si = vmParseString(pVM, delimiter);
+
+ if (SI_COUNT(si) > FICL_STRING_MAX)
+ {+ SI_SETLEN(si, FICL_STRING_MAX);
+ }
+
+ strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
+ spDest->text[SI_COUNT(si)] = '\0';
+ spDest->count = (FICL_COUNT)SI_COUNT(si);
+
+ return spDest->text + SI_COUNT(si) + 1;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d
+** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
+** non-zero length.
+**************************************************************************/
+STRINGINFO vmGetWord(FICL_VM *pVM)
+{+ STRINGINFO si = vmGetWord0(pVM);
+
+ if (SI_COUNT(si) == 0)
+ {+ vmThrow(pVM, VM_RESTART);
+ }
+
+ return si;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d 0
+** Skip leading whitespace and parse a space delimited word from the tib.
+** Returns the start address and length of the word. Updates the tib
+** to reflect characters consumed, including the trailing delimiter.
+** If there's nothing of interest in the tib, returns zero. This function
+** does not use vmParseString because it uses isspace() rather than a
+** single delimiter character.
+**************************************************************************/
+STRINGINFO vmGetWord0(FICL_VM *pVM)
+{+ char *pSrc = vmGetInBuf(pVM);
+ STRINGINFO si;
+ UNS32 count = 0;
+ char ch;
+
+ pSrc = skipSpace(pSrc);
+ SI_SETPTR(si, pSrc);
+
+ for (ch = *pSrc; ch != '\0' && !isspace(ch); ch = *++pSrc)
+ {+ count++;
+ }
+
+ SI_SETLEN(si, count);
+
+ if (isspace(ch)) /* skip one trailing delimiter */
+ pSrc++;
+
+ vmUpdateTib(pVM, pSrc);
+
+ return si;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d T o P a d
+** Does vmGetWord0 and copies the result to the pad as a NULL terminated
+** string. Returns the length of the string. If the string is too long
+** to fit in the pad, it is truncated.
+**************************************************************************/
+int vmGetWordToPad(FICL_VM *pVM)
+{+ STRINGINFO si;
+ char *cp = (char *)pVM->pad;
+ si = vmGetWord0(pVM);
+
+ if (SI_COUNT(si) > nPAD)
+ SI_SETLEN(si, nPAD);
+
+ strncpy(cp, SI_PTR(si), SI_COUNT(si));
+ cp[SI_COUNT(si)] = '\0';
+ return (int)(SI_COUNT(si));
+}
+
+
+/**************************************************************************
+ v m P a r s e S t r i n g
+** Parses a string out of the input buffer using the delimiter
+** specified. Skips leading delimiters, marks the start of the string,
+** and counts characters to the next delimiter it encounters. It then
+** updates the vm input buffer to consume all these chars, including the
+** trailing delimiter.
+** Returns the address and length of the parsed string, not including the
+** trailing delimiter.
+**************************************************************************/
+STRINGINFO vmParseString(FICL_VM *pVM, char delim)
+{+ STRINGINFO si;
+ char *pSrc = vmGetInBuf(pVM);
+ char ch;
+
+ while (*pSrc == delim) /* skip lead delimiters */
+ pSrc++;
+
+ SI_SETPTR(si, pSrc); /* mark start of text */
+
+ for (ch = *pSrc; (ch != delim)
+ && (ch != '\0')
+ && (ch != '\r')
+ && (ch != '\n'); ch = *++pSrc)
+ {+ ; /* find next delimiter or end of line */
+ }
+
+ /* set length of result */
+ SI_SETLEN(si, pSrc - SI_PTR(si));
+
+ if (*pSrc == delim) /* gobble trailing delimiter */
+ pSrc++;
+
+ vmUpdateTib(pVM, pSrc);
+ return si;
+}
+
+
+/**************************************************************************
+ v m P o p I P
+**
+**************************************************************************/
+void vmPopIP(FICL_VM *pVM)
+{+ pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
+ return;
+}
+
+
+/**************************************************************************
+ v m P u s h I P
+**
+**************************************************************************/
+void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
+{+ stackPushPtr(pVM->rStack, (void *)pVM->ip);
+ pVM->ip = newIP;
+ return;
+}
+
+
+/**************************************************************************
+ 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)
+{+ if (pSaveTib)
+ {+ *pSaveTib = pVM->tib;
+ }
+
+ pVM->tib.cp = text;
+ pVM->tib.index = 0;
+}
+
+
+void vmPopTib(FICL_VM *pVM, TIB *pTib)
+{+ if (pTib)
+ {+ pVM->tib = *pTib;
+ }
+ return;
+}
+
+
+/**************************************************************************
+ v m Q u i t
+**
+**************************************************************************/
+void vmQuit(FICL_VM *pVM)
+{+ static FICL_WORD *pInterp = NULL;
+ if (!pInterp)
+ pInterp = ficlLookup("interpret");+ assert(pInterp);
+
+ stackReset(pVM->rStack);
+ pVM->fRestart = 0;
+ pVM->ip = &pInterp;
+ pVM->runningWord = pInterp;
+ pVM->state = INTERPRET;
+ pVM->tib.cp = NULL;
+ pVM->tib.index = 0;
+ pVM->pad[0] = '\0';
+ pVM->sourceID = 0;
+ return;
+}
+
+
+/**************************************************************************
+ v m R e s e t
+**
+**************************************************************************/
+void vmReset(FICL_VM *pVM)
+{+ vmQuit(pVM);
+ stackReset(pVM->pStack);
+ pVM->base = 10;
+ return;
+}
+
+
+/**************************************************************************
+ v m S e t T e x t O u t
+** Binds the specified output callback to the vm. If you pass NULL,
+** binds the default output function (ficlTextOut)
+**************************************************************************/
+void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut)
+{+ if (textOut)
+ pVM->textOut = textOut;
+ else
+ pVM->textOut = ficlTextOut;
+
+ return;
+}
+
+
+/**************************************************************************
+ v m T e x t O u t
+** Feeds text to the vm's output callback
+**************************************************************************/
+void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
+{+ assert(pVM);
+ assert(pVM->textOut);
+ (pVM->textOut)(pVM, text, fNewline);
+
+ return;
+}
+
+
+/**************************************************************************
+ v m T h r o w
+**
+**************************************************************************/
+void vmThrow(FICL_VM *pVM, int except)
+{+ longjmp(*(pVM->pState), except);
+}
+
+
+void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
+{+ va_list va;
+ va_start(va, fmt);
+ vsprintf(pVM->pad, fmt, va);
+ vmTextOut(pVM, pVM->pad, 1);
+ va_end(va);
+ longjmp(*(pVM->pState), VM_ERREXIT);
+}
+
+
+/**************************************************************************
+ w o r d I s I m m e d i a t e
+**
+**************************************************************************/
+int wordIsImmediate(FICL_WORD *pFW)
+{+ return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
+}
+
+
+/**************************************************************************
+ w o r d I s C o m p i l e O n l y
+**
+**************************************************************************/
+int wordIsCompileOnly(FICL_WORD *pFW)
+{+ return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
+}
+
+
+/**************************************************************************
+ s t r r e v
+**
+**************************************************************************/
+char *strrev( char *string )
+{ /* reverse a string in-place */+ int i = strlen(string);
+ char *p1 = string; /* first char of string */
+ char *p2 = string + i - 1; /* last non-NULL char of string */
+ char c;
+
+ if (i > 1)
+ {+ while (p1 < p2)
+ {+ c = *p2;
+ *p2 = *p1;
+ *p1 = c;
+ p1++; p2--;
+ }
+ }
+
+ return string;
+}
+
+
+/**************************************************************************
+ d i g i t _ t o _ c h a r
+**
+**************************************************************************/
+char digit_to_char(int value)
+{+ return digits[value];
+}
+
+
+/**************************************************************************
+ l t o a
+**
+**************************************************************************/
+char *ltoa( INT32 value, char *string, int radix )
+{ /* convert long to string, any base */+ char *cp = string;
+ int sign = ((radix == 10) && (value < 0));
+ UNSQR result;
+ UNS64 v;
+
+ assert(radix > 1);
+ assert(radix < 37);
+ assert(string);
+
+ if (sign)
+ value = -value;
+
+ if (value == 0)
+ *cp++ = '0';
+ else
+ {+ v.hi = 0;
+ v.lo = (UNS32)value;
+ while (v.lo)
+ {+ result = ficlLongDiv(v, (UNS32)radix);
+ *cp++ = digits[result.rem];
+ v.lo = result.quot;
+ }
+ }
+
+ if (sign)
+ *cp++ = '-';
+
+ *cp++ = '\0';
+
+ return strrev(string);
+}
+
+
+/**************************************************************************
+ u l t o a
+**
+**************************************************************************/
+char *ultoa(UNS32 value, char *string, int radix )
+{ /* convert long to string, any base */+ char *cp = string;
+ UNS64 ud;
+ UNSQR result;
+
+ assert(radix > 1);
+ assert(radix < 37);
+ assert(string);
+
+ if (value == 0)
+ *cp++ = '0';
+ else
+ {+ ud.hi = 0;
+ ud.lo = value;
+ result.quot = value;
+
+ while (ud.lo)
+ {+ result = ficlLongDiv(ud, (UNS32)radix);
+ ud.lo = result.quot;
+ *cp++ = digits[result.rem];
+ }
+ }
+
+ *cp++ = '\0';
+
+ return strrev(string);
+}
+
+
+/**************************************************************************
+ c a s e F o l d
+** Case folds a NULL terminated string in place. All characters
+** get converted to lower case.
+**************************************************************************/
+char *caseFold(char *cp)
+{+ char *oldCp = cp;
+
+ while (*cp)
+ {+ if (isupper(*cp))
+ *cp = (char)tolower(*cp);
+ cp++;
+ }
+
+ return oldCp;
+}
+
+
+/**************************************************************************
+ s t r i n c m p
+**
+**************************************************************************/
+int strincmp(char *cp1, char *cp2, FICL_COUNT count)
+{+ int i = 0;
+ char c1, c2;
+
+ for (c1 = *cp1, c2 = *cp2;
+ ((i == 0) && count && c1 && c2);
+ c1 = *++cp1, c2 = *++cp2, count--)
+ {+ i = tolower(c1) - tolower(c2);
+ }
+
+ return i;
+}
+
+
+
+/**************************************************************************
+ 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.
+**************************************************************************/
+char *skipSpace(char *cp)
+{+ assert(cp);
+
+ while (isspace(*cp))
+ cp++;
+
+ return cp;
+}
+
+
--- /dev/null
+++ b/words.c
@@ -1,0 +1,4278 @@
+/*******************************************************************
+** w o r d s . c
+** Forth Inspired Command Language
+** ANS Forth CORE word-set written in C
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+**
+*******************************************************************/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+#include "math64.h"
+
+static void colonParen(FICL_VM *pVM);
+static void literalIm(FICL_VM *pVM);
+static void interpWord(FICL_VM *pVM, STRINGINFO si);
+
+/*
+** Control structure building words use these
+** strings' addresses as markers on the stack to
+** check for structure completion.
+*/
+static char doTag[] = "do";
+static char ifTag[] = "if";
+static char colonTag[] = "colon";
+static char leaveTag[] = "leave";
+static char beginTag[] = "begin";
+static char whileTag[] = "while";
+
+/*
+** Pointers to various words in the dictionary
+** -- initialized by ficlCompileCore, below --
+** for use by compiling words. Colon definitions
+** in ficl are lists of pointers to words. A bit
+** simple-minded...
+*/
+static FICL_WORD *pBranchParen = NULL;
+static FICL_WORD *pComma = NULL;
+static FICL_WORD *pDoParen = NULL;
+static FICL_WORD *pDoesParen = NULL;
+static FICL_WORD *pExitParen = NULL;
+static FICL_WORD *pIfParen = NULL;
+static FICL_WORD *pInterpret = NULL;
+static FICL_WORD *pLitParen = NULL;
+static FICL_WORD *pLoopParen = NULL;
+static FICL_WORD *pPLoopParen = NULL;
+static FICL_WORD *pQDoParen = NULL;
+static FICL_WORD *pSemiParen = NULL;
+static FICL_WORD *pStore = NULL;
+static FICL_WORD *pStringLit = NULL;
+static FICL_WORD *pType = NULL;
+
+#if FICL_WANT_LOCALS
+static FICL_WORD *pGetLocalParen= NULL;
+static FICL_WORD *pGetLocal0 = NULL;
+static FICL_WORD *pGetLocal1 = NULL;
+static FICL_WORD *pToLocalParen = 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;
+#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
+**
+** Push current dict location for later branch resolution.
+** The location may be either a branch target or a patch address...
+*/
+static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
+{+ stackPushPtr(pVM->pStack, dp->here);
+ stackPushPtr(pVM->pStack, tag);
+ return;
+}
+
+static void markControlTag(FICL_VM *pVM, char *tag)
+{+ stackPushPtr(pVM->pStack, tag);
+ return;
+}
+
+static void matchControlTag(FICL_VM *pVM, char *tag)
+{+ char *cp = (char *)stackPopPtr(pVM->pStack);
+ if ( strcmp(cp, tag) )
+ {+ vmTextOut(pVM, "Warning -- unmatched control word: ", 0);
+ vmTextOut(pVM, tag, 1);
+ }
+
+ return;
+}
+
+/*
+** Expect a branch target address on the param stack,
+** compile a literal offset from the current dict location
+** to the target address
+*/
+static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
+{+ long offset;
+ CELL *patchAddr;
+
+ matchControlTag(pVM, tag);
+
+ patchAddr = (CELL *)stackPopPtr(pVM->pStack);
+ offset = patchAddr - dp->here;
+ dictAppendCell(dp, LVALUEtoCELL(offset));
+
+ return;
+}
+
+
+/*
+** Expect a branch patch address on the param stack,
+** compile a literal offset from the patch location
+** to the current dict location
+*/
+static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
+{+ long offset;
+ CELL *patchAddr;
+
+ matchControlTag(pVM, tag);
+
+ patchAddr = (CELL *)stackPopPtr(pVM->pStack);
+ offset = dp->here - patchAddr;
+ *patchAddr = LVALUEtoCELL(offset);
+
+ return;
+}
+
+/*
+** Match the tag to the top of the stack. If success,
+** sopy "here" address into the cell whose address is next
+** on the stack. Used by do..leave..loop.
+*/
+static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
+{+ CELL *patchAddr;
+ char *cp;
+
+ cp = stackPopPtr(pVM->pStack);
+ if (strcmp(cp, tag))
+ {+ vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
+ vmTextOut(pVM, tag, 1);
+ }
+
+ patchAddr = (CELL *)stackPopPtr(pVM->pStack);
+ *patchAddr = LVALUEtoCELL(dp->here);
+
+ return;
+}
+
+
+/**************************************************************************
+ i s N u m b e r
+** Attempts to convert the NULL terminated string in the VM's pad to
+** a number using the VM's current base. If successful, pushes the number
+** onto the param stack and returns TRUE. Otherwise, returns FALSE.
+**************************************************************************/
+
+static int isNumber(FICL_VM *pVM, STRINGINFO si)
+{+ INT32 accum = 0;
+ char isNeg = FALSE;
+ unsigned base = pVM->base;
+ char *cp = SI_PTR(si);
+ FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
+ unsigned ch;
+ unsigned digit;
+
+ if (*cp == '-')
+ {+ cp++;
+ count--;
+ isNeg = TRUE;
+ }
+ else if ((cp[0] == '0') && (cp[1] == 'x'))
+ { /* detect 0xNNNN format for hex numbers */+ cp += 2;
+ count -= 2;
+ base = 16;
+ }
+
+ if (count == 0)
+ return FALSE;
+
+ while (count-- && ((ch = *cp++) != '\0'))
+ {+ if (ch < '0')
+ return FALSE;
+
+ digit = ch - '0';
+
+ if (digit > 9)
+ digit = tolower(ch) - 'a' + 10;
+ /*
+ ** Note: following test also catches chars between 9 and a
+ ** because 'digit' is unsigned!
+ */
+ if (digit >= base)
+ return FALSE;
+
+ accum = accum * base + digit;
+ }
+
+ if (isNeg)
+ accum = -accum;
+
+ stackPushINT32(pVM->pStack, accum);
+
+ return TRUE;
+}
+
+
+/**************************************************************************
+ a d d & f r i e n d s
+**
+**************************************************************************/
+
+static void add(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ i = stackPopINT32(pVM->pStack);
+ i += stackGetTop(pVM->pStack).i;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void sub(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ i = stackPopINT32(pVM->pStack);
+ i = stackGetTop(pVM->pStack).i - i;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void mul(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ i = stackPopINT32(pVM->pStack);
+ i *= stackGetTop(pVM->pStack).i;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void negate(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ i = -stackPopINT32(pVM->pStack);
+ stackPushINT32(pVM->pStack, i);
+ return;
+}
+
+static void ficlDiv(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ i = stackPopINT32(pVM->pStack);
+ i = stackGetTop(pVM->pStack).i / i;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+/*
+** slash-mod CORE ( n1 n2 -- n3 n4 )
+** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
+** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
+** differ in sign, the implementation-defined result returned will be the
+** same as that returned by either the phrase
+** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
+** NOTE: Ficl complies with the second phrase (symmetric division)
+*/
+static void slashMod(FICL_VM *pVM)
+{+ INT64 n1;
+ INT32 n2;
+ INTQR qr;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 2);
+#endif
+ n2 = stackPopINT32(pVM->pStack);
+ n1.lo = stackPopINT32(pVM->pStack);
+ i64Extend(n1);
+
+ qr = m64SymmetricDivI(n1, n2);
+ stackPushINT32(pVM->pStack, qr.rem);
+ stackPushINT32(pVM->pStack, qr.quot);
+ return;
+}
+
+static void onePlus(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ i = stackGetTop(pVM->pStack).i;
+ i += 1;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void oneMinus(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ i = stackGetTop(pVM->pStack).i;
+ i -= 1;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void twoMul(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ i = stackGetTop(pVM->pStack).i;
+ i *= 2;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void twoDiv(FICL_VM *pVM)
+{+ INT32 i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ i = stackGetTop(pVM->pStack).i;
+ i >>= 1;
+ stackSetTop(pVM->pStack, LVALUEtoCELL(i));
+ return;
+}
+
+static void mulDiv(FICL_VM *pVM)
+{+ INT32 x, y, z;
+ INT64 prod;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 1);
+#endif
+ z = stackPopINT32(pVM->pStack);
+ y = stackPopINT32(pVM->pStack);
+ x = stackPopINT32(pVM->pStack);
+
+ prod = m64MulI(x,y);
+ x = m64SymmetricDivI(prod, z).quot;
+
+ stackPushINT32(pVM->pStack, x);
+ return;
+}
+
+
+static void mulDivRem(FICL_VM *pVM)
+{+ INT32 x, y, z;
+ INT64 prod;
+ INTQR qr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 2);
+#endif
+ z = stackPopINT32(pVM->pStack);
+ y = stackPopINT32(pVM->pStack);
+ x = stackPopINT32(pVM->pStack);
+
+ prod = m64MulI(x,y);
+ qr = m64SymmetricDivI(prod, z);
+
+ stackPushINT32(pVM->pStack, qr.rem);
+ stackPushINT32(pVM->pStack, qr.quot);
+ return;
+}
+
+
+/**************************************************************************
+ b y e
+** TOOLS
+** Signal the system to shut down - this causes ficlExec to return
+** VM_USEREXIT. The rest is up to you.
+**************************************************************************/
+
+static void bye(FICL_VM *pVM)
+{+ vmThrow(pVM, VM_USEREXIT);
+ return;
+}
+
+
+/**************************************************************************
+ c o l o n d e f i n i t i o n s
+** Code to begin compiling a colon definition
+** This function sets the state to COMPILE, then creates a
+** new word whose name is the next word in the input stream
+** and whose code is colonParen.
+**************************************************************************/
+
+static void colon(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+
+ pVM->state = COMPILE;
+ markControlTag(pVM, colonTag);
+ dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
+#if FICL_WANT_LOCALS
+ nLocals = 0;
+#endif
+ return;
+}
+
+
+/**************************************************************************
+ c o l o n P a r e n
+** This is the code that executes a colon definition. It assumes that the
+** virtual machine is running a "next" loop (See the vm.c
+** for its implementation of member function vmExecute()). The colon
+** code simply copies the address of the first word in the list of words
+** to interpret into IP after saving its old value. When we return to the
+** "next" loop, the virtual machine will call the code for each word in
+** turn.
+**
+**************************************************************************/
+
+static void colonParen(FICL_VM *pVM)
+{+ IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
+ vmPushIP(pVM, tempIP);
+
+ return;
+}
+
+
+/**************************************************************************
+ s e m i c o l o n C o I m
+**
+** IMMEDIATE code for ";". This function sets the state to INTERPRET and
+** terminates a word under compilation by appending code for "(;)" to
+** the definition. TO DO: checks for leftover branch target tags on the
+** return stack and complains if any are found.
+**************************************************************************/
+static void semiParen(FICL_VM *pVM)
+{+ vmPopIP(pVM);
+ return;
+}
+
+
+static void semicolonCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pSemiParen);
+ matchControlTag(pVM, colonTag);
+
+#if FICL_WANT_LOCALS
+ assert(pUnLinkParen);
+ if (nLocals > 0)
+ {+ FICL_DICT *pLoc = ficlGetLoc();
+ dictEmpty(pLoc, pLoc->pForthWords->size);
+ dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ }
+ nLocals = 0;
+#endif
+
+ dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
+ pVM->state = INTERPRET;
+ dictUnsmudge(dp);
+ return;
+}
+
+
+/**************************************************************************
+ e x i t
+** CORE
+** This function simply pops the previous instruction
+** pointer and returns to the "next" loop. Used for exiting from within
+** a definition. Note that exitParen is identical to semiParen - they
+** are in two different functions so that "see" can correctly identify
+** the end of a colon definition, even if it uses "exit".
+**************************************************************************/
+static void exitParen(FICL_VM *pVM)
+{+ vmPopIP(pVM);
+ return;
+}
+
+static void exitCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ assert(pExitParen);
+ IGNORE(pVM);
+
+#if FICL_WANT_LOCALS
+ if (nLocals > 0)
+ {+ dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ }
+#endif
+ dictAppendCell(dp, LVALUEtoCELL(pExitParen));
+ return;
+}
+
+
+/**************************************************************************
+ c o n s t a n t P a r e n
+** This is the run-time code for "constant". It simply returns the
+** contents of its word's first data cell.
+**
+**************************************************************************/
+
+void constantParen(FICL_VM *pVM)
+{+ FICL_WORD *pFW = pVM->runningWord;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+ stackPush(pVM->pStack, pFW->param[0]);
+ return;
+}
+
+void twoConstParen(FICL_VM *pVM)
+{+ FICL_WORD *pFW = pVM->runningWord;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 2);
+#endif
+ stackPush(pVM->pStack, pFW->param[0]); /* lo */
+ stackPush(pVM->pStack, pFW->param[1]); /* hi */
+ return;
+}
+
+
+/**************************************************************************
+ c o n s t a n t
+** IMMEDIATE
+** Compiles a constant into the dictionary. Constants return their
+** value when invoked. Expects a value on top of the parm stack.
+**************************************************************************/
+
+static void constant(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
+ dictAppendCell(dp, stackPop(pVM->pStack));
+ return;
+}
+
+
+static void twoConstant(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+ CELL c;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ c = stackPop(pVM->pStack);
+ dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
+ dictAppendCell(dp, stackPop(pVM->pStack));
+ dictAppendCell(dp, c);
+ return;
+}
+
+
+/**************************************************************************
+ d i s p l a y C e l l
+** Drop and print the contents of the cell at the top of the param
+** stack
+**************************************************************************/
+
+static void displayCell(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ c = stackPop(pVM->pStack);
+ ltoa((c).i, pVM->pad, pVM->base);
+ strcat(pVM->pad, " ");
+ vmTextOut(pVM, pVM->pad, 0);
+ return;
+}
+
+static void uDot(FICL_VM *pVM)
+{+ UNS32 u;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ u = stackPopUNS32(pVM->pStack);
+ ultoa(u, pVM->pad, pVM->base);
+ strcat(pVM->pad, " ");
+ vmTextOut(pVM, pVM->pad, 0);
+ return;
+}
+
+
+static void hexDot(FICL_VM *pVM)
+{+ UNS32 u;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ u = stackPopUNS32(pVM->pStack);
+ ultoa(u, pVM->pad, 16);
+ strcat(pVM->pad, " ");
+ vmTextOut(pVM, pVM->pad, 0);
+ return;
+}
+
+
+/**************************************************************************
+ d i s p l a y S t a c k
+** Display the parameter stack (code for ".s")
+**************************************************************************/
+
+static void displayStack(FICL_VM *pVM)
+{+ int d = stackDepth(pVM->pStack);
+ int i;
+ CELL *pCell;
+
+ vmCheckStack(pVM, 0, 0);
+
+ if (d == 0)
+ vmTextOut(pVM, "(Stack Empty)", 1);
+ else
+ {+ pCell = pVM->pStack->sp;
+ for (i = 0; i < d; i++)
+ {+ vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1);
+ }
+ }
+}
+
+
+/**************************************************************************
+ d u p & f r i e n d s
+**
+**************************************************************************/
+
+static void depth(FICL_VM *pVM)
+{+ int i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+ i = stackDepth(pVM->pStack);
+ stackPushINT32(pVM->pStack, i);
+ return;
+}
+
+
+static void drop(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ stackDrop(pVM->pStack, 1);
+ return;
+}
+
+
+static void twoDrop(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ stackDrop(pVM->pStack, 2);
+ return;
+}
+
+
+static void dup(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 2);
+#endif
+ stackPick(pVM->pStack, 0);
+ return;
+}
+
+
+static void twoDup(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 4);
+#endif
+ stackPick(pVM->pStack, 1);
+ stackPick(pVM->pStack, 1);
+ return;
+}
+
+
+static void over(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 3);
+#endif
+ stackPick(pVM->pStack, 1);
+ return;
+}
+
+static void twoOver(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 4, 6);
+#endif
+ stackPick(pVM->pStack, 3);
+ stackPick(pVM->pStack, 3);
+ return;
+}
+
+
+static void pick(FICL_VM *pVM)
+{+ CELL c = stackPop(pVM->pStack);
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, c.i+1, c.i+2);
+#endif
+ stackPick(pVM->pStack, c.i);
+ return;
+}
+
+
+static void questionDup(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 2);
+#endif
+ c = stackGetTop(pVM->pStack);
+
+ if (c.i != 0)
+ stackPick(pVM->pStack, 0);
+
+ return;
+}
+
+
+static void roll(FICL_VM *pVM)
+{+ int i = stackPop(pVM->pStack).i;
+ i = (i > 0) ? i : 0;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, i+1, i+1);
+#endif
+ stackRoll(pVM->pStack, i);
+ return;
+}
+
+
+static void minusRoll(FICL_VM *pVM)
+{+ int i = stackPop(pVM->pStack).i;
+ i = (i > 0) ? i : 0;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, i+1, i+1);
+#endif
+ stackRoll(pVM->pStack, -i);
+ return;
+}
+
+
+static void rot(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 3);
+#endif
+ stackRoll(pVM->pStack, 2);
+ return;
+}
+
+
+static void swap(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 2);
+#endif
+ stackRoll(pVM->pStack, 1);
+ return;
+}
+
+
+static void twoSwap(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 4, 4);
+#endif
+ stackRoll(pVM->pStack, 3);
+ stackRoll(pVM->pStack, 3);
+ return;
+}
+
+
+/**************************************************************************
+ e m i t & f r i e n d s
+**
+**************************************************************************/
+
+static void emit(FICL_VM *pVM)
+{+ char *cp = pVM->pad;
+ int i;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ i = stackPopINT32(pVM->pStack);
+ cp[0] = (char)i;
+ cp[1] = '\0';
+ vmTextOut(pVM, cp, 0);
+ return;
+}
+
+
+static void cr(FICL_VM *pVM)
+{+ vmTextOut(pVM, "", 1);
+ return;
+}
+
+
+static void commentLine(FICL_VM *pVM)
+{+ char *cp = vmGetInBuf(pVM);
+ char ch = *cp;
+
+ while ((ch != '\0') && (ch != '\r') && (ch != '\n'))
+ {+ ch = *++cp;
+ }
+
+ /*
+ ** Cope with DOS or UNIX-style EOLs -
+ ** 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')
+ {+ cp++;
+
+ if ( (ch != *cp)
+ && ((*cp == '\r') || (*cp == '\n')) )
+ cp++;
+ }
+
+ vmUpdateTib(pVM, cp);
+ return;
+}
+
+
+/*
+** paren CORE
+** Compilation: Perform the execution semantics given below.
+** Execution: ( "ccc<paren>" -- )
+** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
+** The number of characters in ccc may be zero to the number of characters
+** in the parse area.
+**
+*/
+static void commentHang(FICL_VM *pVM)
+{+ vmParseString(pVM, ')');
+ return;
+}
+
+
+/**************************************************************************
+ F E T C H & S T O R E
+**
+**************************************************************************/
+
+static void fetch(FICL_VM *pVM)
+{+ CELL *pCell;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ pCell = (CELL *)stackPopPtr(pVM->pStack);
+ stackPush(pVM->pStack, *pCell);
+ return;
+}
+
+/*
+** two-fetch CORE ( a-addr -- x1 x2 )
+** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
+** x1 at the next consecutive cell. It is equivalent to the sequence
+** DUP CELL+ @ SWAP @ .
+*/
+static void twoFetch(FICL_VM *pVM)
+{+ CELL *pCell;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 2);
+#endif
+ pCell = (CELL *)stackPopPtr(pVM->pStack);
+ stackPush(pVM->pStack, *pCell++);
+ stackPush(pVM->pStack, *pCell);
+ swap(pVM);
+ return;
+}
+
+/*
+** store CORE ( x a-addr -- )
+** Store x at a-addr.
+*/
+static void store(FICL_VM *pVM)
+{+ CELL *pCell;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ pCell = (CELL *)stackPopPtr(pVM->pStack);
+ *pCell = stackPop(pVM->pStack);
+}
+
+/*
+** two-store CORE ( x1 x2 a-addr -- )
+** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
+** next consecutive cell. It is equivalent to the sequence
+** SWAP OVER ! CELL+ ! .
+*/
+static void twoStore(FICL_VM *pVM)
+{+ CELL *pCell;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 0);
+#endif
+ pCell = (CELL *)stackPopPtr(pVM->pStack);
+ *pCell++ = stackPop(pVM->pStack);
+ *pCell = stackPop(pVM->pStack);
+}
+
+static void plusStore(FICL_VM *pVM)
+{+ CELL *pCell;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ pCell = (CELL *)stackPopPtr(pVM->pStack);
+ pCell->i += stackPop(pVM->pStack).i;
+}
+
+
+static void wFetch(FICL_VM *pVM)
+{+ UNS16 *pw;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ pw = (UNS16 *)stackPopPtr(pVM->pStack);
+ stackPushUNS32(pVM->pStack, (UNS32)*pw);
+ return;
+}
+
+static void wStore(FICL_VM *pVM)
+{+ UNS16 *pw;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ pw = (UNS16 *)stackPopPtr(pVM->pStack);
+ *pw = (UNS16)(stackPop(pVM->pStack).u);
+}
+
+static void cFetch(FICL_VM *pVM)
+{+ UNS8 *pc;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ pc = (UNS8 *)stackPopPtr(pVM->pStack);
+ stackPushUNS32(pVM->pStack, (UNS32)*pc);
+ return;
+}
+
+static void cStore(FICL_VM *pVM)
+{+ UNS8 *pc;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ pc = (UNS8 *)stackPopPtr(pVM->pStack);
+ *pc = (UNS8)(stackPop(pVM->pStack).u);
+}
+
+
+/**************************************************************************
+ i f C o I m
+** IMMEDIATE
+** Compiles code for a conditional branch into the dictionary
+** and pushes the branch patch address on the stack for later
+** patching by ELSE or THEN/ENDIF.
+**************************************************************************/
+
+static void ifCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pIfParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ markBranch(dp, pVM, ifTag);
+ dictAppendUNS32(dp, 1);
+ return;
+}
+
+
+/**************************************************************************
+ i f P a r e n
+** Runtime code to do "if" or "until": pop a flag from the stack,
+** fall through if true, branch if false. Probably ought to be
+** called (not?branch) since it does "branch if false".
+**************************************************************************/
+
+static void ifParen(FICL_VM *pVM)
+{+ UNS32 flag;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ flag = stackPopUNS32(pVM->pStack);
+
+ if (flag)
+ { /* fall through */+ vmBranchRelative(pVM, 1);
+ }
+ else
+ { /* take branch (to else/endif/begin) */+ vmBranchRelative(pVM, (int)(*pVM->ip));
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ e l s e C o I m
+**
+** IMMEDIATE -- compiles an "else"...
+** 1) Compile a branch and a patch address; the address gets patched
+** by "endif" to point past the "else" code.
+** 2) Pop the the "if" patch address
+** 3) Patch the "if" branch to point to the current compile address.
+** 4) Push the "else" patch address. ("endif" patches this to jump past +** the "else" code.
+**************************************************************************/
+
+static void elseCoIm(FICL_VM *pVM)
+{+ CELL *patchAddr;
+ int offset;
+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pBranchParen);
+ /* (1) compile branch runtime */
+ dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
+ matchControlTag(pVM, ifTag);
+ patchAddr =
+ (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
+ markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */
+ dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */
+ offset = dp->here - patchAddr;
+ *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
+
+ return;
+}
+
+
+/**************************************************************************
+ b r a n c h P a r e n
+**
+** Runtime for "(branch)" -- expects a literal offset in the next
+** compilation address, and branches to that location.
+**************************************************************************/
+
+static void branchParen(FICL_VM *pVM)
+{+ vmBranchRelative(pVM, *(int *)(pVM->ip));
+ return;
+}
+
+
+/**************************************************************************
+ e n d i f C o I m
+**
+**************************************************************************/
+
+static void endifCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ resolveForwardBranch(dp, pVM, ifTag);
+ 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
+** Copy next word into the pad (vmGetWord)
+** Attempt to find the word in the dictionary (dictLookup)
+** If successful, execute the word.
+** Otherwise, attempt to convert the word to a number (isNumber)
+** If successful, push the number onto the parameter stack.
+** Otherwise, print an error message and exit loop...
+** End Loop
+**
+** From the standard, section 3.4
+** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
+** repeat the following steps until either the parse area is empty or an
+** ambiguous condition exists:
+** a) Skip leading spaces and parse a name (see 3.4.1);
+**************************************************************************/
+
+static void interpret(FICL_VM *pVM)
+{+ STRINGINFO si = vmGetWord0(pVM);
+ assert(pVM);
+
+ vmBranchRelative(pVM, -1);
+
+ /*
+ // 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 */
+}
+
+/**************************************************************************
+** From the standard, section 3.4
+** b) Search the dictionary name space (see 3.4.2). If a definition name
+** matching the string is found:
+** 1.if interpreting, perform the interpretation semantics of the definition
+** (see 3.4.3.2), and continue at a);
+** 2.if compiling, perform the compilation semantics of the definition
+** (see 3.4.3.3), and continue at a).
+**
+** c) If a definition name matching the string is not found, attempt to
+** convert the string to a number (see 3.4.1.3). If successful:
+** 1.if interpreting, place the number on the data stack, and continue at a);
+** 2.if compiling, compile code that when executed will place the number on
+** the stack (see 6.1.1780 LITERAL), and continue at a);
+**
+** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
+**************************************************************************/
+static void interpWord(FICL_VM *pVM, STRINGINFO si)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_WORD *tempFW;
+
+#if FICL_ROBUST
+ dictCheck(dp, pVM, 0);
+ vmCheckStack(pVM, 0, 0);
+#endif
+
+#if FICL_WANT_LOCALS
+ if (nLocals > 0)
+ {+ tempFW = dictLookupLoc(dp, si);
+ }
+ else
+#endif
+ tempFW = dictLookup(dp, si);
+
+ if (pVM->state == INTERPRET)
+ {+ if (tempFW != NULL)
+ {+ if (wordIsCompileOnly(tempFW))
+ {+ vmThrowErr(pVM, "Error: Compile only!");
+ }
+
+ vmExecute(pVM, tempFW);
+ }
+
+ else if (!isNumber(pVM, si))
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
+ }
+ }
+
+ else /* (pVM->state == COMPILE) */
+ {+ if (tempFW != NULL)
+ {+ if (wordIsImmediate(tempFW))
+ {+ vmExecute(pVM, tempFW);
+ }
+ else
+ {+ dictAppendCell(dp, LVALUEtoCELL(tempFW));
+ }
+ }
+ else if (isNumber(pVM, si))
+ {+ literalIm(pVM);
+ }
+ else
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
+ }
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ l i t e r a l P a r e n
+**
+** This is the runtime for (literal). It assumes that it is part of a colon
+** definition, and that the next CELL contains a value to be pushed on the
+** parameter stack at runtime. This code is compiled by "literal".
+**
+**************************************************************************/
+
+static void literalParen(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+ stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip));
+ vmBranchRelative(pVM, 1);
+ return;
+}
+
+
+/**************************************************************************
+ l i t e r a l I m
+**
+** IMMEDIATE code for "literal". This function gets a value from the stack
+** and compiles it into the dictionary preceded by the code for "(literal)".
+** IMMEDIATE
+**************************************************************************/
+
+static void literalIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ assert(pLitParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pLitParen));
+ dictAppendCell(dp, stackPop(pVM->pStack));
+
+ return;
+}
+
+
+/**************************************************************************
+ l i s t W o r d s
+**
+**************************************************************************/
+#define nCOLWIDTH 8
+static void listWords(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
+ FICL_WORD *wp;
+ int nChars = 0;
+ int len;
+ unsigned i;
+ int nWords = 0;
+ char *cp;
+ char *pPad = pVM->pad;
+
+ for (i = 0; i < pHash->size; i++)
+ {+ for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ {+ cp = wp->name;
+ nChars += sprintf(pPad + nChars, "%s", cp);
+
+ if (nChars > 70)
+ {+ pPad[nChars] = '\0';
+ nChars = 0;
+ vmTextOut(pVM, pPad, 1);
+ }
+ else
+ {+ len = nCOLWIDTH - nChars % nCOLWIDTH;
+ while (len-- > 0)
+ pPad[nChars++] = ' ';
+ }
+
+ if (nChars > 70)
+ {+ pPad[nChars] = '\0';
+ nChars = 0;
+ vmTextOut(pVM, pPad, 1);
+ }
+ }
+ }
+
+ if (nChars > 0)
+ {+ pPad[nChars] = '\0';
+ nChars = 0;
+ vmTextOut(pVM, pPad, 1);
+ }
+
+ sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total",
+ nWords, dp->here - dp->dict, dp->size);
+ vmTextOut(pVM, pVM->pad, 1);
+ return;
+}
+
+
+static void listEnv(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetEnv();
+ FICL_HASH *pHash = dp->pForthWords;
+ FICL_WORD *wp;
+ unsigned i;
+ int nWords = 0;
+
+ for (i = 0; i < pHash->size; i++)
+ {+ for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ {+ vmTextOut(pVM, wp->name, 1);
+ }
+ }
+
+ sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total",
+ nWords, dp->here - dp->dict, dp->size);
+ vmTextOut(pVM, pVM->pad, 1);
+ return;
+}
+
+
+/**************************************************************************
+ l o g i c a n d c o m p a r i s o n s
+**
+**************************************************************************/
+
+static void zeroEquals(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0);
+ stackPush(pVM->pStack, c);
+ return;
+}
+
+static void zeroLess(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0);
+ stackPush(pVM->pStack, c);
+ return;
+}
+
+static void zeroGreater(FICL_VM *pVM)
+{+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0);
+ stackPush(pVM->pStack, c);
+ return;
+}
+
+static void isEqual(FICL_VM *pVM)
+{+ CELL x, y;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ x = stackPop(pVM->pStack);
+ y = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i));
+ return;
+}
+
+static void isLess(FICL_VM *pVM)
+{+ CELL x, y;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ y = stackPop(pVM->pStack);
+ x = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i));
+ return;
+}
+
+static void uIsLess(FICL_VM *pVM)
+{+ UNS32 u1, u2;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ u2 = stackPopUNS32(pVM->pStack);
+ u1 = stackPopUNS32(pVM->pStack);
+ stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2));
+ return;
+}
+
+static void isGreater(FICL_VM *pVM)
+{+ CELL x, y;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ y = stackPop(pVM->pStack);
+ x = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i));
+ return;
+}
+
+static void bitwiseAnd(FICL_VM *pVM)
+{+ CELL x, y;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ x = stackPop(pVM->pStack);
+ y = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, x.i & y.i);
+ return;
+}
+
+static void bitwiseOr(FICL_VM *pVM)
+{+ CELL x, y;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ x = stackPop(pVM->pStack);
+ y = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, x.i | y.i);
+ return;
+}
+
+static void bitwiseXor(FICL_VM *pVM)
+{+ CELL x, y;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 1);
+#endif
+ x = stackPop(pVM->pStack);
+ y = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, x.i ^ y.i);
+ return;
+}
+
+static void bitwiseNot(FICL_VM *pVM)
+{+ CELL x;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ x = stackPop(pVM->pStack);
+ stackPushINT32(pVM->pStack, ~x.i);
+ return;
+}
+
+
+/**************************************************************************
+ D o / L o o p
+** do -- IMMEDIATE COMPILE ONLY
+** Compiles code to initialize a loop: compile (do),
+** allot space to hold the "leave" address, push a branch
+** target address for the loop.
+** (do) -- runtime for "do"
+** pops index and limit from the p stack and moves them
+** to the r stack, then skips to the loop body.
+** loop -- IMMEDIATE COMPILE ONLY
+** +loop
+** Compiles code for the test part of a loop:
+** compile (loop), resolve forward branch from "do", and
+** copy "here" address to the "leave" address allotted by "do"
+** i,j,k -- COMPILE ONLY
+** Runtime: Push loop indices on param stack (i is innermost loop...)
+** Note: each loop has three values on the return stack:
+** ( R: leave limit index )
+** "leave" is the absolute address of the next cell after the loop
+** limit and index are the loop control variables.
+** leave -- COMPILE ONLY
+** Runtime: pop the loop control variables, then pop the
+** "leave" address and jump (absolute) there.
+**************************************************************************/
+
+static void doCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pDoParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pDoParen));
+ /*
+ ** Allot space for a pointer to the end
+ ** of the loop - "leave" uses this...
+ */
+ markBranch(dp, pVM, leaveTag);
+ dictAppendUNS32(dp, 0);
+ /*
+ ** Mark location of head of loop...
+ */
+ markBranch(dp, pVM, doTag);
+
+ return;
+}
+
+
+static void doParen(FICL_VM *pVM)
+{+ CELL index, limit;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ index = stackPop(pVM->pStack);
+ limit = stackPop(pVM->pStack);
+
+ /* copy "leave" target addr to stack */
+ stackPushPtr(pVM->rStack, *(pVM->ip++));
+ stackPush(pVM->rStack, limit);
+ stackPush(pVM->rStack, index);
+
+ return;
+}
+
+
+static void qDoCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pQDoParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
+ /*
+ ** Allot space for a pointer to the end
+ ** of the loop - "leave" uses this...
+ */
+ markBranch(dp, pVM, leaveTag);
+ dictAppendUNS32(dp, 0);
+ /*
+ ** Mark location of head of loop...
+ */
+ markBranch(dp, pVM, doTag);
+
+ return;
+}
+
+
+static void qDoParen(FICL_VM *pVM)
+{+ CELL index, limit;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ index = stackPop(pVM->pStack);
+ limit = stackPop(pVM->pStack);
+
+ /* copy "leave" target addr to stack */
+ stackPushPtr(pVM->rStack, *(pVM->ip++));
+
+ if (limit.u == index.u)
+ {+ vmPopIP(pVM);
+ }
+ else
+ {+ stackPush(pVM->rStack, limit);
+ stackPush(pVM->rStack, index);
+ }
+
+ return;
+}
+
+
+/*
+** Runtime code to break out of a do..loop construct
+** Drop the loop control variables; the branch address
+** past "loop" is next on the return stack.
+*/
+static void leaveCo(FICL_VM *pVM)
+{+ /* almost unloop */
+ stackDrop(pVM->rStack, 2);
+ /* exit */
+ vmPopIP(pVM);
+ return;
+}
+
+
+static void unloopCo(FICL_VM *pVM)
+{+ stackDrop(pVM->rStack, 3);
+ return;
+}
+
+
+static void loopCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pLoopParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
+ resolveBackBranch(dp, pVM, doTag);
+ resolveAbsBranch(dp, pVM, leaveTag);
+ return;
+}
+
+
+static void plusLoopCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pPLoopParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
+ resolveBackBranch(dp, pVM, doTag);
+ resolveAbsBranch(dp, pVM, leaveTag);
+ return;
+}
+
+
+static void loopParen(FICL_VM *pVM)
+{+ INT32 index = stackGetTop(pVM->rStack).i;
+ INT32 limit = stackFetch(pVM->rStack, 1).i;
+
+ index++;
+
+ if (index >= limit)
+ {+ stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
+ vmBranchRelative(pVM, 1); /* fall through the loop */
+ }
+ else
+ { /* update index, branch to loop head */+ stackSetTop(pVM->rStack, LVALUEtoCELL(index));
+ vmBranchRelative(pVM, *(int *)(pVM->ip));
+ }
+
+ return;
+}
+
+
+static void plusLoopParen(FICL_VM *pVM)
+{+ INT32 index = stackGetTop(pVM->rStack).i;
+ INT32 limit = stackFetch(pVM->rStack, 1).i;
+ INT32 increment = stackPop(pVM->pStack).i;
+ int flag;
+
+ index += increment;
+
+ if (increment < 0)
+ flag = (index < limit);
+ else
+ flag = (index >= limit);
+
+ if (flag)
+ {+ stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
+ vmBranchRelative(pVM, 1); /* fall through the loop */
+ }
+ else
+ { /* update index, branch to loop head */+ stackSetTop(pVM->rStack, LVALUEtoCELL(index));
+ vmBranchRelative(pVM, *(int *)(pVM->ip));
+ }
+
+ return;
+}
+
+
+static void loopICo(FICL_VM *pVM)
+{+ CELL index = stackGetTop(pVM->rStack);
+ stackPush(pVM->pStack, index);
+
+ return;
+}
+
+
+static void loopJCo(FICL_VM *pVM)
+{+ CELL index = stackFetch(pVM->rStack, 3);
+ stackPush(pVM->pStack, index);
+
+ return;
+}
+
+
+static void loopKCo(FICL_VM *pVM)
+{+ CELL index = stackFetch(pVM->rStack, 6);
+ stackPush(pVM->pStack, index);
+
+ return;
+}
+
+
+/**************************************************************************
+ r e t u r n s t a c k
+**
+**************************************************************************/
+
+static void toRStack(FICL_VM *pVM)
+{+ stackPush(pVM->rStack, stackPop(pVM->pStack));
+ return;
+}
+
+static void fromRStack(FICL_VM *pVM)
+{+ stackPush(pVM->pStack, stackPop(pVM->rStack));
+ return;
+}
+
+static void fetchRStack(FICL_VM *pVM)
+{+ stackPush(pVM->pStack, stackGetTop(pVM->rStack));
+ return;
+}
+
+
+/**************************************************************************
+ v a r i a b l e
+**
+**************************************************************************/
+
+static void variableParen(FICL_VM *pVM)
+{+ FICL_WORD *fw = pVM->runningWord;
+ stackPushPtr(pVM->pStack, fw->param);
+ return;
+}
+
+
+static void variable(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+
+ dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
+ dictAllotCells(dp, 1);
+ return;
+}
+
+
+
+/**************************************************************************
+ b a s e & f r i e n d s
+**
+**************************************************************************/
+
+static void base(FICL_VM *pVM)
+{+ CELL *pBase = (CELL *)(&pVM->base);
+ stackPush(pVM->pStack, LVALUEtoCELL(pBase));
+ return;
+}
+
+
+static void decimal(FICL_VM *pVM)
+{+ pVM->base = 10;
+ return;
+}
+
+
+static void hex(FICL_VM *pVM)
+{+ pVM->base = 16;
+ return;
+}
+
+
+/**************************************************************************
+ a l l o t & f r i e n d s
+**
+**************************************************************************/
+
+static void allot(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ INT32 i = stackPopINT32(pVM->pStack);
+#if FICL_ROBUST
+ dictCheck(dp, pVM, i);
+#endif
+ dictAllot(dp, i);
+ return;
+}
+
+
+static void here(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ stackPushPtr(pVM->pStack, dp->here);
+ return;
+}
+
+
+static void comma(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ CELL c = stackPop(pVM->pStack);
+ dictAppendCell(dp, c);
+ return;
+}
+
+
+static void cComma(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ char c = (char)stackPopINT32(pVM->pStack);
+ dictAppendChar(dp, c);
+ return;
+}
+
+
+static void cells(FICL_VM *pVM)
+{+ INT32 i = stackPopINT32(pVM->pStack);
+ stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL));
+ return;
+}
+
+
+static void cellPlus(FICL_VM *pVM)
+{+ char *cp = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, cp + sizeof (CELL));
+ return;
+}
+
+
+/**************************************************************************
+ t i c k
+** tick CORE ( "<spaces>name" -- xt )
+** Skip leading space delimiters. Parse name delimited by a space. Find
+** name and return xt, the execution token for name. An ambiguous condition
+** exists if name is not found.
+**************************************************************************/
+static void tick(FICL_VM *pVM)
+{+ FICL_WORD *pFW = NULL;
+ STRINGINFO si = vmGetWord(pVM);
+
+ pFW = dictLookup(ficlGetDict(), si);
+ if (!pFW)
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
+ }
+ stackPushPtr(pVM->pStack, pFW);
+ return;
+}
+
+
+static void bracketTickCoIm(FICL_VM *pVM)
+{+ tick(pVM);
+ literalIm(pVM);
+
+ return;
+}
+
+
+/**************************************************************************
+ p o s t p o n e
+** Lookup the next word in the input stream and compile code to
+** insert it into definitions created by the resulting word
+** (defers compilation, even of immediate words)
+**************************************************************************/
+
+static void postponeCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_WORD *pFW;
+ assert(pComma);
+
+ tick(pVM);
+ pFW = stackGetTop(pVM->pStack).p;
+ if (wordIsImmediate(pFW))
+ {+ dictAppendCell(dp, stackPop(pVM->pStack));
+ }
+ else
+ {+ literalIm(pVM);
+ dictAppendCell(dp, LVALUEtoCELL(pComma));
+ }
+
+ return;
+}
+
+
+
+/**************************************************************************
+ e x e c u t e
+** Pop an execution token (pointer to a word) off the stack and
+** run it
+**************************************************************************/
+
+static void execute(FICL_VM *pVM)
+{+ FICL_WORD *pFW = stackPopPtr(pVM->pStack);
+ vmExecute(pVM, pFW);
+
+ return;
+}
+
+
+/**************************************************************************
+ i m m e d i a t e
+** Make the most recently compiled word IMMEDIATE -- it executes even
+** in compile state (most often used for control compiling words
+** such as IF, THEN, etc)
+**************************************************************************/
+
+static void immediate(FICL_VM *pVM)
+{+ IGNORE(pVM);
+ dictSetImmediate(ficlGetDict());
+ return;
+}
+
+
+static void compileOnly(FICL_VM *pVM)
+{+ IGNORE(pVM);
+ dictSetFlags(ficlGetDict(), FW_COMPILE, 0);
+ return;
+}
+
+
+/**************************************************************************
+ d o t Q u o t e
+** IMMEDIATE word that compiles a string literal for later display
+** Compile stringLit, then copy the bytes of the string from the TIB
+** to the dictionary. Backpatch the count byte and align the dictionary.
+**
+** stringlit: Fetch the count from the dictionary, then push the address
+** and count on the stack. Finally, update ip to point to the first
+** aligned address after the string text.
+**************************************************************************/
+
+static void stringLit(FICL_VM *pVM)
+{+ FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
+ FICL_COUNT count = sp->count;
+ char *cp = sp->text;
+ stackPushPtr(pVM->pStack, cp);
+ stackPushUNS32(pVM->pStack, count);
+ cp += count + 1;
+ cp = alignPtr(cp);
+ pVM->ip = (IPTYPE)(void *)cp;
+ return;
+}
+
+static void dotQuoteCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
+ dictAlign(dp);
+ dictAppendCell(dp, LVALUEtoCELL(pType));
+ return;
+}
+
+
+static void dotParen(FICL_VM *pVM)
+{+ char *pSrc = vmGetInBuf(pVM);
+ char *pDest = pVM->pad;
+ char ch;
+
+ pSrc = skipSpace(pSrc);
+
+ for (ch = *pSrc; (ch != '\0') && (ch != ')'); ch = *++pSrc)
+ *pDest++ = ch;
+
+ *pDest = '\0';
+ if (ch == ')')
+ pSrc++;
+
+ vmTextOut(pVM, pVM->pad, 0);
+ vmUpdateTib(pVM, pSrc);
+
+ return;
+}
+
+
+/**************************************************************************
+ s l i t e r a l
+** STRING
+** Interpretation: Interpretation semantics for this word are undefined.
+** Compilation: ( c-addr1 u -- )
+** Append the run-time semantics given below to the current definition.
+** Run-time: ( -- c-addr2 u )
+** Return c-addr2 u describing a string consisting of the characters
+** specified by c-addr1 u during compilation. A program shall not alter
+** the returned string.
+**************************************************************************/
+static void sLiteralCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ char *cp, *cpDest;
+ UNS32 u;
+ u = stackPopUNS32(pVM->pStack);
+ cp = stackPopPtr(pVM->pStack);
+
+ dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ cpDest = (char *) dp->here;
+ *cpDest++ = (char) u;
+
+ for (; u > 0; --u)
+ {+ *cpDest++ = *cp++;
+ }
+
+ *cpDest++ = 0;
+ dp->here = PTRtoCELL alignPtr(cpDest);
+ return;
+}
+
+
+/**************************************************************************
+ s t a t e
+** Return the address of the VM's state member (must be sized the
+** same as a CELL for this reason)
+**************************************************************************/
+static void state(FICL_VM *pVM)
+{+ stackPushPtr(pVM->pStack, &pVM->state);
+ return;
+}
+
+
+/**************************************************************************
+ c r e a t e . . . d o e s >
+** Make a new word in the dictionary with the run-time effect of
+** a variable (push my address), but with extra space allotted
+** for use by does> .
+**************************************************************************/
+
+static void createParen(FICL_VM *pVM)
+{+ CELL *pCell = pVM->runningWord->param;
+ stackPushPtr(pVM->pStack, pCell+1);
+ return;
+}
+
+
+static void create(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+
+ dictAppendWord2(dp, si, createParen, FW_DEFAULT);
+ dictAllotCells(dp, 1);
+ return;
+}
+
+
+static void doDoes(FICL_VM *pVM)
+{+ CELL *pCell = pVM->runningWord->param;
+ IPTYPE tempIP = (IPTYPE)((*pCell).p);
+ stackPushPtr(pVM->pStack, pCell+1);
+ vmPushIP(pVM, tempIP);
+ return;
+}
+
+
+static void doesParen(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ dp->smudge->code = doDoes;
+ dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
+ vmPopIP(pVM);
+ return;
+}
+
+
+static void doesCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+#if FICL_WANT_LOCALS
+ assert(pUnLinkParen);
+ if (nLocals > 0)
+ {+ FICL_DICT *pLoc = ficlGetLoc();
+ dictEmpty(pLoc, pLoc->pForthWords->size);
+ dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ }
+
+ nLocals = 0;
+#endif
+ IGNORE(pVM);
+
+ dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
+ return;
+}
+
+
+/**************************************************************************
+ t o b o d y
+** to-body CORE ( xt -- a-addr )
+** a-addr is the data-field address corresponding to xt. An ambiguous
+** condition exists if xt is not for a word defined via CREATE.
+**************************************************************************/
+static void toBody(FICL_VM *pVM)
+{+ FICL_WORD *pFW = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, pFW->param + 1);
+ return;
+}
+
+
+/*
+** from-body ficl ( a-addr -- xt )
+** Reverse effect of >body
+*/
+static void fromBody(FICL_VM *pVM)
+{+ char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD);
+ stackPushPtr(pVM->pStack, ptr);
+ return;
+}
+
+
+/*
+** >name ficl ( xt -- c-addr u )
+** Push the address and length of a word's name given its address
+** xt.
+*/
+static void toName(FICL_VM *pVM)
+{+ FICL_WORD *pFW = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, pFW->name);
+ stackPushUNS32(pVM->pStack, pFW->nName);
+ return;
+}
+
+
+/**************************************************************************
+ l b r a c k e t e t c
+**
+**************************************************************************/
+
+static void lbracketCoIm(FICL_VM *pVM)
+{+ pVM->state = INTERPRET;
+ return;
+}
+
+
+static void rbracket(FICL_VM *pVM)
+{+ pVM->state = COMPILE;
+ return;
+}
+
+
+/**************************************************************************
+ p i c t u r e d n u m e r i c w o r d s
+**
+** less-number-sign CORE ( -- )
+** Initialize the pictured numeric output conversion process.
+** (clear the pad)
+**************************************************************************/
+static void lessNumberSign(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ sp->count = 0;
+ return;
+}
+
+/*
+** number-sign CORE ( ud1 -- ud2 )
+** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
+** n. (n is the least-significant digit of ud1.) Convert n to external form
+** and add the resulting character to the beginning of the pictured numeric
+** output string. An ambiguous condition exists if # executes outside of a
+** <# #> delimited number conversion.
+*/
+static void numberSign(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ UNS64 u;
+ UNS16 rem;
+
+ u = u64Pop(pVM->pStack);
+ rem = m64UMod(&u, (UNS16)(pVM->base));
+ sp->text[sp->count++] = digit_to_char(rem);
+ u64Push(pVM->pStack, u);
+ return;
+}
+
+/*
+** number-sign-greater CORE ( xd -- c-addr u )
+** Drop xd. Make the pictured numeric output string available as a character
+** string. c-addr and u specify the resulting character string. A program
+** may replace characters within the string.
+*/
+static void numberSignGreater(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ sp->text[sp->count] = '\0';
+ strrev(sp->text);
+ stackDrop(pVM->pStack, 2);
+ stackPushPtr(pVM->pStack, sp->text);
+ stackPushUNS32(pVM->pStack, sp->count);
+ return;
+}
+
+/*
+** number-sign-s CORE ( ud1 -- ud2 )
+** Convert one digit of ud1 according to the rule for #. Continue conversion
+** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
+** #S executes outside of a <# #> delimited number conversion.
+** TO DO: presently does not use ud1 hi cell - use it!
+*/
+static void numberSignS(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ UNS64 u;
+ UNS16 rem;
+
+ u = u64Pop(pVM->pStack);
+
+ do
+ {+ rem = m64UMod(&u, (UNS16)(pVM->base));
+ sp->text[sp->count++] = digit_to_char(rem);
+ }
+ while (u.hi || u.lo);
+
+ u64Push(pVM->pStack, u);
+ return;
+}
+
+/*
+** HOLD CORE ( char -- )
+** Add char to the beginning of the pictured numeric output string. An ambiguous
+** condition exists if HOLD executes outside of a <# #> delimited number conversion.
+*/
+static void hold(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ int i = stackPopINT32(pVM->pStack);
+ sp->text[sp->count++] = (char) i;
+ return;
+}
+
+/*
+** SIGN CORE ( n -- )
+** If n is negative, add a minus sign to the beginning of the pictured
+** numeric output string. An ambiguous condition exists if SIGN
+** executes outside of a <# #> delimited number conversion.
+*/
+static void sign(FICL_VM *pVM)
+{+ FICL_STRING *sp = PTRtoSTRING pVM->pad;
+ int i = stackPopINT32(pVM->pStack);
+ if (i < 0)
+ sp->text[sp->count++] = '-';
+ return;
+}
+
+
+/**************************************************************************
+ t o N u m b e r
+** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
+** ud2 is the unsigned result of converting the characters within the
+** string specified by c-addr1 u1 into digits, using the number in BASE,
+** and adding each into ud1 after multiplying ud1 by the number in BASE.
+** Conversion continues left-to-right until a character that is not
+** convertible, including any + or -, is encountered or the string is
+** entirely converted. c-addr2 is the location of the first unconverted
+** character or the first character past the end of the string if the string
+** was entirely converted. u2 is the number of unconverted characters in the
+** string. An ambiguous condition exists if ud2 overflows during the
+** conversion.
+** TO DO: presently does not use ud1 hi cell - use it!
+**************************************************************************/
+static void toNumber(FICL_VM *pVM)
+{+ UNS32 count = stackPopUNS32(pVM->pStack);
+ char *cp = (char *)stackPopPtr(pVM->pStack);
+ UNS64 accum;
+ UNS32 base = pVM->base;
+ UNS32 ch;
+ UNS32 digit;
+
+ accum = u64Pop(pVM->pStack);
+
+ for (ch = *cp; count > 0; ch = *++cp, count--)
+ {+ if (ch < '0')
+ break;
+
+ digit = ch - '0';
+
+ if (digit > 9)
+ digit = tolower(ch) - 'a' + 10;
+ /*
+ ** Note: following test also catches chars between 9 and a
+ ** because 'digit' is unsigned!
+ */
+ if (digit >= base)
+ break;
+
+ accum = m64Mac(accum, base, digit);
+ }
+
+ u64Push(pVM->pStack, accum);
+ stackPushPtr (pVM->pStack, cp);
+ stackPushUNS32(pVM->pStack, count);
+
+ return;
+}
+
+
+
+/**************************************************************************
+ q u i t & a b o r t
+** quit CORE ( -- ) ( R: i*x -- )
+** Empty the return stack, store zero in SOURCE-ID if it is present, make
+** the user input device the input source, and enter interpretation state.
+** Do not display a message. Repeat the following:
+**
+** Accept a line from the input source into the input buffer, set >IN to
+** zero, and interpret.
+** Display the implementation-defined system prompt if in
+** interpretation state, all processing has been completed, and no
+** ambiguous condition exists.
+**************************************************************************/
+
+static void quit(FICL_VM *pVM)
+{+ vmThrow(pVM, VM_QUIT);
+ return;
+}
+
+
+static void ficlAbort(FICL_VM *pVM)
+{+ vmThrow(pVM, VM_ERREXIT);
+ return;
+}
+
+
+/**************************************************************************
+ a c c e p t
+** accept CORE ( c-addr +n1 -- +n2 )
+** Receive a string of at most +n1 characters. An ambiguous condition
+** exists if +n1 is zero or greater than 32,767. Display graphic characters
+** as they are received. A program that depends on the presence or absence
+** of non-graphic characters in the string has an environmental dependency.
+** The editing functions, if any, that the system performs in order to
+** construct the string are implementation-defined.
+**
+** (Although the standard text doesn't say so, I assume that the intent
+** of 'accept' is to store the string at the address specified on
+** the stack.)
+** 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.
+**************************************************************************/
+static void accept(FICL_VM *pVM)
+{+ UNS32 count, len;
+ char *cp;
+ char *pBuf = vmGetInBuf(pVM);
+
+ len = strlen(pBuf);
+ if (len == 0)
+ vmThrow(pVM, VM_RESTART);
+ /* OK - now we have something in the text buffer - use it */
+ count = stackPopUNS32(pVM->pStack);
+ cp = stackPopPtr(pVM->pStack);
+
+ strncpy(cp, vmGetInBuf(pVM), count);
+ len = (count < len) ? count : len;
+ pBuf += len;
+ vmUpdateTib(pVM, pBuf);
+ stackPushUNS32(pVM->pStack, len);
+
+ return;
+}
+
+
+/**************************************************************************
+ a l i g n
+** 6.1.0705 ALIGN CORE ( -- )
+** If the data-space pointer is not aligned, reserve enough space to
+** align it.
+**************************************************************************/
+static void align(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ IGNORE(pVM);
+ dictAlign(dp);
+ return;
+}
+
+
+/**************************************************************************
+ a l i g n e d
+**
+**************************************************************************/
+static void aligned(FICL_VM *pVM)
+{+ void *addr = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, alignPtr(addr));
+ return;
+}
+
+
+/**************************************************************************
+ b e g i n & f r i e n d s
+** Indefinite loop control structures
+** A.6.1.0760 BEGIN
+** Typical use:
+** : X ... BEGIN ... test UNTIL ;
+** or
+** : X ... BEGIN ... test WHILE ... REPEAT ;
+**************************************************************************/
+static void beginCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ markBranch(dp, pVM, beginTag);
+ return;
+}
+
+static void untilCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pIfParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ resolveBackBranch(dp, pVM, beginTag);
+ return;
+}
+
+static void whileCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pIfParen);
+
+ dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ markBranch(dp, pVM, whileTag);
+ twoSwap(pVM);
+ dictAppendUNS32(dp, 1);
+ return;
+}
+
+static void repeatCoIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ assert(pBranchParen);
+ dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
+
+ /* expect "begin" branch marker */
+ resolveBackBranch(dp, pVM, beginTag);
+ /* expect "while" branch marker */
+ resolveForwardBranch(dp, pVM, whileTag);
+ return;
+}
+
+
+/**************************************************************************
+ c h a r & f r i e n d s
+** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
+** Skip leading space delimiters. Parse name delimited by a space.
+** Put the value of its first character onto the stack.
+**
+** bracket-char CORE
+** Interpretation: Interpretation semantics for this word are undefined.
+** Compilation: ( "<spaces>name" -- )
+** Skip leading space delimiters. Parse name delimited by a space.
+** Append the run-time semantics given below to the current definition.
+** Run-time: ( -- char )
+** Place char, the value of the first character of name, on the stack.
+**************************************************************************/
+static void ficlChar(FICL_VM *pVM)
+{+ STRINGINFO si = vmGetWord(pVM);
+ stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0]));
+
+ return;
+}
+
+static void charCoIm(FICL_VM *pVM)
+{+ ficlChar(pVM);
+ literalIm(pVM);
+ return;
+}
+
+/**************************************************************************
+ c h a r P l u s
+** char-plus CORE ( c-addr1 -- c-addr2 )
+** Add the size in address units of a character to c-addr1, giving c-addr2.
+**************************************************************************/
+static void charPlus(FICL_VM *pVM)
+{+ char *cp = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, cp + 1);
+ return;
+}
+
+/**************************************************************************
+ c h a r s
+** chars CORE ( n1 -- n2 )
+** n2 is the size in address units of n1 characters.
+** For most processors, this function can be a no-op. To guarantee
+** portability, we'll multiply by sizeof (char).
+**************************************************************************/
+#if defined (_M_IX86)
+#pragma warning(disable: 4127)
+#endif
+static void ficlChars(FICL_VM *pVM)
+{+ if (sizeof (char) > 1)
+ {+ INT32 i = stackPopINT32(pVM->pStack);
+ stackPushINT32(pVM->pStack, i * sizeof (char));
+ }
+ /* otherwise no-op! */
+ return;
+}
+#if defined (_M_IX86)
+#pragma warning(default: 4127)
+#endif
+
+
+/**************************************************************************
+ c o u n t
+** COUNT CORE ( c-addr1 -- c-addr2 u )
+** Return the character string specification for the counted string stored
+** at c-addr1. c-addr2 is the address of the first character after c-addr1.
+** u is the contents of the character at c-addr1, which is the length in
+** characters of the string at c-addr2.
+**************************************************************************/
+static void count(FICL_VM *pVM)
+{+ FICL_STRING *sp = stackPopPtr(pVM->pStack);
+ stackPushPtr(pVM->pStack, sp->text);
+ stackPushUNS32(pVM->pStack, sp->count);
+ return;
+}
+
+/**************************************************************************
+ e n v i r o n m e n t ?
+** environment-query CORE ( c-addr u -- false | i*x true )
+** c-addr is the address of a character string and u is the string's
+** character count. u may have a value in the range from zero to an
+** implementation-defined maximum which shall not be less than 31. The
+** character string should contain a keyword from 3.2.6 Environmental
+** queries or the optional word sets to be checked for correspondence
+** with an attribute of the present environment. If the system treats the
+** attribute as unknown, the returned flag is false; otherwise, the flag
+** is true and the i*x returned is of the type specified in the table for
+** the attribute queried.
+**************************************************************************/
+static void environmentQ(FICL_VM *pVM)
+{+ FICL_DICT *envp = ficlGetEnv();
+ FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack);
+ char *cp = stackPopPtr(pVM->pStack);
+ FICL_WORD *pFW;
+ STRINGINFO si;
+
+ SI_PSZ(si, cp);
+ pFW = dictLookup(envp, si);
+
+ if (pFW != NULL)
+ {+ vmExecute(pVM, pFW);
+ stackPushINT32(pVM->pStack, FICL_TRUE);
+ }
+ else
+ {+ stackPushINT32(pVM->pStack, FICL_FALSE);
+ }
+
+ return;
+}
+
+/**************************************************************************
+ e v a l u a t e
+** 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.
+** 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.
+**************************************************************************/
+static void evaluate(FICL_VM *pVM)
+{+ UNS32 count = stackPopUNS32(pVM->pStack);
+ char *cp = stackPopPtr(pVM->pStack);
+ UNS32 id;
+
+ IGNORE(count);
+ id = pVM->sourceID;
+ pVM->sourceID = -1;
+ vmPushIP(pVM, &pInterpret);
+ ficlExec(pVM, cp);
+ vmPopIP(pVM);
+ pVM->sourceID = id;
+ return;
+}
+
+
+/**************************************************************************
+ s t r i n g q u o t e
+** Intrpreting: get string delimited by a quote from the input stream,
+** copy to a scratch area, and put its count and address on the stack.
+** Compiling: compile code to push the address and count of a string
+** literal, compile the string from the input stream, and align the dict
+** pointer.
+**************************************************************************/
+static void stringQuoteIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ if (pVM->state == INTERPRET)
+ {+ FICL_STRING *sp = (FICL_STRING *) dp->here;
+ vmGetString(pVM, sp, '\"');
+ stackPushPtr(pVM->pStack, sp->text);
+ stackPushUNS32(pVM->pStack, sp->count);
+ }
+ else /* COMPILE state */
+ {+ dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
+ dictAlign(dp);
+ }
+
+ return;
+}
+
+/**************************************************************************
+ t y p e
+** Pop count and char address from stack and print the designated string.
+**************************************************************************/
+static void type(FICL_VM *pVM)
+{+ UNS32 count = stackPopUNS32(pVM->pStack);
+ char *cp = stackPopPtr(pVM->pStack);
+
+ /*
+ ** Since we don't have an output primitive for a counted string
+ ** (oops), make sure the string is null terminated. If not, copy
+ ** and terminate it.
+ */
+ if (cp[count] != '\0')
+ {+ char *pDest = (char *)ficlGetDict()->here;
+ if (cp != pDest)
+ strncpy(pDest, cp, count);
+
+ pDest[count] = '\0';
+ cp = pDest;
+ }
+
+ vmTextOut(pVM, cp, 0);
+ return;
+}
+
+/**************************************************************************
+ w o r d
+** word CORE ( char "<chars>ccc<char>" -- c-addr )
+** Skip leading delimiters. Parse characters ccc delimited by char. An
+** ambiguous condition exists if the length of the parsed string is greater
+** than the implementation-defined length of a counted string.
+**
+** c-addr is the address of a transient region containing the parsed word
+** as a counted string. If the parse area was empty or contained no
+** characters other than the delimiter, the resulting string has a zero
+** length. A space, not included in the length, follows the string. A
+** program may replace characters within the string.
+** NOTE! Ficl also NULL-terminates the dest string.
+**************************************************************************/
+static void ficlWord(FICL_VM *pVM)
+{+ FICL_STRING *sp = (FICL_STRING *)pVM->pad;
+ char delim = (char)stackPopINT32(pVM->pStack);
+ STRINGINFO si;
+
+ si = vmParseString(pVM, delim);
+
+ if (SI_COUNT(si) > nPAD-1)
+ SI_SETLEN(si, nPAD-1);
+
+ sp->count = (FICL_COUNT)SI_COUNT(si);
+ strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
+ strcat(sp->text, " ");
+
+ stackPushPtr(pVM->pStack, sp);
+ return;
+}
+
+
+/**************************************************************************
+ p a r s e - w o r d
+** ficl PARSE-WORD ( <spaces>name -- c-addr u )
+** Skip leading spaces and parse name delimited by a space. c-addr is the
+** address within the input buffer and u is the length of the selected
+** string. If the parse area is empty, the resulting string has a zero length.
+**************************************************************************/
+static void parseNoCopy(FICL_VM *pVM)
+{+ STRINGINFO si = vmGetWord0(pVM);
+ stackPushPtr(pVM->pStack, SI_PTR(si));
+ stackPushUNS32(pVM->pStack, SI_COUNT(si));
+ return;
+}
+
+
+/**************************************************************************
+ p a r s e
+** CORE EXT ( char "ccc<char>" -- c-addr u )
+** Parse ccc delimited by the delimiter char.
+** c-addr is the address (within the input buffer) and u is the length of
+** the parsed string. If the parse area was empty, the resulting string has
+** a zero length.
+** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
+**************************************************************************/
+static void parse(FICL_VM *pVM)
+{+ char *pSrc = vmGetInBuf(pVM);
+ char *cp;
+ UNS32 count;
+ char delim = (char)stackPopINT32(pVM->pStack);
+
+ cp = pSrc; /* mark start of text */
+
+ while ((*pSrc != delim) && (*pSrc != '\0'))
+ pSrc++; /* find next delimiter or end */
+
+ count = pSrc - cp; /* set length of result */
+
+ if (*pSrc == delim) /* gobble trailing delimiter */
+ pSrc++;
+
+ vmUpdateTib(pVM, pSrc);
+ stackPushPtr(pVM->pStack, cp);
+ stackPushUNS32(pVM->pStack, count);
+ return;
+}
+
+
+/**************************************************************************
+ f i l l
+** CORE ( c-addr u char -- )
+** If u is greater than zero, store char in each of u consecutive
+** characters of memory beginning at c-addr.
+**************************************************************************/
+static void fill(FICL_VM *pVM)
+{+ char ch = (char)stackPopINT32(pVM->pStack);
+ UNS32 u = stackPopUNS32(pVM->pStack);
+ char *cp = (char *)stackPopPtr(pVM->pStack);
+
+ while (u > 0)
+ {+ *cp++ = ch;
+ u--;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ f i n d
+** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
+** Find the definition named in the counted string at c-addr. If the
+** definition is not found, return c-addr and zero. If the definition is
+** found, return its execution token xt. If the definition is immediate,
+** also return one (1), otherwise also return minus-one (-1). For a given
+** string, the values returned by FIND while compiling may differ from
+** those returned while not compiling.
+**************************************************************************/
+static void find(FICL_VM *pVM)
+{+ FICL_STRING *sp = stackPopPtr(pVM->pStack);
+ FICL_WORD *pFW;
+ STRINGINFO si;
+
+ SI_PFS(si, sp);
+ pFW = dictLookup(ficlGetDict(), si);
+ if (pFW)
+ {+ stackPushPtr(pVM->pStack, pFW);
+ stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
+ }
+ else
+ {+ stackPushPtr(pVM->pStack, sp);
+ stackPushUNS32(pVM->pStack, 0);
+ }
+ return;
+}
+
+
+/**************************************************************************
+ f m S l a s h M o d
+** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
+** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
+** Input and output stack arguments are signed. An ambiguous condition
+** exists if n1 is zero or if the quotient lies outside the range of a
+** single-cell signed integer.
+**************************************************************************/
+static void fmSlashMod(FICL_VM *pVM)
+{+ INT64 d1;
+ INT32 n1;
+ INTQR qr;
+
+ n1 = stackPopINT32(pVM->pStack);
+ d1 = i64Pop(pVM->pStack);
+ qr = m64FlooredDivI(d1, n1);
+ stackPushINT32(pVM->pStack, qr.rem);
+ stackPushINT32(pVM->pStack, qr.quot);
+ return;
+}
+
+
+/**************************************************************************
+ s m S l a s h R e m
+** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
+** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
+** Input and output stack arguments are signed. An ambiguous condition
+** exists if n1 is zero or if the quotient lies outside the range of a
+** single-cell signed integer.
+**************************************************************************/
+static void smSlashRem(FICL_VM *pVM)
+{+ INT64 d1;
+ INT32 n1;
+ INTQR qr;
+
+ n1 = stackPopINT32(pVM->pStack);
+ d1 = i64Pop(pVM->pStack);
+ qr = m64SymmetricDivI(d1, n1);
+ stackPushINT32(pVM->pStack, qr.rem);
+ stackPushINT32(pVM->pStack, qr.quot);
+ return;
+}
+
+
+static void ficlMod(FICL_VM *pVM)
+{+ INT64 d1;
+ INT32 n1;
+ INTQR qr;
+
+ n1 = stackPopINT32(pVM->pStack);
+ d1.lo = stackPopINT32(pVM->pStack);
+ i64Extend(d1);
+ qr = m64SymmetricDivI(d1, n1);
+ stackPushINT32(pVM->pStack, qr.rem);
+ return;
+}
+
+
+/**************************************************************************
+ u m S l a s h M o d
+** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
+** Divide ud by u1, giving the quotient u3 and the remainder u2.
+** All values and arithmetic are unsigned. An ambiguous condition
+** exists if u1 is zero or if the quotient lies outside the range of a
+** single-cell unsigned integer.
+*************************************************************************/
+static void umSlashMod(FICL_VM *pVM)
+{+ UNS64 ud;
+ UNS32 u1;
+ UNSQR qr;
+
+ u1 = stackPopUNS32(pVM->pStack);
+ ud = u64Pop(pVM->pStack);
+ qr = ficlLongDiv(ud, u1);
+ stackPushUNS32(pVM->pStack, qr.rem);
+ stackPushUNS32(pVM->pStack, qr.quot);
+ return;
+}
+
+
+/**************************************************************************
+ l s h i f t
+** l-shift CORE ( x1 u -- x2 )
+** Perform a logical left shift of u bit-places on x1, giving x2.
+** Put zeroes into the least significant bits vacated by the shift.
+** An ambiguous condition exists if u is greater than or equal to the
+** number of bits in a cell.
+**
+** r-shift CORE ( x1 u -- x2 )
+** Perform a logical right shift of u bit-places on x1, giving x2.
+** Put zeroes into the most significant bits vacated by the shift. An
+** ambiguous condition exists if u is greater than or equal to the
+** number of bits in a cell.
+**************************************************************************/
+static void lshift(FICL_VM *pVM)
+{+ UNS32 nBits = stackPopUNS32(pVM->pStack);
+ UNS32 x1 = stackPopUNS32(pVM->pStack);
+
+ stackPushUNS32(pVM->pStack, x1 << nBits);
+ return;
+}
+
+
+static void rshift(FICL_VM *pVM)
+{+ UNS32 nBits = stackPopUNS32(pVM->pStack);
+ UNS32 x1 = stackPopUNS32(pVM->pStack);
+
+ stackPushUNS32(pVM->pStack, x1 >> nBits);
+ return;
+}
+
+
+/**************************************************************************
+ m S t a r
+** m-star CORE ( n1 n2 -- d )
+** d is the signed product of n1 times n2.
+**************************************************************************/
+static void mStar(FICL_VM *pVM)
+{+ INT32 n2 = stackPopINT32(pVM->pStack);
+ INT32 n1 = stackPopINT32(pVM->pStack);
+ INT64 d;
+
+ d = m64MulI(n1, n2);
+ i64Push(pVM->pStack, d);
+ return;
+}
+
+
+static void umStar(FICL_VM *pVM)
+{+ UNS32 u2 = stackPopUNS32(pVM->pStack);
+ UNS32 u1 = stackPopUNS32(pVM->pStack);
+ UNS64 ud;
+
+ ud = ficlLongMul(u1, u2);
+ u64Push(pVM->pStack, ud);
+ return;
+}
+
+
+/**************************************************************************
+ m a x & m i n
+**
+**************************************************************************/
+static void ficlMax(FICL_VM *pVM)
+{+ INT32 n2 = stackPopINT32(pVM->pStack);
+ INT32 n1 = stackPopINT32(pVM->pStack);
+
+ stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2);
+ return;
+}
+
+static void ficlMin(FICL_VM *pVM)
+{+ INT32 n2 = stackPopINT32(pVM->pStack);
+ INT32 n1 = stackPopINT32(pVM->pStack);
+
+ stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2);
+ return;
+}
+
+
+/**************************************************************************
+ m o v e
+** CORE ( addr1 addr2 u -- )
+** If u is greater than zero, copy the contents of u consecutive address
+** units at addr1 to the u consecutive address units at addr2. After MOVE
+** completes, the u consecutive address units at addr2 contain exactly
+** what the u consecutive address units at addr1 contained before the move.
+** NOTE! This implementation assumes that a char is the same size as
+** an address unit.
+**************************************************************************/
+static void move(FICL_VM *pVM)
+{+ UNS32 u = stackPopUNS32(pVM->pStack);
+ char *addr2 = stackPopPtr(pVM->pStack);
+ char *addr1 = stackPopPtr(pVM->pStack);
+
+ if (u == 0)
+ return;
+ /*
+ ** Do the copy carefully, so as to be
+ ** correct even if the two ranges overlap
+ */
+ if (addr1 >= addr2)
+ {+ for (; u > 0; u--)
+ *addr2++ = *addr1++;
+ }
+ else
+ {+ addr2 += u-1;
+ addr1 += u-1;
+ for (; u > 0; u--)
+ *addr2-- = *addr1--;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ r e c u r s e
+**
+**************************************************************************/
+static void recurseCoIm(FICL_VM *pVM)
+{+ FICL_DICT *pDict = ficlGetDict();
+
+ IGNORE(pVM);
+ dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
+ return;
+}
+
+
+/**************************************************************************
+ s t o d
+** s-to-d CORE ( n -- d )
+** Convert the number n to the double-cell number d with the same
+** numerical value.
+**************************************************************************/
+static void sToD(FICL_VM *pVM)
+{+ INT32 s = stackPopINT32(pVM->pStack);
+
+ /* sign extend to 64 bits.. */
+ stackPushINT32(pVM->pStack, s);
+ stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0);
+ return;
+}
+
+
+/**************************************************************************
+ s o u r c e
+** CORE ( -- c-addr u )
+** c-addr is the address of, and u is the number of characters in, the
+** input buffer.
+**************************************************************************/
+static void source(FICL_VM *pVM)
+{+ stackPushPtr(pVM->pStack, pVM->tib.cp);
+ stackPushINT32(pVM->pStack, strlen(pVM->tib.cp));
+ return;
+}
+
+
+/**************************************************************************
+ v e r s i o n
+** non-standard...
+**************************************************************************/
+static void ficlVersion(FICL_VM *pVM)
+{+ vmTextOut(pVM, "ficl Version " FICL_VER, 1);
+ return;
+}
+
+
+/**************************************************************************
+ t o I n
+** to-in CORE
+**************************************************************************/
+static void toIn(FICL_VM *pVM)
+{+ stackPushPtr(pVM->pStack, &pVM->tib.index);
+ return;
+}
+
+
+/**************************************************************************
+ d e f i n i t i o n s
+** SEARCH ( -- )
+** Make the compilation word list the same as the first word list in the
+** search order. Specifies that the names of subsequent definitions will
+** be placed in the compilation word list. Subsequent changes in the search
+** order will not affect the compilation word list.
+**************************************************************************/
+static void definitions(FICL_VM *pVM)
+{+ FICL_DICT *pDict = ficlGetDict();
+
+ assert(pDict);
+ if (pDict->nLists < 1)
+ {+ vmThrowErr(pVM, "DEFINITIONS error - empty search order");
+ }
+
+ pDict->pCompile = pDict->pSearch[pDict->nLists-1];
+ return;
+}
+
+
+/**************************************************************************
+ f o r t h - w o r d l i s t
+** SEARCH ( -- wid )
+** Return wid, the identifier of the word list that includes all standard
+** words provided by the implementation. This word list is initially the
+** compilation word list and is part of the initial search order.
+**************************************************************************/
+static void forthWordlist(FICL_VM *pVM)
+{+ FICL_HASH *pHash = ficlGetDict()->pForthWords;
+ stackPushPtr(pVM->pStack, pHash);
+ return;
+}
+
+
+/**************************************************************************
+ g e t - c u r r e n t
+** SEARCH ( -- wid )
+** Return wid, the identifier of the compilation word list.
+**************************************************************************/
+static void getCurrent(FICL_VM *pVM)
+{+ ficlLockDictionary(TRUE);
+ stackPushPtr(pVM->pStack, ficlGetDict()->pCompile);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ g e t - o r d e r
+** SEARCH ( -- widn ... wid1 n )
+** Returns the number of word lists n in the search order and the word list
+** identifiers widn ... wid1 identifying these word lists. wid1 identifies
+** the word list that is searched first, and widn the word list that is
+** searched last. The search order is unaffected.
+**************************************************************************/
+static void getOrder(FICL_VM *pVM)
+{+ FICL_DICT *pDict = ficlGetDict();
+ int nLists = pDict->nLists;
+ int i;
+
+ ficlLockDictionary(TRUE);
+ for (i = 0; i < nLists; i++)
+ {+ stackPushPtr(pVM->pStack, pDict->pSearch[i]);
+ }
+
+ stackPushUNS32(pVM->pStack, nLists);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ s e a r c h - w o r d l i s t
+** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
+** Find the definition identified by the string c-addr u in the word list
+** identified by wid. If the definition is not found, return zero. If the
+** definition is found, return its execution token xt and one (1) if the
+** definition is immediate, minus-one (-1) otherwise.
+**************************************************************************/
+static void searchWordlist(FICL_VM *pVM)
+{+ STRINGINFO si;
+ UNS16 hashCode;
+ FICL_WORD *pFW;
+ FICL_HASH *pHash = stackPopPtr(pVM->pStack);
+
+ si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack);
+ si.cp = stackPopPtr(pVM->pStack);
+ hashCode = hashHashCode(si);
+
+ ficlLockDictionary(TRUE);
+ pFW = hashLookup(pHash, si, hashCode);
+ ficlLockDictionary(FALSE);
+
+ if (pFW)
+ {+ stackPushPtr(pVM->pStack, pFW);
+ stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
+ }
+ else
+ {+ stackPushUNS32(pVM->pStack, 0);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ s e t - c u r r e n t
+** SEARCH ( wid -- )
+** Set the compilation word list to the word list identified by wid.
+**************************************************************************/
+static void setCurrent(FICL_VM *pVM)
+{+ FICL_HASH *pHash = stackPopPtr(pVM->pStack);
+ FICL_DICT *pDict = ficlGetDict();
+ ficlLockDictionary(TRUE);
+ pDict->pCompile = pHash;
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ s e t - o r d e r
+** SEARCH ( widn ... wid1 n -- )
+** Set the search order to the word lists identified by widn ... wid1.
+** Subsequently, word list wid1 will be searched first, and word list
+** widn searched last. If n is zero, empty the search order. If n is minus
+** one, set the search order to the implementation-defined minimum
+** search order. The minimum search order shall include the words
+** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
+** be at least eight.
+**************************************************************************/
+static void setOrder(FICL_VM *pVM)
+{+ int i;
+ int nLists = stackPopINT32(pVM->pStack);
+ FICL_DICT *dp = ficlGetDict();
+
+ if (nLists > FICL_DEFAULT_VOCS)
+ {+ vmThrowErr(pVM, "set-order error: list would be too large");
+ }
+
+ ficlLockDictionary(TRUE);
+
+ if (nLists >= 0)
+ {+ dp->nLists = nLists;
+ for (i = nLists-1; i >= 0; --i)
+ {+ dp->pSearch[i] = stackPopPtr(pVM->pStack);
+ }
+ }
+ else
+ {+ dictResetSearchOrder(dp);
+ }
+
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ w o r d l i s t
+** SEARCH ( -- wid )
+** Create a new empty word list, returning its word list identifier wid.
+** The new word list may be returned from a pool of preallocated word
+** lists or may be dynamically allocated in data space. A system shall
+** allow the creation of at least 8 new word lists in addition to any
+** provided as part of the system.
+** Note: ficl creates a new single-list hash in the dictionary and returns
+** its address.
+**************************************************************************/
+static void wordlist(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_HASH *pHash;
+
+ dictAlign(dp);
+ pHash = (FICL_HASH *)dp->here;
+ dictAllot(dp, sizeof (FICL_HASH));
+
+ pHash->size = 1;
+ hashReset(pHash);
+
+ stackPushPtr(pVM->pStack, pHash);
+ return;
+}
+
+
+/**************************************************************************
+ S E A R C H >
+** ficl ( -- wid )
+** Pop wid off the search order. Error if the search order is empty
+**************************************************************************/
+static void searchPop(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ int nLists;
+
+ ficlLockDictionary(TRUE);
+ nLists = dp->nLists;
+ if (nLists == 0)
+ {+ vmThrowErr(pVM, "search> error: empty search order");
+ }
+ stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ > S E A R C H
+** ficl ( wid -- )
+** Push wid onto the search order. Error if the search order is full.
+**************************************************************************/
+static void searchPush(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+
+ ficlLockDictionary(TRUE);
+ if (dp->nLists > FICL_DEFAULT_VOCS)
+ {+ vmThrowErr(pVM, ">search error: search order overflow");
+ }
+ dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ c o l o n N o N a m e
+** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
+** Create an unnamed colon definition and push its address.
+** Change state to compile.
+**************************************************************************/
+static void colonNoName(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_WORD *pFW;
+ STRINGINFO si;
+
+ SI_SETLEN(si, 0);
+ SI_SETPTR(si, NULL);
+
+ pVM->state = COMPILE;
+ markControlTag(pVM, colonTag);
+ pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
+ stackPushPtr(pVM->pStack, pFW);
+ return;
+}
+
+
+/**************************************************************************
+ u s e r V a r i a b l e
+** user ( u -- ) "<spaces>name"
+** Get a name from the input stream and create a user variable
+** with the name and the index supplied. The run-time effect
+** of a user variable is to push the address of the indexed cell
+** in the running vm's user array.
+**
+** User variables are vm local cells. Each vm has an array of
+** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
+** Ficl's user facility is implemented with two primitives,
+** "user" and "(user)", a variable ("nUser") (in softcore.c) that +** holds the index of the next free user cell, and a redefinition
+** (also in softcore) of "user" that defines a user word and increments
+** nUser.
+**************************************************************************/
+#if FICL_WANT_USER
+static void userParen(FICL_VM *pVM)
+{+ INT32 i = pVM->runningWord->param[0].i;
+ stackPushPtr(pVM->pStack, &pVM->user[i]);
+ return;
+}
+
+
+static void userVariable(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+ CELL c;
+
+ c = stackPop(pVM->pStack);
+ if (c.i >= FICL_USER_CELLS)
+ {+ vmThrowErr(pVM, "Error - out of user space");
+ }
+
+ dictAppendWord2(dp, si, userParen, FW_DEFAULT);
+ dictAppendCell(dp, c);
+ return;
+}
+#endif
+
+
+/**************************************************************************
+ t o V a l u e
+** CORE EXT
+** Interpretation: ( x "<spaces>name" -- )
+** Skip leading spaces and parse name delimited by a space. Store x in
+** name. An ambiguous condition exists if name was not defined by VALUE.
+** NOTE: In ficl, VALUE is an alias of CONSTANT
+**************************************************************************/
+static void toValue(FICL_VM *pVM)
+{+ STRINGINFO si = vmGetWord(pVM);
+ FICL_DICT *dp = ficlGetDict();
+ FICL_WORD *pFW;
+
+#if FICL_WANT_LOCALS
+ FICL_DICT *pLoc = ficlGetLoc();
+ if ((nLocals > 0) && (pVM->state == COMPILE))
+ {+ pFW = dictLookup(pLoc, si);
+ if (pFW)
+ {+ dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
+ dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
+ return;
+ }
+ }
+#endif
+
+ assert(pStore);
+
+ pFW = dictLookup(dp, si);
+ if (!pFW)
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
+ }
+
+ if (pVM->state == INTERPRET)
+ pFW->param[0] = stackPop(pVM->pStack);
+ else /* compile code to store to word's param */
+ {+ stackPushPtr(pVM->pStack, &pFW->param[0]);
+ literalIm(pVM);
+ dictAppendCell(dp, LVALUEtoCELL(pStore));
+ }
+ return;
+}
+
+
+#if FICL_WANT_LOCALS
+/**************************************************************************
+ l i n k P a r e n
+** ( -- )
+** Link a frame on the return stack, reserving nCells of space for
+** locals - the value of nCells is the next cell in the instruction
+** stream.
+**************************************************************************/
+static void linkParen(FICL_VM *pVM)
+{+ INT32 nLink = *(INT32 *)(pVM->ip);
+ vmBranchRelative(pVM, 1);
+ stackLink(pVM->rStack, nLink);
+ return;
+}
+
+
+static void unlinkParen(FICL_VM *pVM)
+{+ stackUnlink(pVM->rStack);
+ return;
+}
+
+
+/**************************************************************************
+ d o L o c a l I m
+** Immediate - cfa of a local while compiling - when executed, compiles
+** code to fetch the value of a local given the local's index in the
+** word's pfa
+**************************************************************************/
+static void getLocalParen(FICL_VM *pVM)
+{+ INT32 nLocal = *(INT32 *)(pVM->ip++);
+ stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
+ return;
+}
+
+
+static void toLocalParen(FICL_VM *pVM)
+{+ INT32 nLocal = *(INT32 *)(pVM->ip++);
+ pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
+ return;
+}
+
+
+static void getLocal0(FICL_VM *pVM)
+{+ stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
+ return;
+}
+
+
+static void toLocal0(FICL_VM *pVM)
+{+ pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
+ return;
+}
+
+
+static void getLocal1(FICL_VM *pVM)
+{+ stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
+ return;
+}
+
+
+static void toLocal1(FICL_VM *pVM)
+{+ pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
+ return;
+}
+
+
+/*
+** Each local is recorded in a private locals dictionary as a
+** word that does doLocalIm at runtime. DoLocalIm compiles code
+** into the client definition to fetch the value of the
+** corresponding local variable from the return stack.
+** The private dictionary gets initialized at the end of each block
+** that uses locals (in ; and does> for example).
+*/
+static void doLocalIm(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]);
+ }
+ else
+ {+
+ if (nLocal == 0)
+ {+ dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
+ }
+ else if (nLocal == 1)
+ {+ dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
+ }
+ else
+ {+ dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(nLocal));
+ }
+ }
+ return;
+}
+
+
+/**************************************************************************
+ l o c a l P a r e n
+** paren-local-paren LOCAL
+** Interpretation: Interpretation semantics for this word are undefined.
+** Execution: ( c-addr u -- )
+** When executed during compilation, (LOCAL) passes a message to the
+** system that has one of two meanings. If u is non-zero,
+** the message identifies a new local whose definition name is given by
+** the string of characters identified by c-addr u. If u is zero,
+** the message is last local and c-addr has no significance.
+**
+** The result of executing (LOCAL) during compilation of a definition is
+** to create a set of named local identifiers, each of which is
+** a definition name, that only have execution semantics within the scope
+** of that definition's source.
+**
+** local Execution: ( -- x )
+**
+** Push the local's value, x, onto the stack. The local's value is
+** initialized as described in 13.3.3 Processing locals and may be
+** changed by preceding the local's name with TO. An ambiguous condition
+** exists when local is executed while in interpretation state.
+**************************************************************************/
+static void localParen(FICL_VM *pVM)
+{+ FICL_DICT *pDict = ficlGetDict();
+ STRINGINFO si;
+ SI_SETLEN(si, stackPopUNS32(pVM->pStack));
+ SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
+
+ if (SI_COUNT(si) > 0)
+ { /* add a local to the dict and update nLocals */+ FICL_DICT *pLoc = ficlGetLoc();
+ if (nLocals >= FICL_MAX_LOCALS)
+ {+ vmThrowErr(pVM, "Error: out of local space");
+ }
+
+ dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
+ dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
+
+ if (nLocals == 0)
+ { /* compile code to create a local stack frame */+ dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
+ stackPushPtr(pVM->pStack, pDict->here);
+ dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ /* compile code to initialize first local */
+ dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
+ }
+ else if (nLocals == 1)
+ {+ dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
+ }
+ else
+ {+ dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ }
+
+ nLocals++;
+ }
+ else if (nLocals > 0)
+ { /* pop address of frame link parameter, set value to nLocals */+ INT32 *pI32 = stackPopPtr(pVM->pStack);
+ *pI32 = nLocals;
+ }
+
+ return;
+}
+
+
+#endif
+/**************************************************************************
+ setParentWid
+** FICL
+** setparentwid ( parent-wid wid -- )
+** Set WID's link field to the parent-wid. search-wordlist will
+** iterate through all the links when finding words in the child wid.
+**************************************************************************/
+static void setParentWid(FICL_VM *pVM)
+{+ FICL_HASH *parent, *child;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ child = (FICL_HASH *)stackPopPtr(pVM->pStack);
+ parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
+
+ child->link = parent;
+ return;
+}
+
+
+/**************************************************************************
+ s e e
+** TOOLS ( "<spaces>name" -- )
+** Display a human-readable representation of the named word's definition.
+** The source of the representation (object-code decompilation, source
+** block, etc.) and the particular form of the display is implementation
+** defined.
+** NOTE: these funcs come late in the file because they reference all
+** of the word-builder funcs without declaring them again. Call me lazy.
+**************************************************************************/
+/*
+** isAFiclWord
+** Vet a candidate pointer carefully to make sure
+** it's not some chunk o' inline data...
+** It has to have a name, and it has to look
+** like it's in the dictionary address range.
+** NOTE: this excludes :noname words!
+*/
+static int isAFiclWord(FICL_WORD *pFW)
+{+ void *pv = (void *)pFW;
+ FICL_DICT *pd = ficlGetDict();
+
+ if (!dictIncludes(pd, pFW))
+ return 0;
+
+ if (!dictIncludes(pd, pFW->name))
+ return 0;
+
+ return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0'));
+}
+
+/*
+** seeColon (for proctologists only)
+** Walks a colon definition, decompiling
+** on the fly. Knows about primitive control structures.
+*/
+static void seeColon(FICL_VM *pVM, CELL *pc)
+{+ for (; pc->p != pSemiParen; pc++)
+ {+ FICL_WORD *pFW = (FICL_WORD *)(pc->p);
+
+ if (isAFiclWord(pFW))
+ {+ if (pFW->code == literalParen)
+ {+ CELL v = *++pc;
+ if (isAFiclWord(v.p))
+ {+ FICL_WORD *pLit = (FICL_WORD *)v.p;
+ sprintf(pVM->pad, " literal %.*s (%#lx)",
+ pLit->nName, pLit->name, v.u);
+ }
+ else
+ sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u);
+ }
+ else if (pFW->code == stringLit)
+ {+ FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
+ pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
+ sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
+ }
+ else if (pFW->code == ifParen)
+ {+ CELL c = *++pc;
+ if (c.i > 0)
+ sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
+ else
+ sprintf(pVM->pad, " until (branch rel %ld)", c.i);
+ }
+ else if (pFW->code == branchParen)
+ {+ CELL c = *++pc;
+ if (c.i > 0)
+ sprintf(pVM->pad, " else (branch rel %ld)", c.i);
+ else
+ sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
+ }
+ else if (pFW->code == qDoParen)
+ {+ CELL c = *++pc;
+ sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
+ }
+ else if (pFW->code == doParen)
+ {+ CELL c = *++pc;
+ sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
+ }
+ else if (pFW->code == loopParen)
+ {+ CELL c = *++pc;
+ sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
+ }
+ else if (pFW->code == plusLoopParen)
+ {+ CELL c = *++pc;
+ sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
+ }
+ else /* default: print word's name */
+ {+ sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name);
+ }
+
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+ else /* probably not a word - punt and print value */
+ {+ sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+ }
+
+ vmTextOut(pVM, ";", 1);
+}
+
+/*
+** Here's the outer part of the decompiler. It's
+** just a big nested conditional that checks the
+** CFA of the word to decompile for each kind of
+** known word-builder code, and tries to do
+** something appropriate. If the CFA is not recognized,
+** just indicate that it is a primitive.
+*/
+static void see(FICL_VM *pVM)
+{+ FICL_DICT *pd = ficlGetDict();
+ FICL_WORD *pFW;
+
+ tick(pVM);
+ pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
+
+ if (pFW->code == colonParen)
+ {+ sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
+ vmTextOut(pVM, pVM->pad, 1);
+ seeColon(pVM, pFW->param);
+ }
+ else if (pFW->code == doDoes)
+ {+ vmTextOut(pVM, "does>", 1);
+ seeColon(pVM, (CELL *)pFW->param->p);
+ }
+ else if (pFW->code == createParen)
+ {+ vmTextOut(pVM, "create", 1);
+ }
+ else if (pFW->code == variableParen)
+ {+ sprintf(pVM->pad, "variable = %ld (%#lx)",
+ pFW->param->i, pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+ else if (pFW->code == userParen)
+ {+ sprintf(pVM->pad, "user variable %ld (%#lx)",
+ pFW->param->i, pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+ else if (pFW->code == constantParen)
+ {+ sprintf(pVM->pad, "constant = %ld (%#lx)",
+ pFW->param->i, pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+ else
+ {+ vmTextOut(pVM, "primitive", 1);
+ }
+
+ if (pFW->flags & FW_IMMEDIATE)
+ {+ vmTextOut(pVM, "immediate", 1);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ c o m p a r e
+** STRING ( c-addr1 u1 c-addr2 u2 -- n )
+** Compare the string specified by c-addr1 u1 to the string specified by
+** c-addr2 u2. The strings are compared, beginning at the given addresses,
+** character by character, up to the length of the shorter string or until a
+** difference is found. If the two strings are identical, n is zero. If the two
+** strings are identical up to the length of the shorter string, n is minus-one
+** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
+** identical up to the length of the shorter string, n is minus-one (-1) if the
+** first non-matching character in the string specified by c-addr1 u1 has a
+** lesser numeric value than the corresponding character in the string specified
+** by c-addr2 u2 and one (1) otherwise.
+**************************************************************************/
+static void compareString(FICL_VM *pVM)
+{+ char *cp1, *cp2;
+ UNS32 u1, u2, uMin;
+ int n = 0;
+
+ vmCheckStack(pVM, 4, 1);
+ u2 = stackPopUNS32(pVM->pStack);
+ cp2 = (char *)stackPopPtr(pVM->pStack);
+ u1 = stackPopUNS32(pVM->pStack);
+ cp1 = (char *)stackPopPtr(pVM->pStack);
+
+ uMin = (u1 < u2)? u1 : u2;
+ for ( ; (uMin > 0) && (n == 0); uMin--)
+ {+ n = (int)(*cp1++ - *cp2++);
+ }
+
+ if (n == 0)
+ n = (int)(u1 - u2);
+
+ if (n < 0)
+ n = -1;
+ else if (n > 0)
+ n = 1;
+
+ stackPushINT32(pVM->pStack, n);
+ return;
+}
+
+
+/**************************************************************************
+ r e f i l l
+** CORE EXT ( -- flag )
+** Attempt to fill the input buffer from the input source, returning a true
+** flag if successful.
+** When the input source is the user input device, attempt to receive input
+** into the terminal input buffer. If successful, make the result the input
+** buffer, set >IN to zero, and return true. Receipt of a line containing no
+** characters is considered successful. If there is no input available from
+** the current input source, return false.
+** When the input source is a string from EVALUATE, return false and
+** perform no other action.
+**************************************************************************/
+static void refill(FICL_VM *pVM)
+{+ INT32 ret = (pVM->sourceID == -1) ? FICL_FALSE : FICL_TRUE;
+ stackPushINT32(pVM->pStack, ret);
+ if (ret)
+ vmThrow(pVM, VM_OUTOFTEXT);
+ return;
+}
+
+
+#if 0
+/**************************************************************************
+
+**
+**************************************************************************/
+static void funcname(FICL_VM *pVM)
+{+ IGNORE(pVM);
+ return;
+}
+
+
+#endif
+/**************************************************************************
+ f i c l C o m p i l e C o r e
+** Builds the primitive wordset and the environment-query namespace.
+**************************************************************************/
+
+void ficlCompileCore(FICL_DICT *dp)
+{+ assert (dp);
+
+ /*
+ ** CORE word set
+ ** see softcore.c for definitions of: abs bl space spaces abort"
+ */
+ pStore =
+ dictAppendWord(dp, "!", store, FW_DEFAULT);
+ dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
+ dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
+ dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
+ dictAppendWord(dp, "\'", tick, FW_DEFAULT);
+ dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);+ dictAppendWord(dp, "*", mul, FW_DEFAULT);
+ dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
+ dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
+ dictAppendWord(dp, "+", add, FW_DEFAULT);
+ dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
+ dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
+ pComma =
+ dictAppendWord(dp, ",", comma, FW_DEFAULT);
+ dictAppendWord(dp, "-", sub, FW_DEFAULT);
+ dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
+ dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
+ dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
+ dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
+ dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
+ dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
+ dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
+ dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
+ dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
+ dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
+ dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
+ dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
+ dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
+ dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
+ dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
+ dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
+ dictAppendWord(dp, ":", colon, FW_DEFAULT);
+ dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "<", isLess, FW_DEFAULT);
+ dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
+ dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
+ dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
+ dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
+ dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
+ dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
+ dictAppendWord(dp, ">r", toRStack, FW_DEFAULT);
+ dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
+ dictAppendWord(dp, "@", fetch, FW_DEFAULT);
+ dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
+ dictAppendWord(dp, "accept", accept, FW_DEFAULT);
+ dictAppendWord(dp, "align", align, FW_DEFAULT);
+ dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
+ dictAppendWord(dp, "allot", allot, FW_DEFAULT);
+ dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
+ dictAppendWord(dp, "base", base, FW_DEFAULT);
+ dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
+ dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
+ dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
+ dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
+ dictAppendWord(dp, "cells", cells, FW_DEFAULT);
+ dictAppendWord(dp, "char", ficlChar, FW_DEFAULT);
+ dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
+ dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
+ dictAppendWord(dp, "constant", constant, FW_DEFAULT);
+ dictAppendWord(dp, "count", count, FW_DEFAULT);
+ dictAppendWord(dp, "cr", cr, FW_DEFAULT);
+ dictAppendWord(dp, "create", create, FW_DEFAULT);
+ dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
+ dictAppendWord(dp, "depth", depth, FW_DEFAULT);
+ dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "drop", drop, FW_DEFAULT);
+ dictAppendWord(dp, "dup", dup, FW_DEFAULT);
+ dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "emit", emit, FW_DEFAULT);
+ dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
+ dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
+ dictAppendWord(dp, "execute", execute, FW_DEFAULT);
+ dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "fill", fill, FW_DEFAULT);
+ dictAppendWord(dp, "find", find, FW_DEFAULT);
+ dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
+ dictAppendWord(dp, "here", here, FW_DEFAULT);
+ dictAppendWord(dp, "hex", hex, FW_DEFAULT);
+ dictAppendWord(dp, "hold", hold, FW_DEFAULT);
+ dictAppendWord(dp, "i", loopICo, FW_COMPILE);
+ dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
+ dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
+ dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
+ dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
+ dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
+ dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
+ dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
+ dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
+ dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
+ dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
+ dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT);
+ dictAppendWord(dp, "move", move, FW_DEFAULT);
+ dictAppendWord(dp, "negate", negate, FW_DEFAULT);
+ dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
+ dictAppendWord(dp, "over", over, FW_DEFAULT);
+ dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "quit", quit, FW_DEFAULT);
+ dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT);
+ dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT);
+ dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "rot", rot, FW_DEFAULT);
+ dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
+ dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
+ dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
+ dictAppendWord(dp, "sign", sign, FW_DEFAULT);
+ dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
+ dictAppendWord(dp, "source", source, FW_DEFAULT);
+ dictAppendWord(dp, "state", state, FW_DEFAULT);
+ dictAppendWord(dp, "swap", swap, FW_DEFAULT);
+ dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
+ pType =
+ dictAppendWord(dp, "type", type, FW_DEFAULT);
+ dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
+ dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
+ dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
+ dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
+ dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
+ dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "variable", variable, FW_DEFAULT);
+ dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
+ dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
+ dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
+ dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
+ /*
+ ** CORE EXT word set...
+ ** see softcore.c for other definitions
+ */
+ dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);+ dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
+ dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "parse", parse, FW_DEFAULT);
+ dictAppendWord(dp, "pick", pick, FW_DEFAULT);
+ dictAppendWord(dp, "roll", roll, FW_DEFAULT);
+ dictAppendWord(dp, "refill", refill, FW_DEFAULT);
+ dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
+ dictAppendWord(dp, "value", constant, FW_DEFAULT);
+ dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
+
+
+ /*
+ ** Set CORE environment query values
+ */
+ ficlSetEnv("/counted-string", FICL_STRING_MAX);+ ficlSetEnv("/hold", nPAD);+ ficlSetEnv("/pad", nPAD);+ ficlSetEnv("address-unit-bits", 8);+ ficlSetEnv("core", FICL_TRUE);+ ficlSetEnv("core-ext", FICL_FALSE);+ ficlSetEnv("floored", FICL_FALSE);+ ficlSetEnv("max-char", UCHAR_MAX);+ ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff );+ ficlSetEnv("max-n", 0x7fffffff);+ ficlSetEnv("max-u", 0xffffffff);+ ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff);+ ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);+ ficlSetEnv("stack-cells", FICL_DEFAULT_STACK);+
+ /*
+ ** LOCAL and LOCAL EXT
+ ** see softcore.c for implementation of locals|
+ */
+#if FICL_WANT_LOCALS
+ pLinkParen =
+ dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
+ pUnLinkParen =
+ dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
+ dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
+ pGetLocalParen =
+ dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
+ pToLocalParen =
+ dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
+ pGetLocal0 =
+ dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
+ pToLocal0 =
+ dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
+ pGetLocal1 =
+ dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
+ pToLocal1 =
+ dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
+ dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
+
+ ficlSetEnv("locals", FICL_TRUE);+ ficlSetEnv("locals-ext", FICL_TRUE);+ ficlSetEnv("#locals", FICL_MAX_LOCALS);+#endif
+
+ /*
+ ** optional SEARCH-ORDER word set
+ */
+ dictAppendWord(dp, ">search", searchPush, FW_DEFAULT);
+ dictAppendWord(dp, "search>", searchPop, FW_DEFAULT);
+ dictAppendWord(dp, "definitions",
+ definitions, FW_DEFAULT);
+ dictAppendWord(dp, "forth-wordlist",
+ forthWordlist, FW_DEFAULT);
+ dictAppendWord(dp, "get-current",
+ getCurrent, FW_DEFAULT);
+ dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT);
+ dictAppendWord(dp, "search-wordlist",
+ searchWordlist, FW_DEFAULT);
+ dictAppendWord(dp, "set-current",
+ setCurrent, FW_DEFAULT);
+ dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
+ dictAppendWord(dp, "wordlist", wordlist, FW_DEFAULT);
+
+ /*
+ ** Set SEARCH environment query values
+ */
+ ficlSetEnv("search-order", FICL_TRUE);+ ficlSetEnv("search-order-ext", FICL_TRUE);+ ficlSetEnv("wordlists", FICL_DEFAULT_VOCS);+
+ /*
+ ** TOOLS and TOOLS EXT
+ */
+ dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
+ dictAppendWord(dp, "bye", bye, FW_DEFAULT);
+ dictAppendWord(dp, "see", see, FW_DEFAULT);
+ dictAppendWord(dp, "words", listWords, FW_DEFAULT);
+
+ /*
+ ** Set TOOLS environment query values
+ */
+ ficlSetEnv("tools", FICL_TRUE);+ ficlSetEnv("tools-ext", FICL_FALSE);+
+ /*
+ ** Ficl extras
+ */
+ dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
+ dictAppendWord(dp, ".hash", dictHashSummary,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, "endif", endifCoIm, FW_COMPIMMED);
+ dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
+ dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
+ dictAppendWord(dp, "wid-set-super",
+ setParentWid, FW_DEFAULT);
+ dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
+ dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
+ dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
+#if FICL_WANT_USER
+ dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
+ dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
+#endif
+ /*
+ ** internal support words
+ */
+ pExitParen =
+ dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
+ pSemiParen =
+ dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
+ pLitParen =
+ dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
+ pStringLit =
+ dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
+ pIfParen =
+ dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
+ pBranchParen =
+ dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
+ pDoParen =
+ dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
+ pDoesParen =
+ dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
+ pQDoParen =
+ dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
+ pLoopParen =
+ dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
+ pPLoopParen =
+ dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
+ pInterpret =
+ dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
+ dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
+ dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
+
+ return;
+}
+