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