forth/device/package.fs

\ tag: Package access.
\ 
\ this code implements IEEE 1275-1994 ch. 5.3.4
\ 
\ Copyright (C) 2003 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

\ variable last-package 0 last-package !
\ 0 value active-package
: current-device active-package ;
  
\ 
\ 5.3.4.1 Open/Close packages (part 1)
\ 

\ 0 value my-self ( -- ihandle )
: ?my-self
  my-self dup 0= abort" no current instance."
  ;

: my-parent ( -- ihandle )
  ?my-self >in.my-parent @
;

: ihandle>non-interposed-phandle ( ihandle -- phandle )
  begin dup >in.interposed @ while
    >in.my-parent @
  repeat
  >in.device-node @
;

: instance-to-package ( ihandle -- phandle )
  dup if ihandle>non-interposed-phandle then
;

: ihandle>phandle ( ihandle -- phandle )
  >in.device-node @
;


\ next-property
\ defined in property.c

: peer ( phandle -- phandle.sibling )
  ?dup if
    >dn.peer @
  else
    device-tree @
  then
;

: child ( phandle.parent -- phandle.child )
  \ Assume phandle == 0 indicates root node (not documented but similar
  \ behaviour to "peer"). Used by some versions of Solaris (e.g. 9).
  ?dup if else device-tree @ then

  >dn.child @
;
  

\ 
\ 5.3.4.2 Call methods from other packages
\ 

: find-method ( method-str method-len phandle -- false | xt true )
  \ should we search the private wordlist too? I don't think so...
  >dn.methods @ find-wordlist if
    true
  else
    2drop false
  then
;

: call-package ( ... xt ihandle -- ??? )
  my-self >r 
  to my-self
  execute
  r> to my-self
;


: $call-method  ( ... method-str method-len ihandle -- ??? )
  dup >r >in.device-node @ find-method if
    r> call-package
  else
    -21 throw
  then
;

: $call-parent  ( ... method-str method-len -- ??? )
  my-parent $call-method
;


\ 
\ 5.3.4.1 Open/Close packages (part 2)
\ 

\ find-dev ( dev-str dev-len -- false | phandle true )
\ find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
\ 
\ These function works just like find-device but without
\ any side effects (or exceptions).
\ 
defer find-dev

: find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
  active-package >r active-package!
  find-dev
  r> active-package!
;

: find-package  ( name-str name-len -- false | phandle true )
\ Locate the support package named by name string.
\ If the package can be located, return its phandle and true; otherwise, 
\ return false.
\ Interpret the name in name string relative to the "packages" device node.
\ If there are multiple packages with the same name (within the "packages" 
\ node), return the phandle for the most recently created one.

  \ This does the full path resolution stuff (including
  \ alias expansion. If we don't want that, then we should just
  \ iterade the children of /packages.
  " /packages" find-dev 0= if 2drop false exit then
  find-rel-dev 0= if false exit then

  true
;

: open-package  ( arg-str arg-len phandle -- ihandle | 0 )
\ Open the package indicated by phandle.
\ Create an instance of the package identified by phandle, save in that 
\ instance the instance-argument specified by arg-string and invoke the 
\ package's open method.
\ Return the instance handle ihandle of the new instance, or 0 if the package
\ could not be opened. This could occur either because that package has no
\ open method, or because its open method returned false, indicating an error.
\ The parent instance of the new instance is the instance that invoked
\ open-package. The current instance is not changed.

  create-instance dup 0= if
    3drop 0 exit
  then
  >r

  \ clone arg-str
  strdup r@ >in.arguments 2!

  \ open the package
  " open" r@ ['] $call-method catch if 3drop false then
  if
    r>
  else
    r> destroy-instance false
  then
;


: $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 )
  \ Open the support package named by name string.
  find-package if
    open-package
  else 
    2drop false 
  then
;


: close-package ( ihandle -- )
\  Close the instance identified by ihandle by calling the package's close
\  method and then destroying the instance.
  dup " close" rot ['] $call-method catch if 3drop then
  destroy-instance
;

\ 
\ 5.3.4.3 Get local arguments
\ 

: my-address ( -- phys.lo ... )
  ?my-self >in.device-node @
  >dn.probe-addr
  my-#acells tuck /l* + swap 1- 0
  ?do
    /l - dup l@ swap
  loop
  drop
  ;
  
: my-space ( -- phys.hi )
  ?my-self >in.device-node @
  >dn.probe-addr @
  ;
  
: my-unit ( -- phys.lo ... phys.hi )
  ?my-self >in.my-unit
  my-#acells tuck /l* + swap 0 ?do
    /l - dup l@ swap
  loop
  drop
  ;

: my-args ( -- arg-str arg-len )
  ?my-self >in.arguments 2@
  ;

\ char is not included. If char is not found, then R-len is zero
: left-parse-string ( str len char -- R-str R-len L-str L-len )
  left-split
;

  
\ 
\ 5.3.4.4 Mapping tools
\ 

: map-low ( phys.lo ... size -- virt )
  my-space swap s" map-in" $call-parent
  ;

: free-virtual ( virt size -- )
  over s" address" get-my-property 0= if
    decode-int -rot 2drop = if
      s" address" delete-property
    then
  else
    drop
  then
  s" map-out" $call-parent
  ;


\ Deprecated functions (required for compatibility with older loaders)

variable package-stack-pos 0 package-stack-pos !
create package-stack 8 cells allot

: push-package    ( phandle -- )
  \ Throw an error if we attempt to push a full stack
  package-stack-pos @ 8 >= if
    ." cannot push-package onto full stack" cr
    -99 throw
  then
  active-package
  package-stack-pos @ /n * package-stack + !
  package-stack-pos @ 1 + package-stack-pos !
  active-package!
  ;

: pop-package    ( -- )
  \ Throw an error if we attempt to pop an empty stack
  package-stack-pos @ 0 = if
    ." cannot pop-package from empty stack" cr
    -99 throw
  then
  package-stack-pos @ 1 - package-stack-pos !
  package-stack-pos @ /n * package-stack + @
  active-package!
  ;