| 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 |