forth/device/pathres.fs

   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 : select-dev ( dev-str dev-len -- ihandle | 0 )
 475   open-dev
 476 ;
 477
 478 : execute-device-method
 479 ( ... dev-str dev-len met-str met-len -- ... false | ?? true )
 480   2swap
 481   2 -rot path-resolution 0= if 2drop false exit then
 482   ( method-str method-len sinfo )
 483   >r
 484   my-self ['] $call-method catch
 485   if 3drop false else true then
 486   r> true path-res-cleanup
 487 ;
 488
 489 : find-device ( dev-str dev-len -- )
 490   2dup " .." strcmp 0= if
 491     2drop
 492     active-package dup if >dn.parent @ then
 493     \ ".." in root note?
 494     dup 0= if -22 throw then
 495     active-package!
 496     exit
 497   then
 498   0 -rot path-resolution 0= if false exit then
 499   ( sinfo )
 500   active-package swap
 501   true path-res-cleanup
 502   active-package!
 503 ;
 504
 505 \ find-device, but without side effects
 506 : (find-dev) ( dev-str dev-len -- phandle true | false )
 507   active-package -rot
 508   ['] find-device catch if 3drop false exit then
 509   active-package swap active-package! true
 510 ;
 511
 512 \ Tuck on a node at the end of the chain being created.
 513 \ This implementation follows the interpose recommended practice
 514 \ (v0.2 draft).
 515
 516 : interpose ( arg-str arg-len phandle -- )
 517   to interpose-ph
 518   strdup interpose-args 2!
 519 ;
 520
 521 ['] (find-dev) to find-dev