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, David Rosenboom
   8 \
   9 \ Permission to use, copy, modify, and/or distribute this
  10 \ software for any purpose with or without fee is hereby granted.
  11 \
  12 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  13 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  14 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  15 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  16 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  17 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  18 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  19 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  20 \
  21 \ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
  22
  23 variable RFENCE    \ relocatable value below which we won't forget
  24
  25 : FREEZE  ( -- , protect below here )
  26     here rfence a!
  27 ;
  28
  29 : FORGET.NFA  ( nfa -- , set DP etc. )
  30     dup name> >code dp !
  31     prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
  32 ;
  33
  34 : VERIFY.FORGET  ( nfa -- , ask for verification if below fence )
  35     dup name> >code rfence a@ u<  \ 19970701
  36     IF
  37         >newline dup id. ."  is below fence!!" cr
  38         drop
  39     ELSE forget.nfa
  40     THEN
  41 ;
  42
  43 : (FORGET)  ( <name> -- )
  44     BL word findnfa
  45     IF  verify.forget
  46     ELSE ." FORGET - couldn't find " count type cr abort
  47     THEN
  48 ;
  49
  50 variable LAST-FORGET   \ contains address of last if.forgotten frame
  51 0 last-forget !
  52
  53 : IF.FORGOTTEN  ( <name> -- , place links in dictionary without header )
  54     bl word find
  55     IF  ( xt )
  56         here                \ start of frame
  57         last-forget a@ a,   \ Cell[0] = rel address of previous frame
  58         last-forget a!      \ point to this frame
  59         compile,            \ Cell[1] = xt for this frame
  60     ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
  61     THEN
  62 ;
  63 if.forgotten noop
  64
  65 : [FORGET]  ( <name> -- , forget then exec forgotten words )
  66     (forget)
  67     last-forget
  68     BEGIN a@ dup 0<>   \ 19970701
  69         IF dup here u>   \ 19970701
  70             IF dup cell+ x@ execute false
  71             ELSE dup last-forget a! true
  72             THEN
  73         ELSE true
  74         THEN
  75     UNTIL drop
  76 ;
  77
  78 : FORGET ( <name> -- , execute latest [FORGET] )
  79     " [FORGET]" find
  80     IF  execute
  81     ELSE ." FORGET - couldn't find " count type cr abort
  82     THEN
  83 ;
  84
  85 : ANEW ( -- , forget if defined then redefine )
  86     >in @
  87     bl word find
  88     IF over >in ! forget
  89     THEN drop
  90     >in ! variable
  91 ;
  92
  93 : MARKER  ( <name> -- , define a word that forgets itself when executed, ANS )
  94     CREATE
  95         latest namebase -  \ convert to relocatable
  96         ,                  \ save for DOES>
  97     DOES>  ( -- body )
  98         @ namebase +       \ convert back to NFA
  99         verify.forget
 100 ;