Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: detokeni.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: @(#)detokeni.fth 1.4 03/12/11 09:22:47 | |
43 | purpose: | |
44 | copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | ||
47 | \ Decompiles FCode binary code into FCode source text | |
48 | ||
49 | only forth definitions | |
50 | vocabulary detokenizer | |
51 | only forth also detokenizer also definitions | |
52 | ||
53 | warning @ warning off | |
54 | : headers ; : headerless ; | |
55 | ||
56 | needs init-tables ${BP}/pkg/fcode/common.fth | |
57 | \ fload ${BP}/pkg/fcode/common.fth | |
58 | 32 buffer: name-buf | |
59 | \ : $create ( adr len -- ) name-buf pack count $create ; | |
60 | : /string ( adr len cnt -- adr+cnt len-cnt ) tuck 2swap + -rot - ; | |
61 | ||
62 | 0 value paginate? | |
63 | : cr ( -- ) cr paginate? if exit? if bye then then ; | |
64 | also forth definitions | |
65 | : paginate ( -- ) true to paginate? ; | |
66 | ||
67 | \ "Indenting" counterparts of cr and ??cr | |
68 | : icr ( -- ) cr lmargin @ spaces ; | |
69 | : ??icr ( -- ) #out @ lmargin @ > if icr then ; | |
70 | ||
71 | previous definitions | |
72 | ||
73 | : +indent ( -- ) 3 lmargin +! ; | |
74 | : -indent ( -- ) -3 lmargin +! ; | |
75 | ||
76 | : name-leng ( acf -- $len+1 ) | |
77 | >name name>string nip 1+ ( $len+1 ) \ Account for space after... | |
78 | ; | |
79 | : show-name ( acf -- ) dup name-leng ?line .name ; | |
80 | : show-byte ( adr immediate? -- ) if execute ?cr else show-name then ; | |
81 | ||
82 | : byte-load ( adr spread -- ) | |
83 | ['] show-byte is do-byte-compile | |
84 | push-hex | |
85 | byte-interpret \ Interpret byte sequence | |
86 | pop-base | |
87 | cr ." end0 " cr | |
88 | ; | |
89 | ||
90 | ||
91 | \ We will first load obsolete FCodes' token-table-entries with the | |
92 | \ function obsolete-fcode | |
93 | \ | |
94 | \ Afterwards, we will load the same (obsolete) FCode numbers with | |
95 | \ their functions' old names, causing each old (obsolete) name | |
96 | \ to be freshly created as a byte-code word. We will take | |
97 | \ advantage of that: detokenization will show the old name | |
98 | \ together with an indication that the function is obsolete... | |
99 | \ | |
100 | 1 actions | |
101 | action: \ Detokenizer's display of an obsolete-fcode | |
102 | body> dup ??icr .name | |
103 | ." "t\ Warning: " .name ." is an obsolete fcode." icr | |
104 | ; | |
105 | ||
106 | \ Test whether the newly created byte-code word is | |
107 | \ an entry for an obsolete word. | |
108 | \ | |
109 | \ If it is, attach the action to it. | |
110 | \ | |
111 | \ Return an indication as to whether it was: TRUE = it wasn't | |
112 | \ | |
113 | : ?obsolete? ( code# tableaddr acf ftoken-addr -- ..... ) | |
114 | ( .... -- code# tableaddr acf ftoken-addr flag ) | |
115 | dup token@ ['] obsolete-fcode <> ( code# tableaddr acf ftoken-addr flag ) | |
116 | ?dup 0= if | |
117 | use-actions 2over set-immed | |
118 | false | |
119 | then | |
120 | ; | |
121 | ||
122 | \ Test for token definitions that are duplicated, and issue a warning | |
123 | : ?duplicate ( ftoken-addr -- ftoken-addr ) | |
124 | dup token@ | |
125 | ['] ferror <> | |
126 | if | |
127 | ??cr ." ****** DUPLICATE TOKEN " | |
128 | over .name cr | |
129 | then | |
130 | ; | |
131 | ||
132 | \ Control the sequence of special testing of token definitions: | |
133 | \ | |
134 | \ If the token isn't a name that was found, but was newly created, | |
135 | \ then we want to test whether it was already entered in the | |
136 | \ tables as an obsolete FCode. If it was, then we want to | |
137 | \ bypass the test for duplicate token definitions. | |
138 | \ | |
139 | \ We want to test for duplicate token definitions if the token | |
140 | \ is a name that was found, or if its name wasn't found and | |
141 | \ wasn't already entered in the tables as an obsolete FCode. | |
142 | \ | |
143 | : test-tokens ( code# tableaddr acf ftoken-addr new? -- .... ) | |
144 | ( ..... -- code# tableaddr acf ftoken-addr ) | |
145 | if ?obsolete? | |
146 | else true | |
147 | then | |
148 | if ?duplicate then | |
149 | ; | |
150 | ||
151 | : byte-code: \ name ( code# table# -- ) | |
152 | >token-table ( code# tableaddr ) | |
153 | 2dup parse-word $find | |
154 | dup 0= >r ( R: new? ) | |
155 | ?dup if ( c#,t-a code# tableaddr acf immed? ) | |
156 | dup 0> if ( c#,t-a code# tableaddr acf immed? ) | |
157 | 2over set-immed | |
158 | then drop ( c#,t-a code# tableaddr acf ) | |
159 | else ( c#,t-a code# tableaddr $adr,len ) | |
160 | $create lastacf ( c#,t-a code# tableaddr acf ) | |
161 | then ( c#,t-a code# tableaddr acf ) | |
162 | -rot swap ta+ ( c#,t-a acf ftoken-addr ) ( R: new? ) | |
163 | r> test-tokens | |
164 | token! 2drop ( ) | |
165 | ; | |
166 | ||
167 | : .def ( adr len -- ) | |
168 | type space lastacf .name | |
169 | ; | |
170 | ||
171 | variable tok-state tok-state off | |
172 | : b(:) ??cr " :" .def 3 lmargin ! icr tok-state on ; immediate | |
173 | ||
174 | : b(field) " field" .def cr ; immediate | |
175 | : b(create) ??cr " create" .def space ; immediate | |
176 | : b(constant) " constant" .def cr ; immediate | |
177 | : b(variable) ??cr " variable" .def space ; immediate | |
178 | : b(value) " value" .def cr ; immediate | |
179 | : b(defer) ??cr " defer" .def cr ; immediate | |
180 | : b(buffer:) " buffer:" .def cr ; immediate | |
181 | ||
182 | : b(;) 0 lmargin ! ??cr ." ;" cr tok-state off ; immediate | |
183 | ||
184 | : b(lit) get-long ." h# " .x ?cr ; immediate | |
185 | ||
186 | : b(') ( -- ) | |
187 | tok-state @ if ." ['] " else ." ' " then next-fc-token drop .name ?cr | |
188 | ; immediate | |
189 | ||
190 | : b(") | |
191 | ascii " emit space get-bstring type ascii " emit space ?cr | |
192 | ; immediate | |
193 | ||
194 | : b(to) ." to " ; immediate | |
195 | ||
196 | : .offset ( adr len -- ) type ." (" get-offset (.) type ." ) " ?cr ; | |
197 | ||
198 | : bbranch | |
199 | get-offset 0< if | |
200 | -indent icr ." again " | |
201 | else | |
202 | -indent icr ." else " +indent icr | |
203 | next-fc-token 2drop \ eat the b(>resolve) | |
204 | then | |
205 | ; immediate | |
206 | ||
207 | \ : b?branch " ?branch" .offset ; immediate | |
208 | : b?branch | |
209 | get-offset dup 0< if | |
210 | drop | |
211 | -indent icr ." until" icr | |
212 | else ( offset ) | |
213 | interpreter-pointer @ + | |
214 | offset16? @ if 6 else 4 then - ( adr ) | |
215 | \ bbranch followed by a negative offset | |
216 | dup dup c@ h# 13 = swap 1+ c@ h# 80 and 0<> and if ( addr ) | |
217 | -indent icr ." while " | |
218 | h# b3 swap c! \ Store the fake FCode for b(repeat) | |
219 | else ( addr ) | |
220 | drop ." if " | |
221 | then +indent icr | |
222 | then | |
223 | ; immediate | |
224 | ||
225 | : drop-offset ( -- ) get-offset drop ; | |
226 | ||
227 | : b(<mark) ." begin " +indent icr ; immediate | |
228 | : b(>resolve) -indent icr ." then " ; immediate | |
229 | ||
230 | : b(case) ." case " +indent icr ; immediate | |
231 | : b(of) ." of " drop-offset ; immediate | |
232 | : b(endof) ." endof " icr drop-offset ; immediate | |
233 | : b(endcase) -indent icr ." endcase " icr ; immediate | |
234 | ||
235 | : b(repeat) | |
236 | -indent icr ." repeat " drop-offset next-fc-token 2drop | |
237 | ; immediate | |
238 | ||
239 | : b(loop) ." loop " drop-offset ?cr ; immediate | |
240 | : b(+loop) ." +loop " drop-offset ?cr ; immediate | |
241 | : b(do) ." do " drop-offset ?cr ; immediate | |
242 | : b(?do) ." ?do " drop-offset ?cr ; immediate | |
243 | ||
244 | : b(leave) ." leave " ; immediate | |
245 | ||
246 | \ We would like to have the detokenizer's output be such that it can | |
247 | \ be re-cycled through the tokenizer. This would not only be a | |
248 | \ "proof-of-correctness" tool, but also provide a way of testing | |
249 | \ proposed changes to a piece of FCode for which source is not | |
250 | \ available, as, for example, when a plug-in-card is found to | |
251 | \ have a buggy driver. | |
252 | \ | |
253 | \ In order to do this, we distinguish between the way the "fake-name" | |
254 | \ is shown for a headerless token and for one whose name exists. | |
255 | \ | |
256 | \ A headerless token should be shown as "(TT,CC)" (where TT and CC | |
257 | \ are the Table and Code numbers), with no space separating the | |
258 | \ open-paren from the rest of the string. This could then become | |
259 | \ the stand-in for the function's name, and will be displayed | |
260 | \ -- for example -- after the colon. | |
261 | \ | |
262 | \ A headerful token has its "fake-name" shown before the definition | |
263 | \ occurs, with its supplied name appearing before the defining | |
264 | \ line. It should be in the form of a comment, i.e., as "( TT,CC)" | |
265 | \ (note the space after the open-paren), because it really is | |
266 | \ purely an informative item, and it only gets typed out anyway. | |
267 | \ | |
268 | \ Factor out the common elements: | |
269 | \ | |
270 | \ We want to make sure we print out two digits, and not just one for | |
271 | \ byte-codes less than 10. It's safe to print exactly two digits, | |
272 | \ because they're bytes and we're printing in hex. Table-codes, | |
273 | \ though, may be printed as only one digit... | |
274 | : begin-fake-name ( code# table# -- ) | |
275 | swap <# ascii ) hold u# u# drop ascii , hold u#s | |
276 | ; | |
277 | : end-fake-name ( -- $adr,len ) | |
278 | ascii ( hold u#> | |
279 | ; | |
280 | ||
281 | : fake-headerless-name ( code# table# -- $adr,len ) | |
282 | begin-fake-name end-fake-name | |
283 | ; | |
284 | : fake-headered-name ( code# table# -- $adr,len ) | |
285 | begin-fake-name bl hold end-fake-name | |
286 | ; | |
287 | ||
288 | : show-def next-fc-token drop execute ; | |
289 | ||
290 | : set-entry ( acf code# table# -- ) >token-table swap ta+ token! ; | |
291 | ||
292 | \ The other thing we need to do to accomplish that is to print the | |
293 | \ "naming" state. That is to say, whenever a transition | |
294 | \ is made between named, un-named, and external definitions, | |
295 | \ we want to print the appropriate directive. | |
296 | \ We accomplish that with a special variable and some special | |
297 | \ words to handle them... | |
298 | defer detok-naming-state ' noop is detok-naming-state | |
299 | ||
300 | \ Defining-word for a naming-state | |
301 | ||
302 | \ Transition the naming-state; print it out if changed. | |
303 | \ | |
304 | : is-naming-state ( apf -- ) | |
305 | body> ( acf ) | |
306 | ['] detok-naming-state behavior ( acf current-state ) | |
307 | over = if drop | |
308 | else ( acf ) | |
309 | dup is detok-naming-state | |
310 | cr .name cr | |
311 | then | |
312 | ; | |
313 | ||
314 | : detok-name-state: ( -- ) \ name | |
315 | create | |
316 | does> is-naming-state | |
317 | ; | |
318 | ||
319 | \ Now we're ready to define the three magic words. | |
320 | \ | |
321 | \ Better stash 'em out of the way of usual compilation, | |
322 | \ in a vocabulary of their own... | |
323 | \ | |
324 | vocabulary detok-name-states | |
325 | ||
326 | detok-name-states definitions | |
327 | detok-name-state: headerless | |
328 | detok-name-state: headers | |
329 | detok-name-state: external | |
330 | detokenizer definitions | |
331 | ||
332 | : new-token \ then table#, code#, token-type | |
333 | [ also detok-name-states ] headerless [ previous ] | |
334 | get-byte get-byte swap ( code# table# ) | |
335 | 2dup fake-headerless-name $create lastacf ( code# table# acf ) | |
336 | -rot set-entry | |
337 | show-def | |
338 | ; immediate | |
339 | ||
340 | : (named-token) ( -- ) | |
341 | get-bstring $create lastacf ( acf ) | |
342 | get-byte get-byte swap ( acf code# table# ) | |
343 | 2dup cr fake-headered-name type space ( acf code# table# ) | |
344 | set-entry | |
345 | show-def | |
346 | ; | |
347 | ||
348 | : named-token \ then string, table#, code#, token-type | |
349 | [ also detok-name-states ] headers [ previous ] | |
350 | (named-token) | |
351 | ; immediate | |
352 | ||
353 | : external-token \ then string, table#, code#, token-type | |
354 | [ also detok-name-states ] external [ previous ] | |
355 | (named-token) | |
356 | ; immediate | |
357 | ||
358 | previous definitions | |
359 | ||
360 | : .header ( adr len -- ) | |
361 | space icr | |
362 | get-word \ Show the Checksum later | |
363 | get-long dup \ Show Image Size in Hex and Decimal | |
364 | ." \ Image Size h# " .x | |
365 | ." ( d# " .d ." ) bytes." icr | |
366 | ." \ Checksum h# " .x cr icr | |
367 | ; | |
368 | : version1 \ then 0byte,chksum(2bytes),length(4bytes) | |
369 | ." FCode-version1" .header | |
370 | get-byte drop \ Skip the Rev# field | |
371 | ; immediate | |
372 | ||
373 | : .start ( -- ) | |
374 | offset16 ." FCode-version" | |
375 | get-byte 8 >= if ." 3" else ." 2" then \ Rev# field | |
376 | ." ( start" | |
377 | ; | |
378 | ||
379 | : start0 ( -- ) .start ." 0 )" .header ; immediate | |
380 | : start1 ( -- ) .start ." 1 )" .header ; immediate | |
381 | : start2 ( -- ) .start ." 2 )" .header ; immediate | |
382 | : start4 ( -- ) .start ." 4 )" .header ; immediate | |
383 | ||
384 | : offset16 offset16 ." offset16" icr ; immediate | |
385 | ||
386 | : 4-byte-id \ then 3 more bytes | |
387 | ." 4-byte-id " get-byte .x get-byte .x get-byte .x icr | |
388 | ; immediate | |
389 | ||
390 | : property ." property" icr ; immediate | |
391 | ||
392 | alias v1 noop | |
393 | alias v2 noop | |
394 | alias v2.1 noop | |
395 | alias v2.2 noop | |
396 | alias v2.3 noop | |
397 | alias v3 noop | |
398 | ||
399 | \ We need non-immediate definitions of >R R> and R@ | |
400 | \ in the detokenizer vocabulary, so that they will | |
401 | \ print out (instead of executing) during detokenization. | |
402 | \ It would also be nice if they actually work... | |
403 | ||
404 | \ context: detokenizer detokenizer forth re-heads root current: detokenizer | |
405 | forth | |
406 | \ context: forth detokenizer forth re-heads root current: detokenizer | |
407 | ||
408 | : r> 2r> >r ; | |
409 | : >r r> 2>r ; | |
410 | : r@ 2r@ drop ; | |
411 | ||
412 | detokenizer | |
413 | ||
414 | init-tables | |
415 | ||
416 | fload ${BP}/pkg/tokenizr/primlist.fth | |
417 | ||
418 | \ Load the obsolete FCode functions for the DeTokenizer | |
419 | fload ${BP}/pkg/tokenizr/obsfcdtk.fth | |
420 | ||
421 | ||
422 | h# 0b3 0 byte-code: b(repeat) \ Used to be byte-code for V1 set-token | |
423 | ||
424 | h# 10020 buffer: fcode-buf | |
425 | ||
426 | : load-fcode ( -- ) | |
427 | fcode-buf h# 10020 ifd @ fgets drop | |
428 | ifd @ fclose | |
429 | ; | |
430 | ||
431 | \ Initialize simple variables for the detokenizer | |
432 | : init-detok ( -- ) | |
433 | offset16? off | |
434 | ['] noop is detok-naming-state | |
435 | d# 64 rmargin ! | |
436 | ; | |
437 | only forth also detokenizer also forth definitions | |
438 | ||
439 | : detokenize \ name ( -- ) | |
440 | .detokenizer-version | |
441 | reading load-fcode | |
442 | init-detok | |
443 | fcode-buf dup @ h# 01030107 = if h# 20 + then ( adr ) | |
444 | 1 byte-load | |
445 | cr | |
446 | ; | |
447 | ||
448 | warning ! |