Return to util.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / util

Annotation of qemu/roms/openbios/forth/util/util.fs, revision 1.1.1.1

1.1       root        1: \ tag: Utility functions
                      2: \ 
                      3: \ Utility functions
                      4: \ 
                      5: \ Copyright (C) 2003, 2004 Samuel Rydh
                      6: \ 
                      7: \ See the file "COPYING" for further information about
                      8: \ the copyright and warranty status of this work.
                      9: \ 
                     10: 
                     11: \ -------------------------------------------------------------------------
                     12: \ package utils
                     13: \ -------------------------------------------------------------------------
                     14: 
                     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
                     19: ;
                     20: 
                     21: \ like $call-parent but takes an xt
                     22: : call-parent ( ... xt -- ??? )
                     23:   my-parent call-package
                     24: ;
                     25: 
                     26: : [active-package],
                     27:        ['] (lit) , active-package ,
                     28: ; immediate
                     29: 
                     30: \ -------------------------------------------------------------------------
                     31: \ word creation
                     32: \ -------------------------------------------------------------------------
                     33: 
                     34: : ?mmissing ( name len -- 1 name len | 0 )
                     35:   2dup active-package find-method
                     36:   if 3drop false else true then
                     37: ;
                     38: 
                     39: \ install trivial open and close functions
                     40: : is-open ( -- )
                     41:   " open" ?mmissing if ['] true -rot is-xt-func then
                     42:   " close" ?mmissing if 0 -rot is-xt-func then
                     43: ;
                     44: 
                     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 ).
                     48: \ 
                     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)
                     52:     3drop exit
                     53:   then
                     54: 
                     55:   -rot is-func-begin
                     56:   ( xt method-xt )
                     57:   ['] (lit) , ,                 \ ['] method
                     58:   , ['] @ ,                     \ xt @
                     59:   ['] call-package ,            \ call-package
                     60:   is-func-end
                     61: ;
                     62: 
                     63: \ -------------------------------------------------------------------------
                     64: \ install deblocker bindings
                     65: \ -------------------------------------------------------------------------
                     66: 
                     67: : (open-deblocker) ( varaddr -- )
                     68:   " deblocker" find-package if
                     69:     0 0 rot open-package
                     70:   else 0 then
                     71:   swap !
                     72: ;
                     73:   
                     74: : is-deblocker ( -- )
                     75:   " deblocker" find-package 0= if exit then >r
                     76:   " deblocker" is-ivariable
                     77: 
                     78:   \ create open-deblocker
                     79:   " open-deblocker" is-func-begin
                     80:   dup , ['] (open-deblocker) ,
                     81:   is-func-end
                     82: 
                     83:   \ create close-deblocker
                     84:   " close-deblocker" is-func-begin
                     85:   dup , ['] @ , ['] close-package ,
                     86:   is-func-end
                     87:   
                     88:   ( save-ph deblk-xt R: deblocker-ph  )
                     89:   r>
                     90:   2dup " read" is-relay
                     91:   2dup " seek" is-relay
                     92:   2dup " write" is-relay
                     93:   2dup " tell" is-relay
                     94:   2drop
                     95: ;

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.