qemu/roms/openbios/forth/system/ciface.fs

   1
   2 0 value ciface-ph
   3
   4 dev /openprom/
   5 new-device
   6 " client-services" device-name
   7
   8 active-package to ciface-ph
   9
  10 \ -------------------------------------------------------------
  11 \ private stuff
  12 \ -------------------------------------------------------------
  13
  14 private
  15
  16 variable callback-function
  17
  18 : ?phandle ( phandle -- phandle )
  19   dup 0= if ." NULL phandle" -1 throw then
  20 ;
  21 : ?ihandle ( ihandle -- ihandle )
  22   dup 0= if ." NULL ihandle" -2 throw then
  23 ;
  24
  25 \ copy and null terminate return string
  26 : ci-strcpy ( buf buflen str len -- len )
  27   >r -rot dup
  28   ( str buf buflen buflen R: len )
  29   r@ min swap
  30   ( str buf n buflen R: len )
  31   over > if
  32     ( str buf n )
  33     2dup + 0 swap c!
  34   then
  35   move r>
  36 ;
  37
  38 0 value memory-ih
  39 0 value mmu-ih
  40
  41 :noname ( -- )
  42   " /chosen" find-device
  43
  44   " mmu" active-package get-package-property 0= if
  45     decode-int nip nip to mmu-ih
  46   then
  47
  48   " memory" active-package get-package-property 0= if
  49     decode-int nip nip to memory-ih
  50   then
  51   device-end
  52 ; SYSTEM-initializer
  53
  54 : safetype
  55   ." <" dup cstrlen dup 20 < if type else 2drop ." BAD" then ." >"
  56 ;
  57
  58 : phandle-exists?  ( phandle -- found? )
  59   false swap 0
  60   begin iterate-tree ?dup while
  61     ( found? find-ph current-ph )
  62     over over = if
  63       rot drop true -rot
  64     then
  65   repeat
  66   drop
  67 ;
  68
  69 \ -------------------------------------------------------------
  70 \ public interface
  71 \ -------------------------------------------------------------
  72
  73 external
  74
  75 \ -------------------------------------------------------------
  76 \ 6.3.2.1 Client interface
  77 \ -------------------------------------------------------------
  78
  79 \ returns -1 if missing
  80 : test ( name -- 0|-1 )
  81   dup cstrlen ciface-ph find-method
  82   if drop 0 else -1 then
  83 ;
  84
  85 \ -------------------------------------------------------------
  86 \ 6.3.2.2 Device tree
  87 \ -------------------------------------------------------------
  88
  89 : peer peer ;
  90 : child child ;
  91 : parent parent ;
  92
  93 : getproplen ( name phandle -- len|-1 )
  94   over cstrlen swap
  95   ?phandle get-package-property
  96   if -1 else nip then
  97 ;
  98
  99 : getprop ( buflen buf name phandle -- size|-1 )
 100   \ detect phandle == -1
 101   dup -1 = if
 102     2drop 2drop -1 exit
 103   then
 104
 105   \ return -1 if phandle is 0 (MacOS actually does this)
 106   ?dup 0= if drop 2drop -1 exit then
 107
 108   over cstrlen swap
 109   ?phandle get-package-property if 2drop -1 exit then
 110   ( buflen buf prop proplen )
 111   >r swap rot r>
 112   ( prop buf buflen proplen )
 113   dup >r min move r>
 114 ;
 115
 116 \ 1 OK, 0 no more prop, -1 prev invalid
 117 : nextprop ( buf prev phandle -- 1|0|-1 )
 118   >r
 119   dup 0= if 0 else dup cstrlen then
 120
 121   ( buf prev prev_len )
 122
 123   \ verify that prev exists (overkill...)
 124   dup if
 125     2dup r@ get-package-property if
 126       r> 2drop drop
 127       0 swap c!
 128       -1 exit
 129     else
 130       2drop
 131     then
 132   then
 133
 134   ( buf prev prev_len )
 135
 136   r> next-property if
 137     ( buf name name_len )
 138     dup 1+ -rot ci-strcpy drop 1
 139   else
 140     ( buf )
 141     0 swap c!
 142     0
 143   then
 144 ;
 145
 146 : setprop ( len buf name phandle -- size )
 147   3 pick >r
 148   >r >r swap encode-bytes  \ ( prop-addr prop-len  R: phandle name )
 149   r> dup cstrlen r>
 150   (property)
 151   r>
 152 ;
 153
 154 : finddevice ( dev_spec -- phandle|-1 )
 155   dup cstrlen
 156   \ ." FIND-DEVICE " 2dup type
 157   find-dev 0= if -1 then
 158   \ ." -- " dup . cr
 159 ;
 160
 161 : instance-to-package ( ihandle -- phandle )
 162   ?ihandle ihandle>phandle
 163 ;
 164
 165 : package-to-path ( buflen buf phandle -- length )
 166   \ XXX improve error checking
 167   dup 0= if 3drop -1 exit then
 168   >r swap r>
 169   get-package-path
 170   ( buf buflen str len )
 171   ci-strcpy
 172 ;
 173
 174 : canon ( buflen buf dev_specifier -- len )
 175   dup cstrlen find-dev if
 176     ( buflen buf phandle )
 177     package-to-path
 178   else
 179     2drop -1
 180   then
 181 ;
 182
 183 : instance-to-path ( buflen buf ihandle -- length )
 184   \ XXX improve error checking
 185   dup 0= if 3drop -1 exit then
 186   >r swap r>
 187   get-instance-path
 188   \ ." INSTANCE: " 2dup type cr dup .
 189   ( buf buflen str len )
 190   ci-strcpy
 191 ;
 192
 193 : instance-to-interposed-path ( buflen buf ihandle -- length )
 194   \ XXX improve error checking
 195   dup 0= if 3drop -1 exit then
 196   >r swap r>
 197   get-instance-interposed-path
 198   ( buf buflen str len )
 199   ci-strcpy
 200 ;
 201
 202 : call-method ( ihandle method -- xxxx catch-result )
 203   dup 0= if ." call of null method" -1 exit then
 204   dup >r
 205   dup cstrlen
 206   \ ." call-method " 2dup type cr
 207   rot ?ihandle ['] $call-method catch dup if
 208     \ not necessary an error but very useful for debugging...
 209     ." call-method " r@ dup cstrlen type ." : exception " dup . cr
 210   then
 211   r> drop
 212 ;
 213
 214
 215 \ -------------------------------------------------------------
 216 \ 6.3.2.3 Device I/O
 217 \ -------------------------------------------------------------
 218
 219 : open ( dev_spec -- ihandle|0 )
 220   dup cstrlen open-dev
 221 ;
 222
 223 : close ( ihandle -- )
 224   close-dev
 225 ;
 226
 227 : read ( len addr ihandle -- actual )
 228   >r swap r>
 229   dup ihandle>phandle " read" rot find-method
 230   if swap call-package else 3drop -1 then
 231 ;
 232
 233 : write ( len addr ihandle -- actual )
 234   >r swap r>
 235   dup ihandle>phandle " write" rot find-method
 236   if swap call-package else 3drop -1 then
 237 ;
 238
 239 : seek ( pos_lo pos_hi ihandle -- status )
 240   dup ihandle>phandle " seek" rot find-method
 241   if swap call-package else 3drop -1 then
 242 ;
 243
 244
 245 \ -------------------------------------------------------------
 246 \ 6.3.2.4 Memory
 247 \ -------------------------------------------------------------
 248
 249 : claim ( align size virt -- baseaddr|-1 )
 250   -rot swap
 251   ciface-ph " cif-claim" rot find-method
 252   if execute else 3drop -1 then
 253 ;
 254
 255 : release ( size virt -- )
 256   swap
 257   ciface-ph " cif-release" rot find-method
 258   if execute else 2drop -1 then
 259 ;
 260
 261 \ -------------------------------------------------------------
 262 \ 6.3.2.5 Control transfer
 263 \ -------------------------------------------------------------
 264
 265 : boot ( bootspec -- )
 266   ." BOOT"
 267 ;
 268
 269 : enter ( -- )
 270   ." ENTER"
 271 ;
 272
 273 \ exit ( -- ) is defined later (clashes with builtin exit)
 274
 275 : chain ( virt size entry args len -- )
 276   ." CHAIN"
 277 ;
 278
 279 \ -------------------------------------------------------------
 280 \ 6.3.2.6 User interface
 281 \ -------------------------------------------------------------
 282
 283 : interpret ( xxx cmdstring -- ??? catch-reult )
 284   dup cstrlen
 285   \ ." INTERPRETE: --- " 2dup type
 286   ['] evaluate catch dup if
 287     \ this is not necessary an error...
 288     ." interpret: exception " dup . ." caught" cr
 289
 290     \ Force back to interpret state on error, otherwise the next call to
 291     \ interpret gets confused if the error occurred in compile mode
 292     0 state !
 293   then
 294   \ ." --- " cr
 295 ;
 296
 297 : set-callback ( newfunc -- oldfunc )
 298   callback-function @
 299   swap
 300   callback-function !
 301 ;
 302
 303 \ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ;
 304
 305
 306 \ -------------------------------------------------------------
 307 \ 6.3.2.7 Time
 308 \ -------------------------------------------------------------
 309
 310 : milliseconds ( -- ms )
 311   get-msecs
 312 ;
 313
 314 \ -------------------------------------------------------------
 315 \ arch?
 316 \ -------------------------------------------------------------
 317
 318 : start-cpu ( xxx xxx xxx --- )
 319   ." Start CPU unimplemented" cr
 320   3drop
 321 ;
 322
 323 \ -------------------------------------------------------------
 324 \ special
 325 \ -------------------------------------------------------------
 326
 327 : exit ( -- )
 328   ." EXIT"
 329   outer-interpreter
 330 ;
 331
 332 : test-method    ( cstring-method phandle -- missing? )
 333   swap dup cstrlen rot
 334
 335   \ Check for incorrect phandle
 336   dup phandle-exists? false = if
 337     -1 throw
 338   then
 339
 340   find-method 0= if -1 else drop 0 then
 341 ;
 342
 343 finish-device
 344 device-end
 345
 346
 347 \ -------------------------------------------------------------
 348 \ entry point
 349 \ -------------------------------------------------------------
 350
 351 : client-iface ( [args] name len -- [args] -1 | [rets] 0 )
 352   ciface-ph find-method 0= if -1 exit then
 353   catch ?dup if
 354     cr ." Unexpected client interface exception: " . -2 cr exit
 355   then
 356   0
 357 ;
 358
 359 : client-call-iface ( [args] name len -- [args] -1 | [rets] 0 )
 360   ciface-ph find-method 0= if -1 exit then
 361   execute
 362   0
 363 ;