![[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.