search.f

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

\ Definitions for ANS Search Order and Search Order Extension words.
\
\ This code has been placed in the Public Domain by J.D.Medhurst (aka Tixy)

\ ----------------------------------------------------------------------------
\ Word name words

: LFA>NFA   ( lfa -- nfa )
	CELL+ ;

: NAME   ( nfa -- c-addr u )
	COUNT 31 AND ;

: NAME.   ( lfa -- )
	LFA>NFA NAME TYPE SPACE ;

\ ----------------------------------------------------------------------------
\ Search order manipulation

: GET-CURRENT   ( -- wid )
	CURRENT @ ;

: SET-CURRENT   ( wid -- )
	CURRENT ! ;

: GET-ORDER   ( -- widn ... wid1 n )
	0 CONTEXT @ ?DO CONTEXT I CELLS + @ -1 +LOOP ;

: SET-ORDER   ( widn ... wid1 n -- )
	DUP 0< IF DROP FORTH-WORDLIST 1 THEN
	DUP 1+ 0 DO CONTEXT I CELLS + ! LOOP ;

: ALSO   ( -- )
	GET-ORDER >R DUP R> 1+ SET-ORDER ;

: ONLY   ( -- )
	-1 SET-ORDER ;

: PREVIOUS   ( -- )
	GET-ORDER NIP 1- SET-ORDER ;

: DEFINITIONS   ( -- )
	CONTEXT CELL+ @ SET-CURRENT ;

\ ----------------------------------------------------------------------------
\ Wordlist creation

CREATE WORDLIST-END 0 ,

: WORDLIST   ( -- wid )
	ALIGN HERE WORDLIST-END , WORDLISTS @ , 0 , DUP WORDLISTS ! ;

: WID>LFA-PTR   ( wid -- nfa )
	CELL+ CELL+ ;

: NAME-WORDLIST   ( wid -- )
	LATEST @ SWAP WID>LFA-PTR ! ;

: (vocabulary)   ( wid -- )
	CONTEXT CELL+ ! ;

\ ----------------------------------------------------------------------------
\ ORDER Implementation

: .H   ( x -- )
	BASE @ SWAP HEX . BASE ! ;

: WID.   ( wid -- )
	DUP WID>LFA-PTR @ ?DUP IF NAME. DROP EXIT THEN .H ;

: ORDER   ( -- )
	GET-CURRENT WID. SPACE
	GET-ORDER BEGIN ?DUP WHILE 1- SWAP WID. REPEAT ;

\ ----------------------------------------------------------------------------
\ WORDS implementation

: WORDLIST-WORDS   ( wid -- )
	DUP WID. ." words..." CR
	@ BEGIN DUP @ WHILE DUP NAME. DUP @ + REPEAT
	DROP CR
;

: WORDS   ( -- )
	CONTEXT @ IF CONTEXT CELL+ @ WORDLIST-WORDS THEN ;

\ ----------------------------------------------------------------------------
\ Definitions for FORTH and ENVIRONMENT vocabularies

: VOCABULARY   ( "<spaces>name" -- )
	CREATE WORDLIST NAME-WORDLIST DOES> (vocabulary) ;

: FORTH   ( -- )
	FORTH-WORDLIST (vocabulary) ;

FORTH-WORDLIST NAME-WORDLIST

FORTH-WORDLIST CELL+ @
CONSTANT ENVIRONMENT-WORDLIST

: ENVIRONMENT   ( -- )
	ENVIRONMENT-WORDLIST (vocabulary) ;

ENVIRONMENT-WORDLIST NAME-WORDLIST