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 | 8 | \ |
1f99f95d S |
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. | |
8e9db35f PB |
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 | ; |