![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ciface.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / system|
Return to ciface.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / system |
1.1 root 1:
2: 0 value ciface-ph
3:
4: dev /openprom/
5: new-device
6: " client-services" device-name
7:
8: active-package to ciface-ph
9:
10: \ -------------------------------------------------------------
11: \ private stuff
12: \ -------------------------------------------------------------
13:
14: private
15:
16: variable 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:
38: 0 value memory-ih
39: 0 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: \ -------------------------------------------------------------
59: \ public interface
60: \ -------------------------------------------------------------
61:
62: external
63:
64: \ -------------------------------------------------------------
65: \ 6.3.2.1 Client interface
66: \ -------------------------------------------------------------
67:
68: \ returns -1 if missing
69: : test ( name -- 0|-1 )
70: dup cstrlen ciface-ph find-method
71: if drop 0 else -1 then
72: ;
73:
74: \ -------------------------------------------------------------
75: \ 6.3.2.2 Device tree
76: \ -------------------------------------------------------------
77:
78: : peer peer ;
79: : child child ;
80: : parent parent ;
81:
82: : getproplen ( name phandle -- len|-1 )
83: over cstrlen swap
84: ?phandle get-package-property
85: if -1 else nip then
86: ;
87:
88: : getprop ( buflen buf name phandle -- size|-1 )
89: \ detect phandle == -1
90: dup -1 = if
91: 2drop 2drop -1 exit
92: then
93:
94: \ return -1 if phandle is 0 (MacOS actually does this)
95: ?dup 0= if drop 2drop -1 exit then
96:
97: over cstrlen swap
98: ?phandle get-package-property if 2drop -1 exit then
99: ( buflen buf prop proplen )
100: >r swap rot r>
101: ( prop buf buflen proplen )
102: dup >r min move r>
103: ;
104:
105: \ 1 OK, 0 no more prop, -1 prev invalid
106: : nextprop ( buf prev phandle -- 1|0|-1 )
107: >r
108: dup 0= if 0 else dup cstrlen then
109:
110: ( buf prev prev_len )
111: 0 3 pick c!
112:
113: \ verify that prev exists (overkill...)
114: dup if
115: 2dup r@ get-package-property if
116: r> 2drop 2drop -1 exit
117: else
118: 2drop
119: then
120: then
121:
122: ( buf prev prev_len )
123:
124: r> next-property if
125: ( buf name name_len )
126: dup 1+ -rot ci-strcpy drop 1
127: else
128: ( buf )
129: drop 0
130: then
131: ;
132:
133: : setprop ( len buf name phandle -- size )
134: 3 pick >r
135: >r >r swap encode-bytes \ ( prop-addr prop-len R: phandle name )
136: r> dup cstrlen r>
137: (property)
138: r>
139: ;
140:
141: : finddevice ( dev_spec -- phandle|-1 )
142: dup cstrlen
143: \ ." FIND-DEVICE " 2dup type
144: find-dev 0= if -1 then
145: \ ." -- " dup . cr
146: ;
147:
148: : instance-to-package ( ihandle -- phandle )
149: ?ihandle ihandle>phandle
150: ;
151:
152: : package-to-path ( buflen buf phandle -- length )
153: \ XXX improve error checking
154: dup 0= if 3drop -1 exit then
155: >r swap r>
156: get-package-path
157: ( buf buflen str len )
158: ci-strcpy
159: ;
160:
161: : canon ( buflen buf dev_specifier -- len )
162: dup cstrlen find-dev if
163: ( buflen buf phandle )
164: package-to-path
165: else
166: 2drop -1
167: then
168: ;
169:
170: : instance-to-path ( buflen buf ihandle -- length )
171: \ XXX improve error checking
172: dup 0= if 3drop -1 exit then
173: >r swap r>
174: get-instance-path
175: \ ." INSTANCE: " 2dup type cr dup .
176: ( buf buflen str len )
177: ci-strcpy
178: ;
179:
180: : instance-to-interposed-path ( buflen buf ihandle -- length )
181: \ XXX improve error checking
182: dup 0= if 3drop -1 exit then
183: >r swap r>
184: get-instance-interposed-path
185: ( buf buflen str len )
186: ci-strcpy
187: ;
188:
189: : call-method ( ihandle method -- xxxx catch-result )
190: dup 0= if ." call of null method" -1 exit then
191: dup >r
192: dup cstrlen
193: \ ." call-method " 2dup type cr
194: rot ?ihandle ['] $call-method catch dup if
195: \ not necessary an error but very useful for debugging...
196: ." call-method " r@ dup cstrlen type ." : exception " dup . cr
197: then
198: r> drop
199: ;
200:
201:
202: \ -------------------------------------------------------------
203: \ 6.3.2.3 Device I/O
204: \ -------------------------------------------------------------
205:
206: : open ( dev_spec -- ihandle|0 )
207: dup cstrlen open-dev
208: ;
209:
210: : close ( ihandle -- )
211: close-dev
212: ;
213:
214: : read ( len addr ihandle -- actual )
215: >r swap r>
216: dup ihandle>phandle " read" rot find-method
217: if swap call-package else 3drop -1 then
218: ;
219:
220: : write ( len addr ihandle -- actual )
221: >r swap r>
222: dup ihandle>phandle " write" rot find-method
223: if swap call-package else 3drop -1 then
224: ;
225:
226: : seek ( pos_lo pos_hi ihandle -- status )
227: dup ihandle>phandle " seek" rot find-method
228: if swap call-package else 3drop -1 then
229: ;
230:
231:
232: \ -------------------------------------------------------------
233: \ 6.3.2.4 Memory
234: \ -------------------------------------------------------------
235:
236: : claim ( align size virt -- baseaddr|-1 )
237: -rot swap
238: ciface-ph " cif-claim" rot find-method
239: if execute else 3drop -1 then
240: ;
241:
242: : release ( size virt -- )
243: swap
244: ciface-ph " cif-release" rot find-method
245: if execute else 2drop -1 then
246: ;
247:
248: \ -------------------------------------------------------------
249: \ 6.3.2.5 Control transfer
250: \ -------------------------------------------------------------
251:
252: : boot ( bootspec -- )
253: ." BOOT"
254: ;
255:
256: : enter ( -- )
257: ." ENTER"
258: ;
259:
260: \ exit ( -- ) is defined later (clashes with builtin exit)
261:
262: : chain ( virt size entry args len -- )
263: ." CHAIN"
264: ;
265:
266: \ -------------------------------------------------------------
267: \ 6.3.2.6 User interface
268: \ -------------------------------------------------------------
269:
270: : interpret ( xxx cmdstring -- ??? catch-reult )
271: dup cstrlen
272: \ ." INTERPRETE: --- " 2dup type
273: ['] evaluate catch dup if
274: \ this is not necessary an error...
275: ." interpret: exception " dup . ." caught" cr
276:
277: \ Force back to interpret state on error, otherwise the next call to
278: \ interpret gets confused if the error occurred in compile mode
279: 0 state !
280: then
281: \ ." --- " cr
282: ;
283:
284: : set-callback ( newfunc -- oldfunc )
285: callback-function @
286: swap
287: callback-function !
288: ;
289:
290: \ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ;
291:
292:
293: \ -------------------------------------------------------------
294: \ 6.3.2.7 Time
295: \ -------------------------------------------------------------
296:
297: \ : milliseconds ( -- ms ) ;
298:
299:
300: \ -------------------------------------------------------------
301: \ arch?
302: \ -------------------------------------------------------------
303:
304: : start-cpu ( xxx xxx xxx --- )
305: ." Start CPU unimplemented" cr
306: 3drop
307: ;
308:
309: \ -------------------------------------------------------------
310: \ special
311: \ -------------------------------------------------------------
312:
313: : exit ( -- )
314: ." EXIT"
315: outer-interpreter
316: ;
317:
318: [IFDEF] CONFIG_PPC
319: \ PowerPC Microprocessor CHRP binding
320: \ 10.5.2. Client Interface
321:
322: ( cstring-method phandle -- missing )
323:
324: : test-method
325: swap dup cstrlen rot
326: find-method 0= if -1 else drop 0 then
327: ;
328: [THEN]
329:
330: finish-device
331: device-end
332:
333:
334: \ -------------------------------------------------------------
335: \ entry point
336: \ -------------------------------------------------------------
337:
338: : client-iface ( [args] name len -- [args] -1 | [rets] 0 )
339: ciface-ph find-method 0= if -1 exit then
340: catch ?dup if
341: cr ." Unexpected client interface exception: " . -2 cr exit
342: then
343: 0
344: ;
345:
346: : client-call-iface ( [args] name len -- [args] -1 | [rets] 0 )
347: ciface-ph find-method 0= if -1 exit then
348: execute
349: 0
350: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.