![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pathres.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 pathres.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 root 1: \ tag: Path resolution
2: \
3: \ this code implements IEEE 1275-1994 path resolution
4: \
5: \ Copyright (C) 2003 Samuel Rydh
6: \
7: \ See the file "COPYING" for further information about
8: \ the copyright and warranty status of this work.
9: \
10:
11: 0 value interpose-ph
12: 0 0 create interpose-args , ,
13:
14: : expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? )
15: 2dup
16: " /aliases" find-dev 0= if 2drop false exit then
17: get-package-property if
18: false
19: else
20: 2swap 2drop
21: \ drop trailing 0 from string
22: dup if 1- then
23: true
24: then
25: ;
26:
27: \
28: \ 4.3.1 Resolve aliases
29: \
30:
31: \ the returned string is allocated with alloc-mem
32: : pathres-resolve-aliases ( path-addr path-len -- path-addr path-len )
33: over c@ 2f <> if
34: 200 here + >r \ abuse dictionary for temporary storage
35:
36: \ If the pathname does not begin with "/", and its first node name
37: \ component is an alias, replace the alias with its expansion.
38: ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD)
39: ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME)
40: expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? )
41: if
42: 2 pick 0<> if \ If ALIAS_ARGS is not empty
43: ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/)
44: 2swap ( TAIL AL_HEAD/ AL_TAIL )
45: ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL)
46: 2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL )
47: 2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD )
48: r> tmpstrcat tmpstrcat >r
49: else
50: 2swap 2drop \ drop ALIAS_ARGS
51: then
52: r> tmpstrcat drop
53: else
54: \ put thing back together again
55: r> tmpstrcat tmpstrcat drop
56: then
57: then
58:
59: strdup
60: ( path-addr path-len )
61: ;
62:
63: \
64: \ search struct
65: \
66:
67: struct ( search information )
68: 2 cells field >si.path
69: 2 cells field >si.arguments
70: 2 cells field >si.unit_addr
71: 2 cells field >si.node_name
72: 2 cells field >si.free_me
73: 4 cells field >si.unit_phys
74: /n field >si.unit_phys_len
75: /n field >si.save-ihandle
76: /n field >si.save-phandle
77: /n field >si.top-ihandle
78: /n field >si.top-opened \ set after successful open
79: /n field >si.child \ node to match
80: constant sinfo.size
81:
82:
83: \
84: \ 4.3.6 node name match criteria
85: \
86:
87: : match-nodename ( childname len sinfo -- match? )
88: >r
89: 2dup r@ >si.node_name 2@
90: ( [childname] [childname] [nodename] )
91: strcmp 0= if r> 3drop true exit then
92:
93: \ does NODE_NAME contain a comma?
94: r@ >si.node_name 2@ ascii , strchr
95: if r> 3drop false exit then
96:
97: ( [childname] )
98: ascii , left-split 2drop r@ >si.node_name 2@
99: r> drop
100: strcmp if false else true then
101: ;
102:
103:
104: \
105: \ 4.3.4 exact match child node
106: \
107:
108: \ If NODE_NAME is not empty, make sure it matches the name property
109: : common-match ( sinfo -- )
110: >r
111: \ a) NODE_NAME nonempty
112: r@ >si.node_name 2@ nip if
113: " name" r@ >si.child @ get-package-property if -1 throw then
114: \ name is supposed to be null-terminated
115: dup 0> if 1- then
116: \ exit if NODE_NAME does not match
117: r@ match-nodename 0= if -2 throw then
118: then
119: r> drop
120: ;
121:
122: : (exact-match) ( sinfo -- )
123: >r
124: \ a) If NODE_NAME is not empty, make sure it matches the name property
125: r@ common-match
126:
127: \ b) UNIT_PHYS nonempty?
128: r@ >si.unit_phys_len @ /l* ?dup if
129: \ check if unit_phys matches
130: " reg" r@ >si.child @ get-package-property if -3 throw then
131: ( unitbytes propaddr proplen )
132: rot r@ >si.unit_phys -rot
133: ( propaddr unit_phys proplen unitbytes )
134: swap over < if -4 throw then
135: comp if -5 throw then
136: else
137: \ c) both NODE_NAME and UNIT_PHYS empty?
138: r@ >si.node_name 2@ nip 0= if -6 throw then
139: then
140:
141: r> drop
142: ;
143:
144: : exact-match ( sinfo -- match? )
145: ['] (exact-match) catch if drop false exit then
146: true
147: ;
148:
149: \
150: \ 4.3.5 wildcard match child node
151: \
152:
153: : (wildcard-match) ( sinfo -- match? )
154: >r
155: \ a) If NODE_NAME is not empty, make sure it matches the name property
156: r@ common-match
157:
158: \ b) Fail if "reg" property exist
159: " reg" r@ >si.child @ get-package-property 0= if -7 throw then
160:
161: \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty
162: r@ >si.unit_phys_len @
163: r@ >si.node_name 2@ nip
164: or 0= if -1 throw then
165:
166: \ SUCCESS
167: r> drop
168: ;
169:
170: : wildcard-match ( sinfo -- match? )
171: ['] (wildcard-match) catch if drop false exit then
172: true
173: ;
174:
175:
176: \
177: \ 4.3.3 match child node
178: \
179:
180: : find-child ( sinfo -- phandle )
181: >r
182: \ decode unit address string
183: r@ >si.unit_addr 2@ dup if
184: ( str len )
185: " decode-unit" active-package find-method
186: if
187: depth 3 - >r execute depth r@ - r> swap
188: ( ... a_lo ... a_hi olddepth n )
189: 4 min 0 max
190: dup r@ >si.unit_phys_len !
191: ( ... a_lo ... a_hi olddepth n )
192: r@ >si.unit_phys >r
193: begin 1- dup 0>= while
194: rot r> dup la1+ >r l!-be
195: repeat
196: r> 2drop
197: depth!
198: else
199: \ no decode-unit method... failure
200: -99 throw
201: then
202: else
203: 2drop
204: \ clear unit_phys
205: 0 r@ >si.unit_phys_len !
206: \ r@ >si.unit_phys 4 cells 0 fill
207: then
208:
209: ( R: sinfo )
210: ['] exact-match
211: begin dup while
212: active-package >dn.child @
213: begin ?dup while
214: dup r@ >si.child !
215: ( xt phandle R: sinfo )
216: r@ 2 pick execute if 2drop r> >si.child @ exit then
217: >dn.peer @
218: repeat
219: ['] exact-match = if ['] wildcard-match else 0 then
220: repeat
221:
222: -99 throw
223: ;
224:
225:
226: \
227: \ 4.3.2 Create new linked instance procedure
228: \
229:
230: : link-one ( sinfo -- )
231: >r
232: active-package create-instance
233: dup 0= if -99 throw then
234:
235: \ change instance parent
236: r@ >si.top-ihandle @ over >in.my-parent !
237: dup r@ >si.top-ihandle !
238: to my-self
239:
240: \ b) set my-args field
241: r@ >si.arguments 2@ strdup my-self >in.arguments 2!
242:
243: \ e) set my-unit field
244: r@ >si.unit_addr 2@ nip if
245: \ copy UNIT_PHYS to the my-unit field
246: r@ >si.unit_phys my-self >in.my-unit 4 cells move
247: else
248: \ set unit-addr from reg property
249: " reg" active-package get-package-property 0= if
250: \ ( ihandle prop proplen )
251: \ copy address to my-unit
252: 4 cells min my-self >in.my-unit swap move
253: else
254: \ clear my-unit
255: my-self >in.my-unit 4 cells 0 fill
256: then
257: then
258:
259: \ top instance has not been opened (yet)
260: false r> >si.top-opened !
261: ;
262:
263: : invoke-open ( sinfo -- )
264: " open" my-self ['] $call-method
265: catch if 3drop false then
266: 0= if -99 throw then
267:
268: true swap >si.top-opened !
269: ;
270:
271: \
272: \ 4.3.7 Handle interposers procedure (supplement)
273: \
274:
275: : handle-interposers ( sinfo -- )
276: >r
277: begin
278: interpose-ph ?dup
279: while
280: 0 to interpose-ph
281: active-package swap active-package!
282:
283: \ clear unit address and set arguments
284: 0 0 r@ >si.unit_addr 2!
285: interpose-args 2@ r@ >si.arguments 2!
286: r@ link-one
287: true my-self >in.interposed !
288: interpose-args 2@ free-mem
289: r@ invoke-open
290:
291: active-package!
292: repeat
293:
294: r> drop
295: ;
296:
297: \
298: \ 4.3.1 Path resolution procedure
299: \
300:
301: \ close-dev ( ihandle -- )
302: \
303: : close-dev
304: begin
305: dup
306: while
307: dup >in.my-parent @
308: swap close-package
309: repeat
310: drop
311: ;
312:
313: : path-res-cleanup ( sinfo close? )
314:
315: \ tear down all instances if close? is set
316: if
317: dup >si.top-opened @ if
318: dup >si.top-ihandle @
319: ?dup if close-dev then
320: else
321: dup >si.top-ihandle @ dup
322: ( sinfo ihandle ihandle )
323: dup if >in.my-parent @ swap then
324: ( sinfo parent ihandle )
325: ?dup if destroy-instance then
326: ?dup if close-dev then
327: then
328: then
329:
330: \ restore active-package and my-self
331: dup >si.save-ihandle @ to my-self
332: dup >si.save-phandle @ active-package!
333:
334: \ free any allocated memory
335: dup >si.free_me 2@ free-mem
336: sinfo.size free-mem
337: ;
338:
339: : (path-resolution) ( context sinfo -- )
340: >r r@ >si.path 2@
341: ( context pathstr pathlen )
342:
343: \ this allocates a copy of the string
344: pathres-resolve-aliases
345: 2dup r@ >si.free_me 2!
346:
347: \ If the pathname, after possible alias expansion, begins with "/",
348: \ begin the search at the root node. Otherwise, begin at the active
349: \ package.
350:
351: dup if \ make sure string is not empty
352: over c@ 2f = if
353: swap char+ swap /c - \ Remove the "/" from PATH_NAME.
354: \ Set the active package to the root node.
355: device-tree @ active-package!
356: then
357: then
358:
359: r@ >si.path 2!
360: 0 0 r@ >si.unit_addr 2!
361: 0 0 r@ >si.arguments 2!
362: 0 r@ >si.top-ihandle !
363:
364: \ If there is no active package, exit this procedure, returning false.
365: ( context )
366: active-package 0= if -99 throw then
367:
368: \ Begin the creation of an instance chain.
369: \ NOTE--If, at this step, the active package is not the root node and
370: \ we are in open-dev or execute-device-method contexts, the instance
371: \ chain that results from the path resolution process may be incomplete.
372:
373: active-package swap
374: ( virt-active-node context )
375: begin
376: r@ >si.path 2@ nip \ nonzero path?
377: while
378: \ ( active-node context )
379: \ is this open-dev or execute-device-method context?
380: dup if
381: r@ link-one
382: over active-package <> my-self >in.interposed !
383: r@ invoke-open
384: r@ handle-interposers
385: then
386: over active-package!
387:
388: r@ >si.path 2@ ( PATH )
389:
390: ascii / left-split ( PATH COMPONENT )
391: ascii : left-split ( PATH ARGS NODE_ADDR )
392: ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME )
393:
394: r@ >si.node_name 2!
395: r@ >si.unit_addr 2!
396: r@ >si.arguments 2!
397: r@ >si.path 2!
398:
399: ( virt-active-node context )
400:
401: \ 4.3.1 i) pathname has a leading %?
402: r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if
403: 1- swap 1+ swap r@ >si.node_name 2!
404: " /packages" find-dev drop active-package!
405: r@ find-child
406: else
407: 2drop
408: nip r@ find-child swap over
409: ( new-node context new-node )
410: then
411:
412: \ (optional: open any nodes between parent and child )
413:
414: active-package!
415: repeat
416:
417: ( virt-active-node type )
418: dup if r@ link-one then
419: 1 = if
420: dup active-package <> my-self >in.interposed !
421: r@ invoke-open
422: r@ handle-interposers
423: then
424: active-package!
425:
426: r> drop
427: ;
428:
429: : path-resolution ( context path-addr path-len -- sinfo true | false )
430: \ allocate and clear the search block
431: sinfo.size alloc-mem >r
432: r@ sinfo.size 0 fill
433:
434: \ store path
435: r@ >si.path 2!
436:
437: \ save ihandle and phandle
438: my-self r@ >si.save-ihandle !
439: active-package r@ >si.save-phandle !
440:
441: \ save context (if we take an exception)
442: dup
443:
444: r@ ['] (path-resolution)
445: catch ?dup if
446: ( context xxx xxx error )
447: r> true path-res-cleanup
448:
449: \ rethrow everything except our "cleanup throw"
450: dup -99 <> if throw then
451: 3drop
452:
453: \ ( context ) throw an exception if this is find-device context
454: if false else -22 throw then
455: exit
456: then
457:
458: \ ( context )
459: drop r> true
460: ( sinfo true )
461: ;
462:
463:
464: : open-dev ( dev-str dev-len -- ihandle | 0 )
465: 1 -rot path-resolution 0= if false exit then
466:
467: ( sinfo )
468: my-self swap
469: false path-res-cleanup
470:
471: ( ihandle )
472: ;
473:
474: : execute-device-method
475: ( ... dev-str dev-len met-str met-len -- ... false | ?? true )
476: 2swap
477: 2 -rot path-resolution 0= if 2drop false exit then
478: ( method-str method-len sinfo )
479: >r
480: my-self ['] $call-method catch
481: if 3drop false else true then
482: r> true path-res-cleanup
483: ;
484:
485: : find-device ( dev-str dev-len -- )
486: 2dup " .." strcmp 0= if
487: 2drop
488: active-package dup if >dn.parent @ then
489: \ ".." in root note?
490: dup 0= if -22 throw then
491: active-package!
492: exit
493: then
494: 0 -rot path-resolution 0= if false exit then
495: ( sinfo )
496: active-package swap
497: true path-res-cleanup
498: active-package!
499: ;
500:
501: \ find-device, but without side effects
502: : (find-dev) ( dev-str dev-len -- phandle true | false )
503: active-package -rot
504: ['] find-device catch if 3drop false exit then
505: active-package swap active-package! true
506: ;
507:
508: \ Tuck on a node at the end of the chain being created.
509: \ This implementation follows the interpose recommended practice
510: \ (v0.2 draft).
511:
512: : interpose ( arg-str arg-len phandle -- )
513: to interpose-ph
514: strdup interpose-args 2!
515: ;
516:
517: ['] (find-dev) to find-dev
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.