CR .( search order extensions )
CR ( Copyright Bill Muench All rights reserved. )

( Bill Muench \ OntoLogic )
(             \ Santa Cruz  CA  95065 )

( 971011 change .WID VOCS  add WIDOF )
( 950321 change back to search order stack )
(        !WID .WID VOCS ONLY ALSO )
( 940928 change for linked search order )
( 940912 remove environmental dependency )
( 940711 fixed stack version )

MARKER E4.VOCS
BASE @ !CSP
HEX

( ============================================================ )

: >WID ( wid -- ) CELL+ ;

: .WID ( wid -- )
  SPACE DUP >WID CELL+ @ ?DUP IF .ID DROP EXIT THEN 0 U.R ;

: !WID ( wid -- ) >WID CELL+ LAST @ SWAP ! ;

: VOCS ( -- ) ( list all wordlists )
  CR ." Vocs:" CURRENT CELL+
  BEGIN @ ?DUP WHILE DUP .WID >WID REPEAT ;

: ORDER ( -- ) ( list search order )
  CR ." Search:" GET-ORDER BEGIN ?DUP WHILE SWAP .WID 1 - REPEAT
  CR ." Define:" GET-CURRENT .WID ;

: ONLY ( -- ) -1 SET-ORDER ;
: ALSO ( -- ) GET-ORDER OVER SWAP 1 + SET-ORDER ;
: PREVIOUS ( -- ) GET-ORDER SWAP DROP 1 - SET-ORDER ;

: >VOC ( wid 'name' -- )
  CREATE DUP , !WID
  DOES> @ >R GET-ORDER SWAP DROP R> SWAP SET-ORDER ;

: WIDOF ( "vocabulary" -- wid ) ' >BODY @ ;

: VOCABULARY ( 'name' -- ) WORDLIST >VOC ;

FORTH-WORDLIST >VOC FORTH

( ============================================================ )
( tests )
( ============================================================ )

WORDLIST CONSTANT W1  W1 !WID ( named )
WORDLIST CONSTANT W2
WORDLIST CONSTANT W3  W3 !WID ( named )

VOCABULARY V4
VOCABULARY V5
VOCABULARY V6

: LL ( -- ) FORTH-WORDLIST W1 W2 W3 W1 5 SET-ORDER ;

W1 SET-CURRENT
: _W1 ;

W2 SET-CURRENT
: _W2 ;

W3 SET-CURRENT
: _W3 ;

WIDOF V4 SET-CURRENT
: _V4 ;

WIDOF V5 SET-CURRENT
: _V5 ;

WIDOF V6 SET-CURRENT
: _V6 ;

WIDOF FORTH SET-CURRENT

( ============================================================ )

?CSP BASE !

FROM CON