summaryrefslogtreecommitdiffstats
path: root/qemu/roms/SLOF/slof/fs/node.fs
diff options
context:
space:
mode:
authorRajithaY <rajithax.yerrumsetty@intel.com>2017-04-25 03:31:15 -0700
committerRajitha Yerrumchetty <rajithax.yerrumsetty@intel.com>2017-05-22 06:48:08 +0000
commitbb756eebdac6fd24e8919e2c43f7d2c8c4091f59 (patch)
treeca11e03542edf2d8f631efeca5e1626d211107e3 /qemu/roms/SLOF/slof/fs/node.fs
parenta14b48d18a9ed03ec191cf16b162206998a895ce (diff)
Adding qemu as a submodule of KVMFORNFV
This Patch includes the changes to add qemu as a submodule to kvmfornfv repo and make use of the updated latest qemu for the execution of all testcase Change-Id: I1280af507a857675c7f81d30c95255635667bdd7 Signed-off-by:RajithaY<rajithax.yerrumsetty@intel.com>
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/node.fs')
-rw-r--r--qemu/roms/SLOF/slof/fs/node.fs766
1 files changed, 0 insertions, 766 deletions
diff --git a/qemu/roms/SLOF/slof/fs/node.fs b/qemu/roms/SLOF/slof/fs/node.fs
deleted file mode 100644
index 22bf77b6f..000000000
--- a/qemu/roms/SLOF/slof/fs/node.fs
+++ /dev/null
@@ -1,766 +0,0 @@
-\ *****************************************************************************
-\ * Copyright (c) 2004, 2008 IBM Corporation
-\ * All rights reserved.
-\ * This program and the accompanying materials
-\ * are made available under the terms of the BSD License
-\ * which accompanies this distribution, and is available at
-\ * http://www.opensource.org/licenses/bsd-license.php
-\ *
-\ * Contributors:
-\ * IBM Corporation - initial implementation
-\ ****************************************************************************/
-
-
-\ Device nodes.
-
-false VALUE debug-find-component?
-
-VARIABLE device-tree
-VARIABLE current-node
-: get-node current-node @ dup 0= ABORT" No active device tree node" ;
-
-STRUCT
- cell FIELD node>peer
- cell FIELD node>parent
- cell FIELD node>child
- cell FIELD node>properties
- cell FIELD node>words
- cell FIELD node>instance-template
- cell FIELD node>instance-size
- cell FIELD node>space?
- cell FIELD node>space
- cell FIELD node>addr1
- cell FIELD node>addr2
- cell FIELD node>addr3
-END-STRUCT
-
-: find-method ( str len phandle -- false | xt true )
- node>words @ voc-find dup IF link> true THEN ;
-
-\ Instances.
-#include "instance.fs"
-
-: create-node ( parent -- new )
- max-instance-size alloc-mem ( parent instance-mem )
- dup max-instance-size erase >r ( parent R: instance-mem )
- align wordlist >r wordlist >r ( parent R: instance-mem wl wl )
- here ( parent new R: instance-mem wl wl )
- 0 , swap , 0 , \ Set node>peer, node>parent & node>child
- r> , r> , \ Set node>properties & node>words to wl
- r> , /instance-header , \ Set instance-template & instance-size
- FALSE , 0 , \ Set node>space? and node>space
- 0 , 0 , 0 , \ Set node>addr*
-;
-
-: peer node>peer @ ;
-: parent node>parent @ ;
-: child node>child @ ;
-: peer dup IF peer ELSE drop device-tree @ THEN ;
-
-
-: link ( new head -- ) \ link a new node at the end of a linked list
- BEGIN dup @ WHILE @ REPEAT ! ;
-: link-node ( parent child -- )
- swap dup IF node>child link ELSE drop device-tree ! THEN ;
-
-\ Set a node as active node.
-: set-node ( phandle -- )
- current-node @ IF previous THEN
- dup current-node !
- ?dup IF node>words @ also context ! THEN
- definitions ;
-: get-parent get-node parent ;
-
-
-: new-node ( -- phandle ) \ active node becomes new node's parent;
- \ new node becomes active node
-\ XXX: change to get-node, handle root node creation specially
- current-node @ dup create-node
- tuck link-node dup set-node ;
-
-: finish-node ( -- )
- \ TODO: maybe resize the instance template buffer here (or in finish-device)?
- get-node parent set-node
-;
-
-: device-end ( -- ) 0 set-node ;
-
-\ Properties.
-CREATE $indent 100 allot VARIABLE indent 0 indent !
-#include "property.fs"
-
-\ Unit address.
-: #address-cells s" #address-cells" rot parent get-property
- ABORT" parent doesn't have a #address-cells property!"
- decode-int nip nip
-;
-
-\ my-#address-cells returns the #address-cells property of the parent node.
-\ child-#address-cells returns the #address-cells property of the current node.
-
-\ This is confusing in several ways: Remember that a node's address is always
-\ described in the parent's address space, thus the parent's property is taken
-\ into regard, rather than the own.
-
-\ Also, an address-cell here is always a 32bit cell, no matter whether the
-\ "real" cell size is 32bit or 64bit.
-
-: my-#address-cells ( -- #address-cells )
- get-node #address-cells
-;
-
-: child-#address-cells ( -- #address-cells )
- s" #address-cells" get-node get-property
- ABORT" node doesn't have a #address-cells property!"
- decode-int nip nip
-;
-
-: child-#size-cells ( -- #address-cells )
- s" #size-cells" get-node get-property
- ABORT" node doesn't have a #size-cells property!"
- decode-int nip nip
-;
-
-: encode-phys ( phys.hi ... phys.low -- prop len )
- encode-first? IF encode-start ELSE here 0 THEN
- my-#address-cells 0 ?DO rot encode-int+ LOOP
-;
-
-: encode-child-phys ( phys.hi ... phys.low -- prop len )
- encode-first? IF encode-start ELSE here 0 THEN
- child-#address-cells 0 ?DO rot encode-int+ LOOP
-;
-
-: encode-child-size ( size.hi ... size.low -- prop len )
- encode-first? IF encode-start ELSE here 0 THEN
- child-#size-cells 0 ?DO rot encode-int+ LOOP
-;
-
-: decode-phys
- my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
- my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
-: decode-phys-and-drop
- my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
- my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
-: reg >r encode-phys r> encode-int+ s" reg" property ;
-
-
-: >space node>space @ ;
-: >space? node>space? @ ;
-: >address dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
- dup 2 > IF r@ node>addr2 @ swap THEN
- 1 > IF r@ node>addr1 @ THEN r> drop ;
-: >unit dup >r >address r> >space ;
-
-: (my-phandle) ( -- phandle )
- my-self ?dup IF
- ihandle>phandle
- ELSE
- get-node dup 0= ABORT" no active node"
- THEN
-;
-
-: my-space ( -- phys.hi )
- (my-phandle) >space
-;
-: my-address (my-phandle) >address ;
-
-\ my-unit returns the unit address of the current _instance_ - that means
-\ it returns the same values as my-space and my-address together _or_ it
-\ returns a unit address that has been set manually while opening the node.
-: my-unit
- my-self instance>#units @ IF
- 0 my-self instance>#units @ 1- DO
- my-self instance>unit1 i cells + @
- -1 +LOOP
- ELSE
- my-self ihandle>phandle >unit
- THEN
-;
-
-\ Return lower 64 bit of address
-: my-unit-64 ( -- phys.lo+1|phys.lo )
- my-unit ( phys.lo ... phys.hi )
- (my-phandle) #address-cells ( phys.lo ... phys.hi #ad-cells )
- CASE
- 1 OF EXIT ENDOF
- 2 OF lxjoin EXIT ENDOF
- 3 OF drop lxjoin EXIT ENDOF
- dup OF 2drop lxjoin EXIT ENDOF
- ENDCASE
-;
-
-: set-space get-node dup >r node>space ! true r> node>space? ! ;
-: set-address my-#address-cells 1 ?DO
- get-node node>space i cells + ! LOOP ;
-: set-unit set-space set-address ;
-: set-unit-64 ( phys.lo|phys.hi -- )
- my-#address-cells 2 <> IF
- ." set-unit-64: #address-cells <> 2 " abort
- THEN
- xlsplit set-unit
-;
-
-\ Never ever use this in actual code, only when debugging interactively.
-\ Thank you.
-: set-args ( arg-str len unit-str len -- )
- s" decode-unit" get-parent $call-static set-unit set-my-args
-;
-
-: $cat-unit
- dup parent 0= IF drop EXIT THEN
- dup >space? not IF drop EXIT THEN
- dup >r >unit s" encode-unit" r> parent $call-static
- dup IF
- dup >r here swap move s" @" $cat here r> $cat
- ELSE
- 2drop
- THEN
-;
-
-: $cat-instance-unit
- dup parent 0= IF drop EXIT THEN
- \ No instance unit, use node unit
- dup instance>#units @ 0= IF
- ihandle>phandle $cat-unit
- EXIT
- THEN
- dup >r push-my-self
- ['] my-unit CATCH IF pop-my-self r> drop EXIT THEN
- pop-my-self
- s" encode-unit"
- r> ihandle>phandle parent
- $call-static
- dup IF
- dup >r here swap move s" @" $cat here r> $cat
- ELSE
- 2drop
- THEN
-;
-
-\ Getting basic info about a node.
-: node>name dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
-: node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
-: node>path
- here 0 rot
- BEGIN dup WHILE dup parent REPEAT
- 2drop
- dup 0= IF [char] / c, THEN
- BEGIN
- dup
- WHILE
- [char] / c, node>qname here over allot swap move
- REPEAT
- drop here 2dup - allot over -
-;
-
-: interposed? ( ihandle -- flag )
- \ We cannot actually detect if an instance is interposed; instead, we look
- \ if an instance is part of the "normal" chain that would be opened by
- \ open-dev and friends, if there were no interposition.
- dup instance>parent @ dup 0= IF 2drop false EXIT THEN
- ihandle>phandle swap ihandle>phandle parent <> ;
-
-: instance>qname
- dup >r interposed? IF s" %" ELSE 0 0 THEN
- r@ dup ihandle>phandle node>name
- rot ['] $cat-instance-unit CATCH IF drop THEN
- $cat r> instance>args 2@ swap
- dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN
-;
-
-: instance>qpath \ With interposed nodes.
- here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
- dup 0= IF [char] / c, THEN
- BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
- REPEAT drop here 2dup - allot over - ;
-: instance>path \ Without interposed nodes.
- here 0 rot BEGIN dup WHILE
- dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
- dup 0= IF [char] / c, THEN
- BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
- REPEAT drop here 2dup - allot over - ;
-
-: .node node>path type ;
-: pwd get-node .node ;
-
-: .instance instance>qpath type ;
-: .chain dup instance>parent @ ?dup IF recurse THEN
- cr dup . instance>qname type ;
-
-
-\ Alias helper
-defer find-node
-: set-alias ( alias-name len device-name len -- )
- encode-string
- 2swap s" /aliases" find-node ?dup IF
- set-property
- ELSE
- 4drop
- THEN
-;
-
-: find-alias ( alias-name len -- false | dev-path len )
- s" /aliases" find-node dup IF
- get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
- THEN
-;
-
-: .alias ( alias-name len -- )
- find-alias dup IF type ELSE ." no alias available" THEN ;
-
-: (.print-alias) ( lfa -- )
- link> dup >name name>string
- \ Don't print name property
- 2dup s" name" string=ci IF 2drop drop
- ELSE cr type space ." : " execute type
- THEN ;
-
-: (.list-alias) ( phandle -- )
- node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
-
-: list-alias ( -- )
- s" /aliases" find-node dup IF (.list-alias) THEN ;
-
-\ return next available name for aliasing or
-\ false if more than MAX-ALIAS aliases found
-8 CONSTANT MAX-ALIAS
-1 VALUE alias-ind
-: get-next-alias ( $alias-name -- $next-alias-name|FALSE )
- 2dup find-alias IF
- drop
- 1 TO alias-ind
- BEGIN
- 2dup alias-ind $cathex 2dup find-alias
- WHILE
- drop 2drop
- alias-ind 1 + TO alias-ind
- alias-ind MAX-ALIAS = IF
- 2drop FALSE EXIT
- THEN
- REPEAT
- strdup 2swap 2drop
- THEN
-;
-
-: devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
- parse-word parse-word dup IF set-alias
- ELSE 2drop dup IF .alias
- ELSE 2drop list-alias THEN THEN ;
-
-\ sub-alias does a single iteration of an alias at the beginning od dev path
-\ expression. de-alias will repeat this until all indirect alising is resolved
-: sub-alias ( arg-str arg-len -- arg' len' | false )
- 2dup
- 2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
- ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
- ( a l l p -- R:p | a l -- R:0 )
- find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
- r@ IF
- 2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
- ELSE
- ( a' l' -- R:0 ) r> drop ( a' l' -- )
- THEN
- ELSE
- ( a l -- R:p | -- R:0 ) r> IF 2drop THEN
- false ( 0 -- )
- THEN
-;
-
-: de-alias ( arg-str arg-len -- arg' len' )
- BEGIN
- over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
- WHILE
- 2swap 2drop
- REPEAT
-;
-
-
-\ Display the device tree.
-: +indent ( not-last? -- )
- IF s" | " ELSE s" " THEN $indent indent @ + swap move 4 indent +! ;
-: -indent ( -- ) -4 indent +! ;
-
-: ls-phandle ( node -- ) . ." : " ;
-
-: ls-node ( node -- )
- cr dup ls-phandle
- $indent indent @ type
- dup peer IF ." |-- " ELSE ." +-- " THEN
- node>qname type
-;
-
-: (ls) ( node -- )
- child BEGIN dup WHILE dup ls-node dup child IF
- dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
-
-: ls ( -- )
- get-node cr
- dup ls-phandle
- dup node>path type
- (ls)
- 0 indent !
-;
-
-: show-devs ( {device-specifier}<eol> -- )
- skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN ( str len )
- find-node dup 0= ABORT" No such device path" (ls)
-;
-
-
-VARIABLE interpose-node
-2VARIABLE interpose-args
-: interpose ( arg len phandle -- ) interpose-node ! interpose-args 2! ;
-
-
-0 VALUE user-instance-#units
-CREATE user-instance-units 4 cells allot
-
-\ Copy the unit information (specified by the user) that we've found during
-\ "find-component" into the current instance data structure
-: copy-instance-unit ( -- )
- user-instance-#units IF
- user-instance-#units my-self instance>#units !
- user-instance-units my-self instance>unit1 user-instance-#units cells move
- 0 to user-instance-#units
- THEN
-;
-
-
-: open-node ( arg len phandle -- ihandle|0 )
- current-node @ >r my-self >r \ Save current node and instance
- set-node create-instance set-my-args
- copy-instance-unit
- \ Execute "open" method if available, and assume default of
- \ success (=TRUE) for nodes without open method:
- s" open" get-node find-method IF execute ELSE TRUE THEN
- 0= IF
- my-self destroy-instance 0 to my-self
- THEN
- my-self ( ihandle|0 )
- r> to my-self r> set-node \ Restore current node and instance
- \ Handle interposition:
- interpose-node @ IF
- my-self >r to my-self
- interpose-args 2@ interpose-node @
- interpose-node off recurse
- r> to my-self
- THEN
-;
-
-: close-node ( ihandle -- )
- my-self >r to my-self
- s" close" ['] $call-my-method CATCH IF 2drop THEN
- my-self destroy-instance r> to my-self ;
-
-: close-dev ( ihandle -- )
- my-self >r to my-self
- BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
- r> to my-self ;
-
-: new-device ( -- )
- my-self new-node ( parent-ihandle phandle )
- node>instance-template @ ( parent-ihandle ihandle )
- dup to my-self ( parent-ihanlde ihandle )
- instance>parent !
- get-node my-self instance>node !
- max-instance-size my-self instance>size !
-;
-
-: finish-device ( -- )
- \ Set unit address to first entry of reg property if it has not been set yet
- get-node >space? 0= IF
- s" reg" get-node get-property 0= IF
- decode-int set-space 2drop
- THEN
- THEN
- finish-node my-parent to my-self
-;
-
-\ Set the instance template as current instance for extending it
-\ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there)
-: extend-device ( phandle -- )
- my-self >r
- dup set-node
- node>instance-template @
- dup to my-self
- r> swap instance>parent !
-;
-
-: split ( str len char -- left len right len )
- >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
-: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
- dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
- $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
- BEGIN dup WHILE 1- r> swap REPEAT drop ;
-: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
- 0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
-: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
- base @ >r hex generic-decode-unit r> base ! ;
-: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
- base @ >r hex generic-encode-unit r> base ! ;
-
-: hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
- dup 2 <> IF
- hex-decode-unit
- ELSE
- drop
- base @ >r hex
- $number IF 0 0 ELSE xlsplit THEN
- r> base !
- THEN
-;
-
-: hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
- dup 2 <> IF
- hex-encode-unit
- ELSE
- drop
- base @ >r hex
- lxjoin (u.)
- r> base !
- THEN
-;
-
-: handle-leading-/ ( path len -- path' len' )
- dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
-: match-name ( name len node -- match? )
- over 0= IF 3drop true EXIT THEN
- s" name" rot get-property IF 2drop false EXIT THEN
- 1- string=ci ; \ XXX should use decode-string
-
-0 VALUE #search-unit
-CREATE search-unit 4 cells allot
-
-: match-unit ( node -- match? )
- \ A node with no space is a wildcard and will always match
- dup >space? IF
- node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
- 2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true
- ELSE drop true THEN
-;
-: match-node ( name len node -- match? )
- dup >r match-name r> match-unit and ; \ XXX e3d
-: find-kid ( name len -- node|0 )
- dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
- 2drop get-node
- ELSE
- get-node child >r BEGIN r@ WHILE 2dup r@ match-node
- IF 2drop r> EXIT THEN r> peer >r REPEAT
- r> 3drop false
- THEN ;
-
-: set-search-unit ( unit len -- )
- 0 to #search-unit
- 0 to user-instance-#units
- dup 0= IF 2drop EXIT THEN
- s" #address-cells" get-node get-property THROW
- decode-int to #search-unit 2drop
- s" decode-unit" get-node $call-static
- #search-unit 0 ?DO search-unit i cells + ! LOOP
-;
-
-: resolve-relatives ( path len -- path' len' )
- \ handle ..
- 2dup 2 = swap s" .." comp 0= and IF
- get-node parent ?dup IF
- set-node drop -1
- ELSE
- s" Already in root node." type
- THEN
- THEN
- \ handle .
- 2dup 1 = swap c@ [CHAR] . = and IF
- drop -1
- THEN
-;
-
-\ XXX This is an old hack that allows wildcard nodes to work
-\ by not having a #address-cells in the parent and no
-\ decode unit. This should be removed.
-\ (It appears to be still used on js2x)
-: set-instance-unit ( unitaddr len -- )
- dup 0= IF 2drop 0 to user-instance-#units EXIT THEN
- 2dup 0 -rot bounds ?DO
- i c@ [char] , = IF 1+ THEN \ Count the commas
- LOOP
- 1+ dup to user-instance-#units
- hex-decode-unit
- user-instance-#units 0 ?DO
- user-instance-units i cells + !
- LOOP
-;
-
-: split-component ( path. -- path'. args. name. unit. )
- [char] / split 2swap ( path'. component. )
- [char] : split 2swap ( path'. args. name@unit. )
- [char] @ split ( path'. args. name. unit. )
-;
-
-: find-component ( path len -- path' len' args len node|0 )
- debug-find-component? IF
- ." find-component for " 2dup type cr
- THEN
- split-component ( path'. args. name. unit. )
- debug-find-component? IF
- ." -> unit =" 2dup type cr
- ." -> stack =" .s cr
- THEN
- ['] set-search-unit CATCH IF
- \ XXX: See comment in set-instance-unit
- ." WARNING: Obsolete old wildcard hack " .s cr
- set-instance-unit
- THEN
- resolve-relatives find-kid ( path' len' args len node|0 )
-
- \ If resolve returned a wildcard node, and we haven't hit
- \ the above gross hack then copy the unit
- dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF
- #search-unit dup to user-instance-#units 0 ?DO
- search-unit i cells + @ user-instance-units i cells + !
- LOOP
- THEN THEN
-
- \ XXX This can go away with the old wildcard hack
- dup IF dup >space? user-instance-#units 0 > AND IF
- \ User supplied a unit value, but node also has different physical unit
- cr ." find-component with unit mismatch!" .s cr
- drop 0
- THEN THEN
-;
-
-: .find-node ( path len -- phandle|0 )
- current-node @ >r
- handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
- BEGIN dup WHILE \ handle one component:
- find-component ( path len args len node ) dup 0= IF
- 3drop 2drop r> set-node 0 EXIT THEN
- set-node 2drop REPEAT 2drop
- get-node r> set-node ;
-' .find-node to find-node
-: find-node ( path len -- phandle|0 ) de-alias find-node ;
-
-: delete-node ( phandle -- )
- dup node>instance-template @ max-instance-size free-mem
- dup node>parent @ node>child @ ( phandle 1st peer )
- 2dup = IF
- node>peer @ swap node>parent @ node>child !
- EXIT
- THEN
- dup node>peer @
- BEGIN
- 2 pick 2dup <>
- WHILE
- drop
- nip dup node>peer @
- dup 0= IF 2drop drop unloop EXIT THEN
- REPEAT
- drop
- node>peer @ swap node>peer !
- drop
-;
-
-: open-dev ( path len -- ihandle|0 )
- 0 to user-instance-#units
- de-alias current-node @ >r
- handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
- my-self >r
- 0 to my-self
- 0 0 >r >r
- BEGIN
- dup
- WHILE \ handle one component:
- ( arg len ) r> r> get-node open-node to my-self
- find-component ( path len args len node ) dup 0= IF
- 3drop 2drop my-self close-dev
- r> to my-self
- r> set-node
- 0 EXIT
- THEN
- set-node
- >r >r
- REPEAT
- 2drop
- \ open final node
- r> r> get-node open-node to my-self
- my-self r> to my-self r> set-node
-;
-
-: select-dev open-dev dup to my-self ihandle>phandle set-node ;
-: unselect-dev my-self close-dev 0 to my-self device-end ;
-
-: find-device ( str len -- ) \ set as active node
- find-node dup 0= ABORT" No such device path" set-node ;
-: dev parse-word find-device ;
-
-: (lsprop) ( node --)
- dup cr $indent indent @ type ." node: " node>qname type
- false +indent (.properties) cr -indent
-;
-: (show-children) ( node -- )
- child BEGIN
- dup
- WHILE
- dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
- REPEAT
- drop
-;
-: lsprop ( {device-specifier}<eol> -- )
- skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN
- find-device get-node dup dup
- cr ." node: " node>path type (.properties) cr (show-children)
- 0 indent !
-;
-
-
-\ node>path does not allot the memory, since it is internally only used
-\ for typing.
-\ The external variant needs to allot memory !
-
-: (node>path) node>path ;
-
-: node>path ( phandle -- str len )
- node>path dup allot
-;
-
-\ Support for support packages.
-
-\ The /packages node.
-0 VALUE packages
-
-\ Find a support package (or arbitrary nodes when name is absolute)
-: find-package ( name len -- false | phandle true )
- dup 0 <= IF
- 2drop FALSE EXIT
- THEN
- \ According to IEEE 1275 Proposal 215 (Extensible Client Services Package),
- \ the find-package method can be used to get the phandle of arbitrary nodes
- \ (i.e. not only support packages) when the name starts with a slash.
- \ Some FCODE programs depend on this behavior so let's support this, too!
- over c@ [char] / = IF
- find-node dup IF TRUE THEN EXIT
- THEN
- \ Ok, let's look for support packages instead. We can't use the standard
- \ find-node stuff, as we are required to find the newest (i.e., last in our
- \ tree) matching package, not just any.
- 0 >r packages child
- BEGIN
- dup
- WHILE
- dup >r node>name 2over string=ci r> swap IF
- r> drop dup >r
- THEN
- peer
- REPEAT
- 3drop
- r> dup IF true THEN
-;
-
-: open-package ( arg len phandle -- ihandle | 0 ) open-node ;
-: close-package ( ihandle -- ) close-node ;
-: $open-package ( arg len name len -- ihandle | 0 )
- find-package IF open-package ELSE 2drop false THEN ;
-
-
-\ device tree translate-address
-#include <translate.fs>