120 lines
3 KiB
Forth
120 lines
3 KiB
Forth
|
\ 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]
|