Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) forget.fth 98/01/26 1.2 |
2 | \ forget.fth | |
3 | \ | |
4 | \ forget part of dictionary | |
5 | \ | |
6 | \ Author: Phil Burk | |
1a088514 | 7 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom |
8e9db35f PB |
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 | ; |