relicense to 0BSD

[pforth] / fth / forget.fth

\ @(#) forget.fth 98/01/26 1.2
\ forget.fth
\
\ forget part of dictionary
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\
\ Permission to use, copy, modify, and/or distribute this
\ software for any purpose with or without fee is hereby granted.
\
\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
\
\ 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
;