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