qemu/roms/SLOF/slof/fs/node.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 \ Device nodes.
  15
  16 false VALUE debug-find-component?
  17
  18 VARIABLE device-tree
  19 VARIABLE current-node
  20 : get-node  current-node @ dup 0= ABORT" No active device tree node" ;
  21
  22 STRUCT
  23   cell FIELD node>peer
  24   cell FIELD node>parent
  25   cell FIELD node>child
  26   cell FIELD node>properties
  27   cell FIELD node>words
  28   cell FIELD node>instance-template
  29   cell FIELD node>instance-size
  30   cell FIELD node>space?
  31   cell FIELD node>space
  32   cell FIELD node>addr1
  33   cell FIELD node>addr2
  34   cell FIELD node>addr3
  35 END-STRUCT
  36
  37 : find-method ( str len phandle -- false | xt true )
  38   node>words @ voc-find dup IF link> true THEN ;
  39
  40 \ Instances.
  41 #include "instance.fs"
  42
  43 : create-node ( parent -- new )
  44    max-instance-size alloc-mem        ( parent instance-mem )
  45    dup max-instance-size erase >r     ( parent  R: instance-mem )
  46    align wordlist >r wordlist >r      ( parent  R: instance-mem wl wl )
  47    here                               ( parent new  R: instance-mem wl wl )
  48    0 , swap , 0 ,                     \ Set node>peer, node>parent & node>child
  49    r> , r> ,                          \ Set node>properties & node>words to wl
  50    r> , /instance-header ,            \ Set instance-template & instance-size
  51    FALSE , 0 ,                        \ Set node>space? and node>space
  52    0 , 0 , 0 ,                        \ Set node>addr*
  53 ;
  54
  55 : peer    node>peer   @ ;
  56 : parent  node>parent @ ;
  57 : child   node>child  @ ;
  58 : peer  dup IF peer ELSE drop device-tree @ THEN ;
  59
  60
  61 : link ( new head -- ) \ link a new node at the end of a linked list
  62   BEGIN dup @ WHILE @ REPEAT ! ;
  63 : link-node ( parent child -- )
  64   swap dup IF node>child link ELSE drop device-tree ! THEN ;
  65
  66 \ Set a node as active node.
  67 : set-node ( phandle -- )
  68   current-node @ IF previous THEN
  69   dup current-node !
  70   ?dup IF node>words @ also context ! THEN
  71   definitions ;
  72 : get-parent  get-node parent ;
  73
  74
  75 : new-node ( -- phandle ) \ active node becomes new node's parent;
  76                           \ new node becomes active node
  77 \ XXX: change to get-node, handle root node creation specially
  78   current-node @ dup create-node
  79   tuck link-node dup set-node ;
  80
  81 : finish-node ( -- )
  82    \ TODO: maybe resize the instance template buffer here (or in finish-device)?
  83    get-node parent set-node
  84 ;
  85
  86 : device-end ( -- )  0 set-node ;
  87
  88 \ Properties.
  89 CREATE $indent 100 allot  VARIABLE indent 0 indent !
  90 #include "property.fs"
  91
  92 \ Unit address.
  93 : #address-cells  s" #address-cells" rot parent get-property
  94    ABORT" parent doesn't have a #address-cells property!"
  95    decode-int nip nip
  96 ;
  97
  98 \ my-#address-cells returns the #address-cells property of the parent node.
  99 \ child-#address-cells returns the #address-cells property of the current node.
 100
 101 \ This is confusing in several ways: Remember that a node's address is always
 102 \ described in the parent's address space, thus the parent's property is taken
 103 \ into regard, rather than the own.
 104
 105 \ Also, an address-cell here is always a 32bit cell, no matter whether the
 106 \ "real" cell size is 32bit or 64bit.
 107
 108 : my-#address-cells  ( -- #address-cells )
 109    get-node #address-cells
 110 ;
 111
 112 : child-#address-cells  ( -- #address-cells )
 113    s" #address-cells" get-node get-property
 114    ABORT" node doesn't have a #address-cells property!"
 115    decode-int nip nip
 116 ;
 117
 118 : child-#size-cells  ( -- #address-cells )
 119    s" #size-cells" get-node get-property
 120    ABORT" node doesn't have a #size-cells property!"
 121    decode-int nip nip
 122 ;
 123
 124 : encode-phys  ( phys.hi ... phys.low -- prop len )
 125    encode-first?  IF  encode-start  ELSE  here 0  THEN
 126    my-#address-cells 0 ?DO rot encode-int+ LOOP
 127 ;
 128
 129 : encode-child-phys  ( phys.hi ... phys.low -- prop len )
 130    encode-first?  IF  encode-start  ELSE  here 0  THEN
 131    child-#address-cells 0 ?DO rot encode-int+ LOOP
 132 ;
 133
 134 : encode-child-size  ( size.hi ... size.low -- prop len )
 135    encode-first? IF  encode-start  ELSE  here 0  THEN
 136    child-#size-cells 0 ?DO rot encode-int+ LOOP
 137 ;
 138
 139 : decode-phys
 140   my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
 141   my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
 142 : decode-phys-and-drop
 143   my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
 144   my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
 145 : reg  >r encode-phys r> encode-int+ s" reg" property ;
 146
 147
 148 : >space    node>space @ ;
 149 : >space?   node>space? @ ;
 150 : >address  dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
 151                                   dup 2 > IF r@ node>addr2 @ swap THEN
 152                                       1 > IF r@ node>addr1 @ THEN r> drop ;
 153 : >unit     dup >r >address r> >space ;
 154
 155 : (my-phandle)  ( -- phandle )
 156    my-self ?dup IF
 157       ihandle>phandle
 158    ELSE
 159       get-node dup 0= ABORT" no active node"
 160    THEN
 161 ;
 162
 163 : my-space ( -- phys.hi )
 164    (my-phandle) >space
 165 ;
 166 : my-address  (my-phandle) >address ;
 167
 168 \ my-unit returns the unit address of the current _instance_ - that means
 169 \ it returns the same values as my-space and my-address together _or_ it
 170 \ returns a unit address that has been set manually while opening the node.
 171 : my-unit
 172    my-self instance>#units @ IF
 173       0 my-self instance>#units @ 1- DO
 174          my-self instance>unit1 i cells + @
 175       -1 +LOOP
 176    ELSE
 177       my-self ihandle>phandle >unit
 178    THEN
 179 ;
 180
 181 \ Return lower 64 bit of address
 182 : my-unit-64 ( -- phys.lo+1|phys.lo )
 183    my-unit                                ( phys.lo ... phys.hi )
 184    (my-phandle) #address-cells            ( phys.lo ... phys.hi #ad-cells )
 185    CASE
 186       1   OF EXIT ENDOF
 187       2   OF lxjoin EXIT ENDOF
 188       3   OF drop lxjoin EXIT ENDOF
 189       dup OF 2drop lxjoin EXIT ENDOF
 190    ENDCASE
 191 ;
 192
 193 : set-space    get-node dup >r node>space ! true r> node>space? ! ;
 194 : set-address  my-#address-cells 1 ?DO
 195                get-node node>space i cells + ! LOOP ;
 196 : set-unit     set-space set-address ;
 197 : set-unit-64 ( phys.lo|phys.hi -- )
 198    my-#address-cells 2 <> IF
 199       ." set-unit-64: #address-cells <> 2 " abort
 200    THEN
 201    xlsplit set-unit
 202 ;
 203
 204 \ Never ever use this in actual code, only when debugging interactively.
 205 \ Thank you.
 206 : set-args ( arg-str len unit-str len -- )
 207    s" decode-unit" get-parent $call-static set-unit set-my-args
 208 ;
 209
 210 : $cat-unit
 211    dup parent 0= IF drop EXIT THEN
 212    dup >space? not IF drop EXIT THEN
 213    dup >r >unit s" encode-unit" r> parent $call-static
 214    dup IF
 215       dup >r here swap move s" @" $cat here r> $cat
 216    ELSE
 217       2drop
 218    THEN
 219 ;
 220
 221 : $cat-instance-unit
 222    dup parent 0= IF drop EXIT THEN
 223    \ No instance unit, use node unit
 224    dup instance>#units @ 0= IF
 225       ihandle>phandle $cat-unit
 226       EXIT
 227    THEN
 228    dup >r push-my-self
 229    ['] my-unit CATCH IF pop-my-self r> drop EXIT THEN
 230    pop-my-self
 231    s" encode-unit"
 232    r> ihandle>phandle parent
 233    $call-static
 234    dup IF
 235       dup >r here swap move s" @" $cat here r> $cat
 236    ELSE
 237       2drop
 238    THEN
 239 ;
 240
 241 \ Getting basic info about a node.
 242 : node>name  dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
 243 : node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
 244 : node>path
 245    here 0 rot
 246    BEGIN dup WHILE dup parent REPEAT
 247    2drop
 248    dup 0= IF [char] / c, THEN
 249    BEGIN
 250       dup
 251    WHILE
 252       [char] / c, node>qname here over allot swap move
 253    REPEAT
 254    drop here 2dup - allot over -
 255 ;
 256
 257 : interposed? ( ihandle -- flag )
 258   \ We cannot actually detect if an instance is interposed; instead, we look
 259   \ if an instance is part of the "normal" chain that would be opened by
 260   \ open-dev and friends, if there were no interposition.
 261   dup instance>parent @ dup 0= IF 2drop false EXIT THEN
 262   ihandle>phandle swap ihandle>phandle parent <> ;
 263
 264 : instance>qname
 265   dup >r interposed? IF s" %" ELSE 0 0 THEN
 266   r@ dup ihandle>phandle node>name
 267   rot ['] $cat-instance-unit CATCH IF drop THEN
 268   $cat r> instance>args 2@ swap
 269   dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN
 270 ;
 271
 272 : instance>qpath \ With interposed nodes.
 273   here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
 274   dup 0= IF [char] / c, THEN
 275   BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
 276   REPEAT drop here 2dup - allot over - ;
 277 : instance>path \ Without interposed nodes.
 278   here 0 rot BEGIN dup WHILE
 279   dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
 280   dup 0= IF [char] / c, THEN
 281   BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
 282   REPEAT drop here 2dup - allot over - ;
 283
 284 : .node  node>path type ;
 285 : pwd  get-node .node ;
 286
 287 : .instance instance>qpath type ;
 288 : .chain    dup instance>parent @ ?dup IF recurse THEN
 289             cr dup . instance>qname type ;
 290
 291
 292 \ Alias helper
 293 defer find-node
 294 : set-alias ( alias-name len device-name len -- )
 295     encode-string
 296     2swap s" /aliases" find-node ?dup IF
 297        set-property
 298     ELSE
 299        4drop
 300     THEN
 301 ;
 302
 303 : find-alias ( alias-name len -- false | dev-path len )
 304    s" /aliases" find-node dup IF
 305       get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
 306    THEN
 307 ;
 308
 309 : .alias ( alias-name len -- )
 310     find-alias dup IF type ELSE ." no alias available" THEN ;
 311
 312 : (.print-alias) ( lfa -- )
 313     link> dup >name name>string
 314     \ Don't print name property
 315     2dup s" name" string=ci IF 2drop drop
 316     ELSE cr type space ." : " execute type
 317     THEN ;
 318
 319 : (.list-alias) ( phandle -- )
 320     node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
 321
 322 : list-alias ( -- )
 323     s" /aliases" find-node dup IF (.list-alias) THEN ;
 324
 325 \ return next available name for aliasing or
 326 \ false if more than MAX-ALIAS aliases found
 327 8 CONSTANT MAX-ALIAS
 328 1 VALUE alias-ind
 329 : get-next-alias ( $alias-name -- $next-alias-name|FALSE )
 330     2dup find-alias IF
 331         drop
 332         1 TO alias-ind
 333         BEGIN
 334             2dup alias-ind $cathex 2dup find-alias
 335         WHILE
 336             drop 2drop
 337             alias-ind 1 + TO alias-ind
 338             alias-ind MAX-ALIAS = IF
 339                 2drop FALSE EXIT
 340             THEN
 341         REPEAT
 342         strdup 2swap 2drop
 343     THEN
 344 ;
 345
 346 : devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
 347     parse-word parse-word dup IF set-alias
 348     ELSE 2drop dup IF .alias
 349     ELSE 2drop list-alias THEN THEN ;
 350
 351 \ sub-alias does a single iteration of an alias at the beginning od dev path
 352 \ expression. de-alias will repeat this until all indirect alising is resolved
 353 : sub-alias ( arg-str arg-len -- arg' len' | false )
 354    2dup
 355    2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
 356    ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
 357    ( a l l p -- R:p | a l -- R:0 )
 358    find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
 359       r@ IF
 360          2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
 361       ELSE
 362          ( a' l' -- R:0 ) r> drop ( a' l' -- )
 363       THEN
 364    ELSE
 365       ( a l -- R:p | -- R:0 ) r> IF 2drop THEN
 366       false ( 0 -- )
 367    THEN
 368 ;
 369
 370 : de-alias ( arg-str arg-len -- arg' len' )
 371    BEGIN
 372       over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
 373    WHILE
 374       2swap 2drop
 375    REPEAT
 376 ;
 377
 378
 379 \ Display the device tree.
 380 : +indent ( not-last? -- )
 381   IF s" |   " ELSE s"     " THEN $indent indent @ + swap move 4 indent +! ;
 382 : -indent ( -- )  -4 indent +! ;
 383
 384 : ls-phandle ( node -- )  . ." :  " ;
 385
 386 : ls-node ( node -- )
 387    cr dup ls-phandle
 388    $indent indent @ type
 389    dup peer IF ." |-- " ELSE ." +-- " THEN
 390    node>qname type
 391 ;
 392
 393 : (ls) ( node -- )
 394   child BEGIN dup WHILE dup ls-node dup child IF
 395   dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
 396
 397 : ls ( -- )
 398    get-node cr
 399    dup ls-phandle
 400    dup node>path type
 401    (ls)
 402    0 indent !
 403 ;
 404
 405 : show-devs ( {device-specifier}<eol> -- )
 406    skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN   ( str len )
 407    find-node dup 0= ABORT" No such device path" (ls)
 408 ;
 409
 410
 411 VARIABLE interpose-node
 412 2VARIABLE interpose-args
 413 : interpose ( arg len phandle -- )  interpose-node ! interpose-args 2! ;
 414
 415
 416 0 VALUE user-instance-#units
 417 CREATE user-instance-units 4 cells allot
 418
 419 \ Copy the unit information (specified by the user) that we've found during
 420 \ "find-component" into the current instance data structure
 421 : copy-instance-unit  ( -- )
 422    user-instance-#units IF
 423       user-instance-#units my-self instance>#units !
 424       user-instance-units my-self instance>unit1 user-instance-#units cells move
 425       0 to user-instance-#units
 426    THEN
 427 ;
 428
 429
 430 : open-node ( arg len phandle -- ihandle|0 )
 431    current-node @ >r  my-self >r            \ Save current node and instance
 432    set-node create-instance set-my-args
 433    copy-instance-unit
 434    \ Execute "open" method if available, and assume default of
 435    \ success (=TRUE) for nodes without open method:
 436    s" open" get-node find-method IF execute ELSE TRUE THEN
 437    0= IF
 438       my-self destroy-instance 0 to my-self
 439    THEN
 440    my-self                                  ( ihandle|0 )
 441    r> to my-self  r> set-node               \ Restore current node and instance
 442    \ Handle interposition:
 443    interpose-node @ IF
 444       my-self >r to my-self
 445       interpose-args 2@ interpose-node @
 446       interpose-node off recurse
 447       r> to my-self
 448    THEN
 449 ;
 450
 451 : close-node ( ihandle -- )
 452   my-self >r to my-self
 453   s" close" ['] $call-my-method CATCH IF 2drop THEN
 454   my-self destroy-instance r> to my-self ;
 455
 456 : close-dev ( ihandle -- )
 457   my-self >r to my-self
 458   BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
 459   r> to my-self ;
 460
 461 : new-device ( -- )
 462    my-self new-node                     ( parent-ihandle phandle )
 463    node>instance-template @             ( parent-ihandle ihandle )
 464    dup to my-self                       ( parent-ihanlde ihandle )
 465    instance>parent !
 466    get-node my-self instance>node !
 467    max-instance-size my-self instance>size !
 468 ;
 469
 470 : finish-device ( -- )
 471    \ Set unit address to first entry of reg property if it has not been set yet
 472    get-node >space? 0= IF
 473       s" reg" get-node get-property 0= IF
 474          decode-int set-space 2drop
 475       THEN
 476    THEN
 477    finish-node my-parent to my-self
 478 ;
 479
 480 \ Set the instance template as current instance for extending it
 481 \ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there)
 482 : extend-device  ( phandle -- )
 483    my-self >r
 484    dup set-node
 485    node>instance-template @
 486    dup to my-self
 487    r> swap instance>parent !
 488 ;
 489
 490 : split ( str len char -- left len right len )
 491   >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
 492 : generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 493   dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
 494   $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
 495   BEGIN dup WHILE 1- r> swap REPEAT drop ;
 496 : generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 497   0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
 498 : hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 499   base @ >r hex generic-decode-unit r> base ! ;
 500 : hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 501   base @ >r hex generic-encode-unit r> base ! ;
 502
 503 : hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
 504   dup 2 <> IF
 505      hex-decode-unit
 506   ELSE
 507      drop
 508      base @ >r hex
 509      $number IF 0 0 ELSE xlsplit THEN
 510      r> base !
 511   THEN
 512 ;
 513
 514 : hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
 515   dup 2 <> IF
 516      hex-encode-unit
 517   ELSE
 518      drop
 519      base @ >r hex
 520      lxjoin (u.)
 521      r> base !
 522   THEN
 523 ;
 524
 525 : handle-leading-/ ( path len -- path' len' )
 526   dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
 527 : match-name ( name len node -- match? )
 528   over 0= IF 3drop true EXIT THEN
 529   s" name" rot get-property IF 2drop false EXIT THEN
 530   1- string=ci ; \ XXX should use decode-string
 531
 532 0 VALUE #search-unit
 533 CREATE search-unit 4 cells allot
 534
 535 : match-unit ( node -- match? )
 536   \ A node with no space is a wildcard and will always match
 537   dup >space? IF
 538       node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
 539       2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true
 540   ELSE drop true THEN
 541 ;
 542 : match-node ( name len node -- match? )
 543   dup >r match-name r> match-unit and ; \ XXX e3d
 544 : find-kid ( name len -- node|0 )
 545   dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
 546     2drop get-node
 547   ELSE
 548     get-node child >r BEGIN r@ WHILE 2dup r@ match-node
 549     IF 2drop r> EXIT THEN r> peer >r REPEAT
 550     r> 3drop false
 551   THEN ;
 552
 553 : set-search-unit ( unit len -- )
 554    0 to #search-unit
 555    0 to user-instance-#units
 556    dup 0= IF 2drop EXIT THEN
 557    s" #address-cells" get-node get-property THROW
 558    decode-int to #search-unit 2drop
 559    s" decode-unit" get-node $call-static
 560    #search-unit 0 ?DO search-unit i cells + ! LOOP
 561 ;
 562
 563 : resolve-relatives ( path len -- path' len' )
 564   \ handle ..
 565   2dup 2 = swap s" .." comp 0= and IF
 566     get-node parent ?dup IF
 567       set-node drop -1
 568     ELSE
 569       s" Already in root node." type
 570     THEN
 571   THEN
 572   \ handle .
 573   2dup 1 = swap c@ [CHAR] . = and IF
 574     drop -1
 575   THEN
 576 ;
 577
 578 \ XXX This is an old hack that allows wildcard nodes to work
 579 \     by not having a #address-cells in the parent and no
 580 \     decode unit. This should be removed.
 581 \     (It appears to be still used on js2x)
 582 : set-instance-unit  ( unitaddr len -- )
 583    dup 0= IF 2drop  0 to user-instance-#units  EXIT THEN
 584    2dup 0 -rot bounds ?DO
 585       i c@ [char] , = IF 1+ THEN      \ Count the commas
 586    LOOP
 587    1+ dup to user-instance-#units
 588    hex-decode-unit
 589    user-instance-#units 0 ?DO
 590       user-instance-units i cells + !
 591    LOOP
 592 ;
 593
 594 : split-component  ( path. -- path'. args. name. unit. )
 595    [char] / split 2swap     ( path'. component. )
 596    [char] : split 2swap     ( path'. args. name@unit. )
 597    [char] @ split           ( path'. args. name. unit. )
 598 ;
 599
 600 : find-component  ( path len -- path' len' args len node|0 )
 601    debug-find-component? IF
 602       ." find-component for " 2dup type cr
 603    THEN
 604    split-component           ( path'. args. name. unit. )
 605    debug-find-component? IF
 606       ." -> unit  =" 2dup type cr
 607       ." -> stack =" .s cr
 608    THEN
 609    ['] set-search-unit CATCH IF
 610       \ XXX: See comment in set-instance-unit
 611       ." WARNING: Obsolete old wildcard hack " .s cr
 612       set-instance-unit
 613    THEN
 614    resolve-relatives find-kid        ( path' len' args len node|0 )
 615
 616    \ If resolve returned a wildcard node, and we haven't hit
 617    \ the above gross hack then copy the unit
 618    dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF
 619      #search-unit dup to user-instance-#units 0 ?DO
 620         search-unit i cells + @ user-instance-units i cells + !
 621      LOOP
 622    THEN THEN
 623
 624    \ XXX This can go away with the old wildcard hack
 625    dup IF dup >space? user-instance-#units 0 > AND IF
 626       \ User supplied a unit value, but node also has different physical unit
 627       cr ." find-component with unit mismatch!" .s cr
 628       drop 0
 629    THEN THEN
 630 ;
 631
 632 : .find-node ( path len -- phandle|0 )
 633   current-node @ >r
 634   handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
 635   BEGIN dup WHILE \ handle one component:
 636   find-component ( path len args len node ) dup 0= IF
 637   3drop 2drop r> set-node 0 EXIT THEN
 638   set-node 2drop REPEAT 2drop
 639   get-node r> set-node ;
 640 ' .find-node to find-node
 641 : find-node ( path len -- phandle|0 ) de-alias find-node ;
 642
 643 : delete-node ( phandle -- )
 644    dup node>instance-template @ max-instance-size free-mem
 645    dup node>parent @ node>child @ ( phandle 1st peer )
 646    2dup = IF
 647      node>peer @ swap node>parent @ node>child !
 648      EXIT
 649    THEN
 650    dup node>peer @
 651    BEGIN
 652       2 pick 2dup <>
 653    WHILE
 654       drop
 655       nip dup node>peer @
 656       dup 0= IF 2drop drop unloop EXIT THEN
 657    REPEAT
 658    drop
 659    node>peer @  swap node>peer !
 660    drop
 661 ;
 662
 663 : open-dev ( path len -- ihandle|0 )
 664    0 to user-instance-#units
 665    de-alias current-node @ >r
 666    handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
 667    my-self >r
 668    0 to my-self
 669    0 0 >r >r
 670    BEGIN
 671       dup
 672    WHILE \ handle one component:
 673      ( arg len ) r> r> get-node open-node to my-self
 674      find-component ( path len args len node ) dup 0= IF
 675         3drop 2drop my-self close-dev
 676         r> to my-self
 677         r> set-node
 678         0 EXIT
 679      THEN
 680      set-node
 681      >r >r
 682   REPEAT
 683   2drop
 684   \ open final node
 685   r> r> get-node open-node to my-self
 686   my-self r> to my-self r> set-node
 687 ;
 688
 689 : select-dev  open-dev dup to my-self ihandle>phandle set-node ;
 690 : unselect-dev  my-self close-dev  0 to my-self  device-end ;
 691
 692 : find-device ( str len -- ) \ set as active node
 693   find-node dup 0= ABORT" No such device path" set-node ;
 694 : dev  parse-word find-device ;
 695
 696 : (lsprop) ( node --)
 697    dup cr $indent indent @ type ."     node: " node>qname type
 698    false +indent (.properties) cr -indent
 699 ;
 700 : (show-children) ( node -- )
 701    child BEGIN
 702       dup
 703    WHILE
 704       dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
 705    REPEAT
 706    drop
 707 ;
 708 : lsprop ( {device-specifier}<eol> -- )
 709    skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN
 710    find-device get-node dup dup
 711    cr ." node: " node>path type (.properties) cr (show-children)
 712    0 indent !
 713 ;
 714
 715
 716 \ node>path does not allot the memory, since it is internally only used
 717 \ for typing.
 718 \ The external variant needs to allot memory !
 719
 720 : (node>path) node>path ;
 721
 722 : node>path ( phandle -- str len )
 723    node>path dup allot
 724 ;
 725
 726 \ Support for support packages.
 727
 728 \ The /packages node.
 729 0 VALUE packages
 730
 731 \ Find a support package (or arbitrary nodes when name is absolute)
 732 : find-package  ( name len -- false | phandle true )
 733    dup 0 <= IF
 734       2drop FALSE EXIT
 735    THEN
 736    \ According to IEEE 1275 Proposal 215 (Extensible Client Services Package),
 737    \ the find-package method can be used to get the phandle of arbitrary nodes
 738    \ (i.e. not only support packages) when the name starts with a slash.
 739    \ Some FCODE programs depend on this behavior so let's support this, too!
 740    over c@ [char] / = IF
 741       find-node dup IF TRUE THEN EXIT
 742    THEN
 743    \ Ok, let's look for support packages instead. We can't use the standard
 744    \ find-node stuff, as we are required to find the newest (i.e., last in our
 745    \ tree) matching package, not just any.
 746     0 >r packages child
 747     BEGIN
 748        dup
 749     WHILE
 750        dup >r node>name 2over string=ci r> swap IF
 751           r> drop dup >r
 752        THEN
 753        peer
 754     REPEAT
 755     3drop
 756     r> dup IF true THEN
 757 ;
 758
 759 : open-package ( arg len phandle -- ihandle | 0 )  open-node ;
 760 : close-package ( ihandle -- )  close-node ;
 761 : $open-package ( arg len name len -- ihandle | 0 )
 762   find-package IF open-package ELSE 2drop false THEN ;
 763
 764
 765 \ device tree translate-address
 766 #include <translate.fs>