1*a1bf3f78SToomas Soome\ Here is an implementation of ALSO/ONLY in terms of the 2*a1bf3f78SToomas Soome\ primitive search-order word set. 3*a1bf3f78SToomas Soome\ 4*a1bf3f78SToomas SoomeWORDLIST CONSTANT ROOT ROOT SET-CURRENT 5*a1bf3f78SToomas Soome 6*a1bf3f78SToomas Soome: DO-VOCABULARY ( -- ) \ Implementation factor 7*a1bf3f78SToomas Soome DOES> @ >R ( ) ( R: widnew ) 8*a1bf3f78SToomas Soome GET-ORDER SWAP DROP ( wid1 ... widn-1 n ) 9*a1bf3f78SToomas Soome R> SWAP SET-ORDER 10*a1bf3f78SToomas Soome; 11*a1bf3f78SToomas Soome 12*a1bf3f78SToomas Soome: DISCARD ( x1 .. xu u - ) \ Implementation factor 13*a1bf3f78SToomas Soome 0 ?DO DROP LOOP \ DROP u+1 stack items 14*a1bf3f78SToomas Soome; 15*a1bf3f78SToomas Soome 16*a1bf3f78SToomas SoomeCREATE FORTH FORTH-WORDLIST , DO-VOCABULARY 17*a1bf3f78SToomas Soome 18*a1bf3f78SToomas Soome: VOCABULARY ( name -- ) WORDLIST CREATE , DO-VOCABULARY ; 19*a1bf3f78SToomas Soome 20*a1bf3f78SToomas Soome: ALSO ( -- ) GET-ORDER OVER SWAP 1+ SET-ORDER ; 21*a1bf3f78SToomas Soome 22*a1bf3f78SToomas Soome: PREVIOUS ( -- ) GET-ORDER SWAP DROP 1- SET-ORDER ; 23*a1bf3f78SToomas Soome 24*a1bf3f78SToomas Soome: DEFINITIONS ( -- ) GET-ORDER OVER SET-CURRENT DISCARD ; 25*a1bf3f78SToomas Soome 26*a1bf3f78SToomas Soome: ONLY ( -- ) ROOT ROOT 2 SET-ORDER ; 27*a1bf3f78SToomas Soome 28*a1bf3f78SToomas Soome\ Forth-83 version; just removes ONLY 29*a1bf3f78SToomas Soome: SEAL ( -- ) GET-ORDER 1- SET-ORDER DROP ; 30*a1bf3f78SToomas Soome 31*a1bf3f78SToomas Soome\ F83 and F-PC version; leaves only CONTEXT 32*a1bf3f78SToomas Soome: SEAL ( -- ) GET-ORDER OVER 1 SET-ORDER DISCARD ; 33