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

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