![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to package.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 / device|
Return to package.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: Package access.
2: \
3: \ this code implements IEEE 1275-1994 ch. 5.3.4
4: \
5: \ Copyright (C) 2003 Stefan Reinauer
6: \
7: \ See the file "COPYING" for further information about
8: \ the copyright and warranty status of this work.
9: \
10:
11: \ variable last-package 0 last-package !
12: \ 0 value active-package
13: : current-device active-package ;
14:
15: \
16: \ 5.3.4.1 Open/Close packages (part 1)
17: \
18:
19: \ 0 value my-self ( -- ihandle )
20: : ?my-self
21: my-self dup 0= abort" no current instance."
22: ;
23:
24: : my-parent ( -- ihandle )
25: ?my-self >in.my-parent @
26: ;
27:
28: : ihandle>non-interposed-phandle ( ihandle -- phandle )
29: begin dup >in.interposed @ while
30: >in.my-parent @
31: repeat
32: >in.device-node @
33: ;
34:
35: : ihandle>phandle ( ihandle -- phandle )
36: >in.device-node @
37: ;
38:
39:
40: \ next-property
41: \ defined in property.c
42:
43: : peer ( phandle -- phandle.sibling )
44: ?dup if
45: >dn.peer @
46: else
47: device-tree @
48: then
49: ;
50:
51: : child ( phandle.parent -- phandle.child )
52: >dn.child @
53: ;
54:
55:
56: \
57: \ 5.3.4.2 Call methods from other packages
58: \
59:
60: : find-method ( method-str method-len phandle -- false | xt true )
61: \ should we search the private wordlist too? I don't think so...
62: >dn.methods @ find-wordlist if
63: true
64: else
65: 2drop false
66: then
67: ;
68:
69: : call-package ( ... xt ihandle -- ??? )
70: my-self >r
71: to my-self
72: execute
73: r> to my-self
74: ;
75:
76:
77: : $call-method ( ... method-str method-len ihandle -- ??? )
78: dup >r >in.device-node @ find-method if
79: r> call-package
80: else
81: -21 throw
82: then
83: ;
84:
85: : $call-parent ( ... method-str method-len -- ??? )
86: my-parent $call-method
87: ;
88:
89:
90: \
91: \ 5.3.4.1 Open/Close packages (part 2)
92: \
93:
94: \ find-dev ( dev-str dev-len -- false | phandle true )
95: \ find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
96: \
97: \ These function works just like find-device but without
98: \ any side effects (or exceptions).
99: \
100: defer find-dev
101:
102: : find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
103: active-package >r active-package!
104: find-dev
105: r> active-package!
106: ;
107:
108: : find-package ( name-str name-len -- false | phandle true )
109: \ Locate the support package named by name string.
110: \ If the package can be located, return its phandle and true; otherwise,
111: \ return false.
112: \ Interpret the name in name string relative to the "packages" device node.
113: \ If there are multiple packages with the same name (within the "packages"
114: \ node), return the phandle for the most recently created one.
115:
116: \ This does the full path resolution stuff (including
117: \ alias expansion. If we don't want that, then we should just
118: \ iterade the children of /packages.
119: " /packages" find-dev 0= if 2drop false exit then
120: find-rel-dev 0= if false exit then
121:
122: true
123: ;
124:
125: : open-package ( arg-str arg-len phandle -- ihandle | 0 )
126: \ Open the package indicated by phandle.
127: \ Create an instance of the package identified by phandle, save in that
128: \ instance the instance-argument specified by arg-string and invoke the
129: \ package's open method.
130: \ Return the instance handle ihandle of the new instance, or 0 if the package
131: \ could not be opened. This could occur either because that package has no
132: \ open method, or because its open method returned false, indicating an error.
133: \ The parent instance of the new instance is the instance that invoked
134: \ open-package. The current instance is not changed.
135:
136: create-instance dup 0= if
137: 3drop 0 exit
138: then
139: >r
140:
141: \ clone arg-str
142: strdup r@ >in.arguments 2!
143:
144: \ open the package
145: " open" r@ ['] $call-method catch if 3drop false then
146: if
147: r>
148: else
149: r> destroy-instance false
150: then
151: ;
152:
153:
154: : $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 )
155: \ Open the support package named by name string.
156: find-package if
157: open-package
158: else
159: 2drop false
160: then
161: ;
162:
163:
164: : close-package ( ihandle -- )
165: \ Close the instance identified by ihandle by calling the package's close
166: \ method and then destroying the instance.
167: dup " close" rot ['] $call-method catch if 3drop then
168: destroy-instance
169: ;
170:
171: \
172: \ 5.3.4.3 Get local arguments
173: \
174:
175: : my-address ( -- phys.lo ... )
176: ?my-self >in.device-node @
177: >dn.probe-addr
178: my-#acells tuck /l* + swap 1- 0
179: ?do
180: /l - dup l@ swap
181: loop
182: drop
183: ;
184:
185: : my-space ( -- phys.hi )
186: ?my-self >in.device-node @
187: >dn.probe-addr @
188: ;
189:
190: : my-unit ( -- phys.lo ... phys.hi )
191: ?my-self >in.my-unit
192: my-#acells tuck /l* + swap 0 ?do
193: /l - dup l@ swap
194: loop
195: drop
196: ;
197:
198: : my-args ( -- arg-str arg-len )
199: ?my-self >in.arguments 2@
200: ;
201:
202: \ char is not included. If char is not found, then R-len is zero
203: : left-parse-string ( str len char -- R-str R-len L-str L-len )
204: left-split
205: ;
206:
207: \ parse ints "hi,...,lo" separated by comma
208: : parse-ints ( str len num -- val.lo .. val.hi )
209: -rot 2 pick -rot
210: begin
211: rot 1- -rot 2 pick 0>=
212: while
213: ( num n str len )
214: 2dup ascii , strchr ?dup if
215: ( num n str len p )
216: 1+ -rot
217: 2 pick 2 pick - ( num n p str len len1+1 )
218: dup -rot - ( num n p str len1+1 len2 )
219: -rot 1- ( num n p len2 str len1 )
220: else
221: 0 0 2swap
222: then
223: $number if 0 then >r
224: repeat
225: 3drop
226:
227: ( num )
228: begin 1- dup 0>= while r> swap repeat
229: drop
230: ;
231:
232: : parse-2int ( str len -- val.lo val.hi )
233: 2 parse-ints
234: ;
235:
236:
237: \
238: \ 5.3.4.4 Mapping tools
239: \
240:
241: : map-low ( phys.lo ... size -- virt )
242: my-space swap s" map-in" $call-parent
243: ;
244:
245: : free-virtual ( virt size -- )
246: over s" address" get-my-property 0= if
247: decode-int -rot 2drop = if
248: s" address" delete-property
249: then
250: else
251: drop
252: then
253: s" map-out" $call-parent
254: ;
255:
256:
257: \ Deprecated functions (required for compatibility with older loaders)
258:
259: variable package-stack-pos 0 package-stack-pos !
260: create package-stack 8 cells allot
261:
262: : push-package ( phandle -- )
263: \ Throw an error if we attempt to push a full stack
264: package-stack-pos @ 8 >= if
265: ." cannot push-package onto full stack" cr
266: -99 throw
267: then
268: active-package
269: package-stack-pos @ /n * package-stack + !
270: package-stack-pos @ 1 + package-stack-pos !
271: active-package!
272: ;
273:
274: : pop-package ( -- )
275: \ Throw an error if we attempt to pop an empty stack
276: package-stack-pos @ 0 = if
277: ." cannot pop-package from empty stack" cr
278: -99 throw
279: then
280: package-stack-pos @ 1 - package-stack-pos !
281: package-stack-pos @ /n * package-stack + @
282: active-package!
283: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.