/*
This program is distributed under the terms of the 'MIT license'. The text
of this licence follows...

Copyright (c) 2005 J.D.Medhurst (a.k.a. Tixy)

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
*/

/**
@file

@brief Internal implementation of the forth virtual machine.
*/

/**
@defgroup forth_imp Internal - Internal implementation of the forth virtual machine

@ingroup forth

@version 2005-12-27
	- Fixed various bugs in Forth virtual machine which manifested when <code>sizeof(CELL)</code>
	  was greater than <code>sizeof(CELL*)</code>.
@version 2007-01-13
	- Fixed GCC compilation warnings.
@version 2007-05-28
	- Moved uncaught <code>THROW</Code> handling into new member function ForthVM::UncaughtException.
	  This improves the code generated by GCC.
@{
*/

#include "common.h"
#include "forth.h"

#if 1
#define LITTLE_ENDIAN	/**< Define this when compiling for a little endian target */
#else
#define BIG_ENDIAN		/**< Define this when compiling for a big endian target */
#endif

/**
Size of \a x cells in address untits.
@param x
*/
#define CELLS(x)		((CELL)(((CELL*)256)+(x))-(CELL)((CELL*)256))

/**
Size of \a x chars in address untits.
@param x
*/
#define CHARS(x)		((CELL)(((CHAR*)256)+(x))-(CELL)((CHAR*)256))

/**
Number of cells in \a x address units.
@param x
*/
#define SLASH_CELL(x)	((CELL*)(256+(x))-((CELL*)256))

/**
Number of chars in \a x address units.
@param x
*/
#define SLASH_CHAR(x)	((CHAR*)(256+(x))-((CHAR*)256))

/**
Next aligned cell address equal or higher than address x.
@param x The address to align.
*/
#define ALIGNED(x)		(((x)+CELLS(1)-1)&~(CELLS(1)-1))

/**
Number of bits in a cell.
*/
static const CELL BitsPerCell = BITS_PER_CHAR*CHARS_PER_CELL;

/**
The mask value for the bits in the least significant half of a cell.
I.e. <code> x&CellLoMask </code> will clear the bits on the most significant half of a cell.
*/
static const CELL CellLoMask = ((CELL)1<<(BitsPerCell/2))-1;

/**
Maximum length of a counted string.
*/
static const CELL SlashCountedString = 255;

/**
Value to AND with the length of a words name length in order to remove any flag bits.
This also represents the maximum length a word's name may have.
@see ForthVM::WordFlags
*/
static const CELL NameLengthMask = 31;

/**
Size of the Terminal Input Buffer.
*/
static const CELL NumberTIB = 80;

/**
Size of the \c PAD area.
*/
static const CELL SlashPad = 84;

/**
The size of memory after \c HERE which is used for the transiant buffers used by
pictured numeric output, \c PAD, and \c WORD.
*/
static const CELL DictionaryOverhead = CHARS(SlashCountedString+2+SlashPad);

/**
Maximum number of wordlists in the search order.
*/
static const CELL MaxWordlists = 16;

/**
Size of parameter stack in cells.
*/
static const CELL StackCells = 256;

/**
Size of return stack in cells.
*/
static const CELL ReturnStackCells = 256;


/**
@brief Representation of a forth word's header in the dictionary.
*/
class WordHeader
	{
public:
	/**
	Link to the previous word in the wordlist, this is an address
	offset from 'this'. E.g. to get a pointer to the previous word:
	@code
	WordHeader* word = a_word;
	WordHeader* previous_word = (WordHeader*)((CELL)a_word+Previous);
	@endcode
	If #Previous equals zero then the end of the wordlist has been
	reached and the this header isn't associated with a word definition.
	*/
	CELL Previous;

	/**
	Length of the word's name. This also includes flag values from
	#WordFlags. To mask out these flags, AND the value with #NameLengthMask.
	*/
	CHAR NameLength;

	/**
	The first character of the name. Any subsequent characters follow
	immediately after this one.
	*/
	CHAR Name[1];

	/**
	Bit flags representing the type of a word definition. The flags are present
	in #NameLength.
	*/
	enum WordFlags
		{
		Token		= 1<<5, /**< The words CFA contains its exection token value.
								 (As opposed to a list of execution tokens.) */
		Immediate	= 1<<6,	/**< The word is an \c IMMEDIATE word. */
		Valid		= 1<<7	/**< The word can be found in the dictionary. */
		};

public:
	/**
	Calculate the word's Code Field Address (CFA).
	@return The word's CFA.
	*/
	inline CELL* CFA()
		{ return (CELL*)ALIGNED((CELL)(Name+(NameLength&NameLengthMask))); }
	};


/**
Exception values define by the ANS standard
*/
enum Exception
	{
	DivideByZero = -10,
	ResultOutOfRange = -11,
	UndefinedWord = -13,
	ZeroLengthName = -16,
	PicturedStringOverflow = -17,
	ControlStructureMismatch = -22
	};


/**
@brief Representaion of a forth wordlist.
*/
struct Wordlist
	{
	/**
	Pointer to the WordHeader of the last word defined in this wordlist.
	*/
	CELL LastWord;

	/**
	Pointer to the previous defined wordlist. (Used to form a linked
	list of all wordlists which is needed to implement \c MARKER.) */
	CELL Previous;

	/**
	Pointer to the WordHeader of a word whoes name will be given to this wordlist.
	(Used to implement \c ORDER.)
	*/
	CELL Name;
	};


/**
Values placed on the control stack to indicate the type of control flow nesting value.
*/
enum ControlStackMarkers
	{
	ColonMagic = 12340,	/**< \c colon-sys */
	OrigMagic  = 12341,	/**< \c orig */
	DestMagic  = 12342	/**< \c dest */
	};


/**
Enumeration of forth execution tokens.
*/
enum ForthXT
	{
	XT_STORE,				/**< xt for <code> !   ( x a-addr -- ) </code> */
	XT_NUMBER_SIGN,			/**< xt for <code> #   ( ud1 -- ud2 ) </code> */
	XT_NUMBER_SIGN_GREATER,	/**< xt for <code> #>   ( xd -- c-addr u ) </code> */
	XT_STAR,				/**< xt for <code> *   ( n1|u1 n2|u2 -- n3|u3 ) </code> */
	XT_PLUS,				/**< xt for <code> +   ( n1|u1 n2|u2 -- n3|u3 ) </code> */
	XT_PLUS_STORE,			/**< xt for <code> +!   ( n|u a-addr -- ) </code> */
	XT_PAREN_PLUS_LOOP,		/**< xt for runtime semantics of <code> +LOOP   ( n -- ) ( R: loop-sys1 -- | loop-sys2 ) </code> */
	XT_COMMA,				/**< xt for <code> ,   ( x -- ) </code> */
	XT_MINUS,				/**< xt for <code> -   ( n1|u1 n2|u2 -- n3|u3 ) </code> */
	XT_0_LESS,				/**< xt for <code> 0<   ( n -- flag ) </code> */
	XT_0_EQUALS,			/**< xt for <code> 0=   ( x -- flag ) </code> */
	XT_1_PLUS,				/**< xt for <code> 1+   ( n1|u1 -- n2|u2 ) </code> */
	XT_1_MINUS,				/**< xt for <code> 1-   ( n1|u1 -- n2|u2 ) </code> */
	XT_2_STORE,				/**< xt for <code> 2!   ( x1 x2 a-addr -- ) </code> */
	XT_2_STAR,				/**< xt for <code> 2*   ( x1 -- x2 ) </code> */
	XT_2_SLASH,				/**< xt for <code> 2/   ( x1 -- x2 ) </code> */
	XT_2_FETCH,				/**< xt for <code> 2@   ( a-addr -- x1 x2 ) </code> */
	XT_2DROP,				/**< xt for <code> 2DROP   ( x1 x2 -- ) </code> */
	XT_2DUP,				/**< xt for <code> 2DUP   ( x1 x2 -- x1 x2 x1 x2 ) </code> */
	XT_2OVER,				/**< xt for <code> 2OVER   ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) </code> */
	XT_2SWAP,				/**< xt for <code> 2SWAP   ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) </code> */
	XT_LESS_THAN,			/**< xt for <code> <   ( n1 n2 -- flag ) </code> */
	XT_LESS_NUMBER_SIGN,	/**< xt for <code> <#   ( -- ) </code> */
	XT_EQUALS,				/**< xt for <code> =   ( x1 x2 -- flag ) </code> */
	XT_GREATER_THAN,		/**< xt for <code> >   ( n1 n2 -- flag ) </code> */
	XT_TO_IN,				/**< xt for <code> >IN   ( -- a-addr ) </code> */
	XT_TO_NUMBER,			/**< xt for <code> >NUMBER   ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) </code> */
	XT_TO_R,				/**< xt for <code> >R   ( x -- ) ( R:  -- x ) </code> */
	XT_QUESTION_DUP,		/**< xt for <code> ?DUP   ( x -- 0 | x x ) </code> */
	XT_FETCH,				/**< xt for <code> @   ( a-addr -- x ) </code> */
	XT_ABS,					/**< xt for <code> ABS   ( n -- u ) </code> */
	XT_ACCEPT,				/**< xt for <code> ACCEPT   ( c-addr +n1 -- +n2 ) </code> */
	XT_ALIGN,				/**< xt for <code> ALIGN   ( -- ) </code> */
	XT_ALIGNED,				/**< xt for <code> ALIGNED   ( addr -- a-addr ) </code> */
	XT_ALLOT,				/**< xt for <code> ALLOT   ( n -- ) </code> */
	XT_AND,					/**< xt for <code> AND   ( x1 x2 -- x3 ) </code> */
	XT_BASE,				/**< xt for <code> BASE   ( -- a-addr ) </code> */
	XT_C_STORE,				/**< xt for <code> C!   ( char c-addr -- ) </code> */
	XT_C_COMMA,				/**< xt for <code> C,   ( char -- ) </code> */
	XT_C_FETCH,				/**< xt for <code> C@   ( c-addr -- char ) </code> */
	XT_CELL_PLUS,			/**< xt for <code> CELL+   ( a-addr1 -- a-addr2 ) </code> */
	XT_CELLS,				/**< xt for <code> CELLS   ( n1 -- n2 ) </code> */
	XT_CHAR_PLUS,			/**< xt for <code> CHAR+   ( c-addr1 -- c-addr2 ) </code> */
	XT_CHARS,				/**< xt for <code> CHARS   ( n1 -- n2 ) </code> */
	XT_PAREN_CONSTANT,		/**< xt for runtime semantics of words defined with <code> CONSTANT   ( -- x ) </code> */
	XT_COUNT,				/**< xt for <code> COUNT   ( c-addr1 -- c-addr2 u ) </code> */
	XT_DEPTH,				/**< xt for <code> DEPTH   ( -- +n ) </code> */
	XT_PAREN_DO,			/**< xt for runtime semantics of <code> DO   ( n1|u1 n2|u2 -- ) ( R: -- loop-sys ) </code> */
	XT_DROP,				/**< xt for <code> DROP   ( x -- ) </code> */
	XT_DUP,					/**< xt for <code> DUP   ( x -- x x ) </code> */
	XT_PAREN_BRANCH,		/**< xt for un-conditional branch as compiled by <code> REPEAT   ( -- ) </code> */
	XT_EMIT,				/**< xt for <code> EMIT   ( x -- ) </code> */
	XT_EXECUTE,				/**< xt for <code> EXECUTE   ( i*x xt -- j*x ) </code> */
	XT_EXIT,				/**< xt for <code> EXIT   ( -- ) ( R: nest-sys -- ) </code> */
	XT_FILL,				/**< xt for <code> FILL   ( c-addr u char -- ) </code> */
	XT_HERE,				/**< xt for <code> HERE   ( -- addr ) </code> */
	XT_HOLD,				/**< xt for <code> HOLD   ( char -- ) </code> */
	XT_I,					/**< xt for <code> I   ( -- n|u ) ( R:  loop-sys -- loop-sys ) </code> */
	XT_PAREN_0BRANCH,		/**< xt for conditional branch as compiled by <code> IF   ( x -- ) </code> */
	XT_INVERT,				/**< xt for <code> INVERT   ( x1 -- x2 ) </code> */
	XT_J,					/**< xt for <code> J   ( -- n|u ) ( R: loop-sys1 loop-sys2 -- loop-sys1 loop-sys2 ) </code> */
	XT_KEY,					/**< xt for <code> KEY   ( -- char ) </code> */
	XT_LEAVE,				/**< xt for <code> LEAVE   ( -- ) ( R: loop-sys -- ) </code> */
	XT_PAREN_LITERAL,		/**< xt for runtime semantics of <code> LITERAL   ( -- x ) </code> */
	XT_PAREN_LOOP,			/**< xt for runtime semantics of <code> LOOP   ( -- ) ( R:  loop-sys1 --  | loop-sys2 ) </code> */
	XT_LSHIFT,				/**< xt for <code> LSHIFT   ( x1 u -- x2 ) </code> */
	XT_MAX,					/**< xt for <code> MAX   ( n1 n2 -- n3 ) </code> */
	XT_MIN,					/**< xt for <code> MIN   ( n1 n2 -- n3 ) </code> */
	XT_MOVE,				/**< xt for <code> MOVE   ( addr1 addr2 u -- ) </code> */
	XT_NEGATE,				/**< xt for <code> NEGATE   ( n1 -- n2 ) </code> */
	XT_OR,					/**< xt for <code> OR   ( x1 x2 -- x3 ) </code> */
	XT_OVER,				/**< xt for <code> OVER   ( x1 x2 -- x1 x2 x1 ) </code> */
	XT_R_FROM,				/**< xt for <code> R>   ( -- x ) ( R:  x -- ) </code> */
	XT_R_FETCH,				/**< xt for <code> R@   ( -- x ) ( R:  x -- x ) </code> */
	XT_ROT,					/**< xt for <code> ROT   ( x1 x2 x3 -- x2 x3 x1 ) </code> */
	XT_RSHIFT,				/**< xt for <code> RSHIFT   ( x1 u -- x2 ) </code> */
	XT_S_TO_D,				/**< xt for <code> S>D   ( n -- d ) </code> */
	XT_SIGN,				/**< xt for <code> SIGN   ( n -- ) </code> */
	XT_SPACE,				/**< xt for <code> SPACE   ( -- ) </code> */
	XT_STATE,				/**< xt for <code> STATE   ( -- a-addr ) </code> */
	XT_SWAP,				/**< xt for <code> SWAP   ( x1 x2 -- x2 x1 ) </code> */
	XT_TYPE,				/**< xt for <code> TYPE   ( c-addr u -- ) </code> */
	XT_U_LESS_THAN,			/**< xt for <code> U<   ( u1 u2 -- flag ) </code> */
	XT_UM_STAR,				/**< xt for <code> UM*   ( u1 u2 -- ud ) </code> */
	XT_UNLOOP,				/**< xt for <code> UNLOOP   ( -- ) ( R: loop-sys -- ) </code> */
	XT_XOR,					/**< xt for <code> XOR   ( x1 x2 -- x3 ) </code> */
	XT_LEFT_BRACKET,		/**< xt for <code> [   ( -- ) </code> */
	XT_RIGHT_BRACKET,		/**< xt for <code> ]   ( -- ) </code> */

	XT_0_NOT_EQUALS,		/**< xt for <code> 0<>   ( x -- flag ) </code> */
	XT_0_GREATER,			/**< xt for <code> 0>   ( x -- flag ) </code> */
	XT_2_TO_R,				/**< xt for <code> 2>R   ( x1 x2 -- ) ( R:  -- x1 x2 ) </code> */
	XT_2_R_FROM,			/**< xt for <code> 2R>   ( -- x1 x2 ) ( R:  x1 x2 -- ) </code> */
	XT_2_R_FETCH,			/**< xt for <code> 2R@   ( -- x1 x2 ) ( R:  x1 x2 -- x1 x2 ) </code> */
	XT_NOT_EQUALS,			/**< xt for <code> <>   ( x1 x2 -- flag ) </code> */
	XT_PAREN_QUESTION_DO,	/**< xt for runtime semantics of <code> ?DO   ( n1|u1 n2|u2 -- ) ( R: --  | loop-sys ) </code> */
	XT_ERASE,				/**< xt for <code> ERASE   ( addr u -- ) </code> */
	XT_FALSE,				/**< xt for <code> FALSE   ( -- false ) </code> */
	XT_NIP,					/**< xt for <code> NIP   ( x1 x2 -- x2 ) </code> */
	XT_PAD,					/**< xt for <code> PAD   ( -- a-addr ) </code> */
	XT_PARSE,				/**< xt for <code> PARSE   ( char "ccc<char>" -- c-addr u ) </code> */
	XT_PICK,				/**< xt for <code> PICK   ( xu ... x1 x0 u -- xu ... x1 x0 xu ) </code> */
	XT_ROLL,				/**< xt for <code> ROLL   ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) </code> */
	XT_TRUE,				/**< xt for <code> TRUE   ( -- true ) </code> */
	XT_TUCK,				/**< xt for <code> TUCK   ( x1 x2 -- x2 x1 x2 ) </code> */
	XT_U_GREATER_THAN,		/**< xt for <code> U>   ( u1 u2 -- flag ) </code> */
	XT_UNUSED,				/**< xt for <code> UNUSED   ( -- u ) </code> */

	XT_D_PLUS,				/**< xt for <code> D+   ( d1|ud1 d2|ud2 -- d3|ud3 ) </code> */
	XT_DABS,				/**< xt for <code> DABS   ( d -- ud ) </code> */
	XT_DNEGATE,				/**< xt for <code> DNEGATE   ( d1 -- d2 ) </code> */
	XT_M_PLUS,				/**< xt for <code> M+   ( d1|ud1 n -- d2|ud2 ) </code> */

	XT_CATCH,				/**< xt for <code> CATCH   ( i*x xt -- j*x 0 | i*x n ) </code> */
	XT_THROW,				/**< xt for <code> THROW   ( k*x n -- k*x | i*x n ) </code> */

	XT_CMOVE,				/**< xt for <code> CMOVE   ( c-addr1 c-addr2 u -- ) </code> */
	XT_CMOVE_UP,			/**< xt for <code> CMOVE>   ( c-addr1 c-addr2 u -- ) </code> */

	XT_BREAKPOINT,
	XT_END,
	XT_CATCH_END,
	XT_EXCEPTION_MESSAGE,
	XT_CODE_EXECUTE,

	XT_UDM_SLASH_MOD,
	XT_RDROP,

	XT_EMPTYS,
	XT_EMPTYR,
	XT_TIB,
	XT_PAREN_SOURCE,
	XT_CONTEXT,
	XT_CURRENT,
	XT_LATEST,
	XT_FORTH_WORDLIST,
	XT_PARSE_WORD,
	XT_PAREN_SEARCH_WORDLIST,
	XT_TO_CFA,
	XT_PAREN_CR
	};

/**
Macro for an unconditional branch. I.e. the execution sematics of \c AGAIN .
@param offset	Offset, in cells, to the target of the branch.
				The xt following this branch has an offset of one.
		
*/
#define XT_BRANCH(offset) XT_PAREN_BRANCH,CELLS(offset)

/**
Macro for an conditional branch. I.e. the execution sematics of \c IF .
@param offset	Offset, in cells, to the target of the branch.
				The xt following this branch has an offset of one.
		
*/
#define XT_0BRANCH(offset) XT_PAREN_0BRANCH,CELLS(offset)

/**
Macro for construction the execution semantics of \c LITERAL .
@param x The value which will be placed on the stack when these execution
		 semantics are performed.
*/
#define LIT(x) XT_PAREN_LITERAL,(CELL)x


/** Definition of non standard forth word. <PRE>
: NEST-CHECK   ( C: x1 -- ) ( x2 -- )   \ Check control structure nesting value x1 equals x2.
   = IF EXIT THEN -22 THROW
;
</PRE> */
static const CELL XT_NEST_CHECK[] =
	{
	XT_EQUALS, XT_0BRANCH(2), XT_EXIT,						// = IF EXIT THEN
	LIT(ControlStructureMismatch), XT_THROW					// -22 THROW
	};


/** Definition of non standard forth word. <PRE>
: >BRANCH,   ( C: -- orig ) ( xt -- )   \ Compile a forwards branch of type specified by xt.
    , HERE 0 , OrigMagic 
;
</PRE> */
static const CELL XT_FORWARD_BRANCH_COMMA[] =
	{
	XT_COMMA, XT_HERE, XT_FALSE, XT_COMMA,					// , HERE 0 , 
	LIT(OrigMagic), XT_EXIT									// OrigMagic 
	};


/** Definition of non standard forth word. <PRE>
: <BRANCH,   ( C: dest -- ) ( xt -- )   \ Compile a backwards branch of type specified by xt.
    , DestMagic NEST-CHECK HERE - ,
;
</PRE> */
static const CELL XT_BACKWARD_BRANCH_COMMA[] =
	{
	XT_COMMA, LIT(DestMagic), (CELL)XT_NEST_CHECK,			// , DestMagic NEST-CHECK
	XT_HERE, XT_MINUS, XT_COMMA, XT_EXIT					// HERE - ,
	};


/** Definition of ANS forth word.<PRE>
: IF   ( C: -- orig )
    ['] (0branch) >BRANCH,
; IMMEDIATE
</PRE> */
static const CELL XT_IF[] =
	{
	LIT(XT_PAREN_0BRANCH), (CELL)XT_FORWARD_BRANCH_COMMA,	// ['] (0branch) >BRANCH,
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: AHEAD   ( C: -- orig )
    ['] (branch) >BRANCH,
; IMMEDIATE
</PRE> */
static const CELL XT_AHEAD[] =
	{
	LIT(XT_PAREN_BRANCH), (CELL)XT_FORWARD_BRANCH_COMMA,	// ['] (branch) >BRANCH, 
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: THEN   ( C: orig -- )
    OrigMagic NEST-CHECK
    HERE OVER - SWAP !
; IMMEDIATE
</PRE> */
static const CELL XT_THEN[] =
	{
	LIT(OrigMagic), (CELL)XT_NEST_CHECK,					// OrigMagic NEST-CHECK
	XT_HERE, XT_OVER, XT_MINUS, XT_SWAP, XT_STORE, XT_EXIT	// HERE OVER - SWAP !
	};


/** Definition of ANS forth word.<PRE>
: BEGIN   ( C: -- dest )
    HERE DestMagic
; IMMEDIATE
</PRE> */
static const CELL XT_BEGIN[] =
	{
	XT_HERE, LIT(DestMagic), XT_EXIT						// HERE DestMagic
	};


/** Definition of ANS forth word.<PRE>
: AGAIN   ( C: dest -- )
    ['] (branch) <BRANCH,
; IMMEDIATE
</PRE> */
static const CELL XT_AGAIN[] =
	{
	LIT(XT_PAREN_BRANCH), (CELL)XT_BACKWARD_BRANCH_COMMA,	// ['] (branch) <BRANCH,
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: UM/MOD   ( ud u1 -- u2 u3 )
    DUP 0= IF -10 THROW THEN
    UDM/MOD
    IF -11 THROW THEN
;
</PRE> */
static const CELL XT_UM_SLASH_MOD[] =
	{
	XT_DUP, XT_0_EQUALS, XT_0BRANCH(4),						// DUP 0= IF
	LIT(DivideByZero), XT_THROW,							// -10 THROW THEN
	XT_UDM_SLASH_MOD, XT_0BRANCH(4),						// UDM/MOD IF
	LIT(ResultOutOfRange), XT_THROW,						// -11 THROW THEN
	XT_EXIT
	};


/** Definition of non standard forth word. <PRE>
: CHECK-NEG   ( n -- n )  
    \ If n is greater than zero, throw -11 (result out of range)
    DUP 0> IF -11 THROW THEN
;
</PRE> */
static const CELL XT_CHECK_NEG[] =
	{
	XT_DUP, XT_0_GREATER, XT_0BRANCH(4),					// DUP 0> IF 
	LIT(ResultOutOfRange), XT_THROW, XT_EXIT				// -11 THROW THEN
	};


/** Definition of non standard forth word. <PRE>
: CHECK-POS   ( n -- n )  
    \ If n is less than zero, throw -11 (result out of range)
    DUP 0< IF -11 THROW THEN
;
</PRE> */
static const CELL XT_CHECK_POS[] = // ( n -- n )
	{
	XT_DUP, XT_0_LESS, XT_0BRANCH(4),						// DUP 0< IF 
	LIT(ResultOutOfRange), XT_THROW, XT_EXIT				// -11 THROW THEN
	};


/** Definition of ANS forth word.<PRE>
: SM/REM   ( d1 n1 -- n2 n3 )
    OVER >R 2DUP XOR >R
    ABS >R DABS R>
    UM/MOD
    R> 0<
    IF NEGATE CHECK-NEG
    ELSE CHECK-POS
    THEN
    SWAP R> 0< IF NEGATE THEN
    SWAP
;
</PRE> */
static const CELL XT_SM_SLASH_REM[] =
	{
	XT_OVER, XT_TO_R, XT_2DUP, XT_XOR, XT_TO_R,				// OVER >R 2DUP XOR >R
	XT_ABS, XT_TO_R, XT_DABS, XT_R_FROM, 					// ABS >R DABS R>
	(CELL)XT_UM_SLASH_MOD,									// UM/MOD
	XT_R_FROM, XT_0_LESS, XT_0BRANCH(5),					// R> 0< IF
	XT_NEGATE, (CELL)XT_CHECK_NEG, XT_BRANCH(2),			// NEGATE CHECK-NEG ELSE 
	(CELL)XT_CHECK_POS,										// CHECK-POS THEN
	XT_SWAP, XT_R_FROM, XT_0_LESS, XT_0BRANCH(2),			// SWAP R> 0< IF
	XT_NEGATE, XT_SWAP, XT_EXIT								// NEGATE THEN SWAP
	};


/** Definition of ANS forth word.<PRE>
: FM/MOD   ( d1 n1 -- n2 n3 )
    DUP >R 2DUP XOR >R
    ABS >R DABS R>
    UM/MOD
    R> 0<
    IF NEGATE CHECK-NEG OVER
        IF 1- CHECK-NEG R@ ABS ROT - SWAP
        THEN
    ELSE CHECK-POS
    THEN
    SWAP R> 0< IF NEGATE THEN SWAP
;
</PRE> */
static const CELL XT_FM_SLASH_MOD[] =
	{
	XT_DUP, XT_TO_R, XT_2DUP, XT_XOR, XT_TO_R,				// DUP >R 2DUP XOR >R
	XT_ABS, XT_TO_R, XT_DABS, XT_R_FROM, 					// ABS >R DABS R>
	(CELL)XT_UM_SLASH_MOD,									// UM/MOD
	XT_R_FROM, XT_0_LESS, XT_0BRANCH(15),					// R> 0< IF
	XT_NEGATE, (CELL)XT_CHECK_NEG, XT_OVER, XT_0BRANCH(11),	// NEGATE CHECK-NEG OVER IF
	XT_1_MINUS, (CELL)XT_CHECK_NEG, XT_R_FETCH, XT_ABS,		// 1- CHECK-NEG R@ ABS
	XT_ROT, XT_MINUS, XT_SWAP, XT_BRANCH(2),				// ROT - SWAP THEN ELSE
	(CELL)XT_CHECK_POS,										// CHECK-POS THEN
	XT_SWAP, XT_R_FROM, XT_0_LESS, XT_0BRANCH(2),			// SWAP R> 0< IF
	XT_NEGATE, XT_SWAP, XT_EXIT								// NEGATE THEN SWAP
	};


/** Definition of non standard forth word. <PRE>
: M/MOD   ( d1 n1 -- n2 n3 )
    \ If the system uses floored division, execute FM/MOD
    \ otherwise execute SM/MOD
;
</PRE> */
#define XT_M_SLASH_MOD (((-1)/2) ? (CELL)XT_FM_SLASH_MOD : (CELL)XT_SM_SLASH_REM)


/** Definition of ANS forth word.<PRE>
: /MOD   ( n1 n2 -- n3 n4 )
    >R S>D R> M/MOD
;
</PRE> */
static const CELL XT_SLASH_MOD[] =
	{
	XT_TO_R, XT_S_TO_D, XT_R_FROM, XT_M_SLASH_MOD, XT_EXIT	// >R S>D R> M/MOD
	};


/** Definition of ANS forth word.<PRE>
: M*   ( n1 n2 -- d )
    2DUP XOR >R ABS SWAP ABS
    UM* R> 0< IF DNEGATE THEN
;
</PRE> */
static const CELL XT_M_STAR[] =
	{
	XT_2DUP, XT_XOR, XT_TO_R, XT_ABS, XT_SWAP, XT_ABS,		// 2DUP XOR >R ABS SWAP ABS
	XT_UM_STAR, XT_R_FROM, XT_0_LESS,						// UM* R> 0<
	XT_0BRANCH(2), XT_DNEGATE, XT_EXIT						// IF DNEGATE THEN
	};


/** Definition of ANS forth word.<PRE>
: * /MOD   ( n1 n2 n3 -- n4 n5 )
    >R M* R> M/MOD
;
</PRE> */
static const CELL XT_STAR_SLASH_MOD[] =
	{
	XT_TO_R, (CELL)XT_M_STAR, XT_R_FROM, XT_M_SLASH_MOD,	// >R M* R> M/MOD
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: \#S   ( ud1 -- ud2 )
    BEGIN # 2DUP OR 0= UNTIL
;
</PRE> */
static const CELL XT_NUMBER_SIGN_S[] =
	{
	XT_NUMBER_SIGN, XT_2DUP, XT_OR, XT_0_EQUALS,			// BEGIN # 2DUP OR 0=
	XT_0BRANCH(-5), XT_EXIT									// UNTIL
	};


/** Definition of ANS forth word.<PRE>
: D.   ( d -- )
    <# BL HOLD
    DUP >R DABS \#S R> SIGN 
    #> TYPE 
;
</PRE> */
static const CELL XT_D_DOT[] =
	{
	XT_LESS_NUMBER_SIGN, LIT(' '),							// <# BL
	XT_HOLD, XT_DUP, XT_TO_R, XT_DABS,						// HOLD DUP >R DABS 
	(CELL)XT_NUMBER_SIGN_S, XT_R_FROM, XT_SIGN,				// #S R> SIGN 
	XT_NUMBER_SIGN_GREATER, XT_TYPE, XT_EXIT				// #> TYPE 
	};


/** Definition of ANS forth word.<PRE>
: .   ( n -- )
    S>D D.
;
</PRE> */
static const CELL XT_DOT[] =
	{
	XT_S_TO_D, (CELL)XT_D_DOT, XT_EXIT						// S>D D.
	};


/** Definition of ANS forth word.<PRE>
: CR   ( -- )
    (cr) TYPE
;
</PRE> */
static const CELL XT_CR[] =
	{
	XT_PAREN_CR, XT_TYPE, XT_EXIT							// (cr) TYPE
	};


/** Definition of non standard forth word. <PRE>
: CREATE-WORD   ( c-addr u -- )

    \ Create a dictionary entry for a word named by the string c-addr u.
    \ This entry cannot be found until VALIDATE is called.

    OVER 0<> OVER 0> INVERT AND IF -16 THROW THEN   \ check address and length are valid
    NameLengthMask MIN                              \ truncate name to maximum
    ALIGN HERE >R                                   \ get location to store word's header
    CURRENT @                                       \ get current wordlist
    DUP @ R@ - ,                                    \ write link field
    R@ SWAP !                                       \ update current wordlist
    DUP C,                                          \ write name length
    BEGIN DUP                                       \ write each character in name...
    WHILE OVER C@ C, SWAP CHAR+ SWAP 1-
    REPEAT 
    2DROP ALIGN                                     \ tidy up
    R> LATEST !                                     \ update LATEST to point to new word
;
</PRE> */
static const CELL XT_CREATE_WORD[] =
	{
	XT_OVER, XT_0_NOT_EQUALS,									// OVER 0<>
	XT_OVER, XT_0_GREATER, XT_INVERT, XT_AND,					// OVER 0> INVERT AND
	XT_0BRANCH(4), LIT(ZeroLengthName), XT_THROW,				// IF -16 THROW THEN
	LIT(NameLengthMask), XT_MIN,								// NameLengthMask MIN 
	XT_ALIGN, XT_HERE, XT_TO_R,									// ALIGN HERE >R

	XT_CURRENT, XT_FETCH,										// CURRENT @
	XT_DUP, XT_FETCH, XT_R_FETCH, XT_MINUS, XT_COMMA,			// DUP @ R@ - ,
	XT_R_FETCH, XT_SWAP, XT_STORE,								// R@ SWAP !

	XT_DUP, XT_C_COMMA,											// DUP C,
	XT_DUP, XT_0BRANCH(10), XT_OVER, XT_C_FETCH, XT_C_COMMA,	// BEGIN DUP WHILE OVER C@ C,
	XT_SWAP, XT_CHAR_PLUS, XT_SWAP, XT_1_MINUS, XT_BRANCH(-11),	// SWAP CHAR+ SWAP 1- REPEAT 
	XT_2DROP, XT_ALIGN, XT_R_FROM, XT_LATEST, XT_STORE,			// 2DROP ALIGN R> LATEST ! ;
	XT_EXIT
	};


/** Definition of non standard forth word. <PRE>
: VALIDATE   ( -- )   \ Mark latest word as valid (findable).
    WordValid
    LATEST @ >FLAGS 
    TUCK C@ OR SWAP C!
;
</PRE> */
static const CELL XT_VALIDATE[] =
	{
	LIT(WordHeader::Valid),									// WordValid
	XT_LATEST, XT_FETCH, XT_CELL_PLUS,						// LATEST @ >FLAGS 
	XT_TUCK, XT_C_FETCH,									// TUCK C@
	XT_OR, XT_SWAP, XT_C_STORE,								// OR SWAP C!
	XT_EXIT
	};


/** Definition of runtime semantics for words defined with ANS forth word \c CREATE
<PRE>
: (create)   ( -- a-addr )
    R>
;
</PRE> */
static const CELL XT_PAREN_CREATE[] =
	{
	XT_R_FROM, XT_EXIT										// R>
	};


/** Definition of ANS forth word.<PRE>
: CREATE   ( "<spaces>name" -- )
    PARSE-WORD CREATE-WORD POSTPONE (create) VALIDATE 
;
</PRE> */
static const CELL XT_CREATE[] =
	{
	XT_PARSE_WORD, (CELL)XT_CREATE_WORD,					// PARSE-WORD CREATE-WORD
	LIT(XT_PAREN_CREATE), XT_COMMA,							// POSTPONE (create)
	(CELL)XT_VALIDATE, XT_EXIT								// VALIDATE 
	};


/** Definition of runtime semantics for ANS forth word \c DOES>
<PRE>
: (does>)   ( -- ) ( R: nest-sys1 -- )
    R> LATEST @ >CFA !
;
</PRE> */
static const CELL XT_PAREN_DOES[] = 
	{
	XT_R_FROM, XT_LATEST, XT_FETCH, XT_TO_CFA, XT_STORE, 	// R> LATEST @ >CFA !
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: LITERAL   ( x -- )
    ['] (literal) , ,
;
</PRE> */
static const CELL XT_LITERAL[] =
	{
	LIT(XT_PAREN_LITERAL), XT_COMMA, XT_COMMA,				// ['] (literal) , ,
	XT_EXIT
	};


/** Definition of runtime semantics for ANS forth word \c S"
<PRE>
: (s")   ( -- c-addr u )
    R@ CELL+ R> @
    2DUP CHARS + ALIGNED >R
;
</PRE> */
static const CELL XT_PAREN_S_QUOTE[] =
	{
	XT_R_FETCH, XT_CELL_PLUS, XT_R_FROM, XT_FETCH,			// R@ CELL+ R> @
	XT_2DUP, XT_CHARS, XT_PLUS, XT_ALIGNED, XT_TO_R,		// 2DUP CHARS + ALIGNED >R
	XT_EXIT
	};


/** Definition of ANS forth word.<PRE>
: S"   ( "ccc<quote>" -- )
    [CHAR] " PARSE 
    POSTPONE (s")
    DUP ,
    HERE SWAP DUP CHARS ALLOT ALIGN CMOVE
;
</PRE> */
static const CELL XT_S_QUOTE[] = 
	{
	LIT('"'), XT_PARSE,										// [CHAR] " PARSE 
	LIT(XT_PAREN_S_QUOTE), XT_COMMA,						// POSTPONE (s")
	XT_DUP, XT_COMMA, XT_HERE, XT_SWAP,						// DUP , HERE SWAP
	XT_DUP, XT_CHARS, XT_ALLOT, XT_ALIGN, XT_CMOVE, XT_EXIT	// DUP CHARS ALLOT ALIGN CMOVE
	};


/** Definition of ANS forth word.<PRE>
: CHAR   ( "<spaces>name" -- char )
    PARSE-WORD IF C@ EXIT THEN DROP FALSE
;
</PRE> */
static const CELL XT_CHAR[] = 
	{
	XT_PARSE_WORD, XT_0BRANCH(3), XT_C_FETCH, XT_EXIT,		// PARSE-WORD IF C@ EXIT THEN 
	XT_DROP, XT_FALSE, XT_EXIT								// DROP FALSE
	};


/** Definition of non standard forth word. <PRE>
: (find)   ( c-addr u -- xt flag header | c-addr u 0 )

    \ Find the defination named by the string c-addr u.
    \ If the definition is not found return c-addr u and zero.
    \ If the definition is found, return its execution token xt,
    \ a flag which is true if the word is immediate, and it's header address.

    CONTEXT @ 0                         \ loop through number of wordlists in CONTEXT
    DO
        CONTEXT I 1+ CELLS +            \ get pointer to next wordlist
        @ (search-wordlist)             \ search this wordlist
        ?DUP IF UNLOOP EXIT THEN        \ exit if found
    LOOP
    FALSE                               \ return FALSE for words not found
;
</PRE> */
static const CELL XT_PAREN_FIND[] =
	{
	XT_CONTEXT, XT_FETCH, XT_FALSE,							// CONTEXT @ 0 
	XT_PAREN_QUESTION_DO, CELLS(15),						// DO
	XT_CONTEXT, XT_I, XT_1_PLUS, XT_CELLS, XT_PLUS,			// CONTEXT I 1+ CELLS +
	XT_FETCH, XT_PAREN_SEARCH_WORDLIST,						// @ (search-wordlist)
	XT_QUESTION_DUP, XT_0BRANCH(3), XT_UNLOOP, XT_EXIT,		// ?DUP IF UNLOOP EXIT THEN
	XT_PAREN_LOOP, CELLS(-13), XT_FALSE, XT_EXIT			// LOOP FALSE
	};


/** Definition of non standard forth word. <PRE>
: THROW"   ( c-addr u x -- )   \ Throw execption x with message string c-addr u
    >R EXCEPTION-MESSAGE 2! R> THROW
;
</PRE> */
static const CELL XT_THROW_QUOTE[] =
	{
	XT_TO_R, XT_EXCEPTION_MESSAGE, XT_2_STORE,
	XT_R_FROM, XT_THROW
	};


/** Definition of non standard forth word. <PRE>
: (')   ( "<spaces>name" -- xt immediate-flag )   \ Implementation factor for ' (tick).
    PARSE-WORD (find) IF EXIT THEN -13 THROW
;
</PRE> */
static const CELL XT_PAREN_TICK[] =
	{
	XT_PARSE_WORD, (CELL)XT_PAREN_FIND,						// PARSE-WORD (find) 
	XT_0BRANCH(2), XT_EXIT,									// IF EXIT THEN
	LIT(UndefinedWord), (CELL)XT_THROW_QUOTE				// -13 THROW"
	};


/** Definition of ANS forth word.<PRE>
: '   ( "<spaces>name" -- xt )
    (') DROP
;
</PRE> */
static const CELL XT_TICK[] =
	{
	(CELL)XT_PAREN_TICK, XT_DROP, XT_EXIT					// (') DROP
	};


/** Definition of non standard forth word. <PRE>
: >SIGN   ( c-addr1 u1 -- c-addr2 u2 true | c-addr1 u1 false )

   \ If the string specified by c-addr1 u1 begings with a minus sign
   \ then adjust string to remove it and return true,
   \ else return then original string and false.

   DUP 0= IF FALSE EXIT THEN
   OVER C@ [CHAR] - =
   IF SWAP CHAR+ SWAP 1- TRUE EXIT THEN FALSE
;
</PRE> */
static const CELL XT_TO_SIGN[] =
	{
	XT_DUP, XT_0_EQUALS, XT_0BRANCH(3), XT_FALSE, XT_EXIT,	// DUP 0= IF FALSE EXIT THEN
	XT_OVER, XT_C_FETCH, LIT('-'), XT_EQUALS,				// OVER C@ [CHAR] - =
	XT_0BRANCH(7), XT_SWAP, XT_CHAR_PLUS, XT_SWAP,			// IF SWAP CHAR+ SWAP
	XT_1_MINUS, XT_TRUE, XT_EXIT, XT_FALSE, XT_EXIT			// 1- TRUE EXIT THEN FALSE
	};


/** Definition of non standard forth word. <PRE>
: NUMBER?   ( c-addr1 u1 -- d 2 | n 1 | 0 )

    \ Convert the string specified by c-addr1 u1 into a number.
    \ Return d and 2 if the number is a double number,
    \ return n and 1 if the number is a single number;
    \ otherwise return zero.

    >SIGN >R                                \ check for leading minus sign
    0 0 2SWAP >NUMBER 2SWAP                 \ convert string to a number
    R> IF DNEGATE THEN                      \ apply sign to number
    2SWAP DUP 0=                            \ all of string converted?
    IF 2DROP DROP 1 EXIT THEN               \ return a single cell number
    1 = SWAP C@ [CHAR] . = AND              \ remainder of string is a single decimal point?
    IF 2 EXIT THEN                          \ return a double cell number
    2DROP 0                                 \ not a number, so return 0
;
</PRE> */
static const CELL XT_NUMBER_QUERY[] =
	{
	(CELL)XT_TO_SIGN, XT_TO_R, XT_FALSE, XT_FALSE,			// >SIGN >R 0 0
	XT_2SWAP, XT_TO_NUMBER, XT_2SWAP,						// 2SWAP >NUMBER 2SWAP
	XT_R_FROM, XT_0BRANCH(2), XT_DNEGATE,					// R> IF DNEGATE THEN
	XT_2SWAP, XT_DUP, XT_0_EQUALS, XT_0BRANCH(6), 			// 2SWAP DUP 0= IF
	XT_2DROP, XT_DROP, LIT(1), XT_EXIT,						// 2DROP DROP 1 EXIT THEN
	LIT(1), XT_EQUALS, XT_SWAP, 							// 1 = SWAP
	XT_C_FETCH, LIT('.'), XT_EQUALS,	XT_AND,				// C@ [CHAR] . = AND
	XT_0BRANCH(4),  LIT(2), XT_EXIT,						// IF 2 EXIT THEN
	XT_2DROP, XT_FALSE, XT_EXIT								// 2DROP 0
	};


/** Definition of non standard forth word. <PRE>
: INTERPRET-WORD   ( c-addr u -- i*x | d | n )

    \ Find the defination named by the string c-addr u.
    \ If the definition is found, perform it's execution semantics,
    \ i*x represents the results of this.
    \ If the definition is not found, convert c-addr u into a number.
    \ If the number is valid double number, leave its value d on the stack.
    \ If the number is valid single number, leave its value n on the stack.
    \ If the number isn't valid, throw exception -13.

    (find)                          \ search dictionary for the word
    IF DROP EXECUTE EXIT THEN       \ if found, execute it and end
    2DUP 2>R                        \ save string
    NUMBER?                         \ convert string into a number
    IF                              \ if it is a valid number
        R> DROP R> DROP             \   discard saved string
        EXIT                        \   leave number's value on stack and end
    THEN
    2R> -13 THROW                   \ throw -13 (with string on top of stack)
;
</PRE> */
static const CELL XT_INTERPRET_WORD[] =
	{
	(CELL)XT_PAREN_FIND,									// (find)
	XT_0BRANCH(4), XT_DROP, XT_EXECUTE, XT_EXIT,			// IF DROP EXECUTE EXIT THEN
	XT_2DUP, XT_2_TO_R, (CELL)XT_NUMBER_QUERY,				// 2DUP 2>R NUMBER? 
	XT_0BRANCH(4), XT_RDROP, XT_RDROP, XT_EXIT,				// IF R> DROP R> DROP EXIT THEN
	XT_2_R_FROM,											// 2R>
	LIT(UndefinedWord), (CELL)XT_THROW_QUOTE				// -13 THROW"
	};


/** Definition of non standard forth word. <PRE>
: COMPILE-WORD   ( c-addr u -- i*x | )

    \ Find the defination named by the string c-addr u.
    \ If the definition is found, then if the word is immediate perform it's
    \ execution semantics, i*x represents the results of this. If the word
    \ isn't immediate, append it's execution semantics to the current definition.
    \ If the definition is not found, convert c-addr u into a number.
    \ If the number is valid single or double number, append code to the current
    \ definition which when executed will leave the number's value on the stack.
    \ If the number isn't valid, throw exception -13.

    (find)                                  \ search dictionary for the word
    IF                                      \ if found
        IF                                  \   and it's immediate,
            EXECUTE EXIT                    \     then execute it and end
        THEN                                \   else
        , EXIT                              \     compile it and end
    THEN
    2DUP 2>R                                \ save string
    NUMBER? DUP                             \ convert string into a number
    IF                                      \ if it is a valid number
        R> DROP R> DROP                     \   discard saved string
        1- IF SWAP POSTPONE LITERAL THEN    \   compile number as a literal...
        POSTPONE LITERAL EXIT
    THEN
    2R> -13 THROW                           \ throw -13 (with string on top of stack)
;
</PRE> */
static const CELL XT_COMPILE_WORD[] =
	{
	(CELL)XT_PAREN_FIND,									// (find)
	XT_0BRANCH(7), XT_0BRANCH(3), XT_EXECUTE, XT_EXIT,		// IF IF EXECUTE EXIT THEN
	XT_COMMA, XT_EXIT,										// , EXIT THEN
	XT_2DUP, XT_2_TO_R, (CELL)XT_NUMBER_QUERY, XT_DUP,		// 2DUP 2>R NUMBER? DUP
	XT_0BRANCH(10), XT_RDROP, XT_RDROP,						// IF R> DROP R> DROP 
	XT_1_MINUS, XT_0BRANCH(3), XT_SWAP, (CELL)XT_LITERAL,	// 1- IF SWAP POSTPONE LITERAL THEN
	(CELL)XT_LITERAL, XT_EXIT,								// POSTPONE LITERAL EXIT THEN
	XT_2_R_FROM,											// 2R>
	LIT(UndefinedWord), (CELL)XT_THROW_QUOTE				// -13 THROW"
	};


/** Definition of non standard forth word. <PRE>
: INTERPRET   ( -- i*x)   \ Interpret the current input, i*x is the result of this
    BEGIN
        PARSE-WORD DUP                  \ get a word from the input
    WHILE                               \ while there is a word
        STATE @                         \   if in compile state
        IF COMPILE-WORD                 \   compile the word
        ELSE INTERPRET-WORD             \   else interpret the word
        THEN
    REPEAT                              \ get next word
    2DROP                               \ discard empty word and end
;
</PRE> */
static const CELL XT_INTERPRET[] =
	{
	XT_PARSE_WORD, XT_DUP,									// BEGIN PARSE-WORD DUP
	XT_0BRANCH(11), XT_STATE, XT_FETCH,						// WHILE STATE @
	XT_0BRANCH(4), (CELL)XT_COMPILE_WORD,					// IF COMPILE-WORD
	XT_BRANCH(-10), (CELL)XT_INTERPRET_WORD, XT_BRANCH(-13),// ELSE INTERPRET-WORD THEN REPEAT
	XT_2DROP, XT_EXIT										// 2DROP
	};


/** Definition of ANS forth word.<PRE>
: EVALUATE   ( i*x c-addr u -- j*x )
    (source) 2@ 2>R >IN 2@ 2>R 
    (source) 2! -1 0 >IN 2!
	' INTERPRET CATCH
    2R> >IN 2! 2R> (source) 2!
	THROW
;
</PRE> */
static const CELL XT_EVALUATE[] = 
	{
	XT_PAREN_SOURCE, XT_2_FETCH, XT_2_TO_R,					// (source) 2@ 2>R
	XT_TO_IN, XT_2_FETCH, XT_2_TO_R,						// >IN 2@ 2>R 
	XT_PAREN_SOURCE, XT_2_STORE,							// (source) 2!
	XT_TRUE, XT_FALSE, XT_TO_IN, XT_2_STORE,				// -1 0 >IN 2!
	LIT(XT_INTERPRET), XT_CATCH,							// ' INTERPRET CATCH
	XT_2_R_FROM, XT_TO_IN, XT_2_STORE,						// 2R> >IN 2!
	XT_2_R_FROM, XT_PAREN_SOURCE, XT_2_STORE,				// 2R> (source) 2!
	XT_THROW, XT_EXIT										// THROW
	};


/** Definition of non standard forth word. <PRE>
: REFILL-TIB   ( -- true )

    \ Refill the terminal input buffer (TIB)
    \ and make it the current input source.

    TIB DUP /TIB ACCEPT SPACE   \ get input from terminal
    (source) 2!                 \ make SOURCE point to TIB
    0 >IN ! TRUE                \ set >IN to zero
;
</PRE> */
static const CELL XT_REFILL_TIB[] =
	{
	XT_TIB, XT_DUP, LIT(NumberTIB), XT_ACCEPT,				// TIB DUP /TIB ACCEPT
	XT_SPACE, XT_PAREN_SOURCE, XT_2_STORE,					// SPACE (source) 2!
	XT_FALSE, XT_TO_IN, XT_STORE, XT_TRUE, XT_EXIT			// 0 >IN ! TRUE
	};


/** Definition of ANS forth word.<PRE>
: REFILL   ( -- flag )

    \ Attempt to fill the input buffer from the input source,
    \ returning a true flag if successful.

    >IN CELL+ @ 0=              \ if input source is 0
    IF REFILL-TIB EXIT THEN     \ get input from terminal and return true
    FALSE                       \ otherwise, return false
;
</PRE> */
static const CELL XT_REFILL[] =
	{
	XT_TO_IN, XT_CELL_PLUS, XT_FETCH, XT_0_EQUALS,			// >IN CELL+ @ 0=
	XT_0BRANCH(3), (CELL)XT_REFILL_TIB, XT_EXIT,			// IF REFILL-TIB EXIT THEN
	XT_FALSE, XT_EXIT										// FALSE
	};


/** Definition of non standard forth word.<PRE>
: DO-QUIT   ( -- )  ( R:  i*x -- )
    EMPTYR
    0 >IN CELL+ !   \ set SOURCE-ID to 0
    POSTPONE [
    BEGIN
        REFILL
    WHILE
        INTERPRET
        STATE @ 0= IF ."  OK" THEN
        CR
    REPEAT
;
</PRE> */
static const CELL XT_DO_QUIT[] =
	{
	XT_FALSE, XT_TO_IN, XT_CELL_PLUS,						// 0 >IN CELL+
	XT_STORE, XT_LEFT_BRACKET,								// ! POSTPONE [
	(CELL)XT_REFILL, XT_0BRANCH(18), (CELL)XT_INTERPRET,	// BEGIN REFILL WHILE INTERPRET
	XT_STATE, XT_FETCH, XT_0_EQUALS, XT_0BRANCH(8),			// STATE @ 0= IF
	XT_SPACE, LIT('O'), XT_EMIT,							// ."  OK"
	LIT('K'), XT_EMIT, (CELL)XT_CR, 						// THEN CR
	XT_BRANCH(-18), XT_EXIT									// REPEAT
	};


static const CHAR AbortText[] = {'A','B','O','R','T'};
static const CHAR ExceptionText[] = {'E','x','c','e','p','t','i','o','n'};

/** Definition of ANS forth word. <PRE>
: EXCEPTION.   ( n -- n )
    DUP -1 =
    IF ." ABORT" EXIT THEN         // Print 'ABORT', and end
    DUP -2 =
    IF EXCEPTION-STRING 2@ TYPE EXIT THEN  // Print exception message, and end
    DUP -13 =
    IF
        EXCEPTION-STRING 2@ TYPE   // Print word name
        SPACE [CHAR] ? EMIT EXIT   // followed by " ?", then end
    THEN
    ." Exception" DUP .            // Print "Exception n", then end
;
</PRE> */
const CELL XT_EXCEPTION_DOT[] =
	{
	XT_DUP, XT_TRUE, XT_EQUALS, XT_0BRANCH(7),				// DUP -1 = IF 
	LIT(AbortText), LIT(5), XT_TYPE, XT_EXIT,				// ." ABORT" EXIT THEN

	XT_DUP, LIT(-2), XT_EQUALS, XT_0BRANCH(5),				// DUP -2 = IF 
	XT_EXCEPTION_MESSAGE, XT_2_FETCH, XT_TYPE, XT_EXIT,		// EXCEPTION-STRING 2@ TYPE EXIT

	XT_DUP, LIT(-13), XT_EQUALS, XT_0BRANCH(9),				// DUP -13 = IF 
	XT_EXCEPTION_MESSAGE, XT_2_FETCH, XT_TYPE, XT_SPACE,	// EXCEPTION-STRING 2@ TYPE SPACE
	LIT('?'), XT_EMIT, XT_EXIT,								// [CHAR] ? EMIT EXIT THEN

	LIT(ExceptionText), LIT(10), XT_TYPE,					// ." Exception"
	XT_DUP, (CELL)XT_DOT, XT_EXIT							// DUP .
	};


/** Definition of ANS forth word. <PRE>
: QUIT   ( i*x n -- )
	BEGIN
		EMPTYR  ['] DO-QUIT CATCH
		EXCEPTION. CR
	AGAIN
;
</PRE> */
const CELL XT_QUIT[] =
	{
	XT_EMPTYR, LIT(XT_DO_QUIT), XT_CATCH,					// BEGIN EMPTYR ['] DO-QUIT CATCH 
	(CELL)XT_EXCEPTION_DOT, (CELL)XT_CR,					// EXCEPTION. CR
	XT_EMPTYS, XT_BRANCH(-8)								// EMPTYS AGAIN
	};


// Macros for constructing word headers
#define IMMEDIATE 0x8000
#define TOKEN 0x4000
#define LINK(n) CELLS(((n)+!!((n)&TOKEN))&~(IMMEDIATE|TOKEN))
#define FLAGS(f) ((((f)&IMMEDIATE)?(UCELL)WordHeader::Immediate:0)|(((f)&TOKEN)?(UCELL)WordHeader::Token:0)|(UCELL)WordHeader::Valid)

#define PREPEND_CHAR(x,c) ((((CELL)x)<<BITS_PER_CHAR)+((CELL)c))
#ifdef LITTLE_ENDIAN
#define C4(a,b,c,d) ((CELL)PREPEND_CHAR(PREPEND_CHAR(PREPEND_CHAR(d,c),b),a))
#define C8(a,b,c,d,e,f,g,h) ((C4(e,f,g,h)<<(BITS_PER_CHAR*4))+C4(a,b,c,d))
#endif
#ifdef BIG_ENDIAN
#define C4(a,b,c,d) ((CELL)PREPEND_CHAR(PREPEND_CHAR(PREPEND_CHAR(a,b),c),d))
#define C8(a,b,c,d,e,f,g,h) ((C4(a,b,c,d)<<(BITS_PER_CHAR*4))+C4(e,f,g,h))
#endif

#if CHARS_PER_CELL==8

#define H1(a,args)				LINK(2+(args)),C8(FLAGS(args)+1,a,0,0,0,0,0,0)
#define H2(a,b,args)			LINK(2+(args)),C8(FLAGS(args)+2,a,b,0,0,0,0,0)
#define H3(a,b,c,args)			LINK(2+(args)),C8(FLAGS(args)+3,a,b,c,0,0,0,0)
#define H4(a,b,c,d,args)		LINK(2+(args)),C8(FLAGS(args)+4,a,b,c,d,0,0,0)
#define H5(a,b,c,d,e,args)		LINK(2+(args)),C8(FLAGS(args)+5,a,b,c,d,e,0,0)
#define H6(a,b,c,d,e,f,args)	LINK(2+(args)),C8(FLAGS(args)+6,a,b,c,d,e,f,0)
#define H7(a,b,c,d,e,f,g,args)	LINK(2+(args)),C8(FLAGS(args)+7,a,b,c,d,e,f,g)
#define H8(a,b,c,d,e,f,g,h,args)				LINK(3+(args)),C8(FLAGS(args)+8,a,b,c,d,e,f,g),C8(h,0,0,0,0,0,0,0)
#define H9(a,b,c,d,e,f,g,h,i,args)				LINK(3+(args)),C8(FLAGS(args)+9,a,b,c,d,e,f,g),C8(h,i,0,0,0,0,0,0)
#define H10(a,b,c,d,e,f,g,h,i,j,args)			LINK(3+(args)),C8(FLAGS(args)+10,a,b,c,d,e,f,g),C8(h,i,j,0,0,0,0,0)
#define H11(a,b,c,d,e,f,g,h,i,j,k,args)			LINK(3+(args)),C8(FLAGS(args)+11,a,b,c,d,e,f,g),C8(h,i,j,k,0,0,0,0)
#define H12(a,b,c,d,e,f,g,h,i,j,k,l,args)		LINK(3+(args)),C8(FLAGS(args)+12,a,b,c,d,e,f,g),C8(h,i,j,k,l,0,0,0)
#define H13(a,b,c,d,e,f,g,h,i,j,k,l,m,args)		LINK(3+(args)),C8(FLAGS(args)+13,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,0,0)
#define H14(a,b,c,d,e,f,g,h,i,j,k,l,m,n,args)	LINK(3+(args)),C8(FLAGS(args)+14,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,n,0)
#define H15(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,args)	LINK(3+(args)),C8(FLAGS(args)+15,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,n,o)
#define H16(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,args)		LINK(4+(args)),C8(FLAGS(args)+16,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,n,o),C8(p,0,0,0,0,0,0,0)
#define H17(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,args)		LINK(4+(args)),C8(FLAGS(args)+17,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,n,o),C8(p,q,0,0,0,0,0,0)
#define H18(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,args)	LINK(4+(args)),C8(FLAGS(args)+18,a,b,c,d,e,f,g),C8(h,i,j,k,l,m,n,o),C8(p,q,r,0,0,0,0,0)

#elif CHARS_PER_CELL==4

#define H1(a,args)		LINK(2+(args)),C4(FLAGS(args)+1,a,0,0)
#define H2(a,b,args)	LINK(2+(args)),C4(FLAGS(args)+2,a,b,0)
#define H3(a,b,c,args)	LINK(2+(args)),C4(FLAGS(args)+3,a,b,c)
#define H4(a,b,c,d,args)		LINK(3+(args)),C4(FLAGS(args)+4,a,b,c),C4(d,0,0,0)
#define H5(a,b,c,d,e,args)		LINK(3+(args)),C4(FLAGS(args)+5,a,b,c),C4(d,e,0,0)
#define H6(a,b,c,d,e,f,args)	LINK(3+(args)),C4(FLAGS(args)+6,a,b,c),C4(d,e,f,0)
#define H7(a,b,c,d,e,f,g,args)	LINK(3+(args)),C4(FLAGS(args)+7,a,b,c),C4(d,e,f,g)
#define H8(a,b,c,d,e,f,g,h,args)		LINK(4+(args)),C4(FLAGS(args)+8,a,b,c),C4(d,e,f,g),C4(h,0,0,0)
#define H9(a,b,c,d,e,f,g,h,i,args)		LINK(4+(args)),C4(FLAGS(args)+9,a,b,c),C4(d,e,f,g),C4(h,i,0,0)
#define H10(a,b,c,d,e,f,g,h,i,j,args)	LINK(4+(args)),C4(FLAGS(args)+10,a,b,c),C4(d,e,f,g),C4(h,i,j,0)
#define H11(a,b,c,d,e,f,g,h,i,j,k,args)	LINK(4+(args)),C4(FLAGS(args)+11,a,b,c),C4(d,e,f,g),C4(h,i,j,k)
#define H12(a,b,c,d,e,f,g,h,i,j,k,l,args)		LINK(5+(args)),C4(FLAGS(args)+12,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,0,0,0)
#define H13(a,b,c,d,e,f,g,h,i,j,k,l,m,args)		LINK(5+(args)),C4(FLAGS(args)+13,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,0,0)
#define H14(a,b,c,d,e,f,g,h,i,j,k,l,m,n,args)	LINK(5+(args)),C4(FLAGS(args)+14,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,0)
#define H15(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,args)	LINK(5+(args)),C4(FLAGS(args)+15,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o)
#define H16(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,args)		LINK(6+(args)),C4(FLAGS(args)+16,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,0,0,0)
#define H17(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,args)		LINK(6+(args)),C4(FLAGS(args)+17,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,q,0,0)
#define H18(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,args)	LINK(6+(args)),C4(FLAGS(args)+18,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,q,r,0)

#else

#error CHARS_PER_CELL value not supported

#endif

/**
Initial contents for FORTH dictionary
*/
static const CELL ForthDictionary[] =
	{
	H1('!',TOKEN), XT_STORE,
	H1('#',TOKEN), XT_NUMBER_SIGN,
	H2('#','>',TOKEN), XT_NUMBER_SIGN_GREATER,
	H2('#','S',TOKEN), (CELL)XT_NUMBER_SIGN_S,
	H1('\'',TOKEN), (CELL)XT_TICK,
	H1('(',IMMEDIATE|5), LIT(')'),							// : (   ( "ccc<paren>" -- )
		XT_PARSE, XT_2DROP, XT_EXIT,						//   [CHAR] ) PARSE 2DROP ; IMMEDIATE
	H1('*',TOKEN), XT_STAR,
	H2('*','/',3),											// : * /   ( n1 n2 n3 -- n4 )
		(CELL)XT_STAR_SLASH_MOD, XT_NIP, XT_EXIT,			//   */MOD NIP ;
	H5('*','/','M','O','D',TOKEN), (CELL)XT_STAR_SLASH_MOD,
	H1('+',TOKEN), XT_PLUS,
	H2('+','!',TOKEN), XT_PLUS_STORE,
	H5('+','L','O','O','P',IMMEDIATE|5),					// : +LOOP   ( C: do-sys -- )
		LIT(XT_PAREN_PLUS_LOOP),							//   ['] (+loop)
		(CELL)XT_BACKWARD_BRANCH_COMMA, (CELL)XT_THEN,		//   <BRANCH, POSTPONE THEN
		XT_EXIT,											//   ; IMMEDIATE
	H1(',',TOKEN), XT_COMMA,
	H1('-',TOKEN), XT_MINUS,
	H1('.',TOKEN), (CELL)XT_DOT,
	H2('.','"',IMMEDIATE|5),								// : ."   ( "ccc<quote>" -- )
		(CELL)XT_S_QUOTE, LIT(XT_TYPE), XT_COMMA, XT_EXIT,	//   POSTPONE S" POSTPONE TYPE ; IMMEDIATE
	H1('/',3),												// : /   ( n1 n2 -- n3 )
		(CELL)XT_SLASH_MOD, XT_NIP, XT_EXIT,				//   /MOD NIP ;
	H4('/','M','O','D',TOKEN), (CELL)XT_SLASH_MOD,
	H2('0','<',TOKEN), XT_0_LESS,
	H2('0','=',TOKEN), XT_0_EQUALS,
	H2('1','+',TOKEN), XT_1_PLUS,
	H2('1','-',TOKEN), XT_1_MINUS,
	H2('2','!',TOKEN), XT_2_STORE,
	H2('2','*',TOKEN), XT_2_STAR,
	H2('2','/',TOKEN), XT_2_SLASH,
	H2('2','@',TOKEN), XT_2_FETCH,
	H5('2','D','R','O','P',TOKEN), XT_2DROP,
	H4('2','D','U','P',TOKEN), XT_2DUP,
	H5('2','O','V','E','R',TOKEN), XT_2OVER,
	H5('2','S','W','A','P',TOKEN), XT_2SWAP,
	H1(':',7),												// : :   ( C: "<spaces>name" -- colon-sys )
		XT_PARSE_WORD, (CELL)XT_CREATE_WORD,				//   PARSE-WORD CREATE-WORD
		XT_FALSE, LIT(ColonMagic), XT_RIGHT_BRACKET,		//   0 COLON-MAGIC ]
		XT_EXIT,
	H1(';',IMMEDIATE|14),									// : ;   ( C: colon-sys -- )
		XT_LEFT_BRACKET,									//   [
		LIT(ColonMagic), (CELL)XT_NEST_CHECK,				//   COLON-MAGIC NEST-CHECK
		LIT(XT_EXIT), XT_COMMA, XT_DUP, XT_0_EQUALS, 		//   ['] EXIT , DUP 0=
		XT_0BRANCH(2), XT_DROP, (CELL)XT_VALIDATE, XT_EXIT,	//   IF DROP VALIDATE THEN ; IMMEDIATE
	H1('<',TOKEN), XT_LESS_THAN,
	H2('<','#',TOKEN), XT_LESS_NUMBER_SIGN,
	H1('=',TOKEN), XT_EQUALS,
	H1('>',TOKEN), XT_GREATER_THAN,
	H5('>','B','O','D','Y',TOKEN), XT_CELL_PLUS,
	H3('>','I','N',TOKEN), XT_TO_IN,
	H7('>','N','U','M','B','E','R',TOKEN), XT_TO_NUMBER,
	H2('>','R',TOKEN), XT_TO_R,
	H4('?','D','U','P',TOKEN), XT_QUESTION_DUP,
	H1('@',TOKEN), XT_FETCH,
	H5('A','B','O','R','T',2), XT_TRUE, XT_THROW,			// : ABORT -1 THROW ;
	H6('A','B','O','R','T','"',IMMEDIATE|10),				// : ABORT"   ( "ccc<quote>" -- )
		(CELL)XT_IF, (CELL)XT_S_QUOTE,						//   POSTPONE IF POSTPONE S"
		LIT(-2), (CELL)XT_LITERAL,							//   -2 POSTPONE LITERAL
		LIT(XT_THROW_QUOTE), XT_COMMA,						//   POSTPONE THROW-QUOTE
		(CELL)XT_THEN, XT_EXIT,								//   POSTPONE THEN ; IMMEDIATE
	H3('A','B','S',TOKEN), XT_ABS,
	H6('A','C','C','E','P','T',TOKEN), XT_ACCEPT,
	H5('A','L','I','G','N',TOKEN), XT_ALIGN,
	H7('A','L','I','G','N','E','D',TOKEN), XT_ALIGNED,
	H5('A','L','L','O','T',TOKEN), XT_ALLOT,
	H3('A','N','D',TOKEN), XT_AND,
	H4('B','A','S','E',TOKEN), XT_BASE,
	H5('B','E','G','I','N',IMMEDIATE|TOKEN), (CELL)XT_BEGIN,
	H2('B','L',2),											// 32 CONSTANT BL
		XT_PAREN_CONSTANT, 32,
	H2('C','!',TOKEN), XT_C_STORE,
	H2('C',',',TOKEN), XT_C_COMMA,
	H2('C','@',TOKEN), XT_C_FETCH,
	H5('C','E','L','L','+',TOKEN), XT_CELL_PLUS,
	H5('C','E','L','L','S',TOKEN), XT_CELLS,
	H4('C','H','A','R',TOKEN), (CELL)XT_CHAR,
	H5('C','H','A','R','+',TOKEN), XT_CHAR_PLUS,
	H5('C','H','A','R','S',TOKEN), XT_CHARS,
	H8('C','O','N','S','T','A','N','T',8),					// : CONSTANT   ( x "<spaces>name" -- )
		XT_PARSE_WORD, (CELL)XT_CREATE_WORD,				//   PARSE-WORD CREATE-WORD
		LIT(XT_PAREN_CONSTANT), XT_COMMA, XT_COMMA,			//   POSTPONE (constant) ,
		(CELL)XT_VALIDATE, XT_EXIT,							//   VALIDATE ;
	H5('C','O','U','N','T',TOKEN), XT_COUNT,
	H2('C','R',TOKEN), (CELL)XT_CR,
	H6('C','R','E','A','T','E',TOKEN), (CELL)XT_CREATE,
	H7('D','E','C','I','M','A','L',5),						// : DECIMAL   ( -- )
		LIT(10), XT_BASE, XT_STORE, XT_EXIT,				//   10 BASE ! ;
	H5('D','E','P','T','H',TOKEN), XT_DEPTH,
	H2('D','O',IMMEDIATE|5),								// : DO   ( C: -- do-sys )
		LIT(XT_PAREN_DO), (CELL)XT_FORWARD_BRANCH_COMMA,	//   ['] (do) >BRANCH,
		(CELL)XT_BEGIN, XT_EXIT,							//   POSTPONE BEGIN ; IMMEDIATE
	H5('D','O','E','S','>',IMMEDIATE|7),					// : DOES>   ( C: colon-sys1 -- colon-sys2 )
		LIT(XT_PAREN_DOES), XT_COMMA,						//   POSTPONE (does) 
		LIT(XT_R_FROM), XT_COMMA, XT_EXIT,					//   POSTPONE R> ;
	H4('D','R','O','P',TOKEN), XT_DROP,
	H3('D','U','P',TOKEN), XT_DUP,
	H4('E','L','S','E',IMMEDIATE|4),						// : ELSE   ( C: orig1 -- orig2 )
		(CELL)XT_AHEAD, XT_2SWAP, (CELL)XT_THEN, XT_EXIT,	//   POSTPONE AHEAD 2SWAP POSTPONE THEN ; IMMEDIATE
	H4('E','M','I','T',TOKEN), XT_EMIT,
	H12('E','N','V','I','R','O','N','M','E','N','T','?',13),// : ENVIRONMENT?   ( c-addr u -- false | i*x true )
		XT_FORTH_WORDLIST, XT_CELL_PLUS, XT_FETCH,			//   ENVIRONMENT-WORDLIST
		XT_PAREN_SEARCH_WORDLIST, XT_NIP, 					//   (search-wordlist) NIP
		XT_0BRANCH(4), XT_EXECUTE, XT_TRUE, XT_EXIT,		//   IF EXECUTE TRUE EXIT THEN
		XT_DROP, XT_FALSE, XT_EXIT,							//   DROP FALSE ;
	H8('E','V','A','L','U','A','T','E',TOKEN), (CELL)XT_EVALUATE,
	H7('E','X','E','C','U','T','E',TOKEN), XT_EXECUTE,
	H4('E','X','I','T',TOKEN), XT_EXIT,
	H4('F','I','L','L',TOKEN), XT_FILL,
	H4('F','I','N','D',17),									// : FIND   ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
		XT_COUNT, (CELL)XT_PAREN_FIND, XT_0BRANCH(8),		//   COUNT (find) IF 
		XT_0BRANCH(4), LIT(1), XT_EXIT, XT_TRUE, XT_EXIT,	//   IF 1 EXIT THEN -1 EXIT 
		XT_DROP, LIT(CHARS(1)), XT_MINUS, XT_FALSE, XT_EXIT,//   THEN DROP 1 CHARS - 0 THEN ;
	H6('F','M','/','M','O','D',TOKEN), (CELL)XT_FM_SLASH_MOD,
	H4('H','E','R','E',TOKEN), XT_HERE,
	H4('H','O','L','D',TOKEN), XT_HOLD,
	H1('I',TOKEN), XT_I,
	H2('I','F',IMMEDIATE|TOKEN), (CELL)XT_IF,
	H9('I','M','M','E','D','I','A','T','E',4),				// : IMMEDIATE   ( -- )
		LIT(WordHeader::Immediate), (CELL)(XT_VALIDATE+2),	//   1 SET-WORD-FLAG ;
		XT_EXIT,
	H6('I','N','V','E','R','T',TOKEN), XT_INVERT,
	H1('J',TOKEN), XT_J,
	H3('K','E','Y',TOKEN), XT_KEY,
	H5('L','E','A','V','E',TOKEN), XT_LEAVE,
	H7('L','I','T','E','R','A','L',IMMEDIATE|TOKEN), (CELL)XT_LITERAL,
	H4('L','O','O','P',IMMEDIATE|5),						// : LOOP   ( C: do-sys -- )
		LIT(XT_PAREN_LOOP), (CELL)XT_BACKWARD_BRANCH_COMMA,	//   ['] (loop) <BRANCH,
		(CELL)XT_THEN, XT_EXIT,								//   POSTPONE THEN ; IMMEDIATE
	H6('L','S','H','I','F','T',TOKEN), XT_LSHIFT,
	H2('M','*',TOKEN), (CELL)XT_M_STAR,
	H3('M','A','X',TOKEN), XT_MAX,
	H3('M','I','N',TOKEN), XT_MIN,
	H3('M','O','D',3),										// : MOD   ( n1 n2 -- n3 )
		(CELL)XT_SLASH_MOD, XT_DROP, XT_EXIT,				//   /MOD DROP ;
	H4('M','O','V','E',TOKEN), XT_MOVE,
	H6('N','E','G','A','T','E',TOKEN), XT_NEGATE,
	H2('O','R',TOKEN), XT_OR,
	H4('O','V','E','R',TOKEN), XT_OVER,
	H8('P','O','S','T','P','O','N','E',IMMEDIATE|10),		// : POSTPONE   ( "<spaces>name" -- )
		(CELL)XT_PAREN_TICK,								//   (')
		XT_0BRANCH(3), XT_COMMA, XT_EXIT,					//   IF , EXIT THEN
		(CELL)XT_LITERAL, LIT(XT_COMMA), XT_COMMA, XT_EXIT,	//   POSTPONE LITERAL POSTPONE , ; IMMEDIATE
	H4('Q','U','I','T',TOKEN), (CELL)XT_QUIT,
	H2('R','>',TOKEN), XT_R_FROM,
	H2('R','@',TOKEN), XT_R_FETCH,
	H7('R','E','C','U','R','S','E',IMMEDIATE|5),			// : RECURSE   ( -- )
		XT_LATEST, XT_FETCH, XT_TO_CFA, XT_COMMA, XT_EXIT,	//   LATEST @ >CFA , ;
	H6('R','E','P','E','A','T',IMMEDIATE|3),				// : REPEAT   ( C: orig dest -- )
		(CELL)XT_AGAIN, (CELL)XT_THEN, XT_EXIT,				//   POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE
	H3('R','O','T',TOKEN), XT_ROT,
	H6('R','S','H','I','F','T',TOKEN), XT_RSHIFT,
	H2('S','"',IMMEDIATE|TOKEN), (CELL)XT_S_QUOTE,
	H3('S','>','D',TOKEN), XT_S_TO_D,
	H4('S','I','G','N',TOKEN), XT_SIGN,
	H6('S','M','/','R','E','M',TOKEN), (CELL)XT_SM_SLASH_REM,
	H6('S','O','U','R','C','E',3),							// : SOURCE   ( -- c-addr u )
		XT_PAREN_SOURCE, XT_2_FETCH, XT_EXIT,				//   (source) 2@ ;
	H5('S','P','A','C','E',TOKEN), XT_SPACE,
	H6('S','P','A','C','E','S',10),							// : SPACES   ( n -- )
		XT_DUP, XT_0_GREATER, XT_0BRANCH(5),				//   BEGIN DUP 0> WHILE 
		XT_SPACE, XT_1_MINUS, XT_BRANCH(-7), XT_DROP,		//   SPACE 1- REPEAT DROP
		XT_EXIT,											//   ;
	H5('S','T','A','T','E',TOKEN), XT_STATE,
	H4('S','W','A','P',TOKEN), XT_SWAP,
	H4('T','H','E','N',IMMEDIATE|TOKEN), (CELL)XT_THEN,
	H4('T','Y','P','E',TOKEN), XT_TYPE,
	H2('U','.',3),											// : U.   ( u -- )
		XT_FALSE, (CELL)XT_D_DOT, XT_EXIT,					//   0 D. ;
	H2('U','<',TOKEN), XT_U_LESS_THAN,
	H3('U','M','*',TOKEN), XT_UM_STAR,
	H6('U','M','/','M','O','D',TOKEN), (CELL)XT_UM_SLASH_MOD,
	H6('U','N','L','O','O','P',TOKEN), XT_UNLOOP,
	H5('U','N','T','I','L',IMMEDIATE|4),					// : UNTIL   ( C: dest -- )
		LIT(XT_PAREN_0BRANCH),								//   ['] (0branch) 
		(CELL)XT_BACKWARD_BRANCH_COMMA,	XT_EXIT,			//   <BRANCH, ; IMMEDIATE
	H8('V','A','R','I','A','B','L','E',4),					// : VARIABLE   ( "<spaces>name" -- )
		(CELL)XT_CREATE, XT_FALSE, XT_COMMA, XT_EXIT,		//   CREATE 0 , ;
	H5('W','H','I','L','E',IMMEDIATE|3),					// : WHILE   ( C: dest -- orig dest )
		(CELL)XT_IF, XT_2SWAP, XT_EXIT,						//   POSTPONE IF 2SWAP ; IMMEDIATE
	H4('W','O','R','D',14),									// : WORD   ( char "<chars>ccc<char>" -- c-addr )
		XT_INVERT, XT_PARSE, LIT(SlashCountedString),		//   INVERT PARSE /COUNTED-STRING 
		XT_MIN, XT_DUP, XT_HERE, XT_C_STORE, XT_HERE,		//   MIN DUP HERE C! HERE 
		XT_CHAR_PLUS, XT_SWAP, XT_CMOVE, XT_HERE, XT_EXIT,	//   CHAR+ SWAP CMOVE HERE ;
	H3('X','O','R',TOKEN), XT_XOR,
	H1('[',IMMEDIATE|TOKEN), XT_LEFT_BRACKET,
	H3('[','\'',']',IMMEDIATE|3),							// : [']   ( "<spaces>name" -- )
		(CELL)XT_TICK, (CELL)XT_LITERAL, XT_EXIT,			//   ' POSTPONE LITERAL ; IMMEDIATE
	H6('[','C','H','A','R',']',IMMEDIATE|3),				// : [CHAR]   ( "<spaces>name" -- )
		(CELL)XT_CHAR, (CELL)XT_LITERAL, XT_EXIT,			//   CHAR POSTPONE LITERAL ; IMMEDIATE
	H1(']',TOKEN), XT_RIGHT_BRACKET,

	//
	// CORE EXT
	//

	H3('0','<','>',TOKEN), XT_0_NOT_EQUALS,
	H2('0','>',TOKEN), XT_0_GREATER,
	H3('2','>','R',TOKEN), XT_2_TO_R,
	H3('2','R','>',TOKEN), XT_2_R_FROM,
	H3('2','R','@',TOKEN), XT_2_R_FETCH,
	H7(':','N','O','N','A','M','E',8),						// : :NONAME   ( C:  -- colon-sys )  ( S:  -- xt )
		XT_FALSE, XT_FALSE, (CELL)XT_CREATE_WORD,			//   0 0 CREATE-WORD 
		XT_HERE, LIT(ColonMagic), XT_RIGHT_BRACKET,		//   HERE COLON-MAGIC ] ;
		XT_EXIT,
	H2('<','>',TOKEN), XT_NOT_EQUALS,
	H3('?','D','O',IMMEDIATE|5),							// : ?DO   ( C: -- do-sys )
		LIT(XT_PAREN_QUESTION_DO),							//   ['] (?do)
		(CELL)XT_FORWARD_BRANCH_COMMA, (CELL)XT_BEGIN,		//   >BRANCH, POSTPONE BEGIN
		XT_EXIT,											// ; IMMEDIATE
	H5('A','G','A','I','N',IMMEDIATE|TOKEN), (CELL)XT_AGAIN,
	H8('C','O','M','P','I','L','E',',',TOKEN), XT_COMMA,
	H5('E','R','A','S','E',TOKEN), XT_ERASE,
	H5('F','A','L','S','E',TOKEN), XT_FALSE,
	H3('H','E','X',5),										// : HEX   ( -- )
		LIT(16), XT_BASE, XT_STORE, XT_EXIT,				//   16 BASE ! ;
	H3('N','I','P',TOKEN), XT_NIP,
	H3('P','A','D',TOKEN), XT_PAD,
	H5('P','A','R','S','E',TOKEN), XT_PARSE,
	H4('P','I','C','K',TOKEN), XT_PICK,
	H4('R','O','L','L',TOKEN), XT_ROLL,
	H4('T','R','U','E',TOKEN), XT_TRUE,
	H4('T','U','C','K',TOKEN), XT_TUCK,
	H2('U','>',TOKEN), XT_U_GREATER_THAN,
	H6('U','N','U','S','E','D',TOKEN), XT_UNUSED,
	H1('\\',IMMEDIATE|8),									// : \   ( "ccc<eol>"-- )
		XT_PAREN_CR, XT_1_MINUS, XT_CHARS, XT_PLUS,			//   (cr) 1- CHARS +
		XT_C_FETCH, XT_PARSE, XT_2DROP, XT_EXIT,			//   C@ PARSE 2DROP ; IMMEDIATE

	//
	// DOUBLE
	//

	H2('D','+',TOKEN), XT_D_PLUS,
	H2('D','.',TOKEN), (CELL)XT_D_DOT,
	H4('D','A','B','S',TOKEN), XT_DABS,
	H7('D','N','E','G','A','T','E',TOKEN), XT_DNEGATE,
	H2('M','+',TOKEN), XT_M_PLUS,

	//
	// EXCEPTION
	//

	H5('C','A','T','C','H',TOKEN), XT_CATCH,
	H5('T','H','R','O','W',TOKEN), XT_THROW,

	//
	// SEARCH
	//

	H14('F','O','R','T','H','-','W','O','R','D','L','I','S','T',TOKEN), XT_FORTH_WORDLIST, // : FORTH-WORDLIST   ( -- wid )
	H15('S','E','A','R','C','H','-','W','O','R','D','L','I','S','T',13), // : SEARCH-WORDLIST   ( c-addr u wid -- 0 | xt 1 | xt -1 )
		XT_PAREN_SEARCH_WORDLIST, XT_0BRANCH(8),			//   (SEARCH-WORDLIST) IF
		XT_0BRANCH(4), LIT(1), XT_EXIT, XT_TRUE, XT_EXIT,	//   IF 1 EXIT THEN -1 EXIT
		XT_2DROP, XT_FALSE, XT_EXIT,						//   2DROP FALSE ;

	//
	// STRING
	//

	H5('C','M','O','V','E',TOKEN), XT_CMOVE,
	H6('C','M','O','V','E','>',TOKEN), XT_CMOVE_UP,

	//
	// TOOLS
	//

	H2('.','S',18),											// : .S   ( -- )
		(CELL)XT_CR, XT_DEPTH, LIT(StackCells), XT_MIN,		//   CR DEPTH STACK-CELLS MIN
		XT_FALSE, XT_MAX, XT_DUP, XT_0BRANCH(7),			//   0 MAX BEGIN DUP WHILE
		XT_DUP, XT_PICK, (CELL)XT_DOT, XT_1_MINUS,			//   DUP PICK . 1-
		XT_BRANCH(-8), XT_DROP, XT_EXIT,					//   REPEAT DROP ;
	H5('A','H','E','A','D',TOKEN), (CELL)XT_AHEAD,
	H3('B','Y','E',TOKEN), XT_END,							// : BYE   ( -- )   END ;

	//
	// NOT ANS
	//

	H7('C','O','N','T','E','X','T',TOKEN), XT_CONTEXT,		// : CONTEXT   ( -- a-addr )
	H7('C','U','R','R','E','N','T',TOKEN), XT_CURRENT,		// : CURRENT   ( -- a-addr )
	H6('L','A','T','E','S','T',TOKEN), XT_LATEST,			// : LATEST   ( -- a-addr )
	H8('(','s','o','u','r','c','e',')',TOKEN), XT_PAREN_SOURCE, // : (source)   ( -- a-addr )
	H9('I','N','T','E','R','P','R','E','T',TOKEN), (CELL)XT_INTERPRET, // : INTERPRET   ( i*x -- j*x )
	H10('B','R','E','A','K','P','O','I','N','T',TOKEN), XT_BREAKPOINT, // : BREAKPOINT   ( -- )

	0
	};


/**
Initial contents for ENVIRONMENT dictionary
*/
static const CELL EnvironmentDictionary[] = 
	{
	H15('/','C','O','U','N','T','E','D','-','S','T','R','I','N','G',2), XT_PAREN_CONSTANT, SlashCountedString,
	H5('/','H','O','L','D',2), XT_PAREN_CONSTANT, SlashCountedString,
	H4('/','P','A','D',2), XT_PAREN_CONSTANT, SlashPad,
	H17('A','D','D','R','E','S','S','-','U','N','I','T','-','B','I','T','S',2), XT_PAREN_CONSTANT, BITS_PER_CHAR/CHARS(1),
	H4('C','O','R','E',TOKEN), XT_TRUE,
	H7('F','L','O','O','R','E','D',2), XT_PAREN_CONSTANT, ((-1)/2),
	H8('M','A','X','-','C','H','A','R',2), XT_PAREN_CONSTANT, (1<<BITS_PER_CHAR)-1,
	H5('M','A','X','-','U',TOKEN), XT_TRUE,
	H5('M','A','X','-','D',4), XT_TRUE, LIT((CELL)(((UCELL)(~0))>>1)), XT_EXIT,
	H5('M','A','X','-','N',2), XT_PAREN_CONSTANT, (CELL)(((UCELL)(~0))>>1),
	H6('M','A','X','-','U','D',3), XT_TRUE, XT_TRUE, XT_EXIT,
	H18('R','E','T','U','R','N','-','S','T','A','C','K','-','C','E','L','L','S',2), XT_PAREN_CONSTANT, ReturnStackCells,
	H11('S','T','A','C','K','-','C','E','L','L','S',2), XT_PAREN_CONSTANT, StackCells,
	0
	};


/**
@brief Implementation of the forth virtual machine.
*/
class ForthVM : public Forth
	{
private:
	/** Implementation of Forth::Reset */
	bool DoReset();

	/** Implementation of Forth::Quit */
	CELL DoQuit();

	/** Implementation of Forth::Execute */
	CELL DoExecute(CELL xt);

	/** Implementation of Forth::Evaluate */
	CELL DoEvaluate(const CHAR* text,unsigned textLength);

	/** Implementation of Forth::Push */
	void DoPush(const CELL* cells, unsigned numCells);

	/** Implementation of Forth::Pop */
	const CELL* DoPop(unsigned numCells);
private:
	/**
	Execute forth code.
	@param ip Pointer to the forth execution tokens to execute.
	@return Forth exception number or zero if code executed OK.
	*/
	CELL Run(const CELL* ip);

	/**
	Called if there is not a \c CATCH for a \c THROW.
	@param exceptionNumber	Forth exception number
	@return \a exceptionNumber
	*/
	CELL UncaughtException(CELL exceptionNumber);
private:
	/**
	Object used to perform console i/o.
	*/
	ForthIo*	Io;

	/**
	Initial value for the parameter stack.
	*/
	CELL*		Sp0;

	/**
	Initial value for the return stack.
	*/
	CELL*		Rp0;

	/**
	The address immediately after the memory used by the virtual machine.
	Note, member data after this member is zeroed on reboot of forth VM
	*/
	CELL*		MemoryEnd;

	/**
	Saved value for the parameter stack.
	Only valid when VM code is not executing.
	*/
	CELL*		Sp;

	/**
	Saved value for the restore stack.
	Only valid when VM code is not executing.
	*/
	CELL*		Rp;

	/**
	The Dictionary Pointer. (The value returned by \c HERE.)
	*/
	CHAR*		Dp;

	/**
	The maximum valid value for #Dp
	*/
	UCELL		DpLimit;

	/**
	Length of the current input buffer.
	*/
	UCELL		SourceSize;

	/**
	Start address of the current input buffer.
	Note, this member must immediately follow #SourceSize.
	*/
	CELL		SourceBase;

	/**
	The address of this member is returned by \c >IN.
	*/
	UCELL		SourceOffset;

	/**
	Stores the value returned by \c SOURCE-ID
	Note, this member must immediately follow #SourceOffset.
	*/
	CELL		SourceId;

	/**
	List of wordlists in the dictionary search order. The first cell contains
	a count of the number of wordlists, following cells contain pointers to
	wordlists in the order they will be searched.
	*/
	CELL		Context[MaxWordlists+1];

	/**
	Pointer to the wordlist to which new definitions will be added.
	I.e. contains the value returned by \c GET-CURRENT.
	*/
	CELL		Current;

	/**
	Pointer to the Link Field Address of the last word to be defined.
	(Or the current word being defined.)
	*/
	CELL		Latest;	
									
	/**
	The address of this member is returned by \c STATE.
	*/
	CELL		State;

	/**
	The address of this member is returned by \c BASE.
	*/
	CELL		Base;

	/**
	Pointer to the latest exception frame used by \c CATCH and \c THROW.
	*/
	CELL*		ExceptionFrame;

	/**
	\c c-addr and \c u which indicate the string
	associated with the last \c ABORT" performed.
	Also used to store the name of a word when it
	wasn't found in the dictionary.
	This member is used in the implementation of
	\c QUIT to display a message when an uncaught
	\c THROW is executed.
	*/
	CELL		ExceptionMessage[2];

	/**
	The main forth wordlist.
	*/
	Wordlist	ForthWordlist;

	/**
	Wordlist used to store words for environment queries.
	*/
	Wordlist	EnvironmentWordlist;

	static void MultiplyPrimitive(CELL* sp);
	static void DividePrimitive(CELL* sp);
	static void ToNumber(CELL* sp,UCELL base);
	void ParsePrimitive(CELL* sp,CELL delimiter);
	CELL FindPrimitive(CELL* sp,CELL wordlist);
	CELL Accept(CHAR* buffer, CELL maxLen);

	friend class Forth;
	};


bool ForthVM::DoReset()
	{
	// clear all memory
	CELL* end = MemoryEnd;
	CELL* ptr = (CELL*)(&this->MemoryEnd+1);
	while(ptr<end) *ptr++=0;

	// make space for TIB at end of memory
	end -= (NumberTIB*sizeof(CHAR)+(sizeof(CELL)-1))/sizeof(CELL);

	// initialise stacks
	Rp0 = end;
	Rp = end;
	end -= ReturnStackCells;

	Sp0 = end;
	Sp = end;
	end -= StackCells;

	// initialse user variables
	DpLimit = (UCELL)end-DictionaryOverhead;
	Dp = (CHAR*)(this+1);
	if((UCELL)Dp>=DpLimit)
		return false;
	Base = 10;

	// initialise dictionary
	ForthWordlist.LastWord = (CELL)ForthDictionary;
	ForthWordlist.Previous = (CELL)&EnvironmentWordlist;
	EnvironmentWordlist.LastWord = (CELL)EnvironmentDictionary;

	Context[0] = 2;
	Context[1] = (CELL)&ForthWordlist;
	Context[2] = (CELL)&EnvironmentWordlist;
	Current = (CELL)&ForthWordlist;

	return true;
	}


inline CELL ForthVM::DoQuit()
	{
	return DoExecute((CELL)XT_QUIT);
	}


inline CELL ForthVM::DoExecute(CELL xt)
	{
	CELL execute[2];
	execute[0] = xt;
	execute[1] = XT_END;
	return ((ForthVM*)this)->Run(execute);
	}


inline CELL ForthVM::DoEvaluate(const CHAR* text,unsigned textLength)
	{
	SourceBase = (CELL)text;
	SourceSize = textLength;
	SourceOffset = 0;
	SourceId = -2;
	return Execute((CELL)XT_INTERPRET);
	}


inline const CELL* ForthVM::DoPop(unsigned numCells)
	{
	CELL* cells = Sp;
	Sp+=numCells;
	return cells;
	}


inline void ForthVM::DoPush(const CELL* cells, unsigned numCells)
	{
	CELL* sp = Sp-numCells;
	Sp = sp;
	while(numCells--)
		*sp++ = *cells++;
	}


#define NEXT			goto next
#define BRANCH			ip = (CELL*)((CELL)ip+(CELL)ip[0]); NEXT
#define THROW(a)		{ t=a; goto exception; }
#define CALL(a)			{ xt=(CELL)(a); goto call; }

#define PUSH(a)			{ *--sp=(CELL)(a); }
#define POP(a)			{ (a)=*sp++; }
#define RPUSH(a)		{ *--rp=(CELL)(a); }
#define RPOP(cast,a)	{ (a)=(cast)*rp++; }

CELL ForthVM::Run(const CELL* ip)
	{
	CELL*	sp = Sp;
	CELL*	rp = Rp;
	CELL	t = *sp++;
	CELL	x = 0;
	CELL	xt;
	goto next;
call:
	RPUSH(ip);
	ip=(CELL*)xt;
next:
	xt = *ip++;
execute:
	switch(xt)
		{
	case XT_BREAKPOINT:				BREAKPOINT; NEXT;
	case XT_END:					PUSH(t); Sp = sp; Rp = rp; return 0;

	case XT_CATCH:					RPUSH(ip); RPUSH(sp); RPUSH(XT_CATCH_END); ip = rp;
									RPUSH(ExceptionFrame); ExceptionFrame = rp;
									// fall through to EXECUTE...
	case XT_EXECUTE:				xt=t; POP(t); goto execute;

	case XT_CATCH_END:				RPOP(CELL*,ExceptionFrame); ++rp; ++rp; PUSH(t); t=0;
									// fall through to EXIT...
	case XT_EXIT:					RPOP(CELL*,ip); NEXT;

	case XT_THROW:					if(!t) { POP(t); NEXT; }
						exception:	rp=ExceptionFrame;
									if(rp)
										{
										RPOP(CELL*,ExceptionFrame); ++rp; RPOP(CELL*,sp); RPOP(CELL*,ip); NEXT;
										}
									Sp = sp; Rp = rp; return UncaughtException(t);

	case XT_EXCEPTION_MESSAGE:		PUSH(t); t=(CELL)ExceptionMessage; NEXT;

	case XT_CODE_EXECUTE:			sp=((CELL*(*)(CELL*))t)(sp); POP(t); NEXT;
	case XT_PAREN_0BRANCH:			x=t; POP(t); if(x) { ++ip; NEXT; } // fall through to BRANCH...
	case XT_PAREN_BRANCH:			BRANCH;
	case XT_PAREN_LITERAL:			PUSH(t); t=*ip++; NEXT;
	case XT_PAREN_CONSTANT:			PUSH(t); t=*ip; RPOP(CELL*,ip); NEXT;

	// Looping
	case XT_PAREN_QUESTION_DO:		if(t==*sp) { t = sp[1]; sp+=2; BRANCH; } // fall through to (DO)...
	case XT_PAREN_DO:				RPUSH(ip++); POP(x); RPUSH(x); RPUSH(t); POP(t); NEXT;
	case XT_LEAVE:					rp+=2; RPOP(CELL*,ip); BRANCH;
	case XT_PAREN_LOOP:				x=*rp+1; *rp=x; if(x!=rp[1]) { BRANCH; } ++ip; // fall through to UNLOOP...
	case XT_UNLOOP:					rp+=3; NEXT;
	case XT_J:						PUSH(t); t=rp[3]; NEXT;
	case XT_PAREN_PLUS_LOOP:	{	x = rp[0]; t+=x; rp[0]=t; CELL lim=rp[1];
									if(( ((x-lim)&(lim-1-t)) | ((t-lim)&(lim-1-x)) )>=0)
										{ POP(t); BRANCH; }
									POP(t); ip++; rp += 3; NEXT; }

	// Arithmetic
	case XT_PLUS:					POP(x); t=x+t; NEXT;
	case XT_MINUS:					POP(x); t=x-t; NEXT;
	case XT_STAR:					POP(x); t=x*t; NEXT;
	case XT_UM_STAR:				PUSH(t); MultiplyPrimitive(sp); POP(t); NEXT;
	case XT_UDM_SLASH_MOD:			PUSH(t); if(!t) THROW(DivideByZero); DividePrimitive(sp); POP(t); NEXT;
	case XT_AND:					POP(x); t=x&t; NEXT;
	case XT_OR:						POP(x); t=x|t; NEXT;
	case XT_XOR:					POP(x); t=x^t; NEXT;
	case XT_LSHIFT:					POP(x); t=x<<t; NEXT;
	case XT_RSHIFT:					POP(x); t=(UCELL)x>>t; NEXT;
	case XT_INVERT:					t = ~t; NEXT;
	case XT_ABS:					if(t>=0) NEXT; // fall through to NEGATE...
	case XT_NEGATE:					t=-t; NEXT;
	case XT_1_PLUS:					++t; NEXT;
	case XT_1_MINUS:				--t; NEXT;
	case XT_2_STAR:					t<<=1; NEXT;
	case XT_2_SLASH:				t>>=1; NEXT;
	case XT_MIN:					POP(x); if(x<t) t=x; NEXT;
	case XT_MAX:					POP(x); if(x>t) t=x; NEXT;

	case XT_DABS:					if(t>=0) NEXT; // fall through to DNEGATE...
	case XT_DNEGATE:				x=*sp; *sp=-x; if(x) t=~t; else t=-t; NEXT;
	case XT_M_PLUS:					PUSH(t); t>>=(BitsPerCell-1); // fall through to D+...
	case XT_D_PLUS:					sp[2]+=sp[0]; if((UCELL)sp[2]<(UCELL)sp[0]) ++t; t+=sp[1]; sp+=2; NEXT;

	// Memory access
	case XT_CELLS:					t=CELLS(t); NEXT;
	case XT_CHARS:					t=CHARS(t); NEXT;
	case XT_CELL_PLUS:				t = (CELL)((CELL*)t+1); NEXT;
	case XT_CHAR_PLUS:				t = (CELL)((CHAR*)t+1); NEXT;
	case XT_ALIGNED:				t=ALIGNED(t); NEXT;
	case XT_2_FETCH:				PUSH(((CELL*)t)[1]); // fall through to @
	case XT_FETCH:					t=*(CELL*)t; NEXT;
	case XT_STORE:					POP(x); *(CELL*)t=x; POP(t); NEXT;
	case XT_C_FETCH:				t=*(CHAR*)t; NEXT;
	case XT_C_STORE:				POP(x); *(CHAR*)t=x; POP(t); NEXT;
	case XT_2_STORE:				POP(x); *((CELL*)t)=x; POP(x); ((CELL*)t)[1]=x; POP(t); NEXT;
	case XT_PLUS_STORE:				POP(x); *(CELL*)t+=x; POP(t); NEXT;
	case XT_COUNT:					t = (CELL)((CHAR*)t+1); PUSH(t); t=((CHAR*)t)[-1]; NEXT;

	case XT_MOVE:					t=SLASH_CHAR(t);
									if((UCELL)(sp[0]-sp[1])<(UCELL)CHARS(t)) goto cmove_up;
									// fall through to CMOVE...

	case XT_CMOVE:					{	POP(x); CHAR* d=(CHAR*)x; POP(x); CHAR* s=(CHAR*)x; CHAR* lim=s+t;
										while(s<lim) *d++=*s++; POP(t); NEXT; }

	case XT_CMOVE_UP:				cmove_up:
									{	POP(x); CHAR* d=(CHAR*)x+t; POP(x); CHAR* lim=(CHAR*)x; CHAR* s=lim+t;
										while(s>lim) *--d=*--s; POP(t); NEXT; }

	case XT_ERASE:					t=SLASH_CHAR(t); PUSH(t); t=0; // fall through to FILL...

	case XT_FILL:					{	POP(x); CHAR* lim=(CHAR*)x; POP(x); CHAR* d=(CHAR*)x;
										if((CELL)lim>0)
											{ lim=d+(CELL)lim; while(d<lim) *d++=t; }
										POP(t); NEXT; }

	// Stack maniputation
	case XT_QUESTION_DUP:			if(!t) NEXT; // fall through to DUP
	case XT_DUP:					PUSH(t); NEXT;
	case XT_2DROP:					++sp; // fall through to DROP...
	case XT_DROP:					POP(t); NEXT;
	case XT_SWAP:					x=*sp; *sp=t; t=x; NEXT;
	case XT_OVER:					PUSH(t); t=sp[1]; NEXT;
	case XT_ROT:					x=sp[1]; sp[1]=sp[0]; sp[0]=t; t=x; NEXT;
	case XT_NIP:					++sp; NEXT;
	case XT_TUCK:					x=*sp; *sp=t; PUSH(x); NEXT; 
	case XT_2_TO_R:					POP(x); RPUSH(x); // fall through to >R
	case XT_TO_R:					RPUSH(t); POP(t); NEXT;
	case XT_R_FROM:					PUSH(t); RPOP(CELL,t); NEXT;
	case XT_I:						PUSH(t); t=*rp; NEXT;
	case XT_R_FETCH:				PUSH(t); t=*rp; NEXT;
	case XT_2DUP:					x=*sp; PUSH(t); PUSH(x); NEXT; 
	case XT_2SWAP:					x=sp[1]; sp[1]=t; t=x; x=sp[2]; sp[2]=sp[0]; sp[0]=x; NEXT;
	case XT_2OVER:					PUSH(t); t=sp[3]; PUSH(t); t=sp[3]; NEXT;
	case XT_2_R_FROM:				PUSH(t); RPOP(CELL,t); RPOP(CELL,x); PUSH(x); NEXT;
	case XT_2_R_FETCH:				PUSH(t); t=rp[0]; x=rp[1]; PUSH(x); NEXT;
	case XT_RDROP:					++rp; NEXT;
	case XT_PICK:					t=sp[t]; NEXT;
	case XT_ROLL:					x = sp[t]; while(t) { sp[t]=sp[t-1]; --t; } t=x; ++sp; NEXT;
	case XT_DEPTH:					PUSH(t); t=(CELL*)Sp0-sp; NEXT;
	case XT_EMPTYS:					sp=Sp0+1; NEXT;
	case XT_EMPTYR:					ExceptionFrame=0; rp=Rp0; NEXT;

	// Comparison operation
	case XT_0_EQUALS:				if(t==0) t=~0; else t=0; NEXT;
	case XT_0_NOT_EQUALS:			if(t!=0) t=~0; NEXT;
	case XT_S_TO_D:					PUSH(t); // fall through to 0< ...
	case XT_0_LESS:					t>>=(BitsPerCell-1); NEXT;
	case XT_0_GREATER:				if(t>0) t=~0; else t=0; NEXT;
	case XT_EQUALS:					POP(x); if(x==t) t=~0; else t=0; NEXT;
	case XT_NOT_EQUALS:				POP(x); if(x!=t) t=~0; else t=0; NEXT;
	case XT_LESS_THAN:				POP(x); if(x<t) t=~0; else t=0; NEXT;
	case XT_GREATER_THAN:			POP(x); if(x>t) t=~0; else t=0; NEXT;
	case XT_U_LESS_THAN:			POP(x); if((UCELL)x<(UCELL)t) t=~0; else t=0; NEXT;
	case XT_U_GREATER_THAN:			POP(x); if((UCELL)x>(UCELL)t) t=~0; else t=0; NEXT;
	case XT_TRUE:					PUSH(t); t=~0; NEXT;
	case XT_FALSE:					PUSH(t); t=0; NEXT;

	// Dictionary manipulation
	case XT_HERE:					PUSH(t); t=(CELL)Dp; NEXT;
	case XT_ALLOT:					x=(CELL)Dp; x=(CELL)((CHAR*)x+t); Dp=(CHAR*)x; POP(t); NEXT;
	case XT_ALIGN:					x=(CELL)Dp; x=ALIGNED(x); Dp=(CHAR*)x; NEXT;
	case XT_COMMA:					{ CELL* p=(CELL*)Dp; *p++=t; Dp=(CHAR*)p; } POP(t); NEXT;
	case XT_C_COMMA:				*((CHAR*&)Dp)++=t; POP(t); NEXT;
	case XT_UNUSED:					PUSH(t); t=DpLimit-(UCELL)Dp; NEXT;
	case XT_PAD:					PUSH(t); t=(CELL)Dp+CHARS(SlashCountedString+2); NEXT;

	// Input parsing
	case XT_PAREN_SOURCE:			PUSH(t); t=(CELL)&SourceSize; NEXT;
	case XT_TO_IN:					PUSH(t); t=(CELL)&SourceOffset; NEXT;
	case XT_PARSE_WORD:				PUSH(t); t=~' '; // fall through to PARSE...
	case XT_PARSE:					ParsePrimitive(sp,t); --sp; t=sp[-1]; NEXT;
	case XT_TO_NUMBER:				PUSH(t); ToNumber(sp,Base); POP(t); NEXT;

	// Dictionary search
	case XT_CONTEXT:				PUSH(t); t=(CELL)&Context; NEXT;
	case XT_CURRENT:				PUSH(t); t=(CELL)&Current; NEXT;
	case XT_LATEST:					PUSH(t); t=(CELL)&Latest; NEXT;
	case XT_FORTH_WORDLIST:			PUSH(t); t=(CELL)&ForthWordlist; NEXT;
	case XT_PAREN_SEARCH_WORDLIST:	t=FindPrimitive(sp,t); NEXT;
	case XT_TO_CFA:					t=(CELL)((WordHeader*)t)->CFA(); NEXT;

	// Compilation state
	case XT_STATE:					PUSH(t); t=(CELL)&State; NEXT;
	case XT_LEFT_BRACKET:			State=0; NEXT;
	case XT_RIGHT_BRACKET:			State=~0; NEXT;

	// Console i/o
	case XT_SPACE:					PUSH(t); t=' '; // fall through to EMIT...
	case XT_EMIT:					x = (CELL)((CHAR*)rp-1); *(CHAR*)x=(CHAR)t; PUSH(x); t=1; // Fall through to type...
	case XT_TYPE:					Io->ConsoleOut((CHAR*)*sp++,t); POP(t); NEXT;
	case XT_KEY:					PUSH(t); do t=Io->ConsoleIn(); while((UCELL)t>255); NEXT;
	case XT_ACCEPT:					POP(x); t=Accept((CHAR*)x,t); NEXT;
	case XT_PAREN_CR:				PUSH(t); PUSH(&Io->NewLine[1]); t=(CELL)Io->NewLine[0]; NEXT;
	case XT_TIB:					PUSH(t); t=(CELL)Rp0; NEXT;

	// Number conversion
	case XT_BASE:					PUSH(t); t=(CELL)&Base; NEXT;
	case XT_LESS_NUMBER_SIGN:		*Dp=SlashCountedString; NEXT;

	case XT_NUMBER_SIGN_GREATER:	t=(CELL)(SlashCountedString-*Dp);
									sp[0]=(CELL)(Dp+(SlashCountedString+1-t)); NEXT;

	case XT_SIGN:					if(t>=0) { POP(t); NEXT; } t='-'; goto hold;

	case XT_NUMBER_SIGN:			PUSH(t); sp[-1]=Base; DividePrimitive(sp-1);
									t=sp[1]; sp[1]=sp[0]; sp[0]=sp[-1];
									t+='0'; if(t>'9') t+='A'-'9'-1; // fall through to HOLD...

	case XT_HOLD:			hold:	if(*Dp==0) THROW(-17);
									Dp[*Dp]=(CHAR)t; --Dp[0]; POP(t); NEXT;

	default:
		goto call;
	}
}


CELL ForthVM::UncaughtException(CELL exceptionNumber)
	{
	Io->ConsoleOut((const CHAR*)ExceptionMessage[1],ExceptionMessage[0]);
	if(exceptionNumber==-13)
		{
		CHAR c = ' ';
		Io->ConsoleOut(&c,1);
		c = '?';
		Io->ConsoleOut(&c,1);
		}
	{
	CHAR* source = (CHAR*)SourceBase+SourceOffset;
	*(volatile CHAR*)source; // to avoid warning about 'source' being unused
	BREAKPOINT;
	}
	State = 0;
	return exceptionNumber;
	}


void ForthVM::MultiplyPrimitive(CELL* sp) // (u1 u2 -- ud )
	{
	UCELL a = (UCELL)sp[0];
	UCELL b = (UCELL)sp[1];

	UCELL lo = (a&CellLoMask)*(b&CellLoMask);
	UCELL hi = (a>>(BitsPerCell/2))*(b>>(BitsPerCell/2));
	UCELL i1 = (a&CellLoMask)*(b>>(BitsPerCell/2));
	UCELL i2 = (a>>(BitsPerCell/2))*(b&CellLoMask);

	i1 += i2;
	if(i1<i2)
		hi += (CELL)(UCELL)1<<(BitsPerCell/2);
	hi += i1>>(BitsPerCell/2);
	i1 <<= (BitsPerCell/2);
	lo += i1;
	if(lo<i1)
		hi++;

	sp[0] = hi;
	sp[1] = lo;
	}


void ForthVM::DividePrimitive(CELL* sp) // (ud1 u1 -- u2[remainder] ud2[quotient])
	{
	UCELL d  = sp[0];
	UCELL r  = 0;
	UCELL qh = sp[1];
	UCELL ql = sp[2];
	int n  = 2*BitsPerCell;

	if(qh<d)
		{
		r = qh;
		qh = ql;
		ql = 0;
		n -= BitsPerCell;
		}

	UCELL c  = 0;
	do
		{
		UCELL sub = r>>(BitsPerCell-1);

		r  = (r<<1)+(qh>>(BitsPerCell-1));
		qh = (qh<<1)+(ql>>(BitsPerCell-1));
		ql = (ql<<1)+c;

		if(r>=d) sub = 1;
		c = sub;
		if(sub)
			r -= d;
		}
	while(--n);
	
	qh = (qh<<1)+(ql>>(BitsPerCell-1));
	ql = (ql<<1)+c;
	
	sp[0] = qh;
	sp[1] = ql;
	sp[2] = r;
	}


void ForthVM::ToNumber(CELL* sp,UCELL base) // ( d1 c-addr2 u2 -- d2 c-addr2 u2 )
	{
	UCELL count = sp[0];
	CHAR* ptr = (CHAR*)sp[1];
	UCELL hi = sp[2];
	UCELL lo = sp[3];

	while(count)
		{
		UCELL c=ptr[0];
		if(c>='a')
			c -= 'a'-'A';
		c -= '0';
		if(c>=10)
			{
			c -= 'A'-'9'-1;
			if(c<10)
				break;
			}
		if(c>=base)
			break;

		UCELL mid = lo>>(BitsPerCell/2);
		lo &= CellLoMask;
		lo = lo*base+c;
		mid *= base;
		hi *= base;
		hi += mid>>(BitsPerCell/2);
		mid = mid<<(BitsPerCell/2);
		lo = lo+mid;
		if(lo<mid)
			++hi;

		++ptr;
		--count;
		}

	sp[0] = count;
	sp[1] = (CELL)ptr;
	sp[2] = hi;
	sp[3] = lo;
	}


void ForthVM::ParsePrimitive(CELL* sp,CELL delimiter) // ( -- c-addr u )
	{
	CHAR* base = (CHAR*)SourceBase;
	CHAR* end = base+SourceSize;
	CHAR* in = base+SourceOffset;
	CHAR* start;

	CELL skipLeading = delimiter>>(BitsPerCell-1);
	if(skipLeading)
		delimiter = ~delimiter;

	if(delimiter==' ')
		{
		if(skipLeading)
			while(in<end && *in<=' ')
				++in;
		start = in;
		while(in<end)
			if(*in++<=' ')
				goto delimited;
		}
	else
		{
		if(skipLeading)
			while(in<end && *in==delimiter)
				++in;
		start = in;
		while(in<end)
			if(*in++==delimiter)
				goto delimited;
		}

	sp[-1] = (CELL)start;
	sp[-2] = in-start;
	SourceOffset = in-base;
	return;

delimited:
	sp[-1] = (CELL)start;
	sp[-2] = in-start-1;
	SourceOffset = in-base;
	}


inline bool MatchChars(CELL a, CELL b)
	{
	if(a>='a' && a<='z')
		a -= 'a'-'A';
	if(b>='a' && b<='z')
		b -= 'a'-'A';
	return a==b;
	}


CELL ForthVM::FindPrimitive(CELL* sp,CELL wordlist) // (c-addr u -- c-addr u 0 | xt immed header )
	{
	UCELL nameLength = (UCELL)sp[0];
	if(nameLength>(UCELL)NameLengthMask)
		nameLength=NameLengthMask;
	CHAR* name = (CHAR*)sp[1];

	WordHeader* word=*(WordHeader**)wordlist;
	while(word->Previous)
		{
		UCELL i;
		if((UCELL)(word->NameLength&NameLengthMask)!=nameLength)
			goto next;
		for(i=0; i<nameLength; i++)
			if(!MatchChars(word->Name[i],name[i]))
				goto next;
		if(word->NameLength&WordHeader::Valid)
			{
			CELL xt = (CELL)word->CFA();
			if(word->NameLength&WordHeader::Token)
				xt = *(CELL*)xt;

			sp[1] = xt;
			sp[0] = word->NameLength&WordHeader::Immediate ? ~0 : 0;
			return (CELL)word;
			}
next:
		word=(WordHeader*)((CELL)word+word->Previous);
		}
	return 0;
	}


CELL ForthVM::Accept(CHAR* buffer, CELL maxLen)
	{
	CELL len=0;
	for(;;)
		{
		CELL c=Io->ConsoleIn();
		if(c==Io->NewLine[1])
			return len;
		if(c==8)
			{
			if(!len)
				continue;
			--len;
			static const CHAR bs[] = {8,' ',8};
			Io->ConsoleOut(bs,3);
			}
		else
			{
			if(len>=maxLen)
				continue;
			buffer[len] = c;
			Io->ConsoleOut(&buffer[len],1);
			len++;
			}
		}
	}


/** @} */ // End of group

//
// Definition of the public Forth class members follow...
//

Forth* Forth::Construct(void* memoryStart,size_t memorySize,ForthIo* ioHandler)
	{
	if(memorySize<sizeof(ForthVM))
		return 0;
	ForthVM* forth = (ForthVM*)memoryStart;
	forth->MemoryEnd = (CELL*)memoryStart+memorySize/sizeof(CELL);
	forth->Io = ioHandler;
	if(!forth->DoReset())
		return 0;
	return forth;
	}


void Forth::Reset()
	{
	((ForthVM*)this)->DoReset();
	}


CELL Forth::Quit()
	{
	return ((ForthVM*)this)->DoQuit();
	}


CELL Forth::Execute(CELL xt)
	{
	return ((ForthVM*)this)->DoExecute(xt);
	}


CELL Forth::Evaluate(const CHAR* text,unsigned textLength)
	{
	return ((ForthVM*)this)->DoEvaluate(text,textLength);
	}


const CELL* Forth::Pop(unsigned numCells)
	{
	return ((ForthVM*)this)->DoPop(numCells);
	}


void Forth::Push(const CELL* cells, unsigned numCells)
	{
	((ForthVM*)this)->DoPush(cells,numCells);
	}