qemu/roms/openbios/forth/util/util.fs

   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 ;