qemu/roms/openbios/forth/device/package.fs

   1 \ tag: Package access.
   2 \
   3 \ this code implements IEEE 1275-1994 ch. 5.3.4
   4 \
   5 \ Copyright (C) 2003 Stefan Reinauer
   6 \
   7 \ See the file "COPYING" for further information about
   8 \ the copyright and warranty status of this work.
   9 \
  10
  11 \ variable last-package 0 last-package !
  12 \ 0 value active-package
  13 : current-device active-package ;
  14
  15 \
  16 \ 5.3.4.1 Open/Close packages (part 1)
  17 \
  18
  19 \ 0 value my-self ( -- ihandle )
  20 : ?my-self
  21   my-self dup 0= abort" no current instance."
  22   ;
  23
  24 : my-parent ( -- ihandle )
  25   ?my-self >in.my-parent @
  26 ;
  27
  28 : ihandle>non-interposed-phandle ( ihandle -- phandle )
  29   begin dup >in.interposed @ while
  30     >in.my-parent @
  31   repeat
  32   >in.device-node @
  33 ;
  34
  35 : ihandle>phandle ( ihandle -- phandle )
  36   >in.device-node @
  37 ;
  38
  39
  40 \ next-property
  41 \ defined in property.c
  42
  43 : peer ( phandle -- phandle.sibling )
  44   ?dup if
  45     >dn.peer @
  46   else
  47     device-tree @
  48   then
  49 ;
  50
  51 : child ( phandle.parent -- phandle.child )
  52   \ Assume phandle == 0 indicates root node (not documented but similar
  53   \ behaviour to "peer"). Used by some versions of Solaris (e.g. 9).
  54   ?dup if else device-tree @ then
  55
  56   >dn.child @
  57 ;
  58
  59
  60 \
  61 \ 5.3.4.2 Call methods from other packages
  62 \
  63
  64 : find-method ( method-str method-len phandle -- false | xt true )
  65   \ should we search the private wordlist too? I don't think so...
  66   >dn.methods @ find-wordlist if
  67     true
  68   else
  69     2drop false
  70   then
  71 ;
  72
  73 : call-package ( ... xt ihandle -- ??? )
  74   my-self >r
  75   to my-self
  76   execute
  77   r> to my-self
  78 ;
  79
  80
  81 : $call-method  ( ... method-str method-len ihandle -- ??? )
  82   dup >r >in.device-node @ find-method if
  83     r> call-package
  84   else
  85     -21 throw
  86   then
  87 ;
  88
  89 : $call-parent  ( ... method-str method-len -- ??? )
  90   my-parent $call-method
  91 ;
  92
  93
  94 \
  95 \ 5.3.4.1 Open/Close packages (part 2)
  96 \
  97
  98 \ find-dev ( dev-str dev-len -- false | phandle true )
  99 \ find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
 100 \
 101 \ These function works just like find-device but without
 102 \ any side effects (or exceptions).
 103 \
 104 defer find-dev
 105
 106 : find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
 107   active-package >r active-package!
 108   find-dev
 109   r> active-package!
 110 ;
 111
 112 : find-package  ( name-str name-len -- false | phandle true )
 113 \ Locate the support package named by name string.
 114 \ If the package can be located, return its phandle and true; otherwise,
 115 \ return false.
 116 \ Interpret the name in name string relative to the "packages" device node.
 117 \ If there are multiple packages with the same name (within the "packages"
 118 \ node), return the phandle for the most recently created one.
 119
 120   \ This does the full path resolution stuff (including
 121   \ alias expansion. If we don't want that, then we should just
 122   \ iterade the children of /packages.
 123   " /packages" find-dev 0= if 2drop false exit then
 124   find-rel-dev 0= if false exit then
 125
 126   true
 127 ;
 128
 129 : open-package  ( arg-str arg-len phandle -- ihandle | 0 )
 130 \ Open the package indicated by phandle.
 131 \ Create an instance of the package identified by phandle, save in that
 132 \ instance the instance-argument specified by arg-string and invoke the
 133 \ package's open method.
 134 \ Return the instance handle ihandle of the new instance, or 0 if the package
 135 \ could not be opened. This could occur either because that package has no
 136 \ open method, or because its open method returned false, indicating an error.
 137 \ The parent instance of the new instance is the instance that invoked
 138 \ open-package. The current instance is not changed.
 139
 140   create-instance dup 0= if
 141     3drop 0 exit
 142   then
 143   >r
 144
 145   \ clone arg-str
 146   strdup r@ >in.arguments 2!
 147
 148   \ open the package
 149   " open" r@ ['] $call-method catch if 3drop false then
 150   if
 151     r>
 152   else
 153     r> destroy-instance false
 154   then
 155 ;
 156
 157
 158 : $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 )
 159   \ Open the support package named by name string.
 160   find-package if
 161     open-package
 162   else
 163     2drop false
 164   then
 165 ;
 166
 167
 168 : close-package ( ihandle -- )
 169 \  Close the instance identified by ihandle by calling the package's close
 170 \  method and then destroying the instance.
 171   dup " close" rot ['] $call-method catch if 3drop then
 172   destroy-instance
 173 ;
 174
 175 \
 176 \ 5.3.4.3 Get local arguments
 177 \
 178
 179 : my-address ( -- phys.lo ... )
 180   ?my-self >in.device-node @
 181   >dn.probe-addr
 182   my-#acells tuck /l* + swap 1- 0
 183   ?do
 184     /l - dup l@ swap
 185   loop
 186   drop
 187   ;
 188
 189 : my-space ( -- phys.hi )
 190   ?my-self >in.device-node @
 191   >dn.probe-addr @
 192   ;
 193
 194 : my-unit ( -- phys.lo ... phys.hi )
 195   ?my-self >in.my-unit
 196   my-#acells tuck /l* + swap 0 ?do
 197     /l - dup l@ swap
 198   loop
 199   drop
 200   ;
 201
 202 : my-args ( -- arg-str arg-len )
 203   ?my-self >in.arguments 2@
 204   ;
 205
 206 \ char is not included. If char is not found, then R-len is zero
 207 : left-parse-string ( str len char -- R-str R-len L-str L-len )
 208   left-split
 209 ;
 210
 211 \ parse ints "hi,...,lo" separated by comma
 212 : parse-ints ( str len num -- val.lo .. val.hi )
 213   -rot 2 pick -rot
 214   begin
 215     rot 1- -rot 2 pick 0>=
 216   while
 217     ( num n str len )
 218     2dup ascii , strchr ?dup if
 219       ( num n str len p )
 220       1+ -rot
 221       2 pick 2 pick -    ( num n p str len len1+1 )
 222       dup -rot -         ( num n p str len1+1 len2 )
 223       -rot 1-            ( num n p len2 str len1 )
 224     else
 225       0 0 2swap
 226     then
 227     $number if 0 then >r
 228   repeat
 229   3drop
 230
 231   ( num )
 232   begin 1- dup 0>= while r> swap repeat
 233   drop
 234 ;
 235
 236 : parse-2int ( str len -- val.lo val.hi )
 237   2 parse-ints
 238 ;
 239
 240
 241 \
 242 \ 5.3.4.4 Mapping tools
 243 \
 244
 245 : map-low ( phys.lo ... size -- virt )
 246   my-space swap s" map-in" $call-parent
 247   ;
 248
 249 : free-virtual ( virt size -- )
 250   over s" address" get-my-property 0= if
 251     decode-int -rot 2drop = if
 252       s" address" delete-property
 253     then
 254   else
 255     drop
 256   then
 257   s" map-out" $call-parent
 258   ;
 259
 260
 261 \ Deprecated functions (required for compatibility with older loaders)
 262
 263 variable package-stack-pos 0 package-stack-pos !
 264 create package-stack 8 cells allot
 265
 266 : push-package    ( phandle -- )
 267   \ Throw an error if we attempt to push a full stack
 268   package-stack-pos @ 8 >= if
 269     ." cannot push-package onto full stack" cr
 270     -99 throw
 271   then
 272   active-package
 273   package-stack-pos @ /n * package-stack + !
 274   package-stack-pos @ 1 + package-stack-pos !
 275   active-package!
 276   ;
 277
 278 : pop-package    ( -- )
 279   \ Throw an error if we attempt to pop an empty stack
 280   package-stack-pos @ 0 = if
 281     ." cannot pop-package from empty stack" cr
 282     -99 throw
 283   then
 284   package-stack-pos @ 1 - package-stack-pos !
 285   package-stack-pos @ /n * package-stack + @
 286   active-package!
 287   ;