1 \ tag: Utility functions
5 \ Copyright (C) 2003, 2004 Samuel Rydh
7 \ See the file "COPYING" for further information about
8 \ the copyright and warranty status of this work.
11 \ -------------------------------------------------------------------------
13 \ -------------------------------------------------------------------------
15 ( method-str method-len package-str package-len -- xt|0 )
16 : $find-package-method
17 find-package 0= if 2drop false exit then
18 find-method 0= if 0 then
21 \ like $call-parent but takes an xt
22 : call-parent ( ... xt -- ??? )
23 my-parent call-package
27 ['] (lit) , active-package ,
30 \ -------------------------------------------------------------------------
32 \ -------------------------------------------------------------------------
34 : ?mmissing ( name len -- 1 name len | 0 )
35 2dup active-package find-method
36 if 3drop false else true then
39 \ install trivial open and close functions
41 " open" ?mmissing if ['] true -rot is-xt-func then
42 " close" ?mmissing if 0 -rot is-xt-func then
45 \ is-relay installs a relay function (a function that calls
46 \ a function with the same name but belonging to a different node).
47 \ The execution behaviour of xt should be ( -- ptr-to-ihandle ).
49 : is-relay ( xt ph name-str name-len -- )
50 rot >r 2dup r> find-method 0= if
51 \ function missing (not necessarily an error)
57 ['] (lit) , , \ ['] method
59 ['] call-package , \ call-package
63 \ -------------------------------------------------------------------------
64 \ install deblocker bindings
65 \ -------------------------------------------------------------------------
67 : (open-deblocker) ( varaddr -- )
68 " deblocker" find-package if
75 " deblocker" find-package 0= if exit then >r
76 " deblocker" is-ivariable
78 \ create open-deblocker
79 " open-deblocker" is-func-begin
80 dup , ['] (open-deblocker) ,
83 \ create close-deblocker
84 " close-deblocker" is-func-begin
85 dup , ['] @ , ['] close-package ,
88 ( save-ph deblk-xt R: deblocker-ph )
92 2dup " write" is-relay