forth.cpp

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

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