forth.cpp

这个是关于G.726算法的源程序

	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