git.gag.com Git - debian/pforth/blob - fth/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 ;