![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to package.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device|
Return to package.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / device |
1.1 ! root 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: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.