\ Definitions for ANS Search Order and Search Order Extension words.
\
\ This program is distributed under the terms of the 'MIT license'. The text
\ of this licence follows...
\
\ Copyright (c) 2005 J.D.Medhurst (a.k.a. Tixy)
\
\ Permission is hereby granted, free of charge, to any person obtaining a copy
\ of this software and associated documentation files (the "Software"), to deal
\ in the Software without restriction, including without limitation the rights
\ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
\ copies of the Software, and to permit persons to whom the Software is
\ furnished to do so, subject to the following conditions:
\
\ The above copyright notice and this permission notice shall be included in
\ all copies or substantial portions of the Software.
\
\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
\ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
\ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
\ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
\ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
\ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
\ THE SOFTWARE.


\ ----------------------------------------------------------------------------
\ 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