/prods/Cognitive/p4th/forget.fth
https://github.com/createuniverses/praxis · Forth · 97 lines · 86 code · 11 blank · 0 comment · 4 complexity · 94bbaa764f0947146f5373f21b744bb6 MD5 · raw file
- \ @(#) forget.fth 98/01/26 1.2
- \ forget.fth
- \
- \ forget part of dictionary
- \
- \ Author: Phil Burk
- \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
- \
- \ The pForth software code is dedicated to the public domain,
- \ and any third party may reproduce, distribute and modify
- \ the pForth software code or any derivative works thereof
- \ without any compensation or license. The pForth software
- \ code is provided on an "as is" basis without any warranty
- \ of any kind, including, without limitation, the implied
- \ warranties of merchantability and fitness for a particular
- \ purpose and their equivalents under the laws of any jurisdiction.
- \
- \ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
- variable RFENCE \ relocatable value below which we won't forget
- : FREEZE ( -- , protect below here )
- here rfence a!
- ;
- : FORGET.NFA ( nfa -- , set DP etc. )
- dup name> >code dp !
- prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
- ;
- : VERIFY.FORGET ( nfa -- , ask for verification if below fence )
- dup name> >code rfence a@ u< \ 19970701
- IF
- >newline dup id. ." is below fence!!" cr
- drop
- ELSE forget.nfa
- THEN
- ;
- : (FORGET) ( <name> -- )
- BL word findnfa
- IF verify.forget
- ELSE ." FORGET - couldn't find " count type cr abort
- THEN
- ;
- variable LAST-FORGET \ contains address of last if.forgotten frame
- 0 last-forget !
- : IF.FORGOTTEN ( <name> -- , place links in dictionary without header )
- bl word find
- IF ( xt )
- here \ start of frame
- last-forget a@ a, \ Cell[0] = rel address of previous frame
- last-forget a! \ point to this frame
- compile, \ Cell[1] = xt for this frame
- ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
- THEN
- ;
- if.forgotten noop
- : [FORGET] ( <name> -- , forget then exec forgotten words )
- (forget)
- last-forget
- BEGIN a@ dup 0<> \ 19970701
- IF dup here u> \ 19970701
- IF dup cell+ x@ execute false
- ELSE dup last-forget a! true
- THEN
- ELSE true
- THEN
- UNTIL drop
- ;
- : FORGET ( <name> -- , execute latest [FORGET] )
- " [FORGET]" find
- IF execute
- ELSE ." FORGET - couldn't find " count type cr abort
- THEN
- ;
- : ANEW ( -- , forget if defined then redefine )
- >in @
- bl word find
- IF over >in ! forget
- THEN drop
- >in ! variable
- ;
- : MARKER ( <name> -- , define a word that forgets itself when executed, ANS )
- CREATE
- latest namebase - \ convert to relocatable
- , \ save for DOES>
- DOES> ( -- body )
- @ namebase + \ convert back to NFA
- verify.forget
- ;