Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: forward.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 | id: @(#)forward.fth 2.12 03/12/08 13:22:32 | |
43 | purpose: | |
44 | copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | \ Copyright 1985-1990 Bradley Forthware | |
47 | ||
48 | \ Metacompiler forward referencing code, target-independent | |
49 | ||
50 | only forth also meta also forth definitions | |
51 | ||
52 | \ Symbol entries in "symbols" vocabulary: | |
53 | ||
54 | \ The "first-occurrence" field is the head of a linked list | |
55 | \ its value is a pointer to an occurrence of this word in the | |
56 | \ target dictionary. Each node in the list is one 16-bit word. | |
57 | \ The last node contains 0. If there are no occurrences, the | |
58 | \ first-occurrence field contains 0. | |
59 | \ The "resadd" field contains the compilation address of the | |
60 | \ word, or 0 if the word hasn't been defined yet. | |
61 | \ Symbols are "does>" words, but historically hadn't been. | |
62 | ||
63 | \ It is important to keep in mind the distinction between the ACF of the | |
64 | \ named word as it occurs in the symbols vocabulary and as it occurs | |
65 | \ in the target-space. In stack diagrams, the former will be notated | |
66 | \ acf-s and the latter, acf-t . The notation of just-plain acf will | |
67 | \ be used to designate an ACF in the metacompilation host, as in what | |
68 | \ gets "set" in the setaction function. | |
69 | ||
70 | \ The PF of words in the symbols vocabulary consists of four fields: | |
71 | \ | |
72 | : >first-occurrence ( acf-s -- first-occurrence-add ) >body ; | |
73 | : >resolution ( acf-s -- resolution-add ) >first-occurrence /a-t + ; | |
74 | : >action ( acf-s -- action-add ) >resolution /token-t + ; | |
75 | : >info ( acf-s -- info-addr ) >action /token + ; | |
76 | \ | |
77 | \ Note: The order of these fields is closely linked with the sequence | |
78 | \ of "<something>comma" events in the definition of $makesym | |
79 | ||
80 | : first-occurrence@ ( acf-s -- first-occurrence ) >first-occurrence rlink-t@ ; | |
81 | : first-occurrence! ( first-occurrence acf-s -- ) >first-occurrence rlink-t! ; | |
82 | : resolution@ ( acf-s -- resolution ) >resolution token-t@ ; | |
83 | : resolution! ( resolution acf-s -- ) >resolution token-t! ; | |
84 | : action@ ( acf-s -- acf ) >action token@ ; | |
85 | : action! ( acf acf-s -- ) >action token! ; | |
86 | : info@ ( acf-s -- info ) >info c@ ; | |
87 | : info! ( info acf-s -- ) >info c! ; | |
88 | ||
89 | \ Add a new occurrence of word to the linked-list of occurrences. | |
90 | \ The "first-occurrence" field is the head of the list. If the list | |
91 | \ is empty, it contains 0. If the list isn't empty, it contains the | |
92 | \ non-relocated target address of the most-recent | |
93 | \ occurrence of the word. That location, in turn, points to the | |
94 | \ previous occurrence. The last one in the list contains 0. | |
95 | ||
96 | : addlink ( acf-s -- ) | |
97 | here-t | |
98 | over first-occurrence@ ( acf-s occurrence old-first-link ) | |
99 | over rlink!-t ( acf-s occurrence ) \ link old list to occurrence | |
100 | swap first-occurrence! ( ) \ link occurrence to head-of-list-node | |
101 | /token-t allot-t | |
102 | ; | |
103 | ||
104 | variable lastacf-s | |
105 | variable lastanf-s | |
106 | ||
107 | \ Establish the action to be performed by the most recently | |
108 | \ defined symbol when it is the target of "is" | |
109 | : setaction ( acf -- ) lastacf-s @ action! ; | |
110 | ||
111 | \ Perform the established action when the target-word | |
112 | \ is the target of "is" | |
113 | : do-action ( ??? acf-s -- ) | |
114 | action@ execute | |
115 | ; | |
116 | ||
117 | \ The default action of a newly-defined symbol (until it's over-written) | |
118 | : isunknown ( n??? -- ) | |
119 | drop ." Unknown `is' action." cr | |
120 | ; | |
121 | ||
122 | : $makesym ( adr len -- acf-s ) \ makes a new symbol entry | |
123 | ['] symbols $vcreate | |
124 | here body> \ leave acf-s for downstream code | |
125 | 0 a-t, \ initialize first-occurrence | |
126 | 0 token-t, \ initialize resolution | |
127 | ['] isunknown token, \ initialize action | |
128 | 0 c, \ info ( headers/headerless & immediate ) | |
129 | does> | |
130 | \ When a target symbol executes, it compiles itself into the | |
131 | \ target dictionary by adding a reference to itself to the list. | |
132 | body> ( acf ) | |
133 | dup immediate? | |
134 | if | |
135 | .name | |
136 | ." is immediate in the target system but it" cr | |
137 | ." is not defined in the metacompiler." cr abort | |
138 | else | |
139 | addlink | |
140 | then | |
141 | ; | |
142 | : makesym ( str -- acf-s ) count $makesym ; \ makes a new symbol entry | |
143 | ||
144 | : resolved? ( acf-s -- flag ) \ true if already resolved | |
145 | resolution@ origin-t u> | |
146 | ; | |
147 | ||
148 | \ Words to manipulate the symbol table vocabulary at the end of compilation. | |
149 | ||
150 | : .x ( -- ) | |
151 | depth 30 u< if push-hex .s pop-base else ." Underflow" then | |
152 | ; | |
153 | ||
154 | \ Is there another entry in this list of occurrences? | |
155 | : another-occurrence? ( current-occurrence -- [ current-occurrence ] flag ) | |
156 | dup origin-t u> if true else drop false then | |
157 | ; | |
158 | ||
159 | \ resolve is used to replace all the references chained to | |
160 | \ its argument acf-s with the associated referent | |
161 | variable debugflag debugflag off | |
162 | : resolve ( acf-s -- ) \ replace all links with the resolution | |
163 | dup resolution@ >r ( ) ( R: resol'n ) | |
164 | first-occurrence@ ( first-occ ) | |
165 | \ If there are no occurrences, | |
166 | \ the resolution is just put in | |
167 | \ the "first-occurrence" field, | |
168 | \ which doesn't hurt anything | |
169 | begin another-occurrence? while | |
170 | \ first grab link to next occurrence before clobbering it | |
171 | dup rlink@-t ( current-occ next-occ ) ( R: resol'n ) | |
172 | \ put the resolution value in the current-occ. | |
173 | r@ rot token!-t ( next-occurrence ) ( R: resol'n ) | |
174 | repeat | |
175 | r> drop | |
176 | ; | |
177 | ||
178 | \ Print the addresses of all the places where this word is used | |
179 | : where-used ( acf-s -- ) | |
180 | first-occurrence@ ( first-occurrence ) | |
181 | begin another-occurrence? while | |
182 | dup u. token@-t | |
183 | repeat | |
184 | ; | |
185 | ||
186 | \ For each target symbol, prints the name of the word, | |
187 | \ its compilation address, and all the places it's used. | |
188 | \ Basically a cross-reference listing for the word. | |
189 | : show ( acf-s -- ) \ name, resolution, occurrences | |
190 | dup .name dup resolution@ u. where-used | |
191 | ; | |
192 | ||
193 | \ Find the named target symbol | |
194 | : n' \ name ( voc-acf -- acf ) | |
195 | \ CROSS [compile] "" | |
196 | safe-parse-word rot $vfind 0= if type ." not found" abort then | |
197 | ; | |
198 | ||
199 | \ Display all the target symbols | |
200 | : nwords ( voc-cfa -- ) | |
201 | follow begin another? while .id 2 spaces repeat | |
202 | ; | |
203 | ||
204 | : .targ-acf ( acf-t -- ) ." h# " <# u# u# u# u# u# u# u#> type ; | |
205 | ||
206 | \ Display all the symbols, with their offsets and types, along with | |
207 | \ the header: / headerless: indication. | |
208 | : nheads ( -- ) | |
209 | push-hex | |
210 | ['] symbols follow begin another? while ( anf ) | |
211 | dup name> ( anf acf-s ) | |
212 | dup resolution@ ( anf acf-s acf-t ) | |
213 | .targ-acf ( anf acf-s ) | |
214 | info@ dup 3 and ( anf info-type header-type ) | |
215 | over ." ( type " . ." )" | |
216 | case ( anf info-type ) | |
217 | 0 of ." header: " endof | |
218 | 1 of ." header: " endof | |
219 | 2 of ." headerless: " endof | |
220 | 3 of ." header: " endof | |
221 | endcase ( anf info-type ) | |
222 | swap .id ( info-type ) | |
223 | h# 80 and if ." immediate" then ( ) | |
224 | cr | |
225 | repeat | |
226 | pop-base | |
227 | ; | |
228 | ||
229 | \ Display only the headerless: symbols with their offsets. | |
230 | : nheadless ( -- ) | |
231 | push-hex | |
232 | ['] symbols follow begin another? while ( anf ) | |
233 | dup name> ( anf acf-s ) | |
234 | dup info@ ( anf acf-s info-type ) | |
235 | dup 3 and 2 <> if 3drop | |
236 | else -rot ( info-type anf acf-s ) | |
237 | resolution@ ( info-type anf acf-t ) | |
238 | .targ-acf ( info-type anf ) | |
239 | ." headerless: " .id ( info-type ) | |
240 | h# 80 and if ." immediate" then ( ) | |
241 | cr | |
242 | then | |
243 | repeat | |
244 | pop-base | |
245 | ; | |
246 | ||
247 | \ Display a cross-reference list | |
248 | : cref ( voc-cfa -- ) | |
249 | follow begin another? while name> cr show repeat | |
250 | ; | |
251 | ||
252 | \ Display undefined forward references | |
253 | : undef ( voc-cfa -- ) | |
254 | follow begin another? while | |
255 | dup name> resolved? 0= ( lfa f ) | |
256 | if .id space else drop then | |
257 | repeat | |
258 | ; | |
259 | ||
260 | \ Replace all the references with the resolution address | |
261 | : fixall ( voc-cfa -- ) | |
262 | follow begin another? while | |
263 | dup name> dup resolved? ( lfa acf f ) | |
264 | if resolve drop | |
265 | else drop .id ." not defined" cr then | |
266 | repeat | |
267 | ; | |
268 | variable warning-t \ warning for target | |
269 | warning-t off | |
270 | ||
271 | only forth also meta also definitions | |
272 | ||
273 | ||
274 | \ Finds the acf-s of the symbol whose name is str, or makes it if it | |
275 | \ doesn't already exist. | |
276 | : $findsymbol ( str -- acf-s ) $sfind 0= if $makesym then ; | |
277 | ||
278 | \ Defines a new target symbol with name str. | |
279 | \ If a symbol with the same name exists and has already been resolved, | |
280 | \ a new one is created and a warning message is printed. | |
281 | \ If a symbol of the same name exists but is unresolved (a forward reference), | |
282 | \ a new one is not created. | |
283 | ||
284 | : $create-s ( str -- acf-s ) | |
285 | 2dup $findsymbol ( str acf-s ) | |
286 | dup resolved? if ( str acf-s ) | |
287 | drop ( str ) | |
288 | warning-t @ if ( str ) | |
289 | where 2dup type ." isn't unique in target" cr | |
290 | then | |
291 | $makesym ( acf-s ) | |
292 | else nip nip ( acf-s ) | |
293 | then ( acf-s ) | |
294 | dup lastacf-s ! >name lastanf-s ! | |
295 | ; | |
296 | ||
297 | \ Set the precedence bit on the most-recently-resolved symbol. | |
298 | \ We can't do this with immediate-h because the symbol we need to make | |
299 | \ immediate isn't necessarily the last one for which a header was | |
300 | \ created. It could have been a forward reference, with the header | |
301 | \ created long ago. | |
302 | : immediate-s ( -- ) | |
303 | lastanf-s @ n>flags h# 40 toggle \ fix symbol table | |
304 | lastacf-s @ dup info@ h# 80 or swap info! | |
305 | ; | |
306 | ||
307 | \ hide-t temporarily prevents the most-recently-created word from being | |
308 | \ found. It is used when creating a colon definition, so that a colon | |
309 | \ definition may refer to a previous word with the same name as itself, | |
310 | \ without resulting in recursion. | |
311 | \ | |
312 | \ reveal-t is the inverse of hide-t, allowing the most-recently-created | |
313 | \ word to be found again. | |
314 | \ | |
315 | \ In the normal Forth kernel, hide is implemented by unhooking the most | |
316 | \ recent word from the dictionary. That implementation doesn't work in | |
317 | \ the metacompiler, because due to forward referencing, the current colon | |
318 | \ definition is not necessarily the most-recently-created symbol. | |
319 | \ Instead, we use a technique similar to the old FIG-Forth "smudge", where | |
320 | \ the name is altered to make it unrecognizable. "Smudge" was a toggle, | |
321 | \ which suffered from the problem that sometimes "smudge" would inadvertantly | |
322 | \ be executed one too many times, thus leaving the word hidden when it | |
323 | \ should have been visible. To eliminate this, we use separate words | |
324 | \ hide and reveal. | |
325 | ||
326 | : hide-t ( -- ) | |
327 | lastanf-s @ name>string xref-hide-hook | |
328 | drop dup c@ h# 80 or swap c! | |
329 | ; | |
330 | : reveal-t ( -- ) | |
331 | lastanf-s @ name>string ( str,len ) | |
332 | over dup c@ h# 80 invert and swap c! ( str,len ) | |
333 | xref-reveal-hook 2drop ( ) | |
334 | ; | |
335 | : .lastname ( -- ) | |
336 | \ This hack gets around the fact that symbol headers are "smudged" | |
337 | lastanf-s @ ?dup if name>string h# 1f and bounds ?do i c@ h# 7f and emit loop then | |
338 | ; | |
339 | ||
340 | \ compile,-t takes an acf-s and compiles it into | |
341 | \ the current definition in the target-space. | |
342 | : compile,-t ( acf-s -- ) addlink ; | |
343 | ||
344 | \ $compile-t takes a string and compiles a reference to that word in the | |
345 | \ target dictionary. In the case of a forward reference, this may | |
346 | \ involve creating an entry in the symbol vocabulary. Even if the | |
347 | \ word has already been defined, we don't emplace the compilation address | |
348 | \ yet. Instead, we just add this location to a linked list of references | |
349 | \ to the word. For what it's worth, this makes generating a | |
350 | \ cross-reference list easy at the end of the metacompilation. | |
351 | ||
352 | : $compile-t ( adr len -- ) $findsymbol ( acf-s ) addlink ; | |
353 | ||
354 | \ compile-t is used inside a definition. It takes an in-line string | |
355 | \ argument and stores the string somewhere in the definition. When the | |
356 | \ definition executes, that string is $compile-t'd. This allows | |
357 | \ immediate words to compile run-time words, even if the run-time | |
358 | \ word hasn't yet been defined in the target system. | |
359 | ||
360 | \ example : foo compile-t bar ; | |
361 | \ when foo executes, it will then search for the word bar and | |
362 | \ compile a reference to it. The STRING bar is stored within foo | |
363 | ||
364 | : compile-t \ name ( -- ) | |
365 | [compile] [""] compile count compile $compile-t | |
366 | ; immediate |