Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: methods.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: @(#)methods.fth 1.10 05/11/03 | |
43 | purpose: | |
44 | copyright: Copyright 2005 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | ||
47 | headerless | |
48 | ||
49 | instance defer (find-drop-in) \ Alternative device specifiers | |
50 | instance defer (fetch-drop-in) \ Forward reference.. | |
51 | ||
52 | " /flashprom:" encode-string | |
53 | " source" property | |
54 | ||
55 | : dropin-alloc ( len -- va ) | |
56 | 0 tuck [ also client-services ] claim [ previous ] | |
57 | ; | |
58 | ||
59 | : dropin-free ( va len -- ) | |
60 | swap [ also client-services ] release [ previous ] | |
61 | ; | |
62 | ||
63 | headers | |
64 | ||
65 | : free-drop-in ( va,len -- ) dropin-free ; | |
66 | ||
67 | headerless | |
68 | ||
69 | : level2? ( name$ -- left$ true | false ) | |
70 | dup 0= if | |
71 | 2drop false \ if namelen = 0, consume the args | |
72 | \ and return false | |
73 | else ( name$ ) | |
74 | 1- \ subtract one from the length | |
75 | \ to point to the last char | |
76 | \ not the first byte beyond it | |
77 | over -1 \ Copy the base address and | |
78 | \ make a flag word to mark a | |
79 | \ failed search | |
80 | ( base len base -1) | |
81 | 2swap bounds swap ?do \ Create the do-loop counters | |
82 | \ from base,len. Note that | |
83 | \ the swap will create a | |
84 | \ backward counter | |
85 | ( base -1 ) | |
86 | i c@ ascii / = if | |
87 | drop i leave \ If "/", drop the "not | |
88 | \ found flag (-1) and get the | |
89 | \ address of where we found | |
90 | \ the slash and leave the loop | |
91 | ( base addr-of-slash ) | |
92 | then ( base -1 ) | |
93 | -1 +loop \ End of loop, decrementing counter | |
94 | ( base -1 | base add-of-slash ) | |
95 | dup -1 = if \ Test to see if the not found | |
96 | \ flag is still on the stack | |
97 | 2drop false \ Yes, slash not found, drop | |
98 | \ the base -1 and return false | |
99 | ( false ) | |
100 | else | |
101 | over - true \ calculate the length of the | |
102 | \ string and return true | |
103 | then ( base len ) | |
104 | then | |
105 | ; | |
106 | ||
107 | : $cat+replace-slashes ( src$ buf -- ) | |
108 | dup c@ ( src$ buf len ) | |
109 | over + >r ( src$ buf ) | |
110 | over over c@ + ( src$ buf len' ) | |
111 | swap c! r> 1+ ( src$ dest ) | |
112 | -rot bounds ?do ( dest ) | |
113 | i c@ dup ascii / = if drop ascii | then | |
114 | over c! 1+ ( dest' ) | |
115 | loop drop ( ) | |
116 | ; | |
117 | ||
118 | \ | |
119 | \ You can't use open-package because that makes this package the | |
120 | \ logical parent of the node you are opening which is incorrect. | |
121 | \ | |
122 | : $open-dev ( arg$ dev$ extra$ -- ihandle ) | |
123 | dup 5 pick + 3 pick + 1+ -rot ( arg$ dev$ n extra$ ) | |
124 | 2>r ( arg$ dev$ ) | |
125 | dup >r alloc-mem ( arg$ dev$ va ) | |
126 | >r 0 r@ c! ( arg$ dev$ ) | |
127 | r@ $cat ( arg$ ) | |
128 | r@ $cat+replace-slashes ( ) | |
129 | r> r> ( va len ) | |
130 | 2r> 3 pick $cat+replace-slashes ( va len ) | |
131 | over count open-dev ( va len ihandle ) | |
132 | -rot free-mem ( ihandle ) | |
133 | ; | |
134 | ||
135 | : execute-drop-in ( ihandle -- ) | |
136 | dup >r ( ihandle ) | |
137 | (fetch-drop-in) if ( va,len ) | |
138 | 2dup execute-buffer ( va,len ) | |
139 | free-drop-in ( ) | |
140 | then ( ) | |
141 | r> close-dev ( ) | |
142 | ; | |
143 | ||
144 | : open-dropin-device ( name$ dev$ -- ihandle ) | |
145 | 2over 2over over 0 $open-dev ( name$ dev$ ihandle|0 ) | |
146 | ?dup if ( name$ dev$ ihandle ) | |
147 | >r 2swap level2? if ( dev$ left$ ) | |
148 | 2swap " /.init" $open-dev ( ihandle ) | |
149 | ?dup if execute-drop-in then ( ihandle ) | |
150 | else ( dev$ ) | |
151 | 2drop ( ) | |
152 | then ( ) | |
153 | r> ( ihandle ) | |
154 | else ( name$ dev$ ) | |
155 | 2drop 2drop false ( 0 ) | |
156 | then ( 0 ) | |
157 | ; | |
158 | ||
159 | : decode-and-open-device ( name$ xdr,len -- name$ xdr,len ihandle ) | |
160 | decode-string ( name$ xdr,len dev$ ) | |
161 | 2swap 2>r ( name$ dev$ ) | |
162 | 2over 2>r ( name$ dev$ ) | |
163 | open-dropin-device ( ihandle ) | |
164 | 2r> rot 2r> rot ( name$ xdr,len ihandle ) | |
165 | ; | |
166 | ||
167 | : search-source-property ( name$ xdr,len -- ihandle ) recursive | |
168 | ?dup if ( name$ str$ ) | |
169 | decode-and-open-device ( name$ xdr,len ihandle ) | |
170 | ?dup if ( name$ xdr,len ihandle ) | |
171 | >r 2drop 2drop r> ( ihandle ) | |
172 | else ( name$ xdr,len ) | |
173 | search-source-property ( ihandle ) | |
174 | then ( ihandle ) | |
175 | else ( name$ ) | |
176 | 3drop false ( false ) | |
177 | then ( ihandle ) | |
178 | ; | |
179 | ||
180 | : locate-dropin-using-property ( name$ -- ihandle ) | |
181 | " source" get-my-property if ( name$ ) | |
182 | 2drop false ( false ) | |
183 | else ( name$ xdr,len ) | |
184 | search-source-property ( flag ) | |
185 | then ( flag ) | |
186 | ; | |
187 | ||
188 | : locate-dropin-using-args ( name$ -- ihandle ) | |
189 | my-args open-dropin-device ( ihandle ) | |
190 | ; | |
191 | ||
192 | \ The format of a compressed dropin: | |
193 | \ Dropin Header | |
194 | \ 4 bytes magic-number = COMP | |
195 | \ 4 bytes size = dropinhdr->size | |
196 | \ 4 bytes comp-type | |
197 | \ 4 bytes decomp-size | |
198 | ||
199 | : dropin-compressed? ( buffer len -- flag ) | |
200 | swap ( len buffer ) | |
201 | dup l@ h# 434f4d50 = ( len data-ptr comp? ) | |
202 | swap 1 la+ l@ ( len comp? size ) | |
203 | rot = and ( flag ) | |
204 | ; | |
205 | ||
206 | : do-decompress ( buf len -- buf len ) | |
207 | over 3 la+ l@ ( buf len dlen ) | |
208 | >r d# 16 - swap d# 16 + swap r> ( buf' len' dlen ) | |
209 | [ also decompressor ] | |
210 | dup dropin-alloc tuck ( buf len dest dlen dest ) | |
211 | /decomp-data dropin-alloc ( buf len dest dlen dest scr ) | |
212 | -rot ( adr len dest scratch dlen dest ) | |
213 | swap 2>r dup >r ( adr len dest scratch ) | |
214 | (decompress) ( -- ) | |
215 | r> /decomp-data dropin-free ( -- ) | |
216 | 2r> ( addr' len' ) | |
217 | [ previous ] | |
218 | ; | |
219 | ||
220 | : decompress-dropin ( buf len -- buf len ) | |
221 | 2dup do-decompress ( data,len buf,len ) | |
222 | 2swap free-drop-in ( buf,len ) | |
223 | ; | |
224 | ||
225 | : fetch-drop-in ( ihandle -- adr,len,true | false ) | |
226 | >r ( ) | |
227 | " size" r@ $call-method ( n ) | |
228 | dup dropin-alloc ?dup if ( n va ) | |
229 | dup rot ( va va n ) | |
230 | " read" r@ $call-method ( va len' ) | |
231 | 2dup dropin-compressed? if ( buf len ) | |
232 | decompress-dropin ( buf len ) | |
233 | then ( buf len ) | |
234 | true ( buf len true ) | |
235 | else ( n ) | |
236 | drop false ( false ) | |
237 | then ( flag ) | |
238 | r> drop ( flag ) | |
239 | ; | |
240 | ' fetch-drop-in to (fetch-drop-in) | |
241 | ||
242 | headers | |
243 | \ | |
244 | \ If open is called without arguments then the property | |
245 | \ " source" is decoded and all devices in the encoded string will | |
246 | \ be searched for a dropin, if an argument is specified then only | |
247 | \ that device will be searched. | |
248 | \ | |
249 | ||
250 | : open ( -- flag ) | |
251 | my-args nip if | |
252 | ['] locate-dropin-using-args | |
253 | else | |
254 | ['] locate-dropin-using-property | |
255 | then | |
256 | ( acf ) to (find-drop-in) | |
257 | true | |
258 | ; | |
259 | ||
260 | : close ( -- ) ; | |
261 | ||
262 | : find-drop-in ( name$ -- buf,len,true | false ) | |
263 | ?dup if ( name$ ) | |
264 | (find-drop-in) ( ihandle ) | |
265 | ?dup if ( ihandle ) | |
266 | dup >r fetch-drop-in ( flag ) | |
267 | r> close-dev ( flag ) | |
268 | exit ( flag ) | |
269 | then ( ) | |
270 | else ( arg ) | |
271 | drop ( ) | |
272 | then ( ) | |
273 | false ( false ) | |
274 | ; | |
275 | ||
276 | headerless | |
277 | : (do-drop-in) ( name$ xdr,len -- ) recursive | |
278 | ?dup if ( name$ str$ ) | |
279 | decode-and-open-device ( name$ xdr,len ihandle ) | |
280 | ?dup if execute-drop-in then ( name$ xdr,len ) | |
281 | (do-drop-in) ( ) | |
282 | else ( name$ xdr ) | |
283 | 3drop ( ) | |
284 | then ( ) | |
285 | ; | |
286 | ||
287 | headers | |
288 | : do-drop-in ( name$ -- ) | |
289 | " source" get-my-property if ( name$ ) | |
290 | 2drop ( ) | |
291 | else ( name$ xdr,len ) | |
292 | (do-drop-in) ( ) | |
293 | then ( ) | |
294 | ; | |
295 | ||
296 | headerless |