forth.cpp

Go to the documentation of this file.

/*
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.
*/

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

#if 1
#define LITTLE_ENDIAN   
#else
#define BIG_ENDIAN      
#endif

#define CELLS(x)        ((CELL)(((CELL*)256)+(x))-(CELL)((CELL*)256))

#define CHARS(x)        ((CELL)(((CHAR*)256)+(x))-(CELL)((CHAR*)256))

#define SLASH_CELL(x)   ((CELL*)(256+(x))-((CELL*)256))

#define SLASH_CHAR(x)   ((CHAR*)(256+(x))-((CHAR*)256))

#define ALIGNED(x)      (((x)+CELLS(1)-1)&~(CELLS(1)-1))

static const CELL BitsPerCell = BITS_PER_CHAR*CHARS_PER_CELL;

static const CELL CellLoMask = ((CELL)1<<(BitsPerCell/2))-1;

static const CELL SlashCountedString = 255;

static const CELL NameLengthMask = 31;

static const CELL NumberTIB = 80;

static const CELL SlashPad = 84;

static const CELL DictionaryOverhead = CHARS(SlashCountedString+2+SlashPad);

static const CELL MaxWordlists = 16;

static const CELL StackCells = 256;

static const CELL ReturnStackCells = 256;


class WordHeader
    {
public:
    CELL Previous;

    CHAR NameLength;

    CHAR Name[1];

    enum WordFlags
        {
        Token       = 1<<5, 
        Immediate   = 1<<6, 
        Valid       = 1<<7  
        };

public:
    inline CELL* CFA()
        { return (CELL*)ALIGNED((CELL)(Name+(NameLength&NameLengthMask))); }
    };


enum Exception
    {
    DivideByZero = -10,
    ResultOutOfRange = -11,
    UndefinedWord = -13,
    ZeroLengthName = -16,
    PicturedStringOverflow = -17,
    ControlStructureMismatch = -22
    };


struct Wordlist
    {
    CELL LastWord;

    CELL Previous;

    CELL Name;
    };


enum ControlStackMarkers
    {
    ColonMagic = 12340, 
    OrigMagic  = 12341, 
    DestMagic  = 12342  
    };


enum ForthXT
    {
    XT_STORE,               
    XT_NUMBER_SIGN,         
    XT_NUMBER_SIGN_GREATER, 
    XT_STAR,                
    XT_PLUS,                
    XT_PLUS_STORE,          
    XT_PAREN_PLUS_LOOP,     
    XT_COMMA,               
    XT_MINUS,               
    XT_0_LESS,              
    XT_0_EQUALS,            
    XT_1_PLUS,              
    XT_1_MINUS,             
    XT_2_STORE,             
    XT_2_STAR,              
    XT_2_SLASH,             
    XT_2_FETCH,             
    XT_2DROP,               
    XT_2DUP,                
    XT_2OVER,               
    XT_2SWAP,               
    XT_LESS_THAN,           
    XT_LESS_NUMBER_SIGN,    
    XT_EQUALS,              
    XT_GREATER_THAN,        
    XT_TO_IN,               
    XT_TO_NUMBER,           
    XT_TO_R,                
    XT_QUESTION_DUP,        
    XT_FETCH,               
    XT_ABS,                 
    XT_ACCEPT,              
    XT_ALIGN,               
    XT_ALIGNED,             
    XT_ALLOT,               
    XT_AND,                 
    XT_BASE,                
    XT_C_STORE,             
    XT_C_COMMA,             
    XT_C_FETCH,             
    XT_CELL_PLUS,           
    XT_CELLS,               
    XT_CHAR_PLUS,           
    XT_CHARS,               
    XT_PAREN_CONSTANT,      
    XT_COUNT,               
    XT_DEPTH,               
    XT_PAREN_DO,            
    XT_DROP,                
    XT_DUP,                 
    XT_PAREN_BRANCH,        
    XT_EMIT,                
    XT_EXECUTE,             
    XT_EXIT,                
    XT_FILL,                
    XT_HERE,                
    XT_HOLD,                
    XT_I,                   
    XT_PAREN_0BRANCH,       
    XT_INVERT,              
    XT_J,                   
    XT_KEY,                 
    XT_LEAVE,               
    XT_PAREN_LITERAL,       
    XT_PAREN_LOOP,          
    XT_LSHIFT,              
    XT_MAX,                 
    XT_MIN,                 
    XT_MOVE,                
    XT_NEGATE,              
    XT_OR,                  
    XT_OVER,                
    XT_R_FROM,              
    XT_R_FETCH,             
    XT_ROT,                 
    XT_RSHIFT,              
    XT_S_TO_D,              
    XT_SIGN,                
    XT_SPACE,               
    XT_STATE,               
    XT_SWAP,                
    XT_TYPE,                
    XT_U_LESS_THAN,         
    XT_UM_STAR,             
    XT_UNLOOP,              
    XT_XOR,                 
    XT_LEFT_BRACKET,        
    XT_RIGHT_BRACKET,       
    XT_0_NOT_EQUALS,        
    XT_0_GREATER,           
    XT_2_TO_R,              
    XT_2_R_FROM,            
    XT_2_R_FETCH,           
    XT_NOT_EQUALS,          
    XT_PAREN_QUESTION_DO,   
    XT_ERASE,               
    XT_FALSE,               
    XT_NIP,                 
    XT_PAD,                 
    XT_PARSE,               
    XT_PICK,                
    XT_ROLL,                
    XT_TRUE,                
    XT_TUCK,                
    XT_U_GREATER_THAN,      
    XT_UNUSED,              
    XT_D_PLUS,              
    XT_DABS,                
    XT_DNEGATE,             
    XT_M_PLUS,              
    XT_CATCH,               
    XT_THROW,               
    XT_CMOVE,               
    XT_CMOVE_UP,            
    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
    };

#define XT_BRANCH(offset) XT_PAREN_BRANCH,CELLS(offset)

#define XT_0BRANCH(offset) XT_PAREN_0BRANCH,CELLS(offset)

#define LIT(x) XT_PAREN_LITERAL,(CELL)x


static const CELL XT_NEST_CHECK[] =
    {
    XT_EQUALS, XT_0BRANCH(2), XT_EXIT,                      // = IF EXIT THEN
    LIT(ControlStructureMismatch), XT_THROW                 // -22 THROW
    };


static const CELL XT_FORWARD_BRANCH_COMMA[] =
    {
    XT_COMMA, XT_HERE, XT_FALSE, XT_COMMA,                  // , HERE 0 ,
    LIT(OrigMagic), XT_EXIT                                 // OrigMagic
    };


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 - ,
    };


static const CELL XT_IF[] =
    {
    LIT(XT_PAREN_0BRANCH), (CELL)XT_FORWARD_BRANCH_COMMA,   // ['] (0branch) >BRANCH,
    XT_EXIT
    };


static const CELL XT_AHEAD[] =
    {
    LIT(XT_PAREN_BRANCH), (CELL)XT_FORWARD_BRANCH_COMMA,    // ['] (branch) >BRANCH,
    XT_EXIT
    };


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 !
    };


static const CELL XT_BEGIN[] =
    {
    XT_HERE, LIT(DestMagic), XT_EXIT                        // HERE DestMagic
    };


static const CELL XT_AGAIN[] =
    {
    LIT(XT_PAREN_BRANCH), (CELL)XT_BACKWARD_BRANCH_COMMA,   // ['] (branch) <BRANCH,
    XT_EXIT
    };


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
    };


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
    };


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
    };


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
    };


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
    };


#define XT_M_SLASH_MOD (((-1)/2) ? (CELL)XT_FM_SLASH_MOD : (CELL)XT_SM_SLASH_REM)


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
    };


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
    };


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
    };


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
    };


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
    };


static const CELL XT_DOT[] =
    {
    XT_S_TO_D, (CELL)XT_D_DOT, XT_EXIT                      // S>D D.
    };


static const CELL XT_CR[] =
    {
    XT_PAREN_CR, XT_TYPE, XT_EXIT                           // (cr) TYPE
    };


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
    };


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
    };


static const CELL XT_PAREN_CREATE[] =
    {
    XT_R_FROM, XT_EXIT                                      // R>
    };


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
    };


static const CELL XT_PAREN_DOES[] =
    {
    XT_R_FROM, XT_LATEST, XT_FETCH, XT_TO_CFA, XT_STORE,    // R> LATEST @ >CFA !
    XT_EXIT
    };


static const CELL XT_LITERAL[] =
    {
    LIT(XT_PAREN_LITERAL), XT_COMMA, XT_COMMA,              // ['] (literal) , ,
    XT_EXIT
    };


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
    };


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
    };


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
    };


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
    };


static const CELL XT_THROW_QUOTE[] =
    {
    XT_TO_R, XT_EXCEPTION_MESSAGE, XT_2_STORE,
    XT_R_FROM, XT_THROW
    };


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"
    };


static const CELL XT_TICK[] =
    {
    (CELL)XT_PAREN_TICK, XT_DROP, XT_EXIT                   // (') DROP
    };


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
    };


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
    };


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"
    };


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"
    };


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
    };


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
    };


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
    };


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
    };


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(17), (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'};

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 .
    };


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

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
    };


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
    };


class ForthVM : public Forth
    {
private:
    bool DoReset();

    CELL DoQuit();

    CELL DoExecute(CELL xt);

    CELL DoEvaluate(const CHAR* text,unsigned textLength);

    void DoPush(const CELL* cells, unsigned numCells);

    const CELL* DoPop(unsigned numCells);
private:
    CELL Run(const CELL* ip);

    CELL UncaughtException(CELL exceptionNumber);
private:
    ForthIo*    Io;

    CELL*       Sp0;

    CELL*       Rp0;

    CELL*       MemoryEnd;

    CELL*       Sp;

    CELL*       Rp;

    CHAR*       Dp;

    UCELL       DpLimit;

    UCELL       SourceSize;

    CELL        SourceBase;

    UCELL       SourceOffset;

    CELL        SourceId;

    CELL        Context[MaxWordlists+1];

    CELL        Current;

    CELL        Latest;

    CELL        State;

    CELL        Base;

    CELL*       ExceptionFrame;

    CELL        ExceptionMessage[2];

    Wordlist    ForthWordlist;

    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::DoExecute(CELL xt)
    {
    CELL execute[2];
    execute[0] = xt;
    execute[1] = XT_END;
    return ((ForthVM*)this)->Run(execute);
    }


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


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==0x0a || c==0x0d) // LF or CR
            return len;
        if(c==0x08 || c==0x7f) // BS or DEL
            {
            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);
    }