Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: clientif.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: @(#)clientif.fth 1.18 04/01/28 | |
43 | purpose: | |
44 | copyright: Copyright 1993-2002, 2004 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | ||
47 | headers | |
48 | only forth also definitions | |
49 | ||
50 | \ | |
51 | \ Access to Client Interface Arguments | |
52 | \ | |
53 | ||
54 | defer carg@ ( adr -- n ) | |
55 | defer carg! ( n adr -- ) | |
56 | defer carga+ ( adr n -- adr+n*cells ) | |
57 | defer /carg ( -- #cells ) | |
58 | defer /carg* ( n -- n*cells ) | |
59 | ||
60 | : cif-32 ( -- ) | |
61 | ['] l@ to carg@ | |
62 | ['] l! to carg! | |
63 | ['] la+ to carga+ | |
64 | ['] /l to /carg | |
65 | ['] /l* to /carg* | |
66 | ; | |
67 | ||
68 | 64\ : cif-64 ( -- ) | |
69 | 64\ ['] x@ to carg@ | |
70 | 64\ ['] x! to carg! | |
71 | 64\ ['] xa+ to carga+ | |
72 | 64\ ['] /x to /carg | |
73 | 64\ ['] /x* to /carg* | |
74 | 64\ ; | |
75 | ||
76 | cif-32 | |
77 | ||
78 | headerless | |
79 | ||
80 | 0 value cif-struct | |
81 | : #cargs ( -- n ) cif-struct 1 carga+ carg@ ; | |
82 | : #crets ( -- n ) cif-struct 2 carga+ carg@ ; | |
83 | ||
84 | : service-name ( -- adr,len ) cif-struct carg@ cscount ; | |
85 | : args-adr ( -- arg-n ) cif-struct 3 carga+ ; | |
86 | ||
87 | : is-cif-function? ( adr,len -- false | acf +-1 ) | |
88 | ['] client-services behavior (search-wordlist) | |
89 | ; | |
90 | ||
91 | headers transient | |
92 | \ | |
93 | \ NOTE: | |
94 | \ Don't define client service methods using the old way any longer. | |
95 | \ the old way being: | |
96 | \ also client-services definitions headers caps @ caps on | |
97 | \ : SUNW,failed ( -- failed? ) true ; | |
98 | \ previous definitions headerless caps ! | |
99 | \ | |
100 | \ Now you can define this same routine by simply: | |
101 | \ cif: SUNW,failed ( -- failed? ) true ; | |
102 | \ | |
103 | \ | |
104 | \ this method takes the pain out of flipping the case sensitivity of a CIF | |
105 | \ call and also ensures the method goes into the correct vocabulary. | |
106 | \ | |
107 | \ It works by recording the current headers/headerless and caps state, | |
108 | \ then setting then appropriately, moving to client-services and calling ':' | |
109 | \ to create the word, then we restore the original state again. | |
110 | \ | |
111 | : cif: \ name of headered routine with case sensitive name | |
112 | headerless? dup >r if headers then | |
113 | also client-services definitions | |
114 | caps @ >r caps off : r> caps ! r> if headerless then | |
115 | previous definitions | |
116 | ; | |
117 | resident headerless | |
118 | ||
119 | \ | |
120 | \ Client Interface Handler | |
121 | \ | |
122 | ||
123 | headers | |
124 | forth also definitions | |
125 | ||
126 | defer cif-enter-hook ' noop is cif-enter-hook | |
127 | defer cif-error-hook ' noop is cif-error-hook | |
128 | defer cif-exit-hook ' noop is cif-exit-hook | |
129 | : .cif( ( -- ) | |
130 | ??cr dup .name ." ( " #cargs 0 ?do #cargs i - pick .x loop ." -- " | |
131 | ; | |
132 | : ).cif ( -- ) | |
133 | dup if | |
134 | ." Error " | |
135 | else | |
136 | #crets 0 ?do #crets i - pick .x loop | |
137 | then | |
138 | ." )" cr | |
139 | ; | |
140 | : verbose-cif ( -- ) | |
141 | ['] .cif( to cif-enter-hook | |
142 | ['] ).cif to cif-exit-hook | |
143 | ; | |
144 | : silent-cif ( -- ) | |
145 | ['] noop to cif-enter-hook | |
146 | ['] noop to cif-exit-hook | |
147 | ; | |
148 | ||
149 | : do-cif ( adr -- result ) | |
150 | dup is cif-struct | |
151 | ||
152 | \ Push arguments on the stack | |
153 | #cargs if | |
154 | args-adr #cargs 1- /carg* bounds swap do | |
155 | i carg@ /carg negate | |
156 | +loop | |
157 | then | |
158 | ||
159 | service-name is-cif-function? if ( args.. acf ) | |
160 | cif-enter-hook ( args.. acf ) | |
161 | catch 0<> ( rets.. error? ) | |
162 | cif-exit-hook | |
163 | else ( args.. ) | |
164 | cif-error-hook true ( args.. error ) | |
165 | then ( rets.. error? ) | |
166 | ||
167 | >r | |
168 | \ Pop results from the stack | |
169 | args-adr #cargs carga+ #crets /carg* bounds | |
170 | ?do i carg! /carg +loop | |
171 | r> | |
172 | ; | |
173 | ||
174 | \ Support functions for client interface services | |
175 | headerless | |
176 | ||
177 | : copy-out ( len,buf adr len1 -- len1 ) | |
178 | dup >r ( len,buf adr,len1 ) ( r: len1 ) | |
179 | 2swap swap ( adr len1 buf,len ) ( r: len1 ) | |
180 | rot min cmove ( ) ( r: len1 ) | |
181 | r> | |
182 | ; | |
183 | ||
184 | : setnode ( nodeid | 0 -- ) | |
185 | dup 0= if drop ['] root-node then also execute | |
186 | ; | |
187 | ||
188 | : options? ( -- flag ) 'properties token@ ['] options = ; | |
189 | ||
190 | : null? ( cstr -- flag ) dup if c@ 0= else drop true then ; | |
191 | ||
192 | : str>cstr ( adr len -- cstr ) | |
193 | tuck cstrbuf swap cmove cstrbuf + 0 swap c! cstrbuf | |
194 | ; | |
195 | : &link>cstr ( alf -- acf cstr true | nullstr false ) | |
196 | another-link? if ( acf ) | |
197 | dup >name name>string str>cstr ( acf cstr ) | |
198 | true ( acf cstr true ) | |
199 | else ( ) | |
200 | nullstring false ( cstr false ) | |
201 | then | |
202 | ; | |
203 | false value canonical-properties? | |
204 | d# 32 buffer: canon-prop | |
205 | : $canonical-property ( cstr -- adr len ) | |
206 | cscount | |
207 | canonical-properties? if d# 31 min canon-prop $save 2dup lower then | |
208 | ; | |
209 | : find-property ( cstr -- adr len false | acf true ) | |
210 | $canonical-property | |
211 | 2dup current-properties (search-wordlist) dup if 2swap 2drop then | |
212 | ; | |
213 | : first-property ( -- cstr ) | |
214 | current-properties >threads &link>cstr if nip then | |
215 | ; | |
216 | ||
217 | ||
218 | : next-property ( cstr -- cstr ) | |
219 | find-property if ( acf ) | |
220 | ||
221 | \ Get the next property that has not been superceded by a | |
222 | \ later redefinition of the same name. | |
223 | ||
224 | begin ( acf ) | |
225 | dup >name n>link &link>cstr if ( acf acf' cstr ) | |
226 | rot drop ( acf' cstr ) | |
227 | \ Check to see if this is the most recent | |
228 | \ version of the property with this name. | |
229 | ||
230 | dup find-property if ( acf' cstr acf" ) | |
231 | rot tuck <> ( cstr acf" deleted? ) | |
232 | else ( acf' cstr name$ ) | |
233 | 2drop swap false ( cstr acf' false ) | |
234 | then ( cstr acf" deleted? ) | |
235 | else ( acf nullstr ) | |
236 | \ There are no more firmware-defined configuration variables; | |
237 | \ find the first user-created environment variable | |
238 | 2drop ( ) | |
239 | options? if ( ) | |
240 | null$ next-env-var str>cstr ( cstr ) | |
241 | else ( ) | |
242 | nullstring ( cstr ) | |
243 | then ( cstr ) | |
244 | exit | |
245 | then ( cstr acf" deleted? ) | |
246 | while ( cstr acf" ) | |
247 | ||
248 | \ The property returned by "find-property" has | |
249 | \ a different acf than the one we're looking at, | |
250 | \ even though they have the same name. We conclude | |
251 | \ that the one we're looking at has been superceded, | |
252 | \ and go back to try the next one. | |
253 | ||
254 | nip ( acf" ) | |
255 | repeat ( cstr acf ) | |
256 | drop ( cstr ) | |
257 | else ( name$ ) | |
258 | \ The input string is not a firmware-defined configuration | |
259 | \ variable; perhaps it is a user-created environment variable | |
260 | options? if ( name$ ) | |
261 | next-env-var str>cstr ( cstr ) | |
262 | else ( name$ ) | |
263 | 2drop nullstring ( cstr ) | |
264 | then ( cstr ) | |
265 | then ( nullstr | cstr ) | |
266 | ; | |
267 | ||
268 | \ .cstr defined in fm/lib/util.fth | |
269 | \ : .cstr ( cstr -- ) begin dup c@ ?dup while emit 1+ repeat drop ; | |
270 | ||
271 | \ | |
272 | \ Generic Client Interface Services | |
273 | \ | |
274 | ||
275 | only forth ( also hidden also forth ) also client-services definitions | |
276 | headers | |
277 | cif: ci-properties ( -- ) true to canonical-properties? ; | |
278 | ||
279 | cif: cs-properties ( -- ) false to canonical-properties? ; | |
280 | ||
281 | cif: test ( service-name -- missing? ) cscount is-cif-function? 0= ; | |
282 | ||
283 | cif: test-method ( method-cstr phandle -- missing? ) | |
284 | >r cscount r> find-method if drop false else true then | |
285 | ; | |
286 | ||
287 | cif: child ( phandle -- phandle' ) | |
288 | setnode ( ) | |
289 | 0 'child ( last-nodeid &next-nodeid ) | |
290 | begin get-token? while ( last-nodeid next-nodeid ) | |
291 | nip dup execute ( next-nodeid ) | |
292 | 'peer ( last-nodeid' &next-nodeid ) | |
293 | repeat ( last-nodeid' ) | |
294 | previous ( nodeid ) | |
295 | ; | |
296 | ||
297 | cif: peer ( phandle -- phandle' ) | |
298 | dup 0= if | |
299 | drop ['] root-node exit | |
300 | then ( nodeid ) | |
301 | ||
302 | dup ['] root-node = if | |
303 | drop 0 exit | |
304 | then ( nodeid ) | |
305 | ||
306 | \ Select the first child of our parent | |
307 | dup >parent also execute ( nodeid ) | |
308 | 'child token@ execute ( nodeid ) | |
309 | ||
310 | dup current-device = if ( nodeid ) | |
311 | \ Argument node is first child of parent; return "no more nodes" | |
312 | drop 0 ( 0 ) | |
313 | else ( nodeid ) | |
314 | \ Search for the node preceding the argument node | |
315 | begin ( nodeid ) | |
316 | 'peer token@ 2dup <> ( nodeid next-nodeid flag ) | |
317 | while ( nodeid next-nodeid ) | |
318 | push-device ( nodeid ) | |
319 | repeat ( nodeid ) | |
320 | 2drop current-device ( nodeid' ) | |
321 | then ( nodeid | 0 ) | |
322 | previous ( nodeid | 0 ) | |
323 | ; | |
324 | ||
325 | cif: parent ( phandle -- phandle' ) | |
326 | dup ['] root-node = if ( root-phandle ) | |
327 | drop 0 exit ( 0 ) | |
328 | then ( parent-phandle ) | |
329 | >parent | |
330 | ; | |
331 | ||
332 | \ cif-buf passes client's buffer adr,len to the property 'get' routine | |
333 | \ non-zero len and non-zero adr indicates this is a getprop and the | |
334 | \ contains the adr,len. A non-zero len and zero adr indicates this | |
335 | \ is a getproplen so that the property 'get' routine can optimise. | |
336 | \ This mechanism is relied upon by the 'translations' property. | |
337 | 2variable cif-buf 0 0 cif-buf 2! | |
338 | ||
339 | cif: getproplen ( cstr phandle -- len ) | |
340 | setnode find-property if ( acf ) | |
341 | 0 -1 cif-buf 2! ( acf ) | |
342 | >r r@ get r> decode nip ( len ) | |
343 | 0 0 cif-buf 2! ( len ) | |
344 | else ( name$ ) | |
345 | options? if ( name$ ) | |
346 | get-env-var if -1 else nip then ( len | -1 ) | |
347 | else ( name$ ) | |
348 | 2drop -1 ( -1 ) | |
349 | then ( len | -1 ) | |
350 | then ( len | -1 ) | |
351 | previous ( len | -1 ) | |
352 | ; | |
353 | ||
354 | cif: instance-to-package ( ihandle -- phandle ) ihandle>phandle ; | |
355 | ||
356 | cif: getprop ( len,buf cstr phandle -- size ) | |
357 | setnode find-property if ( len,buf acf ) | |
358 | >r 2dup swap ( len,buf buf,len ) | |
359 | 2dup erase ( len,buf buf,len ) | |
360 | cif-buf 2! ( len,buf ) | |
361 | r@ get r> decode ( len,buf adr,len1 ) | |
362 | copy-out ( len1 ) | |
363 | 0 0 cif-buf 2! ( len1 ) | |
364 | else ( len,buf name$ ) | |
365 | options? if ( len,buf name$ ) | |
366 | get-env-var if ( len,buf ) | |
367 | 2drop -1 ( -1 ) | |
368 | else ( len,buf name$ ) | |
369 | 2over swap erase ( len,buf name$ ) | |
370 | copy-out ( len ) | |
371 | then ( len|-1 ) | |
372 | else ( len,buf name$ ) | |
373 | 2drop 2drop -1 ( -1 ) | |
374 | then ( len|-1 ) | |
375 | then ( len|-1 ) | |
376 | previous ( len|-1 ) | |
377 | ; | |
378 | ||
379 | cif: nextprop ( buf prev phandle -- 0|1 ) | |
380 | setnode ( buf prev-cstr ) | |
381 | dup null? if ( buf prev-cstr ) | |
382 | drop first-property ( buf first-cstr ) | |
383 | else ( buf prev-cstr ) | |
384 | next-property ( buf next-cstr ) | |
385 | then ( buf cstr ) | |
386 | previous ( buf cstr ) | |
387 | ||
388 | over >r ( buf cstr ) ( r: buf ) | |
389 | cscount 1+ ( buf adr,len ) | |
390 | rot swap cmove ( cstr ) | |
391 | r> null? if 0 else 1 then ( 0|1 ) | |
392 | ; | |
393 | ||
394 | cif: setprop ( len buf name phandle -- error|len' ) | |
395 | setnode find-property if ( buf-len buf-adr acf ) | |
396 | >r swap 1- 0 max ( buf-adr buf-len ) | |
397 | r@ encode if ( ) | |
398 | r> drop -1 ( -1 ) | |
399 | else ( encoded-value ) | |
400 | r@ set r@ get r> decode ( adr len ) | |
401 | nip ( len' ) | |
402 | then ( len|-1 ) | |
403 | else ( buf-len,adr name$ ) | |
404 | options? if ( buf-len,adr name$ ) | |
405 | 2swap swap 2swap put-env-var ( len|-1 ) | |
406 | else ( buf-len,adr name$ ) | |
407 | 2drop 2drop -1 ( -1 ) | |
408 | then ( len|-1 ) | |
409 | then ( len|-1 ) | |
410 | previous | |
411 | ; | |
412 | ||
413 | cif: finddevice ( cstr -- phandle ) cscount locate-device ?dup drop ; | |
414 | cif: instance-to-path ( len,buf ihandle -- len' ) | |
415 | >r 2dup swap erase r> | |
416 | ihandle>devname copy-out | |
417 | ; | |
418 | ||
419 | cif: instance-to-interposed-path ( len,buf ihandle -- len' ) | |
420 | >r 2dup swap erase r> | |
421 | ihandle>devpath copy-out | |
422 | ; | |
423 | ||
424 | cif: package-to-path ( len,buf phandle -- len' ) | |
425 | >r 2dup swap erase r> | |
426 | phandle>devname copy-out | |
427 | ; | |
428 | ||
429 | cif: call-method ( arg-P .. ihandle cstr -- res-Q ... res-1 catch-result ) | |
430 | cscount rot ['] $call-method catch | |
431 | ; | |
432 | ||
433 | cif: call-static-method ( arg-P .. phandle cstr -- res-Q ... res-1 result ) | |
434 | cscount rot ['] $call-static-method catch | |
435 | ; | |
436 | ||
437 | cif: open ( cstr -- ihandle ) cscount open-dev ; | |
438 | ||
439 | cif: close ( ihandle -- ) close-dev ; | |
440 | ||
441 | cif: read ( len,addr ihandle -- len' ) | |
442 | >r swap " read" r> ['] $call-method catch if | |
443 | 2drop 3drop -1 | |
444 | then ( -1|#read ) | |
445 | ; | |
446 | ||
447 | cif: write ( len,addr ihandle -- len' ) | |
448 | >r swap " write" r> ['] $call-method catch if | |
449 | 2drop 3drop -1 | |
450 | then ( -1|#written ) | |
451 | ; | |
452 | ||
453 | cif: seek ( low,high ihandle -- status ) | |
454 | " seek" rot ['] $call-method catch if ( d.offset adr len nodeid ) | |
455 | 2drop 3drop -1 | |
456 | then ( -1|0|1) | |
457 | ; | |
458 | ||
459 | \ set-symbol-lookup is defined in os/sun/symdebug.fth | |
460 | ||
461 | cif: milliseconds ( -- ) get-msecs ; | |
462 | ||
463 | cif: execute-buffer ( adr len -- ) 'execute-buffer execute ; | |
464 | ||
465 | also forth definitions | |
466 | alias child child \ Make visible outside the client-services package | |
467 | alias peer peer \ Make visible outside the client-services package | |
468 | ||
469 | only forth also definitions | |
470 | ||
471 | headerless | |
472 | d# 32 buffer: nextprop-cstr | |
473 | headers | |
474 | overload: next-property ( prev$ phandle -- false | next$ true ) | |
475 | current-device >r | |
476 | setnode ( prev$ ) | |
477 | nextprop-cstr dup d# 32 erase ( prev$ cstr ) | |
478 | swap cmove nextprop-cstr dup null? if ( prev-cstr ) | |
479 | drop first-property ( first-cstr ) | |
480 | else ( prev-cstr ) | |
481 | next-property ( next-cstr ) | |
482 | then ( cstr ) | |
483 | previous ( cstr ) | |
484 | dup null? if 2drop false else cscount true then | |
485 | r> push-device | |
486 | ; | |
487 |