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