core-ext.f

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

\ Tests for ANS Forth CORE EXTENSION words - Version 1.0
\
\ by J.D.Medhurst a.k.a 'Tixy' 2002
\
\ This file is based on John Hayes' TESTER.FR and CORE.FR which
\ have the following copyright notice:
\
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\
\ My contributions to this file are in the public domain.
\
\
\ Assumptions:
\ * TESTER.FR must be loaded before this file.
\ * Presence of CORE words and DEPTH.
\ * The system uses twos complement arithmetic.
\ * The word \ works.
\
\ Ommisions:
\ * The obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB
\   are not tested.
\ * Testing SOURCE-ID when user input device is input source.
\   (How do we test?)
\
\ Notes:
\ * Some PARSE tests depend on whether line termination characters
\   are present in the input source.
\ * MARKER should test search-order changes are restored but
\   they are in another wordset.
\

TESTING CORE-EXT WORDS
DECIMAL

\ ------------------------------------------------------------------------
{ -> }   \ Start with clean slate

\ Define some constants
0							CONSTANT <FALSE>
0 INVERT					CONSTANT <TRUE>
0 INVERT					CONSTANT MAX-UINT
0 INVERT 1 RSHIFT			CONSTANT MAX-INT
0 INVERT 1 RSHIFT INVERT	CONSTANT MIN-INT
0 INVERT 1 RSHIFT			CONSTANT MID-UINT
0 INVERT 1 RSHIFT INVERT	CONSTANT MID-UINT+1
: MIN-DINT 0 MIN-INT ;
: MAX-DINT MAX-UINT MAX-INT ;
: MAX-DUINT MAX-UINT MAX-UINT ;
: MID-DUINT 0 MID-UINT ;

\ ------------------------------------------------------------------------
TESTING FLAGS: TRUE FALSE
{ TRUE -> 0 INVERT }
{ FALSE -> 0 }

\ ------------------------------------------------------------------------
TESTING OUTPUT: .R U.R .(

: OUTPUT-TEST
	." YOU SHOULD SEE TWO IDENTICAL LINES:" CR
	."   ' 123' -123'123'-123'123'-123'123'123'"
	MAX-INT . [CHAR] ' EMIT MIN-INT . [CHAR] ' EMIT CR

	."   '" 
	123 4 .R [CHAR] ' EMIT
	-123 5 .R [CHAR] ' EMIT
	123 3 .R [CHAR] ' EMIT
	-123 4 .R [CHAR] ' EMIT
	123 2 .R [CHAR] ' EMIT
	-123 3 .R [CHAR] ' EMIT
	123 0 .R [CHAR] ' EMIT
	123 -1 .R [CHAR] ' EMIT
	MAX-INT -1 .R SPACE [CHAR] ' EMIT
	MIN-INT -1 .R SPACE [CHAR] ' EMIT
	CR

	." YOU SHOULD SEE TWO IDENTICAL LINES:" CR
	."   ' 123'123'123'123'" MAX-UINT U. [CHAR] ' EMIT CR

	."   '" 
	123 4 U.R [CHAR] ' EMIT
	123 2 U.R [CHAR] ' EMIT
	123 0 U.R [CHAR] ' EMIT
	123 -1 U.R [CHAR] ' EMIT
	MAX-UINT 1 U.R SPACE [CHAR] ' EMIT
	CR

	." YOU SHOULD SEE 'abc' :" CR
	."   "
;

{ OUTPUT-TEST .( 'abc') CR -> }

\ ------------------------------------------------------------------------
TESTING COMPARISONS: 0<> 0> <> U>

{ 0 0<> -> FALSE }
{ 1 0<> -> TRUE }
{ -1 0<> -> TRUE }

{ 0 0> -> FALSE }
{ -1 0> -> FALSE }
{ MIN-INT 0> -> FALSE }
{ 1 0> -> TRUE }
{ MAX-INT 0> -> TRUE }

{ 0 0 <> -> FALSE }
{ 1 1 <> -> FALSE }
{ -1 -1 <> -> FALSE }
{ 1 0 <> -> TRUE }
{ -1 0 <> -> TRUE }
{ 0 1 <> -> TRUE }
{ 0 -1 <> -> TRUE }

{ 0 1 U> -> FALSE }
{ 1 2 U> -> FALSE }
{ 0 MID-UINT U> -> FALSE }
{ 0 MAX-UINT U> -> FALSE }
{ MID-UINT MAX-UINT U> -> FALSE }
{ 0 0 U> -> FALSE }
{ 1 1 U> -> FALSE }
{ 1 0 U> -> TRUE }
{ 2 1 U> -> TRUE }
{ MID-UINT 0 U> -> TRUE }
{ MAX-UINT 0 U> -> TRUE }
{ MAX-UINT MID-UINT U> -> TRUE }

\ ------------------------------------------------------------------------
TESTING 2>R 2R> 2R@

{ : TEST-2>R 2>R R> R> SWAP ; -> }
{ 123 456 TEST-2>R -> 123 456 }

{ : TEST-2R> SWAP >R >R 2R> ; -> }
{ 123 456 TEST-2R> -> 123 456 }

{ : TEST-2R@ 2>R 2R@ 2R> DROP DROP ; -> }
{ 123 456 TEST-2R@ -> 123 456 }

\ ------------------------------------------------------------------------
TESTING :NONAME

{ :NONAME 123 ; DROP -> }
{ :NONAME 12 34 ; EXECUTE -> 12 34 }

\ ------------------------------------------------------------------------
TESTING ?DO

{ : TEST-DO?1 ?DO I LOOP ; -> }
{ 4 1 TEST-DO?1 -> 1 2 3 }
{ 2 -1 TEST-DO?1 -> -1 0 1 }
{ MID-UINT+1 MID-UINT TEST-DO?1 -> MID-UINT }
{ 4 4 TEST-DO?1 -> }
{ -4 -4 TEST-DO?1 -> }

{ : TEST-DO?2 ?DO I -1 +LOOP ; -> }
{ 1 4 TEST-DO?2 -> 4 3 2 1 }
{ -1 2 TEST-DO?2 -> 2 1 0 -1 }
{ MID-UINT MID-UINT+1 TEST-DO?2 -> MID-UINT+1 MID-UINT }
{ 4 4 TEST-DO?2 -> }
{ -4 -4 TEST-DO?2 -> }

{ : TEST-DO?3 ?DO I 2 = IF LEAVE THEN LOOP ; -> }
\ { 4 1 TEST-DO?3 -> 1 2 }

\ ------------------------------------------------------------------------
TESTING AGAIN

{ : TEST-AGAIN 0 BEGIN DUP 1+ DUP 3 = IF EXIT THEN AGAIN ; -> }
{ TEST-AGAIN -> 0 1 2 3 }

\ ------------------------------------------------------------------------
TESTING C"

{ : TEST-C"1 C" a" ; -> }
{ TEST-C"1 DUP C@ SWAP CHAR+ C@ -> 1 CHAR a }
{ : TEST-C"0 C" " ; -> }
{ TEST-C"0 C@ -> 0 }

\ ------------------------------------------------------------------------
TESTING COMPILE,

{ : TEST-COMPILE,1 COMPILE, ; IMMEDIATE -> }
{ : TEST-COMPILE,2 [ ' 1+ ] TEST-COMPILE,1 ; -> }
{ 123 TEST-COMPILE,2 -> 124 }

\ ------------------------------------------------------------------------
TESTING CASE ENDCASE OF ENDOF

{ : GCASE1 CASE 1+ DUP ENDCASE ; -> }
{ 0 GCASE1 -> 1 }
{ : GCASE2 CASE 1 OF 11 ENDOF 2 OF 22 ENDOF 1+ DUP ENDCASE ; -> }
{ 0 GCASE2 -> 1 }
{ 1 GCASE2 -> 11 }
{ 2 GCASE2 -> 22 }
{ 3 GCASE2 -> 4 }

\ ------------------------------------------------------------------------
TESTING ERASE

CREATE BUF 1 C, 2 C, 3 C,
: SEEBUF BUF C@  BUF CHAR+ C@  BUF CHAR+ CHAR+ C@ ;

{ BUF 0 CHARS ERASE -> }
{ SEEBUF -> 1 2 3 }
{ BUF 2 CHARS ERASE -> }
{ SEEBUF -> 0 0 3 }

\ ------------------------------------------------------------------------
TESTING HEX

{ HEX 11 DECIMAL -> 17 }
{ BASE @ HEX BASE @ SWAP BASE ! -> 16 }

\ ------------------------------------------------------------------------
TESTING NIP TUCK PICK ROLL

{ 1 2 NIP -> 2 }
{ 1 2 TUCK -> 2 1 2 }
{ 1 2 3 0 PICK -> 1 2 3 3 }
{ 1 2 3 1 PICK -> 1 2 3 2 }
{ 1 2 3 2 PICK -> 1 2 3 1 }
{ 1 2 3 0 ROLL -> 1 2 3 }
{ 1 2 3 1 ROLL -> 1 3 2 }
{ 1 2 3 2 ROLL -> 2 3 1 }

\ ------------------------------------------------------------------------
TESTING UNUSED
{ CREATE DUMMY UNUSED 0 , UNUSED - -> 1 CELLS }

\ ------------------------------------------------------------------------
TESTING WITHIN

{ -1 1 3 WITHIN -> FALSE }
{ 0 1 3 WITHIN -> FALSE }
{ 1 1 3 WITHIN -> TRUE }
{ 2 1 3 WITHIN -> TRUE }
{ 3 1 3 WITHIN -> FALSE }

{ -4 -3 -1 WITHIN -> FALSE }
{ -3 -3 -1 WITHIN -> TRUE }
{ -2 -3 -1 WITHIN -> TRUE }
{ -1 -3 -1 WITHIN -> FALSE }
{ -0 -3 -1 WITHIN -> FALSE }
{ 1 -3 -1 WITHIN -> FALSE }

{ -2 -1 1 WITHIN -> FALSE }
{ -1 -1 1 WITHIN -> TRUE }
{ 0 -1 1 WITHIN -> TRUE }
{ 1 -1 1 WITHIN -> FALSE }

{ MAX-UINT 4 - MAX-UINT 3 - MAX-UINT 1 - WITHIN -> FALSE }
{ MAX-UINT 3 - MAX-UINT 3 - MAX-UINT 1 - WITHIN -> TRUE }
{ MAX-UINT 2 - MAX-UINT 3 - MAX-UINT 1 - WITHIN -> TRUE }
{ MAX-UINT 1 - MAX-UINT 3 - MAX-UINT 1 - WITHIN -> FALSE }
{ MAX-UINT MAX-UINT 3 - MAX-UINT 1 - WITHIN -> FALSE }

{ MIN-INT MIN-INT 1 + MIN-INT 3 + WITHIN -> FALSE }
{ MIN-INT 1 + MIN-INT 1 + MIN-INT 3 + WITHIN -> TRUE }
{ MIN-INT 2 + MIN-INT 1 + MIN-INT 3 + WITHIN -> TRUE }
{ MIN-INT 3 + MIN-INT 1 + MIN-INT 3 + WITHIN -> FALSE }

{ MID-UINT 1- MID-UINT MID-UINT+1 WITHIN -> FALSE }
{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }
{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }

\ ------------------------------------------------------------------------
TESTING VALUE TO

{ 123 VALUE TEST-VALUE -> }
{ TEST-VALUE -> 123 }
{ 234 TO TEST-VALUE -> }
{ TEST-VALUE -> 234 }
{ : TEST-VALUE2 TO TEST-VALUE ; -> }
{ TEST-VALUE -> 234 }
{ 123 TEST-VALUE2 -> }
{ TEST-VALUE -> 123 }

\ ------------------------------------------------------------------------
TESTING PAD

84 CONSTANT TEST-PAD-SIZE
: CHECK-PAD   ( char -- flag )
	PAD TEST-PAD-SIZE CHARS OVER + >R
	BEGIN
		2DUP C@ <>
		IF R> DROP DROP DROP FALSE EXIT THEN
		CHAR+
		DUP R@ =
	UNTIL
	R> DROP DROP DROP
	TRUE
;
PAD TEST-PAD-SIZE 222 FILL
{ 222 CHECK-PAD -> TRUE }
\ Check 'WORD' doesn't use PAD
BL WORD ABCDEFGHIJKLMNOPQRSTUVWXYZ12345 DROP
{ 222 CHECK-PAD -> TRUE }
\ Check <# #> don't use PAD...
MAX-UINT MAX-UINT 2 BASE ! <# #S # # #> DROP DROP DECIMAL
{ 222 CHECK-PAD -> TRUE }

\ ------------------------------------------------------------------------
TESTING PARSE

: SEE3 >R  R@ C@  R@ CHAR+ C@  R> CHAR+ CHAR+ C@ ;
{ CHAR " PARSE "NIP -> 0 }
{ -> } \ In case previous line erroneously parsed to end of line
{ CHAR " PARSE abc" SWAP SEE3 -> 3 CHAR a CHAR b CHAR c }
{ CHAR " PARSE abc" SWAP SEE3 -> 3 CHAR a CHAR b CHAR c }

\ Next tests don't work if part of the line termination sequence
\ is present in the input buffer
\ CHAR " PARSE ABC
\ { NIP -> 3 }
\ CHAR " PARSE
\ { NIP -> 0 }

\ ------------------------------------------------------------------------
TESTING SOURCE-ID

: TEST-SOURCE-ID S" SOURCE-ID" EVALUATE ;
{ TEST-SOURCE-ID -> -1 }   \ SOURCE-ID when EVALUATEing is -1
{ SOURCE-ID -1 <> -> TRUE }   \ Not EVALUATEing now
{ SOURCE-ID 0 <> -> TRUE }   \ Not interpreting from user input device

\ ------------------------------------------------------------------------
TESTING SAVE-INPUT RESTORE-INPUT REFILL

: TEST-SAVE-INPUT
	DEPTH >R
	SAVE-INPUT
	DEPTH R> - 1-
	OVER =
	IF
		BEGIN
			DUP
		WHILE
			NIP 1-
		REPEAT
		DROP
		TRUE
	ELSE
		FALSE
	THEN
;
{ 123 TEST-SAVE-INPUT -> 123 TRUE }

: TEST-SAVE/RESTORE-INPUT1
	SAVE-INPUT
	BL PARSE NIP
	>R RESTORE-INPUT R>
;
{ TEST-SAVE/RESTORE-INPUT1 123 -> FALSE 3 123 }

: TEST-SAVE/RESTORE-INPUT2
	SAVE-INPUT
	S" 123" EVALUATE
	>R RESTORE-INPUT R>
;
{ TEST-SAVE/RESTORE-INPUT2 234 -> FALSE 123 234 }

: TEST-SAVE/REFILL/RESTORE
	SAVE-INPUT
	REFILL >R          \ Skip '8' and get next line
	SOURCE DROP C@ >R  \ Get '9' char
	RESTORE-INPUT      \ Source back to '8' char
	R> R>
;
\ DISABLED !!!!!!!!!!!!!!!!!!!!!!!!!!!! 
\ TEST-SAVE/REFILL/RESTORE 8
\ 9
\ { -> FALSE CHAR 9 TRUE 8 9 }  ( REFILL-result C@-'9' RESTORE-INPUT-result 8 9 )  

\ ------------------------------------------------------------------------
TESTING MARKER

: TEST-MARK1 123 ;
CREATE TEST-MARK-HERE        \ Remember value of HERE
{ MARKER TEST-MARK2 -> }     \ Create MARKER
0 ,                          \ Advance HERE
: TEST-MARK1 234 ;
{ TEST-MARK1 -> 234 }
{ TEST-MARK2 -> }
{ TEST-MARK1 -> 123 }        \ Check we find the old definition
{ HERE -> TEST-MARK-HERE }   \ Check HERE has been restored

\ ------------------------------------------------------------------------
TESTING [COMPILE]

: TEST-COMP1 123 ;
{ : TEST-COMP2 [COMPILE] TEST-COMP1 ; -> }
{ TEST-COMP2 -> 123 }
: TEST-COMP3 234 ; IMMEDIATE
{ : TEST-COMP2 [COMPILE] TEST-COMP3 ; -> }
{ TEST-COMP3 -> 234 }
{ : TEST-COMP4 [COMPILE] IF ; IMMEDIATE -> }
{ : TEST-COMP5 TEST-COMP4 2 THEN ; -> }
{ 1 TEST-COMP5 -> 2 }