afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ Here is an implementation of ALSO/ONLY in terms of the
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ primitive search-order word set.
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas SoomeWORDLIST CONSTANT ROOT ROOT SET-CURRENT
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: DO-VOCABULARY ( -- ) \ Implementation factor
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome DOES> @ >R ( ) ( R: widnew )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome GET-ORDER SWAP DROP ( wid1 ... widn-1 n )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome R> SWAP SET-ORDER
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: DISCARD ( x1 .. xu u - ) \ Implementation factor
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome 0 ?DO DROP LOOP \ DROP u+1 stack items
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas SoomeCREATE FORTH FORTH-WORDLIST , DO-VOCABULARY
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: VOCABULARY ( name -- ) WORDLIST CREATE , DO-VOCABULARY ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ALSO ( -- ) GET-ORDER OVER SWAP 1+ SET-ORDER ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: PREVIOUS ( -- ) GET-ORDER SWAP DROP 1- SET-ORDER ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: DEFINITIONS ( -- ) GET-ORDER OVER SET-CURRENT DISCARD ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ONLY ( -- ) ROOT ROOT 2 SET-ORDER ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ Forth-83 version; just removes ONLY
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: SEAL ( -- ) GET-ORDER 1- SET-ORDER DROP ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ F83 and F-PC version; leaves only CONTEXT
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: SEAL ( -- ) GET-ORDER OVER 1 SET-ORDER DISCARD ;