forth.cpp

Tixys source code, include G.711, G.726, IMA-ADPCM etc.

/**
@file

@brief Internal implementation of the forth virtual machine.

This program has been placed in the Public Domain by J.D.Medhurst (a.k.a. Tixy)
*/

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

This code has been placed in the Public Domain by J.D.Medhurst (a.k.a. Tixy).
It may be used, modified and distibuted in any manner, without any restriction.
@ingroup forth
@{
*/

#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 = 8;

/**
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.
	*/
	WordHeader* LastWord;

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

	/**
	Pointer to the WordHeader of a word whoes name will be given to this wordlist.
	(Used to implement \c ORDER.)
	*/
	WordHeader* 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.
		
*/