1
20 value ciface-ph
3
4dev /openprom/
5new-device
6" client-services" device-name
7
8active-package to ciface-ph
9
10\ -------------------------------------------------------------
11\ private stuff
12\ -------------------------------------------------------------
13
14private
15
16variable callback-function
17
18: ?phandle ( phandle -- phandle )
19  dup 0= if ." NULL phandle" -1 throw then
20;
21: ?ihandle ( ihandle -- ihandle )
22  dup 0= if ." NULL ihandle" -2 throw then
23;
24
25\ copy and null terminate return string
26: ci-strcpy ( buf buflen str len -- len )
27  >r -rot dup
28  ( str buf buflen buflen R: len )
29  r@ min swap
30  ( str buf n buflen R: len )
31  over > if
32    ( str buf n )
33    2dup + 0 swap c!
34  then
35  move r>
36;
37
380 value memory-ih
390 value mmu-ih
40
41:noname ( -- )
42  " /chosen" find-device
43
44  " mmu" active-package get-package-property 0= if
45    decode-int nip nip to mmu-ih
46  then
47
48  " memory" active-package get-package-property 0= if
49    decode-int nip nip to memory-ih
50  then
51  device-end
52; SYSTEM-initializer
53
54: safetype
55  ." <" dup cstrlen dup 20 < if type else 2drop ." BAD" then ." >"
56;
57
58: phandle-exists?  ( phandle -- found? )
59  false swap 0
60  begin iterate-tree ?dup while
61    ( found? find-ph current-ph )
62    over over = if
63      rot drop true -rot
64    then
65  repeat
66  drop
67;
68
69\ -------------------------------------------------------------
70\ public interface
71\ -------------------------------------------------------------
72
73external
74
75\ -------------------------------------------------------------
76\ 6.3.2.1 Client interface
77\ -------------------------------------------------------------
78
79\ returns -1 if missing
80: test ( name -- 0|-1 )
81  dup cstrlen ciface-ph find-method
82  if drop 0 else -1 then
83;
84
85\ -------------------------------------------------------------
86\ 6.3.2.2 Device tree
87\ -------------------------------------------------------------
88
89: peer peer ;
90: child child ;
91: parent parent ;
92
93: getproplen ( name phandle -- len|-1 )
94  over cstrlen swap
95  ?phandle get-package-property
96  if -1 else nip then
97;
98
99: getprop ( buflen buf name phandle -- size|-1 )
100  \ detect phandle == -1
101  dup -1 = if
102    2drop 2drop -1 exit
103  then
104
105  \ return -1 if phandle is 0 (MacOS actually does this)
106  ?dup 0= if drop 2drop -1 exit then
107
108  over cstrlen swap
109  ?phandle get-package-property if 2drop -1 exit then
110  ( buflen buf prop proplen )
111  >r swap rot r>
112  ( prop buf buflen proplen )
113  dup >r min move r>
114;
115
116\ 1 OK, 0 no more prop, -1 prev invalid
117: nextprop ( buf prev phandle -- 1|0|-1 )
118  >r
119  dup 0= if 0 else dup cstrlen then
120
121  ( buf prev prev_len )
122
123  \ verify that prev exists (overkill...)
124  dup if
125    2dup r@ get-package-property if
126      r> 2drop drop
127      0 swap c!
128      -1 exit
129    else
130      2drop
131    then
132  then
133
134  ( buf prev prev_len )
135
136  r> next-property if
137    ( buf name name_len )
138    dup 1+ -rot ci-strcpy drop 1
139  else
140    ( buf )
141    0 swap c!
142    0
143  then
144;
145
146: setprop ( len buf name phandle -- size )
147  3 pick >r
148  >r >r swap encode-bytes  \ ( prop-addr prop-len  R: phandle name )
149  r> dup cstrlen r>
150  (property)
151  r>
152;
153
154: finddevice ( dev_spec -- phandle|-1 )
155  dup cstrlen
156  \ ." FIND-DEVICE " 2dup type
157  find-dev 0= if -1 then
158  \ ." -- " dup . cr
159;
160
161: instance-to-package ( ihandle -- phandle )
162  ?ihandle instance-to-package
163;
164
165: package-to-path ( buflen buf phandle -- length )
166  \ XXX improve error checking
167  dup 0= if 3drop -1 exit then
168  >r swap r>
169  get-package-path
170  ( buf buflen str len )
171  ci-strcpy
172;
173
174: canon ( buflen buf dev_specifier -- len )
175  dup cstrlen find-dev if
176    ( buflen buf phandle )
177    package-to-path
178  else
179    2drop -1
180  then
181;
182
183: instance-to-path ( buflen buf ihandle -- length )
184  \ XXX improve error checking
185  dup 0= if 3drop -1 exit then
186  >r swap r>
187  get-instance-path
188  \ ." INSTANCE: " 2dup type cr dup .
189  ( buf buflen str len )
190  ci-strcpy
191;
192
193: instance-to-interposed-path ( buflen buf ihandle -- length )
194  \ XXX improve error checking
195  dup 0= if 3drop -1 exit then
196  >r swap r>
197  get-instance-interposed-path
198  ( buf buflen str len )
199  ci-strcpy
200;
201
202: call-method ( ihandle method -- xxxx catch-result )
203  dup 0= if ." call of null method" -1 exit then
204  dup >r
205  dup cstrlen
206  \ ." call-method " 2dup type cr
207  rot ?ihandle ['] $call-method catch dup if
208    \ not necessary an error but very useful for debugging...
209    ." call-method " r@ dup cstrlen type ." : exception " dup . cr
210  then
211  r> drop
212;
213
214
215\ -------------------------------------------------------------
216\ 6.3.2.3 Device I/O
217\ -------------------------------------------------------------
218
219: open ( dev_spec -- ihandle|0 )
220  dup cstrlen open-dev
221;
222
223: close ( ihandle -- )
224  close-dev
225;
226
227: read ( len addr ihandle -- actual )
228  >r swap r>
229  dup ihandle>phandle " read" rot find-method
230  if swap call-package else 3drop -1 then
231;
232
233: write ( len addr ihandle -- actual )
234  >r swap r>
235  dup ihandle>phandle " write" rot find-method
236  if swap call-package else 3drop -1 then
237;
238
239: seek ( pos_lo pos_hi ihandle -- status )
240  dup ihandle>phandle " seek" rot find-method
241  if swap call-package else 3drop -1 then
242;
243
244
245\ -------------------------------------------------------------
246\ 6.3.2.4 Memory
247\ -------------------------------------------------------------
248
249: claim ( align size virt -- baseaddr|-1 )
250  -rot swap
251  ciface-ph " cif-claim" rot find-method
252  if execute else 3drop -1 then
253;
254
255: release ( size virt -- )
256  swap
257  ciface-ph " cif-release" rot find-method
258  if execute else 2drop -1 then
259;
260
261\ -------------------------------------------------------------
262\ 6.3.2.5 Control transfer
263\ -------------------------------------------------------------
264
265: boot ( bootspec -- )
266  ." BOOT"
267;
268
269: enter ( -- )
270  ." ENTER"
271;
272
273\ exit ( -- ) is defined later (clashes with builtin exit)
274
275: chain ( virt size entry args len -- )
276  ." CHAIN"
277;
278
279\ -------------------------------------------------------------
280\ 6.3.2.6 User interface
281\ -------------------------------------------------------------
282
283: interpret ( xxx cmdstring -- ??? catch-reult )
284  dup cstrlen
285  \ ." INTERPRETE: --- " 2dup type
286  ['] evaluate catch dup if
287    \ this is not necessary an error...
288    ." interpret: exception " dup . ." caught" cr
289
290    \ Force back to interpret state on error, otherwise the next call to
291    \ interpret gets confused if the error occurred in compile mode
292    0 state !
293  then
294  \ ." --- " cr
295;
296
297: set-callback ( newfunc -- oldfunc )
298  callback-function @
299  swap
300  callback-function !
301;
302
303\ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ;
304
305
306\ -------------------------------------------------------------
307\ 6.3.2.7 Time
308\ -------------------------------------------------------------
309
310: milliseconds ( -- ms )
311  get-msecs
312;
313
314\ -------------------------------------------------------------
315\ arch?
316\ -------------------------------------------------------------
317
318: start-cpu ( xxx xxx xxx --- )
319  ." Start CPU unimplemented" cr
320  3drop
321;
322
323\ -------------------------------------------------------------
324\ special
325\ -------------------------------------------------------------
326
327: exit ( -- )
328  ." EXIT"
329
330  \ Execute (exit) hook if one exists
331  s" (exit)" $find if
332    execute
333  else
334    2drop
335  then
336
337  outer-interpreter
338;
339
340: test-method    ( cstring-method phandle -- missing? )
341  swap dup cstrlen rot
342
343  \ Check for incorrect phandle
344  dup phandle-exists? false = if
345    -1 throw
346  then
347
348  find-method 0= if -1 else drop 0 then
349;
350
351[IFDEF] CONFIG_SPARC64
352
353: SUNW,power-off ( -- )
354  power-off
355;
356
357[THEN]
358
359finish-device
360device-end
361
362
363\ -------------------------------------------------------------
364\ entry point
365\ -------------------------------------------------------------
366
367: client-iface ( [args] name len -- [args] -1 | [rets] 0 )
368  ciface-ph find-method 0= if -1 exit then
369  catch ?dup if
370    cr ." Unexpected client interface exception: " . -2 cr exit
371  then
372  0
373;
374
375: client-call-iface ( [args] name len -- [args] -1 | [rets] 0 )
376  ciface-ph find-method 0= if -1 exit then
377  execute
378  0
379;
380