\ *****************************************************************************
\ * 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
\ ****************************************************************************/
\ Properties 5.3.5
\ Words on the property list for a node are actually executable words,
\ that return the address and length of the property's data. Special
\ nodes like /options can have their properties use specialized code to
\ dynamically generate their data; most nodes just use a 2CONSTANT.
\ Put the type as byte before the property
\ { int = 1, bytes = 2, string = 3 }
\ This is used by .properties for pretty print
\ Flag for type encoding, encode-* resets, set-property set the flag
true value encode-first?
: decode-int over >r 4 /string r> 4c@ swap 2swap swap bljoin ;
: decode-64 decode-int -rot decode-int -rot 2swap swap lxjoin ;
: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len )
dup 0= IF 2dup EXIT THEN \ string properties with zero length
over BEGIN dup c@ 0= IF 1+ -rot swap 2 pick over - rot over - -rot 1-
EXIT THEN 1+ AGAIN ;
\ Remove a word from a wordlist.
: (prune) ( name len head -- )
dup >r (find) ?dup IF r> BEGIN dup @ WHILE 2dup @ = IF
>r @ r> ! EXIT THEN @ REPEAT 2drop ELSE r> drop THEN ;
: prune ( name len -- ) last (prune) ;
: set-property ( data dlen name nlen phandle -- )
true to encode-first?
get-current >r node>properties @ set-current
2dup prune $2CONSTANT r> set-current ;
: delete-property ( name nlen -- )
get-node get-current >r node>properties @ set-current
prune r> set-current ;
: property ( data dlen name nlen -- ) get-node set-property ;
: get-property ( str len phandle -- true | data dlen false )
?dup 0= IF cr cr cr ." get-property for " type ." on zero phandle"
cr cr true EXIT THEN
node>properties @ voc-find dup IF link> execute false ELSE drop true THEN ;
: get-package-property ( str len phandle -- true | data dlen false )
get-property ;
: get-my-property ( str len -- true | data dlen false )
my-self ihandle>phandle get-property ;
: get-parent-property ( str len -- true | data dlen false )
my-parent ihandle>phandle get-property ;
: get-inherited-property ( str len -- true | data dlen false )
my-self ihandle>phandle
BEGIN
3dup get-property 0= IF
\ Property found
rot drop rot drop rot drop false EXIT
THEN
parent dup 0= IF
\ Root node has been reached, but property has not been found
3drop true EXIT
THEN
AGAIN
;
\ Print out properties.
20 CONSTANT indent-prop
: .prop-int ( str len -- )
space
400 min 0
?DO
i over + dup ( str act-addr act-addr )
c@ 2 0.r 1+ dup c@ 2 0.r 1+ dup c@ 2 0.r 1+ c@ 2 0.r ( str )
i c and c = IF \ check for multipleof 16 bytes
cr indent @ indent-prop + 1+ 0 \ linefeed + indent
DO
space \ print spaces
LOOP
ELSE
space space \ print two spaces
THEN
4 +LOOP
drop
;
: .prop-bytes ( str len -- )
2dup -4 and .prop-int ( str len )
dup 3 and dup IF ( str len len%4 )
>r -4 and + r> ( str' len%4 )
bounds ( str' str'+len%4 )
DO
i c@ 2 0.r \ Print last 3 bytes
LOOP
ELSE
3drop
THEN
;
: .prop-string ( str len )
2dup space type
cr indent @ indent-prop + 0 DO space LOOP \ Linefeed
.prop-bytes
;
: .propbytes ( xt -- )
execute dup
IF
over cell- @ execute
ELSE
2drop
THEN
;
: .property ( lfa -- )
cr indent @ 0
?DO
space
LOOP
link> dup >name name>string 2dup type nip ( len )
indent-prop swap - ( xt 20-len )
dup 0< IF drop 0 THEN 0 ( xt number-of-space 0 )
?DO
space
LOOP
.propbytes
;
: (.properties) ( phandle -- )
node>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ;
: .properties ( -- )
get-node (.properties) ;
: next-property ( str len phandle -- false | str' len' true )
?dup 0= IF device-tree @ THEN \ XXX: is this line required?
node>properties @
>r 2dup 0= swap 0= or IF 2drop r> cell+ ELSE r> voc-find THEN
@ dup IF link>name name>string true THEN ;
\ encode-* words and all helpers
\ Start a encoded property string
: encode-start ( -- prop 0 )
['] .prop-int compile,
false to encode-first?
here 0
;
: encode-int ( val -- prop prop-len )
encode-first? IF
['] .prop-int compile, \ Execution token for print
false to encode-first?
THEN
here swap lbsplit c, c, c, c, /l
;
: encode-bytes ( str len -- prop-addr prop-len )
encode-first? IF
['] .prop-bytes compile, \ Execution token for print
false to encode-first?
THEN
here over 2dup 2>r allot swap move 2r>
;
: encode-string ( str len -- prop-addr prop-len )
encode-first? IF
['] .prop-string compile, \ Execution token for print
false to encode-first?
THEN
encode-bytes 0 c, char+
;
: encode+ ( prop1-addr prop1-len prop2-addr prop2-len -- prop-addr prop-len )
nip + ;
: encode-int+ encode-int encode+ ;
: encode-64 xlsplit encode-int rot encode-int+ ;
: encode-64+ encode-64 encode+ ;
\ Helpers for common nodes. Should perhaps remove "compatible", as it's
\ not typically a single string.
: device-name encode-string s" name" property ;
: device-type encode-string s" device_type" property ;
: model encode-string s" model" property ;
: compatible encode-string s" compatible" property ;