forth/util/util.fs

\ tag: Utility functions
\ 
\ Utility functions
\ 
\ Copyright (C) 2003, 2004 Samuel Rydh
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 

\ -------------------------------------------------------------------------
\ package utils
\ -------------------------------------------------------------------------

( method-str method-len package-str package-len -- xt|0 )
: $find-package-method
  find-package 0= if 2drop false exit then
  find-method 0= if 0 then
;

\ like $call-parent but takes an xt
: call-parent ( ... xt -- ??? )
  my-parent call-package
;

: [active-package],
	['] (lit) , active-package ,
; immediate

\ -------------------------------------------------------------------------
\ word creation
\ -------------------------------------------------------------------------

: ?mmissing ( name len -- 1 name len | 0 )
  2dup active-package find-method
  if 3drop false else true then
;

\ install trivial open and close functions
: is-open ( -- )
  " open" ?mmissing if ['] true -rot is-xt-func then
  " close" ?mmissing if 0 -rot is-xt-func then
;

\ is-relay installs a relay function (a function that calls
\ a function with the same name but belonging to a different node).
\ The execution behaviour of xt should be ( -- ptr-to-ihandle ).
\ 
: is-relay ( xt ph name-str name-len -- )
  rot >r 2dup r> find-method 0= if
    \ function missing (not necessarily an error)
    3drop exit
  then

  -rot is-func-begin
  ( xt method-xt )
  ['] (lit) , ,                 \ ['] method
  , ['] @ ,                     \ xt @
  ['] call-package ,            \ call-package
  is-func-end
;

\ is-call-parent installs a function that calls a function with
\ the same name but on the parent node
: is-call-parent  ( str len )
  2dup is-func-begin
  ['] (") , dup , ", null-align
  ['] $call-parent ,
  is-func-end
;

\ -------------------------------------------------------------------------
\ install deblocker bindings
\ -------------------------------------------------------------------------

: (open-deblocker) ( varaddr -- )
  " deblocker" find-package if
    0 0 rot open-package
  else 0 then
  swap !
;
  
: is-deblocker ( -- )
  " deblocker" find-package 0= if exit then >r
  " deblocker" is-ivariable

  \ create open-deblocker
  " open-deblocker" is-func-begin
  dup , ['] (open-deblocker) ,
  is-func-end

  \ create close-deblocker
  " close-deblocker" is-func-begin
  dup , ['] @ , ['] close-package ,
  is-func-end
  
  ( save-ph deblk-xt R: deblocker-ph  )
  r>
  2dup " read" is-relay
  2dup " seek" is-relay
  2dup " write" is-relay
  2dup " tell" is-relay
  2drop
;

\ -------------------------------------------------------------------------
\ Miscellaneous
\ -------------------------------------------------------------------------

[IFDEF] CONFIG_SPARC32 1 [ELSE] [IFDEF] CONFIG_SPARC64 1 [ELSE] 0 [THEN] [THEN] [IF]

\ Return the address of a named constant or value
: addr  ( <word> -- addr )
  parse-word $find if
    cell +
  then
;

[THEN]