Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: spectok.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: @(#)spectok.fth 2.21 01/04/06 | |
43 | purpose: FCode compiling words, control structures, defining words | |
44 | copyright: Copyright 1991-2001 Sun Microsystems, Inc. All Rights Reserved | |
45 | ||
46 | \ Byte-code recompiler; Compiling words and defining words | |
47 | ||
48 | defer (fcode-debug?) ' false to (fcode-debug?) | |
49 | ||
50 | headers | |
51 | : b(lit) ( -- n ) get-long l->n state @ if [compile] literal then ; immediate | |
52 | ||
53 | : b(') ( -- acf ) | |
54 | next-fc-token drop state @ if compile (') token, then | |
55 | ; immediate | |
56 | ||
57 | : b(") ( -- adr len ) | |
58 | get-bstring | |
59 | state @ if compile (") ", else "temp pack count then | |
60 | ; immediate | |
61 | ||
62 | : b(to) ( -- ) next-fc-token drop do-is ; immediate | |
63 | ||
64 | headerless | |
65 | : drop-offset ( -- ) get-offset drop ; | |
66 | headers | |
67 | : b(do) ( -- ) drop-offset [compile] do ; immediate | |
68 | : b(?do) ( -- ) drop-offset [compile] ?do ; immediate | |
69 | : b(loop) ( -- ) drop-offset [compile] loop ; immediate | |
70 | : b(+loop) ( -- ) drop-offset [compile] +loop ; immediate | |
71 | ||
72 | alias b(leave) leave | |
73 | alias b(<mark) begin | |
74 | : b(>resolve) ( [ >mark ] -- ) state @ if [compile] then then ; immediate | |
75 | ||
76 | headerless | |
77 | : get-backward-mark ( marks -- marks' backward-mark ) | |
78 | 0 >r \ Put a sentinel value on the return stack | |
79 | ||
80 | \ A forward mark is an address that points to a "0" | |
81 | \ A backward mark is an address that points to something else | |
82 | ||
83 | \ Move forward mark addresses to return stack | |
84 | ||
85 | begin dup branch@ 0= while >r repeat ( <adr ) ( r: 0 >adr0 .. >adrn ) | |
86 | ||
87 | \ Restore forward marks to data stack, | |
88 | \ always floating the backward address to the top of the stack | |
89 | ||
90 | begin r> ?dup while swap repeat ( >markn .. >mark0 <mark ) | |
91 | ; | |
92 | ||
93 | : skip-bytes ( -- ) | |
94 | get-offset offset16? if 2 else 1 then - ( #bytes-to-skip ) | |
95 | 0 ?do get-byte drop loop | |
96 | ; | |
97 | headers | |
98 | : bbranch ( [ <mark ] -- [ >mark ] ) | |
99 | ||
100 | \ New feature | |
101 | state @ 0= if skip-bytes exit then | |
102 | ||
103 | get-offset 0< if | |
104 | ||
105 | \ The tokenizer compiles "while" as "if" (i.e. "b?branch(+)"), | |
106 | \ and "repeat" as "again then" (i.e. "bbranch(-) b(>resolve)"). | |
107 | \ The control flow factoring of "while .. repeat" is "if but again then" | |
108 | \ It's impractical to make a smart "b?branch(+)" to automatically | |
109 | \ execute the "but" in the "while" case, because there is nothing | |
110 | \ on the stack before a real "if" to distinguish it from a "while". | |
111 | \ Therefore, we must make "bbranch(-)" smart, automatically | |
112 | \ distinguishing "again" from "repeat". | |
113 | \ Unfortunately, this is an insufficient basis for ANS Forth | |
114 | \ control flow with multiple "while"s. We need either "but" or | |
115 | \ "b(while)". However, we can fake it out by making "again" smart | |
116 | \ enough to search for a backward mark underneath a bunch of | |
117 | \ forward marks. This is a cheat, but I think that it is ANS Forth | |
118 | \ compliant so long as CS-PICK and CS-ROLL are not available. | |
119 | ||
120 | get-backward-mark | |
121 | ||
122 | [compile] again | |
123 | else | |
124 | \ The tokenizer compiles "else" as "bbranch(+) then". | |
125 | \ The control flow factoring of "else" is "ahead but then". | |
126 | [compile] ahead [compile] but | |
127 | then | |
128 | ; immediate | |
129 | ||
130 | : b?branch ( [ <mark ] -- [ >mark ] ) | |
131 | ||
132 | \ New feature of IEEE 1275 | |
133 | state @ 0= if ( flag ) | |
134 | if get-offset drop else skip-bytes then | |
135 | exit | |
136 | then | |
137 | ||
138 | get-offset 0< if ( ) | |
139 | \ The get-backward-mark is needed in case of the following valid | |
140 | \ ANS Forth construct: BEGIN .. WHILE .. UNTIL .. THEN | |
141 | get-backward-mark [compile] until | |
142 | else | |
143 | [compile] if | |
144 | then | |
145 | ; immediate | |
146 | ||
147 | \ Eaker's case statement | |
148 | alias b(case) case | |
149 | : b(of) ( marks -- marks ) drop-offset [compile] of ; immediate | |
150 | : b(endof) ( marks -- marks+ ) drop-offset [compile] endof ; immediate | |
151 | alias b(endcase) endcase | |
152 | ||
153 | \ I don't think we should support [ ... ] inside colon definitions, | |
154 | \ because they result in stuff in the code stream that must be skipped | |
155 | \ if we are directly interpreting the PROM code. Also, the result of | |
156 | \ interpreting the ... stuff would have to be stuck into the code | |
157 | \ stream, and that's not possible with PROM code. Since we don't | |
158 | \ support vocabularies, the common usage [ also <vocabulary> ] is not | |
159 | \ necessary. | |
160 | ||
161 | headerless | |
162 | : b] ( -- ) state on ; | |
163 | : b[ ( -- ) state off ; immediate | |
164 | ||
165 | : get-code-adr ( -- table-entry-adr ) | |
166 | get-byte get-byte ( table# byte-code ) | |
167 | swap >token-table ( code# table-adr ) | |
168 | swap ta+ | |
169 | ; | |
170 | : set-acf ( table-entry-adr -- ) acf-align lastacf swap token! ; | |
171 | ||
172 | headers | |
173 | : new-token ( -- ) \ Code stream: table# byte-code# | |
174 | get-code-adr ( table-entry-adr ) set-acf | |
175 | ; immediate | |
176 | ||
177 | : named-token ( -- ) \ Code stream: namestring, table#, code# | |
178 | \ get-code-adr must be executed before $header in order | |
179 | \ to avoid splitting the dictionary if get-code-adr has to | |
180 | \ allocate a token table in the dictionary. | |
181 | get-bstring get-code-adr -rot ( table-entry-adr adr len ) | |
182 | (fcode-debug?) if $header else 2drop then | |
183 | set-acf | |
184 | ; immediate | |
185 | ||
186 | : external-token ( -- ) \ Code stream: namestring, table#, code# | |
187 | \ get-code-adr must be executed before "header in order | |
188 | \ to avoid splitting the dictionary if get-code-adr has to | |
189 | \ allocate a token table in the dictionary. | |
190 | get-bstring get-code-adr -rot ( table-entry-adr adr len ) | |
191 | $header | |
192 | set-acf | |
193 | ; immediate | |
194 | ||
195 | : b(:) ( -- ) colon-cf b] ; immediate | |
196 | ||
197 | : b(;) ( -- ) compile unnest [compile] b[ ; immediate | |
198 | ||
199 | : b(value) ( n -- ) (value) ; immediate | |
200 | : b(variable) ( -- ) (variable) ; immediate | |
201 | : b(defer) ( -- ) (defer) ; immediate | |
202 | : b(buffer:) ( size -- ) (buffer:) ; immediate | |
203 | ||
204 | : b(constant) ( n -- ) constant-cf , ; immediate | |
205 | : b(create) ( -- ) create-cf ; immediate | |
206 | : b(field) ( offset size -- offset' ) create-cf over , + does> @ + ; | |
207 | ||
208 | ||
209 | \ The following will not work: | |
210 | \ create jump-table ] here pad up@ [ | |
211 | \ Here's how to do that: | |
212 | \ create jump-table ' here token, ' pad token, ' up@ token, | |
213 | ||
214 | headers |