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