\ tag: Path resolution \ \ this code implements IEEE 1275-1994 path resolution \ \ Copyright (C) 2003 Samuel Rydh \ \ See the file "COPYING" for further information about \ the copyright and warranty status of this work. \ 0 value interpose-ph 0 0 create interpose-args , , : expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? ) 2dup " /aliases" find-dev 0= if 2drop false exit then get-package-property if false else 2swap 2drop \ drop trailing 0 from string dup if 1- then true then ; \ \ 4.3.1 Resolve aliases \ \ the returned string is allocated with alloc-mem : pathres-resolve-aliases ( path-addr path-len -- path-addr path-len ) over c@ 2f <> if 200 here + >r \ abuse dictionary for temporary storage \ If the pathname does not begin with "/", and its first node name \ component is an alias, replace the alias with its expansion. ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD) ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME) expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? ) if 2 pick 0<> if \ If ALIAS_ARGS is not empty ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/) 2swap ( TAIL AL_HEAD/ AL_TAIL ) ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL) 2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL ) 2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD ) r> tmpstrcat tmpstrcat >r else 2swap 2drop \ drop ALIAS_ARGS then r> tmpstrcat drop else \ put thing back together again r> tmpstrcat tmpstrcat drop then then strdup ( path-addr path-len ) ; \ \ search struct \ struct ( search information ) 2 cells field >si.path 2 cells field >si.arguments 2 cells field >si.unit_addr 2 cells field >si.node_name 2 cells field >si.free_me 4 cells field >si.unit_phys /n field >si.unit_phys_len /n field >si.save-ihandle /n field >si.save-phandle /n field >si.top-ihandle /n field >si.top-opened \ set after successful open /n field >si.child \ node to match constant sinfo.size \ \ 4.3.6 node name match criteria \ : match-nodename ( childname len sinfo -- match? ) >r 2dup r@ >si.node_name 2@ ( [childname] [childname] [nodename] ) strcmp 0= if r> 3drop true exit then \ does NODE_NAME contain a comma? r@ >si.node_name 2@ ascii , strchr if r> 3drop false exit then ( [childname] ) ascii , left-split 2drop r@ >si.node_name 2@ r> drop strcmp if false else true then ; \ \ 4.3.4 exact match child node \ \ If NODE_NAME is not empty, make sure it matches the name property : common-match ( sinfo -- ) >r \ a) NODE_NAME nonempty r@ >si.node_name 2@ nip if " name" r@ >si.child @ get-package-property if -1 throw then \ name is supposed to be null-terminated dup 0> if 1- then \ exit if NODE_NAME does not match r@ match-nodename 0= if -2 throw then then r> drop ; : (exact-match) ( sinfo -- ) >r \ a) If NODE_NAME is not empty, make sure it matches the name property r@ common-match \ b) UNIT_PHYS nonempty? r@ >si.unit_phys_len @ /l* ?dup if \ check if unit_phys matches " reg" r@ >si.child @ get-package-property if -3 throw then ( unitbytes propaddr proplen ) rot r@ >si.unit_phys -rot ( propaddr unit_phys proplen unitbytes ) swap over < if -4 throw then comp if -5 throw then else \ c) both NODE_NAME and UNIT_PHYS empty? r@ >si.node_name 2@ nip 0= if -6 throw then then r> drop ; : exact-match ( sinfo -- match? ) ['] (exact-match) catch if drop false exit then true ; \ \ 4.3.5 wildcard match child node \ : (wildcard-match) ( sinfo -- match? ) >r \ a) If NODE_NAME is not empty, make sure it matches the name property r@ common-match \ b) Fail if "reg" property exist " reg" r@ >si.child @ get-package-property 0= if -7 throw then \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty r@ >si.unit_phys_len @ r@ >si.node_name 2@ nip or 0= if -1 throw then \ SUCCESS r> drop ; : wildcard-match ( sinfo -- match? ) ['] (wildcard-match) catch if drop false exit then true ; \ \ 4.3.3 match child node \ \ used if package lacks a decode-unit method : def-decode-unit ( str len -- unitaddr ... ) parse-hex ; : get-decode-unit-xt ( phandle -- xt ) " decode-unit" rot find-method 0= if ['] def-decode-unit then ; : find-child ( sinfo -- phandle ) >r \ decode unit address string r@ >si.unit_addr 2@ dup if ( str len ) active-package get-decode-unit-xt depth 3 - >r execute depth r@ - r> swap ( ... a_lo ... a_hi olddepth n ) 4 min 0 max dup r@ >si.unit_phys_len ! ( ... a_lo ... a_hi olddepth n ) r@ >si.unit_phys >r begin 1- dup 0>= while rot r> dup la1+ >r l!-be repeat r> 2drop depth! else 2drop \ clear unit_phys 0 r@ >si.unit_phys_len ! \ r@ >si.unit_phys 4 cells 0 fill then ( R: sinfo ) ['] exact-match begin dup while active-package >dn.child @ begin ?dup while dup r@ >si.child ! ( xt phandle R: sinfo ) r@ 2 pick execute if 2drop r> >si.child @ exit then >dn.peer @ repeat ['] exact-match = if ['] wildcard-match else 0 then repeat -99 throw ; \ \ 4.3.2 Create new linked instance procedure \ : link-one ( sinfo -- ) >r active-package create-instance dup 0= if -99 throw then \ change instance parent r@ >si.top-ihandle @ over >in.my-parent ! dup r@ >si.top-ihandle ! to my-self \ b) set my-args field r@ >si.arguments 2@ strdup my-self >in.arguments 2! \ e) set my-unit field r@ >si.unit_addr 2@ nip if \ copy UNIT_PHYS to the my-unit field r@ >si.unit_phys my-self >in.my-unit 4 cells move else \ set unit-addr from reg property " reg" active-package get-package-property 0= if \ ( ihandle prop proplen ) \ copy address to my-unit 4 cells min my-self >in.my-unit swap move else \ clear my-unit my-self >in.my-unit 4 cells 0 fill then then \ top instance has not been opened (yet) false r> >si.top-opened ! ; : invoke-open ( sinfo -- ) " open" my-self ['] $call-method catch if 3drop false then 0= if -99 throw then true swap >si.top-opened ! ; \ \ 4.3.7 Handle interposers procedure (supplement) \ : handle-interposers ( sinfo -- ) >r begin interpose-ph ?dup while 0 to interpose-ph active-package swap active-package! \ clear unit address and set arguments 0 0 r@ >si.unit_addr 2! interpose-args 2@ r@ >si.arguments 2! r@ link-one true my-self >in.interposed ! interpose-args 2@ free-mem r@ invoke-open active-package! repeat r> drop ; \ \ 4.3.1 Path resolution procedure \ \ close-dev ( ihandle -- ) \ : close-dev begin dup while dup >in.my-parent @ swap close-package repeat drop ; : path-res-cleanup ( sinfo close? ) \ tear down all instances if close? is set if dup >si.top-opened @ if dup >si.top-ihandle @ ?dup if close-dev then else dup >si.top-ihandle @ dup ( sinfo ihandle ihandle ) dup if >in.my-parent @ swap then ( sinfo parent ihandle ) ?dup if destroy-instance then ?dup if close-dev then then then \ restore active-package and my-self dup >si.save-ihandle @ to my-self dup >si.save-phandle @ active-package! \ free any allocated memory dup >si.free_me 2@ free-mem sinfo.size free-mem ; : (path-resolution) ( context sinfo -- ) >r r@ >si.path 2@ ( context pathstr pathlen ) \ this allocates a copy of the string pathres-resolve-aliases 2dup r@ >si.free_me 2! \ If the pathname, after possible alias expansion, begins with "/", \ begin the search at the root node. Otherwise, begin at the active \ package. dup if \ make sure string is not empty over c@ 2f = if swap char+ swap /c - \ Remove the "/" from PATH_NAME. \ Set the active package to the root node. device-tree @ active-package! then then r@ >si.path 2! 0 0 r@ >si.unit_addr 2! 0 0 r@ >si.arguments 2! 0 r@ >si.top-ihandle ! \ If there is no active package, exit this procedure, returning false. ( context ) active-package 0= if -99 throw then \ Begin the creation of an instance chain. \ NOTE--If, at this step, the active package is not the root node and \ we are in open-dev or execute-device-method contexts, the instance \ chain that results from the path resolution process may be incomplete. active-package swap ( virt-active-node context ) begin r@ >si.path 2@ nip \ nonzero path? while \ ( active-node context ) \ is this open-dev or execute-device-method context? dup if r@ link-one over active-package <> my-self >in.interposed ! r@ invoke-open r@ handle-interposers then over active-package! r@ >si.path 2@ ( PATH ) ascii / left-split ( PATH COMPONENT ) ascii : left-split ( PATH ARGS NODE_ADDR ) ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME ) r@ >si.node_name 2! r@ >si.unit_addr 2! r@ >si.arguments 2! r@ >si.path 2! ( virt-active-node context ) \ 4.3.1 i) pathname has a leading %? r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if 1- swap 1+ swap r@ >si.node_name 2! " /packages" find-dev drop active-package! r@ find-child else 2drop nip r@ find-child swap over ( new-node context new-node ) then \ (optional: open any nodes between parent and child ) active-package! repeat ( virt-active-node type ) dup if r@ link-one then 1 = if dup active-package <> my-self >in.interposed ! r@ invoke-open r@ handle-interposers then active-package! r> drop ; : path-resolution ( context path-addr path-len -- sinfo true | false ) \ allocate and clear the search block sinfo.size alloc-mem >r r@ sinfo.size 0 fill \ store path r@ >si.path 2! \ save ihandle and phandle my-self r@ >si.save-ihandle ! active-package r@ >si.save-phandle ! \ save context (if we take an exception) dup r@ ['] (path-resolution) catch ?dup if ( context xxx xxx error ) r> true path-res-cleanup \ rethrow everything except our "cleanup throw" dup -99 <> if throw then 3drop \ ( context ) throw an exception if this is find-device context if false else -22 throw then exit then \ ( context ) drop r> true ( sinfo true ) ; : open-dev ( dev-str dev-len -- ihandle | 0 ) 1 -rot path-resolution 0= if false exit then ( sinfo ) my-self swap false path-res-cleanup ( ihandle ) ; : execute-device-method ( ... dev-str dev-len met-str met-len -- ... false | ?? true ) 2swap 2 -rot path-resolution 0= if 2drop false exit then ( method-str method-len sinfo ) >r my-self ['] $call-method catch if 3drop false else true then r> true path-res-cleanup ; : find-device ( dev-str dev-len -- ) 2dup " .." strcmp 0= if 2drop active-package dup if >dn.parent @ then \ ".." in root note? dup 0= if -22 throw then active-package! exit then 0 -rot path-resolution 0= if false exit then ( sinfo ) active-package swap true path-res-cleanup active-package! ; \ find-device, but without side effects : (find-dev) ( dev-str dev-len -- phandle true | false ) active-package -rot ['] find-device catch if 3drop false exit then active-package swap active-package! true ; \ Tuck on a node at the end of the chain being created. \ This implementation follows the interpose recommended practice \ (v0.2 draft). : interpose ( arg-str arg-len phandle -- ) to interpose-ph strdup interpose-args 2! ; ['] (find-dev) to find-dev