git.gag.com Git - debian/pforth/blob - forget.fth

   1 \ @(#) forget.fth 98/01/26 1.2
   2 \ forget.fth
   3 \
   4 \ forget part of dictionary
   5 \
   6 \ Author: Phil Burk
   7 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   8 \
   9 \ The pForth software code is dedicated to the public domain,
  10 \ and any third party may reproduce, distribute and modify
  11 \ the pForth software code or any derivative works thereof
  12 \ without any compensation or license.  The pForth software
  13 \ code is provided on an "as is" basis without any warranty
  14 \ of any kind, including, without limitation, the implied
  15 \ warranties of merchantability and fitness for a particular
  16 \ purpose and their equivalents under the laws of any jurisdiction.
  17 \
  18 \ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
  19
  20 variable RFENCE    \ relocatable value below which we won't forget
  21
  22 : FREEZE  ( -- , protect below here )
  23         here rfence a!
  24 ;
  25
  26 : FORGET.NFA  ( nfa -- , set DP etc. )
  27         dup name> >code dp !
  28         prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
  29 ;
  30
  31 : VERIFY.FORGET  ( nfa -- , ask for verification if below fence )
  32         dup name> >code rfence a@ u<  \ 19970701
  33         IF
  34                 >newline dup id. ."  is below fence!!" cr
  35                 drop
  36         ELSE forget.nfa
  37         THEN
  38 ;
  39
  40 : (FORGET)  ( <name> -- )
  41         BL word findnfa
  42         IF      verify.forget
  43         ELSE ." FORGET - couldn't find " count type cr abort
  44         THEN
  45 ;
  46
  47 variable LAST-FORGET   \ contains address of last if.forgotten frame
  48 0 last-forget !
  49
  50 : IF.FORGOTTEN  ( <name> -- , place links in dictionary without header )
  51         bl word find
  52         IF      ( xt )
  53                 here                \ start of frame
  54                 last-forget a@ a,   \ Cell[0] = rel address of previous frame
  55                 last-forget a!      \ point to this frame
  56                 compile,            \ Cell[1] = xt for this frame
  57         ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
  58         THEN
  59 ;
  60 if.forgotten noop
  61
  62 : [FORGET]  ( <name> -- , forget then exec forgotten words )
  63         (forget)
  64         last-forget
  65         BEGIN a@ dup 0<>   \ 19970701
  66                 IF dup here u>   \ 19970701
  67                         IF dup cell+ x@ execute false
  68                         ELSE dup last-forget a! true
  69                         THEN
  70                 ELSE true
  71                 THEN
  72         UNTIL drop
  73 ;
  74
  75 : FORGET ( <name> -- , execute latest [FORGET] )
  76         " [FORGET]" find
  77         IF  execute
  78         ELSE ." FORGET - couldn't find " count type cr abort
  79         THEN
  80 ;
  81
  82 : ANEW ( -- , forget if defined then redefine )
  83         >in @
  84         bl word find
  85         IF over >in ! forget
  86         THEN drop
  87         >in ! variable
  88 ;
  89
  90 : MARKER  ( <name> -- , define a word that forgets itself when executed, ANS )
  91         CREATE
  92                 latest namebase -  \ convert to relocatable
  93                 ,                  \ save for DOES>
  94         DOES>  ( -- body )
  95                 @ namebase +       \ convert back to NFA
  96                 verify.forget
  97 ;