\ *****************************************************************************
\ * 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 lenght
   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 ;