\ Tests for ANS Forth SEARCH-ORDER 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.
\
\
\ Assumptions:
\ * TESTER.FR must be loaded before this file.
\ * Presence of CORE words and DEPTH.
\ * Assumes that the FORTH-WORDLIST is the current compilation wordlist and
\   also the first wordlist in the search order.
\

TESTING SEARCH-ORDER WORDS
DECIMAL

\ Some utility words used for testing

: GCREATE-ORDER   ( "<spaces>name" -- )
	CREATE
	GET-ORDER
	DUP ,
	BEGIN
		DUP
	WHILE
		SWAP , 1-
	REPEAT
	DROP
;

: GNDROP   ( xn ... x1 n -- )
	BEGIN
		DUP
	WHILE
		SWAP DROP 1-
	REPEAT
	DROP
;

: GORDER=   ( widn ... wid1 n a-addr -- )
	OVER 1+ SWAP
	BEGIN
		OVER
	WHILE
		ROT OVER @ =
	WHILE
		CELL+ SWAP 1- SWAP
	REPEAT
		SWAP GNDROP 0
		EXIT
	THEN
	DROP DROP -1
;

: G1ST-WORDLIST   ( -- wid )
	GET-ORDER OVER >R GNDROP R>
;

{ -> }   \ Start with clean slate

\ ------------------------------------------------------------------------
TESTING GET-ORDER SET-ORDER WORDLIST FORTH-WORDLIST

{ 123 GET-ORDER GNDROP -> 123 }
{ GCREATE-ORDER BUF -> }
{ 123 GET-ORDER SET-ORDER -> 123 }
{ GET-ORDER BUF GORDER= -> -1 }

{ G1ST-WORDLIST -> FORTH-WORDLIST }

{ WORDLIST CONSTANT TEST-WORDLIST -> }
{ GET-ORDER TEST-WORDLIST SWAP 1+ SET-ORDER -> }
{ G1ST-WORDLIST -> TEST-WORDLIST }
{ GET-ORDER NIP 1- BUF GORDER= -> -1 }
{ GET-ORDER NIP 1- SET-ORDER -> }
{ GET-ORDER BUF GORDER= -> -1 }

\ ------------------------------------------------------------------------
TESTING GET-CURRENT SET-CURRENT WORDLIST DEFINITIONS

{ GET-CURRENT -> FORTH-WORDLIST }
{ TEST-WORDLIST SET-CURRENT -> }
{ GET-CURRENT -> TEST-WORDLIST }
{ FORTH-WORDLIST SET-CURRENT -> }
{ GET-CURRENT -> FORTH-WORDLIST }

{ GET-ORDER TEST-WORDLIST SWAP 1+ SET-ORDER -> }
{ GET-CURRENT -> FORTH-WORDLIST }
{ DEFINITIONS -> }
{ GET-CURRENT -> TEST-WORDLIST }
{ GET-ORDER NIP 1- SET-ORDER -> }
{ FORTH-WORDLIST SET-CURRENT -> }

\ ------------------------------------------------------------------------
TESTING FIND SEARCH-WORDLIST

: GFIND BL WORD FIND ;
: GSEARCH BL PARSE ROT SEARCH-WORDLIST ;

{ 123 CONSTANT G1 -> }
' G1 CONSTANT 'G1F
{ TEST-WORDLIST SET-CURRENT -> }
{ 234 CONSTANT G1 -> }
{ GET-ORDER TEST-WORDLIST SWAP 1+ SET-ORDER -> }
{ G1 -> 234 }
' G1 FORTH-WORDLIST SET-CURRENT CONSTANT 'G1T

{ GFIND G1 -> 'G1T -1 }
{ TEST-WORDLIST GSEARCH G1 -> 'G1T -1 }
{ FORTH-WORDLIST GSEARCH G1 -> 'G1F -1 }

{ GET-ORDER NIP 1- SET-ORDER -> }
{ G1 -> 123 }
{ GFIND G1 -> 'G1F -1 }
{ TEST-WORDLIST GSEARCH G1 -> 'G1T -1 }
{ FORTH-WORDLIST GSEARCH G1 -> 'G1F -1 }