openbios/forth/admin/devices.fs

\ tag: device tree administration
\ 
\ this code implements IEEE 1275-1994 
\ 
\ Copyright (C) 2003 Samuel Rydh
\ Copyright (C) 2003-2006 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 


\ 7.4.11.1 Device alias

: devalias    ( "{alias-name}< >{device-specifier}<cr>" -- )
  ;
  
: nvalias    ( "alias-name< >device-specifier<cr>" -- )
  ;
  
: $nvalias    ( name-str name-len dev-str dev-len -- )
  ;

: nvunalias    ( "alias-name< >" -- )
  ;
  
: $nvunalias    ( name-str name-len -- )
  ;


\ 7.4.11.2 Device tree browsing

: dev    ( "<spaces>device-specifier" -- )
  bl parse
  find-device
;

: cd
  dev
;
  
\ find-device    ( dev-str dev-len -- )
\ implemented in pathres.fs

: device-end    ( -- )
  0 active-package!
  ;

: unselect-dev ( -- )
  device-end
;
  
: ?active-package ( -- phandle )
  active-package dup 0= abort" no active device"
;

\ -------------------------------------------------------
\  path handling
\ -------------------------------------------------------

\ used if parent lacks an encode-unit method
: def-encode-unit ( unitaddr ... )
    pocket tohexstr
;

: get-encode-unit-xt ( phandle.parent -- xt )
  >dn.parent @
  " encode-unit" rot find-method
  0= if ['] def-encode-unit then
;

: get-nodename ( phandle -- str len )
  " name" rot get-package-property if " <noname>" else 1- then  
;

\ helper, return the node name in the format 'cpus@addr'
: pnodename ( phandle -- str len )
  dup get-nodename rot
  dup " reg" rot get-package-property if drop exit then rot

  \ set active-package and clear my-self (decode-phys needs this)
  my-self >r 0 to my-self
  active-package >r
  dup active-package!

  ( name len prop len phandle )
  get-encode-unit-xt

  ( name len prop len xt )
  depth >r >r
  decode-phys r> execute
  r> -rot >r >r depth! 3drop

  ( name len R: len str )
  r> r> " @"
  here 20 +              \ abuse dictionary for temporary storage
  tmpstrcat >r
  2swap r> tmpstrcat drop
  pocket tmpstrcpy drop
  
  r> active-package!
  r> to my-self
;

: inodename ( ihandle -- str len )
  my-self over to my-self >r
  ihandle>phandle get-nodename
  
  \ nonzero unit number?
  false >r
  depth >r my-unit r> 1+
  begin depth over > while
    swap 0<> if r> drop true >r then
  repeat
  drop

  \ if not... check for presence of "reg" property
  r> ?dup 0= if
    " reg" my-self ihandle>phandle get-package-property
    if false else 2drop true then
  then
  
  ( name len print-unit-flag )
  if
    my-self ihandle>phandle get-encode-unit-xt

    ( name len xt )
    depth >r >r
    my-unit r> execute
    r> -rot >r >r depth! drop
    r> r>
    ( name len str len )
    here 20 + tmpstrcpy 
    " @" rot tmpstrcat drop
    2swap pocket tmpstrcat drop
  then

  \ add :arguments
  my-args dup if
    " :" pocket tmpstrcat drop
    2swap pocket tmpstrcat drop
  else
    2drop
  then
  
  r> to my-self
;

\ helper, also used by client interface (package-to-path)
: get-package-path ( phandle -- str len )
  ?dup 0= if 0 0 then

  dup >dn.parent @ 0= if drop " /" exit then
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >dn.parent @ dup >r while
    ( path len tempbuf phandle R: phandle.parent )
    pnodename rot tmpstrcat
    " /" rot tmpstrcat
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

\ used by client interface (instance-to-path)
: get-instance-path ( ihandle -- str len )
  ?dup 0= if 0 0 then

  dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
    
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >in.my-parent @ dup >r while
    ( path len tempbuf ihandle R: ihandle.parent )
    dup >in.interposed @ 0= if
      inodename rot tmpstrcat
      " /" rot tmpstrcat
    else
      drop
    then
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

\ used by client interface (instance-to-interposed-path)
: get-instance-interposed-path ( ihandle -- str len )
  ?dup 0= if 0 0 then

  dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
    
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >in.my-parent @ dup >r while
    ( path len tempbuf ihandle R: ihandle.parent )
    dup >r inodename rot tmpstrcat
    r> >in.interposed @ if " /%" else " /" then
    rot tmpstrcat
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

: pwd    ( -- )
  ?active-package get-package-path type
;
  
: ls    ( -- )
  cr
  ?active-package >dn.child @
  begin dup while
    dup u. dup pnodename type cr
    >dn.peer @
  repeat
  drop
;
  

\ -------------------------------------------
\  property printing
\ -------------------------------------------

: .p-string? ( data len -- true | data len false )
  \ no trailing zero?
  2dup + 1- c@ if 0 exit then

  swap >r 0 
  \ count zeros and detect unprintable characters?
  over 1- begin 1- dup 0>= while
    dup r@ + c@
    ( len zerocnt n ch )

    ?dup 0= if
      swap 1+ swap
    else
      dup 1b <= swap 80 >= or
      if 2drop r> swap 0 exit then
    then
  repeat drop r> -rot
  ( data len zerocnt )
  
  \ simple string
  0= if
    ascii " emit 1- type ascii " emit true exit
  then

  \ make sure there are no double zeros (except possibly at the end)
  2dup over + swap
  ( data len end ptr )
  begin 2dup <> while
    dup c@ 0= if
      2dup 1+ <> if 2drop false exit then
    then
    dup cstrlen 1+ +
  repeat
  2drop
  
  ." {"
  0 -rot over + swap
  \ multistring ( cnt end ptr )
  begin 2dup <> while
    rot dup if ." , " then 1+ -rot
    dup cstrlen 2dup
    ascii " emit type ascii " emit
    1+ +
  repeat
  ." }"
  3drop true
;

: .p-int? ( data len -- 1 | data len 0 )
  dup 4 <> if false exit then
  decode-int -rot 2drop true swap
  dup 0>= if . exit then
  dup -ff < if u. exit then
  .
;

: .p-bytes? ( data len -- 1 | data len 0 )
  ." -- " dup . ." : "
  swap >r 0
  begin 2dup > while
    dup r@ + c@
    ( len n ch )

    pocket tohexstr dup 2 <> if ." 0" then type ."  "
    1+
  repeat 
  2drop r> drop 1
;

\ this function tries to heuristically determine the data format
: (.property) ( data len -- )
  dup 0= if 2drop ." <empty>" exit then

  .p-string? if exit then
  .p-int? if exit then
  .p-bytes? if exit then
  2drop ." <unimplemented type>"
;

: .properties    ( -- )
  ?active-package dup >r if
    0 0
    begin
      r@ next-property
    while
      cr 2dup dup -rot type
      begin ."  " 1+ dup d# 26 >= until drop
      2dup active-package get-package-property drop (.property)
    repeat
  then
  r> drop
  cr
;


\ 7.4.11    Device tree

: print-dev ( phandle -- phandle )
  dup u. 
  dup get-package-path type
  dup " device_type" rot get-package-property if
    cr 
  else
    ."  (" decode-string type ." )" cr 2drop
  then
  ;

: show-sub-devs ( subtree-phandle -- )
  print-dev
  >dn.child @
    begin dup while
      dup recurse
      >dn.peer @
    repeat
    drop
  ;

: show-all-devs    ( -- )
  active-package
  cr " /" find-device
  ?active-package show-sub-devs
  active-package!
  ;


: show-devs    ( "{device-specifier}<cr>" -- )
  active-package
  cr " /" find-device
  linefeed parse find-device
  ?active-package show-sub-devs
  active-package!
  ;



\ 7.4.11.3 Device probing

: probe-all    ( -- )
  ;