diff options
Diffstat (limited to 'qemu/roms/openbios/forth/device/package.fs')
| -rw-r--r-- | qemu/roms/openbios/forth/device/package.fs | 287 |
1 files changed, 287 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/device/package.fs b/qemu/roms/openbios/forth/device/package.fs new file mode 100644 index 000000000..d5b52c3eb --- /dev/null +++ b/qemu/roms/openbios/forth/device/package.fs @@ -0,0 +1,287 @@ +\ 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 @ +; + +: 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 +; + +\ parse ints "hi,...,lo" separated by comma +: parse-ints ( str len num -- val.lo .. val.hi ) + -rot 2 pick -rot + begin + rot 1- -rot 2 pick 0>= + while + ( num n str len ) + 2dup ascii , strchr ?dup if + ( num n str len p ) + 1+ -rot + 2 pick 2 pick - ( num n p str len len1+1 ) + dup -rot - ( num n p str len1+1 len2 ) + -rot 1- ( num n p len2 str len1 ) + else + 0 0 2swap + then + $number if 0 then >r + repeat + 3drop + + ( num ) + begin 1- dup 0>= while r> swap repeat + drop +; + +: parse-2int ( str len -- val.lo val.hi ) + 2 parse-ints +; + + +\ +\ 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! + ; |