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     ! 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.