forth/system/ciface.fs

0 value ciface-ph

dev /openprom/
new-device
" client-services" device-name

active-package to ciface-ph

\ -------------------------------------------------------------
\ private stuff
\ -------------------------------------------------------------

private

variable callback-function

: ?phandle ( phandle -- phandle )
  dup 0= if ." NULL phandle" -1 throw then
;
: ?ihandle ( ihandle -- ihandle )
  dup 0= if ." NULL ihandle" -2 throw then
;

\ copy and null terminate return string
: ci-strcpy ( buf buflen str len -- len )
  >r -rot dup
  ( str buf buflen buflen R: len )
  r@ min swap
  ( str buf n buflen R: len )
  over > if
    ( str buf n )
    2dup + 0 swap c!
  then
  move r>
;

0 value memory-ih
0 value mmu-ih

:noname ( -- )
  " /chosen" find-device

  " mmu" active-package get-package-property 0= if
    decode-int nip nip to mmu-ih
  then

  " memory" active-package get-package-property 0= if
    decode-int nip nip to memory-ih
  then
  device-end
; SYSTEM-initializer

: safetype
  ." <" dup cstrlen dup 20 < if type else 2drop ." BAD" then ." >"
;

: phandle-exists?  ( phandle -- found? )
  false swap 0
  begin iterate-tree ?dup while
    ( found? find-ph current-ph )
    over over = if
      rot drop true -rot
    then
  repeat
  drop
;

\ -------------------------------------------------------------
\ public interface
\ -------------------------------------------------------------

external

\ -------------------------------------------------------------
\ 6.3.2.1 Client interface
\ -------------------------------------------------------------

\ returns -1 if missing
: test ( name -- 0|-1 )
  dup cstrlen ciface-ph find-method
  if drop 0 else -1 then
;

\ -------------------------------------------------------------
\ 6.3.2.2 Device tree
\ -------------------------------------------------------------

: peer peer ;
: child child ;
: parent parent ;

: getproplen ( name phandle -- len|-1 )
  over cstrlen swap
  ?phandle get-package-property
  if -1 else nip then
;

: getprop ( buflen buf name phandle -- size|-1 )
  \ detect phandle == -1 
  dup -1 = if
    2drop 2drop -1 exit
  then

  \ return -1 if phandle is 0 (MacOS actually does this)
  ?dup 0= if drop 2drop -1 exit then
 
  over cstrlen swap
  ?phandle get-package-property if 2drop -1 exit then
  ( buflen buf prop proplen )
  >r swap rot r>
  ( prop buf buflen proplen )
  dup >r min move r>
;

\ 1 OK, 0 no more prop, -1 prev invalid
: nextprop ( buf prev phandle -- 1|0|-1 )
  >r
  dup 0= if 0 else dup cstrlen then

  ( buf prev prev_len )
  
  \ verify that prev exists (overkill...)
  dup if
    2dup r@ get-package-property if
      r> 2drop drop
      0 swap c!
      -1 exit
    else
      2drop
    then
  then
  
  ( buf prev prev_len )

  r> next-property if
    ( buf name name_len )
    dup 1+ -rot ci-strcpy drop 1
  else
    ( buf )
    0 swap c!
    0
  then
;

: setprop ( len buf name phandle -- size )
  3 pick >r
  >r >r swap encode-bytes  \ ( prop-addr prop-len  R: phandle name ) 
  r> dup cstrlen r>
  (property)
  r>
;

: finddevice ( dev_spec -- phandle|-1 )
  dup cstrlen
  \ ." FIND-DEVICE " 2dup type
  find-dev 0= if -1 then
  \ ." -- " dup . cr
;

: instance-to-package ( ihandle -- phandle )
  ?ihandle instance-to-package
;

: package-to-path ( buflen buf phandle -- length )
  \ XXX improve error checking
  dup 0= if 3drop -1 exit then
  >r swap r>
  get-package-path
  ( buf buflen str len )
  ci-strcpy
;

: canon ( buflen buf dev_specifier -- len )
  dup cstrlen find-dev if
    ( buflen buf phandle )
    package-to-path
  else
    2drop -1
  then
;

: instance-to-path ( buflen buf ihandle -- length )
  \ XXX improve error checking
  dup 0= if 3drop -1 exit then
  >r swap r>
  get-instance-path
  \ ." INSTANCE: " 2dup type cr dup .
  ( buf buflen str len )
  ci-strcpy
;

: instance-to-interposed-path ( buflen buf ihandle -- length )
  \ XXX improve error checking
  dup 0= if 3drop -1 exit then
  >r swap r>
  get-instance-interposed-path
  ( buf buflen str len )
  ci-strcpy
;

: call-method ( ihandle method -- xxxx catch-result )
  dup 0= if ." call of null method" -1 exit then
  dup >r
  dup cstrlen
  \ ." call-method " 2dup type cr
  rot ?ihandle ['] $call-method catch dup if
    \ not necessary an error but very useful for debugging...
    ." call-method " r@ dup cstrlen type ." : exception " dup . cr
  then
  r> drop
;


\ -------------------------------------------------------------
\ 6.3.2.3 Device I/O
\ -------------------------------------------------------------

: open ( dev_spec -- ihandle|0 )
  dup cstrlen open-dev
;

: close ( ihandle -- )
  close-dev
;

: read ( len addr ihandle -- actual )
  >r swap r>
  dup ihandle>phandle " read" rot find-method
  if swap call-package else 3drop -1 then
;

: write ( len addr ihandle -- actual )
  >r swap r>
  dup ihandle>phandle " write" rot find-method
  if swap call-package else 3drop -1 then
;

: seek ( pos_lo pos_hi ihandle -- status )
  dup ihandle>phandle " seek" rot find-method
  if swap call-package else 3drop -1 then
;


\ -------------------------------------------------------------
\ 6.3.2.4 Memory
\ -------------------------------------------------------------

: claim ( align size virt -- baseaddr|-1 )
  -rot swap
  ciface-ph " cif-claim" rot find-method
  if execute else 3drop -1 then
;

: release ( size virt -- )
  swap
  ciface-ph " cif-release" rot find-method
  if execute else 2drop -1 then
;

\ -------------------------------------------------------------
\ 6.3.2.5 Control transfer
\ -------------------------------------------------------------

: boot ( bootspec -- )
  ." BOOT"
;

: enter ( -- )
  ." ENTER"
;

\ exit ( -- ) is defined later (clashes with builtin exit)

: chain ( virt size entry args len -- )
  ." CHAIN"
;

\ -------------------------------------------------------------
\ 6.3.2.6 User interface
\ -------------------------------------------------------------

: interpret ( xxx cmdstring -- ??? catch-reult )
  dup cstrlen
  \ ." INTERPRETE: --- " 2dup type
  ['] evaluate catch dup if
    \ this is not necessary an error...
    ." interpret: exception " dup . ." caught" cr

    \ Force back to interpret state on error, otherwise the next call to
    \ interpret gets confused if the error occurred in compile mode
    0 state !
  then
  \ ." --- " cr
;

: set-callback ( newfunc -- oldfunc )
  callback-function @
  swap
  callback-function !
;

\ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ;


\ -------------------------------------------------------------
\ 6.3.2.7 Time
\ -------------------------------------------------------------

: milliseconds ( -- ms )
  get-msecs
;

\ -------------------------------------------------------------
\ arch?
\ -------------------------------------------------------------

: start-cpu ( xxx xxx xxx --- )
  ." Start CPU unimplemented" cr
  3drop
;

\ -------------------------------------------------------------
\ special
\ -------------------------------------------------------------

: exit ( -- )
  ." EXIT"
  
  \ Execute (exit) hook if one exists
  s" (exit)" $find if
    execute
  else
    2drop
  then
  
  outer-interpreter
;

: test-method    ( cstring-method phandle -- missing? )
  swap dup cstrlen rot
  
  \ Check for incorrect phandle
  dup phandle-exists? false = if
    -1 throw
  then
  
  find-method 0= if -1 else drop 0 then
;

[IFDEF] CONFIG_SPARC64

: SUNW,power-off ( -- )
  power-off
;

[THEN]

finish-device
device-end


\ -------------------------------------------------------------
\ entry point
\ -------------------------------------------------------------

: client-iface ( [args] name len -- [args] -1 | [rets] 0 )
  ciface-ph find-method 0= if -1 exit then
  catch ?dup if
    cr ." Unexpected client interface exception: " . -2 cr exit
  then
  0
;

: client-call-iface ( [args] name len -- [args] -1 | [rets] 0 )
  ciface-ph find-method 0= if -1 exit then
  execute
  0
;