Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: voccom.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | \ voccom.fth 3.15 02/05/02 | |
43 | \ Copyright 1985-1990 Bradley Forthware | |
44 | \ Copyright: Copyright 1999-2002 Sun Microsystems, Inc. All Rights Reserved | |
45 | \ Copyright: Use is subject to license terms. | |
46 | ||
47 | \ Common routines for vocabularies, independent of name field | |
48 | \ implementation details | |
49 | ||
50 | headers | |
51 | : wordlist ( -- wid ) (wordlist) lastacf ; | |
52 | : vocabulary ( "name" -- ) header (wordlist) ; | |
53 | ||
54 | defer $find-next | |
55 | ' ($find-next) is $find-next | |
56 | ||
57 | \ : insert-after ( new-node old-node -- ) | |
58 | \ dup link@ ( new-node old-node next-node ) | |
59 | \ 2 pick link! ( new-node old-node ) | |
60 | \ link! | |
61 | \ ; | |
62 | tuser hidden-voc origin-t is hidden-voc | |
63 | ||
64 | : not-hidden ( -- ) hidden-voc !null-token ; | |
65 | ||
66 | \ WARNING: current-voc is patched later by fm/lib/hashcach.fth | |
67 | : hide (s -- ) | |
68 | current-voc hidden-voc token! | |
69 | last @ | |
70 | [ifexist] xref-hide-hook dup name>string xref-hide-hook 2drop [then] | |
71 | n>link current-voc remove-word | |
72 | ; | |
73 | ||
74 | \ WARNING: hidden-voc is patched later by fm/lib/hashcach.fth | |
75 | : reveal (s -- ) | |
76 | hidden-voc get-token? if ( xt ) | |
77 | last @ ( xt ) | |
78 | [ifexist] xref-reveal-hook dup name>string xref-reveal-hook 2drop [then] | |
79 | n>link 0 rot insert-word ( ) | |
80 | not-hidden | |
81 | then | |
82 | ; | |
83 | ||
84 | #threads-t constant #threads | |
85 | ||
86 | auser voc-link \ points to newest vocabulary | |
87 | ||
88 | headerless | |
89 | ||
90 | : voc-link, (s -- ) \ links this vocabulary to the chain | |
91 | lastacf voc-link link@ link, voc-link link! | |
92 | ; | |
93 | ||
94 | hex | |
95 | 0 value fake-name-buf | |
96 | ||
97 | headers | |
98 | : fake-name ( xt -- anf ) | |
99 | base @ >r hex | |
100 | <# 0 hold ascii ) hold u#s ascii ( hold u#> ( adr len ) | |
101 | fake-name-buf $save ( adr len ) | |
102 | tuck + 1- tuck ( anf len adr+len ) | |
103 | swap 1- h# 80 or swap c! ( adr ) | |
104 | r> base ! | |
105 | ; | |
106 | ||
107 | \ Returns the name field address, or if the word is headerless, the | |
108 | \ address of a numeric string representing the xt in parentheses. | |
109 | : >name ( xt -- anf ) | |
110 | dup >name? if nip else drop fake-name then | |
111 | ; | |
112 | ||
113 | : immediate (s -- ) last @ n>flags dup c@ 40 or swap c! ; | |
114 | : immediate? (s xt -- flag ) >flags c@ 40 and 0<> ; | |
115 | : flagalias (s -- ) last @ n>flags dup c@ 20 or swap c! ; | |
116 | : .last (s -- ) last @ .id ; | |
117 | ||
118 | : current-voc ( -- voc-xt ) current token@ ; | |
119 | : context-voc ( -- voc-xt ) context token@ ; | |
120 | ||
121 | 0 value canonical-word | |
122 | headerless | |
123 | ||
124 | : duplicate-notification ( adr len voc -- adr len voc ) | |
125 | where (compile-time-warning) | |
126 | >r 2dup type r> ." isn't unique " cr | |
127 | ; | |
128 | ||
129 | chain: init ( -- ) | |
130 | d# 20 alloc-mem is fake-name-buf | |
131 | d# 32 alloc-mem is canonical-word | |
132 | ; | |
133 | ||
134 | headers | |
135 | : $canonical ( adr len -- adr' len' ) | |
136 | caps @ if d# 31 min canonical-word $save 2dup lower then | |
137 | ; | |
138 | ||
139 | : $create-word ( adr len voc-xt -- ) | |
140 | >r $canonical | |
141 | [ifexist] xref-header-hook | |
142 | xref-header-hook | |
143 | [then] | |
144 | r> warning @ if | |
145 | 3dup $find-word if ( adr len voc-xt xt ) | |
146 | drop duplicate-notification | |
147 | else ( adr len voc-xt adr len ) | |
148 | 2drop | |
149 | then | |
150 | then ( adr len voc-xt ) | |
151 | $make-header | |
152 | ; | |
153 | ||
154 | : ($header) (s adr len -- ) current-voc $create-word ; | |
155 | ||
156 | ' ($header) is $header | |
157 | ||
158 | : (search-wordlist) ( adr len vocabulary -- false | xt +-1 ) | |
159 | $find-word dup 0= if nip nip then | |
160 | ; | |
161 | : search-wordlist ( adr len vocabulary -- false | xt +-1 ) | |
162 | >r $canonical r> (search-wordlist) | |
163 | ; | |
164 | : $vfind ( adr len vocabulary -- adr len false | xt +-1 ) | |
165 | >r $canonical r> $find-word | |
166 | ; | |
167 | ||
168 | : find-fixup ( adr len alf true | adr len false -- xt +-1 | adr len 0 ) | |
169 | dup if ( adr len alf true ) | |
170 | drop nip nip ( alf ) | |
171 | dup link> swap l>name n>flags c@ ( xt flags ) | |
172 | dup h# 20 and if swap token@ swap then ( xt' flags ) \ alias? | |
173 | h# 40 and if 1 else -1 then \ immediate? | |
174 | then | |
175 | ; | |
176 | ||
177 | headerless | |
178 | 2 /n-t * ualloc-t user tbuf | |
179 | headers | |
180 | : follow ( voc-acf -- ) tbuf token! 0 tbuf na1+ ! ; | |
181 | ||
182 | : another? ( -- false | anf true ) | |
183 | tbuf na1+ @ tbuf token@ next-word ( 0 | alf true ) | |
184 | if dup tbuf na1+ ! l>name true else false then | |
185 | ; | |
186 | ||
187 | : another-word? ( alf|0 voc-acf -- alf' voc-acf anf true | false ) | |
188 | tuck next-word if ( voc-acf alf' ) | |
189 | tuck l>name true ( alf' voc-acf anf true ) | |
190 | else ( voc-acf ) | |
191 | drop false ( false ) | |
192 | then | |
193 | ; | |
194 | ||
195 | \ Forget | |
196 | ||
197 | headerless | |
198 | : trim (s alf voc-acf -- ) | |
199 | >r 0 ( adr 0 ) | |
200 | begin r@ next-word while ( adr alf ) | |
201 | 2dup <= if dup r@ remove-word then ( adr alf ) | |
202 | repeat ( adr ) | |
203 | r> 2drop | |
204 | ; | |
205 | ||
206 | headers | |
207 | ||
208 | auser fence \ barrier for forgetting | |
209 | ||
210 | : (forget) (s adr -- ) \ reclaim dictionary space above "adr" | |
211 | ||
212 | dup fence a@ u< ( -15 ) abort" below fence" ( adr ) | |
213 | ||
214 | \ Forget any entire vocabularies defined after "adr" | |
215 | ||
216 | voc-link ( adr first-voc ) | |
217 | begin ( adr voc ) | |
218 | \ XXX this may not work with a mixed RAM/ROM system where | |
219 | \ RAM is at a lower address than ROM | |
220 | link@ 2dup u< ( adr voc' more? ) | |
221 | while ( adr voc ) | |
222 | dup voc> current-voc = ( adr voc error? ) | |
223 | ( -15 ) abort" I can't forget the current vocabulary." | |
224 | \ Remove the voc from the search order | |
225 | dup voc> (except ( adr voc ) | |
226 | >voc-link ( adr voc-link ) | |
227 | repeat ( adr voc ) | |
228 | dup voc-link link! ( adr voc ) | |
229 | ||
230 | \ For all remaining vocabularies, unlink words defined after "adr" | |
231 | ||
232 | \ We assume that we haven't forgotten all the vocabularies; | |
233 | \ otherwise this will fail. Forgetting all the vocabularies would | |
234 | \ crash the system anyway, so we don't worry about it. | |
235 | begin ( adr voc ) | |
236 | 2dup voc> trim ( adr voc ) | |
237 | >voc-link ( adr voc-link-adr ) | |
238 | another-link? 0= ( adr voc' ) | |
239 | until ( adr ) | |
240 | l>beginning here - allot \ Reclaim dictionary space | |
241 | ; | |
242 | ||
243 | : forget (s -- ) | |
244 | safe-parse-word current-voc $vfind $?missing drop | |
245 | >link (forget) | |
246 | ; | |
247 | ||
248 | : marker ( "name" -- ) | |
249 | create #user @ , | |
250 | does> dup @ #user ! body> >link (forget) | |
251 | ; | |
252 | ||
253 | chain: init ( -- ) ['] ($find-next) is $find-next ; |