\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: finddev.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)finddev.fth 2.43 06/02/16
copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
: unit-bounds ( -- end-adr start-adr ) unit# '#adr-cells @ /n* bounds ;
: "name" ( -- adr,len ) " name" ; \ Space savings
\ True if "name$" matches the node's name
: name-match? ( name$ -- name$ flag )
"name" get-property if ( name$ )
1- \ Omit null byte ( name$ adr' len' )
2over 2over $= if ( name$ adr' len' )
2drop true ( name$ true )
\ Omit the manufacturer name and test again
ascii , left-parse-string 2drop 2over $=
\ True if "unit-adr,space" matches the node's unit number
: unit-match? ( -- flag )
false ( flag ) \ No "reg" property
else ( phys.lo .. phys.hi )
unit-bounds ?do ( unit-adr,len flag )
-rot decode-int ( flag unit-adr,len' n )
i @ = 3 roll and ( unit-adr,len' flag' )
/n +loop ( unit-adr,len' flag )
\ True if the node has no unit number and "name$" matches the node's name
: wildcard-match? ( name$ acf -- name$ acf flag )
name-match? 0= if r> false exit then
get-unit 0= if nip nip r> false exit then ( name$ )
dup 0= unit#-valid? 0= and if r> false exit then
: exact-match? ( name$ acf -- name$ acf flag )
dup if ( name$ ) \ Name present
name-match? 0= if r> false exit then
unit#-valid? if ( name$ ) \ Unit present
unit-match? 0= if r> false exit then
: (package-execute) ( str,len package -- ?? )
setup-method$ (search-wordlist) if
\ 1) Search direct children for an exact match
\ 2) Search direct children for a wildcard match
\ 3) Select each child node in turn and (recursively) repeat steps
: (find-node) ( unit$ name$ -- unit$ name$ )
\ If the node has no children, then there is no point in searching it,
\ and it doesn't matter if it has no decode-unit method
first-child 0= if exit then
\ Omit unit match test if no unit string or this is a support node
support-node? @ 0= pop-device unit#-valid? and if
2over ['] (decode-unit) catch if
then ( unit$ name$ phys.lo .. phys.hi )
\ We can't use unit-bounds here
unit# #adr-cells /n* bounds ?do i ! /n +loop ( unit$ name$ )
\ (search-level) will throw "found" to (find-device) if it succeeds
['] exact-match? (search-level) drop ( unit$ name$ )
['] wildcard-match? (search-level) drop ( unit$ name$ )
: (find-child-node) ( unit$ name$ -- unit$ name$ ) recursive
first-child begin while (find-node) (find-child-node) next-child repeat
: (find-device) ( str -- )
\ If a search path is present, find the indicated subdirectory
\ Split the remaining string at the first backslash, if there is one
ascii / left-parse-string ( str component-str )
ascii : left-parse-string ( str args-str name.unit$ )
\ Arguments only apply to "open", so discard them when searching
2swap 2drop ( rem$ name.unit$ )
ascii @ left-parse-string ( rem$ unit$ name$ )
2 pick is unit#-valid? ( rem$ unit$ name$ )
['] (find-node) catch 0= if ( rem$ unit$ name$ )
['] (find-child-node) invert-signal ( rem$ unit$ name$ )
then ( rem$ unit$ name$ )
: not-alias? ( str -- expansion$ false | true )
['] aliases (search-wordlist) if execute false else true then
\ Expands devaliases optionally overwriting the default argument
\ to the rightmost component of the expanded pathname
: expand-alias ( devspec$ -- pathname$ flag )
\ Extract the part of the pathname that can be an alias
2dup ascii / split-before ( devspec$ tail$ head$ )
ascii : split-before ( devspec$ tail$ arg$ name$ )
\ If the device-specifier is not an alias, return it unmodified.
not-alias? if ( devspec$ tail$ arg$ )
2drop 2drop false exit ( devspec$ )
then ( devspec$ tail$ arg$ expansion$ )
\ The device-specifier is an alias.
\ If the aliased component of the device-specifier had explicit
\ arguments, use them to override any arguments that were included
\ in the alias expansion.
2 pick if ( devspec$ tail$ arg$ expansion$ )
ascii / split-after ( devspec$ tail$ arg$ alias-tail$ alias-head$ )
alias-buf place ( devspec$ tail$ arg$ alias-tail$ )
ascii : split-before ( devspec$ tail$ arg$ $deadargs $alias-tail$' )
alias-buf $cat ( devspec$ tail$ arg$ $deadargs )
2drop alias-buf $cat ( devspec$ tail$ )
else ( devspec$ tail$ arg$ expansion$ )
\ alias name does not have args
alias-buf place ( devspec$ tail$ arg$ )
\ Append the tail of the device specifier to the expanded alias
alias-buf $cat ( devspec$ )
alias-buf count true ( pathname$ true )
: aliased? ( name-str -- name-str false | alias-expansion-str true )
\ The empty string is not an alias
dup 0= if false exit then ( str )
\ A pathname beginning with a slash is not an alias
over c@ ascii / = if false exit then ( str )
: ?expand-alias ( name-str -- name-str | alias-expansion-str )
: context-voc? ( voc acf -- voc acf false | ??) over context-voc = throw false ;
: device-context? ( -- device-node? )
context-voc ['] root-node = if true exit then
current-voc >r also context-voc root-node ( voc )
['] context-voc? ['] (search-preorder) catch nip nip ( device-node?)
r> set-current previous ( device-node?)
\ rather than move a whole load of code around it is easier to patch
\ the device-end routine in devtree.fth
patch device-context? false device-end
: ?not-found ( flag -- ) if not-found throw then ;
: noalias-find-device ( str -- )
?dup 0= ?not-found ( str$ )
\ The path starts at the root directory if the first character is "/";
\ otherwise it starts at the current directory
over c@ ascii / = if 1 /string ['] root-node push-device then
current-device null = ?not-found
device-context? 0= ?not-found
: aliased-find-device ( str -- ) ?expand-alias noalias-find-device ;
action: 3drop ; \ No "store" method
action: ; \ Just return the address
action: drop ; \ Decode method is null because string is already right
action: drop ; \ Encode method is null too
: $devalias ( name-str expansion-str -- )
strip-blanks 2swap strip-blanks
\ Create the alias w/o not unique warning.
warning @ >r warning off $create r> warning !
: locate-device ( adr len -- true | phandle false )
['] aliased-find-device catch if
: noa-find-device ( adr len -- )
['] noalias-find-device catch case
not-found of r> push-device not-found throw endof
( default ) r> push-device throw
: find-device ( adr len -- ) ?expand-alias noa-find-device ;
: $parent-execute ( adr len -- )
current-device >r pop-device r@ >parent (package-execute) r> push-device
: delete-device ( phandle -- deleted? )
\ Save the current device
dup >parent push-device ( phandle )
'child begin ( phandle &phandle' )
2dup link@ = if ( phandle &phandle' )
true true ( phandle &phandle' true true )
else ( phandle &phandle' )
link@ dup null = if ( phandle null )
drop false true ( phandle false true )
else ( phandle phandle' )
push-device 'peer ( phandle &phandle" )
false ( phandle &phandle" done? )
then ( phandle &phandle" false )
then ( phandle &phandle' true true )
\ OR ( phandle false true )
\ OR ( phandle &phandle" false )
until if ( phandle &prev-phandle )
swap push-device 'peer ( &prev-phandle &next-phandle )
link@ swap link! true ( ok )
\ Restore the current device
: $delete-device ( path$ -- deleted? )
locate-device if false exit then delete-device ( deleted? )
projects / OpenSPARC-T2-SAM / blob